From 7c1441df36d4a2523461fd45d49a3927fe561820 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 18:33:10 +0800 Subject: [PATCH 01/17] Embed CoLM2024 as an MPAS land surface option CoLM2024 now builds inside the atmosphere core like Noah-MP, uses MPAS-owned ranks and cell subsets, keeps patch/PFT state internal to CoLM, and exposes fluxes through MPAS fields/streams. Constraint: CoLM2024 must run without a separate master/io/worker allocation or external -lcolm library. Rejected: standalone CoLM USEMPI-off adapter | it collapses parallel land/routing behavior and risks global duplicated state. Rejected: CaMa and sediment routing in embedded mode | not part of the requested GridRiverLakeFlow path. Confidence: medium Scope-risk: broad Directive: Keep MPAS cell == CoLM element; do not reintroduce global mesh gathers or CoLM-owned MPI roles. Tested: make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; cmake --install build-cmake-colm-debug; git diff --cached --check; otool/nm checks for external CoLM/CaMa/CMF symbols. Not-tested: full runtime case with real MPAS+CoLM input datasets. --- .gitignore | 1 + CMakeLists.txt | 9 +- Makefile | 9 +- cmake/Functions/MPAS_Functions.cmake | 19 +- src/core_atmosphere/CMakeLists.txt | 164 + src/core_atmosphere/Makefile | 3 + src/core_atmosphere/Registry.xml | 96 +- src/core_atmosphere/physics/Makefile | 32 +- .../physics/mpas_atmphys_control.F | 24 +- .../physics/mpas_atmphys_driver.F | 13 +- .../mpas_atmphys_driver_lsm_colm2024.F | 357 ++ .../mpas_atmphys_driver_radiation_sw.F | 56 +- .../physics/mpas_atmphys_finalize.F | 7 +- .../physics/mpas_atmphys_init.F | 9 +- .../physics/mpas_atmphys_packages.F | 13 +- .../physics/mpas_atmphys_sfc_diagnostics.F | 6 +- .../physics/physics_colm2024/.gitignore | 13 + .../physics/physics_colm2024/Makefile | 281 + .../physics/physics_colm2024/README.md | 3 + .../physics/physics_colm2024/ReadMeEvaluation | 1 + .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 1057 ++++ .../physics_colm2024/include/Makeoptions | 9 + .../physics/physics_colm2024/include/define.h | 123 + .../main/BGC/MOD_BGC_CNAnnualUpdate.F90 | 81 + .../main/BGC/MOD_BGC_CNBalanceCheck.F90 | 273 + .../main/BGC/MOD_BGC_CNCStateUpdate1.F90 | 493 ++ .../main/BGC/MOD_BGC_CNCStateUpdate2.F90 | 176 + .../main/BGC/MOD_BGC_CNCStateUpdate3.F90 | 194 + .../main/BGC/MOD_BGC_CNNStateUpdate1.F90 | 410 ++ .../main/BGC/MOD_BGC_CNNStateUpdate2.F90 | 172 + .../main/BGC/MOD_BGC_CNNStateUpdate3.F90 | 222 + .../main/BGC/MOD_BGC_CNSASU.F90 | 1074 ++++ .../main/BGC/MOD_BGC_CNSummary.F90 | 919 +++ .../main/BGC/MOD_BGC_CNZeroFluxes.F90 | 838 +++ .../main/BGC/MOD_BGC_Daylength.F90 | 90 + .../MOD_BGC_Soil_BiogeochemCompetition.F90 | 469 ++ .../BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 | 122 + ...OD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 | 122 + .../MOD_BGC_Soil_BiogeochemLittVertTransp.F90 | 333 ++ .../BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 | 167 + .../MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 | 244 + .../MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 | 186 + .../BGC/MOD_BGC_Soil_BiogeochemPotential.F90 | 150 + ...MOD_BGC_Soil_BiogeochemVerticalProfile.F90 | 237 + .../main/BGC/MOD_BGC_Vars_1DFluxes.F90 | 740 +++ .../main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 | 1313 +++++ .../main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 | 2696 +++++++++ .../main/BGC/MOD_BGC_Vars_TimeInvariants.F90 | 512 ++ .../main/BGC/MOD_BGC_Vars_TimeVariables.F90 | 1543 +++++ .../main/BGC/MOD_BGC_Veg_CNFireBase.F90 | 421 ++ .../main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 | 320 ++ .../main/BGC/MOD_BGC_Veg_CNGResp.F90 | 139 + .../main/BGC/MOD_BGC_Veg_CNGapMortality.F90 | 274 + .../main/BGC/MOD_BGC_Veg_CNMResp.F90 | 119 + .../main/BGC/MOD_BGC_Veg_CNNDynamics.F90 | 193 + .../main/BGC/MOD_BGC_Veg_CNPhenology.F90 | 1615 ++++++ .../BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 | 159 + .../BGC/MOD_BGC_Veg_NutrientCompetition.F90 | 539 ++ .../main/BGC/MOD_BGC_driver.F90 | 166 + .../physics_colm2024/main/CoLMDRIVER.F90 | 371 ++ .../physics_colm2024/main/CoLMMAIN.F90 | 1739 ++++++ .../physics_colm2024/main/DA/MOD_DA_Const.F90 | 143 + .../physics_colm2024/main/DA/MOD_DA_EnKF.F90 | 137 + .../main/DA/MOD_DA_Ensemble.F90 | 267 + .../physics_colm2024/main/DA/MOD_DA_Main.F90 | 396 ++ .../physics_colm2024/main/DA/MOD_DA_RTM.F90 | 1431 +++++ .../physics_colm2024/main/DA/MOD_DA_SM.F90 | 1787 ++++++ .../physics_colm2024/main/DA/MOD_DA_TWS.F90 | 440 ++ .../main/DA/MOD_DA_Vars_1DFluxes.F90 | 92 + .../main/DA/MOD_DA_Vars_TimeVariables.F90 | 716 +++ .../main/HYDRO/MOD_Catch_BasinNetwork.F90 | 494 ++ .../main/HYDRO/MOD_Catch_HillslopeFlow.F90 | 310 + .../main/HYDRO/MOD_Catch_HillslopeNetwork.F90 | 381 ++ .../main/HYDRO/MOD_Catch_Hist.F90 | 490 ++ .../main/HYDRO/MOD_Catch_LateralFlow.F90 | 496 ++ .../main/HYDRO/MOD_Catch_Reservoir.F90 | 497 ++ .../main/HYDRO/MOD_Catch_RiverLakeFlow.F90 | 596 ++ .../main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 | 1145 ++++ .../main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 | 823 +++ .../main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 | 115 + .../HYDRO/MOD_Catch_Vars_TimeVariables.F90 | 178 + .../main/HYDRO/MOD_Catch_WriteParameters.F90 | 230 + .../main/HYDRO/MOD_ElementNeighbour.F90 | 711 +++ .../main/HYDRO/MOD_Grid_Reservoir.F90 | 341 ++ .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 764 +++ .../main/HYDRO/MOD_Grid_RiverLakeHist.F90 | 756 +++ .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 2105 +++++++ .../main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 | 287 + .../main/HYDRO/MOD_Hydro_SoilFunction.F90 | 173 + .../main/HYDRO/MOD_Hydro_SoilWater.F90 | 3620 ++++++++++++ .../main/HYDRO/MOD_Hydro_VIC.F90 | 588 ++ .../main/HYDRO/MOD_Hydro_VIC_Variables.F90 | 298 + .../main/HYDRO/MOD_Vector_ReadWrite.F90 | 291 + .../main/LULCC/MOD_Lulcc_Driver.F90 | 162 + .../main/LULCC/MOD_Lulcc_Initialize.F90 | 138 + .../LULCC/MOD_Lulcc_MassEnergyConserve.F90 | 1165 ++++ .../LULCC/MOD_Lulcc_TransferTraceReadin.F90 | 136 + .../LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 | 201 + .../LULCC/MOD_Lulcc_Vars_TimeVariables.F90 | 1206 ++++ .../main/MOD_3DCanopyRadiation.F90 | 1455 +++++ .../physics_colm2024/main/MOD_Aerosol.F90 | 434 ++ .../physics_colm2024/main/MOD_Albedo.F90 | 2079 +++++++ .../main/MOD_Albedo_HiRes.F90 | 3374 +++++++++++ .../main/MOD_AssimStomataConductance.F90 | 844 +++ .../main/MOD_CanopyLayerProfile.F90 | 730 +++ .../main/MOD_CheckEquilibrium.F90 | 685 +++ .../physics_colm2024/main/MOD_Const_LC.F90 | 878 +++ .../physics_colm2024/main/MOD_Const_PFT.F90 | 1817 ++++++ .../main/MOD_Const_Physical.F90 | 30 + .../physics_colm2024/main/MOD_CropReadin.F90 | 377 ++ .../physics_colm2024/main/MOD_Eroot.F90 | 156 + .../physics_colm2024/main/MOD_FireData.F90 | 139 + .../physics_colm2024/main/MOD_Forcing.F90 | 1810 ++++++ .../main/MOD_ForcingDownscaling.F90 | 1049 ++++ .../main/MOD_FrictionVelocity.F90 | 572 ++ .../physics_colm2024/main/MOD_Glacier.F90 | 1142 ++++ .../main/MOD_GroundFluxes.F90 | 264 + .../main/MOD_GroundTemperature.F90 | 447 ++ .../main/MOD_HighRes_Parameters.F90 | 550 ++ .../physics_colm2024/main/MOD_Hist.F90 | 5057 +++++++++++++++++ .../physics_colm2024/main/MOD_HistGridded.F90 | 1074 ++++ .../physics_colm2024/main/MOD_HistSingle.F90 | 370 ++ .../physics_colm2024/main/MOD_HistVector.F90 | 623 ++ .../main/MOD_HistWriteBack.F90 | 743 +++ .../physics_colm2024/main/MOD_Irrigation.F90 | 569 ++ .../main/MOD_LAIEmpirical.F90 | 139 + .../physics_colm2024/main/MOD_LAIReadin.F90 | 219 + .../physics_colm2024/main/MOD_Lake.F90 | 2186 +++++++ .../main/MOD_LeafInterception.F90 | 2458 ++++++++ .../main/MOD_LeafTemperature.F90 | 1568 +++++ .../main/MOD_LeafTemperaturePC.F90 | 2145 +++++++ .../main/MOD_LightningData.F90 | 116 + .../main/MOD_MonthlyinSituCO2MaunaLoa.F90 | 746 +++ .../physics_colm2024/main/MOD_NdepData.F90 | 230 + .../physics_colm2024/main/MOD_NetSolar.F90 | 323 ++ .../main/MOD_NetSolar_Hyper.F90 | 356 ++ .../physics_colm2024/main/MOD_NewSnow.F90 | 125 + .../physics_colm2024/main/MOD_NitrifData.F90 | 171 + .../physics_colm2024/main/MOD_OrbCosazi.F90 | 70 + .../physics_colm2024/main/MOD_OrbCoszen.F90 | 84 + .../physics_colm2024/main/MOD_Ozone.F90 | 275 + .../physics_colm2024/main/MOD_PhaseChange.F90 | 823 +++ .../main/MOD_PlantHydraulic.F90 | 1096 ++++ .../physics_colm2024/main/MOD_Qsadv.F90 | 108 + .../main/MOD_RainSnowTemp.F90 | 308 + .../physics_colm2024/main/MOD_Runoff.F90 | 440 ++ .../physics_colm2024/main/MOD_SimpleOcean.F90 | 680 +++ .../main/MOD_SnowFraction.F90 | 175 + .../main/MOD_SnowLayersCombineDivide.F90 | 1290 +++++ .../physics_colm2024/main/MOD_SnowSnicar.F90 | 3000 ++++++++++ .../main/MOD_SnowSnicar_HiRes.F90 | 2994 ++++++++++ .../main/MOD_SoilSnowHydrology.F90 | 2458 ++++++++ .../main/MOD_SoilSurfaceResistance.F90 | 319 ++ .../main/MOD_SoilThermalParameters.F90 | 524 ++ .../physics_colm2024/main/MOD_Thermal.F90 | 1390 +++++ .../main/MOD_TurbulenceLEddy.F90 | 465 ++ .../main/MOD_UserSpecifiedForcing.F90 | 969 ++++ .../main/MOD_Vars_1DAccFluxes.F90 | 2970 ++++++++++ .../main/MOD_Vars_1DFluxes.F90 | 305 + .../main/MOD_Vars_1DForcing.F90 | 167 + .../main/MOD_Vars_1DPFTFluxes.F90 | 173 + .../main/MOD_Vars_2DForcing.F90 | 81 + .../physics_colm2024/main/MOD_Vars_Global.F90 | 168 + .../main/MOD_Vars_TimeInvariants.F90 | 1120 ++++ .../main/MOD_Vars_TimeVariables.F90 | 1644 ++++++ .../main/MOD_VicParaReadin.F90 | 146 + .../physics_colm2024/main/MOD_WetBulb.F90 | 119 + .../main/MOD_dataSpec_PDB.F90 | 1181 ++++ .../physics_colm2024/main/MOD_prospect_DB.F90 | 204 + .../physics_colm2024/main/MOD_tav_abs.F90 | 67 + .../main/ParaOpt/MOD_Opt_Baseflow.F90 | 212 + .../ParaOpt/MOD_ParameterOptimization.F90 | 44 + .../main/URBAN/CoLMMAIN_Urban.F90 | 1368 +++++ .../main/URBAN/MOD_Urban_Albedo.F90 | 371 ++ .../main/URBAN/MOD_Urban_BEM.F90 | 256 + .../main/URBAN/MOD_Urban_Const_LCZ.F90 | 125 + .../main/URBAN/MOD_Urban_Flux.F90 | 2644 +++++++++ .../main/URBAN/MOD_Urban_GroundFlux.F90 | 229 + .../main/URBAN/MOD_Urban_Hydrology.F90 | 419 ++ .../URBAN/MOD_Urban_ImperviousTemperature.F90 | 304 + .../main/URBAN/MOD_Urban_LAIReadin.F90 | 83 + .../main/URBAN/MOD_Urban_LUCY.F90 | 181 + .../main/URBAN/MOD_Urban_Longwave.F90 | 678 +++ .../main/URBAN/MOD_Urban_NetSolar.F90 | 184 + .../URBAN/MOD_Urban_PerviousTemperature.F90 | 314 + .../main/URBAN/MOD_Urban_RoofFlux.F90 | 236 + .../main/URBAN/MOD_Urban_RoofTemperature.F90 | 252 + .../main/URBAN/MOD_Urban_Shortwave.F90 | 777 +++ .../main/URBAN/MOD_Urban_Thermal.F90 | 1402 +++++ .../main/URBAN/MOD_Urban_Vars_1DFluxes.F90 | 155 + .../URBAN/MOD_Urban_Vars_TimeInvariants.F90 | 340 ++ .../URBAN/MOD_Urban_Vars_TimeVariables.F90 | 506 ++ .../main/URBAN/MOD_Urban_WallTemperature.F90 | 190 + .../mkinidata/MOD_DBedrockReadin.F90 | 72 + .../mkinidata/MOD_HtopReadin.F90 | 152 + .../mkinidata/MOD_IniTimeVariable.F90 | 1376 +++++ .../mkinidata/MOD_Initialize.F90 | 1662 ++++++ .../mkinidata/MOD_LakeDepthReadin.F90 | 110 + .../mkinidata/MOD_PercentagesPFTReadin.F90 | 94 + .../mkinidata/MOD_SoilColorRefl.F90 | 115 + .../mkinidata/MOD_SoilParametersReadin.F90 | 550 ++ .../mkinidata/MOD_SoilTextureReadin.F90 | 54 + .../mkinidata/MOD_UrbanIniTimeVariable.F90 | 132 + .../mkinidata/MOD_UrbanReadin.F90 | 321 ++ .../mksrfdata/Aggregation_DBedrock.F90 | 129 + .../mksrfdata/Aggregation_ForestHeight.F90 | 332 ++ .../mksrfdata/Aggregation_LAI.F90 | 759 +++ .../mksrfdata/Aggregation_LakeDepth.F90 | 145 + .../mksrfdata/Aggregation_PercentagesPFT.F90 | 218 + .../mksrfdata/Aggregation_SoilBrightness.F90 | 409 ++ .../mksrfdata/Aggregation_SoilHyperAlbedo.F90 | 166 + .../mksrfdata/Aggregation_SoilParameters.F90 | 2042 +++++++ .../mksrfdata/Aggregation_SoilTexture.F90 | 139 + .../mksrfdata/Aggregation_TopoWetness.F90 | 345 ++ .../mksrfdata/Aggregation_Topography.F90 | 206 + .../Aggregation_TopographyFactors.F90 | 522 ++ .../Aggregation_TopographyFactors_Simple.F90 | 242 + .../mksrfdata/Aggregation_Urban.F90 | 1293 +++++ .../mksrfdata/MOD_AggregationRequestData.F90 | 701 +++ .../mksrfdata/MOD_ElmVector.F90 | 168 + .../mksrfdata/MOD_HRUVector.F90 | 215 + .../mksrfdata/MOD_Land2mWMO.F90 | 249 + .../mksrfdata/MOD_LandCrop.F90 | 152 + .../mksrfdata/MOD_LandElm.F90 | 84 + .../mksrfdata/MOD_LandHRU.F90 | 222 + .../mksrfdata/MOD_LandPFT.F90 | 326 ++ .../mksrfdata/MOD_LandPatch.F90 | 319 ++ .../mksrfdata/MOD_LandUrban.F90 | 409 ++ .../mksrfdata/MOD_Lulcc_TransferTrace.F90 | 293 + .../mksrfdata/MOD_MeshFilter.F90 | 181 + .../mksrfdata/MOD_PixelsetShared.F90 | 213 + .../mksrfdata/MOD_RegionClip.F90 | 809 +++ .../mksrfdata/MOD_SingleSrfdata.F90 | 3472 +++++++++++ .../mksrfdata/MOD_SrfdataDiag.F90 | 553 ++ .../mksrfdata/MOD_SrfdataRestart.F90 | 816 +++ .../physics_colm2024/run/NmlNameFormatReadme | 127 + .../run/examples/CRA40_Grid_30km_IGBP_VG.nml | 71 + .../run/examples/China_Grid_50km_IGBP_VG.nml | 68 + .../examples/Global_Grid_2x2_PFT_VG_BGC.nml | 69 + .../Global_Grid_50km_IGBP_CB_URBAN.nml | 126 + .../examples/GreaterBay_Grid_10km_IGBP_VG.nml | 73 + .../PearlRiver_Catch_100km_IGBP_VG.nml | 53 + .../examples/PoyangLake_Grid_5km_IGBP_VG.nml | 65 + .../RegChina_Grid_50km_IGBP_CB_LULCC.nml | 110 + .../run/examples/SiteSYSUAtmos_IGBP_VG.nml | 64 + .../run/examples/full_history_variables.nml | 353 ++ .../physics_colm2024/run/forcing/CLDAS.nml | 50 + .../physics_colm2024/run/forcing/CMFD.nml | 51 + .../physics_colm2024/run/forcing/CMFDv2.nml | 51 + .../physics_colm2024/run/forcing/CRA40.nml | 50 + .../physics_colm2024/run/forcing/CRUJRA.nml | 48 + .../run/forcing/CRUNCEPV4.nml | 45 + .../run/forcing/CRUNCEPV7.nml | 45 + .../physics_colm2024/run/forcing/ERA5.nml | 53 + .../physics_colm2024/run/forcing/ERA5LAND.nml | 50 + .../run/forcing/ERA5_LEddy.nml | 50 + .../physics_colm2024/run/forcing/GDAS.nml | 51 + .../physics_colm2024/run/forcing/GSWP3.nml | 44 + .../physics_colm2024/run/forcing/IsoGSM.nml | 68 + .../physics_colm2024/run/forcing/JRA3Q.nml | 47 + .../physics_colm2024/run/forcing/JRA55.nml | 46 + .../run/forcing/MPI-ESM1-2-HR_ssp585.nml | 45 + .../physics_colm2024/run/forcing/MSWX.nml | 45 + .../physics_colm2024/run/forcing/POINT.nml | 31 + .../run/forcing/PRINCETON.nml | 45 + .../physics_colm2024/run/forcing/QIAN.nml | 45 + .../physics_colm2024/run/forcing/TPMFD.nml | 50 + .../physics_colm2024/run/forcing/WFDE5.nml | 48 + .../physics_colm2024/run/forcing/WFDEI.nml | 49 + .../physics/physics_colm2024/run/mapdata.txt | 5 + .../physics_colm2024/run/test_vic_para.nml | 111 + .../share/MOD_5x5DataReadin.F90 | 554 ++ .../physics_colm2024/share/MOD_Block.F90 | 635 +++ .../share/MOD_CatchmentDataReadin.F90 | 375 ++ .../physics_colm2024/share/MOD_DataType.F90 | 709 +++ .../physics_colm2024/share/MOD_Grid.F90 | 1004 ++++ .../share/MOD_IncompleteGamma.F90 | 946 +++ .../physics_colm2024/share/MOD_Mesh.F90 | 1045 ++++ .../physics_colm2024/share/MOD_Namelist.F90 | 2508 ++++++++ .../share/MOD_NetCDFBlock.F90 | 462 ++ .../share/MOD_NetCDFPoint.F90 | 425 ++ .../share/MOD_NetCDFSerial.F90 | 2635 +++++++++ .../share/MOD_NetCDFVector.F90 | 1996 +++++++ .../physics_colm2024/share/MOD_Pixel.F90 | 418 ++ .../physics_colm2024/share/MOD_Pixelset.F90 | 737 +++ .../physics_colm2024/share/MOD_Precision.F90 | 12 + .../physics_colm2024/share/MOD_RangeCheck.F90 | 886 +++ .../physics_colm2024/share/MOD_SPMD_Task.F90 | 215 + .../share/MOD_SpatialMapping.F90 | 2856 ++++++++++ .../share/MOD_TimeManager.F90 | 711 +++ .../physics_colm2024/share/MOD_UserDefFun.F90 | 70 + .../physics_colm2024/share/MOD_Utils.F90 | 2615 +++++++++ .../share/MOD_WorkerPushData.F90 | 1136 ++++ .../physics/physics_wrf/module_ra_rrtmg_sw.F | 25 +- 294 files changed, 167423 insertions(+), 96 deletions(-) create mode 100644 src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F create mode 100644 src/core_atmosphere/physics/physics_colm2024/.gitignore create mode 100644 src/core_atmosphere/physics/physics_colm2024/Makefile create mode 100644 src/core_atmosphere/physics/physics_colm2024/README.md create mode 100644 src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation create mode 100644 src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/include/Makeoptions create mode 100644 src/core_atmosphere/physics/physics_colm2024/include/define.h create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofFlux.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SingleSrfdata.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt create mode 100644 src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 diff --git a/.gitignore b/.gitignore index 42e80e9e98..9d941743c9 100644 --- a/.gitignore +++ b/.gitignore @@ -61,3 +61,4 @@ stream_list.* *.i90 src/core_*/inc +/build-cmake-colm-debug diff --git a/CMakeLists.txt b/CMakeLists.txt index e7e010394d..c934cde3e9 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -22,6 +22,7 @@ option(MPAS_PROFILE "Enable GPTL profiling" OFF) option(MPAS_OPENMP "Enable OpenMP" OFF) option(BUILD_SHARED_LIBS "Build shared libraries" ON) option(MPAS_USE_PIO "Build with PIO I/O library" OFF) +option(MPAS_COLM2024 "Build atmosphere core with embedded CoLM2024 land-surface physics" OFF) message(STATUS "[OPTION] MPAS_CORES: ${MPAS_CORES}") message(STATUS "[OPTION] MPAS_DOUBLE_PRECISION: ${MPAS_DOUBLE_PRECISION}") @@ -29,6 +30,7 @@ message(STATUS "[OPTION] MPAS_PROFILE: ${MPAS_PROFILE}") message(STATUS "[OPTION] MPAS_OPENMP: ${MPAS_OPENMP}") message(STATUS "[OPTION] BUILD_SHARED_LIBS: ${BUILD_SHARED_LIBS}") message(STATUS "[OPTION] MPAS_USE_PIO: ${MPAS_USE_PIO}") +message(STATUS "[OPTION] MPAS_COLM2024: ${MPAS_COLM2024}") # Build product output locations set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) @@ -68,9 +70,14 @@ endif() find_package(MPI REQUIRED COMPONENTS Fortran) find_package(PnetCDF REQUIRED COMPONENTS Fortran) +if(MPAS_USE_PIO OR MPAS_COLM2024) + find_package(NetCDF REQUIRED COMPONENTS Fortran C) +endif() +if(MPAS_COLM2024) + find_package(LAPACK REQUIRED) +endif() if(MPAS_USE_PIO) find_package(PIO REQUIRED COMPONENTS Fortran C) - find_package(NetCDF REQUIRED COMPONENTS Fortran C) endif() if(MPAS_PROFILE) find_package(GPTL REQUIRED) diff --git a/Makefile b/Makefile index 07ba5f9556..3b9f5277a5 100644 --- a/Makefile +++ b/Makefile @@ -1029,6 +1029,13 @@ endif # END OF GIT DESCRIBE VERSION #################################################### # Section for adding external libraries and includes #################################################### +ifeq "$(COLM2024)" "true" +COLM2024_DIR ?= $(PWD)/src/core_atmosphere/physics/physics_colm2024 +override CPPFLAGS += -DMPAS_COLM2024 +COLM2024_MESSAGE = "MPAS was built with CoLM2024 from $(COLM2024_DIR)." +else +COLM2024_MESSAGE = "MPAS was not built with CoLM2024." +endif ifdef MPAS_EXTERNAL_LIBS override LIBS += $(MPAS_EXTERNAL_LIBS) endif @@ -1573,6 +1580,7 @@ mpas_main: $(MAIN_DEPS) @echo $(OPENMP_OFFLOAD_MESSAGE) @echo $(OPENACC_MESSAGE) @echo $(MUSICA_MESSAGE) + @echo $(COLM2024_MESSAGE) @echo $(SCOTCH_MESSAGE) @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @@ -1648,4 +1656,3 @@ errmsg: ifdef CORE exit 1 endif - diff --git a/cmake/Functions/MPAS_Functions.cmake b/cmake/Functions/MPAS_Functions.cmake index 15d9f63fc1..1a349d13fc 100644 --- a/cmake/Functions/MPAS_Functions.cmake +++ b/cmake/Functions/MPAS_Functions.cmake @@ -214,25 +214,26 @@ function(mpas_core_target) if (${DO_PHYSICS}) set(CPP_EXTRA_FLAGS ${CPP_EXTRA_FLAGS} -DDO_PHYSICS) endif() + set(REGISTRY_PROCESSED_XML ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml) -add_custom_command(OUTPUT Registry_processed.xml - COMMAND ${CPP_EXECUTABLE} -E -P ${CPP_EXTRA_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml > Registry_processed.xml +add_custom_command(OUTPUT ${REGISTRY_PROCESSED_XML} + COMMAND ${CPP_EXECUTABLE} -E -P ${CPP_EXTRA_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml > ${REGISTRY_PROCESSED_XML} COMMENT "CORE ${ARG_CORE}: Pre-Process Registry" - DEPENDS Registry.xml) + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml) add_custom_command(OUTPUT ${ARG_INCLUDES} - COMMAND mpas_parse_${ARG_CORE} Registry_processed.xml ${CPP_EXTRA_FLAGS} + COMMAND mpas_parse_${ARG_CORE} ${REGISTRY_PROCESSED_XML} ${CPP_EXTRA_FLAGS} COMMENT "CORE ${ARG_CORE}: Parse Registry" - DEPENDS mpas_parse_${ARG_CORE} Registry_processed.xml) + DEPENDS mpas_parse_${ARG_CORE} ${REGISTRY_PROCESSED_XML}) add_custom_command(OUTPUT namelist.${ARG_CORE} WORKING_DIRECTORY ${CORE_DATADIR} - COMMAND mpas_namelist_gen ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml namelist.${ARG_CORE} in_defaults=true + COMMAND mpas_namelist_gen ${REGISTRY_PROCESSED_XML} namelist.${ARG_CORE} in_defaults=true COMMENT "CORE ${ARG_CORE}: Generate Namelist" - DEPENDS mpas_namelist_gen Registry_processed.xml) + DEPENDS mpas_namelist_gen ${REGISTRY_PROCESSED_XML}) add_custom_command(OUTPUT streams.${ARG_CORE} WORKING_DIRECTORY ${CORE_DATADIR} - COMMAND mpas_streams_gen ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml streams.${ARG_CORE} stream_list.${ARG_CORE}. listed + COMMAND mpas_streams_gen ${REGISTRY_PROCESSED_XML} streams.${ARG_CORE} stream_list.${ARG_CORE}. listed COMMENT "CORE ${ARG_CORE}: Generate Streams" - DEPENDS mpas_streams_gen Registry_processed.xml) + DEPENDS mpas_streams_gen ${REGISTRY_PROCESSED_XML}) add_custom_target(gen_${ARG_CORE} DEPENDS ${ARG_INCLUDES} namelist.${ARG_CORE} streams.${ARG_CORE}) add_dependencies(${ARG_TARGET} gen_${ARG_CORE}) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 7fdbe66992..9b94b64ca6 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -35,6 +35,7 @@ set(ATMOSPHERE_CORE_PHYSICS_SOURCES mpas_atmphys_driver_sfclayer.F mpas_atmphys_init.F mpas_atmphys_lsm_shared.F + mpas_atmphys_driver_lsm_colm2024.F mpas_atmphys_packages.F mpas_atmphys_todynamics.F mpas_atmphys_vars.F @@ -298,6 +299,140 @@ set(ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES ) list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES PREPEND physics/physics_noahmp/src/) +if(MPAS_COLM2024) + set(COLM2024_SOURCE_ROOT ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_colm2024) + file(STRINGS ${COLM2024_SOURCE_ROOT}/Makefile COLM2024_MAKEFILE_LINES) + set(_colm2024_collect_sources FALSE) + foreach(_colm2024_line IN LISTS COLM2024_MAKEFILE_LINES) + if(_colm2024_line MATCHES "^OBJS_SHARED[ \t]*=" OR + _colm2024_line MATCHES "^OBJS_BASIC[ \t]*=" OR + _colm2024_line MATCHES "^OBJS_MAIN[ \t]*=") + set(_colm2024_collect_sources TRUE) + endif() + if(_colm2024_collect_sources) + string(REGEX MATCHALL "[A-Za-z0-9_]+\\.o" _colm2024_objects "${_colm2024_line}") + list(APPEND COLM2024_OBJECT_LIST ${_colm2024_objects}) + if(NOT _colm2024_line MATCHES "\\\\[ \t]*$") + set(_colm2024_collect_sources FALSE) + endif() + endif() + endforeach() + set(COLM2024_SOURCE_SEARCH_DIRS + include + share + mksrfdata + mkinidata + main + main/HYDRO + main/BGC + main/URBAN + main/LULCC + main/DA + main/ParaOpt + drivers/mpas + ) + foreach(_colm2024_obj IN LISTS COLM2024_OBJECT_LIST) + string(REGEX REPLACE "\\.o$" ".F90" _colm2024_src_name ${_colm2024_obj}) + unset(_colm2024_src) + foreach(_colm2024_dir IN LISTS COLM2024_SOURCE_SEARCH_DIRS) + if(EXISTS ${COLM2024_SOURCE_ROOT}/${_colm2024_dir}/${_colm2024_src_name}) + set(_colm2024_src ${COLM2024_SOURCE_ROOT}/${_colm2024_dir}/${_colm2024_src_name}) + break() + endif() + endforeach() + if(NOT _colm2024_src) + message(FATAL_ERROR "Could not resolve CoLM2024 object ${_colm2024_obj} to a source file") + endif() + file(RELATIVE_PATH _colm2024_src_rel ${CMAKE_CURRENT_SOURCE_DIR} ${_colm2024_src}) + execute_process( + COMMAND ${CPP_EXECUTABLE} -traditional-cpp -P -I${COLM2024_SOURCE_ROOT}/include ${_colm2024_src} + OUTPUT_VARIABLE _colm2024_preprocessed_src + ERROR_VARIABLE _colm2024_preprocess_error + RESULT_VARIABLE _colm2024_preprocess_result + ) + if(NOT _colm2024_preprocess_result EQUAL 0) + message(FATAL_ERROR "Could not preprocess CoLM2024 source ${_colm2024_src}: ${_colm2024_preprocess_error}") + endif() + string(TOUPPER "${_colm2024_preprocessed_src}" _colm2024_preprocessed_src_upper) + if(NOT "${_colm2024_preprocessed_src_upper}" MATCHES "(^|\n)[ \t]*(MODULE|SUBROUTINE|FUNCTION|PROGRAM)[ \t]+[A-Z0-9_]+") + list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES ${_colm2024_src_rel}) + continue() + endif() + list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES ${_colm2024_src_rel}) + endforeach() + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES _colm2024_source_count) + if(_colm2024_source_count EQUAL 0) + message(FATAL_ERROR "CoLM2024 CMake source list is empty") + endif() + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES _colm2024_skipped_empty_count) + message(STATUS "CoLM2024 embedded CMake sources: ${_colm2024_source_count}") + message(STATUS "CoLM2024 embedded CMake skipped empty sources: ${_colm2024_skipped_empty_count}") + + function(_colm2024_object_path out source) + set(${out} "${CMAKE_CURRENT_BINARY_DIR}/CMakeFiles/core_atmosphere.dir/${source}.o" PARENT_SCOPE) + endfunction() + + function(_colm2024_source_depends source) + if(NOT "${source}" IN_LIST ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + return() + endif() + set(_colm2024_deps) + foreach(_colm2024_dep IN LISTS ARGN) + if(NOT "${_colm2024_dep}" IN_LIST ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + continue() + endif() + _colm2024_object_path(_colm2024_dep_obj ${_colm2024_dep}) + list(APPEND _colm2024_deps ${_colm2024_dep_obj}) + endforeach() + if(_colm2024_deps) + set_property(SOURCE ${source} APPEND PROPERTY OBJECT_DEPENDS "${_colm2024_deps}") + endif() + endfunction() + + set(_colm2024_previous_source) + foreach(_colm2024_source IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + if(_colm2024_previous_source) + _colm2024_source_depends(${_colm2024_source} ${_colm2024_previous_source}) + endif() + set(_colm2024_previous_source ${_colm2024_source}) + endforeach() + + _colm2024_source_depends( + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90) + _colm2024_source_depends( + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 + physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90) + _colm2024_source_depends( + physics/physics_colm2024/main/MOD_HistGridded.F90 + physics/physics_colm2024/main/MOD_HistWriteBack.F90) + _colm2024_source_depends( + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90) + _colm2024_source_depends( + physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90) + _colm2024_source_depends( + physics/physics_colm2024/main/MOD_Hist.F90 + physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90) + _colm2024_source_depends( + physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 + physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 + physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90) + _colm2024_source_depends( + physics/mpas_atmphys_driver_lsm_colm2024.F + physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90) +endif() + # diagnostics/ set(ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES mpas_atm_diagnostic_template.F @@ -351,6 +486,7 @@ add_library(core_atmosphere ${ATMOSPHERE_CORE_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_NOAMP_UTILITY_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_NOAMP_MPAS_DRIVER_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES} @@ -365,7 +501,35 @@ set(CORE_ATMOSPHERE_COMPILE_DEFINITIONS if (${DO_PHYSICS}) list(APPEND CORE_ATMOSPHERE_COMPILE_DEFINITIONS DO_PHYSICS) endif () +if (MPAS_COLM2024) + list(APPEND CORE_ATMOSPHERE_COMPILE_DEFINITIONS MPAS_COLM2024) +endif () target_compile_definitions(core_atmosphere PRIVATE ${CORE_ATMOSPHERE_COMPILE_DEFINITIONS}) +if (MPAS_COLM2024) + target_include_directories(core_atmosphere PRIVATE ${COLM2024_SOURCE_ROOT}/include) + target_link_libraries(core_atmosphere PUBLIC NetCDF::NetCDF_Fortran NetCDF::NetCDF_C) + if(TARGET LAPACK::LAPACK) + target_link_libraries(core_atmosphere PUBLIC LAPACK::LAPACK) + else() + target_link_libraries(core_atmosphere PUBLIC ${LAPACK_LIBRARIES}) + endif() + set_property(SOURCE ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} + PROPERTY Fortran_PREPROCESS ON) + if(CMAKE_Fortran_COMPILER_ID MATCHES GNU) + set(_colm2024_compile_options -fdefault-real-8 -ffree-line-length-none) + if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + list(APPEND _colm2024_compile_options -fallow-argument-mismatch) + endif() + elseif(CMAKE_Fortran_COMPILER_ID MATCHES Intel) + set(_colm2024_compile_options -real-size 64) + elseif(CMAKE_Fortran_COMPILER_ID MATCHES NVHPC) + set(_colm2024_compile_options -r8) + endif() + if(_colm2024_compile_options) + set_property(SOURCE ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} + APPEND PROPERTY COMPILE_OPTIONS ${_colm2024_compile_options}) + endif() +endif () set_MPAS_DEBUG_flag(core_atmosphere) mpas_core_target(CORE atmosphere TARGET core_atmosphere INCLUDES ${ATMOSPHERE_CORE_INCLUDES}) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index bb2bd2c2e7..332823e86c 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -48,6 +48,7 @@ post_build: physcore: mpas_atm_dimensions.o ( cd physics; $(MAKE) all ) + $(RM) -r libphys ( mkdir libphys; cd libphys; ar -x ../physics/libphys.a ) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*TBL .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) @@ -55,6 +56,7 @@ physcore: mpas_atm_dimensions.o chemcore: ( cd chemistry; $(MAKE) all CHEMISTRY="$(CHEMISTRY)" ) + $(RM) -r libchem ( mkdir libchem; cd libchem; ar -x ../chemistry/libchem.a ) dycore: mpas_atm_dimensions.o $(PHYSCORE) $(CHEMCORE) @@ -67,6 +69,7 @@ utilities: $(PHYSCORE) ( cd utils; $(MAKE) all PHYSICS="$(PHYSICS)" ) atmcore: $(PHYSCORE) dycore diagcore $(OBJS) + $(RM) libdycore.a ar -ru libdycore.a $(OBJS) dynamics/*.o $(PHYS_OBJS) $(CHEM_OBJS) diagnostics/*.o mpas_atm_core_interface.o: mpas_atm_core.o diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 425e0349d1..8b0ff5241e 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -474,6 +474,7 @@ + @@ -496,9 +497,9 @@ - @@ -599,9 +600,9 @@ - @@ -647,11 +648,11 @@ #endif - @@ -924,9 +925,9 @@ #endif - @@ -997,6 +998,14 @@ + + + + + + + + @@ -1028,9 +1037,9 @@ #endif - @@ -1157,9 +1166,9 @@ #endif - @@ -1170,9 +1179,9 @@ #endif - @@ -1694,7 +1703,7 @@ description="Moist potential temperature: theta*(1+q_v*R_v/R_d)"/> - + #ifndef MPAS_CAM_DYCORE @@ -2024,7 +2033,7 @@ - + @@ -2060,7 +2069,7 @@ description="Tendency of surface pressure"/> - + #ifndef MPAS_CAM_DYCORE @@ -2093,7 +2102,7 @@ description="Tendency of cloud ice number concentration multiplied by dry air density divided by d(zeta)/dz" packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in"/> - @@ -2109,7 +2118,7 @@ description="Tendency of water-friendly aerosol number concentration multiplied by dry air density divided by d(zeta)/dz" packages="mp_thompson_aers_in"/> - @@ -2252,7 +2261,7 @@ possible_values="Positive integers"/> - + + possible_values="`suite',`sf_noah',`sf_noahmp`, `sf_colm2024`, `off'"/> + + + + @@ -3237,6 +3253,18 @@ + + + + + + + + @@ -3543,7 +3571,7 @@ - + #ifdef DO_PHYSICS @@ -3970,7 +3998,7 @@ #endif - + diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 2b7422ddec..05a125b409 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,9 +4,17 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif +ifneq (,$(findstring -DMPAS_COLM2024,$(CPPFLAGS))) +COLM2024_ENABLED = true +COLM2024_CORE = core_physics_colm2024 +COLM2024_INCLUDES = -I./physics_colm2024/include -I./physics_colm2024/.bld +COLM2024_FOPTS ?= $(CPPFLAGS) $(COREDEF) $(FFLAGS) -fdefault-real-8 -ffree-form -cpp -ffree-line-length-0 -fallow-argument-mismatch +endif + all: ./../tools/manage_externals/checkout_externals --externals ./../Externals.cfg - $(MAKE) lookup_tables core_physics_init core_physics_mmm core_UGWP core_physics_wrf core_physics_noahmp core_physics + $(RM) libphys.a + $(MAKE) lookup_tables $(COLM2024_CORE) core_physics_init core_physics_mmm core_UGWP core_physics_wrf core_physics_noahmp core_physics dummy: echo "****** compiling physics ******" @@ -27,6 +35,7 @@ OBJS = \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ + mpas_atmphys_driver_lsm_colm2024.o \ mpas_atmphys_driver_microphysics.o \ mpas_atmphys_driver_oml.o \ mpas_atmphys_driver_pbl.o \ @@ -71,9 +80,12 @@ core_physics_noahmp: (cd physics_noahmp/src; $(MAKE) all COREDEF="$(COREDEF)") (cd physics_noahmp/drivers/mpas; $(MAKE) all COREDEF="$(COREDEF)") +core_physics_colm2024: + (cd physics_colm2024; $(MAKE) mpas_objects FF="$(FC)" FOPTS="$(COLM2024_FOPTS)") + core_physics_init: $(OBJS_init) -core_physics: core_physics_wrf core_physics_noahmp +core_physics: core_physics_wrf core_physics_noahmp $(COLM2024_CORE) ($(MAKE) phys_interface COREDEF="$(COREDEF)") ar -ru libphys.a $(OBJS_init) $(OBJS) ($(MAKE) -C ./physics_mmm -f Makefile.mpas physics_mmm_lib) @@ -81,6 +93,9 @@ core_physics: core_physics_wrf core_physics_noahmp ($(MAKE) -C ./physics_noahmp/drivers/mpas driver_lib) ($(MAKE) -C ./physics_noahmp/src src_lib) ($(MAKE) -C ./physics_noahmp/utility utility_lib) +ifeq "$(COLM2024_ENABLED)" "true" + (cd physics_colm2024/.mpas; ar -ru ../../libphys.a *.o) +endif phys_interface: $(OBJS) @@ -99,6 +114,7 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ + mpas_atmphys_driver_lsm_colm2024.o \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ @@ -175,7 +191,8 @@ mpas_atmphys_driver_sfclayer.o: \ mpas_atmphys_vars.o mpas_atmphys_finalize.o: \ - mpas_atmphys_lsm_noahmpfinalize.o + mpas_atmphys_lsm_noahmpfinalize.o \ + mpas_atmphys_driver_lsm_colm2024.o mpas_atmphys_init.o: \ mpas_atmphys_driver_convection.o \ @@ -186,6 +203,7 @@ mpas_atmphys_init.o: \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_driver_sfclayer.o \ mpas_atmphys_lsm_noahmpinit.o \ + mpas_atmphys_driver_lsm_colm2024.o \ mpas_atmphys_landuse.o \ mpas_atmphys_o3climatology.o \ mpas_atmphys_vars.o @@ -209,6 +227,9 @@ mpas_atmphys_lsm_noahmpinit.o: \ mpas_atmphys_lsm_noahmpfinalize.o : \ mpas_atmphys_vars.o +mpas_atmphys_driver_lsm_colm2024.o : \ + mpas_atmphys_utilities.o + mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ mpas_atmphys_o3climatology.o \ @@ -253,6 +274,7 @@ clean: ( cd physics_noahmp/drivers/mpas; $(MAKE) clean ) ( cd physics_noahmp/src; $(MAKE) clean ) ( cd physics_noahmp/utility; $(MAKE) clean ) + ( if [ -d physics_colm2024 ]; then cd physics_colm2024; $(MAKE) clean; fi ) ( if [ -d physics_noaa/UGWP ]; then cd physics_noaa/UGWP; $(MAKE) clean; fi ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process @@ -262,7 +284,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) -I../../framework $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) $(COLM2024_INCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) $(COLM2024_INCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index b3162019e5..c83013c5ee 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -52,7 +52,7 @@ module mpas_atmphys_control ! * renamed "kain_fritsch" to "cu_kain_fritsch" and "tiedtke" to "cu_tiedtke". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. ! * renamed "ysu" to "bl_ysu", "ysu_gwdo" to "bl_gwdo_ysu", and "monin_obukhov" to "sf_monin_obukhov". -! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. +! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. ! * added the option mp_thompson. ! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. ! * added the option cu_grell_freitas. @@ -224,7 +224,7 @@ subroutine physics_namelist_check(configs) if(.not. (config_radt_lw_scheme .eq. 'off' .or. & config_radt_lw_scheme .eq. 'cam_lw' .or. & config_radt_lw_scheme .eq. 'rrtmg_lw')) then - + write(mpas_err_message,'(A,A20)') 'illegal value for longwave radiation scheme: ', & trim(config_radt_lw_scheme) call physics_error_fatal(mpas_err_message) @@ -235,7 +235,7 @@ subroutine physics_namelist_check(configs) if(.not. (config_radt_sw_scheme .eq. 'off' .or. & config_radt_sw_scheme .eq. 'cam_sw' .or. & config_radt_sw_scheme .eq. 'rrtmg_sw')) then - + write(mpas_err_message,'(A,A20)') 'illegal value for shortwave radiation _scheme: ', & trim(config_radt_sw_scheme) call physics_error_fatal(mpas_err_message) @@ -272,7 +272,7 @@ subroutine physics_namelist_check(configs) config_sfclayer_scheme .eq. 'sf_mynn' .or. & config_sfclayer_scheme .eq. 'sf_monin_obukhov' .or. & config_sfclayer_scheme .eq. 'sf_monin_obukhov_rev')) then - + write(mpas_err_message,'(A,A20)') 'illegal value for surface layer scheme: ', & trim(config_sfclayer_scheme) call physics_error_fatal(mpas_err_message) @@ -292,14 +292,15 @@ subroutine physics_namelist_check(configs) !land-surface scheme: note that config_sfclayer_scheme must be defined for the land-surface !scheme to be called: if(config_lsm_scheme .ne. 'off' .and. config_sfclayer_scheme .eq. 'off') then - + call physics_error_fatal('land surface scheme: ' // & 'set config_sfclayer_scheme different than off') - + elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & config_lsm_scheme .eq. 'sf_noah' .or. & - config_lsm_scheme .eq. 'sf_noahmp')) then - + config_lsm_scheme .eq. 'sf_noahmp' .or. & + config_lsm_scheme .eq. 'sf_colm2024')) then + write(mpas_err_message,'(A,A20)') 'illegal value for land surface scheme: ', & trim(config_lsm_scheme) call physics_error_fatal(mpas_err_message) @@ -308,7 +309,7 @@ subroutine physics_namelist_check(configs) !checks if any physics process is called. if not, return: moist_physics = .true. - + if(config_microp_scheme .eq. 'off' .and. & config_convection_scheme .eq. 'off' .and. & config_lsm_scheme .eq. 'off' .and. & @@ -379,9 +380,9 @@ subroutine physics_registry_init(mesh,configs,sfc_input) enddo case default - + end select lsm_select - + endif !call mpas_log_write('--- enter subroutine physics_namelist_check.') @@ -535,4 +536,3 @@ end subroutine physics_compatibility_check !================================================================================================================= end module mpas_atmphys_control !================================================================================================================= - diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 8e31672657..faf2b9c1bc 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -15,9 +15,10 @@ module mpas_atmphys_driver use mpas_atmphys_driver_gwdo use mpas_atmphys_driver_lsm use mpas_atmphys_driver_lsm_noahmp + use mpas_atmphys_driver_lsm_colm2024,only: driver_lsm_colm2024 use mpas_atmphys_driver_pbl use mpas_atmphys_driver_radiation_lw - use mpas_atmphys_driver_radiation_sw + use mpas_atmphys_driver_radiation_sw use mpas_atmphys_driver_seaice,only: allocate_seaice,deallocate_seaice,driver_seaice use mpas_atmphys_driver_sfclayer use mpas_atmphys_driver_oml @@ -169,12 +170,12 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_config(domain%configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) call mpas_pool_get_config(domain%configs,'config_bucket_radt' ,config_bucket_radt ) call mpas_pool_get_config(domain%configs,'config_bucket_update' ,config_bucket_update ) - call mpas_pool_get_config(domain%configs,'config_frac_seaice' ,config_frac_seaice ) + call mpas_pool_get_config(domain%configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(domain%configs,'config_oml1d' ,config_oml1d ) if(config_convection_scheme .ne. 'off' .or. & config_lsm_scheme .ne. 'off' .or. & - config_pbl_scheme .ne. 'off' .or. & + config_pbl_scheme .ne. 'off' .or. & config_radt_lw_scheme .ne. 'off' .or. & config_radt_sw_scheme .ne. 'off' .or. & config_sfclayer_scheme .ne. 'off') then @@ -297,6 +298,10 @@ subroutine physics_driver(domain,itimestep,xtime_s) diag_physics_noahmp,output_noahmp,sfc_input,itimestep, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) enddo + elseif(config_lsm_scheme == 'sf_colm2024') then + call driver_lsm_colm2024(block%configs,mesh,state,time_lev,diag,diag_physics, & + sfc_input,itimestep,cellSolveThreadStart(1), & + cellSolveThreadEnd(nThreads)) endif call allocate_seaice(block%configs) @@ -372,7 +377,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) call deallocate_forall_physics(block%configs) block => block % next - end do + end do endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F new file mode 100644 index 0000000000..f475759bcd --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -0,0 +1,357 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atmphys_driver_lsm_colm2024 + use mpas_kind_types + use mpas_derived_types, only: dm_info + use mpas_pool_routines + + use mpas_atmphys_constants, only: R_d, R_v + use mpas_atmphys_manager, only: year, curr_julday + use mpas_atmphys_utilities, only: physics_error_fatal + use mpas_atmphys_vars, only: dt_pbl, xice_threshold + +#ifdef MPAS_COLM2024 + use MOD_Precision, only: colm_r8 => r8 + use MOD_CoLM_MPAS_Interface, only: colm_mpas_initialize_from_namelist, colm_mpas_ready, & + colm_mpas_set_element_forcing, & + colm_mpas_step, colm_mpas_get_element_surface, & + colm_mpas_finalize +#endif + + implicit none + private + public :: init_lsm_colm2024, driver_lsm_colm2024, finalize_lsm_colm2024 + + logical, save :: colm_first_step = .true. +#ifdef MPAS_COLM2024 + integer, allocatable, save :: colm_element_for_cell(:) +#endif + + contains + +!================================================================================================================= + subroutine init_lsm_colm2024(dminfo,configs,mesh,diag_physics,sfc_input) +!================================================================================================================= + + type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input +#ifdef MPAS_COLM2024 + logical :: colm_ready + integer :: colm_ierr + integer :: colm_mpas_comm + integer :: colm_patch_count + character(len=StrKIND),pointer:: config_colm2024_namelist + integer,pointer:: nCellsSolve + integer,dimension(:),pointer:: indexToCellID + real(kind=RKIND),dimension(:),pointer:: latCell, lonCell +#endif + +#ifdef MPAS_COLM2024 + call mpas_pool_get_config(configs,'config_colm2024_namelist',config_colm2024_namelist) + if(trim(config_colm2024_namelist) == 'none' .or. trim(config_colm2024_namelist) == '') then + call physics_error_fatal("config_lsm_scheme='sf_colm2024' requires config_colm2024_namelist.") + endif + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_array(mesh,'latCell',latCell) + call mpas_pool_get_array(mesh,'lonCell',lonCell) + call mpas_pool_get_array(mesh,'indexToCellID',indexToCellID) + if(allocated(colm_element_for_cell)) deallocate(colm_element_for_cell) + allocate(colm_element_for_cell(size(latCell))) + colm_element_for_cell(:) = 0 + +#ifdef MPAS_USE_MPI_F08 + colm_mpas_comm = dminfo % comm % mpi_val +#else + colm_mpas_comm = dminfo % comm +#endif + + call colm_mpas_initialize_from_namelist(trim(config_colm2024_namelist), colm_ierr, & + mpas_comm=colm_mpas_comm, & + mpas_lon_rad=real(lonCell(1:nCellsSolve), colm_r8), & + mpas_lat_rad=real(latCell(1:nCellsSolve), colm_r8), & + mpas_cell_id=indexToCellID(1:nCellsSolve), & + n_mpas_cells=nCellsSolve, & + cell_to_element=colm_element_for_cell(1:nCellsSolve)) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 initialization from config_colm2024_namelist failed.") + + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + + colm_first_step = .true. +#else + call colm2024_adapter_not_built +#endif + + end subroutine init_lsm_colm2024 + +!================================================================================================================= + subroutine driver_lsm_colm2024(configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) +!================================================================================================================= + + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + integer,intent(in):: time_lev + integer,intent(in):: itimestep + integer,intent(in):: its,ite +#ifdef MPAS_COLM2024 + logical :: colm_ready + integer :: colm_ierr + integer :: colm_patch_count + integer :: colm_idate(3) +#endif + +#ifdef MPAS_COLM2024 + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + if(.not. allocated(colm_element_for_cell)) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is not initialized.") + if(size(colm_element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & + "than the MPAS cell range.") + + call colm2024_push_mpas_forcing(configs, mesh, state, time_lev, diag, diag_physics, sfc_input, itimestep, its, ite) + + colm_idate(1) = year + colm_idate(2) = int(curr_julday) + 1 + colm_idate(3) = nint((curr_julday - real(int(curr_julday), RKIND)) * 86400._RKIND) + call colm_mpas_step(colm_idate, real(dt_pbl, colm_r8), colm_first_step, .true., .false., colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 driver returned before completing a land-surface step.") + + call colm2024_pull_mpas_surface(diag_physics, sfc_input, real(dt_pbl, colm_r8), its, ite) + colm_first_step = .false. +#else + call colm2024_adapter_not_built +#endif + + end subroutine driver_lsm_colm2024 + +!================================================================================================================= + subroutine finalize_lsm_colm2024() + !================================================================================================================= + +#ifdef MPAS_COLM2024 + integer :: colm_ierr + + call colm_mpas_finalize(colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.") +#endif + + end subroutine finalize_lsm_colm2024 + +#ifdef MPAS_COLM2024 +!================================================================================================================= + subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) +!================================================================================================================= + + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: sfc_input + integer,intent(in):: time_lev + integer,intent(in):: itimestep + integer,intent(in):: its,ite + + character(len=StrKIND),pointer:: config_convection_scheme, config_microp_scheme + integer,pointer:: index_qv + integer:: i, k + integer:: ierr + real(kind=colm_r8):: aerdep(14) + real(kind=colm_r8):: dt, grid_snow, hgt, oro, pbot, psrf, prc, prl, qair, rain, rhoair, snow, & + solld, soll, solsd, sols, spectral_sw, swdir, swdif, tair, uair, vair + real(kind=RKIND):: qv_cell + real(kind=RKIND),dimension(:),pointer:: glw, swddir, swddif, swvisdir, swvisdif, swnirdir, swnirdif + real(kind=RKIND),dimension(:),pointer:: surface_pressure, sr, xice, xland + real(kind=RKIND),dimension(:),pointer:: raincv, rainncv, snowncv, graupelncv + real(kind=RKIND),dimension(:,:),pointer:: exner, pressure_b, pressure_p, theta_m, u, v, zgrid + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_array(mesh,'zgrid',zgrid) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'pressure_base' ,pressure_b) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) + call mpas_pool_get_array(diag,'uReconstructZonal' ,u ) + call mpas_pool_get_array(diag,'uReconstructMeridional',v ) + call mpas_pool_get_array(diag,'surface_pressure',surface_pressure) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'swddir',swddir) + call mpas_pool_get_array(diag_physics,'swddif',swddif) + call mpas_pool_get_array(diag_physics,'swvisdir',swvisdir) + call mpas_pool_get_array(diag_physics,'swvisdif',swvisdif) + call mpas_pool_get_array(diag_physics,'swnirdir',swnirdir) + call mpas_pool_get_array(diag_physics,'swnirdif',swnirdif) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + call mpas_pool_get_array(sfc_input,'xland',xland) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + + dt = max(real(dt_pbl, colm_r8), 1._colm_r8) + aerdep(:) = 0._colm_r8 + + k = lbound(theta_m, 1) + do i = its,ite + if(colm_element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + + psrf = real(surface_pressure(i), colm_r8) + pbot = real(pressure_b(k,i) + pressure_p(k,i), colm_r8) + qv_cell = max(0._RKIND, scalars(index_qv,k,i)) + tair = real((theta_m(k,i) / (1._RKIND + R_v / R_d * qv_cell)) * exner(k,i), colm_r8) + qair = real(qv_cell / (1._RKIND + qv_cell), colm_r8) + uair = real(u(k,i), colm_r8) + vair = real(v(k,i), colm_r8) + hgt = 2._colm_r8 + if(ubound(zgrid, 1) >= k + 1) hgt = max(2._colm_r8, real(0.5_RKIND * (zgrid(k+1,i) - zgrid(k,i)), colm_r8)) + rhoair = max(0.1_colm_r8, pbot / (R_d * tair * (1._colm_r8 + 0.61_colm_r8 * qair))) + prc = 0._colm_r8 + prl = 0._colm_r8 + rain = 0._colm_r8 + snow = 0._colm_r8 + + if(config_convection_scheme .ne. 'off') then + prc = max(0._colm_r8, real(raincv(i), colm_r8) / dt) + rain = rain + prc + endif + if(config_microp_scheme .ne. 'off') then + prl = max(0._colm_r8, real(rainncv(i), colm_r8) / dt) + grid_snow = max(0._colm_r8, real(snowncv(i) + graupelncv(i), colm_r8) / dt) + if(grid_snow <= 0._colm_r8 .and. sr(i) > 0._RKIND) then + grid_snow = prl * min(1._colm_r8, real(sr(i), colm_r8)) + endif + snow = min(prl, grid_snow) + rain = rain + max(0._colm_r8, prl - snow) + endif + + swdir = max(0._colm_r8, real(swddir(i), colm_r8)) + swdif = max(0._colm_r8, real(swddif(i), colm_r8)) + sols = max(0._colm_r8, real(swvisdir(i), colm_r8)) + solsd = max(0._colm_r8, real(swvisdif(i), colm_r8)) + soll = max(0._colm_r8, real(swnirdir(i), colm_r8)) + solld = max(0._colm_r8, real(swnirdif(i), colm_r8)) + spectral_sw = sols + solsd + soll + solld + if(spectral_sw <= 0._colm_r8 .and. swdir + swdif > 0._colm_r8) then + sols = 0.5_colm_r8 * swdir + soll = 0.5_colm_r8 * swdir + solsd = 0.5_colm_r8 * swdif + solld = 0.5_colm_r8 * swdif + endif + oro = 1._colm_r8 + if(xland(i) >= 1.5_RKIND) oro = 0._colm_r8 + if(xice(i) >= xice_threshold) oro = 2._colm_r8 + + call colm_mpas_set_element_forcing(colm_element_for_cell(i), psrf * 420.e-6_colm_r8, & + psrf * 0.209_colm_r8, uair, vair, tair, qair, & + prc, prl, rain, snow, psrf, pbot, & + sols, soll, solsd, solld, & + real(glw(i), colm_r8), hgt, hgt, hgt, rhoair, 1000._colm_r8, & + aerdep, oro=oro, ierr=ierr) + if(ierr /= 0) call physics_error_fatal("Failed to pass MPAS forcing into CoLM2024.") + enddo + + end subroutine colm2024_push_mpas_forcing + +!================================================================================================================= + subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) +!================================================================================================================= + + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + real(kind=colm_r8),intent(in):: dt + integer,intent(in):: its,ite + + integer:: i + integer:: ierr + real(kind=colm_r8):: sensible, latent, evaporation, ground_heat, runoff + real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm + real(kind=colm_r8):: emissivity, roughness, albedo + real(kind=RKIND),dimension(:),pointer:: hfx, lh, qfx, grdflx, sfcrunoff, udrunoff + real(kind=RKIND),dimension(:),pointer:: sfc_albedo, sfc_emiss, z0, znt, qsfc, t2m, q2 + real(kind=RKIND),dimension(:),pointer:: skintemp + + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) + call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + + do i = its,ite + if(colm_element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + + call colm_mpas_get_element_surface(colm_element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & + emissivity, roughness, albedo, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.") + + hfx(i) = real(sensible, RKIND) + lh(i) = real(latent, RKIND) + qfx(i) = real(evaporation, RKIND) + grdflx(i) = real(ground_heat, RKIND) + sfcrunoff(i) = real(surface_runoff * dt, RKIND) + udrunoff(i) = real(subsurface_runoff * dt, RKIND) + skintemp(i) = real(skin_temp, RKIND) + t2m(i) = real(t2m_colm, RKIND) + qsfc(i) = real(q2m_colm, RKIND) + if(q2m_colm > 0._colm_r8 .and. q2m_colm < 1._colm_r8) then + q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) + else + q2(i) = real(q2m_colm, RKIND) + endif + sfc_emiss(i) = real(emissivity, RKIND) + z0(i) = real(roughness, RKIND) + znt(i) = real(roughness, RKIND) + if(albedo > 0._colm_r8 .and. albedo < 1._colm_r8) sfc_albedo(i) = real(albedo, RKIND) + enddo + + end subroutine colm2024_pull_mpas_surface +#endif + +!================================================================================================================= + subroutine colm2024_adapter_not_ready() +!================================================================================================================= + + call physics_error_fatal("CoLM2024 is linked, but CoLM landpatch/restart state has not been initialized " // & + "for this MPAS run.") + + end subroutine colm2024_adapter_not_ready + +!================================================================================================================= + subroutine colm2024_adapter_not_built() +!================================================================================================================= + + call physics_error_fatal("CoLM2024 requires building MPAS with COLM2024=true.") + + end subroutine colm2024_adapter_not_built + +!================================================================================================================= + end module mpas_atmphys_driver_lsm_colm2024 +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index 3a14275826..777260259d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -16,7 +16,7 @@ module mpas_atmphys_driver_radiation_sw use mpas_atmphys_camrad_init use mpas_atmphys_rrtmg_swinit use mpas_atmphys_vars - + !wrf physics: use module_mp_thompson_aerosols use module_ra_rrtmg_sw_aerosols @@ -142,7 +142,7 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(swupbc_p) ) allocate(swupbc_p(ims:ime,jms:jme) ) if(.not.allocated(swupt_p) ) allocate(swupt_p(ims:ime,jms:jme) ) if(.not.allocated(swuptc_p) ) allocate(swuptc_p(ims:ime,jms:jme) ) - + if(.not.allocated(rthratensw_p) ) allocate(rthratensw_p(ims:ime,kms:kme,jms:jme) ) radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -208,7 +208,7 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(pin_p) ) allocate(pin_p(num_oznlevels) ) if(.not.allocated(ozmixm_p) ) & allocate(ozmixm_p(ims:ime,1:num_oznlevels,jms:jme,num_months) ) - + if(.not.allocated(m_hybi_p) ) allocate(m_hybi_p(num_aerlevels) ) if(.not.allocated(m_psn_p) ) allocate(m_psn_p(ims:ime,jms:jme) ) if(.not.allocated(m_psp_p) ) allocate(m_psp_p(ims:ime,jms:jme) ) @@ -270,7 +270,7 @@ subroutine deallocate_radiation_sw(configs) if(allocated(swupbc_p) ) deallocate(swupbc_p ) if(allocated(swupt_p) ) deallocate(swupt_p ) if(allocated(swuptc_p) ) deallocate(swuptc_p ) - + if(allocated(rthratensw_p) ) deallocate(rthratensw_p ) radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -478,6 +478,10 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i swddir_p(i,j) = 0.0_RKIND swddni_p(i,j) = 0.0_RKIND swddif_p(i,j) = 0.0_RKIND + swvisdir_p(i,j) = 0.0_RKIND + swvisdif_p(i,j) = 0.0_RKIND + swnirdir_p(i,j) = 0.0_RKIND + swnirdif_p(i,j) = 0.0_RKIND enddo enddo @@ -525,7 +529,7 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo endif - case default + case default end select microp_select aerosol_select: select case(microp_scheme) @@ -717,9 +721,9 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !input arguments: type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend_physics - type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: radt_sw_scheme integer,intent(in):: its,ite @@ -729,7 +733,7 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !local pointers: real(kind=RKIND),dimension(:),pointer :: coszr,gsw,swcf,swdnb,swdnbc,swdnt,swdntc, & swupb,swupbc,swupt,swuptc,swddir,swddni, & - swddif + swddif,swvisdir,swvisdif,swnirdir,swnirdif real(kind=RKIND),dimension(:,:),pointer:: rthratensw !----------------------------------------------------------------------------------------------------------------- @@ -750,9 +754,13 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) call mpas_pool_get_array(diag_physics,'swddni' ,swddni ) call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) + call mpas_pool_get_array(diag_physics,'swvisdir' ,swvisdir ) + call mpas_pool_get_array(diag_physics,'swvisdif' ,swvisdif ) + call mpas_pool_get_array(diag_physics,'swnirdir' ,swnirdir ) + call mpas_pool_get_array(diag_physics,'swnirdif' ,swnirdif ) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) - call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) do j = jts,jte @@ -768,6 +776,10 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) swupbc(i) = swupbc_p(i,j) swupt(i) = swupt_p(i,j) swuptc(i) = swuptc_p(i,j) + swvisdir(i) = 0.0_RKIND + swvisdif(i) = 0.0_RKIND + swnirdir(i) = 0.0_RKIND + swnirdif(i) = 0.0_RKIND enddo radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -776,6 +788,10 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) swddir(i) = swddir_p(i,j) swddni(i) = swddni_p(i,j) swddif(i) = swddif_p(i,j) + swvisdir(i) = swvisdir_p(i,j) + swvisdif(i) = swvisdif_p(i,j) + swnirdir(i) = swnirdir_p(i,j) + swnirdif(i) = swnirdif_p(i,j) enddo case default end select radiation_sw_select @@ -894,7 +910,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !... convert the radiation time_step to minutes: radt = dt_radtsw/60. - + !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) case ("rrtmg_sw") @@ -938,6 +954,8 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p , & swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p , & swddir = swddir_p , swddni = swddni_p , swddif = swddif_p , & + swvisdir = swvisdir_p , swvisdif = swvisdif_p , swnirdir = swnirdir_p , & + swnirdif = swnirdif_p , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -949,7 +967,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic call camrad( dolw = .false. , dosw = .true. , & p_phy = pres_hyd_p , p8w = pres2_hyd_p , & pi_phy = pi_p , t_phy = t_p , & - z = zmid_p , dz8w = dz_p , & + z = zmid_p , dz8w = dz_p , & rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , & swupt = swupt_p , swuptc = swuptc_p , & swdnt = swdnt_p , swdntc = swdntc_p , & @@ -962,11 +980,11 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic swcf = swcf_p , lwcf = lwcf_p , & gsw = gsw_p , glw = glw_p , & olr = olrtoa_p , cemiss = cemiss_p , & - taucldc = taucldc_p , taucldi = taucldi_p , & - coszr = coszr_p , albedo = sfc_albedo_p , & - emiss = sfc_emiss_p , tsk = tsk_p , & + taucldc = taucldc_p , taucldi = taucldi_p , & + coszr = coszr_p , albedo = sfc_albedo_p , & + emiss = sfc_emiss_p , tsk = tsk_p , & xlat = xlat_p , xlong = xlon_p , & - rho_phy = rho_p , qv3d = qv_p , & + rho_phy = rho_p , qv3d = qv_p , & qc3d = qc_p , qr3d = qr_p , & qi3d = qi_p , qs3d = qs_p , & qg3d = qg_p , f_qc = f_qc , & @@ -974,7 +992,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic f_qs = f_qs , f_ice_phy = f_ice , & f_rain_phy = f_rain , cldfra = cldfrac_p , & xland = xland_p , xice = xice_p , & - num_months = num_months , levsiz = num_oznlevels , & + num_months = num_months , levsiz = num_oznlevels , & pin0 = pin_p , ozmixm = ozmixm_p , & paerlev = num_aerlevels , naer_c = num_aerosols , & m_psp = m_psp_p , m_psn = m_psn_p , & @@ -1026,11 +1044,11 @@ subroutine radconst(declin,solcon,julian,degrad,dpd) solcon=0. !obecl : obliquity = 23.5 degree. - + obecl=23.5*degrad sinob=sin(obecl) - -!calculate longitude of the sun from vernal equinox: + +!calculate longitude of the sun from vernal equinox: if(julian.ge.80.)sxlong=dpd*(julian-80.) if(julian.lt.80.)sxlong=dpd*(julian+285.) diff --git a/src/core_atmosphere/physics/mpas_atmphys_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index 5367d83286..b3d7a7b12b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -10,6 +10,7 @@ module mpas_atmphys_finalize use mpas_pool_routines use mpas_atmphys_lsm_noahmpfinalize,only: sf_noahmp_deallocate + use mpas_atmphys_driver_lsm_colm2024,only: finalize_lsm_colm2024 use module_mp_thompson use cires_ugwpv1_module @@ -46,7 +47,7 @@ subroutine atmphys_finalize(configs) character(len=StrKIND),pointer:: config_gwdo_scheme logical,pointer:: config_ngw_scheme -!----------------------------------------------------------------------------------------------------------------- +!----------------------------------------------------------------------------------------------------------------- call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme',config_microp_scheme) @@ -55,6 +56,8 @@ subroutine atmphys_finalize(configs) if(trim(config_lsm_scheme) == 'sf_noahmp') & call sf_noahmp_deallocate + if(trim(config_lsm_scheme) == 'sf_colm2024') & + call finalize_lsm_colm2024 if(trim(config_microp_scheme) == 'mp_thompson' .or. & trim(config_microp_scheme) == 'mp_thompson_aerosols') then @@ -72,7 +75,7 @@ subroutine mp_thompson_deallocate !call mpas_log_write('') !call mpas_log_write('--- enter subroutine mp_thompson_deallocate:') - if(allocated(tcg_racg) ) deallocate(tcg_racg ) + if(allocated(tcg_racg) ) deallocate(tcg_racg ) if(allocated(tmr_racg) ) deallocate(tmr_racg ) if(allocated(tcr_gacr) ) deallocate(tcr_gacr ) if(allocated(tmg_gacr) ) deallocate(tmg_gacr ) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 5183f5a974..4d4109b7c5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -23,6 +23,7 @@ module mpas_atmphys_init use mpas_atmphys_landuse use mpas_atmphys_o3climatology use mpas_atmphys_lsm_noahmpinit,only: init_lsm_noahmp + use mpas_atmphys_driver_lsm_colm2024,only: init_lsm_colm2024 use bl_ugwpv1_ngw, only: ugwpv1_ngw_init @@ -74,7 +75,7 @@ module mpas_atmphys_init ! * added call to subroutine init_lsm_noahmp to initialize the Noah-MP land surface scheme. ! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. ! * added initialization of the integer variable mp_top_level to the physics_init code. -! Bill Skamarock / 2025-10-17 +! Bill Skamarock / 2025-10-17 contains @@ -158,7 +159,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ type(MPAS_Time_Type):: currTime logical:: init_done - integer:: ierr,julday + integer:: ierr,julday integer:: iCell,iLag,k real(kind=RKIND):: layer_height @@ -420,6 +421,8 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) elseif(config_lsm_scheme .eq. 'sf_noahmp') then call init_lsm_noahmp(configs,mesh,clock,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + elseif(config_lsm_scheme .eq. 'sf_colm2024') then + call init_lsm_colm2024(dminfo,configs,mesh,diag_physics,sfc_input) endif endif @@ -437,7 +440,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ !initialization of longwave radiation processes: if we run the CAM radiation codes, the initia !lization of the longwave and shortwave parameterizations is the same, and needs to be called !only once: - if(config_radt_lw_scheme.ne.'off') then + if(config_radt_lw_scheme.ne.'off') then if(trim(config_radt_lw_scheme) .eq. 'cam_lw') then if(.not. init_done) then call init_radiation_lw(dminfo,configs,mesh,atm_input,diag,diag_physics,state,time_lev) diff --git a/src/core_atmosphere/physics/mpas_atmphys_packages.F b/src/core_atmosphere/physics/mpas_atmphys_packages.F index 5d32cb297e..228bb86243 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_packages.F +++ b/src/core_atmosphere/physics/mpas_atmphys_packages.F @@ -41,6 +41,7 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) logical,pointer:: cu_grell_freitas_in,cu_kain_fritsch_in,cu_ntiedtke_in logical,pointer:: bl_mynn_in,bl_ysu_in logical,pointer:: sf_noahmp_in + logical,pointer:: sf_colm2024_in integer :: ierr @@ -178,8 +179,11 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) nullify(sf_noahmp_in) call mpas_pool_get_package(packages,'sf_noahmp_inActive',sf_noahmp_in) + nullify(sf_colm2024_in) + call mpas_pool_get_package(packages,'sf_colm2024_inActive',sf_colm2024_in) - if(.not.associated(sf_noahmp_in)) then + if(.not.associated(sf_noahmp_in) .or. & + .not.associated(sf_colm2024_in)) then call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) call mpas_log_write('* Error while setting up packages for land surface options in atmosphere core.' , messageType=MPAS_LOG_ERR) call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) @@ -190,8 +194,12 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) if(config_lsm_scheme=='sf_noahmp') then sf_noahmp_in = .true. endif + if(config_lsm_scheme=='sf_colm2024') then + sf_colm2024_in = .true. + endif call mpas_log_write(' sf_noahmp_in = $l', logicArgs=(/sf_noahmp_in/)) + call mpas_log_write(' sf_colm2024_in = $l', logicArgs=(/sf_colm2024_in/)) call mpas_log_write('') @@ -200,6 +208,3 @@ end function atmphys_setup_packages !================================================================================================================= end module mpas_atmphys_packages !================================================================================================================= - - - diff --git a/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F b/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F index 6e3a84c394..bf830df049 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F @@ -115,6 +115,11 @@ subroutine atmphys_sfc_diagnostics(configs,mesh,diag,diag_physics,sfc_input,outp th2m(i) = t2m(i)*(P0/psfc(i))**rcp enddo + case("sf_colm2024") + do i = 1,nCellsSolve + th2m(i) = t2m(i)*(P0/psfc(i))**rcp + enddo + case default end select sf_select @@ -125,4 +130,3 @@ end subroutine atmphys_sfc_diagnostics !================================================================================================================= end module mpas_atmphys_sfc_diagnostics !================================================================================================================= - diff --git a/src/core_atmosphere/physics/physics_colm2024/.gitignore b/src/core_atmosphere/physics/physics_colm2024/.gitignore new file mode 100644 index 0000000000..c0d791f49b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/.gitignore @@ -0,0 +1,13 @@ + +.DS_Store +run/log_CaMa.txt +*.pyc +__pycache__ +*.o +*.mod +.vscode +.bld +lib +*.a +*.x +*.log diff --git a/src/core_atmosphere/physics/physics_colm2024/Makefile b/src/core_atmosphere/physics/physics_colm2024/Makefile new file mode 100644 index 0000000000..e19c22d2bb --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/Makefile @@ -0,0 +1,281 @@ +# Makefile for CoLM program + +include include/Makeoptions +HEADER = include/define.h + +INCLUDE_DIR = -Iinclude -I.bld/ -I${NETCDF_INC} +ifneq ($(strip $(PNETCDF)),) +INCLUDE_DIR += -I$(PNETCDF)/include +endif +ifneq ($(strip $(PNETCDF_INC)),) +INCLUDE_DIR += -I$(PNETCDF_INC) +endif +VPATH = include : share : mksrfdata : mkinidata \ + : main : main/HYDRO : main/BGC : main/URBAN : main/LULCC : main/DA \ + : main/ParaOpt : drivers/mpas : .bld + +.PHONY: all +all : mpas_objects + +.PHONY: mkdir_build +mkdir_build : + mkdir -p .bld + +OBJS_SHARED = \ + MOD_Precision.o \ + MOD_SPMD_Task.o \ + MOD_Namelist.o \ + MOD_Vars_Global.o \ + MOD_Const_Physical.o \ + MOD_Const_LC.o \ + MOD_Utils.o \ + MOD_IncompleteGamma.o \ + MOD_UserDefFun.o \ + MOD_TimeManager.o \ + MOD_Const_PFT.o \ + MOD_NetCDFSerial.o \ + MOD_Block.o \ + MOD_Grid.o \ + MOD_Pixel.o \ + MOD_DataType.o \ + MOD_NetCDFPoint.o \ + MOD_NetCDFBlock.o \ + MOD_CatchmentDataReadin.o \ + MOD_5x5DataReadin.o \ + MOD_Mesh.o \ + MOD_Pixelset.o \ + MOD_NetCDFVector.o \ + MOD_RangeCheck.o \ + MOD_SpatialMapping.o \ + MOD_WorkerPushData.o \ + MOD_AggregationRequestData.o \ + MOD_PixelsetShared.o \ + MOD_LandElm.o \ + MOD_LandHRU.o \ + MOD_LandPatch.o \ + MOD_Land2mWMO.o \ + MOD_LandCrop.o \ + MOD_LandPFT.o \ + MOD_LandUrban.o \ + MOD_Urban_Const_LCZ.o \ + MOD_SingleSrfdata.o \ + MOD_SrfdataDiag.o \ + MOD_SrfdataRestart.o \ + MOD_ElmVector.o \ + MOD_HRUVector.o \ + MOD_MeshFilter.o \ + MOD_RegionClip.o + +${OBJS_SHARED} : %.o : %.F90 ${HEADER} + ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld + +OBJS_SHARED_T = $(addprefix .bld/,${OBJS_SHARED}) + +OBJS_BASIC = \ + MOD_Vector_ReadWrite.o \ + MOD_dataSpec_PDB.o \ + MOD_tav_abs.o \ + MOD_prospect_DB.o \ + MOD_Catch_BasinNetwork.o \ + MOD_Catch_Vars_TimeVariables.o \ + MOD_Catch_Vars_1DFluxes.o \ + MOD_Grid_RiverLakeNetwork.o \ + MOD_Grid_Reservoir.o \ + MOD_Grid_RiverLakeTimeVars.o \ + MOD_BGC_Vars_1DFluxes.o \ + MOD_BGC_Vars_1DPFTFluxes.o \ + MOD_BGC_Vars_PFTimeVariables.o \ + MOD_BGC_Vars_TimeInvariants.o \ + MOD_BGC_Vars_TimeVariables.o \ + MOD_Urban_Vars_1DFluxes.o \ + MOD_Urban_Vars_TimeVariables.o \ + MOD_Urban_Vars_TimeInvariants.o\ + MOD_DA_Vars_1DFluxes.o \ + MOD_Vars_TimeInvariants.o \ + MOD_DA_Vars_TimeVariables.o \ + MOD_Vars_TimeVariables.o \ + MOD_Vars_1DPFTFluxes.o \ + MOD_Vars_1DFluxes.o \ + MOD_Vars_1DForcing.o \ + MOD_Hydro_SoilFunction.o \ + MOD_Hydro_SoilWater.o \ + MOD_Eroot.o \ + MOD_Qsadv.o \ + MOD_LAIEmpirical.o \ + MOD_LAIReadin.o \ + MOD_CropReadin.o \ + MOD_NitrifData.o \ + MOD_NdepData.o \ + MOD_FireData.o \ + MOD_OrbCoszen.o \ + MOD_OrbCosazi.o \ + MOD_HighRes_Parameters.o \ + MOD_3DCanopyRadiation.o \ + MOD_Aerosol.o \ + MOD_SnowSnicar.o \ + MOD_Albedo.o \ + MOD_SnowSnicar_HiRes.o \ + MOD_Albedo_HiRes.o \ + MOD_SnowFraction.o \ + MOD_Urban_LAIReadin.o \ + MOD_Urban_Shortwave.o \ + MOD_Urban_Albedo.o \ + MOD_MonthlyinSituCO2MaunaLoa.o \ + MOD_PercentagesPFTReadin.o \ + MOD_LakeDepthReadin.o \ + MOD_DBedrockReadin.o \ + MOD_SoilColorRefl.o \ + MOD_SoilParametersReadin.o \ + MOD_SoilTextureReadin.o \ + MOD_HtopReadin.o \ + MOD_UrbanReadin.o \ + MOD_BGC_CNSummary.o \ + MOD_IniTimeVariable.o \ + MOD_UrbanIniTimeVariable.o \ + MOD_ElementNeighbour.o \ + MOD_Catch_HillslopeNetwork.o \ + MOD_Catch_RiverLakeNetwork.o \ + MOD_Catch_Reservoir.o \ + MOD_VicParaReadin.o \ + MOD_Initialize.o + + +$(OBJS_BASIC) : %.o : %.F90 ${HEADER} ${OBJS_SHARED} + ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld + +OBJS_BASIC_T = $(addprefix .bld/,${OBJS_BASIC}) + +OBJS_MAIN = \ + MOD_Catch_HillslopeFlow.o \ + MOD_Catch_SubsurfaceFlow.o \ + MOD_Catch_RiverLakeFlow.o \ + MOD_Catch_Hist.o \ + MOD_Catch_WriteParameters.o \ + MOD_BGC_CNCStateUpdate1.o \ + MOD_BGC_CNCStateUpdate2.o \ + MOD_BGC_CNCStateUpdate3.o \ + MOD_BGC_CNNStateUpdate1.o \ + MOD_BGC_CNNStateUpdate2.o \ + MOD_BGC_CNNStateUpdate3.o \ + MOD_BGC_Soil_BiogeochemNStateUpdate1.o \ + MOD_BGC_Soil_BiogeochemNitrifDenitrif.o \ + MOD_BGC_Soil_BiogeochemCompetition.o \ + MOD_BGC_Soil_BiogeochemDecompCascadeBGC.o \ + MOD_BGC_Soil_BiogeochemDecomp.o \ + MOD_BGC_Soil_BiogeochemLittVertTransp.o \ + MOD_BGC_Soil_BiogeochemNLeaching.o \ + MOD_BGC_Soil_BiogeochemPotential.o \ + MOD_BGC_Soil_BiogeochemVerticalProfile.o \ + MOD_BGC_Veg_CNGapMortality.o \ + MOD_BGC_Veg_CNGResp.o \ + MOD_BGC_Veg_CNMResp.o \ + MOD_BGC_Daylength.o \ + MOD_BGC_Veg_CNPhenology.o \ + MOD_BGC_Veg_NutrientCompetition.o \ + MOD_BGC_Veg_CNVegStructUpdate.o \ + MOD_BGC_CNAnnualUpdate.o \ + MOD_BGC_CNZeroFluxes.o \ + MOD_BGC_CNBalanceCheck.o \ + MOD_BGC_CNSASU.o \ + MOD_BGC_Veg_CNNDynamics.o \ + MOD_BGC_Veg_CNFireBase.o \ + MOD_BGC_Veg_CNFireLi2016.o \ + MOD_Vars_2DForcing.o \ + MOD_UserSpecifiedForcing.o \ + MOD_ForcingDownscaling.o \ + MOD_Forcing.o \ + MOD_DA_TWS.o \ + MOD_DA_Const.o \ + MOD_DA_RTM.o \ + MOD_DA_EnKF.o \ + MOD_DA_SM.o \ + MOD_DA_Ensemble.o \ + MOD_DA_Main.o \ + MOD_Opt_Baseflow.o \ + MOD_ParameterOptimization.o \ + MOD_AssimStomataConductance.o \ + MOD_PlantHydraulic.o \ + MOD_FrictionVelocity.o \ + MOD_TurbulenceLEddy.o \ + MOD_Ozone.o \ + MOD_CanopyLayerProfile.o \ + MOD_LeafTemperature.o \ + MOD_LeafTemperaturePC.o \ + MOD_SoilThermalParameters.o \ + MOD_Hydro_VIC_Variables.o \ + MOD_Hydro_VIC.o \ + MOD_Runoff.o \ + MOD_SoilSnowHydrology.o \ + MOD_SnowLayersCombineDivide.o \ + MOD_PhaseChange.o \ + MOD_Glacier.o \ + MOD_Lake.o \ + MOD_SimpleOcean.o \ + MOD_GroundFluxes.o \ + MOD_GroundTemperature.o \ + MOD_LeafInterception.o \ + MOD_NetSolar.o \ + MOD_NetSolar_Hyper.o \ + MOD_WetBulb.o \ + MOD_RainSnowTemp.o \ + MOD_SoilSurfaceResistance.o \ + MOD_NewSnow.o \ + MOD_Thermal.o \ + MOD_Vars_1DAccFluxes.o \ + MOD_Irrigation.o \ + MOD_BGC_driver.o \ + MOD_HistWriteBack.o \ + MOD_HistGridded.o \ + MOD_HistVector.o \ + MOD_HistSingle.o \ + MOD_Grid_RiverLakeHist.o \ + MOD_Hist.o \ + MOD_CheckEquilibrium.o \ + MOD_LightningData.o \ + MOD_Catch_LateralFlow.o \ + MOD_Grid_RiverLakeFlow.o \ + MOD_Urban_Longwave.o \ + MOD_Urban_NetSolar.o \ + MOD_Urban_Flux.o \ + MOD_Urban_GroundFlux.o \ + MOD_Urban_RoofFlux.o \ + MOD_Urban_RoofTemperature.o \ + MOD_Urban_WallTemperature.o \ + MOD_Urban_PerviousTemperature.o \ + MOD_Urban_ImperviousTemperature.o \ + MOD_Urban_Hydrology.o \ + MOD_Urban_BEM.o \ + MOD_Urban_LUCY.o \ + MOD_Urban_Thermal.o \ + CoLMMAIN_Urban.o \ + MOD_Lulcc_Vars_TimeInvariants.o \ + MOD_Lulcc_Vars_TimeVariables.o \ + MOD_Lulcc_TransferTraceReadin.o \ + MOD_Lulcc_MassEnergyConserve.o \ + MOD_Lulcc_Initialize.o \ + MOD_Lulcc_Driver.o \ + CoLMDRIVER.o \ + MOD_CoLM_MPAS_Interface.o \ + CoLMMAIN.o + +$(OBJS_MAIN) : %.o : %.F90 ${HEADER} ${OBJS_SHARED} ${OBJS_BASIC} + ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld + +MOD_Urban_Thermal.o: MOD_Urban_Flux.o +MOD_Grid_RiverLakeTimeVars.o: MOD_Grid_RiverLakeNetwork.o MOD_Grid_Reservoir.o +MOD_Grid_RiverLakeFlow.o: MOD_Grid_RiverLakeHist.o + +OBJS_MPAS_T = $(addprefix .bld/,${OBJS_SHARED} ${OBJS_BASIC} ${OBJS_MAIN}) + +.PHONY: mpas_objects +mpas_objects : mkdir_build ${HEADER} ${OBJS_SHARED} ${OBJS_BASIC} ${OBJS_MAIN} + @echo '' + @echo 'staging CoLM objects for MPAS physics library >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>' + rm -rf .mpas + mkdir -p .mpas + cd .mpas && for obj in ${OBJS_MPAS_T}; do ln -sf ../$$obj ./; done + +.PHONY: clean +clean : + rm -rf .bld + rm -rf .mpas diff --git a/src/core_atmosphere/physics/physics_colm2024/README.md b/src/core_atmosphere/physics/physics_colm2024/README.md new file mode 100644 index 0000000000..3f17afd572 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/README.md @@ -0,0 +1,3 @@ +# The Common Land Model Version 202X (CoLM202X) + +[![Build_CoLM202X_gnu](https://github.com/CoLM-SYSU/CoLM202X/actions/workflows/build_CoLM_gnu.yml/badge.svg)](https://github.com/CoLM-SYSU/CoLM202X/actions/workflows/build_CoLM_gnu.yml) diff --git a/src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation b/src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation new file mode 100644 index 0000000000..a95c4d07d1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation @@ -0,0 +1 @@ +Evaluation script for CoLM can be down load from github: https://github.com/CoLM-SYSU/CoLM-Evaluation.git diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 new file mode 100644 index 0000000000..cfa36ee200 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -0,0 +1,1057 @@ +#include + +MODULE MOD_CoLM_MPAS_Interface + + USE MOD_Precision + USE MOD_LandPatch, only: numpatch, landpatch, elm_patch + USE MOD_Vars_Global, only: spval + USE MOD_Vars_1DForcing, only: forc_pco2m, forc_po2m, forc_us, forc_vs, forc_t, forc_q, & + forc_prc, forc_prl, forc_rain, forc_snow, forc_psrf, forc_pbot, forc_sols, forc_soll, & + forc_solsd, forc_solld, forc_frl, forc_swrad, forc_hgt_u, forc_hgt_t, forc_hgt_q, & + forc_rhoair, forc_ozone, forc_hpbl, forc_aerdep +#ifdef HYPERSPECTRAL + USE MOD_Vars_1DForcing, only: forc_solarin +#endif + USE MOD_Vars_1DFluxes, only: oroflag, fsena, lfevpa, fevpa, fgrnd, rnof, rsur, rsub + USE MOD_Vars_TimeInvariants, only: patchlatr, patchlonr, patchmask + USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, emis, z0m, alb + USE MOD_TimeManager, only: timestamp + + IMPLICIT NONE + PRIVATE + + PUBLIC :: colm_mpas_initialize_from_namelist + PUBLIC :: colm_mpas_finalize + PUBLIC :: colm_mpas_ready + PUBLIC :: colm_mpas_find_patch + PUBLIC :: colm_mpas_find_element + PUBLIC :: colm_mpas_set_forcing + PUBLIC :: colm_mpas_set_element_forcing + PUBLIC :: colm_mpas_step + PUBLIC :: colm_mpas_get_surface + PUBLIC :: colm_mpas_get_element_surface + + logical, save :: colm_mpas_initialized = .false. + real(r8), allocatable, save :: colm_mpas_elm_lonr(:) + real(r8), allocatable, save :: colm_mpas_elm_latr(:) + character(len=256), save :: colm_mpas_casename = '' + character(len=256), save :: colm_mpas_dir_restart = '' + integer, save :: colm_mpas_lc_year = -1 + integer, save :: colm_mpas_last_idate(3) = -1 + integer, save :: colm_mpas_last_restart_idate(3) = -1 + type(timestamp), save :: colm_mpas_ptstamp + type(timestamp), save :: colm_mpas_etstamp + logical, save :: colm_mpas_restart_ready = .false. + + INTERFACE + SUBROUTINE CoLMDRIVER(idate,deltim,dolai,doalb,dosst,oro) + USE MOD_Precision + USE MOD_LandPatch, only: numpatch + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: dolai, doalb, dosst + real(r8), intent(inout) :: oro(numpatch) + END SUBROUTINE CoLMDRIVER + END INTERFACE + +CONTAINS + + SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_lon_rad, mpas_lat_rad, & + mpas_cell_id, n_mpas_cells, cell_to_element) + USE MOD_Namelist, only: read_namelist, DEF_CASE_NAME, DEF_dir_landdata, & + DEF_dir_restart, DEF_LC_YEAR, DEF_simulation_time, DEF_USE_SNICAR, & + DEF_file_snowoptics, DEF_file_snowaging, DEF_forcing, DEF_Reservoir_Method, & + DEF_WRST_FREQ, DEF_HIST_FREQ, DEF_HIST_WriteBack + USE MOD_Vars_Global, only: Init_GlobalVars + USE MOD_SPMD_Task, only: spmd_init + USE MOD_Const_LC, only: Init_LC_Const + USE MOD_Const_PFT, only: Init_PFT_Const, rho_p, tau_p + USE MOD_TimeManager, only: initimetype, monthday2julian, adj2begin, adj2end + USE MOD_Block, only: gblock + USE MOD_Pixel, only: pixel + USE MOD_Mesh, only: numelm + USE MOD_LandElm, only: landelm +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: landpft, numpft, map_patch_to_pft +#endif + USE MOD_SrfdataRestart, only: mesh_load_from_file, pixelset_load_from_file + USE MOD_Vars_TimeInvariants, only: allocate_TimeInvariants, READ_TimeInvariants + USE MOD_Vars_TimeVariables, only: allocate_TimeVariables, READ_TimeVariables + USE MOD_Vars_1DForcing, only: allocate_1D_Forcing + USE MOD_Vars_1DFluxes, only: allocate_1D_Fluxes +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeNetwork, only: build_riverlake_network + USE MOD_Grid_Reservoir, only: reservoir_init + USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow_init +#endif +#ifdef HYPERSPECTRAL + USE MOD_SnowSnicar_HiRes, only: SnowAge_init, SnowOptics_init + USE MOD_HighRes_Parameters, only: flux_frac_init, leaf_property_init, & + get_water_optical_properties +#else + USE MOD_SnowSnicar, only: SnowAge_init, SnowOptics_init +#endif + character(len=*), intent(in) :: nlfile + integer, intent(out) :: ierr + integer, intent(in), optional :: mpas_comm + real(r8), intent(in), optional :: mpas_lon_rad(:) + real(r8), intent(in), optional :: mpas_lat_rad(:) + integer, intent(in), optional :: mpas_cell_id(:) + integer, intent(in), optional :: n_mpas_cells + integer, intent(out), optional :: cell_to_element(:) + + character(len=256) :: casename + character(len=256) :: dir_landdata + character(len=256) :: dir_restart + integer :: lc_year + integer :: sdate(3) + integer :: jdate(3) + integer :: s_julian + integer :: p_julian + integer :: e_julian + integer :: n_mpas + integer :: i + integer*8, allocatable :: mpas_cell_id_i8(:) + + ierr = 1 + IF (colm_mpas_initialized) THEN + ierr = 0 + RETURN + ENDIF + + IF (present(mpas_comm)) THEN + CALL spmd_init(mpas_comm) + ELSE + CALL spmd_init() + ENDIF + + CALL read_namelist(trim(nlfile)) +#ifdef MPAS_EMBEDDED_COLM + CALL colm_mpas_check_embedded_io(ierr) + IF (ierr /= 0) RETURN +#endif + + casename = DEF_CASE_NAME + dir_landdata = DEF_dir_landdata + dir_restart = DEF_dir_restart + lc_year = DEF_LC_YEAR + + CALL initimetype(DEF_simulation_time%greenwich) + CALL monthday2julian(DEF_simulation_time%start_year, DEF_simulation_time%start_month, & + DEF_simulation_time%start_day, s_julian) + CALL monthday2julian(DEF_simulation_time%spinup_year, DEF_simulation_time%spinup_month, & + DEF_simulation_time%spinup_day, p_julian) + CALL monthday2julian(DEF_simulation_time%end_year, DEF_simulation_time%end_month, & + DEF_simulation_time%end_day, e_julian) + sdate(1) = DEF_simulation_time%start_year + sdate(2) = s_julian + sdate(3) = DEF_simulation_time%start_sec + + colm_mpas_casename = casename + colm_mpas_dir_restart = dir_restart + colm_mpas_lc_year = lc_year + colm_mpas_ptstamp%year = DEF_simulation_time%spinup_year + colm_mpas_ptstamp%day = p_julian + colm_mpas_ptstamp%sec = DEF_simulation_time%spinup_sec + colm_mpas_etstamp%year = DEF_simulation_time%end_year + colm_mpas_etstamp%day = e_julian + colm_mpas_etstamp%sec = DEF_simulation_time%end_sec + colm_mpas_last_idate(:) = -1 + colm_mpas_last_restart_idate(:) = -1 + colm_mpas_restart_ready = .true. + + CALL Init_GlobalVars + CALL Init_LC_Const + CALL Init_PFT_Const + + n_mpas = 0 + IF (present(n_mpas_cells)) THEN + IF (.not. present(mpas_lon_rad)) RETURN + IF (.not. present(mpas_lat_rad)) RETURN + IF (.not. present(mpas_cell_id)) RETURN + IF (.not. present(cell_to_element)) RETURN + + n_mpas = n_mpas_cells + IF (n_mpas < 1) RETURN + IF (size(mpas_lon_rad) < n_mpas) RETURN + IF (size(mpas_lat_rad) < n_mpas) RETURN + IF (size(mpas_cell_id) < n_mpas) RETURN + IF (size(cell_to_element) < n_mpas) RETURN + + allocate(mpas_cell_id_i8(n_mpas)) + DO i = 1, n_mpas + mpas_cell_id_i8(i) = int(mpas_cell_id(i), 8) + ENDDO + ENDIF + + CALL pixel%load_from_file(dir_landdata) + CALL gblock%load_from_file(dir_landdata) + + IF (n_mpas > 0) THEN + CALL colm_mpas_claim_owned_blocks(mpas_lon_rad, mpas_lat_rad, n_mpas, ierr) + IF (ierr /= 0) RETURN + + CALL mesh_load_from_file(dir_landdata, lc_year, subset_eindex=mpas_cell_id_i8) + CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year, & + subset_eindex=mpas_cell_id_i8) + CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year, & + subset_eindex=mpas_cell_id_i8) + ELSE + CALL mesh_load_from_file(dir_landdata, lc_year) + CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year) + CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (n_mpas > 0) THEN + CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, & + subset_eindex=mpas_cell_id_i8) + ELSE + CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year) + ENDIF +#endif + + IF (n_mpas > 0) THEN + CALL colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cell_id, & + n_mpas, cell_to_element, ierr) + IF (ierr /= 0) RETURN + ENDIF + + CALL elm_patch%build(landelm, landpatch, use_frac = .true.) + +#ifdef GridRiverLakeFlow +#ifdef MPAS_EMBEDDED_COLM + CALL colm_mpas_check_embedded_riverlake(ierr) + IF (ierr /= 0) RETURN +#endif + CALL build_riverlake_network() + IF (DEF_Reservoir_Method > 0) CALL reservoir_init() +#endif + + IF (allocated(colm_mpas_elm_lonr)) deallocate(colm_mpas_elm_lonr) + IF (allocated(colm_mpas_elm_latr)) deallocate(colm_mpas_elm_latr) + IF (numelm > 0) THEN + allocate(colm_mpas_elm_lonr(numelm)) + allocate(colm_mpas_elm_latr(numelm)) + CALL landelm%get_lonlat_radian(colm_mpas_elm_lonr, colm_mpas_elm_latr) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL map_patch_to_pft +#endif + + CALL adj2end(sdate) + jdate = sdate + CALL adj2begin(jdate) + + CALL allocate_TimeInvariants() + CALL READ_TimeInvariants(lc_year, casename, dir_restart) + CALL allocate_TimeVariables() + CALL READ_TimeVariables(jdate, lc_year, casename, dir_restart) + + IF (DEF_USE_SNICAR) THEN + CALL SnowOptics_init(DEF_file_snowoptics) + CALL SnowAge_init(DEF_file_snowaging) + ENDIF + +#ifdef HYPERSPECTRAL + CALL flux_frac_init() + CALL leaf_property_init(rho_p, tau_p) + CALL get_water_optical_properties() +#endif + + CALL allocate_1D_Forcing() + CALL allocate_1D_Fluxes() + DEF_forcing%has_missing_value = .false. + +#ifdef GridRiverLakeFlow + CALL grid_riverlake_flow_init() +#endif + + colm_mpas_initialized = .true. + ierr = 0 + END SUBROUTINE colm_mpas_initialize_from_namelist + +#if defined(GridRiverLakeFlow) && defined(MPAS_EMBEDDED_COLM) + SUBROUTINE colm_mpas_check_embedded_riverlake(ierr) + USE MOD_Namelist, only: DEF_USE_SEDIMENT + USE MOD_SPMD_Task, only: p_np_glb, p_is_master + integer, intent(out) :: ierr + + ierr = 0 + IF (DEF_USE_SEDIMENT) THEN + IF (p_is_master) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode does not support GridRiverLakeSediment yet.' + write(*,'(A)') 'Set DEF_USE_SEDIMENT = .false. until sediment routing is migrated to MPAS-owned rank decomposition.' + ENDIF + ierr = 1 + RETURN + ENDIF + IF (p_np_glb > 1 .and. p_is_master) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded GridRiverLakeFlow uses MPAS communicator ranks for distributed routing.' + write(*,'(A)') 'CoLM standalone master/io/worker MPI pools and replicated full-river-network fallback are disabled.' + ENDIF + END SUBROUTINE colm_mpas_check_embedded_riverlake +#endif + + SUBROUTINE colm_mpas_check_embedded_io(ierr) + USE MOD_Namelist, only: DEF_HIST_FREQ, DEF_HIST_WriteBack, USE_SITE_HistWriteBack + USE MOD_SPMD_Task, only: p_is_master + integer, intent(out) :: ierr + + ierr = 0 + USE_SITE_HistWriteBack = .false. + IF ((trim(adjustl(DEF_HIST_FREQ)) /= 'none' .and. trim(adjustl(DEF_HIST_FREQ)) /= 'NONE') .or. & + DEF_HIST_WriteBack) THEN + IF (p_is_master) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode currently writes fluxes through MPAS streams.' + write(*,'(A)') 'Disable CoLM DEF_HIST_FREQ/DEF_HIST_WriteBack; CoLM restart files remain supported for patch/PFT state.' + write(*,'(A)') 'CoLM USE_SITE_HistWriteBack is forced off in MPAS embedded mode.' + ENDIF + ierr = 1 + ENDIF + END SUBROUTINE colm_mpas_check_embedded_io + + SUBROUTINE colm_mpas_claim_owned_blocks(mpas_lon_rad, mpas_lat_rad, n_mpas_cells, ierr) + USE MOD_Block, only: gblock + USE MOD_SPMD_Task, only: p_iam_glb + USE MOD_Utils, only: normalize_longitude, find_nearest_south, find_nearest_west + real(r8), intent(in) :: mpas_lon_rad(:) + real(r8), intent(in) :: mpas_lat_rad(:) + integer, intent(in) :: n_mpas_cells + integer, intent(out) :: ierr + + logical, allocatable :: keep_block(:,:) + integer :: i + integer :: iblk + integer :: jblk + integer :: iblkme + real(r8) :: lon_deg + real(r8) :: lat_deg + real(r8), parameter :: rad_to_deg = 57.295779513082320876798154814105_r8 + + ierr = 1 + IF (n_mpas_cells < 1) RETURN + IF (.not. allocated(gblock%pio)) RETURN + IF (.not. allocated(gblock%lon_w)) RETURN + IF (.not. allocated(gblock%lat_s)) RETURN + + allocate(keep_block(gblock%nxblk, gblock%nyblk)) + keep_block = .false. + + DO i = 1, n_mpas_cells + lon_deg = mpas_lon_rad(i) * rad_to_deg + lat_deg = mpas_lat_rad(i) * rad_to_deg + CALL normalize_longitude(lon_deg) + lat_deg = max(-90._r8, min(90._r8, lat_deg)) + + iblk = find_nearest_west(lon_deg, gblock%nxblk, gblock%lon_w) + jblk = find_nearest_south(lat_deg, gblock%nyblk, gblock%lat_s) + IF (iblk >= 1 .and. iblk <= gblock%nxblk .and. jblk >= 1 .and. jblk <= gblock%nyblk) THEN + keep_block(iblk,jblk) = .true. + ENDIF + ENDDO + + gblock%pio(:,:) = -1 + WHERE (keep_block) + gblock%pio = p_iam_glb + END WHERE + + IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) + IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) + gblock%nblkme = count(keep_block) + IF (gblock%nblkme < 1) THEN + deallocate(keep_block) + RETURN + ENDIF + + allocate(gblock%xblkme(gblock%nblkme)) + allocate(gblock%yblkme(gblock%nblkme)) + iblkme = 0 + DO iblk = 1, gblock%nxblk + DO jblk = 1, gblock%nyblk + IF (keep_block(iblk,jblk)) THEN + iblkme = iblkme + 1 + gblock%xblkme(iblkme) = iblk + gblock%yblkme(iblkme) = jblk + ENDIF + ENDDO + ENDDO + + deallocate(keep_block) + ierr = 0 + END SUBROUTINE colm_mpas_claim_owned_blocks + + SUBROUTINE colm_mpas_finalize(ierr) +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow_final +#endif + USE MOD_SPMD_Task, only: spmd_exit + integer, intent(out) :: ierr + + ierr = 0 + IF (.not. colm_mpas_initialized) RETURN + + IF (colm_mpas_last_idate(1) > 0) THEN + CALL colm_mpas_write_restart_if_due(colm_mpas_last_idate, 0._r8, .true., ierr) + IF (ierr /= 0) RETURN + ENDIF + +#ifdef GridRiverLakeFlow + CALL grid_riverlake_flow_final() +#endif + + IF (allocated(colm_mpas_elm_lonr)) deallocate(colm_mpas_elm_lonr) + IF (allocated(colm_mpas_elm_latr)) deallocate(colm_mpas_elm_latr) + CALL spmd_exit() + colm_mpas_initialized = .false. + colm_mpas_restart_ready = .false. + END SUBROUTINE colm_mpas_finalize + + SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cell_id, & + n_mpas_cells, cell_to_element, ierr) + USE MOD_LandElm, only: landelm + USE MOD_LandPatch, only: landpatch, numpatch + USE MOD_Mesh, only: numelm +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: landpft, numpft +#endif + real(r8), intent(in) :: mpas_lon_rad(:) + real(r8), intent(in) :: mpas_lat_rad(:) + integer, intent(in) :: mpas_cell_id(:) + integer, intent(in) :: n_mpas_cells + integer, intent(out) :: cell_to_element(:) + integer, intent(out) :: ierr + + logical, allocatable :: keep_elm(:) + logical, allocatable :: keep_patch(:) + logical, allocatable :: keep_pft(:) + integer, allocatable :: old_to_new(:) + integer, allocatable :: old_element_for_cell(:) + real(r8), allocatable :: all_lon(:) + real(r8), allocatable :: all_lat(:) + integer :: i + integer :: old_element + integer :: packed_count + real(r8) :: match_dist2 + real(r8), parameter :: max_coord_match_dist2 = 1.e-10_r8 + + ierr = 1 + IF (n_mpas_cells < 1) RETURN + IF (numelm < 1) RETURN + IF (landelm%nset < 1) RETURN + + allocate(keep_elm(numelm)) + allocate(old_to_new(numelm)) + allocate(old_element_for_cell(n_mpas_cells)) + allocate(all_lon(numelm)) + allocate(all_lat(numelm)) + + keep_elm = .false. + old_to_new = 0 + CALL landelm%get_lonlat_radian(all_lon, all_lat) + + DO i = 1, n_mpas_cells + CALL colm_mpas_find_element_by_eindex(mpas_cell_id(i), old_element) + IF (old_element <= 0) THEN + match_dist2 = huge(match_dist2) + CALL colm_mpas_find_element_in_arrays(mpas_lon_rad(i), mpas_lat_rad(i), & + all_lon, all_lat, old_element, match_dist2) + IF (match_dist2 > max_coord_match_dist2) old_element = 0 + ENDIF + IF (old_element <= 0 .or. old_element > numelm) RETURN + + old_element_for_cell(i) = old_element + keep_elm(old_element) = .true. + ENDDO + + packed_count = 0 + DO i = 1, numelm + IF (keep_elm(i)) THEN + packed_count = packed_count + 1 + old_to_new(i) = packed_count + ENDIF + ENDDO + IF (packed_count < 1) RETURN + + CALL colm_mpas_pack_mesh(keep_elm, old_to_new) + CALL landelm%pset_pack(keep_elm, packed_count) + CALL colm_mpas_remap_pixelset_ielm(landelm, old_to_new, ierr) + IF (ierr /= 0) RETURN + + IF (landpatch%nset > 0) THEN + allocate(keep_patch(landpatch%nset)) + DO i = 1, landpatch%nset + keep_patch(i) = landpatch%ielm(i) >= 1 .and. landpatch%ielm(i) <= size(old_to_new) + IF (keep_patch(i)) keep_patch(i) = old_to_new(landpatch%ielm(i)) > 0 + ENDDO + CALL landpatch%pset_pack(keep_patch, numpatch) + CALL colm_mpas_remap_pixelset_ielm(landpatch, old_to_new, ierr) + deallocate(keep_patch) + IF (ierr /= 0) RETURN + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (landpft%nset > 0) THEN + allocate(keep_pft(landpft%nset)) + DO i = 1, landpft%nset + keep_pft(i) = landpft%ielm(i) >= 1 .and. landpft%ielm(i) <= size(old_to_new) + IF (keep_pft(i)) keep_pft(i) = old_to_new(landpft%ielm(i)) > 0 + ENDDO + CALL landpft%pset_pack(keep_pft, numpft) + CALL colm_mpas_remap_pixelset_ielm(landpft, old_to_new, ierr) + deallocate(keep_pft) + IF (ierr /= 0) RETURN + ENDIF +#endif + + DO i = 1, n_mpas_cells + cell_to_element(i) = old_to_new(old_element_for_cell(i)) + IF (cell_to_element(i) <= 0) RETURN + ENDDO + + ierr = 0 + END SUBROUTINE colm_mpas_restrict_to_mpas_cells + + SUBROUTINE colm_mpas_pack_mesh(keep_elm, old_to_new) + USE MOD_Mesh, only: irregular_elm_type, mesh, numelm, copy_elm + logical, intent(in) :: keep_elm(:) + integer, intent(in) :: old_to_new(:) + + type(irregular_elm_type), allocatable :: packed_mesh(:) + integer :: old_elm + integer :: new_elm + integer :: packed_count + + packed_count = count(keep_elm) + allocate(packed_mesh(packed_count)) + + DO old_elm = 1, size(keep_elm) + IF (.not. keep_elm(old_elm)) CYCLE + new_elm = old_to_new(old_elm) + CALL copy_elm(mesh(old_elm), packed_mesh(new_elm)) + ENDDO + + IF (allocated(mesh)) deallocate(mesh) + CALL move_alloc(packed_mesh, mesh) + numelm = packed_count + END SUBROUTINE colm_mpas_pack_mesh + + SUBROUTINE colm_mpas_remap_pixelset_ielm(pixelset, old_to_new, ierr) + USE MOD_Pixelset, only: pixelset_type + type(pixelset_type), intent(inout) :: pixelset + integer, intent(in) :: old_to_new(:) + integer, intent(out) :: ierr + + integer :: iset + integer :: old_elm + + ierr = 1 + DO iset = 1, pixelset%nset + old_elm = pixelset%ielm(iset) + IF (old_elm < 1 .or. old_elm > size(old_to_new)) RETURN + IF (old_to_new(old_elm) <= 0) RETURN + pixelset%ielm(iset) = old_to_new(old_elm) + ENDDO + + ierr = 0 + END SUBROUTINE colm_mpas_remap_pixelset_ielm + + SUBROUTINE colm_mpas_find_element_by_eindex(cell_id, element) + USE MOD_LandElm, only: landelm + integer, intent(in) :: cell_id + integer, intent(out) :: element + + integer :: i + integer*8 :: cell_id_i8 + + element = 0 + cell_id_i8 = cell_id + DO i = 1, landelm%nset + IF (landelm%eindex(i) == cell_id_i8) THEN + element = i + RETURN + ENDIF + ENDDO + END SUBROUTINE colm_mpas_find_element_by_eindex + + SUBROUTINE colm_mpas_find_element_in_arrays(lon_rad, lat_rad, lon_array, lat_array, element, best_dist2_out) + real(r8), intent(in) :: lon_rad + real(r8), intent(in) :: lat_rad + real(r8), intent(in) :: lon_array(:) + real(r8), intent(in) :: lat_array(:) + integer, intent(out) :: element + real(r8), intent(out), optional :: best_dist2_out + + integer :: i + real(r8) :: dlon + real(r8) :: dist2 + real(r8) :: best_dist2 + real(r8), parameter :: two_pi = 6.283185307179586476925286766559_r8 + + element = 0 + IF (size(lon_array) /= size(lat_array)) RETURN + + best_dist2 = huge(best_dist2) + DO i = 1, size(lat_array) + dlon = abs(lon_array(i) - lon_rad) + dlon = min(dlon, two_pi - dlon) + dist2 = dlon * dlon + (lat_array(i) - lat_rad) * (lat_array(i) - lat_rad) + IF (dist2 < best_dist2) THEN + best_dist2 = dist2 + element = i + ENDIF + ENDDO + IF (present(best_dist2_out)) best_dist2_out = best_dist2 + END SUBROUTINE colm_mpas_find_element_in_arrays + + SUBROUTINE colm_mpas_ready(ready, patch_count) + logical, intent(out) :: ready + integer, intent(out), optional :: patch_count + + ready = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) & + .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subfrc) & + .and. allocated(colm_mpas_elm_lonr) .and. allocated(colm_mpas_elm_latr) + IF (present(patch_count)) THEN + IF (allocated(oroflag)) THEN + patch_count = size(oroflag) + ELSE + patch_count = 0 + ENDIF + ENDIF + END SUBROUTINE colm_mpas_ready + + SUBROUTINE colm_mpas_find_patch(lon_rad, lat_rad, patch, ierr) + real(r8), intent(in) :: lon_rad + real(r8), intent(in) :: lat_rad + integer, intent(out) :: patch + integer, intent(out) :: ierr + + integer :: i + real(r8) :: dlon + real(r8) :: dist2 + real(r8) :: best_dist2 + real(r8), parameter :: two_pi = 6.283185307179586476925286766559_r8 + + patch = 0 + ierr = 1 + IF (.not. allocated(patchlatr)) RETURN + + best_dist2 = huge(best_dist2) + DO i = 1, size(patchlatr) + IF (allocated(patchmask)) THEN + IF (.not. patchmask(i)) CYCLE + ENDIF + dlon = abs(patchlonr(i) - lon_rad) + dlon = min(dlon, two_pi - dlon) + dist2 = dlon * dlon + (patchlatr(i) - lat_rad) * (patchlatr(i) - lat_rad) + IF (dist2 < best_dist2) THEN + best_dist2 = dist2 + patch = i + ENDIF + ENDDO + + IF (patch > 0) ierr = 0 + END SUBROUTINE colm_mpas_find_patch + + SUBROUTINE colm_mpas_find_element(lon_rad, lat_rad, element, ierr) + real(r8), intent(in) :: lon_rad + real(r8), intent(in) :: lat_rad + integer, intent(out) :: element + integer, intent(out) :: ierr + + integer :: i + real(r8) :: dlon + real(r8) :: dist2 + real(r8) :: best_dist2 + real(r8), parameter :: two_pi = 6.283185307179586476925286766559_r8 + + element = 0 + ierr = 1 + IF (.not. allocated(colm_mpas_elm_latr)) RETURN + + best_dist2 = huge(best_dist2) + DO i = 1, size(colm_mpas_elm_latr) + dlon = abs(colm_mpas_elm_lonr(i) - lon_rad) + dlon = min(dlon, two_pi - dlon) + dist2 = dlon * dlon + (colm_mpas_elm_latr(i) - lat_rad) * (colm_mpas_elm_latr(i) - lat_rad) + IF (dist2 < best_dist2) THEN + best_dist2 = dist2 + element = i + ENDIF + ENDDO + + IF (element > 0) ierr = 0 + END SUBROUTINE colm_mpas_find_element + + SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro, ozone, ierr) + integer, intent(in) :: patch + real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow + real(r8), intent(in) :: psrf, pbot, sols, soll, solsd, solld, frl + real(r8), intent(in) :: hgt_u, hgt_t, hgt_q, rhoair, hpbl + real(r8), intent(in) :: aerdep(14) + real(r8), intent(in), optional :: oro + real(r8), intent(in), optional :: ozone + integer, intent(out) :: ierr + + ierr = 1 + IF (.not. allocated(forc_t)) RETURN + IF (patch < 1 .or. patch > size(forc_t)) RETURN + + forc_pco2m(patch) = pco2m + forc_po2m (patch) = po2m + forc_us (patch) = us + forc_vs (patch) = vs + forc_t (patch) = tair + forc_q (patch) = qair + forc_prc (patch) = prc + forc_prl (patch) = prl + forc_rain (patch) = rain + forc_snow (patch) = snow + forc_psrf (patch) = psrf + forc_pbot (patch) = pbot + forc_sols (patch) = sols + forc_soll (patch) = soll + forc_solsd(patch) = solsd + forc_solld(patch) = solld + forc_frl (patch) = frl + forc_swrad(patch) = sols + soll + solsd + solld +#ifdef HYPERSPECTRAL + forc_solarin(patch) = forc_swrad(patch) +#endif + forc_hgt_u(patch) = hgt_u + forc_hgt_t(patch) = hgt_t + forc_hgt_q(patch) = hgt_q + forc_rhoair(patch) = rhoair + forc_hpbl (patch) = hpbl + forc_aerdep(:,patch) = aerdep(:) + IF (present(oro) .and. allocated(oroflag)) oroflag(patch) = oro + IF (present(ozone)) THEN + forc_ozone(patch) = ozone + ELSE + forc_ozone(patch) = 0._r8 + ENDIF + ierr = 0 + END SUBROUTINE colm_mpas_set_forcing + + SUBROUTINE colm_mpas_set_element_forcing(element, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro, ozone, ierr) + integer, intent(in) :: element + real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow + real(r8), intent(in) :: psrf, pbot, sols, soll, solsd, solld, frl + real(r8), intent(in) :: hgt_u, hgt_t, hgt_q, rhoair, hpbl + real(r8), intent(in) :: aerdep(14) + real(r8), intent(in), optional :: oro + real(r8), intent(in), optional :: ozone + integer, intent(out) :: ierr + + integer :: patch + integer :: patch_ierr + integer :: istt + integer :: iend + logical :: did_set + + ierr = 1 + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (element < 1 .or. element > size(elm_patch%substt)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt) RETURN + + did_set = .false. + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) CYCLE + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + IF (present(oro) .and. present(ozone)) THEN + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro=oro, ozone=ozone, ierr=patch_ierr) + ELSEIF (present(oro)) THEN + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro=oro, ierr=patch_ierr) + ELSEIF (present(ozone)) THEN + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, ozone=ozone, ierr=patch_ierr) + ELSE + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, ierr=patch_ierr) + ENDIF + IF (patch_ierr /= 0) RETURN + did_set = .true. + ENDDO + + IF (did_set) ierr = 0 + END SUBROUTINE colm_mpas_set_element_forcing + + SUBROUTINE colm_mpas_step(idate, deltim, dolai, doalb, dosst, ierr) +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow +#endif + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: dolai, doalb, dosst + integer, intent(out) :: ierr + + logical :: ready + + CALL colm_mpas_ready(ready) + ierr = 1 + IF (.not. ready) RETURN + + CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag) +#ifdef GridRiverLakeFlow + CALL grid_riverlake_flow(idate(1), deltim) +#endif + colm_mpas_last_idate(:) = idate(:) + CALL colm_mpas_write_restart_if_due(idate, deltim, .false., ierr) + IF (ierr /= 0) RETURN + ierr = 0 + END SUBROUTINE colm_mpas_step + + SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) + USE MOD_Namelist, only: DEF_WRST_FREQ + USE MOD_TimeManager, only: adj2begin + USE MOD_Vars_TimeVariables, only: save_to_restart, WRITE_TimeVariables + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: force + integer, intent(out) :: ierr + + type(timestamp) :: itstamp + integer :: write_idate(3) + integer :: write_lc_year + logical :: should_write + character(len=256) :: wrst_freq + + ierr = 0 + IF (.not. colm_mpas_restart_ready) RETURN + + write_idate(:) = idate(:) + CALL adj2begin(write_idate) + + IF (all(write_idate == colm_mpas_last_restart_idate)) RETURN + + itstamp%year = idate(1) + itstamp%day = idate(2) + itstamp%sec = idate(3) + + wrst_freq = trim(adjustl(DEF_WRST_FREQ)) + IF (wrst_freq == '' .or. wrst_freq == 'none' .or. wrst_freq == 'NONE') THEN + should_write = force .or. colm_mpas_timestamp_reached(itstamp, colm_mpas_etstamp) + ELSEIF (force) THEN + should_write = .true. + ELSE + should_write = save_to_restart(idate, deltim, itstamp, colm_mpas_ptstamp, colm_mpas_etstamp) + ENDIF + IF (.not. should_write) RETURN + +#ifdef LULCC + IF (write_idate(1) >= 2000) THEN + write_lc_year = write_idate(1) + ELSE + write_lc_year = (write_idate(1) / 5) * 5 + ENDIF +#else + write_lc_year = colm_mpas_lc_year +#endif + + CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) + colm_mpas_last_restart_idate(:) = write_idate(:) + END SUBROUTINE colm_mpas_write_restart_if_due + + LOGICAL FUNCTION colm_mpas_timestamp_reached(tstamp, target) + type(timestamp), intent(in) :: tstamp + type(timestamp), intent(in) :: target + + colm_mpas_timestamp_reached = .false. + IF (tstamp%year > target%year) THEN + colm_mpas_timestamp_reached = .true. + ELSEIF (tstamp%year == target%year .and. tstamp%day > target%day) THEN + colm_mpas_timestamp_reached = .true. + ELSEIF (tstamp%year == target%year .and. tstamp%day == target%day .and. tstamp%sec >= target%sec) THEN + colm_mpas_timestamp_reached = .true. + ENDIF + END FUNCTION colm_mpas_timestamp_reached + + SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & + emissivity, roughness, albedo, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff + real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: emissivity, roughness, albedo + integer, intent(out) :: ierr + + ierr = 1 + sensible = spval + latent = spval + evaporation = spval + ground_heat = spval + runoff = spval + surface_runoff = spval + subsurface_runoff = spval + skin_temp = spval + t2m = spval + q2m = spval + emissivity = spval + roughness = spval + albedo = spval + + IF (.not. allocated(fsena)) RETURN + IF (patch < 1 .or. patch > size(fsena)) RETURN + + sensible = fsena(patch) + latent = lfevpa(patch) + evaporation = fevpa(patch) + ground_heat = fgrnd(patch) + runoff = rnof(patch) + surface_runoff = rsur(patch) + subsurface_runoff = rsub(patch) + skin_temp = t_grnd(patch) + t2m = tref(patch) + q2m = qref(patch) + emissivity = emis(patch) + roughness = z0m(patch) + IF (allocated(alb)) THEN + ! ponytail: bulk albedo average; replace with band/beam mapping when MPAS consumes CoLM spectral albedo. + albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) + ENDIF + ierr = 0 + END SUBROUTINE colm_mpas_get_surface + + SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & + emissivity, roughness, albedo, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff + real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: emissivity, roughness, albedo + integer, intent(out) :: ierr + + integer :: patch + integer :: patch_ierr + integer :: istt + integer :: iend + real(r8) :: wt + real(r8) :: sumwt + real(r8) :: albedo_sum + real(r8) :: albedo_wt + real(r8) :: patch_sensible, patch_latent, patch_evaporation, patch_ground_heat + real(r8) :: patch_runoff, patch_surface_runoff, patch_subsurface_runoff + real(r8) :: patch_skin_temp, patch_t2m, patch_q2m + real(r8) :: patch_emissivity, patch_roughness, patch_albedo + + ierr = 1 + sensible = spval + latent = spval + evaporation = spval + ground_heat = spval + runoff = spval + surface_runoff = spval + subsurface_runoff = spval + skin_temp = spval + t2m = spval + q2m = spval + emissivity = spval + roughness = spval + albedo = spval + + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (element < 1 .or. element > size(elm_patch%substt)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt) RETURN + + sensible = 0._r8 + latent = 0._r8 + evaporation = 0._r8 + ground_heat = 0._r8 + runoff = 0._r8 + surface_runoff = 0._r8 + subsurface_runoff = 0._r8 + skin_temp = 0._r8 + t2m = 0._r8 + q2m = 0._r8 + emissivity = 0._r8 + roughness = 0._r8 + albedo_sum = 0._r8 + albedo_wt = 0._r8 + sumwt = 0._r8 + + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) CYCLE + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (wt <= 0._r8) CYCLE + CALL colm_mpas_get_surface(patch, patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & + patch_runoff, patch_surface_runoff, patch_subsurface_runoff, & + patch_skin_temp, patch_t2m, patch_q2m, patch_emissivity, & + patch_roughness, patch_albedo, patch_ierr) + IF (patch_ierr /= 0) CYCLE + + sumwt = sumwt + wt + sensible = sensible + wt * patch_sensible + latent = latent + wt * patch_latent + evaporation = evaporation + wt * patch_evaporation + ground_heat = ground_heat + wt * patch_ground_heat + runoff = runoff + wt * patch_runoff + surface_runoff = surface_runoff + wt * patch_surface_runoff + subsurface_runoff = subsurface_runoff + wt * patch_subsurface_runoff + skin_temp = skin_temp + wt * patch_skin_temp + t2m = t2m + wt * patch_t2m + q2m = q2m + wt * patch_q2m + emissivity = emissivity + wt * patch_emissivity + roughness = roughness + wt * patch_roughness + IF (patch_albedo > 0._r8 .and. patch_albedo < 1._r8) THEN + albedo_sum = albedo_sum + wt * patch_albedo + albedo_wt = albedo_wt + wt + ENDIF + ENDDO + + IF (sumwt <= 0._r8) THEN + sensible = spval + latent = spval + evaporation = spval + ground_heat = spval + runoff = spval + surface_runoff = spval + subsurface_runoff = spval + skin_temp = spval + t2m = spval + q2m = spval + emissivity = spval + roughness = spval + RETURN + ENDIF + + sensible = sensible / sumwt + latent = latent / sumwt + evaporation = evaporation / sumwt + ground_heat = ground_heat / sumwt + runoff = runoff / sumwt + surface_runoff = surface_runoff / sumwt + subsurface_runoff = subsurface_runoff / sumwt + skin_temp = skin_temp / sumwt + t2m = t2m / sumwt + q2m = q2m / sumwt + emissivity = emissivity / sumwt + roughness = roughness / sumwt + IF (albedo_wt > 0._r8) albedo = albedo_sum / albedo_wt + ierr = 0 + END SUBROUTINE colm_mpas_get_element_surface + +END MODULE MOD_CoLM_MPAS_Interface diff --git a/src/core_atmosphere/physics/physics_colm2024/include/Makeoptions b/src/core_atmosphere/physics/physics_colm2024/include/Makeoptions new file mode 100644 index 0000000000..aed82b243e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/include/Makeoptions @@ -0,0 +1,9 @@ +# MPAS-embedded CoLM2024 defaults. +# The parent MPAS build passes FF/FOPTS into this submake, just as it does for +# Noah-MP. These values only keep a direct `make mpas_objects` usable. + +FF ?= mpif90 +FOPTS ?= -ffree-form -cpp -ffree-line-length-0 -fallow-argument-mismatch +NF_CONFIG ?= nf-config +NETCDF_INC ?= $(shell $(NF_CONFIG) --includedir 2>/dev/null || nc-config --includedir) +MOD_CMD ?= -J diff --git a/src/core_atmosphere/physics/physics_colm2024/include/define.h b/src/core_atmosphere/physics/physics_colm2024/include/define.h new file mode 100644 index 0000000000..3572bc0b95 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h @@ -0,0 +1,123 @@ +! 1. Spatial structure: +! Select one of the following options. +#define GRIDBASED +#undef CATCHMENT +#undef UNSTRUCTURED +#undef SinglePoint + +! 2. Land subgrid type classification: +! Select one of the following options. +#undef LULC_USGS +#undef LULC_IGBP +#undef LULC_IGBP_PFT +#define LULC_IGBP_PC + +! 2.1 3D Urban model (put it temporarily here): +#undef URBAN_MODEL +! Dependence: only LULC_IGBP subgrid type for +! single point URBAN_MODEL right now. +#if (defined URBAN_MODEL && defined SinglePoint) +#define LULC_IGBP +#undef LULC_USGS +#undef LULC_IGBP_PFT +#undef LULC_IGBP_PC +#endif + +! 3. If defined, debug information is output. +#define CoLMDEBUG +! 3.1 If defined, range of variables is checked. +#define RangeCheck +! 3.1 If defined, surface data in vector is mapped to gridded data for checking. +#undef SrfdataDiag + +! 4. CoLM uses MPI collectives through MPAS-owned communicators. The standalone +! CoLM master/IO/worker process decomposition is disabled in MOD_SPMD_Task. +#define USEMPI + +! 5. Hydrological process options. +! 5.1 Two soil hydraulic models can be used. +#undef Campbell_SOIL_MODEL +#define vanGenuchten_Mualem_SOIL_MODEL +! 5.2 If defined, lateral flow is modeled. +#define CatchLateralFlow +! Conflicts : +#ifndef CATCHMENT +#undef CatchLateralFlow +#endif + +! 6. CaMa-Flood is not built in the MPAS-embedded CoLM package. +#undef CaMa_Flood +#if (defined SinglePoint) +#undef CaMa_Flood +#endif +#ifndef USEMPI +#undef CaMa_Flood +#endif + +#define GridRiverLakeFlow +! Conflicts : +#if (defined CATCHMENT || defined SinglePoint) +#undef GridRiverLakeFlow +#endif + +#undef GridRiverLakeSediment +#if (!defined GridRiverLakeFlow) +#undef GridRiverLakeSediment +#endif + +! 7. If defined, BGC model is used. +#undef BGC + +! Conflicts : only used when LULC_IGBP_PFT is defined. +#ifndef LULC_IGBP_PFT +#ifndef LULC_IGBP_PC +#undef BGC +#endif +#endif +! 7.1 If defined, CROP model is used +#undef CROP +! Conflicts : only used when BGC is defined +#ifndef BGC +#undef CROP +#endif + +! 8. If defined, open Land use and land cover change mode. +#undef LULCC + +! 9. If defined, data assimilation is used. +#undef DataAssimilation +#if (defined DataAssimilation) +#define LULC_IGBP +#undef LULC_USGS +#undef LULC_IGBP_PFT +#undef LULC_IGBP_PC +#endif + +! 10. Interface to AI model. +#undef USESplitAI + +! 11. External lake models. +#undef EXTERNAL_LAKE + +! 12. Hyperspectral scheme. +#define HYPERSPECTRAL + +! MPAS embeds CoLM as a local land-surface physics package on each MPAS rank. +! Reusing the CoLM standalone MPI master/IO/worker split inside MPAS leaves some +! ranks without patch forcing/flux arrays, so the embedded library keeps CoLM +! land state on MPAS-owned cells. MPAS also supplies broadband shortwave forcing. +#define MPAS_EMBEDDED_COLM +#ifdef MPAS_EMBEDDED_COLM +#ifndef USEMPI +#define USEMPI +#endif +#undef HYPERSPECTRAL +#undef CoLMDEBUG +! CoLM range diagnostics still assume standalone IO/worker roles. +#undef RangeCheck +#endif + +#undef COLM_PARALLEL +#if defined(USEMPI) +#define COLM_PARALLEL +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 new file mode 100644 index 0000000000..8eff998fda --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 @@ -0,0 +1,81 @@ +#include + +#ifdef BGC +MODULE MOD_BGC_CNAnnualUpdate + +!------------------------------------------------------------------------------------------------------ +! !DESCRIPTION: +! On the radiation time step, update annual summation variables mostly for phenology modules: +! annsum_potential_gpp : annual sum of potential gpp of last year is used to calculate the available +! retranslocation N +! annmax_retransn : maximum of retranslocation N pool size of last year in a whole year, used to +! calculate the available rentranslocation N +! annavg_tref : annual 2m air temperature of last year is used to calculate onset phenology +! annsum_npp : annual NPP of last year is used to calculate the allocation partition. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REFERENCES: +! Lawrence, D.M., Fisher, R.A., Koven, C.D., Oleson, K.W., Swenson, S.C., Bonan, G., Collier, N., +! Ghimire, B., van Kampenhout, L., Kennedy, D. and Kluzek, E., 2019. +! The Community Land Model version 5: Description of new features, benchmarking, +! and impact of forcing uncertainty. Journal of Advances in Modeling Earth Systems, 11(12), 4245-4287. + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + + USE MOD_Vars_PFTimeVariables, only: & + tempsum_potential_gpp_p, tempmax_retransn_p, tempavg_tref_p, tempsum_npp_p, & + annsum_potential_gpp_p , annmax_retransn_p , annavg_tref_p , annsum_npp_p + + USE MOD_TimeManager, only: isendofyear + USE MOD_Precision + + IMPLICIT NONE + + PUBLIC CNAnnualUpdate + +CONTAINS + + SUBROUTINE CNAnnualUpdate(i,ps,pe,deltim,idate) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: idate(3) ! date (year, days of year, seconds of the day) + + !!LOCAL VARIABLES: + integer m + + + IF (isendofyear(idate,deltim)) THEN + + DO m = ps, pe + ! update annual plant ndemand accumulator + annsum_potential_gpp_p(m) = tempsum_potential_gpp_p(m) + tempsum_potential_gpp_p(m) = 0._r8 + + ! update annual total N retranslocation accumulator + annmax_retransn_p(m) = tempmax_retransn_p(m) + tempmax_retransn_p(m) = 0._r8 + + ! update annual average 2m air temperature accumulator + annavg_tref_p(m) = tempavg_tref_p(m) + tempavg_tref_p(m) = 0._r8 + + ! update annual NPP accumulator, convert to annual total + annsum_npp_p(m) = tempsum_npp_p(m) * deltim + tempsum_npp_p(m) = 0._r8 + + ENDDO + + ENDIF + + END SUBROUTINE CNAnnualUpdate + +END MODULE MOD_BGC_CNAnnualUpdate + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 new file mode 100644 index 0000000000..df66ec3151 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 @@ -0,0 +1,273 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNBalanceCheck + +!-------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! C and N balance check module. +! run sequential: BeginCNBalance(i) -> all CN cycle processes ->CBalanceCheck & NBalanceCheck +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + USE MOD_BGC_Vars_TimeVariables, only: & + sminn, col_endcb, col_begcb, totcolc, col_endnb, col_begnb, totcoln, & + col_vegbegcb, totvegc, ctrunc_veg, col_vegbegnb, totvegn, ntrunc_veg, & + col_soilbegcb, totsomc, totlitc, totcwdc, ctrunc_soil, & + col_soilbegnb, totsomn, totlitn, totcwdn, ntrunc_soil, col_sminnbegnb, & + col_vegendcb, col_vegendnb, col_soilendcb, col_soilendnb, col_sminnendnb + USE MOD_BGC_Vars_1DFluxes, only: & + gpp, er, ar, decomp_hr, fire_closs, hrv_xsmrpool_to_atm, wood_harvestc, grainc_to_cropprodc, & + som_c_leached, ndep_to_sminn, nfix_to_sminn, supplement_to_sminn, ffix_to_sminn, & + fert_to_sminn, soyfixn_to_sminn, denit, fire_nloss, wood_harvestn, grainn_to_cropprodn, & + sminn_leached, f_n2o_nit, smin_no3_leached, smin_no3_runoff, som_n_leached, sminn_to_plant + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p, frootc_p, livestemc_p, deadstemc_p, livecrootc_p, deadcrootc_p, & + leafc_storage_p, frootc_storage_p, livestemc_storage_p, & + deadstemc_storage_p, livecrootc_storage_p, deadcrootc_storage_p, gresp_storage_p, & + leafc_xfer_p, frootc_xfer_p, livestemc_xfer_p, & + deadstemc_xfer_p, livecrootc_xfer_p, deadcrootc_xfer_p, gresp_xfer_p, xsmrpool_p, & + grainc_p, grainc_storage_p, grainc_xfer_p, ctrunc_p, totvegc_p, cropseedc_deficit_p + USE MOD_BGC_Vars_1DPFTFluxes, only: & + grainc_to_food_p, & + leafc_to_litter_p , frootc_to_litter_p , livestemc_to_litter_p, & + m_leafc_to_litter_p , m_leafc_storage_to_litter_p , m_leafc_xfer_to_litter_p , & + m_frootc_to_litter_p , m_frootc_storage_to_litter_p , m_frootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , m_livestemc_storage_to_litter_p , m_livestemc_xfer_to_litter_p , & + m_deadstemc_to_litter_p , m_deadstemc_storage_to_litter_p , m_deadstemc_xfer_to_litter_p , & + m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & + m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & + m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p + USE MOD_SPMD_Task + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_1DFluxes, only: & + gap_mortality_to_met_c, gap_mortality_to_cel_c, gap_mortality_to_lig_c, gap_mortality_to_cwdc , & + phenology_to_met_c, phenology_to_cel_c, phenology_to_lig_c + + IMPLICIT NONE + + PUBLIC BeginCNBalance + PUBLIC CBalanceCheck + PUBLIC NBalanceCheck + +CONTAINS + + SUBROUTINE BeginCNBalance(i) + + ! !DESCRIPTION: + ! BeginCNBalance SUBROUTINE stores initial C and N pool size at begining of each time step, which is + ! further used in CN balance check. + ! + ! !ORIGINAL: + ! The Community Land Model version 5.0 (CLM5.0) + ! + ! !REVISION: + ! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + + col_begcb(i) = totcolc(i) + col_begnb(i) = totcoln(i) + + col_vegbegcb(i) = totvegc(i) + ctrunc_veg(i) + col_vegbegnb(i) = totvegn(i) + ntrunc_veg(i) + + col_soilbegcb(i) = totsomc(i) + totlitc(i) + totcwdc(i) + ctrunc_soil(i) + col_soilbegnb(i) = totsomn(i) + totlitn(i) + totcwdn(i) + ntrunc_soil(i) + + col_sminnbegnb(i) = sminn(i) + + END SUBROUTINE BeginCNBalance + + SUBROUTINE CBalanceCheck(i,ps,pe,nl_soil,dz_soi,deltim,dlat,dlon) + + ! !DESCRIPTION: + ! CBalanceCheck tests the carbon balance of each time step, which meet C balance equation: + ! col_endcb - col_begcb = (col_cinputs - col_coutputs)*deltim + ! + ! !ORIGINAL: + ! The Community Land Model version 5.0 (CLM5.0) + ! + ! !REVISION: + ! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dlat ! latitude (degree) + real(r8),intent(in) :: dlon ! longitude (degree) + integer, intent(in) :: nl_soil + real(r8),intent(in) :: dz_soi(nl_soil) + +!Local variables + real(r8),parameter :: cerror = 1.e-7_r8 + real(r8) :: col_cinputs, col_coutputs, col_errcb + real(r8) :: veg_to_litter, phen_to_litter, gap_leaf_to_litter, gap_froot_to_litter, & + gap_livestem_to_litter, gap_deadstem_to_litter, gap_livecroot_to_litter, & + gap_deadcroot_to_litter, gap_gresp_to_litter, gap_veg_to_litter, phen_veg_to_litter + integer m + + col_endcb(i) = totcolc(i) + col_vegendcb(i) = totvegc(i) + ctrunc_veg(i) + col_soilendcb(i) = totsomc(i) + totlitc(i) + totcwdc(i) + ctrunc_soil(i) + + col_cinputs = gpp(i) + + col_coutputs = er(i) + fire_closs(i) + hrv_xsmrpool_to_atm(i) & + + wood_harvestc(i) + grainc_to_cropprodc(i) - som_c_leached(i) + + col_errcb = (col_cinputs - col_coutputs)*deltim - & + (col_endcb(i) - col_begcb(i)) + + phen_to_litter = sum(pftfrac(ps:pe)*(leafc_to_litter_p (ps:pe) + frootc_to_litter_p(ps:pe) & + + livestemc_to_litter_p(ps:pe))) + gap_leaf_to_litter = sum(pftfrac(ps:pe)*(m_leafc_to_litter_p (ps:pe) + m_leafc_storage_to_litter_p(ps:pe) & + + m_leafc_xfer_to_litter_p(ps:pe))) + gap_froot_to_litter = sum(pftfrac(ps:pe)*(m_frootc_to_litter_p (ps:pe) + m_frootc_storage_to_litter_p(ps:pe)& + + m_frootc_xfer_to_litter_p(ps:pe))) + gap_livestem_to_litter = sum(pftfrac(ps:pe)*(m_livestemc_to_litter_p (ps:pe) + m_livestemc_storage_to_litter_p(ps:pe)& + + m_livestemc_xfer_to_litter_p(ps:pe))) + gap_deadstem_to_litter = sum(pftfrac(ps:pe)*(m_deadstemc_to_litter_p (ps:pe) + m_deadstemc_storage_to_litter_p(ps:pe)& + + m_deadstemc_xfer_to_litter_p(ps:pe))) + gap_livecroot_to_litter = sum(pftfrac(ps:pe)*(m_livecrootc_to_litter_p(ps:pe) + m_livecrootc_storage_to_litter_p(ps:pe)& + + m_livecrootc_xfer_to_litter_p(ps:pe))) + gap_deadcroot_to_litter = sum(pftfrac(ps:pe)*(m_deadcrootc_to_litter_p(ps:pe) + m_deadcrootc_storage_to_litter_p(ps:pe)& + + m_deadcrootc_xfer_to_litter_p(ps:pe))) + gap_gresp_to_litter = sum(pftfrac(ps:pe)*(m_gresp_storage_to_litter_p(ps:pe)+m_gresp_xfer_to_litter_p(ps:pe))) + + gap_veg_to_litter = sum((gap_mortality_to_met_c(1:nl_soil,i) + gap_mortality_to_cel_c(1:nl_soil,i)& + + gap_mortality_to_lig_c(1:nl_soil,i) + gap_mortality_to_cwdc (1:nl_soil,i))*dz_soi(1:nl_soil)) + phen_veg_to_litter = sum((phenology_to_met_c (1:nl_soil,i) + phenology_to_cel_c (1:nl_soil,i)& + + phenology_to_lig_c (1:nl_soil,i))*dz_soi(1:nl_soil)) + veg_to_litter = phen_to_litter + gap_leaf_to_litter + gap_froot_to_litter + gap_livestem_to_litter & + + gap_deadstem_to_litter + gap_livecroot_to_litter + gap_deadcroot_to_litter + gap_gresp_to_litter + + IF(abs(col_errcb) > cerror) THEN + write(*,*)'column cbalance error = ', col_errcb, i, p_iam_glb + write(*,*)'Latdeg,Londeg=' , dlat, dlon + write(*,*)'begcb = ',col_begcb(i) + write(*,*)'endcb = ',col_endcb(i) + write(*,*)'delta store = ',col_endcb(i)-col_begcb(i) + write(*,*)'delta veg = ',col_vegendcb(i) - col_vegbegcb(i),totvegc(i),col_vegendcb(i),col_vegbegcb(i) + write(*,*)'delta soil = ',col_soilendcb(i) - col_soilbegcb(i),totsomc(i),totlitc(i),totcwdc(i),col_soilendcb(i),col_soilbegcb(i) + DO m = ps, pe + write(*,*)'m=',m,pftclass(m) + write(*,*)'vegc,leafc = ',leafc_p(m)+leafc_storage_p(m)+leafc_xfer_p(m) + write(*,*)'vegc,frootc = ',frootc_p(m)+frootc_storage_p(m)+frootc_xfer_p(m) + write(*,*)'vegc,livestemc = ',livestemc_p(m)+livestemc_storage_p(m)+livestemc_xfer_p(m) + write(*,*)'vegc,deadstemc = ',deadstemc_p(m)+deadstemc_storage_p(m)+deadstemc_xfer_p(m) + write(*,*)'vegc,livecrootc = ',livecrootc_p(m)+livecrootc_storage_p(m)+livecrootc_xfer_p(m) + write(*,*)'vegc,deadcrootc = ',deadcrootc_p(m)+deadcrootc_storage_p(m)+deadcrootc_xfer_p(m) + write(*,*)'grainc = ',grainc_p(m)+grainc_storage_p(m)+grainc_xfer_p(m)+cropseedc_deficit_p(m) + write(*,*)'growth respiration c = ',gresp_storage_p(m)+gresp_xfer_p(m)+xsmrpool_p(m) + ENDDO + write(*,*)'--------veg output to litter-------------' + write(*,*)'veg to soil and litter = ', veg_to_litter, phen_to_litter, gap_leaf_to_litter, gap_froot_to_litter, gap_livestem_to_litter, & + gap_deadstem_to_litter, gap_livecroot_to_litter, gap_deadcroot_to_litter , gap_gresp_to_litter + write(*,*)'--------liter and soil input from veg----' + write(*,*)'input to soil and litter = ',gap_veg_to_litter + phen_veg_to_litter + write(*,*)'phen, gap to litter = ',phen_veg_to_litter, gap_veg_to_litter + write(*,*)'--- Inputs ---' + write(*,*)'gpp = ',gpp(i)*deltim + write(*,*)'--- Outputs ---' + write(*,*)'er = ',er(i)*deltim + write(*,*)'ar = ',ar(i)*deltim + write(*,*)'decomp_hr = ',decomp_hr(i)*deltim + write(*,*)'fire_closs = ',fire_closs(i)*deltim + write(*,*)'col_hrv_xsmrpool_to_atm = ',hrv_xsmrpool_to_atm(i)*deltim + write(*,*)'wood_harvestc = ',wood_harvestc(i)*deltim + write(*,*)'grainc_to_cropprodc = ',grainc_to_cropprodc(i)*deltim, grainc_to_food_p(ps)*deltim + write(*,*)'-1*som_c_leached = ',som_c_leached(i)*deltim +#ifdef USEMPI + CALL mpi_abort (p_comm_glb, p_err) +#else + CALL abort +#endif + ENDIF + + END SUBROUTINE CBalanceCheck + + SUBROUTINE NBalanceCheck(i,ps,pe,deltim,dlat,dlon) + +! !DESCRIPTION: +! NBalanceCheck tests the carbon balance of each time step, which meet N balance equation: +! col_endnb - col_begnb = (col_ninputs - col_noutputs)*deltim +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i,ps,pe ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dlat ! latitude (degree) + real(r8),intent(in) :: dlon ! longitude (degree) + +!Local variables + real(r8),parameter :: nerror = 1.e-7_r8 + real(r8) :: col_ninputs, col_noutputs, col_errnb + + col_endnb(i) = totcoln(i) + col_vegendnb(i) = totvegn(i) + ntrunc_veg(i) + col_soilendnb(i) = totsomn(i) + totlitn(i) + totcwdn(i) + ntrunc_soil(i) + col_sminnendnb(i) = sminn(i) + + col_ninputs = ndep_to_sminn(i) + nfix_to_sminn(i) + supplement_to_sminn(i) + + col_ninputs = col_ninputs + fert_to_sminn(i) + soyfixn_to_sminn(i) + + col_noutputs = denit(i) + fire_nloss(i) + wood_harvestn(i) + grainn_to_cropprodn(i) + + IF(DEF_USE_NITRIF)THEN + col_noutputs = col_noutputs + f_n2o_nit(i) + smin_no3_leached(i) + smin_no3_runoff(i) + ELSE + col_noutputs = col_noutputs + sminn_leached(i) + ENDIF + + col_noutputs = col_noutputs - som_n_leached(i) + col_errnb =(col_ninputs - col_noutputs)*deltim - (col_endnb(i) - col_begnb(i)) + + IF (abs(col_errnb) > nerror) THEN ! + write(*,*)'column nbalance error = ',col_errnb, i, p_iam_glb + write(*,*)'Latdeg,Londeg = ',dlat, dlon + write(*,*)'begnb = ',col_begnb(i) + write(*,*)'endnb = ',col_endnb(i) + write(*,*)'delta store = ',col_endnb(i)-col_begnb(i) + write(*,*)'delta veg = ',col_vegendnb(i)-col_vegbegnb(i) + write(*,*)'delta soil = ',col_soilendnb(i)-col_soilbegnb(i) + write(*,*)'delta sminn = ',col_sminnendnb(i)-col_sminnbegnb(i) + write(*,*)'smin_to_plant = ',sminn_to_plant(i)*deltim + write(*,*)'input mass = ',col_ninputs*deltim + write(*,*)'output mass = ',col_noutputs*deltim,f_n2o_nit(i)*deltim,smin_no3_leached(i)*deltim,& + smin_no3_runoff(i)*deltim, denit(i)*deltim,fire_nloss(i)*deltim,& + ( wood_harvestn(i) + grainn_to_cropprodn(i))*deltim + write(*,*)'net flux = ',(col_ninputs-col_noutputs)*deltim + write(*,*)'inputs,ffix,nfix,ndep = ',ffix_to_sminn(i)*deltim,nfix_to_sminn(i)*deltim,ndep_to_sminn(i)*deltim,& + fert_to_sminn(i)*deltim,soyfixn_to_sminn(i)*deltim + IF(DEF_USE_NITRIF)THEN + write(*,*)'outputs,leached,runoff,denit = ',smin_no3_leached(i)*deltim, smin_no3_runoff(i)*deltim,f_n2o_nit(i)*deltim + ELSE + write(*,*)'outputs,leached,denit,fire,harvest,som_n_leached',& + sminn_leached(i)*deltim,denit(i)*deltim,fire_nloss(i)*deltim,& + (wood_harvestn(i)+grainn_to_cropprodn(i))*deltim, - som_n_leached(i) + ENDIF +#ifdef USEMPI + CALL mpi_abort (p_comm_glb, p_err) +#else + CALL abort +#endif + ENDIF + + END SUBROUTINE NBalanceCheck + +END MODULE MOD_BGC_CNBalanceCheck +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 new file mode 100644 index 0000000000..24f7bd6731 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 @@ -0,0 +1,493 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNCStateUpdate1 + +!------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! First updates in vegetation and soil carbon. The major updates are included in bgc_CNCStateUpdate1Mod +! 1. Update phenology-associated veg and soil C pool size changes, including plant growth +! 2. Update decomposition-associated soil C pool size changes +! 3. Record the accumulated C transfers associated to phenology and decomposition for semi-analytic spinup +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated phenology-associated C transfer for veg and soil C semi-analytic spinup +! 3) Record the accumulated decomposition-associated C transfer for soil C semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_Const_PFT, only: woody + USE MOD_BGC_Vars_TimeInvariants, only: & +! bgc constants + donor_pool, receiver_pool, i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3 + + USE MOD_BGC_Vars_TimeVariables, only: & + I_met_c_vr_acc, I_cel_c_vr_acc, I_lig_c_vr_acc, & + AKX_met_to_soil1_c_vr_acc , AKX_cel_to_soil1_c_vr_acc , AKX_lig_to_soil2_c_vr_acc , AKX_soil1_to_soil2_c_vr_acc, & + AKX_cwd_to_cel_c_vr_acc , AKX_cwd_to_lig_c_vr_acc , AKX_soil1_to_soil3_c_vr_acc, AKX_soil2_to_soil1_c_vr_acc, & + AKX_soil2_to_soil3_c_vr_acc, AKX_soil3_to_soil1_c_vr_acc, & + AKX_met_exit_c_vr_acc , AKX_cel_exit_c_vr_acc , AKX_lig_exit_c_vr_acc , AKX_cwd_exit_c_vr_acc , & + AKX_soil1_exit_c_vr_acc , AKX_soil2_exit_c_vr_acc , AKX_soil3_exit_c_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & +! decomposition pools flux variables (in) + decomp_cpools_sourcesink, decomp_ctransfer_vr, decomp_hr_vr , & + phenology_to_met_c , phenology_to_cel_c , phenology_to_lig_c + + USE MOD_BGC_Vars_PFTimeVariables, only: & +! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + grainc_p , grainc_storage_p , grainc_xfer_p , & + cropseedc_deficit_p, xsmrpool_p , gresp_storage_p , gresp_xfer_p, & + cpool_p, & + +! crop variables (in) + harvdate_p , cropprod1c_p , & + +! SASU variables + I_leafc_p_acc , I_leafc_st_p_acc , I_frootc_p_acc , I_frootc_st_p_acc , & + I_livestemc_p_acc , I_livestemc_st_p_acc , I_deadstemc_p_acc , I_deadstemc_st_p_acc , & + I_livecrootc_p_acc, I_livecrootc_st_p_acc, I_deadcrootc_p_acc, I_deadcrootc_st_p_acc, & + I_grainc_p_acc , I_grainc_st_p_acc , & + + AKX_leafc_xf_to_leafc_p_acc , AKX_frootc_xf_to_frootc_p_acc , AKX_livestemc_xf_to_livestemc_p_acc , & + AKX_deadstemc_xf_to_deadstemc_p_acc , AKX_livecrootc_xf_to_livecrootc_p_acc , AKX_deadcrootc_xf_to_deadcrootc_p_acc , & + AKX_grainc_xf_to_grainc_p_acc , AKX_livestemc_to_deadstemc_p_acc , AKX_livecrootc_to_deadcrootc_p_acc , & + + AKX_leafc_st_to_leafc_xf_p_acc , AKX_frootc_st_to_frootc_xf_p_acc , AKX_livestemc_st_to_livestemc_xf_p_acc , & + AKX_deadstemc_st_to_deadstemc_xf_p_acc, AKX_livecrootc_st_to_livecrootc_xf_p_acc, AKX_deadcrootc_st_to_deadcrootc_xf_p_acc, & + AKX_livestemc_st_to_livestemc_xf_p_acc, AKX_grainc_st_to_grainc_xf_p_acc , & + + AKX_leafc_exit_p_acc , AKX_frootc_exit_p_acc , AKX_livestemc_exit_p_acc , & + AKX_deadstemc_exit_p_acc , AKX_livecrootc_exit_p_acc , AKX_deadcrootc_exit_p_acc , & + AKX_grainc_exit_p_acc , & + + AKX_leafc_st_exit_p_acc , AKX_frootc_st_exit_p_acc , AKX_livestemc_st_exit_p_acc , & + AKX_deadstemc_st_exit_p_acc , AKX_livecrootc_st_exit_p_acc , AKX_deadcrootc_st_exit_p_acc , & + AKX_grainc_st_exit_p_acc , & + + AKX_leafc_xf_exit_p_acc , AKX_frootc_xf_exit_p_acc , AKX_livestemc_xf_exit_p_acc , & + AKX_deadstemc_xf_exit_p_acc , AKX_livecrootc_xf_exit_p_acc , AKX_deadcrootc_xf_exit_p_acc , & + AKX_grainc_xf_exit_p_acc + + + USE MOD_BGC_Vars_1DPFTFluxes, only: & +! vegetation carbon flux variables (in) +! Vegetation physiology + psn_to_cpool_p, & + +! xfer to display + leafc_xfer_to_leafc_p , frootc_xfer_to_frootc_p , & + livestemc_xfer_to_livestemc_p , deadstemc_xfer_to_deadstemc_p , & + livecrootc_xfer_to_livecrootc_p, deadcrootc_xfer_to_deadcrootc_p, & + grainc_xfer_to_grainc_p , & + +! storage to xfer (in) + leafc_storage_to_xfer_p , frootc_storage_to_xfer_p , & + livestemc_storage_to_xfer_p , deadstemc_storage_to_xfer_p , & + livecrootc_storage_to_xfer_p, deadcrootc_storage_to_xfer_p, & + grainc_storage_to_xfer_p , gresp_storage_to_xfer_p , & + +! display to litter & live to dead (in) + leafc_to_litter_p , frootc_to_litter_p , & + grainc_to_food_p , grainc_to_seed_p , & + crop_seedc_to_leaf_p , livestemc_to_litter_p , & + livestemc_to_deadstemc_p, livecrootc_to_deadcrootc_p, & + +! crop + cropprod1c_loss_p, & + +! cpool to display/storage (in) + cpool_to_xsmrpool_p , cpool_to_gresp_storage_p , & + cpool_to_leafc_p , cpool_to_leafc_storage_p , & + cpool_to_frootc_p , cpool_to_frootc_storage_p , & + cpool_to_livestemc_p , cpool_to_livestemc_storage_p , & + cpool_to_deadstemc_p , cpool_to_deadstemc_storage_p , & + cpool_to_livecrootc_p, cpool_to_livecrootc_storage_p, & + cpool_to_deadcrootc_p, cpool_to_deadcrootc_storage_p, & + cpool_to_grainc_p , cpool_to_grainc_storage_p , & + +! cpool to growth repsiration + cpool_leaf_gr_p , cpool_froot_gr_p , & + cpool_livestem_gr_p , cpool_deadstem_gr_p , & + cpool_livecroot_gr_p , cpool_deadcroot_gr_p , & + cpool_leaf_storage_gr_p , cpool_froot_storage_gr_p , & + cpool_livestem_storage_gr_p , cpool_deadstem_storage_gr_p , & + cpool_livecroot_storage_gr_p, cpool_deadcroot_storage_gr_p , & + + cpool_grain_gr_p , cpool_grain_storage_gr_p , & + +! maintenance respiration fluxes (in) + leaf_xsmr_p, froot_xsmr_p, livestem_xsmr_p, livecroot_xsmr_p, grain_xsmr_p , & + leaf_curmr_p, froot_curmr_p, livestem_curmr_p, livecroot_curmr_p, grain_curmr_p, & + +! growth respiration fluxes (in/inout) + transfer_leaf_gr_p , transfer_froot_gr_p , & + transfer_livestem_gr_p , transfer_deadstem_gr_p , & + transfer_livecroot_gr_p, transfer_deadcroot_gr_p, & + transfer_grain_gr_p , xsmrpool_to_atm_p + + + IMPLICIT NONE + + PUBLIC :: CStateUpdate1 + +CONTAINS + + SUBROUTINE CStateUpdate1 (i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_transitions ! number of total transitions among different litter & soil bgc pools + integer ,intent(in) :: npcropmin ! index of first crop pft + +! Local variables + integer j,k + integer ivt, m + + DO m = ps, pe + cpool_p(m) = cpool_p(m) + psn_to_cpool_p(m) * deltim + ENDDO + DO j=1,nl_soil + decomp_cpools_sourcesink(j,i_met_lit,i) = phenology_to_met_c(j,i) *deltim + decomp_cpools_sourcesink(j,i_cel_lit,i) = phenology_to_cel_c(j,i) *deltim + decomp_cpools_sourcesink(j,i_lig_lit,i) = phenology_to_lig_c(j,i) *deltim + decomp_cpools_sourcesink(j,i_cwd ,i) = 0._r8 + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j=1,nl_soil + I_met_c_vr_acc(j,i) = I_met_c_vr_acc(j,i) + phenology_to_met_c(j,i) *deltim + I_cel_c_vr_acc(j,i) = I_cel_c_vr_acc(j,i) + phenology_to_cel_c(j,i) *deltim + I_lig_c_vr_acc(j,i) = I_lig_c_vr_acc(j,i) + phenology_to_lig_c(j,i) *deltim + ENDDO + ENDIF + + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + decomp_cpools_sourcesink(j,donor_pool(k),i) = & + decomp_cpools_sourcesink(j,donor_pool(k),i) & + - (decomp_hr_vr(j,k,i) + decomp_ctransfer_vr(j,k,i)) * deltim + ENDDO + ENDDO + + DO k = 1,ndecomp_transitions + IF ( receiver_pool(k) /= 0 ) THEN ! skip terminal transitions + DO j = 1,nl_soil + decomp_cpools_sourcesink(j,receiver_pool(k),i) = & + decomp_cpools_sourcesink(j,receiver_pool(k),i) & + + decomp_ctransfer_vr(j,k,i) * deltim + ENDDO + ENDIF + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j = 1, nl_soil + AKX_met_to_soil1_c_vr_acc (j,i) = AKX_met_to_soil1_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 1,i) * deltim + AKX_cel_to_soil1_c_vr_acc (j,i) = AKX_cel_to_soil1_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 2,i) * deltim + AKX_lig_to_soil2_c_vr_acc (j,i) = AKX_lig_to_soil2_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 3,i) * deltim + AKX_soil1_to_soil2_c_vr_acc(j,i) = AKX_soil1_to_soil2_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 4,i) * deltim + AKX_cwd_to_cel_c_vr_acc (j,i) = AKX_cwd_to_cel_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 5,i) * deltim + AKX_cwd_to_lig_c_vr_acc (j,i) = AKX_cwd_to_lig_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 6,i) * deltim + AKX_soil1_to_soil3_c_vr_acc(j,i) = AKX_soil1_to_soil3_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 7,i) * deltim + AKX_soil2_to_soil1_c_vr_acc(j,i) = AKX_soil2_to_soil1_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 8,i) * deltim + AKX_soil2_to_soil3_c_vr_acc(j,i) = AKX_soil2_to_soil3_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 9,i) * deltim + AKX_soil3_to_soil1_c_vr_acc(j,i) = AKX_soil3_to_soil1_c_vr_acc(j,i) + decomp_ctransfer_vr(j,10,i) * deltim + + AKX_met_exit_c_vr_acc (j,i) = AKX_met_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 1,i) + decomp_ctransfer_vr(j, 1,i)) * deltim + AKX_cel_exit_c_vr_acc (j,i) = AKX_cel_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 2,i) + decomp_ctransfer_vr(j, 2,i)) * deltim + AKX_lig_exit_c_vr_acc (j,i) = AKX_lig_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 3,i) + decomp_ctransfer_vr(j, 3,i)) * deltim + AKX_soil1_exit_c_vr_acc (j,i) = AKX_soil1_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 4,i) + decomp_ctransfer_vr(j, 4,i)) * deltim + AKX_cwd_exit_c_vr_acc (j,i) = AKX_cwd_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 5,i) + decomp_ctransfer_vr(j, 5,i)) * deltim + AKX_cwd_exit_c_vr_acc (j,i) = AKX_cwd_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 6,i) + decomp_ctransfer_vr(j, 6,i)) * deltim + AKX_soil1_exit_c_vr_acc (j,i) = AKX_soil1_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 7,i) + decomp_ctransfer_vr(j, 7,i)) * deltim + AKX_soil2_exit_c_vr_acc (j,i) = AKX_soil2_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 8,i) + decomp_ctransfer_vr(j, 8,i)) * deltim + AKX_soil2_exit_c_vr_acc (j,i) = AKX_soil2_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 9,i) + decomp_ctransfer_vr(j, 9,i)) * deltim + AKX_soil3_exit_c_vr_acc (j,i) = AKX_soil3_exit_c_vr_acc (j,i) + (decomp_hr_vr(j,10,i) + decomp_ctransfer_vr(j,10,i)) * deltim + ENDDO + ENDIF + + DO m = ps , pe + ivt = pftclass(m) + leafc_p (m) = leafc_p (m) + leafc_xfer_to_leafc_p (m) * deltim + leafc_xfer_p (m) = leafc_xfer_p (m) - leafc_xfer_to_leafc_p (m) * deltim + frootc_p (m) = frootc_p (m) + frootc_xfer_to_frootc_p(m) * deltim + frootc_xfer_p(m) = frootc_xfer_p(m) - frootc_xfer_to_frootc_p(m) * deltim + IF(woody(ivt) == 1)THEN + livestemc_p (m) = livestemc_p (m) + livestemc_xfer_to_livestemc_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) - livestemc_xfer_to_livestemc_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) + deadstemc_xfer_to_deadstemc_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) - deadstemc_xfer_to_deadstemc_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) + livecrootc_xfer_to_livecrootc_p(m) * deltim + livecrootc_xfer_p(m) = livecrootc_xfer_p(m) - livecrootc_xfer_to_livecrootc_p(m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) + deadcrootc_xfer_to_deadcrootc_p(m) * deltim + deadcrootc_xfer_p(m) = deadcrootc_xfer_p(m) - deadcrootc_xfer_to_deadcrootc_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops +! lines here for consistency; the transfer terms are zero + livestemc_p (m) = livestemc_p (m) + livestemc_xfer_to_livestemc_p(m) * deltim + livestemc_xfer_p(m) = livestemc_xfer_p(m) - livestemc_xfer_to_livestemc_p(m) * deltim + grainc_p (m) = grainc_p (m) + grainc_xfer_to_grainc_p (m) * deltim + grainc_xfer_p (m) = grainc_xfer_p (m) - grainc_xfer_to_grainc_p (m) * deltim + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_xf_to_leafc_p_acc (m) = AKX_leafc_xf_to_leafc_p_acc (m) + leafc_xfer_to_leafc_p (m) * deltim + AKX_frootc_xf_to_frootc_p_acc(m) = AKX_frootc_xf_to_frootc_p_acc(m) + frootc_xfer_to_frootc_p(m) * deltim + AKX_leafc_xf_exit_p_acc (m) = AKX_leafc_xf_exit_p_acc (m) + leafc_xfer_to_leafc_p (m) * deltim + AKX_frootc_xf_exit_p_acc (m) = AKX_frootc_xf_exit_p_acc (m) + frootc_xfer_to_frootc_p(m) * deltim + IF(woody(ivt) == 1)THEN + AKX_livestemc_xf_to_livestemc_p_acc (m) = AKX_livestemc_xf_to_livestemc_p_acc (m) + livestemc_xfer_to_livestemc_p (m) * deltim + AKX_livestemc_xf_exit_p_acc (m) = AKX_livestemc_xf_exit_p_acc (m) + livestemc_xfer_to_livestemc_p (m) * deltim + AKX_deadstemc_xf_to_deadstemc_p_acc (m) = AKX_deadstemc_xf_to_deadstemc_p_acc (m) + deadstemc_xfer_to_deadstemc_p (m) * deltim + AKX_deadstemc_xf_exit_p_acc (m) = AKX_deadstemc_xf_exit_p_acc (m) + deadstemc_xfer_to_deadstemc_p (m) * deltim + AKX_livecrootc_xf_to_livecrootc_p_acc(m) = AKX_livecrootc_xf_to_livecrootc_p_acc(m) + livecrootc_xfer_to_livecrootc_p(m) * deltim + AKX_livecrootc_xf_exit_p_acc (m) = AKX_livecrootc_xf_exit_p_acc (m) + livecrootc_xfer_to_livecrootc_p(m) * deltim + AKX_deadcrootc_xf_to_deadcrootc_p_acc(m) = AKX_deadcrootc_xf_to_deadcrootc_p_acc(m) + deadcrootc_xfer_to_deadcrootc_p(m) * deltim + AKX_deadcrootc_xf_exit_p_acc (m) = AKX_deadcrootc_xf_exit_p_acc (m) + deadcrootc_xfer_to_deadcrootc_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_livestemc_xf_to_livestemc_p_acc(m) = AKX_livestemc_xf_to_livestemc_p_acc(m) + livestemc_xfer_to_livestemc_p(m) * deltim + AKX_livestemc_xf_exit_p_acc (m) = AKX_livestemc_xf_exit_p_acc (m) + livestemc_xfer_to_livestemc_p(m) * deltim + AKX_grainc_xf_to_grainc_p_acc (m) = AKX_grainc_xf_to_grainc_p_acc (m) + grainc_xfer_to_grainc_p (m) * deltim + AKX_grainc_xf_exit_p_acc (m) = AKX_grainc_xf_exit_p_acc (m) + grainc_xfer_to_grainc_p (m) * deltim + ENDIF + ENDIF + +! phenology: litterfall fluxes + leafc_p (m) = leafc_p (m) - leafc_to_litter_p (m) * deltim + frootc_p(m) = frootc_p(m) - frootc_to_litter_p(m) * deltim + +! livewood turnover fluxes + IF (woody(ivt) == 1) THEN + livestemc_p (m) = livestemc_p (m) - livestemc_to_deadstemc_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) + livestemc_to_deadstemc_p (m) * deltim + livecrootc_p(m) = livecrootc_p(m) - livecrootc_to_deadcrootc_p(m) * deltim + deadcrootc_p(m) = deadcrootc_p(m) + livecrootc_to_deadcrootc_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + livestemc_p (m) = livestemc_p (m) - livestemc_to_litter_p(m) * deltim + grainc_p (m) = grainc_p (m) - (grainc_to_food_p(m) + grainc_to_seed_p(m)) * deltim + cropseedc_deficit_p(m) = cropseedc_deficit_p(m) - crop_seedc_to_leaf_p(m) * deltim + grainc_to_seed_p(m) * deltim + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_exit_p_acc (m) = AKX_leafc_exit_p_acc (m) + leafc_to_litter_p (m) * deltim + AKX_frootc_exit_p_acc(m) = AKX_frootc_exit_p_acc(m) + frootc_to_litter_p(m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemc_to_deadstemc_p_acc (m) = AKX_livestemc_to_deadstemc_p_acc (m) + livestemc_to_deadstemc_p (m) * deltim + AKX_livestemc_exit_p_acc (m) = AKX_livestemc_exit_p_acc (m) + livestemc_to_deadstemc_p (m) * deltim + AKX_livecrootc_to_deadcrootc_p_acc(m) = AKX_livecrootc_to_deadcrootc_p_acc(m) + livecrootc_to_deadcrootc_p(m) * deltim + AKX_livecrootc_exit_p_acc (m) = AKX_livecrootc_exit_p_acc (m) + livecrootc_to_deadcrootc_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_livestemc_exit_p_acc (m) = AKX_livestemc_exit_p_acc (m) + livestemc_to_litter_p (m) * deltim + AKX_grainc_exit_p_acc (m) = AKX_grainc_exit_p_acc (m) + (grainc_to_food_p(m) + grainc_to_seed_p(m)) * deltim + ENDIF + ENDIF +! maintenance respiration fluxes from xsmrpool + cpool_p (m) = cpool_p (m) - cpool_to_xsmrpool_p(m) * deltim + cpool_p (m) = cpool_p (m) - leaf_curmr_p (m) * deltim + cpool_p (m) = cpool_p (m) - froot_curmr_p (m) * deltim + IF (woody(ivt) == 1) THEN + cpool_p(m) = cpool_p (m) - livestem_curmr_p (m) * deltim + cpool_p(m) = cpool_p (m) - livecroot_curmr_p (m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN + cpool_p(m) = cpool_p (m) - livestem_curmr_p (m) * deltim + cpool_p(m) = cpool_p (m) - grain_curmr_p (m) * deltim + ENDIF +#ifdef FUN + cpool_p (m) = cpool_p (m) - soilc_change_p (m) * deltim +#endif + xsmrpool_p(m) = xsmrpool_p(m) + cpool_to_xsmrpool_p(m) * deltim + xsmrpool_p(m) = xsmrpool_p(m) - leaf_xsmr_p (m) * deltim + xsmrpool_p(m) = xsmrpool_p(m) - froot_xsmr_p (m) * deltim + IF (woody(ivt) == 1) THEN + xsmrpool_p(m) = xsmrpool_p(m) - livestem_xsmr_p (m) * deltim + xsmrpool_p(m) = xsmrpool_p(m) - livecroot_xsmr_p(m) * deltim + ENDIF + cpool_p (m) = cpool_p (m) - cpool_to_leafc_p (m) * deltim + leafc_p (m) = leafc_p (m) + cpool_to_leafc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_leafc_storage_p (m) * deltim + leafc_storage_p (m) = leafc_storage_p (m) + cpool_to_leafc_storage_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_frootc_p (m) * deltim + frootc_p (m) = frootc_p (m) + cpool_to_frootc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_frootc_storage_p(m) * deltim + frootc_storage_p(m) = frootc_storage_p(m) + cpool_to_frootc_storage_p(m) * deltim + IF (woody(ivt) == 1) THEN + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_p (m) * deltim + livestemc_p (m) = livestemc_p (m) + cpool_to_livestemc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_storage_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) + cpool_to_livestemc_storage_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadstemc_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) + cpool_to_deadstemc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadstemc_storage_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) + cpool_to_deadstemc_storage_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livecrootc_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) + cpool_to_livecrootc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livecrootc_storage_p(m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) + cpool_to_livecrootc_storage_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadcrootc_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) + cpool_to_deadcrootc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadcrootc_storage_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) + cpool_to_deadcrootc_storage_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_p (m) * deltim + livestemc_p (m) = livestemc_p (m) + cpool_to_livestemc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_storage_p(m) * deltim + livestemc_storage_p(m) = livestemc_storage_p(m) + cpool_to_livestemc_storage_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_grainc_p (m) * deltim + grainc_p (m) = grainc_p (m) + cpool_to_grainc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_grainc_storage_p (m) * deltim + grainc_storage_p (m) = grainc_storage_p (m) + cpool_to_grainc_storage_p (m) * deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + I_leafc_p_acc(m) = I_leafc_p_acc(m) + cpool_to_leafc_p (m) * deltim + I_leafc_st_p_acc(m) = I_leafc_st_p_acc(m) + cpool_to_leafc_storage_p (m) * deltim + I_frootc_p_acc(m) = I_frootc_p_acc(m) + cpool_to_frootc_p (m) * deltim + I_frootc_st_p_acc(m) = I_frootc_st_p_acc(m) + cpool_to_frootc_storage_p (m) * deltim + IF(woody(ivt) == 1) THEN + I_livestemc_p_acc (m) = I_livestemc_p_acc (m) + cpool_to_livestemc_p (m) * deltim + I_livestemc_st_p_acc (m) = I_livestemc_st_p_acc (m) + cpool_to_livestemc_storage_p (m) * deltim + I_deadstemc_p_acc (m) = I_deadstemc_p_acc (m) + cpool_to_deadstemc_p (m) * deltim + I_deadstemc_st_p_acc (m) = I_deadstemc_st_p_acc (m) + cpool_to_deadstemc_storage_p (m) * deltim + I_livecrootc_p_acc (m) = I_livecrootc_p_acc (m) + cpool_to_livecrootc_p (m) * deltim + I_livecrootc_st_p_acc(m) = I_livecrootc_st_p_acc(m) + cpool_to_livecrootc_storage_p(m) * deltim + I_deadcrootc_p_acc (m) = I_deadcrootc_p_acc (m) + cpool_to_deadcrootc_p (m) * deltim + I_deadcrootc_st_p_acc(m) = I_deadcrootc_st_p_acc(m) + cpool_to_deadcrootc_storage_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + I_livestemc_p_acc (m) = I_livestemc_p_acc (m) + cpool_to_livestemc_p (m) * deltim + I_livestemc_st_p_acc (m) = I_livestemc_st_p_acc (m) + cpool_to_livestemc_storage_p (m) * deltim + I_grainc_p_acc (m) = I_grainc_p_acc (m) + cpool_to_grainc_p (m) * deltim + I_grainc_st_p_acc (m) = I_grainc_st_p_acc (m) + cpool_to_grainc_storage_p (m) * deltim + ENDIF + ENDIF + ! growth respiration for transfer growth + cpool_p (m) = cpool_p (m) - cpool_leaf_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_froot_gr_p (m) * deltim + IF(woody(ivt) == 1) THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadstem_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_livecroot_gr_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadcroot_gr_p(m) * deltim + ENDIF + IF(ivt >= npcropmin)THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_grain_gr_p (m) * deltim + ENDIF + + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_leaf_gr_p (m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_froot_gr_p(m) * deltim + IF (woody(ivt) == 1) THEN + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_livestem_gr_p (m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_deadstem_gr_p (m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_livecroot_gr_p(m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_deadcroot_gr_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_livestem_gr_p(m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_grain_gr_p (m) * deltim + ENDIF + ! growth respiration at time of storage + cpool_p (m) = cpool_p (m) - cpool_leaf_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_froot_storage_gr_p(m) * deltim + IF(woody(ivt) == 1)THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadstem_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_livecroot_storage_gr_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadcroot_storage_gr_p(m) * deltim + ENDIF + IF(ivt >= npcropmin)THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_grain_storage_gr_p (m) * deltim + ENDIF + + ! growth respiration stored for release during transfer growth + cpool_p (m) = cpool_p (m) - cpool_to_gresp_storage_p(m) * deltim + gresp_storage_p(m) = gresp_storage_p(m) + cpool_to_gresp_storage_p(m) * deltim + + ! move storage pools into transfer pools + leafc_storage_p (m) = leafc_storage_p (m) - leafc_storage_to_xfer_p (m) * deltim + leafc_xfer_p (m) = leafc_xfer_p (m) + leafc_storage_to_xfer_p (m) * deltim + frootc_storage_p(m) = frootc_storage_p(m) - frootc_storage_to_xfer_p(m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) + frootc_storage_to_xfer_p(m) * deltim + IF (woody(ivt) == 1) THEN + gresp_storage_p (m) = gresp_storage_p (m) - gresp_storage_to_xfer_p(m) * deltim + gresp_xfer_p (m) = gresp_xfer_p (m) + gresp_storage_to_xfer_p(m) * deltim + + livestemc_storage_p (m) = livestemc_storage_p (m) - livestemc_storage_to_xfer_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) + livestemc_storage_to_xfer_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) - deadstemc_storage_to_xfer_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) + deadstemc_storage_to_xfer_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) - livecrootc_storage_to_xfer_p(m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) + livecrootc_storage_to_xfer_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) - deadcrootc_storage_to_xfer_p(m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) + deadcrootc_storage_to_xfer_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + livestemc_storage_p (m) = livestemc_storage_p(m) - livestemc_storage_to_xfer_p(m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) + livestemc_storage_to_xfer_p(m) * deltim + grainc_storage_p (m) = grainc_storage_p (m) - grainc_storage_to_xfer_p (m) * deltim + grainc_xfer_p (m) = grainc_xfer_p (m) + grainc_storage_to_xfer_p (m) * deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_st_to_leafc_xf_p_acc (m) = AKX_leafc_st_to_leafc_xf_p_acc (m) + leafc_storage_to_xfer_p (m) * deltim + AKX_leafc_st_exit_p_acc (m) = AKX_leafc_st_exit_p_acc (m) + leafc_storage_to_xfer_p (m) * deltim + AKX_frootc_st_to_frootc_xf_p_acc(m) = AKX_frootc_st_to_frootc_xf_p_acc(m) + frootc_storage_to_xfer_p(m) * deltim + AKX_frootc_st_exit_p_acc (m) = AKX_frootc_st_exit_p_acc (m) + frootc_storage_to_xfer_p(m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemc_st_to_livestemc_xf_p_acc (m) = AKX_livestemc_st_to_livestemc_xf_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_livestemc_st_exit_p_acc (m) = AKX_livestemc_st_exit_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) = AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) + deadstemc_storage_to_xfer_p (m) * deltim + AKX_deadstemc_st_exit_p_acc (m) = AKX_deadstemc_st_exit_p_acc (m) + deadstemc_storage_to_xfer_p (m) * deltim + AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) = AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) + livecrootc_storage_to_xfer_p(m) * deltim + AKX_livecrootc_st_exit_p_acc (m) = AKX_livecrootc_st_exit_p_acc (m) + livecrootc_storage_to_xfer_p(m) * deltim + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) = AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) + deadcrootc_storage_to_xfer_p(m) * deltim + AKX_deadcrootc_st_exit_p_acc (m) = AKX_deadcrootc_st_exit_p_acc (m) + deadcrootc_storage_to_xfer_p(m) * deltim + ENDIF + IF( ivt >= npcropmin) THEN + AKX_livestemc_st_to_livestemc_xf_p_acc (m) = AKX_livestemc_st_to_livestemc_xf_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_livestemc_st_exit_p_acc (m) = AKX_livestemc_st_exit_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_grainc_st_to_grainc_xf_p_acc (m) = AKX_grainc_st_to_grainc_xf_p_acc (m) + grainc_storage_to_xfer_p (m) * deltim + AKX_grainc_st_exit_p_acc (m) = AKX_grainc_st_exit_p_acc (m) + grainc_storage_to_xfer_p (m) * deltim + ENDIF + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + xsmrpool_p(m) = xsmrpool_p(m) - livestem_xsmr_p(m)*deltim + xsmrpool_p(m) = xsmrpool_p(m) - grain_xsmr_p (m)*deltim + IF (harvdate_p(m) < 999) THEN ! beginning at harvest, send to atm + xsmrpool_to_atm_p(m) = xsmrpool_to_atm_p(m) + xsmrpool_p(m)/deltim + xsmrpool_p (m) = 0._r8 + xsmrpool_to_atm_p(m) = xsmrpool_to_atm_p(m) + cpool_p (m)/deltim + cpool_p (m) = 0._r8 + xsmrpool_to_atm_p(m) = xsmrpool_to_atm_p(m) + frootc_p(m)/deltim + frootc_p (m) = 0._r8 + ENDIF + ENDIF +#ifdef CROP + cropprod1c_loss_p(m) = cropprod1c_p(m) * 7.2e-8_r8 + cropprod1c_p (m) = cropprod1c_p(m) + grainc_to_food_p(m) * deltim - cropprod1c_loss_p(m) * deltim +#endif + ENDDO ! END pft loop + + END SUBROUTINE CStateUpdate1 + +END MODULE MOD_BGC_CNCStateUpdate1 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 new file mode 100644 index 0000000000..25fee8e971 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 @@ -0,0 +1,176 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNCStateUpdate2 + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil carbon. The major updates are included in bgc_CNCStateUpdate1Mod +! 1. Update gap-mortality-associated veg and soil C pool size changes +! 2. Record the accumulated C transfers associated to gap-mortality for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated gap-mortality-associated C transfers for veg and soil C semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd + USE MOD_Vars_TimeVariables, only: & +! decomposition pools & fluxes variables (inout) + decomp_cpools_vr, & + I_met_c_vr_acc, I_cel_c_vr_acc, I_lig_c_vr_acc, I_cwd_c_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + gap_mortality_to_met_c, gap_mortality_to_cel_c , & + gap_mortality_to_lig_c, gap_mortality_to_cwdc + + USE MOD_BGC_Vars_PFTimeVariables, only: & +! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + gresp_storage_p , gresp_xfer_p , & + +! SASU variables + AKX_leafc_exit_p_acc , AKX_leafc_st_exit_p_acc , AKX_leafc_xf_exit_p_acc , & + AKX_frootc_exit_p_acc , AKX_frootc_st_exit_p_acc , AKX_frootc_xf_exit_p_acc , & + AKX_livestemc_exit_p_acc , AKX_livestemc_st_exit_p_acc , AKX_livestemc_xf_exit_p_acc , & + AKX_deadstemc_exit_p_acc , AKX_deadstemc_st_exit_p_acc , AKX_deadstemc_xf_exit_p_acc , & + AKX_livecrootc_exit_p_acc, AKX_livecrootc_st_exit_p_acc, AKX_livecrootc_xf_exit_p_acc, & + AKX_deadcrootc_exit_p_acc, AKX_deadcrootc_st_exit_p_acc, AKX_deadcrootc_xf_exit_p_acc + + USE MOD_BGC_Vars_1DPFTFluxes, only: & +! vegetation carbon flux variables + m_leafc_to_litter_p , m_leafc_storage_to_litter_p , m_leafc_xfer_to_litter_p , & + m_frootc_to_litter_p , m_frootc_storage_to_litter_p , m_frootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , m_livestemc_storage_to_litter_p , m_livestemc_xfer_to_litter_p , & + m_deadstemc_to_litter_p , m_deadstemc_storage_to_litter_p , m_deadstemc_xfer_to_litter_p , & + m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & + m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & + m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p + + IMPLICIT NONE + + PUBLIC CStateUpdate2 + +CONTAINS + + SUBROUTINE CStateUpdate2 (i, ps, pe, deltim, nl_soil) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in second + integer ,intent(in) :: nl_soil ! number of total soil layers + + integer j + integer m + +! column level carbon fluxes from gap-phase mortality + DO j = 1,nl_soil +! column gap mortality fluxes + decomp_cpools_vr(j,i_met_lit,i) = & + decomp_cpools_vr(j,i_met_lit,i) + gap_mortality_to_met_c(j,i) * deltim + decomp_cpools_vr(j,i_cel_lit,i) = & + decomp_cpools_vr(j,i_cel_lit,i) + gap_mortality_to_cel_c(j,i) * deltim + decomp_cpools_vr(j,i_lig_lit,i) = & + decomp_cpools_vr(j,i_lig_lit,i) + gap_mortality_to_lig_c(j,i) * deltim + decomp_cpools_vr(j,i_cwd,i) = & + decomp_cpools_vr(j,i_cwd,i) + gap_mortality_to_cwdc(j,i) * deltim + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j = 1,nl_soil + I_met_c_vr_acc(j,i) = I_met_c_vr_acc(j,i) + gap_mortality_to_met_c(j,i) * deltim + I_cel_c_vr_acc(j,i) = I_cel_c_vr_acc(j,i) + gap_mortality_to_cel_c(j,i) * deltim + I_lig_c_vr_acc(j,i) = I_lig_c_vr_acc(j,i) + gap_mortality_to_lig_c(j,i) * deltim + I_cwd_c_vr_acc(j,i) = I_cwd_c_vr_acc(j,i) + gap_mortality_to_cwdc (j,i) * deltim + ENDDO + ENDIF + + ! patch loop + + DO m = ps, pe + gresp_xfer_p (m) = gresp_xfer_p(m) & + - m_gresp_xfer_to_litter_p (m) * deltim + gresp_storage_p (m) = gresp_storage_p(m) & + - m_gresp_storage_to_litter_p (m) * deltim + ! patch-level carbon fluxes from gap-phase mortality + ! displayed pools + leafc_p (m) = leafc_p (m) & + - m_leafc_to_litter_p (m) * deltim + frootc_p (m) = frootc_p (m) & + - m_frootc_to_litter_p (m) * deltim + livestemc_p (m) = livestemc_p (m) & + - m_livestemc_to_litter_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) & + - m_deadstemc_to_litter_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) & + - m_livecrootc_to_litter_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) & + - m_deadcrootc_to_litter_p (m) * deltim + + ! storage pools + leafc_storage_p (m) = leafc_storage_p (m) & + - m_leafc_storage_to_litter_p (m) * deltim + frootc_storage_p (m) = frootc_storage_p (m) & + - m_frootc_storage_to_litter_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) & + - m_livestemc_storage_to_litter_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) & + - m_deadstemc_storage_to_litter_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) & + - m_livecrootc_storage_to_litter_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) & + - m_deadcrootc_storage_to_litter_p(m) * deltim + + ! transfer pools + leafc_xfer_p (m) = leafc_xfer_p (m) & + - m_leafc_xfer_to_litter_p (m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) & + - m_frootc_xfer_to_litter_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) & + - m_livestemc_xfer_to_litter_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) & + - m_deadstemc_xfer_to_litter_p (m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) & + - m_livecrootc_xfer_to_litter_p (m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) & + - m_deadcrootc_xfer_to_litter_p (m) * deltim + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_exit_p_acc (m) = AKX_leafc_exit_p_acc (m) + m_leafc_to_litter_p (m) * deltim + AKX_frootc_exit_p_acc (m) = AKX_frootc_exit_p_acc (m) + m_frootc_to_litter_p (m) * deltim + AKX_livestemc_exit_p_acc (m) = AKX_livestemc_exit_p_acc (m) + m_livestemc_to_litter_p (m) * deltim + AKX_deadstemc_exit_p_acc (m) = AKX_deadstemc_exit_p_acc (m) + m_deadstemc_to_litter_p (m) * deltim + AKX_livecrootc_exit_p_acc (m) = AKX_livecrootc_exit_p_acc (m) + m_livecrootc_to_litter_p (m) * deltim + AKX_deadcrootc_exit_p_acc (m) = AKX_deadcrootc_exit_p_acc (m) + m_deadcrootc_to_litter_p (m) * deltim + + AKX_leafc_st_exit_p_acc (m) = AKX_leafc_st_exit_p_acc (m) + m_leafc_storage_to_litter_p (m) * deltim + AKX_frootc_st_exit_p_acc (m) = AKX_frootc_st_exit_p_acc (m) + m_frootc_storage_to_litter_p (m) * deltim + AKX_livestemc_st_exit_p_acc (m) = AKX_livestemc_st_exit_p_acc (m) + m_livestemc_storage_to_litter_p (m) * deltim + AKX_deadstemc_st_exit_p_acc (m) = AKX_deadstemc_st_exit_p_acc (m) + m_deadstemc_storage_to_litter_p (m) * deltim + AKX_livecrootc_st_exit_p_acc(m) = AKX_livecrootc_st_exit_p_acc(m) + m_livecrootc_storage_to_litter_p(m) * deltim + AKX_deadcrootc_st_exit_p_acc(m) = AKX_deadcrootc_st_exit_p_acc(m) + m_deadcrootc_storage_to_litter_p(m) * deltim + + AKX_leafc_xf_exit_p_acc (m) = AKX_leafc_xf_exit_p_acc (m) + m_leafc_xfer_to_litter_p (m) * deltim + AKX_frootc_xf_exit_p_acc (m) = AKX_frootc_xf_exit_p_acc (m) + m_frootc_xfer_to_litter_p (m) * deltim + AKX_livestemc_xf_exit_p_acc (m) = AKX_livestemc_xf_exit_p_acc (m) + m_livestemc_xfer_to_litter_p (m) * deltim + AKX_deadstemc_xf_exit_p_acc (m) = AKX_deadstemc_xf_exit_p_acc (m) + m_deadstemc_xfer_to_litter_p (m) * deltim + AKX_livecrootc_xf_exit_p_acc(m) = AKX_livecrootc_xf_exit_p_acc(m) + m_livecrootc_xfer_to_litter_p (m) * deltim + AKX_deadcrootc_xf_exit_p_acc(m) = AKX_deadcrootc_xf_exit_p_acc(m) + m_deadcrootc_xfer_to_litter_p (m) * deltim + ENDIF + ENDDO + + END SUBROUTINE CStateUpdate2 + +END MODULE MOD_BGC_CNCStateUpdate2 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 new file mode 100644 index 0000000000..afb640fdd1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 @@ -0,0 +1,194 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNCStateUpdate3 + +!------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil carbon. The major updates are included in bgc_CNCStateUpdate1Mod +! 1. Update fire-associated veg and soil(litter) C pool size changes +! 2. Record the accumulated C transfers associated to fire for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record accumulated fire-associated C transfers for veg and soil C semi-analytic spinup + + USE MOD_Precision + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition pools & fluxes variables (inout) + decomp_cpools_vr + + USE MOD_BGC_Vars_1DFluxes, only: & + m_decomp_cpools_to_fire_vr, & + fire_mortality_to_met_c, fire_mortality_to_cel_c, & + fire_mortality_to_lig_c, fire_mortality_to_cwdc + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + gresp_storage_p , gresp_xfer_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation carbon flux variables + m_leafc_to_fire_p , m_leafc_storage_to_fire_p , m_leafc_xfer_to_fire_p , & + m_frootc_to_fire_p , m_frootc_storage_to_fire_p , m_frootc_xfer_to_fire_p , & + m_livestemc_to_fire_p , m_livestemc_storage_to_fire_p , m_livestemc_xfer_to_fire_p , & + m_deadstemc_to_fire_p , m_deadstemc_storage_to_fire_p , m_deadstemc_xfer_to_fire_p , & + m_livecrootc_to_fire_p , m_livecrootc_storage_to_fire_p, m_livecrootc_xfer_to_fire_p, & + m_deadcrootc_to_fire_p , m_deadcrootc_storage_to_fire_p, m_deadcrootc_xfer_to_fire_p, & + m_livestemc_to_deadstemc_fire_p , m_livecrootc_to_deadcrootc_fire_p , & + m_gresp_storage_to_fire_p , m_gresp_xfer_to_fire_p , & + + m_leafc_to_litter_fire_p , m_leafc_storage_to_litter_fire_p , m_leafc_xfer_to_litter_fire_p , & + m_frootc_to_litter_fire_p , m_frootc_storage_to_litter_fire_p , m_frootc_xfer_to_litter_fire_p , & + m_livestemc_to_litter_fire_p , m_livestemc_storage_to_litter_fire_p , m_livestemc_xfer_to_litter_fire_p , & + m_deadstemc_to_litter_fire_p , m_deadstemc_storage_to_litter_fire_p , m_deadstemc_xfer_to_litter_fire_p , & + m_livecrootc_to_litter_fire_p , m_livecrootc_storage_to_litter_fire_p, m_livecrootc_xfer_to_litter_fire_p, & + m_deadcrootc_to_litter_fire_p , m_deadcrootc_storage_to_litter_fire_p, m_deadcrootc_xfer_to_litter_fire_p, & + m_gresp_storage_to_litter_fire_p, m_gresp_xfer_to_litter_fire_p + + IMPLICIT NONE + + PUBLIC CStateUpdate3 + +CONTAINS + + SUBROUTINE CStateUpdate3(i, ps, pe, deltim, nl_soil, ndecomp_pools) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil number + integer ,intent(in) :: ndecomp_pools ! number total litter & soil pools + + integer j,l,m + + DO j = 1, nl_soil + ! patch-level wood to column-level CWD (uncombusted wood) + decomp_cpools_vr(j,i_cwd,i) = decomp_cpools_vr(j,i_cwd,i) & + + fire_mortality_to_cwdc (j,i) * deltim + + ! patch-level wood to column-level litter (uncombusted wood) + decomp_cpools_vr(j,i_met_lit,i) = decomp_cpools_vr(j,i_met_lit,i) & + + fire_mortality_to_met_c(j,i) * deltim + decomp_cpools_vr(j,i_cel_lit,i) = decomp_cpools_vr(j,i_cel_lit,i) & + + fire_mortality_to_cel_c(j,i) * deltim + decomp_cpools_vr(j,i_lig_lit,i) = decomp_cpools_vr(j,i_lig_lit,i) & + + fire_mortality_to_lig_c(j,i) * deltim + ENDDO + + ! litter and CWD losses to fire + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_vr(j,l,i) = decomp_cpools_vr(j,l,i) & + - m_decomp_cpools_to_fire_vr(j,l,i) * deltim + ENDDO + ENDDO + + ! patch-level carbon fluxes from fire + DO m = ps , pe + gresp_storage_p (m) = gresp_storage_p (m) & + - m_gresp_storage_to_fire_p (m) * deltim + gresp_storage_p (m) = gresp_storage_p (m) & + - m_gresp_storage_to_litter_fire_p (m) * deltim + gresp_xfer_p (m) = gresp_xfer_p (m) & + - m_gresp_xfer_to_fire_p (m) * deltim + gresp_xfer_p (m) = gresp_xfer_p (m) & + - m_gresp_xfer_to_litter_fire_p (m) * deltim + ! displayed pools + leafc_p (m) = leafc_p (m) & + - m_leafc_to_fire_p (m) * deltim + leafc_p (m) = leafc_p (m) & + - m_leafc_to_litter_fire_p (m) * deltim + frootc_p (m) = frootc_p (m) & + - m_frootc_to_fire_p (m) * deltim + frootc_p (m) = frootc_p (m) & + - m_frootc_to_litter_fire_p (m) * deltim + livestemc_p (m) = livestemc_p (m) & + - m_livestemc_to_fire_p (m) * deltim + livestemc_p (m) = livestemc_p (m) & + - m_livestemc_to_litter_fire_p (m) * deltim & + - m_livestemc_to_deadstemc_fire_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) & + - m_deadstemc_to_fire_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) & + - m_deadstemc_to_litter_fire_p (m) * deltim & + + m_livestemc_to_deadstemc_fire_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) & + - m_livecrootc_to_fire_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) & + - m_livecrootc_to_litter_fire_p (m) * deltim & + - m_livecrootc_to_deadcrootc_fire_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) & + - m_deadcrootc_to_fire_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) & + - m_deadcrootc_to_litter_fire_p (m) * deltim & + + m_livecrootc_to_deadcrootc_fire_p (m) * deltim + + ! storage pools + leafc_storage_p (m) = leafc_storage_p (m) & + - m_leafc_storage_to_fire_p (m) * deltim + leafc_storage_p (m) = leafc_storage_p (m) & + - m_leafc_storage_to_litter_fire_p (m) * deltim + frootc_storage_p (m) = frootc_storage_p (m) & + - m_frootc_storage_to_fire_p (m) * deltim + frootc_storage_p (m) = frootc_storage_p (m) & + - m_frootc_storage_to_litter_fire_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) & + - m_livestemc_storage_to_fire_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) & + - m_livestemc_storage_to_litter_fire_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) & + - m_deadstemc_storage_to_fire_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) & + - m_deadstemc_storage_to_litter_fire_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) & + - m_livecrootc_storage_to_fire_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) & + - m_livecrootc_storage_to_litter_fire_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) & + - m_deadcrootc_storage_to_fire_p (m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) & + - m_deadcrootc_storage_to_litter_fire_p(m) * deltim + + ! transfer pools + leafc_xfer_p (m) = leafc_xfer_p (m) & + - m_leafc_xfer_to_fire_p (m) * deltim + leafc_xfer_p (m) = leafc_xfer_p (m) & + - m_leafc_xfer_to_litter_fire_p (m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) & + - m_frootc_xfer_to_fire_p (m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) & + - m_frootc_xfer_to_litter_fire_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) & + - m_livestemc_xfer_to_fire_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) & + - m_livestemc_xfer_to_litter_fire_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) & + - m_deadstemc_xfer_to_fire_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) & + - m_deadstemc_xfer_to_litter_fire_p (m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) & + - m_livecrootc_xfer_to_fire_p (m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) & + - m_livecrootc_xfer_to_litter_fire_p (m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) & + - m_deadcrootc_xfer_to_fire_p (m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) & + - m_deadcrootc_xfer_to_litter_fire_p (m) * deltim + ENDDO + + END SUBROUTINE CStateUpdate3 + +END MODULE MOD_BGC_CNCStateUpdate3 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 new file mode 100644 index 0000000000..d0678b2a5b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 @@ -0,0 +1,410 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNNStateUpdate1 + +!------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! First updates in vegetation and soil nitrogen. The major updates are included in bgc_CNNStateUpdate1Mod +! 1. Update phenology-associated veg and soil N pool size changes, including plant growth +! 2. Update decomposition-associated soil N pool size changes +! 3. Record the accumulated N transfers associated to phenology and decomposition for semi-analytic spinup +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated phenology-associated N transfer for veg and soil N semi-analytic spinup +! 3) Record the accumulated decomposition-associated N transfer for soil N semi-analytic spinup + + USE MOD_Precision + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Const_PFT, only: woody + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + ! bgc constants + donor_pool, receiver_pool, i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3 + + USE MOD_BGC_Vars_TimeVariables, only: & + I_met_n_vr_acc, I_cel_n_vr_acc, I_lig_n_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition pools flux varables (in) + decomp_npools_sourcesink, & + phenology_to_met_n , phenology_to_cel_n, phenology_to_lig_n + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + grainn_p , grainn_storage_p , grainn_xfer_p , & + cropseedn_deficit_p, retransn_p , npool_p , & + + ! SASU variables + I_leafn_p_acc , I_leafn_st_p_acc , I_frootn_p_acc , I_frootn_st_p_acc , & + I_livestemn_p_acc , I_livestemn_st_p_acc , I_deadstemn_p_acc , I_deadstemn_st_p_acc , & + I_livecrootn_p_acc, I_livecrootn_st_p_acc, I_deadcrootn_p_acc, I_deadcrootn_st_p_acc, & + I_grainn_p_acc , I_grainn_st_p_acc , & + + AKX_leafn_xf_to_leafn_p_acc , AKX_frootn_xf_to_frootn_p_acc , AKX_livestemn_xf_to_livestemn_p_acc , & + AKX_deadstemn_xf_to_deadstemn_p_acc , AKX_livecrootn_xf_to_livecrootn_p_acc , AKX_deadcrootn_xf_to_deadcrootn_p_acc , & + AKX_grainn_xf_to_grainn_p_acc , AKX_livestemn_to_deadstemn_p_acc , AKX_livecrootn_to_deadcrootn_p_acc , & + + AKX_leafn_st_to_leafn_xf_p_acc , AKX_frootn_st_to_frootn_xf_p_acc , AKX_livestemn_st_to_livestemn_xf_p_acc , & + AKX_deadstemn_st_to_deadstemn_xf_p_acc, AKX_livecrootn_st_to_livecrootn_xf_p_acc, AKX_deadcrootn_st_to_deadcrootn_xf_p_acc, & + AKX_livestemn_st_to_livestemn_xf_p_acc, AKX_grainn_st_to_grainn_xf_p_acc , & + + AKX_leafn_to_retransn_p_acc , AKX_frootn_to_retransn_p_acc , AKX_livestemn_to_retransn_p_acc , & + AKX_livecrootn_to_retransn_p_acc , & + + AKX_retransn_to_leafn_p_acc , AKX_retransn_to_frootn_p_acc , AKX_retransn_to_livestemn_p_acc , & + AKX_retransn_to_deadstemn_p_acc , AKX_retransn_to_livecrootn_p_acc , AKX_retransn_to_deadcrootn_p_acc , & + AKX_retransn_to_grainn_p_acc , & + + AKX_retransn_to_leafn_st_p_acc , AKX_retransn_to_frootn_st_p_acc , AKX_retransn_to_livestemn_st_p_acc , & + AKX_retransn_to_deadstemn_st_p_acc , AKX_retransn_to_livecrootn_st_p_acc , AKX_retransn_to_deadcrootn_st_p_acc , & + AKX_retransn_to_grainn_st_p_acc , & + + AKX_leafn_exit_p_acc , AKX_frootn_exit_p_acc , AKX_livestemn_exit_p_acc , & + AKX_deadstemn_exit_p_acc , AKX_livecrootn_exit_p_acc , AKX_deadcrootn_exit_p_acc , & + AKX_grainn_exit_p_acc , AKX_retransn_exit_p_acc , & + + AKX_leafn_st_exit_p_acc , AKX_frootn_st_exit_p_acc , AKX_livestemn_st_exit_p_acc , & + AKX_deadstemn_st_exit_p_acc , AKX_livecrootn_st_exit_p_acc , AKX_deadcrootn_st_exit_p_acc , & + AKX_grainn_st_exit_p_acc , & + + AKX_leafn_xf_exit_p_acc , AKX_frootn_xf_exit_p_acc , AKX_livestemn_xf_exit_p_acc , & + AKX_deadstemn_xf_exit_p_acc , AKX_livecrootn_xf_exit_p_acc , AKX_deadcrootn_xf_exit_p_acc , & + AKX_grainn_xf_exit_p_acc + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation nitrogen flux variables (in) + ! xfer to display + leafn_xfer_to_leafn_p , frootn_xfer_to_frootn_p , & + livestemn_xfer_to_livestemn_p , deadstemn_xfer_to_deadstemn_p , & + livecrootn_xfer_to_livecrootn_p, deadcrootn_xfer_to_deadcrootn_p, & + grainn_xfer_to_grainn_p , & + + ! storage to xfer (in) + leafn_storage_to_xfer_p , frootn_storage_to_xfer_p , & + livestemn_storage_to_xfer_p , deadstemn_storage_to_xfer_p , & + livecrootn_storage_to_xfer_p, deadcrootn_storage_to_xfer_p, & + grainn_storage_to_xfer_p , & + + ! display to litter & live to dead (in) + leafn_to_litter_p , frootn_to_litter_p , & + grainn_to_food_p , grainn_to_seed_p , & + crop_seedn_to_leaf_p , livestemn_to_litter_p , & + livestemn_to_deadstemn_p, livecrootn_to_deadcrootn_p, & + + ! display to retransn / retransn to npool (in) + leafn_to_retransn_p , frootn_to_retransn_p , & + livestemn_to_retransn_p , livecrootn_to_retransn_p , & + retransn_to_npool_p , free_retransn_to_npool_p , & + + ! npool to display/storage (in) + npool_to_leafn_p , npool_to_leafn_storage_p , & + npool_to_frootn_p , npool_to_frootn_storage_p , & + npool_to_livestemn_p , npool_to_livestemn_storage_p , & + npool_to_deadstemn_p , npool_to_deadstemn_storage_p , & + npool_to_livecrootn_p, npool_to_livecrootn_storage_p, & + npool_to_deadcrootn_p, npool_to_deadcrootn_storage_p, & + npool_to_grainn_p , npool_to_grainn_storage_p , plant_nalloc_p + + USE MOD_Vars_PFTimeInvariants, only: pftfrac + IMPLICIT NONE + + PUBLIC NStateUpdate1 + +CONTAINS + + SUBROUTINE NStateUpdate1 (i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_transitions ! number of total transitions among different litter & soil bgc pools + integer ,intent(in) :: npcropmin ! index of first crop pft + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer j,k + integer ivt, m + real(r8) f_retr_in_nall + + ! soilbiogeochemistry fluxes TODO - this should be moved elsewhere + ! plant to litter fluxes - phenology and dynamic landcover fluxes + DO j = 1, nl_soil + decomp_npools_sourcesink(j,i_met_lit,i) = phenology_to_met_n(j,i) * deltim + + decomp_npools_sourcesink(j,i_cel_lit,i) = phenology_to_cel_n(j,i) * deltim + + decomp_npools_sourcesink(j,i_lig_lit,i) = phenology_to_lig_n(j,i) * deltim + + decomp_npools_sourcesink(j,i_cwd,i) = 0._r8 + + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j=1,nl_soil + I_met_n_vr_acc(j,i) = I_met_n_vr_acc(j,i) + phenology_to_met_n(j,i) * deltim + I_cel_n_vr_acc(j,i) = I_cel_n_vr_acc(j,i) + phenology_to_cel_n(j,i) * deltim + I_lig_n_vr_acc(j,i) = I_lig_n_vr_acc(j,i) + phenology_to_lig_n(j,i) * deltim + ENDDO + ENDIF + + DO m = ps , pe + ivt = pftclass(m) + ! phenology: transfer growth fluxes + leafn_p(m) = leafn_p(m) + leafn_xfer_to_leafn_p(m)*deltim + leafn_xfer_p(m) = leafn_xfer_p(m) - leafn_xfer_to_leafn_p(m)*deltim + frootn_p(m) = frootn_p(m) + frootn_xfer_to_frootn_p(m)*deltim + frootn_xfer_p(m) = frootn_xfer_p(m) - frootn_xfer_to_frootn_p(m)*deltim + + IF (woody(ivt) == 1) THEN + livestemn_p(m) = livestemn_p(m) + livestemn_xfer_to_livestemn_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) - livestemn_xfer_to_livestemn_p(m)*deltim + deadstemn_p(m) = deadstemn_p(m) + deadstemn_xfer_to_deadstemn_p(m)*deltim + deadstemn_xfer_p(m) = deadstemn_xfer_p(m) - deadstemn_xfer_to_deadstemn_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) + livecrootn_xfer_to_livecrootn_p(m)*deltim + livecrootn_xfer_p(m) = livecrootn_xfer_p(m) - livecrootn_xfer_to_livecrootn_p(m)*deltim + deadcrootn_p(m) = deadcrootn_p(m) + deadcrootn_xfer_to_deadcrootn_p(m)*deltim + deadcrootn_xfer_p(m) = deadcrootn_xfer_p(m) - deadcrootn_xfer_to_deadcrootn_p(m)*deltim + ENDIF + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + livestemn_p(m) = livestemn_p(m) + livestemn_xfer_to_livestemn_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) - livestemn_xfer_to_livestemn_p(m)*deltim + grainn_p(m) = grainn_p(m) + grainn_xfer_to_grainn_p(m)*deltim + grainn_xfer_p(m) = grainn_xfer_p(m) - grainn_xfer_to_grainn_p(m)*deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafn_xf_to_leafn_p_acc (m) = AKX_leafn_xf_to_leafn_p_acc (m) + leafn_xfer_to_leafn_p (m) * deltim + AKX_frootn_xf_to_frootn_p_acc(m) = AKX_frootn_xf_to_frootn_p_acc(m) + frootn_xfer_to_frootn_p(m) * deltim + AKX_leafn_xf_exit_p_acc (m) = AKX_leafn_xf_exit_p_acc (m) + leafn_xfer_to_leafn_p (m) * deltim + AKX_frootn_xf_exit_p_acc (m) = AKX_frootn_xf_exit_p_acc (m) + frootn_xfer_to_frootn_p(m) * deltim + IF(woody(ivt) == 1)THEN + AKX_livestemn_xf_to_livestemn_p_acc (m) = AKX_livestemn_xf_to_livestemn_p_acc (m) + livestemn_xfer_to_livestemn_p (m) * deltim + AKX_livestemn_xf_exit_p_acc (m) = AKX_livestemn_xf_exit_p_acc (m) + livestemn_xfer_to_livestemn_p (m) * deltim + AKX_deadstemn_xf_to_deadstemn_p_acc (m) = AKX_deadstemn_xf_to_deadstemn_p_acc (m) + deadstemn_xfer_to_deadstemn_p (m) * deltim + AKX_deadstemn_xf_exit_p_acc (m) = AKX_deadstemn_xf_exit_p_acc (m) + deadstemn_xfer_to_deadstemn_p (m) * deltim + AKX_livecrootn_xf_to_livecrootn_p_acc(m) = AKX_livecrootn_xf_to_livecrootn_p_acc(m) + livecrootn_xfer_to_livecrootn_p(m) * deltim + AKX_livecrootn_xf_exit_p_acc (m) = AKX_livecrootn_xf_exit_p_acc (m) + livecrootn_xfer_to_livecrootn_p(m) * deltim + AKX_deadcrootn_xf_to_deadcrootn_p_acc(m) = AKX_deadcrootn_xf_to_deadcrootn_p_acc(m) + deadcrootn_xfer_to_deadcrootn_p(m) * deltim + AKX_deadcrootn_xf_exit_p_acc (m) = AKX_deadcrootn_xf_exit_p_acc (m) + deadcrootn_xfer_to_deadcrootn_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_livestemn_xf_to_livestemn_p_acc(m) = AKX_livestemn_xf_to_livestemn_p_acc(m) + livestemn_xfer_to_livestemn_p(m) * deltim + AKX_livestemn_xf_exit_p_acc (m) = AKX_livestemn_xf_exit_p_acc (m) + livestemn_xfer_to_livestemn_p(m) * deltim + AKX_grainn_xf_to_grainn_p_acc (m) = AKX_grainn_xf_to_grainn_p_acc (m) + grainn_xfer_to_grainn_p (m) * deltim + AKX_grainn_xf_exit_p_acc (m) = AKX_grainn_xf_exit_p_acc (m) + grainn_xfer_to_grainn_p (m) * deltim + ENDIF + ENDIF + + ! phenology: litterfall and retranslocation fluxes + leafn_p(m) = leafn_p(m) - leafn_to_litter_p(m)*deltim + frootn_p(m) = frootn_p(m) - frootn_to_litter_p(m)*deltim + leafn_p(m) = leafn_p(m) - leafn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + leafn_to_retransn_p(m)*deltim + + ! live wood turnover and retranslocation fluxes + IF (woody(ivt) == 1) THEN + livestemn_p(m) = livestemn_p(m) - livestemn_to_deadstemn_p(m)*deltim + deadstemn_p(m) = deadstemn_p(m) + livestemn_to_deadstemn_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) - livecrootn_to_deadcrootn_p(m)*deltim + deadcrootn_p(m) = deadcrootn_p(m) + livecrootn_to_deadcrootn_p(m)*deltim + + livestemn_p(m) = livestemn_p(m) - livestemn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + livestemn_to_retransn_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) - livecrootn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + livecrootn_to_retransn_p(m)*deltim + ENDIF + IF (ivt >= npcropmin) THEN + frootn_p(m) = frootn_p(m) - frootn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + frootn_to_retransn_p(m)*deltim + livestemn_p(m) = livestemn_p(m) - livestemn_to_litter_p(m)*deltim + livestemn_p(m) = livestemn_p(m) - livestemn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + livestemn_to_retransn_p(m)*deltim + grainn_p(m) = grainn_p(m) & + - (grainn_to_food_p(m) + grainn_to_seed_p(m))*deltim + cropseedn_deficit_p(m) = cropseedn_deficit_p(m) & + - crop_seedn_to_leaf_p(m) * deltim & + + grainn_to_seed_p(m) * deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafn_exit_p_acc (m) = AKX_leafn_exit_p_acc (m) + leafn_to_litter_p (m) * deltim + AKX_frootn_exit_p_acc (m) = AKX_frootn_exit_p_acc (m) + frootn_to_litter_p (m) * deltim + AKX_leafn_to_retransn_p_acc(m) = AKX_leafn_to_retransn_p_acc(m) + leafn_to_retransn_p(m) * deltim + AKX_leafn_exit_p_acc (m) = AKX_leafn_exit_p_acc (m) + leafn_to_retransn_p(m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemn_to_deadstemn_p_acc (m) = AKX_livestemn_to_deadstemn_p_acc (m) + livestemn_to_deadstemn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_deadstemn_p (m) * deltim + AKX_livecrootn_to_deadcrootn_p_acc(m) = AKX_livecrootn_to_deadcrootn_p_acc(m) + livecrootn_to_deadcrootn_p(m) * deltim + AKX_livecrootn_exit_p_acc (m) = AKX_livecrootn_exit_p_acc (m) + livecrootn_to_deadcrootn_p(m) * deltim + + AKX_livestemn_to_retransn_p_acc (m) = AKX_livestemn_to_retransn_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_livecrootn_to_retransn_p_acc (m) = AKX_livecrootn_to_retransn_p_acc (m) + livecrootn_to_retransn_p (m) * deltim + AKX_livecrootn_exit_p_acc (m) = AKX_livecrootn_exit_p_acc (m) + livecrootn_to_retransn_p (m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_frootn_to_retransn_p_acc (m) = AKX_frootn_to_retransn_p_acc (m) + frootn_to_retransn_p (m) * deltim + AKX_frootn_exit_p_acc (m) = AKX_frootn_exit_p_acc (m) + frootn_to_retransn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_litter_p (m) * deltim + AKX_livestemn_to_retransn_p_acc (m) = AKX_livestemn_to_retransn_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_grainn_exit_p_acc (m) = AKX_grainn_exit_p_acc (m) + (grainn_to_food_p(m) + grainn_to_seed_p(m)) * deltim + ENDIF + ENDIF + + ! allocation fluxes + retransn_p(m) = retransn_p(m) - retransn_to_npool_p(m)*deltim + retransn_p(m) = retransn_p(m) - free_retransn_to_npool_p(m)*deltim + leafn_p(m) = leafn_p(m) + npool_to_leafn_p(m)*deltim + leafn_storage_p(m) = leafn_storage_p(m) + npool_to_leafn_storage_p(m)*deltim + frootn_p(m) = frootn_p(m) + npool_to_frootn_p(m)*deltim + frootn_storage_p(m) = frootn_storage_p(m) + npool_to_frootn_storage_p(m)*deltim + + IF (woody(ivt) == 1) THEN + livestemn_p(m) = livestemn_p(m) + npool_to_livestemn_p(m)*deltim + livestemn_storage_p(m) = livestemn_storage_p(m) + npool_to_livestemn_storage_p(m)*deltim + deadstemn_p(m) = deadstemn_p(m) + npool_to_deadstemn_p(m)*deltim + deadstemn_storage_p(m) = deadstemn_storage_p(m) + npool_to_deadstemn_storage_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) + npool_to_livecrootn_p(m)*deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) + npool_to_livecrootn_storage_p(m)*deltim + deadcrootn_p(m) = deadcrootn_p(m) + npool_to_deadcrootn_p(m)*deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) + npool_to_deadcrootn_storage_p(m)*deltim + ENDIF + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + livestemn_p(m) = livestemn_p(m) + npool_to_livestemn_p(m)*deltim + livestemn_storage_p(m) = livestemn_storage_p(m) + npool_to_livestemn_storage_p(m)*deltim + grainn_p(m) = grainn_p(m) + npool_to_grainn_p(m)*deltim + grainn_storage_p(m) = grainn_storage_p(m) + npool_to_grainn_storage_p(m)*deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + IF(plant_nalloc_p(m) .ne. 0)THEN + f_retr_in_nall = retransn_to_npool_p(m) / plant_nalloc_p(m) + AKX_retransn_exit_p_acc (m) = AKX_retransn_exit_p_acc (m) & + + (retransn_to_npool_p (m) + free_retransn_to_npool_p (m)) * deltim + I_leafn_p_acc (m) = I_leafn_p_acc (m) + npool_to_leafn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_leafn_p_acc (m) = AKX_retransn_to_leafn_p_acc (m) + npool_to_leafn_p (m) * f_retr_in_nall * deltim + I_leafn_st_p_acc (m) = I_leafn_st_p_acc (m) + npool_to_leafn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_leafn_st_p_acc (m) = AKX_retransn_to_leafn_st_p_acc (m) + npool_to_leafn_storage_p (m) * f_retr_in_nall * deltim + I_frootn_p_acc (m) = I_frootn_p_acc (m) + npool_to_frootn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_frootn_p_acc (m) = AKX_retransn_to_frootn_p_acc (m) + npool_to_frootn_p (m) * f_retr_in_nall * deltim + I_frootn_st_p_acc (m) = I_frootn_st_p_acc (m) + npool_to_frootn_storage_p(m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_frootn_st_p_acc(m) = AKX_retransn_to_frootn_st_p_acc(m) + npool_to_frootn_storage_p(m) * f_retr_in_nall * deltim + IF(woody(ivt) == 1)THEN + I_livestemn_p_acc (m) = I_livestemn_p_acc (m) & + + npool_to_livestemn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_p_acc (m) = AKX_retransn_to_livestemn_p_acc (m) & + + npool_to_livestemn_p (m) * f_retr_in_nall * deltim + I_livestemn_st_p_acc (m) = I_livestemn_st_p_acc (m) & + + npool_to_livestemn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_st_p_acc (m) = AKX_retransn_to_livestemn_st_p_acc (m) & + + npool_to_livestemn_storage_p (m) * f_retr_in_nall * deltim + I_deadstemn_p_acc (m) = I_deadstemn_p_acc (m) & + + npool_to_deadstemn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadstemn_p_acc (m) = AKX_retransn_to_deadstemn_p_acc (m) & + + npool_to_deadstemn_p (m) * f_retr_in_nall * deltim + I_deadstemn_st_p_acc (m) = I_deadstemn_st_p_acc (m) & + + npool_to_deadstemn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadstemn_st_p_acc (m) = AKX_retransn_to_deadstemn_st_p_acc (m) & + + npool_to_deadstemn_storage_p (m) * f_retr_in_nall * deltim + I_livecrootn_p_acc (m) = I_livecrootn_p_acc (m) & + + npool_to_livecrootn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livecrootn_p_acc (m) = AKX_retransn_to_livecrootn_p_acc (m) & + + npool_to_livecrootn_p (m) * f_retr_in_nall * deltim + I_livecrootn_st_p_acc (m) = I_livecrootn_st_p_acc (m) & + + npool_to_livecrootn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livecrootn_st_p_acc(m) = AKX_retransn_to_livecrootn_st_p_acc(m) & + + npool_to_livecrootn_storage_p (m) * f_retr_in_nall * deltim + I_deadcrootn_p_acc (m) = I_deadcrootn_p_acc (m) & + + npool_to_deadcrootn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadcrootn_p_acc (m) = AKX_retransn_to_deadcrootn_p_acc (m) & + + npool_to_deadcrootn_p (m) * f_retr_in_nall * deltim + I_deadcrootn_st_p_acc (m) = I_deadcrootn_st_p_acc (m) & + + npool_to_deadcrootn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadcrootn_st_p_acc(m) = AKX_retransn_to_deadcrootn_st_p_acc(m) & + + npool_to_deadcrootn_storage_p (m) * f_retr_in_nall * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + I_livestemn_p_acc (m) = I_livestemn_p_acc (m) & + + npool_to_livestemn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_p_acc (m) = AKX_retransn_to_livestemn_p_acc(m) & + + npool_to_livestemn_p (m) * f_retr_in_nall * deltim + I_livestemn_st_p_acc (m) = I_livestemn_st_p_acc (m) & + + npool_to_livestemn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_st_p_acc (m) = AKX_retransn_to_livestemn_st_p_acc(m) & + + npool_to_livestemn_storage_p (m) * f_retr_in_nall * deltim + I_grainn_p_acc (m) = I_grainn_p_acc (m) & + + npool_to_grainn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_grainn_p_acc (m) = AKX_retransn_to_grainn_p_acc (m) & + + npool_to_grainn_p (m) * f_retr_in_nall * deltim + I_grainn_st_p_acc (m) = I_grainn_st_p_acc (m) & + + npool_to_grainn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_grainn_st_p_acc (m) = AKX_retransn_to_grainn_st_p_acc(m) & + + npool_to_grainn_storage_p (m) * f_retr_in_nall * deltim + ENDIF + ENDIF + ENDIF + ! move storage pools into transfer pools + leafn_storage_p(m) = leafn_storage_p(m) - leafn_storage_to_xfer_p(m)*deltim + leafn_xfer_p(m) = leafn_xfer_p(m) + leafn_storage_to_xfer_p(m)*deltim + frootn_storage_p(m) = frootn_storage_p(m) - frootn_storage_to_xfer_p(m)*deltim + frootn_xfer_p(m) = frootn_xfer_p(m) + frootn_storage_to_xfer_p(m)*deltim + + IF (woody(ivt) == 1) THEN + livestemn_storage_p(m) = livestemn_storage_p(m) - livestemn_storage_to_xfer_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) + livestemn_storage_to_xfer_p(m)*deltim + deadstemn_storage_p(m) = deadstemn_storage_p(m) - deadstemn_storage_to_xfer_p(m)*deltim + deadstemn_xfer_p(m) = deadstemn_xfer_p(m) + deadstemn_storage_to_xfer_p(m)*deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) - livecrootn_storage_to_xfer_p(m)*deltim + livecrootn_xfer_p(m) = livecrootn_xfer_p(m) + livecrootn_storage_to_xfer_p(m)*deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) - deadcrootn_storage_to_xfer_p(m)*deltim + deadcrootn_xfer_p(m) = deadcrootn_xfer_p(m) + deadcrootn_storage_to_xfer_p(m)*deltim + ENDIF + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + livestemn_storage_p(m) = livestemn_storage_p(m) - livestemn_storage_to_xfer_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) + livestemn_storage_to_xfer_p(m)*deltim + grainn_storage_p(m) = grainn_storage_p(m) - grainn_storage_to_xfer_p(m)*deltim + grainn_xfer_p(m) = grainn_xfer_p(m) + grainn_storage_to_xfer_p(m)*deltim + ENDIF + + IF(DEF_USE_SASU)THEN + AKX_leafn_st_to_leafn_xf_p_acc (m) = AKX_leafn_st_to_leafn_xf_p_acc (m) + leafn_storage_to_xfer_p (m) * deltim + AKX_leafn_st_exit_p_acc (m) = AKX_leafn_st_exit_p_acc (m) + leafn_storage_to_xfer_p (m) * deltim + AKX_frootn_st_to_frootn_xf_p_acc (m) = AKX_frootn_st_to_frootn_xf_p_acc (m) + frootn_storage_to_xfer_p (m) * deltim + AKX_frootn_st_exit_p_acc (m) = AKX_frootn_st_exit_p_acc (m) + frootn_storage_to_xfer_p (m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemn_st_to_livestemn_xf_p_acc (m) = AKX_livestemn_st_to_livestemn_xf_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_livestemn_st_exit_p_acc (m) = AKX_livestemn_st_exit_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) = AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) + deadstemn_storage_to_xfer_p (m) * deltim + AKX_deadstemn_st_exit_p_acc (m) = AKX_deadstemn_st_exit_p_acc (m) + deadstemn_storage_to_xfer_p (m) * deltim + AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) = AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) + livecrootn_storage_to_xfer_p(m) * deltim + AKX_livecrootn_st_exit_p_acc (m) = AKX_livecrootn_st_exit_p_acc (m) + livecrootn_storage_to_xfer_p(m) * deltim + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) = AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) + deadcrootn_storage_to_xfer_p(m) * deltim + AKX_deadcrootn_st_exit_p_acc (m) = AKX_deadcrootn_st_exit_p_acc (m) + deadcrootn_storage_to_xfer_p(m) * deltim + ENDIF + IF( ivt >= npcropmin) THEN + AKX_livestemn_st_to_livestemn_xf_p_acc (m) = AKX_livestemn_st_to_livestemn_xf_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_livestemn_st_exit_p_acc (m) = AKX_livestemn_st_exit_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_grainn_st_to_grainn_xf_p_acc (m) = AKX_grainn_st_to_grainn_xf_p_acc (m) + grainn_storage_to_xfer_p (m) * deltim + AKX_grainn_st_exit_p_acc (m) = AKX_grainn_st_exit_p_acc (m) + grainn_storage_to_xfer_p (m) * deltim + ENDIF + ENDIF + ENDDO ! END pft loop + + END SUBROUTINE NStateUpdate1 + +END MODULE MOD_BGC_CNNStateUpdate1 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 new file mode 100644 index 0000000000..d44a47e063 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 @@ -0,0 +1,172 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNNStateUpdate2 + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil nitrogen. The major updates are included in bgc_CNNStateUpdate1Mod +! 1. Update gap-mortality-associated veg and soil N pool size changes +! 2. Record the accumulated N transfers associated to gap-mortality for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated gap-mortality-associated N transfers for veg and soil N semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd, i_soil1, i_soil2,i_soil3 + USE MOD_BGC_Vars_TimeVariables, only: & + ! decompositionn nitrogen pools & fluxes variables (inout) + decomp_npools_vr, & + I_met_n_vr_acc , I_cel_n_vr_acc , I_lig_n_vr_acc , I_cwd_n_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + gap_mortality_to_met_n, gap_mortality_to_cel_n , & + gap_mortality_to_lig_n, gap_mortality_to_cwdn + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + retransn_p , npool_p, grainn_p, grainn_storage_p, grainn_xfer_p, cropseedn_deficit_p, & + + ! SASU variables + AKX_leafn_exit_p_acc , AKX_leafn_st_exit_p_acc , AKX_leafn_xf_exit_p_acc , & + AKX_frootn_exit_p_acc , AKX_frootn_st_exit_p_acc , AKX_frootn_xf_exit_p_acc , & + AKX_livestemn_exit_p_acc , AKX_livestemn_st_exit_p_acc , AKX_livestemn_xf_exit_p_acc , & + AKX_deadstemn_exit_p_acc , AKX_deadstemn_st_exit_p_acc , AKX_deadstemn_xf_exit_p_acc , & + AKX_livecrootn_exit_p_acc, AKX_livecrootn_st_exit_p_acc, AKX_livecrootn_xf_exit_p_acc, & + AKX_deadcrootn_exit_p_acc, AKX_deadcrootn_st_exit_p_acc, AKX_deadcrootn_xf_exit_p_acc, & + AKX_retransn_exit_p_acc + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation nitrogen flux variables + m_leafn_to_litter_p , m_leafn_storage_to_litter_p , m_leafn_xfer_to_litter_p , & + m_frootn_to_litter_p , m_frootn_storage_to_litter_p , m_frootn_xfer_to_litter_p , & + m_livestemn_to_litter_p , m_livestemn_storage_to_litter_p , m_livestemn_xfer_to_litter_p , & + m_deadstemn_to_litter_p , m_deadstemn_storage_to_litter_p , m_deadstemn_xfer_to_litter_p , & + m_livecrootn_to_litter_p , m_livecrootn_storage_to_litter_p, m_livecrootn_xfer_to_litter_p, & + m_deadcrootn_to_litter_p , m_deadcrootn_storage_to_litter_p, m_deadcrootn_xfer_to_litter_p, & + m_retransn_to_litter_p + + USE MOD_Vars_PFTimeInvariants, only: pftfrac + IMPLICIT NONE + + PUBLIC NStateUpdate2 + +CONTAINS + + SUBROUTINE NStateUpdate2(i, ps, pe, deltim, nl_soil, dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer j, m + + ! column-level nitrogen fluxes from gap-phase mortality + DO j = 1, nl_soil + decomp_npools_vr(j,i_met_lit,i) = & + decomp_npools_vr(j,i_met_lit,i) + gap_mortality_to_met_n(j,i) * deltim + decomp_npools_vr(j,i_cel_lit,i) = & + decomp_npools_vr(j,i_cel_lit,i) + gap_mortality_to_cel_n(j,i) * deltim + decomp_npools_vr(j,i_lig_lit,i) = & + decomp_npools_vr(j,i_lig_lit,i) + gap_mortality_to_lig_n(j,i) * deltim + decomp_npools_vr(j,i_cwd,i) = & + decomp_npools_vr(j,i_cwd,i) + gap_mortality_to_cwdn(j,i) * deltim + ENDDO + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j=1,nl_soil + I_met_n_vr_acc(j,i) = I_met_n_vr_acc(j,i) + gap_mortality_to_met_n(j,i) * deltim + I_cel_n_vr_acc(j,i) = I_cel_n_vr_acc(j,i) + gap_mortality_to_cel_n(j,i) * deltim + I_lig_n_vr_acc(j,i) = I_lig_n_vr_acc(j,i) + gap_mortality_to_lig_n(j,i) * deltim + I_cwd_n_vr_acc(j,i) = I_cwd_n_vr_acc(j,i) + gap_mortality_to_cwdn (j,i) * deltim + ENDDO + ENDIF + ! patch -level nitrogen fluxes from gap-phase mortality + + ! displayed pools + DO m = ps, pe + leafn_p (m) = leafn_p (m) & + - m_leafn_to_litter_p (m) * deltim + frootn_p (m) = frootn_p (m) & + - m_frootn_to_litter_p (m) * deltim + livestemn_p (m) = livestemn_p (m) & + - m_livestemn_to_litter_p (m) * deltim + deadstemn_p (m) = deadstemn_p (m) & + - m_deadstemn_to_litter_p (m) * deltim + livecrootn_p (m) = livecrootn_p (m) & + - m_livecrootn_to_litter_p (m) * deltim + deadcrootn_p (m) = deadcrootn_p (m) & + - m_deadcrootn_to_litter_p (m) * deltim + retransn_p (m) = retransn_p (m) & + - m_retransn_to_litter_p (m) * deltim + + ! storage pools + leafn_storage_p (m) = leafn_storage_p (m) & + - m_leafn_storage_to_litter_p (m) * deltim + frootn_storage_p (m) = frootn_storage_p (m) & + - m_frootn_storage_to_litter_p (m) * deltim + livestemn_storage_p (m) = livestemn_storage_p (m) & + - m_livestemn_storage_to_litter_p (m) * deltim + deadstemn_storage_p (m) = deadstemn_storage_p (m) & + - m_deadstemn_storage_to_litter_p (m) * deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) & + - m_livecrootn_storage_to_litter_p(m) * deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) & + - m_deadcrootn_storage_to_litter_p(m) * deltim + + ! transfer pools + leafn_xfer_p (m) = leafn_xfer_p (m) & + - m_leafn_xfer_to_litter_p (m) * deltim + frootn_xfer_p (m) = frootn_xfer_p (m) & + - m_frootn_xfer_to_litter_p (m) * deltim + livestemn_xfer_p (m) = livestemn_xfer_p (m) & + - m_livestemn_xfer_to_litter_p (m) * deltim + deadstemn_xfer_p (m) = deadstemn_xfer_p (m) & + - m_deadstemn_xfer_to_litter_p (m) * deltim + livecrootn_xfer_p (m) = livecrootn_xfer_p (m) & + - m_livecrootn_xfer_to_litter_p (m) * deltim + deadcrootn_xfer_p (m) = deadcrootn_xfer_p (m) & + - m_deadcrootn_xfer_to_litter_p (m) * deltim + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafn_exit_p_acc (m) = AKX_leafn_exit_p_acc (m) + m_leafn_to_litter_p (m) * deltim + AKX_frootn_exit_p_acc (m) = AKX_frootn_exit_p_acc (m) + m_frootn_to_litter_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + m_livestemn_to_litter_p (m) * deltim + AKX_deadstemn_exit_p_acc (m) = AKX_deadstemn_exit_p_acc (m) + m_deadstemn_to_litter_p (m) * deltim + AKX_livecrootn_exit_p_acc (m) = AKX_livecrootn_exit_p_acc (m) + m_livecrootn_to_litter_p (m) * deltim + AKX_deadcrootn_exit_p_acc (m) = AKX_deadcrootn_exit_p_acc (m) + m_deadcrootn_to_litter_p (m) * deltim + AKX_retransn_exit_p_acc (m) = AKX_retransn_exit_p_acc (m) + m_retransn_to_litter_p (m) * deltim + + AKX_leafn_st_exit_p_acc (m) = AKX_leafn_st_exit_p_acc (m) + m_leafn_storage_to_litter_p (m) * deltim + AKX_frootn_st_exit_p_acc (m) = AKX_frootn_st_exit_p_acc (m) + m_frootn_storage_to_litter_p (m) * deltim + AKX_livestemn_st_exit_p_acc (m) = AKX_livestemn_st_exit_p_acc (m) + m_livestemn_storage_to_litter_p (m) * deltim + AKX_deadstemn_st_exit_p_acc (m) = AKX_deadstemn_st_exit_p_acc (m) + m_deadstemn_storage_to_litter_p (m) * deltim + AKX_livecrootn_st_exit_p_acc (m) = AKX_livecrootn_st_exit_p_acc (m) + m_livecrootn_storage_to_litter_p(m) * deltim + AKX_deadcrootn_st_exit_p_acc (m) = AKX_deadcrootn_st_exit_p_acc (m) + m_deadcrootn_storage_to_litter_p(m) * deltim + + AKX_leafn_xf_exit_p_acc (m) = AKX_leafn_xf_exit_p_acc (m) + m_leafn_xfer_to_litter_p (m) * deltim + AKX_frootn_xf_exit_p_acc (m) = AKX_frootn_xf_exit_p_acc (m) + m_frootn_xfer_to_litter_p (m) * deltim + AKX_livestemn_xf_exit_p_acc (m) = AKX_livestemn_xf_exit_p_acc (m) + m_livestemn_xfer_to_litter_p (m) * deltim + AKX_deadstemn_xf_exit_p_acc (m) = AKX_deadstemn_xf_exit_p_acc (m) + m_deadstemn_xfer_to_litter_p (m) * deltim + AKX_livecrootn_xf_exit_p_acc (m) = AKX_livecrootn_xf_exit_p_acc (m) + m_livecrootn_xfer_to_litter_p (m) * deltim + AKX_deadcrootn_xf_exit_p_acc (m) = AKX_deadcrootn_xf_exit_p_acc (m) + m_deadcrootn_xfer_to_litter_p (m) * deltim + ENDIF + ENDDO + + END SUBROUTINE NStateUpdate2 + +END MODULE MOD_BGC_CNNStateUpdate2 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 new file mode 100644 index 0000000000..eff81d7448 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 @@ -0,0 +1,222 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNNStateUpdate3 + +!------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil nitrogen. The major updates are included in bgc_CNNStateUpdate1Mod +! 1. Update fire-associated veg and soil(litter) N pool size changes +! 2. Record the accumulated N transfers associated to fire for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record accumulated fire-associated N transfers for veg and soil N semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_FIRE + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd, i_soil1, i_soil2, i_soil3 + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition pools & fluxes variables (inout) + decomp_npools_vr, sminn_vr, smin_no3_vr, smin_nh4_vr + + USE MOD_BGC_Vars_1DFluxes, only: & + m_decomp_npools_to_fire_vr, & + fire_mortality_to_met_n, fire_mortality_to_cel_n, & + fire_mortality_to_lig_n, fire_mortality_to_cwdn , & + + ! mineral nitrogen pools & fluxes variables (inout) + sminn_leached_vr, smin_no3_leached_vr, smin_no3_runoff_vr + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + retransn_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation nitrogen flux variables + m_leafn_to_fire_p , m_leafn_storage_to_fire_p , m_leafn_xfer_to_fire_p , & + m_frootn_to_fire_p , m_frootn_storage_to_fire_p , m_frootn_xfer_to_fire_p , & + m_livestemn_to_fire_p , m_livestemn_storage_to_fire_p , m_livestemn_xfer_to_fire_p , & + m_deadstemn_to_fire_p , m_deadstemn_storage_to_fire_p , m_deadstemn_xfer_to_fire_p , & + m_livecrootn_to_fire_p , m_livecrootn_storage_to_fire_p, m_livecrootn_xfer_to_fire_p, & + m_deadcrootn_to_fire_p , m_deadcrootn_storage_to_fire_p, m_deadcrootn_xfer_to_fire_p, & + m_livestemn_to_deadstemn_fire_p , m_livecrootn_to_deadcrootn_fire_p , & + m_retransn_to_fire_p, & + + m_leafn_to_litter_fire_p , m_leafn_storage_to_litter_fire_p , m_leafn_xfer_to_litter_fire_p , & + m_frootn_to_litter_fire_p , m_frootn_storage_to_litter_fire_p , m_frootn_xfer_to_litter_fire_p , & + m_livestemn_to_litter_fire_p , m_livestemn_storage_to_litter_fire_p , m_livestemn_xfer_to_litter_fire_p , & + m_deadstemn_to_litter_fire_p , m_deadstemn_storage_to_litter_fire_p , m_deadstemn_xfer_to_litter_fire_p , & + m_livecrootn_to_litter_fire_p , m_livecrootn_storage_to_litter_fire_p, m_livecrootn_xfer_to_litter_fire_p, & + m_deadcrootn_to_litter_fire_p , m_deadcrootn_storage_to_litter_fire_p, m_deadcrootn_xfer_to_litter_fire_p, & + m_retransn_to_litter_fire_p + + + IMPLICIT NONE + + PUBLIC NStateUpdate3 + +CONTAINS + + SUBROUTINE NStateUpdate3(i, ps, pe, deltim, nl_soil, ndecomp_pools, dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + + integer ,intent(in) :: nl_soil ! number of total soil number + integer ,intent(in) :: ndecomp_pools ! number total litter & soil pools + real(r8),intent(in) :: dz_soi(1:nl_soil)! thicnesses of eacn soil layer + + integer j,l,m + + + IF(.not. DEF_USE_NITRIF)THEN + ! mineral N loss due to leaching + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) - sminn_leached_vr(j,i) * deltim + ENDDO + ELSE + DO j = 1, nl_soil + ! mineral N loss due to leaching and runoff + smin_no3_vr(j,i) = max( smin_no3_vr(j,i) & + - ( smin_no3_leached_vr(j,i) + smin_no3_runoff_vr(j,i) ) * deltim, 0._r8) + + sminn_vr(j,i) = smin_no3_vr(j,i) + smin_nh4_vr(j,i) + ENDDO + ENDIF + + ! column level nitrogen fluxes from fire + ! patch-level wood to column-level CWD (uncombusted wood) + IF(DEF_USE_FIRE)THEN + DO j = 1, nl_soil + decomp_npools_vr(j,i_cwd,i) = decomp_npools_vr(j,i_cwd,i) & + + fire_mortality_to_cwdn(j,i) * deltim + + ! patch-level wood to column-level litter (uncombusted wood) + decomp_npools_vr(j,i_met_lit,i) = decomp_npools_vr(j,i_met_lit,i) & + + fire_mortality_to_met_n(j,i)* deltim + decomp_npools_vr(j,i_cel_lit,i) = decomp_npools_vr(j,i_cel_lit,i) & + + fire_mortality_to_cel_n(j,i)* deltim + decomp_npools_vr(j,i_lig_lit,i) = decomp_npools_vr(j,i_lig_lit,i) & + + fire_mortality_to_lig_n(j,i)* deltim + ENDDO + + ! litter and CWD losses to fire + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_npools_vr(j,l,i) = decomp_npools_vr(j,l,i) & + - m_decomp_npools_to_fire_vr(j,l,i) * deltim + ENDDO + ENDDO + + DO m = ps , pe + !from fire displayed pools + leafn_p (m) = leafn_p (m) & + - m_leafn_to_fire_p (m) * deltim + frootn_p (m) = frootn_p (m) & + - m_frootn_to_fire_p (m) * deltim + livestemn_p (m) = livestemn_p (m) & + - m_livestemn_to_fire_p (m) * deltim + deadstemn_p (m) = deadstemn_p (m) & + - m_deadstemn_to_fire_p (m) * deltim + livecrootn_p (m) = livecrootn_p (m) & + - m_livecrootn_to_fire_p (m) * deltim + deadcrootn_p (m) = deadcrootn_p (m) & + - m_deadcrootn_to_fire_p (m) * deltim + + leafn_p (m) = leafn_p (m) & + - m_leafn_to_litter_fire_p (m) * deltim + frootn_p (m) = frootn_p (m) & + - m_frootn_to_litter_fire_p (m) * deltim + livestemn_p (m) = livestemn_p (m) & + - m_livestemn_to_litter_fire_p (m) * deltim & + - m_livestemn_to_deadstemn_fire_p (m) * deltim + deadstemn_p (m) = deadstemn_p (m) & + - m_deadstemn_to_litter_fire_p (m) * deltim & + + m_livestemn_to_deadstemn_fire_p (m) * deltim + livecrootn_p (m) = livecrootn_p (m) & + - m_livecrootn_to_litter_fire_p (m) * deltim & + - m_livecrootn_to_deadcrootn_fire_p(m) * deltim + deadcrootn_p (m) = deadcrootn_p (m) & + - m_deadcrootn_to_litter_fire_p (m) * deltim & + + m_livecrootn_to_deadcrootn_fire_p(m) * deltim + + ! storage pools + leafn_storage_p (m) = leafn_storage_p (m) & + - m_leafn_storage_to_fire_p (m) * deltim + frootn_storage_p (m) = frootn_storage_p (m) & + - m_frootn_storage_to_fire_p (m) * deltim + livestemn_storage_p (m) = livestemn_storage_p (m) & + - m_livestemn_storage_to_fire_p (m) * deltim + deadstemn_storage_p (m) = deadstemn_storage_p (m) & + - m_deadstemn_storage_to_fire_p (m) * deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) & + - m_livecrootn_storage_to_fire_p (m) * deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) & + - m_deadcrootn_storage_to_fire_p (m) * deltim + + leafn_storage_p (m) = leafn_storage_p (m) & + - m_leafn_storage_to_litter_fire_p (m) * deltim + frootn_storage_p (m) = frootn_storage_p (m) & + - m_frootn_storage_to_litter_fire_p (m) * deltim + livestemn_storage_p (m) = livestemn_storage_p (m) & + - m_livestemn_storage_to_litter_fire_p (m) * deltim + deadstemn_storage_p (m) = deadstemn_storage_p (m) & + - m_deadstemn_storage_to_litter_fire_p (m) * deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) & + - m_livecrootn_storage_to_litter_fire_p(m) * deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) & + - m_deadcrootn_storage_to_litter_fire_p(m) * deltim + + + ! transfer pools + leafn_xfer_p (m) = leafn_xfer_p (m) & + - m_leafn_xfer_to_fire_p (m) * deltim + frootn_xfer_p (m) = frootn_xfer_p (m) & + - m_frootn_xfer_to_fire_p (m) * deltim + livestemn_xfer_p (m) = livestemn_xfer_p (m) & + - m_livestemn_xfer_to_fire_p (m) * deltim + deadstemn_xfer_p (m) = deadstemn_xfer_p (m) & + - m_deadstemn_xfer_to_fire_p (m) * deltim + livecrootn_xfer_p (m) = livecrootn_xfer_p (m) & + - m_livecrootn_xfer_to_fire_p (m) * deltim + deadcrootn_xfer_p (m) = deadcrootn_xfer_p (m) & + - m_deadcrootn_xfer_to_fire_p (m) * deltim + + leafn_xfer_p (m) = leafn_xfer_p (m) & + - m_leafn_xfer_to_litter_fire_p (m) * deltim + frootn_xfer_p (m) = frootn_xfer_p (m) & + - m_frootn_xfer_to_litter_fire_p (m) * deltim + livestemn_xfer_p (m) = livestemn_xfer_p (m) & + - m_livestemn_xfer_to_litter_fire_p (m) * deltim + deadstemn_xfer_p (m) = deadstemn_xfer_p (m) & + - m_deadstemn_xfer_to_litter_fire_p (m) * deltim + livecrootn_xfer_p (m) = livecrootn_xfer_p (m) & + - m_livecrootn_xfer_to_litter_fire_p (m) * deltim + deadcrootn_xfer_p (m) = deadcrootn_xfer_p (m) & + - m_deadcrootn_xfer_to_litter_fire_p (m) * deltim + + ! retranslocated N pool + retransn_p (m) = retransn_p (m) & + - m_retransn_to_fire_p (m) * deltim + retransn_p (m) = retransn_p (m) & + - m_retransn_to_litter_fire_p (m) * deltim + ENDDO + ENDIF + + END SUBROUTINE NStateUpdate3 + +END MODULE MOD_BGC_CNNStateUpdate3 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 new file mode 100644 index 0000000000..f4cd21b975 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 @@ -0,0 +1,1074 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNSASU + +!---------------------------------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE implements an semi-analytic accerlating spin-up method (SASU) in CoLM bgc MODULE. The SASU method analytically calculates +! the steady state of each vegetation and soil C and N pool sizes, and replace current CN pool sizes with analytical steady state +! solution. So, CN pool sizes in both vegetation and soil reach steady state much faster than conventional spin up method. +! +! !MODULE for CoLM-BGC matrices +! The vegetation matrix equation +! Xn+1 = Xn + I*dt + (Aph*Kph + Agm*Kgm + Afire*Kfire) * dt +! The soil matrix equation +! Xn+1 = Xn + I*dt + (A*K(ksi) + Kfire + tri/dz)*Xn*dt +! The steady state solution for vegetation C is X = -I*B*(Aph*Kph + Agm*Kgm + Afire*Kfire)**(-1) +! The steady state solution for soil C is X = -I *(A*K(ksi) + Kfire + tri/dz)**(-1) +! +! !ORIGINAL: +! The Community Land Model version 5.1 (CLM5.1) unreleased version developed by Xingjie Lu +! +! !REFERENCES: +! Lu, X., Du, Z., Huang, Y., Lawrence, D., Kluzek, E., Collier, N., Lombardozzi, D., Sobhani, N., Schuur, E.A. and Luo, Y., 2020. +! Full implementation of matrix approach to biogeochemistry MODULE of CLM5. Journal of Advances in Modeling Earth Systems, 12(11), e2020MS002105. +! Liao, C., Lu, X., Huang Y., Tao F., Lawrence, D., Koven C., Oleson, K., Wieder, W., Kluzek, E., Huang, X., Luo, Y. (in submission) +! Matrix Approach to Accelerate Spin-Up of CLM5 +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! USE accumulated transfer fluxes to calculate the matrix. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3, floating_cn_ratio + + USE MOD_BGC_Vars_TimeVariables, only: & + decomp_cpools_vr , decomp_npools_vr , decomp0_cpools_vr , decomp0_npools_vr , & + decomp_cpools_vr_Cap , decomp_npools_vr_Cap , & + I_met_c_vr_acc , I_cel_c_vr_acc , I_lig_c_vr_acc , I_cwd_c_vr_acc , & + AKX_met_to_soil1_c_vr_acc , AKX_cel_to_soil1_c_vr_acc , AKX_lig_to_soil2_c_vr_acc , AKX_soil1_to_soil2_c_vr_acc, & + AKX_cwd_to_cel_c_vr_acc , AKX_cwd_to_lig_c_vr_acc , AKX_soil1_to_soil3_c_vr_acc, AKX_soil2_to_soil1_c_vr_acc, & + AKX_soil2_to_soil3_c_vr_acc, AKX_soil3_to_soil1_c_vr_acc, & + AKX_met_exit_c_vr_acc , AKX_cel_exit_c_vr_acc , AKX_lig_exit_c_vr_acc , AKX_cwd_exit_c_vr_acc , & + AKX_soil1_exit_c_vr_acc , AKX_soil2_exit_c_vr_acc , AKX_soil3_exit_c_vr_acc , & + diagVX_c_vr_acc , upperVX_c_vr_acc , lowerVX_c_vr_acc , & + I_met_n_vr_acc , I_cel_n_vr_acc , I_lig_n_vr_acc , I_cwd_n_vr_acc , & + AKX_met_to_soil1_n_vr_acc , AKX_cel_to_soil1_n_vr_acc , AKX_lig_to_soil2_n_vr_acc , AKX_soil1_to_soil2_n_vr_acc, & + AKX_cwd_to_cel_n_vr_acc , AKX_cwd_to_lig_n_vr_acc , AKX_soil1_to_soil3_n_vr_acc, AKX_soil2_to_soil1_n_vr_acc, & + AKX_soil2_to_soil3_n_vr_acc, AKX_soil3_to_soil1_n_vr_acc, & + AKX_met_exit_n_vr_acc , AKX_cel_exit_n_vr_acc , AKX_lig_exit_n_vr_acc , AKX_cwd_exit_n_vr_acc , & + AKX_soil1_exit_n_vr_acc , AKX_soil2_exit_n_vr_acc , AKX_soil3_exit_n_vr_acc , & + diagVX_n_vr_acc , upperVX_n_vr_acc , lowerVX_n_vr_acc , skip_balance_check , & + cn_decomp_pools + + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p , leafc_storage_p , leafc_xfer_p , leafc0_p , leafc0_storage_p , leafc0_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , frootc0_p , frootc0_storage_p , frootc0_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , livestemc0_p , livestemc0_storage_p , livestemc0_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , deadstemc0_p , deadstemc0_storage_p , deadstemc0_xfer_p , & + livecrootc_p , livecrootc_storage_p , livecrootc_xfer_p , livecrootc0_p , livecrootc0_storage_p, livecrootc0_xfer_p, & + deadcrootc_p , deadcrootc_storage_p , deadcrootc_xfer_p , deadcrootc0_p , deadcrootc0_storage_p, deadcrootc0_xfer_p, & + grainc_p , grainc_storage_p , grainc_xfer_p , grainc0_p , grainc0_storage_p , grainc0_xfer_p , & + + leafcCap_p , leafc_storageCap_p , leafc_xferCap_p , & + frootcCap_p , frootc_storageCap_p , frootc_xferCap_p , & + livestemcCap_p , livestemc_storageCap_p , livestemc_xferCap_p , & + deadstemcCap_p , deadstemc_storageCap_p , deadstemc_xferCap_p , & + livecrootcCap_p , livecrootc_storageCap_p , livecrootc_xferCap_p , & + deadcrootcCap_p , deadcrootc_storageCap_p , deadcrootc_xferCap_p , & + + leafnCap_p , leafn_storageCap_p , leafn_xferCap_p , & + frootnCap_p , frootn_storageCap_p , frootn_xferCap_p , & + livestemnCap_p , livestemn_storageCap_p , livestemn_xferCap_p , & + deadstemnCap_p , deadstemn_storageCap_p , deadstemn_xferCap_p , & + livecrootnCap_p , livecrootn_storageCap_p , livecrootn_xferCap_p , & + deadcrootnCap_p , deadcrootn_storageCap_p , deadcrootn_xferCap_p , & + + leafn_p , leafn_storage_p , leafn_xfer_p , leafn0_p , leafn0_storage_p , leafn0_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , frootn0_p , frootn0_storage_p , frootn0_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , livestemn0_p , livestemn0_storage_p , livestemn0_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , deadstemn0_p , deadstemn0_storage_p , deadstemn0_xfer_p , & + livecrootn_p , livecrootn_storage_p , livecrootn_xfer_p , livecrootn0_p , livecrootn0_storage_p, livecrootn0_xfer_p, & + deadcrootn_p , deadcrootn_storage_p , deadcrootn_xfer_p , deadcrootn0_p , deadcrootn0_storage_p, deadcrootn0_xfer_p, & + grainn_p , grainn_storage_p , grainn_xfer_p , grainn0_p , grainn0_storage_p , grainn0_xfer_p , & + retransn_p , retransn0_p , & + + I_leafc_p_acc , I_leafc_st_p_acc , I_frootc_p_acc , I_frootc_st_p_acc , & + I_livestemc_p_acc , I_livestemc_st_p_acc , I_deadstemc_p_acc , I_deadstemc_st_p_acc , & + I_livecrootc_p_acc, I_livecrootc_st_p_acc, I_deadcrootc_p_acc, I_deadcrootc_st_p_acc, & + I_grainc_p_acc , I_grainc_st_p_acc , & + + I_leafn_p_acc , I_leafn_st_p_acc , I_frootn_p_acc , I_frootn_st_p_acc , & + I_livestemn_p_acc , I_livestemn_st_p_acc , I_deadstemn_p_acc , I_deadstemn_st_p_acc , & + I_livecrootn_p_acc, I_livecrootn_st_p_acc, I_deadcrootn_p_acc, I_deadcrootn_st_p_acc, & + I_grainn_p_acc , I_grainn_st_p_acc , & + + AKX_leafc_xf_to_leafc_p_acc , AKX_frootc_xf_to_frootc_p_acc , AKX_livestemc_xf_to_livestemc_p_acc , & + AKX_deadstemc_xf_to_deadstemc_p_acc , AKX_livecrootc_xf_to_livecrootc_p_acc , AKX_deadcrootc_xf_to_deadcrootc_p_acc , & + AKX_grainc_xf_to_grainc_p_acc , AKX_livestemc_to_deadstemc_p_acc , AKX_livecrootc_to_deadcrootc_p_acc , & + + AKX_leafc_st_to_leafc_xf_p_acc , AKX_frootc_st_to_frootc_xf_p_acc , AKX_livestemc_st_to_livestemc_xf_p_acc , & + AKX_deadstemc_st_to_deadstemc_xf_p_acc, AKX_livecrootc_st_to_livecrootc_xf_p_acc, AKX_deadcrootc_st_to_deadcrootc_xf_p_acc, & + AKX_grainc_st_to_grainc_xf_p_acc , & + + AKX_leafc_exit_p_acc , AKX_frootc_exit_p_acc , AKX_livestemc_exit_p_acc , & + AKX_deadstemc_exit_p_acc , AKX_livecrootc_exit_p_acc , AKX_deadcrootc_exit_p_acc , & + AKX_grainc_exit_p_acc , & + + AKX_leafc_st_exit_p_acc , AKX_frootc_st_exit_p_acc , AKX_livestemc_st_exit_p_acc , & + AKX_deadstemc_st_exit_p_acc , AKX_livecrootc_st_exit_p_acc , AKX_deadcrootc_st_exit_p_acc , & + AKX_grainc_st_exit_p_acc , & + + AKX_leafc_xf_exit_p_acc , AKX_frootc_xf_exit_p_acc , AKX_livestemc_xf_exit_p_acc , & + AKX_deadstemc_xf_exit_p_acc , AKX_livecrootc_xf_exit_p_acc , AKX_deadcrootc_xf_exit_p_acc , & + AKX_grainc_xf_exit_p_acc , & + + AKX_leafn_xf_to_leafn_p_acc , AKX_frootn_xf_to_frootn_p_acc , AKX_livestemn_xf_to_livestemn_p_acc , & + AKX_deadstemn_xf_to_deadstemn_p_acc , AKX_livecrootn_xf_to_livecrootn_p_acc , AKX_deadcrootn_xf_to_deadcrootn_p_acc , & + AKX_grainn_xf_to_grainn_p_acc , AKX_livestemn_to_deadstemn_p_acc , AKX_livecrootn_to_deadcrootn_p_acc , & + + AKX_leafn_st_to_leafn_xf_p_acc , AKX_frootn_st_to_frootn_xf_p_acc , AKX_livestemn_st_to_livestemn_xf_p_acc , & + AKX_deadstemn_st_to_deadstemn_xf_p_acc, AKX_livecrootn_st_to_livecrootn_xf_p_acc, AKX_deadcrootn_st_to_deadcrootn_xf_p_acc, & + AKX_grainn_st_to_grainn_xf_p_acc , & + + AKX_leafn_to_retransn_p_acc , AKX_frootn_to_retransn_p_acc , AKX_livestemn_to_retransn_p_acc , & + AKX_livecrootn_to_retransn_p_acc , & + + AKX_retransn_to_leafn_p_acc , AKX_retransn_to_frootn_p_acc , AKX_retransn_to_livestemn_p_acc , & + AKX_retransn_to_deadstemn_p_acc , AKX_retransn_to_livecrootn_p_acc , AKX_retransn_to_deadcrootn_p_acc , & + AKX_retransn_to_grainn_p_acc , & + + AKX_retransn_to_leafn_st_p_acc , AKX_retransn_to_frootn_st_p_acc , AKX_retransn_to_livestemn_st_p_acc , & + AKX_retransn_to_deadstemn_st_p_acc , AKX_retransn_to_livecrootn_st_p_acc , AKX_retransn_to_deadcrootn_st_p_acc , & + AKX_retransn_to_grainn_st_p_acc , & + + AKX_leafn_exit_p_acc , AKX_frootn_exit_p_acc , AKX_livestemn_exit_p_acc , & + AKX_deadstemn_exit_p_acc , AKX_livecrootn_exit_p_acc , AKX_deadcrootn_exit_p_acc , & + AKX_grainn_exit_p_acc , AKX_retransn_exit_p_acc , & + + AKX_leafn_st_exit_p_acc , AKX_frootn_st_exit_p_acc , AKX_livestemn_st_exit_p_acc , & + AKX_deadstemn_st_exit_p_acc , AKX_livecrootn_st_exit_p_acc , AKX_deadcrootn_st_exit_p_acc , & + AKX_grainn_st_exit_p_acc , & + + AKX_leafn_xf_exit_p_acc , AKX_frootn_xf_exit_p_acc , AKX_livestemn_xf_exit_p_acc , & + AKX_deadstemn_xf_exit_p_acc , AKX_livecrootn_xf_exit_p_acc , AKX_deadcrootn_xf_exit_p_acc , & + AKX_grainn_xf_exit_p_acc +! + IMPLICIT NONE + + PUBLIC :: CNSASU + PUBLIC :: inverse +!----------------------------------------------------------------------- + +CONTAINS + + + !----------------------------------------------------------------------- + SUBROUTINE CNSASU(i,ps,pe,deltim,idate,nl_soil,ndecomp_transitions, ndecomp_pools, ndecomp_pools_vr) + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: idate(3) ! current date (year, days of the year, seconds of the day) + integer, intent(in) :: nl_soil ! number of total soil number + integer, intent(in) :: ndecomp_transitions ! number of total litter & soil pools + integer, intent(in) :: ndecomp_pools ! number of total transfers between all litter & soil pools in the decomposition. + integer, intent(in) :: ndecomp_pools_vr ! number of total litter & soil pools times numer of soil layers (eg. 7 * 10) + + !----------------------------------------------------------------------- + + integer :: k, m, j + ! set index of vegetation CN pools + real(r8),parameter :: epsi = 1.e-8_r8 + integer ,parameter :: nvegc = 21 + integer ,parameter :: nvegn = 22 + integer ,parameter :: ileaf = 1 + integer ,parameter :: ileaf_st = 2 + integer ,parameter :: ileaf_xf = 3 + integer ,parameter :: ifroot = 4 + integer ,parameter :: ifroot_st = 5 + integer ,parameter :: ifroot_xf = 6 + integer ,parameter :: ilivestem = 7 + integer ,parameter :: ilivestem_st = 8 + integer ,parameter :: ilivestem_xf = 9 + integer ,parameter :: ideadstem = 10 + integer ,parameter :: ideadstem_st = 11 + integer ,parameter :: ideadstem_xf = 12 + integer ,parameter :: ilivecroot = 13 + integer ,parameter :: ilivecroot_st = 14 + integer ,parameter :: ilivecroot_xf = 15 + integer ,parameter :: ideadcroot = 16 + integer ,parameter :: ideadcroot_st = 17 + integer ,parameter :: ideadcroot_xf = 18 + integer ,parameter :: igrain = 19 + integer ,parameter :: igrain_st = 20 + integer ,parameter :: igrain_xf = 21 + integer ,parameter :: iretrans = 22 + + + real(r8),dimension(1:nvegc,1:nvegc) :: AK_veg_acc + real(r8),dimension(1:nvegn,1:nvegn) :: AK_veg_nacc + real(r8),dimension(1:nvegc) :: I_veg_acc + real(r8),dimension(1:nvegn) :: I_veg_nacc + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AK_soil_acc + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AK_soil_nacc + real(r8),dimension(1:ndecomp_pools_vr) :: I_soil_acc + real(r8),dimension(1:ndecomp_pools_vr) :: I_soil_nacc + real(r8),dimension(1:nvegc,1:nvegc) :: AKinv_veg + real(r8),dimension(1:nvegn,1:nvegn) :: AKinvn_veg + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AKinv_soil + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AKinvn_soil + real(r8),dimension(1:nvegc,1) :: vegmatrixc_cap + real(r8),dimension(1:nvegn,1) :: vegmatrixn_cap + real(r8),dimension(1:ndecomp_pools_vr,1) :: soilmatrixc_cap + real(r8),dimension(1:ndecomp_pools_vr,1) :: soilmatrixn_cap + + ! Save the C and N pool size at begin of each year, which are used to calculate C and N capacity at end of each year. + IF (idate(2) .eq. 1 .and. idate(3) .eq. deltim)THEN + DO m = ps, pe + leafc0_p (m) = max(leafc_p (m),epsi) + leafc0_storage_p (m) = max(leafc_storage_p (m),epsi) + leafc0_xfer_p (m) = max(leafc_xfer_p (m),epsi) + frootc0_p (m) = max(frootc_p (m),epsi) + frootc0_storage_p (m) = max(frootc_storage_p (m),epsi) + frootc0_xfer_p (m) = max(frootc_xfer_p (m),epsi) + livestemc0_p (m) = max(livestemc_p (m),epsi) + livestemc0_storage_p (m) = max(livestemc_storage_p (m),epsi) + livestemc0_xfer_p (m) = max(livestemc_xfer_p (m),epsi) + deadstemc0_p (m) = max(deadstemc_p (m),epsi) + deadstemc0_storage_p (m) = max(deadstemc_storage_p (m),epsi) + deadstemc0_xfer_p (m) = max(deadstemc_xfer_p (m),epsi) + livecrootc0_p (m) = max(livecrootc_p (m),epsi) + livecrootc0_storage_p(m) = max(livecrootc_storage_p(m),epsi) + livecrootc0_xfer_p (m) = max(livecrootc_xfer_p (m),epsi) + deadcrootc0_p (m) = max(deadcrootc_p (m),epsi) + deadcrootc0_storage_p(m) = max(deadcrootc_storage_p(m),epsi) + deadcrootc0_xfer_p (m) = max(deadcrootc_xfer_p (m),epsi) + grainc0_p (m) = max(grainc_p (m),epsi) + grainc0_storage_p (m) = max(grainc_storage_p (m),epsi) + grainc0_xfer_p (m) = max(grainc_xfer_p (m),epsi) + leafn0_p (m) = max(leafn_p (m),epsi) + leafn0_storage_p (m) = max(leafn_storage_p (m),epsi) + leafn0_xfer_p (m) = max(leafn_xfer_p (m),epsi) + frootn0_p (m) = max(frootn_p (m),epsi) + frootn0_storage_p (m) = max(frootn_storage_p (m),epsi) + frootn0_xfer_p (m) = max(frootn_xfer_p (m),epsi) + livestemn0_p (m) = max(livestemn_p (m),epsi) + livestemn0_storage_p (m) = max(livestemn_storage_p (m),epsi) + livestemn0_xfer_p (m) = max(livestemn_xfer_p (m),epsi) + deadstemn0_p (m) = max(deadstemn_p (m),epsi) + deadstemn0_storage_p (m) = max(deadstemn_storage_p (m),epsi) + deadstemn0_xfer_p (m) = max(deadstemn_xfer_p (m),epsi) + livecrootn0_p (m) = max(livecrootn_p (m),epsi) + livecrootn0_storage_p(m) = max(livecrootn_storage_p(m),epsi) + livecrootn0_xfer_p (m) = max(livecrootn_xfer_p (m),epsi) + deadcrootn0_p (m) = max(deadcrootn_p (m),epsi) + deadcrootn0_storage_p(m) = max(deadcrootn_storage_p(m),epsi) + deadcrootn0_xfer_p (m) = max(deadcrootn_xfer_p (m),epsi) + grainn0_p (m) = max(grainn_p (m),epsi) + grainn0_storage_p (m) = max(grainn_storage_p (m),epsi) + grainn0_xfer_p (m) = max(grainn_xfer_p (m),epsi) + retransn0_p (m) = max(retransn_p (m),epsi) + ENDDO + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp0_cpools_vr(j,k,i)=max(decomp_cpools_vr(j,k,i),epsi) + decomp0_npools_vr(j,k,i)=max(decomp_npools_vr(j,k,i),epsi) + ENDDO + ENDDO + ENDIF + + IF(idate(2) .eq. 365 .and. idate(3) .eq. 86400 - deltim)THEN + ! Copy C transfers from sparse matrix to 2D temporary variables tran_acc and tran_nacc + ! Calculate the C and N transfer rate by dividing CN transfer by base value saved at begin of each year. + + DO m = ps, pe + AK_veg_acc (1:nvegc,1:nvegc) = 0._r8 + AK_veg_nacc (1:nvegn,1:nvegn) = 0._r8 + I_veg_acc (1:nvegc) = 0._r8 + I_veg_nacc (1:nvegn) = 0._r8 + + AK_veg_acc ( ileaf, ileaf_xf) = AKX_leafc_xf_to_leafc_p_acc (m) / leafc0_xfer_p (m) + AK_veg_acc ( ifroot, ifroot_xf) = AKX_frootc_xf_to_frootc_p_acc (m) / frootc0_xfer_p (m) + AK_veg_acc ( ilivestem, ilivestem_xf) = AKX_livestemc_xf_to_livestemc_p_acc (m) / livestemc0_xfer_p (m) + AK_veg_acc ( ideadstem, ideadstem_xf) = AKX_deadstemc_xf_to_deadstemc_p_acc (m) / deadstemc0_xfer_p (m) + AK_veg_acc ( ilivecroot,ilivecroot_xf) = AKX_livecrootc_xf_to_livecrootc_p_acc (m) / livecrootc0_xfer_p (m) + AK_veg_acc ( ideadcroot,ideadcroot_xf) = AKX_deadcrootc_xf_to_deadcrootc_p_acc (m) / deadcrootc0_xfer_p (m) + AK_veg_acc ( igrain, igrain_xf) = AKX_grainc_xf_to_grainc_p_acc (m) / grainc0_xfer_p (m) + AK_veg_acc ( ideadstem, ilivestem) = AKX_livestemc_to_deadstemc_p_acc (m) / livestemc0_p (m) + AK_veg_acc ( ideadcroot, ilivecroot) = AKX_livecrootc_to_deadcrootc_p_acc (m) / livecrootc0_p (m) + + AK_veg_acc ( ileaf_xf, ileaf_st) = AKX_leafc_st_to_leafc_xf_p_acc (m) / leafc0_storage_p (m) + AK_veg_acc ( ifroot_xf, ifroot_st) = AKX_frootc_st_to_frootc_xf_p_acc (m) / frootc0_storage_p (m) + AK_veg_acc ( ilivestem_xf, ilivestem_st) = AKX_livestemc_st_to_livestemc_xf_p_acc (m) / livestemc0_storage_p (m) + AK_veg_acc ( ideadstem_xf, ideadstem_st) = AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) / deadstemc0_storage_p (m) + AK_veg_acc (ilivecroot_xf,ilivecroot_st) = AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) / livecrootc0_storage_p(m) + AK_veg_acc (ideadcroot_xf,ideadcroot_st) = AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) / deadcrootc0_storage_p(m) + AK_veg_acc ( igrain_xf, igrain_st) = AKX_grainc_st_to_grainc_xf_p_acc (m) / grainc0_storage_p (m) + + AK_veg_acc ( ileaf, ileaf) = - AKX_leafc_exit_p_acc (m) / leafc0_p (m) + AK_veg_acc ( ileaf_st, ileaf_st) = - AKX_leafc_st_exit_p_acc (m) / leafc0_storage_p (m) + AK_veg_acc ( ileaf_xf, ileaf_xf) = - AKX_leafc_xf_exit_p_acc (m) / leafc0_xfer_p (m) + AK_veg_acc ( ifroot, ifroot) = - AKX_frootc_exit_p_acc (m) / frootc0_p (m) + AK_veg_acc ( ifroot_st, ifroot_st) = - AKX_frootc_st_exit_p_acc (m) / frootc0_storage_p (m) + AK_veg_acc ( ifroot_xf, ifroot_xf) = - AKX_frootc_xf_exit_p_acc (m) / frootc0_xfer_p (m) + AK_veg_acc ( ilivestem, ilivestem) = - AKX_livestemc_exit_p_acc (m) / livestemc0_p (m) + AK_veg_acc ( ilivestem_st, ilivestem_st) = - AKX_livestemc_st_exit_p_acc (m) / livestemc0_storage_p (m) + AK_veg_acc ( ilivestem_xf, ilivestem_xf) = - AKX_livestemc_xf_exit_p_acc (m) / livestemc0_xfer_p (m) + AK_veg_acc ( ideadstem, ideadstem) = - AKX_deadstemc_exit_p_acc (m) / deadstemc0_p (m) + AK_veg_acc ( ideadstem_st, ideadstem_st) = - AKX_deadstemc_st_exit_p_acc (m) / deadstemc0_storage_p (m) + AK_veg_acc ( ideadstem_xf, ideadstem_xf) = - AKX_deadstemc_xf_exit_p_acc (m) / deadstemc0_xfer_p (m) + AK_veg_acc ( ilivecroot, ilivecroot) = - AKX_livecrootc_exit_p_acc (m) / livecrootc0_p (m) + AK_veg_acc (ilivecroot_st,ilivecroot_st) = - AKX_livecrootc_st_exit_p_acc (m) / livecrootc0_storage_p(m) + AK_veg_acc (ilivecroot_xf,ilivecroot_xf) = - AKX_livecrootc_xf_exit_p_acc (m) / livecrootc0_xfer_p (m) + AK_veg_acc ( ideadcroot, ideadcroot) = - AKX_deadcrootc_exit_p_acc (m) / deadcrootc0_p (m) + AK_veg_acc (ideadcroot_st,ideadcroot_st) = - AKX_deadcrootc_st_exit_p_acc (m) / deadcrootc0_storage_p(m) + AK_veg_acc (ideadcroot_xf,ideadcroot_xf) = - AKX_deadcrootc_xf_exit_p_acc (m) / deadcrootc0_xfer_p (m) + AK_veg_acc ( igrain, igrain) = - AKX_grainc_exit_p_acc (m) / grainc0_p (m) + AK_veg_acc ( igrain_st, igrain_st) = - AKX_grainc_st_exit_p_acc (m) / grainc0_storage_p (m) + AK_veg_acc ( igrain_xf, igrain_xf) = - AKX_grainc_xf_exit_p_acc (m) / grainc0_xfer_p (m) + + I_veg_acc ( ileaf) = I_leafc_p_acc (m) + I_veg_acc ( ileaf_st) = I_leafc_st_p_acc (m) + I_veg_acc ( ifroot) = I_frootc_p_acc (m) + I_veg_acc ( ifroot_st) = I_frootc_st_p_acc (m) + I_veg_acc ( ilivestem) = I_livestemc_p_acc (m) + I_veg_acc ( ilivestem_st) = I_livestemc_st_p_acc (m) + I_veg_acc ( ideadstem) = I_deadstemc_p_acc (m) + I_veg_acc ( ideadstem_st) = I_deadstemc_st_p_acc (m) + I_veg_acc ( ilivecroot) = I_livecrootc_p_acc (m) + I_veg_acc (ilivecroot_st) = I_livecrootc_st_p_acc (m) + I_veg_acc ( ideadcroot) = I_deadcrootc_p_acc (m) + I_veg_acc (ideadcroot_st) = I_deadcrootc_st_p_acc (m) + I_veg_acc ( igrain) = I_grainc_p_acc (m) + I_veg_acc ( igrain_st) = I_grainc_st_p_acc (m) + + AK_veg_nacc ( ileaf, ileaf_xf) = AKX_leafn_xf_to_leafn_p_acc (m) / leafn0_xfer_p (m) + AK_veg_nacc ( ifroot, ifroot_xf) = AKX_frootn_xf_to_frootn_p_acc (m) / frootn0_xfer_p (m) + AK_veg_nacc ( ilivestem, ilivestem_xf) = AKX_livestemn_xf_to_livestemn_p_acc (m) / livestemn0_xfer_p (m) + AK_veg_nacc ( ideadstem, ideadstem_xf) = AKX_deadstemn_xf_to_deadstemn_p_acc (m) / deadstemn0_xfer_p (m) + AK_veg_nacc ( ilivecroot,ilivecroot_xf) = AKX_livecrootn_xf_to_livecrootn_p_acc (m) / livecrootn0_xfer_p (m) + AK_veg_nacc ( ideadcroot,ideadcroot_xf) = AKX_deadcrootn_xf_to_deadcrootn_p_acc (m) / deadcrootn0_xfer_p (m) + AK_veg_nacc ( igrain, igrain_xf) = AKX_grainn_xf_to_grainn_p_acc (m) / grainn0_xfer_p (m) + AK_veg_nacc ( ideadstem, ilivestem) = AKX_livestemn_to_deadstemn_p_acc (m) / livestemn0_p (m) + AK_veg_nacc ( ideadcroot, ilivecroot) = AKX_livecrootn_to_deadcrootn_p_acc (m) / livecrootn0_p (m) + + AK_veg_nacc ( ileaf_xf, ileaf_st) = AKX_leafn_st_to_leafn_xf_p_acc (m) / leafn0_storage_p (m) + AK_veg_nacc ( ifroot_xf, ifroot_st) = AKX_frootn_st_to_frootn_xf_p_acc (m) / frootn0_storage_p (m) + AK_veg_nacc ( ilivestem_xf, ilivestem_st) = AKX_livestemn_st_to_livestemn_xf_p_acc (m) / livestemn0_storage_p (m) + AK_veg_nacc ( ideadstem_xf, ideadstem_st) = AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) / deadstemn0_storage_p (m) + AK_veg_nacc (ilivecroot_xf,ilivecroot_st) = AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) / livecrootn0_storage_p(m) + AK_veg_nacc (ideadcroot_xf,ideadcroot_st) = AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) / deadcrootn0_storage_p(m) + AK_veg_nacc ( igrain_xf, igrain_st) = AKX_grainn_st_to_grainn_xf_p_acc (m) / grainn0_storage_p (m) + + AK_veg_nacc ( iretrans, ileaf) = AKX_leafn_to_retransn_p_acc (m) / leafn0_p (m) + AK_veg_nacc ( iretrans, ifroot) = AKX_frootn_to_retransn_p_acc (m) / frootn0_p (m) + AK_veg_nacc ( iretrans, ilivestem) = AKX_livestemn_to_retransn_p_acc (m) / livestemn0_p (m) + AK_veg_nacc ( iretrans, ilivecroot) = AKX_livecrootn_to_retransn_p_acc (m) / livecrootn0_p (m) + + AK_veg_nacc ( ileaf, iretrans) = AKX_retransn_to_leafn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ifroot, iretrans) = AKX_retransn_to_frootn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ilivestem, iretrans) = AKX_retransn_to_livestemn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ideadstem, iretrans) = AKX_retransn_to_deadstemn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ilivecroot, iretrans) = AKX_retransn_to_livecrootn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ideadcroot, iretrans) = AKX_retransn_to_deadcrootn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( igrain, iretrans) = AKX_retransn_to_grainn_p_acc (m) / retransn0_p (m) + + AK_veg_nacc ( ileaf_st, iretrans) = AKX_retransn_to_leafn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ifroot_st, iretrans) = AKX_retransn_to_frootn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ilivestem_st, iretrans) = AKX_retransn_to_livestemn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ideadstem_st, iretrans) = AKX_retransn_to_deadstemn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc (ilivecroot_st, iretrans) = AKX_retransn_to_livecrootn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc (ideadcroot_st, iretrans) = AKX_retransn_to_deadcrootn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( igrain_st, iretrans) = AKX_retransn_to_grainn_st_p_acc (m) / retransn0_p (m) + + AK_veg_nacc ( ileaf, ileaf) = - AKX_leafn_exit_p_acc (m) / leafn0_p (m) + AK_veg_nacc ( ileaf_st, ileaf_st) = - AKX_leafn_st_exit_p_acc (m) / leafn0_storage_p (m) + AK_veg_nacc ( ileaf_xf, ileaf_xf) = - AKX_leafn_xf_exit_p_acc (m) / leafn0_xfer_p (m) + AK_veg_nacc ( ifroot, ifroot) = - AKX_frootn_exit_p_acc (m) / frootn0_p (m) + AK_veg_nacc ( ifroot_st, ifroot_st) = - AKX_frootn_st_exit_p_acc (m) / frootn0_storage_p (m) + AK_veg_nacc ( ifroot_xf, ifroot_xf) = - AKX_frootn_xf_exit_p_acc (m) / frootn0_xfer_p (m) + AK_veg_nacc ( ilivestem, ilivestem) = - AKX_livestemn_exit_p_acc (m) / livestemn0_p (m) + AK_veg_nacc ( ilivestem_st, ilivestem_st) = - AKX_livestemn_st_exit_p_acc (m) / livestemn0_storage_p (m) + AK_veg_nacc ( ilivestem_xf, ilivestem_xf) = - AKX_livestemn_xf_exit_p_acc (m) / livestemn0_xfer_p (m) + AK_veg_nacc ( ideadstem, ideadstem) = - AKX_deadstemn_exit_p_acc (m) / deadstemn0_p (m) + AK_veg_nacc ( ideadstem_st, ideadstem_st) = - AKX_deadstemn_st_exit_p_acc (m) / deadstemn0_storage_p (m) + AK_veg_nacc ( ideadstem_xf, ideadstem_xf) = - AKX_deadstemn_xf_exit_p_acc (m) / deadstemn0_xfer_p (m) + AK_veg_nacc ( ilivecroot, ilivecroot) = - AKX_livecrootn_exit_p_acc (m) / livecrootn0_p (m) + AK_veg_nacc (ilivecroot_st,ilivecroot_st) = - AKX_livecrootn_st_exit_p_acc (m) / livecrootn0_storage_p(m) + AK_veg_nacc (ilivecroot_xf,ilivecroot_xf) = - AKX_livecrootn_xf_exit_p_acc (m) / livecrootn0_xfer_p (m) + AK_veg_nacc ( ideadcroot, ideadcroot) = - AKX_deadcrootn_exit_p_acc (m) / deadcrootn0_p (m) + AK_veg_nacc (ideadcroot_st,ideadcroot_st) = - AKX_deadcrootn_st_exit_p_acc (m) / deadcrootn0_storage_p(m) + AK_veg_nacc (ideadcroot_xf,ideadcroot_xf) = - AKX_deadcrootn_xf_exit_p_acc (m) / deadcrootn0_xfer_p (m) + AK_veg_nacc ( igrain, igrain) = - AKX_grainn_exit_p_acc (m) / grainn0_p (m) + AK_veg_nacc ( igrain_st, igrain_st) = - AKX_grainn_st_exit_p_acc (m) / grainn0_storage_p (m) + AK_veg_nacc ( igrain_xf, igrain_xf) = - AKX_grainn_xf_exit_p_acc (m) / grainn0_xfer_p (m) + AK_veg_nacc ( iretrans, iretrans) = - AKX_retransn_exit_p_acc (m) / retransn0_p (m) + + I_veg_nacc ( ileaf) = I_leafn_p_acc (m) + I_veg_nacc ( ileaf_st) = I_leafn_st_p_acc (m) + I_veg_nacc ( ifroot) = I_frootn_p_acc (m) + I_veg_nacc ( ifroot_st) = I_frootn_st_p_acc (m) + I_veg_nacc ( ilivestem) = I_livestemn_p_acc (m) + I_veg_nacc ( ilivestem_st) = I_livestemn_st_p_acc (m) + I_veg_nacc ( ideadstem) = I_deadstemn_p_acc (m) + I_veg_nacc ( ideadstem_st) = I_deadstemn_st_p_acc (m) + I_veg_nacc ( ilivecroot) = I_livecrootn_p_acc (m) + I_veg_nacc (ilivecroot_st) = I_livecrootn_st_p_acc (m) + I_veg_nacc ( ideadcroot) = I_deadcrootn_p_acc (m) + I_veg_nacc (ideadcroot_st) = I_deadcrootn_st_p_acc (m) + I_veg_nacc ( igrain) = I_grainn_p_acc (m) + I_veg_nacc ( igrain_st) = I_grainn_st_p_acc (m) + + DO j = 1, nvegc + IF(AK_veg_acc(j,j) .eq. 0)THEN + AK_veg_acc(j,j) = - 1.e+36 + ENDIF + ENDDO + DO j = 1, nvegn + IF(AK_veg_nacc(j,j) .eq. 0)THEN + AK_veg_nacc(j,j) = - 1.e+36 + ENDIF + ENDDO + + ! Calculate capacity + CALL inverse(AK_veg_acc (1:nvegc,1:nvegc),AKinv_veg (1:nvegc,1:nvegc),nvegc) + CALL inverse(AK_veg_nacc(1:nvegn,1:nvegn),AKinvn_veg(1:nvegn,1:nvegn),nvegn) + vegmatrixc_cap(:,1) = -matmul(AKinv_veg (1:nvegc,1:nvegc),I_veg_acc (1:nvegc)) + vegmatrixn_cap(:,1) = -matmul(AKinvn_veg(1:nvegn,1:nvegn),I_veg_nacc(1:nvegn)) + + DO k = 1, nvegc + IF(vegmatrixc_cap(k,1) .lt. 0)THEN + vegmatrixc_cap(k,1) = epsi + ENDIF + ENDDO + DO k = 1, nvegn + IF(vegmatrixn_cap(k,1) .lt. 0)THEN + vegmatrixn_cap(k,1) = epsi + ENDIF + ENDDO + IF(DEF_USE_DiagMatrix)THEN + leafcCap_p (m) = vegmatrixc_cap(ileaf ,1) + leafc_storageCap_p (m) = vegmatrixc_cap(ileaf_st ,1) + leafc_xferCap_p (m) = vegmatrixc_cap(ileaf_xf ,1) + frootcCap_p (m) = vegmatrixc_cap(ifroot ,1) + frootc_storageCap_p (m) = vegmatrixc_cap(ifroot_st ,1) + frootc_xferCap_p (m) = vegmatrixc_cap(ifroot_xf ,1) + livestemcCap_p (m) = vegmatrixc_cap(ilivestem ,1) + livestemc_storageCap_p (m) = vegmatrixc_cap(ilivestem_st ,1) + livestemc_xferCap_p (m) = vegmatrixc_cap(ilivestem_xf ,1) + deadstemcCap_p (m) = vegmatrixc_cap(ideadstem ,1) + deadstemc_storageCap_p (m) = vegmatrixc_cap(ideadstem_st ,1) + deadstemc_xferCap_p (m) = vegmatrixc_cap(ideadstem_xf ,1) + livecrootcCap_p (m) = vegmatrixc_cap(ilivecroot ,1) + livecrootc_storageCap_p (m) = vegmatrixc_cap(ilivecroot_st ,1) + livecrootc_xferCap_p (m) = vegmatrixc_cap(ilivecroot_xf ,1) + deadcrootcCap_p (m) = vegmatrixc_cap(ideadcroot ,1) + deadcrootc_storageCap_p (m) = vegmatrixc_cap(ideadcroot_st ,1) + deadcrootc_xferCap_p (m) = vegmatrixc_cap(ideadcroot_xf ,1) + leafnCap_p (m) = vegmatrixn_cap(ileaf ,1) + leafn_storageCap_p (m) = vegmatrixn_cap(ileaf_st ,1) + leafn_xferCap_p (m) = vegmatrixn_cap(ileaf_xf ,1) + frootnCap_p (m) = vegmatrixn_cap(ifroot ,1) + frootn_storageCap_p (m) = vegmatrixn_cap(ifroot_st ,1) + frootn_xferCap_p (m) = vegmatrixn_cap(ifroot_xf ,1) + livestemnCap_p (m) = vegmatrixn_cap(ilivestem ,1) + livestemn_storageCap_p (m) = vegmatrixn_cap(ilivestem_st ,1) + livestemn_xferCap_p (m) = vegmatrixn_cap(ilivestem_xf ,1) + deadstemnCap_p (m) = vegmatrixn_cap(ideadstem ,1) + deadstemn_storageCap_p (m) = vegmatrixn_cap(ideadstem_st ,1) + deadstemn_xferCap_p (m) = vegmatrixn_cap(ideadstem_xf ,1) + livecrootnCap_p (m) = vegmatrixn_cap(ilivecroot ,1) + livecrootn_storageCap_p (m) = vegmatrixn_cap(ilivecroot_st ,1) + livecrootn_xferCap_p (m) = vegmatrixn_cap(ilivecroot_xf ,1) + deadcrootnCap_p (m) = vegmatrixn_cap(ideadcroot ,1) + deadcrootn_storageCap_p (m) = vegmatrixn_cap(ideadcroot_st ,1) + deadcrootn_xferCap_p (m) = vegmatrixn_cap(ideadcroot_xf ,1) + ENDIF + IF(DEF_USE_SASU)then + deadstemc_p (m) = vegmatrixc_cap(ideadstem,1) + deadstemc_storage_p (m) = vegmatrixc_cap(ideadstem_st,1) + deadcrootc_p (m) = vegmatrixc_cap(ideadcroot,1) + deadcrootc_storage_p(m) = vegmatrixc_cap(ideadcroot_st,1) + deadstemn_p (m) = vegmatrixn_cap(ideadstem,1) + deadstemn_storage_p (m) = vegmatrixn_cap(ideadstem_st,1) + deadcrootn_p (m) = vegmatrixn_cap(ideadcroot,1) + deadcrootn_storage_p(m) = vegmatrixn_cap(ideadcroot_st,1) + ENDIF + ENDDO + + AK_soil_acc (1:ndecomp_pools_vr,1:ndecomp_pools_vr) = 0._r8 + AK_soil_nacc(1:ndecomp_pools_vr,1:ndecomp_pools_vr) = 0._r8 + I_soil_acc (1:ndecomp_pools_vr) = 0._r8 + I_soil_nacc (1:ndecomp_pools_vr) = 0._r8 + DO j=1, nl_soil + ! C EXIT rate + AK_soil_acc ((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = - (AKX_met_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_met_lit,i)) / decomp0_cpools_vr(j,i_met_lit,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = - (AKX_cel_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_cel_lit,i)) / decomp0_cpools_vr(j,i_cel_lit,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = - (AKX_lig_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_lig_lit,i)) / decomp0_cpools_vr(j,i_lig_lit,i) + AK_soil_acc ((i_cwd -1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = - AKX_cwd_exit_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_cwd ,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = - (AKX_soil1_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_soil1,i)) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = - (AKX_soil2_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_soil2,i)) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = - (AKX_soil3_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_soil3,i)) / decomp0_cpools_vr(j,i_soil3 ,i) + + ! C transfer + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = AKX_met_to_soil1_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_met_lit,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = AKX_cel_to_soil1_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_cel_lit,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = AKX_lig_to_soil2_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_lig_lit,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil2_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_cel_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_cwd ,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_lig_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_cwd ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil3_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil1_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil3_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = AKX_soil3_to_soil1_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil3 ,i) + + ! C input + I_soil_acc((i_met_lit-1)*nl_soil+j) = I_met_c_vr_acc(j,i) + I_soil_acc((i_cel_lit-1)*nl_soil+j) = I_cel_c_vr_acc(j,i) + I_soil_acc((i_lig_lit-1)*nl_soil+j) = I_lig_c_vr_acc(j,i) + I_soil_acc((i_cwd -1)*nl_soil+j) = I_cwd_c_vr_acc(j,i) + + ! N EXIT rate + AK_soil_nacc((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = - (AKX_met_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_met_lit,i)) / decomp0_npools_vr(j,i_met_lit,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = - (AKX_cel_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_cel_lit,i)) / decomp0_npools_vr(j,i_cel_lit,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = - (AKX_lig_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_lig_lit,i)) / decomp0_npools_vr(j,i_lig_lit,i) + AK_soil_nacc((i_cwd -1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = - AKX_cwd_exit_n_vr_acc(j,i) / decomp0_npools_vr(j,i_cwd ,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = - (AKX_soil1_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_soil1,i)) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = - (AKX_soil2_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_soil2,i)) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = - (AKX_soil3_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_soil3,i)) / decomp0_npools_vr(j,i_soil3 ,i) + + ! N transfer + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = AKX_met_to_soil1_n_vr_acc (j,i) / decomp0_npools_vr(j,i_met_lit,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = AKX_cel_to_soil1_n_vr_acc (j,i) / decomp0_npools_vr(j,i_cel_lit,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = AKX_lig_to_soil2_n_vr_acc (j,i) / decomp0_npools_vr(j,i_lig_lit,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil2_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_cel_n_vr_acc (j,i) / decomp0_npools_vr(j,i_cwd ,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_lig_n_vr_acc (j,i) / decomp0_npools_vr(j,i_cwd ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil3_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil1_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil3_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = AKX_soil3_to_soil1_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil3 ,i) + + ENDDO + + DO j=1,nl_soil-1 + ! upper triadiagnonal entries for C + AK_soil_acc ((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_met_lit,i) / decomp0_cpools_vr(j+1,i_met_lit,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_cel_lit,i) / decomp0_cpools_vr(j+1,i_cel_lit,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_lig_lit,i) / decomp0_cpools_vr(j+1,i_lig_lit,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_soil1 ,i) / decomp0_cpools_vr(j+1,i_soil1 ,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_soil2 ,i) / decomp0_cpools_vr(j+1,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_soil3 ,i) / decomp0_cpools_vr(j+1,i_soil3 ,i) + + ! lower triadiagnonal entries for C + AK_soil_acc ((i_met_lit-1)*nl_soil+j+1,(i_met_lit-1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_met_lit,i) / decomp0_cpools_vr(j,i_met_lit,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j+1,(i_cel_lit-1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_cel_lit,i) / decomp0_cpools_vr(j,i_cel_lit,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j+1,(i_lig_lit-1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_lig_lit,i) / decomp0_cpools_vr(j,i_lig_lit,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j+1,(i_soil1 -1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_soil1 ,i) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j+1,(i_soil2 -1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_soil2 ,i) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j+1,(i_soil3 -1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_soil3 ,i) / decomp0_cpools_vr(j,i_soil3 ,i) + + + ! upper triadiagnonal entries for N + AK_soil_nacc((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_met_lit,i) / decomp0_npools_vr(j+1,i_met_lit,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_cel_lit,i) / decomp0_npools_vr(j+1,i_cel_lit,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_lig_lit,i) / decomp0_npools_vr(j+1,i_lig_lit,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_soil1 ,i) / decomp0_npools_vr(j+1,i_soil1 ,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_soil2 ,i) / decomp0_npools_vr(j+1,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_soil3 ,i) / decomp0_npools_vr(j+1,i_soil3 ,i) + + ! lower triadiagnonal entries for N + AK_soil_nacc((i_met_lit-1)*nl_soil+j+1,(i_met_lit-1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_met_lit,i) / decomp0_npools_vr(j,i_met_lit,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j+1,(i_cel_lit-1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_cel_lit,i) / decomp0_npools_vr(j,i_cel_lit,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j+1,(i_lig_lit-1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_lig_lit,i) / decomp0_npools_vr(j,i_lig_lit,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j+1,(i_soil1 -1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_soil1 ,i) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j+1,(i_soil2 -1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_soil2 ,i) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j+1,(i_soil3 -1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_soil3 ,i) / decomp0_npools_vr(j,i_soil3 ,i) + + ! N input + I_soil_nacc((i_met_lit-1)*nl_soil+j) = I_met_n_vr_acc(j,i) + I_soil_nacc((i_cel_lit-1)*nl_soil+j) = I_cel_n_vr_acc(j,i) + I_soil_nacc((i_lig_lit-1)*nl_soil+j) = I_lig_n_vr_acc(j,i) + I_soil_nacc((i_cwd -1)*nl_soil+j) = I_cwd_n_vr_acc(j,i) + + ENDDO + + DO k=1,ndecomp_pools_vr + IF (abs(AK_soil_acc(k,k)) .le. epsi)THEN !avoid inversion nan + AK_soil_acc(k,k) = - 1.e+36_r8 + ENDIF + ENDDO + + DO k=1,ndecomp_pools_vr + IF (abs(AK_soil_nacc(k,k)) .le. epsi)THEN + AK_soil_nacc(k,k) = - 1.e+36_r8 + ENDIF + ENDDO + + ! Calculate capacity + CALL inverse(AK_soil_acc (1:ndecomp_pools_vr,1:ndecomp_pools_vr),AKinv_soil (1:ndecomp_pools_vr,1:ndecomp_pools_vr),ndecomp_pools_vr) + CALL inverse(AK_soil_nacc(1:ndecomp_pools_vr,1:ndecomp_pools_vr),AKinvn_soil(1:ndecomp_pools_vr,1:ndecomp_pools_vr),ndecomp_pools_vr) + soilmatrixc_cap(:,1) = -matmul(AKinv_soil(1:ndecomp_pools_vr,1:ndecomp_pools_vr), I_soil_acc (1:ndecomp_pools_vr)) + soilmatrixn_cap(:,1) = -matmul(AKinvn_soil(1:ndecomp_pools_vr,1:ndecomp_pools_vr),I_soil_nacc(1:ndecomp_pools_vr)) + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + IF(soilmatrixc_cap(j+(k-1)*nl_soil,1) .lt. 0)THEN + soilmatrixc_cap(j+(k-1)*nl_soil,1) = 0._r8 + ENDIF + IF(soilmatrixn_cap(j+(k-1)*nl_soil,1) .lt. 0)THEN + soilmatrixn_cap(j+(k-1)*nl_soil,1) = 0._r8 + ENDIF + ENDDO + ENDDO + + IF(DEF_USE_DiagMatrix)THEN + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_vr_Cap(j,k,i) = soilmatrixc_cap(j+(k-1)*nl_soil,1) + decomp_npools_vr_Cap(j,k,i) = soilmatrixn_cap(j+(k-1)*nl_soil,1) + ENDDO + ENDDO + ENDIF + IF(DEF_USE_SASU)THEN + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + IF((soilmatrixc_cap(j+(k-1)*nl_soil,1)/decomp0_cpools_vr(j,k,i) .gt. 100 .and. soilmatrixc_cap(j+(k-1)*nl_soil,1) .gt. 1.e+5_r8 & + .or. soilmatrixn_cap(j+(k-1)*nl_soil,1)/decomp0_npools_vr(j,k,i) .gt. 100 .and. soilmatrixn_cap(j+(k-1)*nl_soil,1) .gt. 1.e+3_r8) & + .or. k .eq. i_cwd .and. (soilmatrixc_cap(j+(k-1)*nl_soil,1)/decomp0_cpools_vr(j,k,i) .gt. 100 .and. soilmatrixc_cap(j+(k-1)*nl_soil,1) .gt. 1.e+5_r8 & + .or. soilmatrixn_cap(j+(k-1)*nl_soil,1)/decomp0_npools_vr(j,k,i) .gt. 100 .and. soilmatrixn_cap(j+(k-1)*nl_soil,1) .gt. 1.e+3_r8) )THEN + soilmatrixc_cap(j+(k-1)*nl_soil,1) = decomp_cpools_vr(j,k,i) + soilmatrixn_cap(j+(k-1)*nl_soil,1) = decomp_npools_vr(j,k,i) + ENDIF + ENDDO + ENDDO + + IF(any(soilmatrixc_cap(:,1) .gt. 1.e+8_r8) .or. any(soilmatrixn_cap(:,1) .gt. 1.e+8_r8))THEN + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + soilmatrixc_cap(j+(k-1)*nl_soil,1) = decomp_cpools_vr(j,k,i) + soilmatrixn_cap(j+(k-1)*nl_soil,1) = decomp_npools_vr(j,k,i) + ENDDO + ENDDO + ENDIF + + ! IF spin up is on, the capacity replaces the pool size with capacity. + ! Copy the capacity into a 3D variable, and be ready to write to history files. + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_vr(j,k,i) = soilmatrixc_cap(j+(k-1)*nl_soil,1) + IF(floating_cn_ratio(k))THEN + decomp_npools_vr(j,k,i) = soilmatrixn_cap(j+(k-1)*nl_soil,1) + ELSE + decomp_npools_vr(j,k,i) = decomp_cpools_vr(j,k,i) / cn_decomp_pools(j,k,i) + ENDIF + ENDDO + ENDDO + + skip_balance_check(i) = .true. + ENDIF + + ! Reset to accumulation variables to 0 at END of each year + DO m=ps, pe + I_leafc_p_acc (m) = 0._r8 + I_leafc_st_p_acc (m) = 0._r8 + I_frootc_p_acc (m) = 0._r8 + I_frootc_st_p_acc (m) = 0._r8 + I_livestemc_p_acc (m) = 0._r8 + I_livestemc_st_p_acc (m) = 0._r8 + I_deadstemc_p_acc (m) = 0._r8 + I_deadstemc_st_p_acc (m) = 0._r8 + I_livecrootc_p_acc (m) = 0._r8 + I_livecrootc_st_p_acc(m) = 0._r8 + I_deadcrootc_p_acc (m) = 0._r8 + I_deadcrootc_st_p_acc(m) = 0._r8 + I_grainc_p_acc (m) = 0._r8 + I_grainc_st_p_acc (m) = 0._r8 + I_leafn_p_acc (m) = 0._r8 + I_leafn_st_p_acc (m) = 0._r8 + I_frootn_p_acc (m) = 0._r8 + I_frootn_st_p_acc (m) = 0._r8 + I_livestemn_p_acc (m) = 0._r8 + I_livestemn_st_p_acc (m) = 0._r8 + I_deadstemn_p_acc (m) = 0._r8 + I_deadstemn_st_p_acc (m) = 0._r8 + I_livecrootn_p_acc (m) = 0._r8 + I_livecrootn_st_p_acc(m) = 0._r8 + I_deadcrootn_p_acc (m) = 0._r8 + I_deadcrootn_st_p_acc(m) = 0._r8 + I_grainn_p_acc (m) = 0._r8 + I_grainn_st_p_acc (m) = 0._r8 + + AKX_leafc_xf_to_leafc_p_acc (m) = 0._r8 + AKX_frootc_xf_to_frootc_p_acc (m) = 0._r8 + AKX_livestemc_xf_to_livestemc_p_acc (m) = 0._r8 + AKX_deadstemc_xf_to_deadstemc_p_acc (m) = 0._r8 + AKX_livecrootc_xf_to_livecrootc_p_acc (m) = 0._r8 + AKX_deadcrootc_xf_to_deadcrootc_p_acc (m) = 0._r8 + AKX_grainc_xf_to_grainc_p_acc (m) = 0._r8 + AKX_livestemc_to_deadstemc_p_acc (m) = 0._r8 + AKX_livecrootc_to_deadcrootc_p_acc (m) = 0._r8 + + AKX_leafc_st_to_leafc_xf_p_acc (m) = 0._r8 + AKX_frootc_st_to_frootc_xf_p_acc (m) = 0._r8 + AKX_livestemc_st_to_livestemc_xf_p_acc (m) = 0._r8 + AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) = 0._r8 + AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) = 0._r8 + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) = 0._r8 + AKX_grainc_st_to_grainc_xf_p_acc (m) = 0._r8 + + AKX_leafc_exit_p_acc (m) = 0._r8 + AKX_frootc_exit_p_acc (m) = 0._r8 + AKX_livestemc_exit_p_acc (m) = 0._r8 + AKX_deadstemc_exit_p_acc (m) = 0._r8 + AKX_livecrootc_exit_p_acc (m) = 0._r8 + AKX_deadcrootc_exit_p_acc (m) = 0._r8 + AKX_grainc_exit_p_acc (m) = 0._r8 + + AKX_leafc_st_exit_p_acc (m) = 0._r8 + AKX_frootc_st_exit_p_acc (m) = 0._r8 + AKX_livestemc_st_exit_p_acc (m) = 0._r8 + AKX_deadstemc_st_exit_p_acc (m) = 0._r8 + AKX_livecrootc_st_exit_p_acc (m) = 0._r8 + AKX_deadcrootc_st_exit_p_acc (m) = 0._r8 + AKX_grainc_st_exit_p_acc (m) = 0._r8 + + AKX_leafc_xf_exit_p_acc (m) = 0._r8 + AKX_frootc_xf_exit_p_acc (m) = 0._r8 + AKX_livestemc_xf_exit_p_acc (m) = 0._r8 + AKX_deadstemc_xf_exit_p_acc (m) = 0._r8 + AKX_livecrootc_xf_exit_p_acc (m) = 0._r8 + AKX_deadcrootc_xf_exit_p_acc (m) = 0._r8 + AKX_grainc_xf_exit_p_acc (m) = 0._r8 + + AKX_leafn_xf_to_leafn_p_acc (m) = 0._r8 + AKX_frootn_xf_to_frootn_p_acc (m) = 0._r8 + AKX_livestemn_xf_to_livestemn_p_acc (m) = 0._r8 + AKX_deadstemn_xf_to_deadstemn_p_acc (m) = 0._r8 + AKX_livecrootn_xf_to_livecrootn_p_acc (m) = 0._r8 + AKX_deadcrootn_xf_to_deadcrootn_p_acc (m) = 0._r8 + AKX_grainn_xf_to_grainn_p_acc (m) = 0._r8 + AKX_livestemn_to_deadstemn_p_acc (m) = 0._r8 + AKX_livecrootn_to_deadcrootn_p_acc (m) = 0._r8 + + AKX_leafn_st_to_leafn_xf_p_acc (m) = 0._r8 + AKX_frootn_st_to_frootn_xf_p_acc (m) = 0._r8 + AKX_livestemn_st_to_livestemn_xf_p_acc (m) = 0._r8 + AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) = 0._r8 + AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) = 0._r8 + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) = 0._r8 + AKX_grainn_st_to_grainn_xf_p_acc (m) = 0._r8 + + AKX_leafn_to_retransn_p_acc (m) = 0._r8 + AKX_frootn_to_retransn_p_acc (m) = 0._r8 + AKX_livestemn_to_retransn_p_acc (m) = 0._r8 + AKX_livecrootn_to_retransn_p_acc (m) = 0._r8 + + AKX_retransn_to_leafn_p_acc (m) = 0._r8 + AKX_retransn_to_frootn_p_acc (m) = 0._r8 + AKX_retransn_to_livestemn_p_acc (m) = 0._r8 + AKX_retransn_to_deadstemn_p_acc (m) = 0._r8 + AKX_retransn_to_livecrootn_p_acc (m) = 0._r8 + AKX_retransn_to_deadcrootn_p_acc (m) = 0._r8 + AKX_retransn_to_grainn_p_acc (m) = 0._r8 + + AKX_retransn_to_leafn_st_p_acc (m) = 0._r8 + AKX_retransn_to_frootn_st_p_acc (m) = 0._r8 + AKX_retransn_to_livestemn_st_p_acc (m) = 0._r8 + AKX_retransn_to_deadstemn_st_p_acc (m) = 0._r8 + AKX_retransn_to_livecrootn_st_p_acc (m) = 0._r8 + AKX_retransn_to_deadcrootn_st_p_acc (m) = 0._r8 + AKX_retransn_to_grainn_st_p_acc (m) = 0._r8 + + AKX_leafn_exit_p_acc (m) = 0._r8 + AKX_frootn_exit_p_acc (m) = 0._r8 + AKX_livestemn_exit_p_acc (m) = 0._r8 + AKX_deadstemn_exit_p_acc (m) = 0._r8 + AKX_livecrootn_exit_p_acc (m) = 0._r8 + AKX_deadcrootn_exit_p_acc (m) = 0._r8 + AKX_grainn_exit_p_acc (m) = 0._r8 + AKX_retransn_exit_p_acc (m) = 0._r8 + + AKX_leafn_st_exit_p_acc (m) = 0._r8 + AKX_frootn_st_exit_p_acc (m) = 0._r8 + AKX_livestemn_st_exit_p_acc (m) = 0._r8 + AKX_deadstemn_st_exit_p_acc (m) = 0._r8 + AKX_livecrootn_st_exit_p_acc (m) = 0._r8 + AKX_deadcrootn_st_exit_p_acc (m) = 0._r8 + AKX_grainn_st_exit_p_acc (m) = 0._r8 + + AKX_leafn_xf_exit_p_acc (m) = 0._r8 + AKX_frootn_xf_exit_p_acc (m) = 0._r8 + AKX_livestemn_xf_exit_p_acc (m) = 0._r8 + AKX_deadstemn_xf_exit_p_acc (m) = 0._r8 + AKX_livecrootn_xf_exit_p_acc (m) = 0._r8 + AKX_deadcrootn_xf_exit_p_acc (m) = 0._r8 + AKX_grainn_xf_exit_p_acc (m) = 0._r8 + ENDDO + + DO j=1,nl_soil + AKX_met_exit_c_vr_acc (j,i) = 0._r8 + AKX_cel_exit_c_vr_acc (j,i) = 0._r8 + AKX_lig_exit_c_vr_acc (j,i) = 0._r8 + AKX_cwd_exit_c_vr_acc (j,i) = 0._r8 + AKX_soil1_exit_c_vr_acc (j,i) = 0._r8 + AKX_soil2_exit_c_vr_acc (j,i) = 0._r8 + AKX_soil3_exit_c_vr_acc (j,i) = 0._r8 + + AKX_met_to_soil1_c_vr_acc (j,i) = 0._r8 + AKX_cel_to_soil1_c_vr_acc (j,i) = 0._r8 + AKX_lig_to_soil2_c_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil2_c_vr_acc(j,i) = 0._r8 + AKX_cwd_to_cel_c_vr_acc (j,i) = 0._r8 + AKX_cwd_to_lig_c_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil3_c_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil1_c_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil3_c_vr_acc(j,i) = 0._r8 + AKX_soil3_to_soil1_c_vr_acc(j,i) = 0._r8 + + diagVX_c_vr_acc (j,i_met_lit,i) = 0._r8 + diagVX_c_vr_acc (j,i_cel_lit,i) = 0._r8 + diagVX_c_vr_acc (j,i_lig_lit,i) = 0._r8 + diagVX_c_vr_acc (j,i_cwd ,i) = 0._r8 + diagVX_c_vr_acc (j,i_soil1 ,i) = 0._r8 + diagVX_c_vr_acc (j,i_soil2 ,i) = 0._r8 + diagVX_c_vr_acc (j,i_soil3 ,i) = 0._r8 + + upperVX_c_vr_acc (j,i_met_lit,i) = 0._r8 + upperVX_c_vr_acc (j,i_cel_lit,i) = 0._r8 + upperVX_c_vr_acc (j,i_lig_lit,i) = 0._r8 + upperVX_c_vr_acc (j,i_cwd ,i) = 0._r8 + upperVX_c_vr_acc (j,i_soil1 ,i) = 0._r8 + upperVX_c_vr_acc (j,i_soil2 ,i) = 0._r8 + upperVX_c_vr_acc (j,i_soil3 ,i) = 0._r8 + + lowerVX_c_vr_acc (j,i_met_lit,i) = 0._r8 + lowerVX_c_vr_acc (j,i_cel_lit,i) = 0._r8 + lowerVX_c_vr_acc (j,i_lig_lit,i) = 0._r8 + lowerVX_c_vr_acc (j,i_cwd ,i) = 0._r8 + lowerVX_c_vr_acc (j,i_soil1 ,i) = 0._r8 + lowerVX_c_vr_acc (j,i_soil2 ,i) = 0._r8 + lowerVX_c_vr_acc (j,i_soil3 ,i) = 0._r8 + + AKX_met_exit_n_vr_acc (j,i) = 0._r8 + AKX_cel_exit_n_vr_acc (j,i) = 0._r8 + AKX_lig_exit_n_vr_acc (j,i) = 0._r8 + AKX_cwd_exit_n_vr_acc (j,i) = 0._r8 + AKX_soil1_exit_n_vr_acc (j,i) = 0._r8 + AKX_soil2_exit_n_vr_acc (j,i) = 0._r8 + AKX_soil3_exit_n_vr_acc (j,i) = 0._r8 + + AKX_met_to_soil1_n_vr_acc (j,i) = 0._r8 + AKX_cel_to_soil1_n_vr_acc (j,i) = 0._r8 + AKX_lig_to_soil2_n_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil2_n_vr_acc(j,i) = 0._r8 + AKX_cwd_to_cel_n_vr_acc (j,i) = 0._r8 + AKX_cwd_to_lig_n_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil3_n_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil1_n_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil3_n_vr_acc(j,i) = 0._r8 + AKX_soil3_to_soil1_n_vr_acc(j,i) = 0._r8 + + diagVX_n_vr_acc (j,i_met_lit,i) = 0._r8 + diagVX_n_vr_acc (j,i_cel_lit,i) = 0._r8 + diagVX_n_vr_acc (j,i_lig_lit,i) = 0._r8 + diagVX_n_vr_acc (j,i_cwd ,i) = 0._r8 + diagVX_n_vr_acc (j,i_soil1 ,i) = 0._r8 + diagVX_n_vr_acc (j,i_soil2 ,i) = 0._r8 + diagVX_n_vr_acc (j,i_soil3 ,i) = 0._r8 + + upperVX_n_vr_acc (j,i_met_lit,i) = 0._r8 + upperVX_n_vr_acc (j,i_cel_lit,i) = 0._r8 + upperVX_n_vr_acc (j,i_lig_lit,i) = 0._r8 + upperVX_n_vr_acc (j,i_cwd ,i) = 0._r8 + upperVX_n_vr_acc (j,i_soil1 ,i) = 0._r8 + upperVX_n_vr_acc (j,i_soil2 ,i) = 0._r8 + upperVX_n_vr_acc (j,i_soil3 ,i) = 0._r8 + + lowerVX_n_vr_acc (j,i_met_lit,i) = 0._r8 + lowerVX_n_vr_acc (j,i_cel_lit,i) = 0._r8 + lowerVX_n_vr_acc (j,i_lig_lit,i) = 0._r8 + lowerVX_n_vr_acc (j,i_cwd ,i) = 0._r8 + lowerVX_n_vr_acc (j,i_soil1 ,i) = 0._r8 + lowerVX_n_vr_acc (j,i_soil2 ,i) = 0._r8 + lowerVX_n_vr_acc (j,i_soil3 ,i) = 0._r8 + + I_met_c_vr_acc(j,i) = 0._r8 + I_cel_c_vr_acc(j,i) = 0._r8 + I_lig_c_vr_acc(j,i) = 0._r8 + I_cwd_c_vr_acc(j,i) = 0._r8 + + I_met_n_vr_acc(j,i) = 0._r8 + I_cel_n_vr_acc(j,i) = 0._r8 + I_lig_n_vr_acc(j,i) = 0._r8 + I_cwd_n_vr_acc(j,i) = 0._r8 + ENDDO + ENDIF + + END SUBROUTINE CNSASU + + SUBROUTINE inverse(a,c,n) + + ! !DESCRIPTION: + ! Inverse matrix + ! Method: Based on Doolittle LU factorization for Ax=b + ! Alex G. December 2009 + !----------------------------------------------------------- + ! input ... + ! a(n,n) - array of coefficients for matrix A + ! n - dimension + ! output ... + ! c(n,n) - inverse matrix of A + ! comments ... + ! the original matrix a(n,n) will be destroyed + ! during the calculation + + IMPLICIT NONE + ! Arguments + integer,intent(in) :: n ! Size of matrix + real(r8),intent(in) :: a(:,:) ! Input matrix to fine the inverse of + real(r8),intent(out) :: c(:,:) ! Output inverse + ! Local variables + real(r8) :: L(n,n) ! matrix of the elimination coefficient + real(r8) :: U(n,n) ! Upper triangular part of input matrix A + real(r8) :: aa(n,n) ! Temporary equal to input matrix a + real(r8) :: b(n) ! Temporary vector + real(r8) :: d(n) ! Temporary vector (solution of L*d) + real(r8) :: x(n) ! Temporary vector (U*x = d) + real(r8) :: coeff ! coefficient + integer i, j, k ! Indices + character(len=*), parameter :: subname = 'inverse' + + DO k=1,n + IF ( a(k,k) == 0.0_r8 )THEN + CALL abort + ENDIF + ENDDO + ! + ! step 0: initialization for matrices L and U and b + ! Fortran 90/95 aloows such operations on matrices + ! + L=0.0 + U=0.0 + b=0.0 + + aa=a + ! + ! Step 1: forward elimination + ! + DO k=1, n-1 + DO i=k+1,n + ! Already verifieid that divisor isn't zero + coeff=aa(i,k)/aa(k,k) + L(i,k) = coeff + DO j=k+1,n + aa(i,j) = aa(i,j)-coeff*aa(k,j) + ENDDO + ENDDO + ENDDO + + ! + ! Step 2: prepare L and U matrices + ! L matrix is a matrix of the elimination coefficient + ! + the diagonal elements are 1.0 + ! + DO i=1,n + L(i,i) = 1.0 + ENDDO + ! + ! U matrix is the upper triangular part of A + ! + DO j=1,n + DO i=1,j + U(i,j) = aa(i,j) + ENDDO + ENDDO + ! + ! Step 3: compute columns of the inverse matrix C + ! + DO k=1,n + b(k)=1.0 + d(1) = b(1) + ! Step 3a: Solve Ld=b using the forward substitution + DO i=2,n + d(i)=b(i) + DO j=1,i-1 + d(i) = d(i) - L(i,j)*d(j) + ENDDO + ENDDO + ! Step 3b: Solve Ux=d using the back substitution + x(n)=d(n)/U(n,n) + DO i = n-1,1,-1 + x(i) = d(i) + DO j=n,i+1,-1 + x(i)=x(i)-U(i,j)*x(j) + ENDDO + ! Already verifieid that divisor isn't zero + x(i) = x(i)/u(i,i) + ENDDO + ! Step 3c: fill the solutions x(n) into column k of C + DO i=1,n + c(i,k) = x(i) + ENDDO + b(k)=0.0 + ENDDO + + END SUBROUTINE inverse + +END MODULE MOD_BGC_CNSASU + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 new file mode 100644 index 0000000000..0d612d9eb7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 @@ -0,0 +1,919 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNSummary + +!------------------------------------------------------------------------------------------ +! !DESCRIPTION: +! bgc_CNSummaryMod calculates following statistics: +! 1) total CN fluxes and pool sizes from individual contribution of each pool. +! 2) aggregate the PFT-level fluxes and pool sizes into Column-level fluxes and pool sizes. +! 3) PFT-level leaf pool sizes, GPP and crop production. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_DiagMatrix + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_PFTimeVariables, only:irrig_method_p, lai_p + USE MOD_Vars_TimeInvariants, only: BD_all + USE MOD_BGC_Vars_TimeVariables, only: & + totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_soil,ctrunc_veg, ctrunc_vr, & + totlitn, totsomn, totcwdn, decomp_npools, decomp_npools_vr, ntrunc_soil,ntrunc_veg, ntrunc_vr, & + totvegc, totvegn, totcolc, totcoln, sminn, sminn_vr, totsoiln_vr, & + leafc, frootc, livestemc, deadstemc, livecrootc, deadcrootc, leafc_storage, frootc_storage, livestemc_storage, & + deadstemc_storage, livecrootc_storage, deadcrootc_storage, leafc_xfer, frootc_xfer, livestemc_xfer, & + deadstemc_xfer, livecrootc_xfer, deadcrootc_xfer, xsmrpool, & + leafcCap, frootcCap, livestemcCap, deadstemcCap, livecrootcCap, deadcrootcCap, leafc_storageCap, frootc_storageCap, & + livestemc_storageCap, deadstemc_storageCap, livecrootc_storageCap, deadcrootc_storageCap, leafc_xferCap, & + frootc_xferCap, livestemc_xferCap, deadstemc_xferCap, livecrootc_xferCap, deadcrootc_xferCap, & +#ifdef CROP + grainc, grainc_storage, grainc_xfer, & + cropseedc_deficit, cropprod1c, cphase, hui, vf, gddplant, gddmaturity, & + manunitro, fertnitro_corn, fertnitro_swheat, fertnitro_wwheat, fertnitro_soybean, & + fertnitro_cotton, fertnitro_rice1, fertnitro_rice2, fertnitro_sugarcane, & + grainn, grainn_storage, grainn_xfer, plantdate, & +#endif + leafn, frootn, livestemn, deadstemn, livecrootn, deadcrootn, leafn_storage, frootn_storage, livestemn_storage, & + deadstemn_storage, livecrootn_storage, deadcrootn_storage, leafn_xfer, frootn_xfer, livestemn_xfer, & + deadstemn_xfer, livecrootn_xfer, deadcrootn_xfer, retransn, downreg, lag_npp, & + leafnCap, frootnCap, livestemnCap, deadstemnCap, livecrootnCap, deadcrootnCap, leafn_storageCap, frootn_storageCap, & + livestemn_storageCap, deadstemn_storageCap, livecrootn_storageCap, deadcrootn_storageCap, leafn_xferCap, & + frootn_xferCap, livestemn_xferCap, deadstemn_xferCap, livecrootn_xferCap, deadcrootn_xferCap + USE MOD_BGC_Vars_TimeInvariants, only: & + is_litter, is_soil, is_cwd, nfix_timeconst + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p, frootc_p, livestemc_p, deadstemc_p, livecrootc_p, deadcrootc_p, & + leafc_storage_p, frootc_storage_p, livestemc_storage_p, & + deadstemc_storage_p, livecrootc_storage_p, deadcrootc_storage_p, gresp_storage_p, & + leafc_xfer_p, frootc_xfer_p, livestemc_xfer_p, & + deadstemc_xfer_p, livecrootc_xfer_p, deadcrootc_xfer_p, gresp_xfer_p, xsmrpool_p, & + leafcCap_p, frootcCap_p, livestemcCap_p, deadstemcCap_p, livecrootcCap_p, deadcrootcCap_p, & + leafc_storageCap_p, frootc_storageCap_p, livestemc_storageCap_p, & + deadstemc_storageCap_p, livecrootc_storageCap_p, deadcrootc_storageCap_p, & + leafc_xferCap_p, frootc_xferCap_p, livestemc_xferCap_p, & + deadstemc_xferCap_p, livecrootc_xferCap_p, deadcrootc_xferCap_p, & +#ifdef CROP + grainc_p, grainc_storage_p, grainc_xfer_p, & +#endif + ctrunc_p, totvegc_p, & + cropseedc_deficit_p, cropprod1c_p, cpool_p, & +#ifdef CROP + plantdate_p, cphase_p, manunitro_p, fertnitro_p, hui_p, gddmaturity_p, gddplant_p, vf_p, & + grainn_p, grainn_storage_p, grainn_xfer_p, cropseedn_deficit_p, & +#endif + leafn_p, frootn_p, livestemn_p, deadstemn_p, livecrootn_p, deadcrootn_p, & + leafn_storage_p, frootn_storage_p, livestemn_storage_p, & + deadstemn_storage_p, livecrootn_storage_p, deadcrootn_storage_p, & + leafn_xfer_p, frootn_xfer_p, livestemn_xfer_p, & + deadstemn_xfer_p, livecrootn_xfer_p, deadcrootn_xfer_p, retransn_p, npool_p, & + leafnCap_p, frootnCap_p, livestemnCap_p, deadstemnCap_p, livecrootnCap_p, deadcrootnCap_p, & + leafn_storageCap_p, frootn_storageCap_p, livestemn_storageCap_p, & + deadstemn_storageCap_p, livecrootn_storageCap_p, deadcrootn_storageCap_p, & + leafn_xferCap_p, frootn_xferCap_p, livestemn_xferCap_p, & + deadstemn_xferCap_p, livecrootn_xferCap_p, deadcrootn_xferCap_p, & + ntrunc_p, totvegn_p, downreg_p + USE MOD_Vars_PFTimeInvariants, only: pftfrac + USE MOD_BGC_Vars_1DFluxes, only: & + gpp_enftemp, gpp_enfboreal, gpp_dnfboreal, gpp_ebftrop, gpp_ebftemp, gpp_dbftrop, gpp_dbftemp, & + gpp_dbfboreal, gpp_ebstemp, gpp_dbstemp, gpp_dbsboreal, gpp_c3arcgrass, gpp_c3grass, gpp_c4grass, & + leafc_enftemp, leafc_enfboreal, leafc_dnfboreal, leafc_ebftrop, leafc_ebftemp, leafc_dbftrop, leafc_dbftemp, & + leafc_dbfboreal, leafc_ebstemp, leafc_dbstemp, leafc_dbsboreal, leafc_c3arcgrass, leafc_c3grass, leafc_c4grass, & + decomp_hr, decomp_hr_vr, gpp, ar, er, supplement_to_sminn, supplement_to_sminn_vr, & + npp_enftemp, npp_enfboreal, npp_dnfboreal, npp_ebftrop, npp_ebftemp, npp_dbftrop, npp_dbftemp, & + npp_dbfboreal, npp_ebstemp, npp_dbstemp, npp_dbsboreal, npp_c3arcgrass, npp_c3grass, npp_c4grass, & + npptoleafc_enftemp, npptoleafc_enfboreal, npptoleafc_dnfboreal, npptoleafc_ebftrop, & + npptoleafc_ebftemp, npptoleafc_dbftrop, npptoleafc_dbftemp, npptoleafc_dbfboreal, npptoleafc_ebstemp, & + npptoleafc_dbstemp, npptoleafc_dbsboreal, npptoleafc_c3arcgrass, npptoleafc_c3grass, npptoleafc_c4grass, & +#ifdef CROP + cropprod1c_loss, grainc_to_cropprodc, grainc_to_seed, grainn_to_cropprodn, & +#endif + sminn_leached, sminn_leached_vr, smin_no3_leached, smin_no3_leached_vr, smin_no3_runoff, smin_no3_runoff_vr, & + f_n2o_nit, f_n2o_nit_vr, decomp_cpools_transport_tendency, decomp_npools_transport_tendency, & + denit, f_denit_vr, fire_closs, hrv_xsmrpool_to_atm, som_c_leached, som_n_leached, sminn_to_denit_excess_vr, & + sminn_to_denit_decomp_vr + USE MOD_BGC_Vars_1DPFTFluxes, only: & + psn_to_cpool_p, leaf_mr_p, froot_mr_p, livestem_mr_p, livecroot_mr_p, & + cpool_leaf_gr_p, cpool_froot_gr_p, cpool_livestem_gr_p, cpool_deadstem_gr_p, & + cpool_livecroot_gr_p, cpool_deadcroot_gr_p, transfer_leaf_gr_p, transfer_froot_gr_p, & + transfer_livestem_gr_p, transfer_deadstem_gr_p, & + transfer_livecroot_gr_p, transfer_deadcroot_gr_p, & + cpool_leaf_storage_gr_p, cpool_froot_storage_gr_p, & + cpool_livestem_storage_gr_p, cpool_deadstem_storage_gr_p, & + cpool_livecroot_storage_gr_p, cpool_deadcroot_storage_gr_p, & + grain_mr_p, xsmrpool_to_atm_p, cpool_grain_gr_p, & + transfer_grain_gr_p, cpool_grain_storage_gr_p, soil_change_p, & + fire_closs_p, hrv_xsmrpool_to_atm_p, & + cpool_to_leafc_p, cpool_to_leafc_storage_p, & +#ifdef CROP + cropprod1c_loss_p, grainc_to_seed_p, grainc_to_food_p, grainn_to_food_p, & +#endif + m_leafc_to_fire_p, m_leafc_storage_to_fire_p, m_leafc_xfer_to_fire_p, & + m_frootc_to_fire_p, m_frootc_storage_to_fire_p, m_frootc_xfer_to_fire_p, & + m_livestemc_to_fire_p, m_livestemc_storage_to_fire_p, m_livestemc_xfer_to_fire_p, & + m_deadstemc_to_fire_p, m_deadstemc_storage_to_fire_p, m_deadstemc_xfer_to_fire_p, & + m_livecrootc_to_fire_p, m_livecrootc_storage_to_fire_p, m_livecrootc_xfer_to_fire_p, & + m_deadcrootc_to_fire_p, m_deadcrootc_storage_to_fire_p, m_deadcrootc_xfer_to_fire_p, & + m_gresp_storage_to_fire_p, m_gresp_xfer_to_fire_p + USE MOD_Vars_TimeVariables, only: & + irrig_method_corn , irrig_method_swheat, irrig_method_wwheat, irrig_method_soybean , & + irrig_method_cotton, irrig_method_rice1 , irrig_method_rice2 , irrig_method_sugarcane, & + lai_enftemp, lai_enfboreal, lai_dnfboreal, lai_ebftrop, lai_ebftemp, lai_dbftrop, lai_dbftemp, & + lai_dbfboreal, lai_ebstemp, lai_dbstemp, lai_dbsboreal, lai_c3arcgrass, lai_c3grass, lai_c4grass + + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Vars_Global, only: spval + USE MOD_SPMD_Task + + IMPLICIT NONE + + PUBLIC CNDriverSummarizeStates + PUBLIC CNDriverSummarizeFluxes + + PRIVATE soilbiogeochem_carbonstate_summary + PRIVATE soilbiogeochem_nitrogenstate_summary + PRIVATE cnveg_carbonstate_summary + PRIVATE cnveg_nitrogenstate_summary + PRIVATE soilbiogeochem_carbonflux_summary + PRIVATE soilbiogeochem_nitrogenflux_summary + PRIVATE cnveg_carbonflux_summary + PRIVATE cnveg_nitrogenflux_summary + +CONTAINS + + SUBROUTINE CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools,init) + +! !DESCRIPTION: +! summarizes CN state varaibles for veg and soil. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + integer, intent(in) :: nl_soil ! number of total soil + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools + logical, intent(in) :: init + + CALL soilbiogeochem_carbonstate_summary(i,nl_soil,dz_soi,ndecomp_pools) + CALL soilbiogeochem_nitrogenstate_summary(i,nl_soil,dz_soi,ndecomp_pools) + + CALL cnveg_carbonstate_summary(i,ps,pe,init) + CALL cnveg_nitrogenstate_summary(i,ps,pe) + + END SUBROUTINE CNDriverSummarizeStates + + SUBROUTINE CNDriverSummarizeFluxes(i,ps,pe,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools,deltim) + +! !DESCRIPTION: +! summarizes CN flux varaibles for veg and soil. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + integer, intent(in) :: ndecomp_pools ! number of tootal soil & litter pools + real(r8),intent(in) :: deltim ! time step in seconds + + CALL soilbiogeochem_carbonflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + + CALL soilbiogeochem_nitrogenflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + + CALL cnveg_carbonflux_summary(i,ps,pe,deltim) + + CALL cnveg_nitrogenflux_summary(i,ps,pe) + + END SUBROUTINE CNDriverSummarizeFluxes + + SUBROUTINE soilbiogeochem_carbonstate_summary(i,nl_soil,dz_soi, ndecomp_pools) + +! !DESCRIPTION +! summarizes soil C state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_pools ! number of tootal soil & litter pools + + integer :: l,j + + totsomc(i) = 0._r8 + totlitc(i) = 0._r8 + totcwdc(i) = 0._r8 + ctrunc_soil(i) = 0._r8 + + DO l = 1, ndecomp_pools + decomp_cpools(l,i) = 0._r8 + DO j = 1, nl_soil + decomp_cpools(l,i) = decomp_cpools(l,i) + decomp_cpools_vr(j,l,i) * dz_soi(j) + ENDDO + ENDDO + + DO l = 1, ndecomp_pools + IF(is_litter(l))THEN + totlitc(i) = totlitc(i) + decomp_cpools(l,i) + ENDIF + IF(is_soil(l))THEN + totsomc(i) = totsomc(i) + decomp_cpools(l,i) + ENDIF + IF(is_cwd(l))THEN + totcwdc(i) = totcwdc(i) + decomp_cpools(l,i) + ENDIF + ENDDO + + DO j = 1, nl_soil + ctrunc_soil(i) = ctrunc_soil(i) + ctrunc_vr(j,i) * dz_soi(j) + ENDDO + + END SUBROUTINE soilbiogeochem_carbonstate_summary + + SUBROUTINE soilbiogeochem_nitrogenstate_summary(i,nl_soil,dz_soi,ndecomp_pools) + +! !DESCRIPTION +! summarizes soil N state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_pools ! number of tootal soil & litter pools + + integer :: l,j + + totsomn(i) = 0._r8 + totlitn(i) = 0._r8 + totcwdn(i) = 0._r8 + sminn(i) = 0._r8 + ntrunc_soil(i) = 0._r8 + totsoiln_vr(1:nl_soil,i) = 0 ! soil total nitrogen (gN/gsoil * 100%) + + DO l = 1, ndecomp_pools + decomp_npools(l,i) = 0._r8 + DO j = 1, nl_soil + decomp_npools(l,i) = decomp_npools(l,i) + decomp_npools_vr(j,l,i) * dz_soi(j) + totsoiln_vr(j,i) = totsoiln_vr(j,i) + decomp_npools_vr(j,l,i) / (BD_all(j,i) * 1000) * 100 !(unit %) + ENDDO + ENDDO + + DO j = 1, nl_soil + sminn(i) = sminn(i) + sminn_vr(j,i) * dz_soi(j) + totsoiln_vr(j,i) = totsoiln_vr(j,i) + sminn_vr(j,i) / (BD_all(j,i) * 1000) * 100 !(unit %) + ENDDO + + DO l = 1, ndecomp_pools + IF(is_litter(l))THEN + totlitn(i) = totlitn(i) + decomp_npools(l,i) + ENDIF + IF(is_soil(l))THEN + totsomn(i) = totsomn(i) + decomp_npools(l,i) + ENDIF + IF(is_cwd(l))THEN + totcwdn(i) = totcwdn(i) + decomp_npools(l,i) + ENDIF + ENDDO + + DO j = 1, nl_soil + ntrunc_soil(i) = ntrunc_soil(i) + ntrunc_vr(j,i) * dz_soi(j) + ENDDO + + END SUBROUTINE soilbiogeochem_nitrogenstate_summary + + SUBROUTINE cnveg_carbonstate_summary(i,ps,pe,init) + +! !DESCRIPTION +! summarizes vegetation C state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + logical, intent(in) :: init + + integer m + + leafc(i) = sum(leafc_p(ps:pe) * pftfrac(ps:pe)) + leafc_storage(i) = sum(leafc_storage_p(ps:pe) * pftfrac(ps:pe)) + leafc_xfer(i) = sum(leafc_xfer_p(ps:pe) * pftfrac(ps:pe)) + frootc(i) = sum(frootc_p(ps:pe) * pftfrac(ps:pe)) + frootc_storage(i) = sum(frootc_storage_p(ps:pe) * pftfrac(ps:pe)) + frootc_xfer(i) = sum(frootc_xfer_p(ps:pe) * pftfrac(ps:pe)) + livestemc(i) = sum(livestemc_p(ps:pe) * pftfrac(ps:pe)) + livestemc_storage(i) = sum(livestemc_storage_p(ps:pe) * pftfrac(ps:pe)) + livestemc_xfer(i) = sum(livestemc_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadstemc(i) = sum(deadstemc_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_storage(i) = sum(deadstemc_storage_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_xfer(i) = sum(deadstemc_xfer_p(ps:pe) * pftfrac(ps:pe)) + livecrootc(i) = sum(livecrootc_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_storage(i) = sum(livecrootc_storage_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_xfer(i) = sum(livecrootc_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc(i) = sum(deadcrootc_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_storage(i) = sum(deadcrootc_storage_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_xfer(i) = sum(deadcrootc_xfer_p(ps:pe) * pftfrac(ps:pe)) + xsmrpool(i) = sum(xsmrpool_p(ps:pe) * pftfrac(ps:pe)) +#ifdef CROP + grainc(i) = sum(grainc_p(ps:pe) * pftfrac(ps:pe)) + grainc_storage(i) = sum(grainc_storage_p(ps:pe) * pftfrac(ps:pe)) + grainc_xfer(i) = sum(grainc_xfer_p(ps:pe) * pftfrac(ps:pe)) + cropseedc_deficit(i) = sum(cropseedc_deficit_p(ps:pe) * pftfrac(ps:pe)) + cropprod1c(i) = sum(cropprod1c_p(ps:pe) * pftfrac(ps:pe)) + cphase(i) = sum(cphase_p(ps:pe) * pftfrac(ps:pe)) + hui(i) = hui_p(ps) + gddplant(i) = sum(gddplant_p(ps:pe) * pftfrac(ps:pe)) + gddmaturity(i) = sum(gddmaturity_p(ps:pe) * pftfrac(ps:pe)) + vf(i) = sum(vf_p(ps:pe) * pftfrac(ps:pe)) + + fertnitro_corn(i) = 0._r8 + fertnitro_swheat(i) = 0._r8 + fertnitro_wwheat(i) = 0._r8 + fertnitro_soybean(i) = 0._r8 + fertnitro_cotton(i) = 0._r8 + fertnitro_rice1(i) = 0._r8 + fertnitro_rice2(i) = 0._r8 + fertnitro_sugarcane(i)= 0._r8 + + manunitro(i) = sum(manunitro_p(ps:pe) * pftfrac(ps:pe)) + +#endif + IF(DEF_USE_DiagMatrix)THEN + leafcCap(i) = sum(leafcCap_p(ps:pe) * pftfrac(ps:pe)) + leafc_storageCap(i) = sum(leafc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + leafc_xferCap(i) = sum(leafc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + frootcCap(i) = sum(frootcCap_p(ps:pe) * pftfrac(ps:pe)) + frootc_storageCap(i) = sum(frootc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + frootc_xferCap(i) = sum(frootc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livestemcCap(i) = sum(livestemcCap_p(ps:pe) * pftfrac(ps:pe)) + livestemc_storageCap(i) = sum(livestemc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livestemc_xferCap(i) = sum(livestemc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemcCap(i) = sum(deadstemcCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_storageCap(i) = sum(deadstemc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_xferCap(i) = sum(deadstemc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootcCap(i) = sum(livecrootcCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_storageCap(i) = sum(livecrootc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_xferCap(i) = sum(livecrootc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootcCap(i) = sum(deadcrootcCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_storageCap(i) = sum(deadcrootc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_xferCap(i) = sum(deadcrootc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + ENDIF + DO m = ps, pe + totvegc_p(m) = leafc_p(m) + frootc_p(m) + livestemc_p(m) & + + deadstemc_p(m) + livecrootc_p(m) + deadcrootc_p(m) & + + leafc_storage_p(m) + frootc_storage_p(m) + livestemc_storage_p(m) & + + deadstemc_storage_p(m) + livecrootc_storage_p(m) + deadcrootc_storage_p(m) & + + leafc_xfer_p(m) + frootc_xfer_p(m) + livestemc_xfer_p(m) & + + deadstemc_xfer_p(m) + livecrootc_xfer_p(m) + deadcrootc_xfer_p(m) & +#ifdef CROP + + grainc_p(m) + grainc_storage_p(m) + grainc_xfer_p(m) & + + cropseedc_deficit_p(m) & +#endif + + gresp_storage_p(m) + gresp_xfer_p(m) + xsmrpool_p(m) + cpool_p(m) + +#ifdef CROP + IF( pftclass(m) .eq. 17 .or. pftclass(m) .eq. 18 .or. pftclass(m) .eq. 63 .or. pftclass(m) .eq. 64)THEN + fertnitro_corn (i) = fertnitro_p (m) + irrig_method_corn (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 19 .or. pftclass(m) .eq. 20)THEN + fertnitro_swheat (i) = fertnitro_p (m) + irrig_method_swheat(i) = irrig_method_p (m) + ELSE IF(pftclass(m) .eq. 21 .or. pftclass(m) .eq. 22)THEN + fertnitro_wwheat (i) = fertnitro_p (m) + irrig_method_wwheat (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 23 .or. pftclass(m) .eq. 24 .or. pftclass(m) .eq. 77 .or. pftclass(m) .eq. 78)THEN + fertnitro_soybean (i) = fertnitro_p (m) + irrig_method_soybean (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 41 .or. pftclass(m) .eq. 42)THEN + fertnitro_cotton (i) = fertnitro_p (m) + irrig_method_cotton (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 61 .or. pftclass(m) .eq. 62)THEN + fertnitro_rice1 (i) = fertnitro_p (m) + fertnitro_rice2 (i) = fertnitro_p (m) + irrig_method_rice1 (i) = irrig_method_p(m) + irrig_method_rice2 (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 67 .or. pftclass(m) .eq. 68)THEN + fertnitro_sugarcane (i) = fertnitro_p (m) + irrig_method_sugarcane(i) = irrig_method_p(m) + ENDIF +#endif + ENDDO + + IF(.not. init)THEN + leafc_enftemp (i) = 0._r8 + leafc_enfboreal (i) = 0._r8 + leafc_dnfboreal (i) = 0._r8 + leafc_ebftrop (i) = 0._r8 + leafc_ebftemp (i) = 0._r8 + leafc_dbftrop (i) = 0._r8 + leafc_dbftemp (i) = 0._r8 + leafc_dbfboreal (i) = 0._r8 + leafc_ebstemp (i) = 0._r8 + leafc_dbstemp (i) = 0._r8 + leafc_dbsboreal (i) = 0._r8 + leafc_c3arcgrass (i) = 0._r8 + leafc_c3grass (i) = 0._r8 + leafc_c4grass (i) = 0._r8 + lai_enftemp (i) = 0._r8 + lai_enfboreal (i) = 0._r8 + lai_dnfboreal (i) = 0._r8 + lai_ebftrop (i) = 0._r8 + lai_ebftemp (i) = 0._r8 + lai_dbftrop (i) = 0._r8 + lai_dbftemp (i) = 0._r8 + lai_dbfboreal (i) = 0._r8 + lai_ebstemp (i) = 0._r8 + lai_dbstemp (i) = 0._r8 + lai_dbsboreal (i) = 0._r8 + lai_c3arcgrass (i) = 0._r8 + lai_c3grass (i) = 0._r8 + lai_c4grass (i) = 0._r8 + DO m = ps, pe + IF(pftclass (m) .eq. 1)THEN + leafc_enftemp (i) = leafc_p(m) + lai_enftemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 2)THEN + leafc_enfboreal (i) = leafc_p(m) + lai_enfboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 3)THEN + leafc_dnfboreal (i) = leafc_p(m) + lai_dnfboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 4)THEN + leafc_ebftrop (i) = leafc_p(m) + lai_ebftrop (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 5)THEN + leafc_ebftemp (i) = leafc_p(m) + lai_ebftemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 6)THEN + leafc_dbftrop (i) = leafc_p(m) + lai_dbftrop (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 7)THEN + leafc_dbftemp (i) = leafc_p(m) + lai_dbftemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 8)THEN + leafc_dbfboreal (i) = leafc_p(m) + lai_dbfboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 9)THEN + leafc_ebstemp (i) = leafc_p(m) + lai_ebstemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 10)THEN + leafc_dbstemp (i) = leafc_p(m) + lai_dbstemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 11)THEN + leafc_dbsboreal (i) = leafc_p(m) + lai_dbsboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 12)THEN + leafc_c3arcgrass(i)= leafc_p(m) + lai_c3arcgrass (i)= lai_p(m) + ELSE IF(pftclass (m) .eq. 13)THEN + leafc_c3grass (i) = leafc_p(m) + lai_c3grass (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 14)THEN + leafc_c4grass (i) = leafc_p(m) + lai_c4grass (i) = lai_p(m) + ENDIF + ENDDO + ENDIF + totvegc(i) = sum(totvegc_p(ps:pe)*pftfrac(ps:pe)) + ctrunc_veg(i) = sum(ctrunc_p(ps:pe) *pftfrac(ps:pe)) + totcolc(i) = totvegc(i) + totcwdc(i) + totlitc(i) + totsomc(i) + ctrunc_veg(i) +ctrunc_soil(i) + + + END SUBROUTINE cnveg_carbonstate_summary + + SUBROUTINE cnveg_nitrogenstate_summary(i,ps,pe) + +! !DESCRIPTION +! summarizes vegetation N state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + + integer m + + leafn(i) = sum(leafn_p(ps:pe) * pftfrac(ps:pe)) + leafn_storage(i) = sum(leafn_storage_p(ps:pe) * pftfrac(ps:pe)) + leafn_xfer(i) = sum(leafn_xfer_p(ps:pe) * pftfrac(ps:pe)) + frootn(i) = sum(frootn_p(ps:pe) * pftfrac(ps:pe)) + frootn_storage(i) = sum(frootn_storage_p(ps:pe) * pftfrac(ps:pe)) + frootn_xfer(i) = sum(frootn_xfer_p(ps:pe) * pftfrac(ps:pe)) + livestemn(i) = sum(livestemn_p(ps:pe) * pftfrac(ps:pe)) + livestemn_storage(i) = sum(livestemn_storage_p(ps:pe) * pftfrac(ps:pe)) + livestemn_xfer(i) = sum(livestemn_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadstemn(i) = sum(deadstemn_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_storage(i) = sum(deadstemn_storage_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_xfer(i) = sum(deadstemn_xfer_p(ps:pe) * pftfrac(ps:pe)) + livecrootn(i) = sum(livecrootn_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_storage(i) = sum(livecrootn_storage_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_xfer(i) = sum(livecrootn_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn(i) = sum(deadcrootn_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_storage(i) = sum(deadcrootn_storage_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_xfer(i) = sum(deadcrootn_xfer_p(ps:pe) * pftfrac(ps:pe)) +#ifdef CROP + grainn(i) = sum(grainn_p(ps:pe) * pftfrac(ps:pe)) + grainn_storage(i) = sum(grainn_storage_p(ps:pe) * pftfrac(ps:pe)) + grainn_xfer(i) = sum(grainn_xfer_p(ps:pe) * pftfrac(ps:pe)) +#endif + retransn(i) = sum(retransn_p(ps:pe) * pftfrac(ps:pe)) + + IF(DEF_USE_DiagMatrix)THEN + leafnCap(i) = sum(leafnCap_p(ps:pe) * pftfrac(ps:pe)) + leafn_storageCap(i) = sum(leafn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + leafn_xferCap(i) = sum(leafn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + frootnCap(i) = sum(frootnCap_p(ps:pe) * pftfrac(ps:pe)) + frootn_storageCap(i) = sum(frootn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + frootn_xferCap(i) = sum(frootn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livestemnCap(i) = sum(livestemnCap_p(ps:pe) * pftfrac(ps:pe)) + livestemn_storageCap(i) = sum(livestemn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livestemn_xferCap(i) = sum(livestemn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemnCap(i) = sum(deadstemnCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_storageCap(i) = sum(deadstemn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_xferCap(i) = sum(deadstemn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootnCap(i) = sum(livecrootnCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_storageCap(i) = sum(livecrootn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_xferCap(i) = sum(livecrootn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootnCap(i) = sum(deadcrootnCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_storageCap(i) = sum(deadcrootn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_xferCap(i) = sum(deadcrootn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + ENDIF + DO m = ps, pe + totvegn_p(m) = leafn_p(m) + frootn_p(m) + livestemn_p(m) & + + deadstemn_p(m) + livecrootn_p(m) + deadcrootn_p(m) & + + leafn_storage_p(m) + frootn_storage_p(m) + livestemn_storage_p(m) & + + deadstemn_storage_p(m) + livecrootn_storage_p(m) + deadcrootn_storage_p(m) & + + leafn_xfer_p(m) + frootn_xfer_p(m) + livestemn_xfer_p(m) & + + deadstemn_xfer_p(m) + livecrootn_xfer_p(m) + deadcrootn_xfer_p(m) & +#ifdef CROP + + grainn_p(m) + grainn_storage_p(m) + grainn_xfer_p(m) & + + cropseedn_deficit_p(m) & +#endif + + npool_p(m) + retransn_p(m) + ENDDO + + totvegn(i) = sum(totvegn_p(ps:pe)*pftfrac(ps:pe)) + ntrunc_veg(i) = sum(ntrunc_p(ps:pe) *pftfrac(ps:pe)) + totcoln(i) = totvegn(i) + totcwdn(i) + totlitn(i) + totsomn(i) + sminn(i) + ntrunc_veg(i) + ntrunc_soil(i) + + END SUBROUTINE cnveg_nitrogenstate_summary + + SUBROUTINE soilbiogeochem_carbonflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + +! !DESCRIPTION +! summarizes soil C flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + + integer k,j,l + + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + decomp_hr(i) = decomp_hr(i) & + + decomp_hr_vr(j,k,i) * dz_soi(j) + ENDDO + ENDDO + + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + som_c_leached(i) = som_c_leached(i) + decomp_cpools_transport_tendency(j,l,i) * dz_soi(j) + ENDDO + ENDDO + + + END SUBROUTINE soilbiogeochem_carbonflux_summary + + SUBROUTINE soilbiogeochem_nitrogenflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + +! !DESCRIPTION +! summarizes soil N flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + + integer j,l,k + + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + som_n_leached(i) = som_n_leached(i) + decomp_npools_transport_tendency(j,l,i) * dz_soi(j) + ENDDO + ENDDO + + DO j = 1, nl_soil + supplement_to_sminn(i) = supplement_to_sminn(i) + supplement_to_sminn_vr(j,i) * dz_soi(j) + smin_no3_leached(i) = smin_no3_leached(i) + smin_no3_leached_vr(j,i) * dz_soi(j) + smin_no3_runoff(i) = smin_no3_runoff(i) + smin_no3_runoff_vr(j,i) * dz_soi(j) + sminn_leached(i) = sminn_leached(i) + sminn_leached_vr(j,i) * dz_soi(j) + f_n2o_nit(i) = f_n2o_nit(i) + f_n2o_nit_vr(j,i) * dz_soi(j) + IF(DEF_USE_NITRIF)THEN + denit(i) = denit(i) + f_denit_vr(j,i) * dz_soi(j) + ELSE + denit(i) = denit(i) + sminn_to_denit_excess_vr(j,i) * dz_soi(j) + ENDIF + + IF(.not. DEF_USE_NITRIF)THEN + DO k = 1, ndecomp_transitions + denit(i) = denit(i) + sminn_to_denit_decomp_vr(j,k,i) * dz_soi(j) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE soilbiogeochem_nitrogenflux_summary + + SUBROUTINE cnveg_carbonflux_summary(i,ps,pe,deltim) + +! !DESCRIPTION +! summarizes vegetationi C flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8) :: ar_p + + integer m + real(r8) nfixlags + + gpp(i) = sum(psn_to_cpool_p(ps:pe) * pftfrac(ps:pe)) + downreg(i) = sum(downreg_p(ps:pe) * pftfrac(ps:pe)) + ar (i) = sum((leaf_mr_p(ps:pe) + froot_mr_p(ps:pe) & + + livestem_mr_p(ps:pe) + livecroot_mr_p(ps:pe) & + + cpool_leaf_gr_p(ps:pe) + cpool_froot_gr_p(ps:pe) & + + cpool_livestem_gr_p(ps:pe) + cpool_deadstem_gr_p(ps:pe) & + + cpool_livecroot_gr_p(ps:pe) + cpool_deadcroot_gr_p(ps:pe) & + + transfer_leaf_gr_p(ps:pe) + transfer_froot_gr_p(ps:pe) & + + transfer_livestem_gr_p(ps:pe) + transfer_deadstem_gr_p(ps:pe) & + + transfer_livecroot_gr_p(ps:pe) + transfer_deadcroot_gr_p(ps:pe) & + + cpool_leaf_storage_gr_p(ps:pe) + cpool_froot_storage_gr_p(ps:pe) & + + cpool_livestem_storage_gr_p(ps:pe) + cpool_deadstem_storage_gr_p(ps:pe) & + + cpool_livecroot_storage_gr_p(ps:pe) + cpool_deadcroot_storage_gr_p(ps:pe) & + + grain_mr_p(ps:pe) + xsmrpool_to_atm_p(ps:pe) & + + cpool_grain_gr_p(ps:pe) + transfer_grain_gr_p(ps:pe) & + + cpool_grain_storage_gr_p(ps:pe)) * pftfrac(ps:pe)) + gpp_enftemp (i) = 0._r8 + gpp_enfboreal (i) = 0._r8 + gpp_dnfboreal (i) = 0._r8 + gpp_ebftrop (i) = 0._r8 + gpp_ebftemp (i) = 0._r8 + gpp_dbftrop (i) = 0._r8 + gpp_dbftemp (i) = 0._r8 + gpp_dbfboreal (i) = 0._r8 + gpp_ebstemp (i) = 0._r8 + gpp_dbstemp (i) = 0._r8 + gpp_dbsboreal (i) = 0._r8 + gpp_c3arcgrass (i) = 0._r8 + gpp_c3grass (i) = 0._r8 + gpp_c4grass (i) = 0._r8 + npp_enftemp (i) = 0._r8 + npp_enfboreal (i) = 0._r8 + npp_dnfboreal (i) = 0._r8 + npp_ebftrop (i) = 0._r8 + npp_ebftemp (i) = 0._r8 + npp_dbftrop (i) = 0._r8 + npp_dbftemp (i) = 0._r8 + npp_dbfboreal (i) = 0._r8 + npp_ebstemp (i) = 0._r8 + npp_dbstemp (i) = 0._r8 + npp_dbsboreal (i) = 0._r8 + npp_c3arcgrass (i) = 0._r8 + npp_c3grass (i) = 0._r8 + npp_c4grass (i) = 0._r8 + npptoleafc_enftemp (i) = 0._r8 + npptoleafc_enfboreal (i) = 0._r8 + npptoleafc_dnfboreal (i) = 0._r8 + npptoleafc_ebftrop (i) = 0._r8 + npptoleafc_ebftemp (i) = 0._r8 + npptoleafc_dbftrop (i) = 0._r8 + npptoleafc_dbftemp (i) = 0._r8 + npptoleafc_dbfboreal (i) = 0._r8 + npptoleafc_ebstemp (i) = 0._r8 + npptoleafc_dbstemp (i) = 0._r8 + npptoleafc_dbsboreal (i) = 0._r8 + npptoleafc_c3arcgrass (i) = 0._r8 + npptoleafc_c3grass (i) = 0._r8 + npptoleafc_c4grass (i) = 0._r8 + DO m = ps, pe + ar_p = (leaf_mr_p(m) + froot_mr_p(m) & + + livestem_mr_p(m) + livecroot_mr_p(m) & + + cpool_leaf_gr_p(m) + cpool_froot_gr_p(m) & + + cpool_livestem_gr_p(m) + cpool_deadstem_gr_p(m) & + + cpool_livecroot_gr_p(m) + cpool_deadcroot_gr_p(m) & + + transfer_leaf_gr_p(m) + transfer_froot_gr_p(m) & + + transfer_livestem_gr_p(m) + transfer_deadstem_gr_p(m) & + + transfer_livecroot_gr_p(m) + transfer_deadcroot_gr_p(m) & + + cpool_leaf_storage_gr_p(m) + cpool_froot_storage_gr_p(m) & + + cpool_livestem_storage_gr_p(m) + cpool_deadstem_storage_gr_p(m) & + + cpool_livecroot_storage_gr_p(m) + cpool_deadcroot_storage_gr_p(m) & + + grain_mr_p(m) + xsmrpool_to_atm_p(m) & + + cpool_grain_gr_p(m) + transfer_grain_gr_p(m) & + + cpool_grain_storage_gr_p(m)) + IF(pftclass (m) .eq. 1)THEN + gpp_enftemp (i) = psn_to_cpool_p(m) + npp_enftemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_enftemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 2)THEN + gpp_enfboreal (i) = psn_to_cpool_p(m) + npp_enfboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_enfboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 3)THEN + gpp_dnfboreal (i) = psn_to_cpool_p(m) + npp_dnfboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dnfboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 4)THEN + gpp_ebftrop (i) = psn_to_cpool_p(m) + npp_ebftrop (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_ebftrop (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 5)THEN + gpp_ebftemp (i) = psn_to_cpool_p(m) + npp_ebftemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_ebftemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 6)THEN + gpp_dbftrop (i) = psn_to_cpool_p(m) + npp_dbftrop (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbftrop (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 7)THEN + gpp_dbftemp (i) = psn_to_cpool_p(m) + npp_dbftemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbftemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 8)THEN + gpp_dbfboreal (i) = psn_to_cpool_p(m) + npp_dbfboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbfboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 9)THEN + gpp_ebstemp (i) = psn_to_cpool_p(m) + npp_ebstemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_ebstemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 10)THEN + gpp_dbstemp (i) = psn_to_cpool_p(m) + npp_dbstemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbstemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 11)THEN + gpp_dbsboreal (i) = psn_to_cpool_p(m) + npp_dbsboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbsboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 12)THEN + gpp_c3arcgrass (i) = psn_to_cpool_p(m) + npp_c3arcgrass (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_c3arcgrass(i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 13)THEN + gpp_c3grass (i) = psn_to_cpool_p(m) + npp_c3grass (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_c3grass (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 14)THEN + gpp_c4grass (i) = psn_to_cpool_p(m) + npp_c4grass (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_c4grass (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ENDIF + ENDDO + + +#ifdef FUN + ar(i) = ar(i) + sum(soil_change_p(ps:pe) * pftfrac(ps:pe)) +#endif + er(i) = ar(i) + decomp_hr(i) +#ifdef CROP + IF(patchclass(i) .eq. 12)THEN + IF(ps .ne. pe)THEN + write(*,*) 'Error: crop patch CONTAINS multiple pfts:',p_iam_glb,'i=',i,'ps',ps,'does not equal to pe',pe + CALL abort + ELSE + cropprod1c_loss (i) = cropprod1c_loss_p(ps) + grainc_to_cropprodc (i) = grainc_to_food_p (ps) + grainc_to_seed (i) = grainc_to_seed_p (ps) + plantdate (i) = plantdate_p (ps) + ENDIF + ELSE + cropprod1c_loss (i) = 0._r8 + grainc_to_cropprodc (i) = 0._r8 + grainc_to_seed (i) = 0._r8 + ENDIF +#endif + + !fire module is not activated yet. + DO m = ps, pe + fire_closs_p(m) = m_leafc_to_fire_p(m) & + + m_leafc_storage_to_fire_p(m) & + + m_leafc_xfer_to_fire_p(m) & + + m_frootc_to_fire_p(m) & + + m_frootc_storage_to_fire_p(m) & + + m_frootc_xfer_to_fire_p(m) & + + m_livestemc_to_fire_p(m) & + + m_livestemc_storage_to_fire_p(m) & + + m_livestemc_xfer_to_fire_p(m) & + + m_deadstemc_to_fire_p(m) & + + m_deadstemc_storage_to_fire_p(m) & + + m_deadstemc_xfer_to_fire_p(m) & + + m_livecrootc_to_fire_p(m) & + + m_livecrootc_storage_to_fire_p(m) & + + m_livecrootc_xfer_to_fire_p(m) & + + m_deadcrootc_to_fire_p(m) & + + m_deadcrootc_storage_to_fire_p(m) & + + m_deadcrootc_xfer_to_fire_p(m) & + + m_gresp_storage_to_fire_p(m) & + + m_gresp_xfer_to_fire_p(m) + ENDDO + + fire_closs(i) = sum(fire_closs_p(ps:pe) * pftfrac(ps:pe)) + hrv_xsmrpool_to_atm(i) = sum(hrv_xsmrpool_to_atm_p(ps:pe) * pftfrac(ps:pe)) + + nfixlags = nfix_timeconst * 86400._r8 + IF(lag_npp(i) /= spval)THEN + lag_npp(i) = lag_npp(i) * exp(-deltim/nfixlags) + & + (gpp(i) - ar(i)) * (1._r8 - exp(-deltim/nfixlags)) + ELSE + lag_npp(i) = gpp(i) - ar(i) + ENDIF + + END SUBROUTINE cnveg_carbonflux_summary + + SUBROUTINE cnveg_nitrogenflux_summary(i,ps,pe) + +! !DESCRIPTION +! summarizes vegetationi N flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + +#ifdef CROP + IF(patchclass(i) .eq. 12)THEN + IF(ps .ne. pe)THEN + write(*,*) 'Error: crop patch contains multiple pfts:',p_iam_glb,'i=',i,'ps',ps,'does not equal to pe',pe + CALL abort + ELSE + grainn_to_cropprodn (i) = grainn_to_food_p (ps) + ENDIF + ELSE + grainn_to_cropprodn (i) = 0._r8 + ENDIF +#endif + END SUBROUTINE cnveg_nitrogenflux_summary + +END MODULE MOD_BGC_CNSummary + + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 new file mode 100644 index 0000000000..a56282a884 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 @@ -0,0 +1,838 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNZeroFluxes + +!---------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE reset flux variable to 0 at begining of each time step to avoid miscalculating from last step. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + m_leafc_to_litter_p , & + m_frootc_to_litter_p , & + m_leafc_storage_to_litter_p , & + m_frootc_storage_to_litter_p , & + m_livestemc_storage_to_litter_p , & + m_deadstemc_storage_to_litter_p , & + m_livecrootc_storage_to_litter_p , & + m_deadcrootc_storage_to_litter_p , & + m_leafc_xfer_to_litter_p , & + m_frootc_xfer_to_litter_p , & + m_livestemc_xfer_to_litter_p , & + m_deadstemc_xfer_to_litter_p , & + m_livecrootc_xfer_to_litter_p , & + m_deadcrootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , & + m_deadstemc_to_litter_p , & + m_livecrootc_to_litter_p , & + m_deadcrootc_to_litter_p , & + m_gresp_storage_to_litter_p , & + m_gresp_xfer_to_litter_p , & + m_leafc_to_fire_p , & + m_leafc_storage_to_fire_p , & + m_leafc_xfer_to_fire_p , & + m_livestemc_to_fire_p , & + m_livestemc_storage_to_fire_p , & + m_livestemc_xfer_to_fire_p , & + m_deadstemc_to_fire_p , & + m_deadstemc_storage_to_fire_p , & + m_deadstemc_xfer_to_fire_p , & + m_frootc_to_fire_p , & + m_frootc_storage_to_fire_p , & + m_frootc_xfer_to_fire_p , & + m_livecrootc_to_fire_p , & + m_livecrootc_storage_to_fire_p , & + m_livecrootc_xfer_to_fire_p , & + m_deadcrootc_to_fire_p , & + m_deadcrootc_storage_to_fire_p , & + m_deadcrootc_xfer_to_fire_p , & + m_gresp_storage_to_fire_p , & + m_gresp_xfer_to_fire_p , & + + m_leafc_to_litter_fire_p , & + m_leafc_storage_to_litter_fire_p , & + m_leafc_xfer_to_litter_fire_p , & + m_livestemc_to_litter_fire_p , & + m_livestemc_storage_to_litter_fire_p , & + m_livestemc_xfer_to_litter_fire_p , & + m_livestemc_to_deadstemc_fire_p , & + m_deadstemc_to_litter_fire_p , & + m_deadstemc_storage_to_litter_fire_p , & + m_deadstemc_xfer_to_litter_fire_p , & + m_frootc_to_litter_fire_p , & + m_frootc_storage_to_litter_fire_p , & + m_frootc_xfer_to_litter_fire_p , & + m_livecrootc_to_litter_fire_p , & + m_livecrootc_storage_to_litter_fire_p, & + m_livecrootc_xfer_to_litter_fire_p , & + m_livecrootc_to_deadcrootc_fire_p , & + m_deadcrootc_to_litter_fire_p , & + m_deadcrootc_storage_to_litter_fire_p, & + m_deadcrootc_xfer_to_litter_fire_p , & + m_gresp_storage_to_litter_fire_p , & + m_gresp_xfer_to_litter_fire_p , & + + leafc_xfer_to_leafc_p , & + frootc_xfer_to_frootc_p , & + livestemc_xfer_to_livestemc_p , & + deadstemc_xfer_to_deadstemc_p , & + livecrootc_xfer_to_livecrootc_p , & + deadcrootc_xfer_to_deadcrootc_p , & + leafc_to_litter_p , & + frootc_to_litter_p , & + + leaf_mr_p , & + froot_mr_p , & + livestem_mr_p , & + livecroot_mr_p , & + grain_mr_p , & + leaf_curmr_p , & + froot_curmr_p , & + livestem_curmr_p , & + livecroot_curmr_p , & + grain_curmr_p , & + leaf_xsmr_p , & + froot_xsmr_p , & + livestem_xsmr_p , & + livecroot_xsmr_p , & + grain_xsmr_p , & + psn_to_cpool_p , & + cpool_to_xsmrpool_p , & + cpool_to_leafc_p , & + cpool_to_leafc_storage_p , & + cpool_to_frootc_p , & + cpool_to_frootc_storage_p , & + cpool_to_livestemc_p , & + cpool_to_livestemc_storage_p , & + cpool_to_deadstemc_p , & + cpool_to_deadstemc_storage_p , & + cpool_to_livecrootc_p , & + cpool_to_livecrootc_storage_p , & + cpool_to_deadcrootc_p , & + cpool_to_deadcrootc_storage_p , & + cpool_to_gresp_storage_p , & + cpool_leaf_gr_p , & + cpool_leaf_storage_gr_p , & + transfer_leaf_gr_p , & + cpool_froot_gr_p , & + cpool_froot_storage_gr_p , & + transfer_froot_gr_p , & + cpool_livestem_gr_p , & + cpool_livestem_storage_gr_p , & + transfer_livestem_gr_p , & + cpool_deadstem_gr_p , & + cpool_deadstem_storage_gr_p , & + transfer_deadstem_gr_p , & + cpool_livecroot_gr_p , & + cpool_livecroot_storage_gr_p , & + transfer_livecroot_gr_p , & + cpool_deadcroot_gr_p , & + cpool_deadcroot_storage_gr_p , & + transfer_deadcroot_gr_p , & + leafc_storage_to_xfer_p , & + frootc_storage_to_xfer_p , & + livestemc_storage_to_xfer_p , & + deadstemc_storage_to_xfer_p , & + livecrootc_storage_to_xfer_p , & + deadcrootc_storage_to_xfer_p , & + gresp_storage_to_xfer_p , & + livestemc_to_deadstemc_p , & + livecrootc_to_deadcrootc_p , & + crop_seedc_to_leaf_p , & + + hrv_xsmrpool_to_atm_p , & + + xsmrpool_to_atm_p , & + livestemc_to_litter_p , & + grainc_to_food_p , & + grainc_to_seed_p , & + grainc_xfer_to_grainc_p , & + cpool_to_grainc_p , & + cpool_to_grainc_storage_p , & + cpool_grain_gr_p , & + cpool_grain_storage_gr_p , & + transfer_grain_gr_p , & + grainc_storage_to_xfer_p , & + + gpp_p, & + + m_leafn_to_litter_p , & + m_frootn_to_litter_p , & + m_leafn_storage_to_litter_p , & + m_frootn_storage_to_litter_p , & + m_livestemn_storage_to_litter_p , & + m_deadstemn_storage_to_litter_p , & + m_livecrootn_storage_to_litter_p , & + m_deadcrootn_storage_to_litter_p , & + m_leafn_xfer_to_litter_p , & + m_frootn_xfer_to_litter_p , & + m_livestemn_xfer_to_litter_p , & + m_deadstemn_xfer_to_litter_p , & + m_livecrootn_xfer_to_litter_p , & + m_deadcrootn_xfer_to_litter_p , & + m_livestemn_to_litter_p , & + m_deadstemn_to_litter_p , & + m_livecrootn_to_litter_p , & + m_deadcrootn_to_litter_p , & + m_retransn_to_litter_p , & + + m_leafn_to_fire_p , & + m_leafn_storage_to_fire_p , & + m_leafn_xfer_to_fire_p , & + m_livestemn_to_fire_p , & + m_livestemn_storage_to_fire_p , & + m_livestemn_xfer_to_fire_p , & + m_deadstemn_to_fire_p , & + m_deadstemn_storage_to_fire_p , & + m_deadstemn_xfer_to_fire_p , & + m_frootn_to_fire_p , & + m_frootn_storage_to_fire_p , & + m_frootn_xfer_to_fire_p , & + m_livecrootn_to_fire_p , & + m_livecrootn_storage_to_fire_p , & + m_livecrootn_xfer_to_fire_p , & + m_deadcrootn_to_fire_p , & + m_deadcrootn_storage_to_fire_p , & + m_deadcrootn_xfer_to_fire_p , & + m_retransn_to_fire_p , & + + m_leafn_to_litter_fire_p , & + m_leafn_storage_to_litter_fire_p , & + m_leafn_xfer_to_litter_fire_p , & + m_livestemn_to_litter_fire_p , & + m_livestemn_storage_to_litter_fire_p , & + m_livestemn_xfer_to_litter_fire_p , & + m_livestemn_to_deadstemn_fire_p , & + m_deadstemn_to_litter_fire_p , & + m_deadstemn_storage_to_litter_fire_p , & + m_deadstemn_xfer_to_litter_fire_p , & + m_frootn_to_litter_fire_p , & + m_frootn_storage_to_litter_fire_p , & + m_frootn_xfer_to_litter_fire_p , & + m_livecrootn_to_litter_fire_p , & + m_livecrootn_storage_to_litter_fire_p, & + m_livecrootn_xfer_to_litter_fire_p , & + m_livecrootn_to_deadcrootn_fire_p , & + m_deadcrootn_to_litter_fire_p , & + m_deadcrootn_storage_to_litter_fire_p, & + m_deadcrootn_xfer_to_litter_fire_p , & + m_retransn_to_litter_fire_p , & + + leafn_xfer_to_leafn_p , & + frootn_xfer_to_frootn_p , & + livestemn_xfer_to_livestemn_p , & + deadstemn_xfer_to_deadstemn_p , & + livecrootn_xfer_to_livecrootn_p , & + deadcrootn_xfer_to_deadcrootn_p , & + leafn_to_litter_p , & + leafn_to_retransn_p , & + frootn_to_litter_p , & + retransn_to_npool_p , & + free_retransn_to_npool_p , & + sminn_to_npool_p , & + npool_to_leafn_p , & + npool_to_leafn_storage_p , & + npool_to_frootn_p , & + npool_to_frootn_storage_p , & + npool_to_livestemn_p , & + npool_to_livestemn_storage_p , & + npool_to_deadstemn_p , & + npool_to_deadstemn_storage_p , & + npool_to_livecrootn_p , & + npool_to_livecrootn_storage_p , & + npool_to_deadcrootn_p , & + npool_to_deadcrootn_storage_p , & + leafn_storage_to_xfer_p , & + frootn_storage_to_xfer_p , & + livestemn_storage_to_xfer_p , & + deadstemn_storage_to_xfer_p , & + livecrootn_storage_to_xfer_p , & + deadcrootn_storage_to_xfer_p , & + livestemn_to_deadstemn_p , & + livestemn_to_retransn_p , & + livecrootn_to_deadcrootn_p , & + livecrootn_to_retransn_p , & + + crop_seedn_to_leaf_p , & + + livestemn_to_litter_p , & + grainn_to_food_p , & + grainn_to_seed_p , & + grainn_xfer_to_grainn_p , & + npool_to_grainn_p , & + npool_to_grainn_storage_p , & + grainn_storage_to_xfer_p , & + frootn_to_retransn_p , & + + fire_closs_p , & + fire_nloss_p , & + wood_harvestc_p , & + wood_harvestn_p , & + grainc_to_cropprodc_p , & + grainn_to_cropprodn_p , & + soyfixn_p + + USE MOD_BGC_Vars_1DFluxes, only: & + + ! phenologgy + phenology_to_met_c , & + phenology_to_cel_c , & + phenology_to_lig_c , & + + ! gap mortality + gap_mortality_to_met_c , & + gap_mortality_to_cel_c , & + gap_mortality_to_lig_c , & + gap_mortality_to_cwdc , & + + ! fire + fire_mortality_to_cwdc , & + fire_mortality_to_met_c , & + fire_mortality_to_cel_c , & + fire_mortality_to_lig_c , & + + m_decomp_cpools_to_fire_vr , & + + ! phenologgy + phenology_to_met_n , & + phenology_to_cel_n , & + phenology_to_lig_n , & + + ! gap mortality + gap_mortality_to_met_n , & + gap_mortality_to_cel_n , & + gap_mortality_to_lig_n , & + gap_mortality_to_cwdn , & + + ! fire + fire_mortality_to_cwdn , & + fire_mortality_to_met_n , & + fire_mortality_to_cel_n , & + fire_mortality_to_lig_n , & + + m_decomp_npools_to_fire_vr , & + + fire_closs , & + fire_nloss , & + wood_harvestc , & + wood_harvestn , & + grainc_to_cropprodc , & + grainn_to_cropprodn , & + + decomp_hr , & + decomp_hr_vr , & + decomp_ctransfer_vr , & + + decomp_cpools_transport_tendency , & + decomp_cpools_sourcesink , & + + somc_fire , & + som_c_leached , & + + sminn_to_denit_excess_vr , & + sminn_leached_vr , & + sminn_to_plant_fun_vr , & + + f_nit_vr , & + f_denit_vr , & + smin_no3_leached_vr , & + smin_no3_runoff_vr , & + n2_n2o_ratio_denit_vr , & + pot_f_nit_vr , & + pot_f_denit_vr , & + actual_immob_no3_vr , & + actual_immob_nh4_vr , & + smin_no3_to_plant_vr , & + smin_nh4_to_plant_vr , & + f_n2o_denit_vr , & + f_n2o_nit_vr , & + + potential_immob_vr , & + actual_immob_vr , & + sminn_to_plant , & + sminn_to_plant_vr , & + supplement_to_sminn_vr , & + gross_nmin_vr , & + net_nmin_vr , & + sminn_to_plant_fun_no3_vr , & + sminn_to_plant_fun_nh4_vr , & + + nfix_to_sminn , & + ffix_to_sminn , & + fert_to_sminn , & + soyfixn_to_sminn , & + sminn_to_plant , & + supplement_to_sminn , & + gross_nmin , & + net_nmin , & + denit , & + f_n2o_nit , & + smin_no3_leached , & + smin_no3_runoff , & + sminn_leached , & + som_n_leached , & + + decomp_npools_transport_tendency , & + + decomp_ntransfer_vr , & + decomp_sminn_flux_vr , & + sminn_to_denit_decomp_vr , & + + decomp_npools_sourcesink + + USE MOD_BGC_Vars_TimeVariables, only: & + decomp_k + + IMPLICIT NONE + + PUBLIC CNZeroFluxes + +CONTAINS + + SUBROUTINE CNZeroFluxes (i,ps,pe,nl_soil,ndecomp_pools,ndecomp_transitions) + + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + integer, intent(in) :: nl_soil ! number of total soil layers + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + + integer j,k, m + + DO m = ps , pe + ! CNVegCarbonFluxes set zero + m_leafc_to_litter_p(m) = 0._r8 + m_frootc_to_litter_p(m) = 0._r8 + m_leafc_storage_to_litter_p(m) = 0._r8 + m_frootc_storage_to_litter_p(m) = 0._r8 + m_livestemc_storage_to_litter_p(m) = 0._r8 + m_deadstemc_storage_to_litter_p(m) = 0._r8 + m_livecrootc_storage_to_litter_p(m) = 0._r8 + m_deadcrootc_storage_to_litter_p(m) = 0._r8 + m_leafc_xfer_to_litter_p(m) = 0._r8 + m_frootc_xfer_to_litter_p(m) = 0._r8 + m_livestemc_xfer_to_litter_p(m) = 0._r8 + m_deadstemc_xfer_to_litter_p(m) = 0._r8 + m_livecrootc_xfer_to_litter_p(m) = 0._r8 + m_deadcrootc_xfer_to_litter_p(m) = 0._r8 + m_livestemc_to_litter_p(m) = 0._r8 + m_deadstemc_to_litter_p(m) = 0._r8 + m_livecrootc_to_litter_p(m) = 0._r8 + m_deadcrootc_to_litter_p(m) = 0._r8 + m_gresp_storage_to_litter_p(m) = 0._r8 + m_gresp_xfer_to_litter_p(m) = 0._r8 + m_leafc_to_fire_p(m) = 0._r8 + m_leafc_storage_to_fire_p(m) = 0._r8 + m_leafc_xfer_to_fire_p(m) = 0._r8 + m_livestemc_to_fire_p(m) = 0._r8 + m_livestemc_storage_to_fire_p(m) = 0._r8 + m_livestemc_xfer_to_fire_p(m) = 0._r8 + m_deadstemc_to_fire_p(m) = 0._r8 + m_deadstemc_storage_to_fire_p(m) = 0._r8 + m_deadstemc_xfer_to_fire_p(m) = 0._r8 + m_frootc_to_fire_p(m) = 0._r8 + m_frootc_storage_to_fire_p(m) = 0._r8 + m_frootc_xfer_to_fire_p(m) = 0._r8 + m_livecrootc_to_fire_p(m) = 0._r8 + m_livecrootc_storage_to_fire_p(m) = 0._r8 + m_livecrootc_xfer_to_fire_p(m) = 0._r8 + m_deadcrootc_to_fire_p(m) = 0._r8 + m_deadcrootc_storage_to_fire_p(m) = 0._r8 + m_deadcrootc_xfer_to_fire_p(m) = 0._r8 + m_gresp_storage_to_fire_p(m) = 0._r8 + m_gresp_xfer_to_fire_p(m) = 0._r8 + + m_leafc_to_litter_fire_p(m) = 0._r8 + m_leafc_storage_to_litter_fire_p(m) = 0._r8 + m_leafc_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemc_to_litter_fire_p(m) = 0._r8 + m_livestemc_storage_to_litter_fire_p(m) = 0._r8 + m_livestemc_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemc_to_deadstemc_fire_p(m) = 0._r8 + m_deadstemc_to_litter_fire_p(m) = 0._r8 + m_deadstemc_storage_to_litter_fire_p(m) = 0._r8 + m_deadstemc_xfer_to_litter_fire_p(m) = 0._r8 + m_frootc_to_litter_fire_p(m) = 0._r8 + m_frootc_storage_to_litter_fire_p(m) = 0._r8 + m_frootc_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootc_to_litter_fire_p(m) = 0._r8 + m_livecrootc_storage_to_litter_fire_p(m) = 0._r8 + m_livecrootc_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootc_to_deadcrootc_fire_p(m) = 0._r8 + m_deadcrootc_to_litter_fire_p(m) = 0._r8 + m_deadcrootc_storage_to_litter_fire_p(m) = 0._r8 + m_deadcrootc_xfer_to_litter_fire_p(m) = 0._r8 + m_gresp_storage_to_litter_fire_p(m) = 0._r8 + m_gresp_xfer_to_litter_fire_p(m) = 0._r8 + leafc_xfer_to_leafc_p(m) = 0._r8 + frootc_xfer_to_frootc_p(m) = 0._r8 + livestemc_xfer_to_livestemc_p(m) = 0._r8 + deadstemc_xfer_to_deadstemc_p(m) = 0._r8 + livecrootc_xfer_to_livecrootc_p(m) = 0._r8 + deadcrootc_xfer_to_deadcrootc_p(m) = 0._r8 + leafc_to_litter_p(m) = 0._r8 + frootc_to_litter_p(m) = 0._r8 + leaf_mr_p(m) = 0._r8 + froot_mr_p(m) = 0._r8 + livestem_mr_p(m) = 0._r8 + livecroot_mr_p(m) = 0._r8 + grain_mr_p(m) = 0._r8 + leaf_curmr_p(m) = 0._r8 + froot_curmr_p(m) = 0._r8 + livestem_curmr_p(m) = 0._r8 + livecroot_curmr_p(m) = 0._r8 + grain_curmr_p(m) = 0._r8 + leaf_xsmr_p(m) = 0._r8 + froot_xsmr_p(m) = 0._r8 + livestem_xsmr_p(m) = 0._r8 + livecroot_xsmr_p(m) = 0._r8 + grain_xsmr_p(m) = 0._r8 + psn_to_cpool_p(m) = 0._r8 + cpool_to_xsmrpool_p(m) = 0._r8 + cpool_to_leafc_p(m) = 0._r8 + cpool_to_leafc_storage_p(m) = 0._r8 + cpool_to_frootc_p(m) = 0._r8 + cpool_to_frootc_storage_p(m) = 0._r8 + cpool_to_livestemc_p(m) = 0._r8 + cpool_to_livestemc_storage_p(m) = 0._r8 + cpool_to_deadstemc_p(m) = 0._r8 + cpool_to_deadstemc_storage_p(m) = 0._r8 + cpool_to_livecrootc_p(m) = 0._r8 + cpool_to_livecrootc_storage_p(m) = 0._r8 + cpool_to_deadcrootc_p(m) = 0._r8 + cpool_to_deadcrootc_storage_p(m) = 0._r8 + cpool_to_gresp_storage_p(m) = 0._r8 + cpool_leaf_gr_p(m) = 0._r8 + cpool_leaf_storage_gr_p(m) = 0._r8 + transfer_leaf_gr_p(m) = 0._r8 + cpool_froot_gr_p(m) = 0._r8 + cpool_froot_storage_gr_p(m) = 0._r8 + transfer_froot_gr_p(m) = 0._r8 + cpool_livestem_gr_p(m) = 0._r8 + cpool_livestem_storage_gr_p(m) = 0._r8 + transfer_livestem_gr_p(m) = 0._r8 + cpool_deadstem_gr_p(m) = 0._r8 + cpool_deadstem_storage_gr_p(m) = 0._r8 + transfer_deadstem_gr_p(m) = 0._r8 + cpool_livecroot_gr_p(m) = 0._r8 + cpool_livecroot_storage_gr_p(m) = 0._r8 + transfer_livecroot_gr_p(m) = 0._r8 + cpool_deadcroot_gr_p(m) = 0._r8 + cpool_deadcroot_storage_gr_p(m) = 0._r8 + transfer_deadcroot_gr_p(m) = 0._r8 + leafc_storage_to_xfer_p(m) = 0._r8 + frootc_storage_to_xfer_p(m) = 0._r8 + livestemc_storage_to_xfer_p(m) = 0._r8 + deadstemc_storage_to_xfer_p(m) = 0._r8 + livecrootc_storage_to_xfer_p(m) = 0._r8 + deadcrootc_storage_to_xfer_p(m) = 0._r8 + gresp_storage_to_xfer_p(m) = 0._r8 + livestemc_to_deadstemc_p(m) = 0._r8 + livecrootc_to_deadcrootc_p(m) = 0._r8 + crop_seedc_to_leaf_p(m) = 0._r8 + + hrv_xsmrpool_to_atm_p(m) = 0._r8 + + xsmrpool_to_atm_p(m) = 0._r8 + livestemc_to_litter_p(m) = 0._r8 + grainc_to_food_p(m) = 0._r8 + grainc_to_seed_p(m) = 0._r8 + grainc_xfer_to_grainc_p(m) = 0._r8 + cpool_to_grainc_p(m) = 0._r8 + cpool_to_grainc_storage_p(m) = 0._r8 + cpool_grain_gr_p(m) = 0._r8 + cpool_grain_storage_gr_p(m) = 0._r8 + transfer_grain_gr_p(m) = 0._r8 + grainc_storage_to_xfer_p(m) = 0._r8 + ENDDO + + DO j=1,nl_soil + phenology_to_met_c(j,i) = 0._r8 + phenology_to_cel_c(j,i) = 0._r8 + phenology_to_lig_c(j,i) = 0._r8 + + gap_mortality_to_met_c(j,i) = 0._r8 + gap_mortality_to_cel_c(j,i) = 0._r8 + gap_mortality_to_lig_c(j,i) = 0._r8 + gap_mortality_to_cwdc(j,i) = 0._r8 + + fire_mortality_to_cwdc(j,i) = 0._r8 + fire_mortality_to_met_c(j,i) = 0._r8 + fire_mortality_to_cel_c(j,i) = 0._r8 + fire_mortality_to_lig_c(j,i) = 0._r8 + + DO k=1,ndecomp_pools + m_decomp_cpools_to_fire_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + fire_closs(i) = 0._r8 + fire_nloss(i) = 0._r8 + wood_harvestc(i) = 0._r8 + wood_harvestn(i) = 0._r8 + grainc_to_cropprodc(i) = 0._r8 + grainn_to_cropprodn(i) = 0._r8 + + DO m = ps, pe + gpp_p(m) = 0._r8 + wood_harvestc_p(m) = 0._r8 + wood_harvestn_p(m) = 0._r8 + grainc_to_cropprodc_p(m) = 0._r8 + grainn_to_cropprodn_p(m) = 0._r8 + soyfixn_p(m) = 0._r8 + + fire_closs_p(m) = 0._r8 + fire_nloss_p(m) = 0._r8 + + ! CNVegNitrogenFluxes set zero + + m_leafn_to_litter_p(m) = 0._r8 + m_frootn_to_litter_p(m) = 0._r8 + m_leafn_storage_to_litter_p(m) = 0._r8 + m_frootn_storage_to_litter_p(m) = 0._r8 + m_livestemn_storage_to_litter_p(m) = 0._r8 + m_deadstemn_storage_to_litter_p(m) = 0._r8 + m_livecrootn_storage_to_litter_p(m) = 0._r8 + m_deadcrootn_storage_to_litter_p(m) = 0._r8 + m_leafn_xfer_to_litter_p(m) = 0._r8 + m_frootn_xfer_to_litter_p(m) = 0._r8 + m_livestemn_xfer_to_litter_p(m) = 0._r8 + m_deadstemn_xfer_to_litter_p(m) = 0._r8 + m_livecrootn_xfer_to_litter_p(m) = 0._r8 + m_deadcrootn_xfer_to_litter_p(m) = 0._r8 + m_livestemn_to_litter_p(m) = 0._r8 + m_deadstemn_to_litter_p(m) = 0._r8 + m_livecrootn_to_litter_p(m) = 0._r8 + m_deadcrootn_to_litter_p(m) = 0._r8 + m_retransn_to_litter_p(m) = 0._r8 + + m_leafn_to_fire_p(m) = 0._r8 + m_leafn_storage_to_fire_p(m) = 0._r8 + m_leafn_xfer_to_fire_p(m) = 0._r8 + m_livestemn_to_fire_p(m) = 0._r8 + m_livestemn_storage_to_fire_p(m) = 0._r8 + m_livestemn_xfer_to_fire_p(m) = 0._r8 + m_deadstemn_to_fire_p(m) = 0._r8 + m_deadstemn_storage_to_fire_p(m) = 0._r8 + m_deadstemn_xfer_to_fire_p(m) = 0._r8 + m_frootn_to_fire_p(m) = 0._r8 + m_frootn_storage_to_fire_p(m) = 0._r8 + m_frootn_xfer_to_fire_p(m) = 0._r8 + m_livecrootn_to_fire_p(m) = 0._r8 + m_livecrootn_storage_to_fire_p(m) = 0._r8 + m_livecrootn_xfer_to_fire_p(m) = 0._r8 + m_deadcrootn_to_fire_p(m) = 0._r8 + m_deadcrootn_storage_to_fire_p(m) = 0._r8 + m_deadcrootn_xfer_to_fire_p(m) = 0._r8 + m_retransn_to_fire_p(m) = 0._r8 + + + m_leafn_to_litter_fire_p(m) = 0._r8 + m_leafn_storage_to_litter_fire_p(m) = 0._r8 + m_leafn_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemn_to_litter_fire_p(m) = 0._r8 + m_livestemn_storage_to_litter_fire_p(m) = 0._r8 + m_livestemn_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemn_to_deadstemn_fire_p(m) = 0._r8 + m_deadstemn_to_litter_fire_p(m) = 0._r8 + m_deadstemn_storage_to_litter_fire_p(m) = 0._r8 + m_deadstemn_xfer_to_litter_fire_p(m) = 0._r8 + m_frootn_to_litter_fire_p(m) = 0._r8 + m_frootn_storage_to_litter_fire_p(m) = 0._r8 + m_frootn_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootn_to_litter_fire_p(m) = 0._r8 + m_livecrootn_storage_to_litter_fire_p(m) = 0._r8 + m_livecrootn_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootn_to_deadcrootn_fire_p(m) = 0._r8 + m_deadcrootn_to_litter_fire_p(m) = 0._r8 + m_deadcrootn_storage_to_litter_fire_p(m) = 0._r8 + m_deadcrootn_xfer_to_litter_fire_p(m) = 0._r8 + m_retransn_to_litter_fire_p(m) = 0._r8 + + leafn_xfer_to_leafn_p(m) = 0._r8 + frootn_xfer_to_frootn_p(m) = 0._r8 + livestemn_xfer_to_livestemn_p(m) = 0._r8 + deadstemn_xfer_to_deadstemn_p(m) = 0._r8 + livecrootn_xfer_to_livecrootn_p(m) = 0._r8 + deadcrootn_xfer_to_deadcrootn_p(m) = 0._r8 + leafn_to_litter_p(m) = 0._r8 + leafn_to_retransn_p(m) = 0._r8 + frootn_to_litter_p(m) = 0._r8 + retransn_to_npool_p(m) = 0._r8 + free_retransn_to_npool_p(m) = 0._r8 + sminn_to_npool_p(m) = 0._r8 + npool_to_leafn_p(m) = 0._r8 + npool_to_leafn_storage_p(m) = 0._r8 + npool_to_frootn_p(m) = 0._r8 + npool_to_frootn_storage_p(m) = 0._r8 + npool_to_livestemn_p(m) = 0._r8 + npool_to_livestemn_storage_p(m) = 0._r8 + npool_to_deadstemn_p(m) = 0._r8 + npool_to_deadstemn_storage_p(m) = 0._r8 + npool_to_livecrootn_p(m) = 0._r8 + npool_to_livecrootn_storage_p(m) = 0._r8 + npool_to_deadcrootn_p(m) = 0._r8 + npool_to_deadcrootn_storage_p(m) = 0._r8 + leafn_storage_to_xfer_p(m) = 0._r8 + frootn_storage_to_xfer_p(m) = 0._r8 + livestemn_storage_to_xfer_p(m) = 0._r8 + deadstemn_storage_to_xfer_p(m) = 0._r8 + livecrootn_storage_to_xfer_p(m) = 0._r8 + deadcrootn_storage_to_xfer_p(m) = 0._r8 + livestemn_to_deadstemn_p(m) = 0._r8 + livestemn_to_retransn_p(m) = 0._r8 + livecrootn_to_deadcrootn_p(m) = 0._r8 + livecrootn_to_retransn_p(m) = 0._r8 + + crop_seedn_to_leaf_p(m) = 0._r8 + + livestemn_to_litter_p(m) = 0._r8 + grainn_to_food_p(m) = 0._r8 + grainn_to_seed_p(m) = 0._r8 + grainn_xfer_to_grainn_p(m) = 0._r8 + npool_to_grainn_p(m) = 0._r8 + npool_to_grainn_storage_p(m) = 0._r8 + grainn_storage_to_xfer_p(m) = 0._r8 + frootn_to_retransn_p(m) = 0._r8 + ENDDO + + DO j=1,nl_soil + + ! phenology: litterfall and crop fluxes associated wit + phenology_to_met_n(j,i) = 0._r8 + phenology_to_cel_n(j,i) = 0._r8 + phenology_to_lig_n(j,i) = 0._r8 + + ! gap mortality + gap_mortality_to_met_n(j,i) = 0._r8 + gap_mortality_to_cel_n(j,i) = 0._r8 + gap_mortality_to_lig_n(j,i) = 0._r8 + gap_mortality_to_cwdn(j,i) = 0._r8 + + ! fire + fire_mortality_to_cwdn(j,i) = 0._r8 + fire_mortality_to_met_n(j,i) = 0._r8 + fire_mortality_to_cel_n(j,i) = 0._r8 + fire_mortality_to_lig_n(j,i) = 0._r8 + + ENDDO + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + m_decomp_npools_to_fire_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + DO k=1,ndecomp_transitions + DO j=1,nl_soil + decomp_hr_vr(j,k,i) = 0._r8 + decomp_ctransfer_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_transport_tendency(j,k,i) = 0._r8 + decomp_cpools_sourcesink(j,k,i) = 0._r8 + decomp_k(j,k,i) = 0._r8 + ENDDO + ENDDO + + somc_fire(i) = 0._r8 + som_c_leached(i) = 0._r8 + decomp_hr(i) = 0._r8 + + + + IF(.not. DEF_USE_NITRIF)THEN + DO j = 1, nl_soil + sminn_to_denit_excess_vr(j,i) = 0._r8 + sminn_leached_vr(j,i) = 0._r8 + sminn_to_plant_fun_vr(j,i) = 0._r8 + ENDDO + ELSE + DO j = 1, nl_soil + f_nit_vr(j,i) = 0._r8 + f_denit_vr(j,i) = 0._r8 + smin_no3_leached_vr(j,i) = 0._r8 + smin_no3_runoff_vr(j,i) = 0._r8 + n2_n2o_ratio_denit_vr(j,i) = 0._r8 + pot_f_nit_vr(j,i) = 0._r8 + pot_f_denit_vr(j,i) = 0._r8 + actual_immob_no3_vr(j,i) = 0._r8 + actual_immob_nh4_vr(j,i) = 0._r8 + smin_no3_to_plant_vr(j,i) = 0._r8 + smin_nh4_to_plant_vr(j,i) = 0._r8 + f_n2o_denit_vr(j,i) = 0._r8 + f_n2o_nit_vr(j,i) = 0._r8 + ENDDO + ENDIF + + DO j = 1, nl_soil + potential_immob_vr(j,i) = 0._r8 + actual_immob_vr(j,i) = 0._r8 + sminn_to_plant(i) = 0._r8 + sminn_to_plant_vr(j,i) = 0._r8 + supplement_to_sminn_vr(j,i) = 0._r8 + gross_nmin_vr(j,i) = 0._r8 + net_nmin_vr(j,i) = 0._r8 + sminn_to_plant_fun_no3_vr(j,i) = 0._r8 + sminn_to_plant_fun_nh4_vr(j,i) = 0._r8 + ENDDO + + nfix_to_sminn(i) = 0._r8 + ffix_to_sminn(i) = 0._r8 + fert_to_sminn(i) = 0._r8 + soyfixn_to_sminn(i) = 0._r8 + supplement_to_sminn(i) = 0._r8 + gross_nmin(i) = 0._r8 + net_nmin(i) = 0._r8 + denit(i) = 0._r8 + f_n2o_nit(i) = 0._r8 + smin_no3_leached(i) = 0._r8 + smin_no3_runoff(i) = 0._r8 + sminn_leached(i) = 0._r8 + som_n_leached(i) = 0._r8 + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_npools_transport_tendency(j,k,i) = 0._r8 + ENDDO + ENDDO + + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + decomp_ntransfer_vr(j,k,i) = 0._r8 + decomp_sminn_flux_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + IF(.not. DEF_USE_NITRIF)THEN + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + sminn_to_denit_decomp_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + ENDIF + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_npools_sourcesink(j,k,i) = 0._r8 + ENDDO + ENDDO + + END SUBROUTINE CNZeroFluxes + +END MODULE MOD_BGC_CNZeroFluxes +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 new file mode 100644 index 0000000000..e37fcd3871 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 @@ -0,0 +1,90 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Daylength + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Computes day length and solar declination angle based on given latitude and date. +! +! ! ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! REVISION: +! Xingjie Lu, 2022, modify original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: daylength ! function to compute daylength + PRIVATE :: declin_angle ! function to compute solar decliation angle + ! + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + real(r8) FUNCTION daylength(dlat, idate2) +! +! !DESCRIPTION: +! Computes daylength (in seconds) +! +! Latitude and solar declination angle should both be specified in radians. decl must +! be strictly less than pi/2; lat must be less than pi/2 within a small tolerance. +! + real(r8), intent(in) :: dlat ! latitude (degrees) + integer , intent(in) :: idate2 ! day of the year + + real(r8),parameter :: PI = 4.*atan(1.)! + ! !LOCAL VARIABLES: + real(r8) :: my_lat ! local version of lat, possibly adjusted slightly + real(r8) :: temp ! temporary variable + real(r8) :: decl + + ! number of seconds per radian of hour-angle + real(r8), parameter :: secs_per_radian = 13750.9871_r8 + + ! epsilon for defining latitudes "near" the pole + real(r8), parameter :: lat_epsilon = 10._r8 * epsilon(1._r8) + + ! Define an offset pole as slightly less than pi/2 to avoid problems with cos(lat) being negative + real(r8), parameter :: pole = PI/2.0_r8 + real(r8), parameter :: offset_pole = pole - lat_epsilon + !----------------------------------------------------------------------- + + decl=declin_angle(idate2) + + ! lat must be less than pi/2 within a small tolerance + IF (abs(dlat/180*PI) >= (pole + lat_epsilon)) THEN + daylength = -9999 + write(*,*)"error in latitude",dlat + + ! decl must be strictly less than pi/2 + ELSE IF (abs(decl) >= pole) THEN + daylength = -9999 + write(*,*)"error in idate:",idate2 + + ! normal case + ELSE + ! Ensure that latitude isn't too close to pole, to avoid problems with cos(lat) being negative + my_lat = min(offset_pole, max(-1._r8 * offset_pole, dlat/180*PI)) + + temp = -(sin(my_lat)*sin(decl))/(cos(my_lat) * cos(decl)) + temp = min(1._r8,max(-1._r8,temp)) + daylength = 2.0_r8 * secs_per_radian * acos(temp) + ENDIF + + END FUNCTION daylength + + real(r8) FUNCTION declin_angle(idate2) + + integer ,intent(in) :: idate2 ! day of the year + real(r8),parameter :: PI = 4.*atan(1.) ! circular constant + + declin_angle=-23.44_r8/180._r8*PI*cos(2*PI/365*(idate2+10)) + + END FUNCTION declin_angle + +END MODULE MOD_BGC_Daylength +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 new file mode 100644 index 0000000000..6438b71cf8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 @@ -0,0 +1,469 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemCompetition + +!--------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil mineral nitrogen competition between soil microbial (immobilisation) and plant (N uptake). +! Note that there is no non-linear microbial model in CoLM-BGC. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Vars_Global, only: npcropmin + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_NOSTRESSNITROGEN + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_BGC_Vars_1DFluxes, only: & + pot_f_nit_vr, potential_immob_vr, sminn_to_plant_vr, sminn_to_denit_excess_vr, plant_ndemand, & + actual_immob_vr, sminn_to_plant, pot_f_nit_vr, actual_immob_nh4_vr, f_nit_vr, & + smin_nh4_to_plant_vr, pot_f_denit_vr, actual_immob_no3_vr, f_denit_vr, smin_no3_to_plant_vr, & + n2_n2o_ratio_denit_vr, f_n2o_nit_vr, f_n2o_denit_vr, supplement_to_sminn_vr + USE MOD_BGC_Vars_TimeVariables, only: & + sminn_vr, smin_no3_vr, smin_nh4_vr, nfixation_prof, fpi_vr, fpi, fpg + USE MOD_BGC_Vars_TimeInvariants,only: & + bdnr, compet_plant_no3, compet_plant_nh4, compet_decomp_no3, compet_decomp_nh4, compet_denit, compet_nit, & + nitrif_n2o_loss_frac + + IMPLICIT NONE + + PUBLIC SoilBiogeochemCompetition + +CONTAINS + + SUBROUTINE SoilBiogeochemCompetition(i,deltim,nl_soil,dz_soi) + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + + + integer :: p,l,pi,j ! indices + real(r8) :: fpi_no3_vr(1:nl_soil) ! fraction of potential immobilization supplied by no3(no units) + real(r8) :: fpi_nh4_vr(1:nl_soil) ! fraction of potential immobilization supplied by nh4 (no units) + real(r8) :: sum_nh4_demand(1:nl_soil) + real(r8) :: sum_nh4_demand_scaled(1:nl_soil) + real(r8) :: sum_no3_demand(1:nl_soil) + real(r8) :: sum_no3_demand_scaled(1:nl_soil) + real(r8) :: sum_ndemand_vr( 1:nl_soil) !total column N demand (gN/m3/s) at a given level + real(r8) :: nuptake_prof( 1:nl_soil) + real(r8) :: sminn_tot + integer :: nlimit(1:nl_soil) !flag for N limitation + integer :: nlimit_no3(1:nl_soil) !flag for NO3 limitation + integer :: nlimit_nh4(1:nl_soil) !flag for NH4 limitation + real(r8) :: residual_sminn_vr( 1:nl_soil) + real(r8) :: residual_sminn + real(r8) :: residual_smin_nh4_vr( 1:nl_soil) + real(r8) :: residual_smin_no3_vr( 1:nl_soil) + real(r8) :: residual_smin_nh4 + real(r8) :: residual_smin_no3 + real(r8) :: residual_plant_ndemand + real(r8) :: sminn_to_plant_new + real(r8) :: actual_immob + real(r8) :: potential_immob + integer :: ivt, ps, pe, m + !----------------------------------------------------------------------- + + sminn_to_plant_new = 0._r8 + + IF(.not. DEF_USE_NITRIF)THEN + + ! init sminn_tot + sminn_tot = 0. + + DO j = 1, nl_soil + sminn_tot = sminn_tot + sminn_vr(j,i) * dz_soi(j) + ENDDO + + DO j = 1, nl_soil + IF (sminn_tot > 0.) THEN + nuptake_prof(j) = sminn_vr(j,i) / sminn_tot + ELSE + nuptake_prof(j) = nfixation_prof(j,i) + ENDIF + ENDDO + + DO j = 1, nl_soil + sum_ndemand_vr(j) = plant_ndemand(i) * nuptake_prof(j) + potential_immob_vr(j,i) + ENDDO + + DO j = 1, nl_soil + IF (sum_ndemand_vr(j)*deltim < sminn_vr(j,i)) THEN + + ! N availability is not limiting immobilization or plant + ! uptake, and both can proceed at their potential rates + nlimit(j) = 0 + fpi_vr(j,i) = 1.0_r8 + actual_immob_vr(j,i) = potential_immob_vr(j,i) + sminn_to_plant_vr(j,i) = plant_ndemand(i) * nuptake_prof(j) + ELSE + ! N availability can not satisfy the sum of immobilization and + ! plant growth demands, so these two demands compete for available + ! soil mineral N resource. + + nlimit(j) = 1 + IF (sum_ndemand_vr(j) > 0.0_r8) THEN + actual_immob_vr(j,i) = (sminn_vr(j,i)/deltim)*(potential_immob_vr(j,i) / sum_ndemand_vr(j)) + ELSE + actual_immob_vr(j,i) = 0.0_r8 + ENDIF + + IF (potential_immob_vr(j,i) > 0.0_r8) THEN + fpi_vr(j,i) = actual_immob_vr(j,i) / potential_immob_vr(j,i) + ELSE + fpi_vr(j,i) = 0.0_r8 + ENDIF + + sminn_to_plant_vr(j,i) = (sminn_vr(j,i)/deltim) - actual_immob_vr(j,i) + ENDIF + + IF (DEF_USE_NOSTRESSNITROGEN) THEN + ps = patch_pft_s(i) + pe = patch_pft_e(i) + DO m = ps, pe + ivt = pftclass(m) + IF (ivt >= npcropmin) THEN + nlimit(j) = 1 + fpi_vr(j,i) = 1.0_r8 + actual_immob_vr(j,i) = potential_immob_vr(j,i) + sminn_to_plant_vr(j,i) = plant_ndemand(i) * nuptake_prof(j) + supplement_to_sminn_vr(j,i) = sum_ndemand_vr(j) - (sminn_vr(j,i)/deltim) + ENDIF + ENDDO + ENDIF + ENDDO + + ! sum up N fluxes to plant + DO j = 1, nl_soil + sminn_to_plant(i) = sminn_to_plant(i) + sminn_to_plant_vr(j,i) * dz_soi(j) + ENDDO + + ! give plants a second pass to see IF there is any mineral N left over with which to satisfy residual N demand. + residual_sminn = 0._r8 + + ! sum up total N left over after initial plant and immobilization fluxes + residual_plant_ndemand = plant_ndemand(i) - sminn_to_plant(i) + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF (nlimit(j) .eq. 0) THEN + residual_sminn_vr(j) = max(sminn_vr(j,i) - (actual_immob_vr(j,i) + sminn_to_plant_vr(j,i) ) * deltim, 0._r8) + residual_sminn = residual_sminn + residual_sminn_vr(j) * dz_soi(j) + ELSE + residual_sminn_vr(j) = 0._r8 + ENDIF + ENDIF + ENDDO + + ! distribute residual N to plants + DO j = 1, nl_soil + IF ( residual_plant_ndemand > 0._r8 .and. residual_sminn > 0._r8 .and. nlimit(j) .eq. 0) THEN + sminn_to_plant_vr(j,i) = sminn_to_plant_vr(j,i) + residual_sminn_vr(j) * & + min(( residual_plant_ndemand * deltim ) / residual_sminn, 1._r8) / deltim + ENDIF + ENDDO + + ! re-sum up N fluxes to plant + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant(i) = sminn_to_plant(i) + sminn_to_plant_vr(j,i) * dz_soi(j) + sum_ndemand_vr(j) = potential_immob_vr(j,i) + sminn_to_plant_vr(j,i) + ENDDO + + ! under conditions of excess N, some proportion is assumed to + ! be lost to denitrification, in addition to the constant + ! proportion lost in the decomposition pathways + DO j = 1, nl_soil + IF ((sminn_to_plant_vr(j,i) + actual_immob_vr(j,i))*deltim < sminn_vr(j,i)) THEN + sminn_to_denit_excess_vr(j,i) = max(bdnr*deltim/86400._r8*((sminn_vr(j,i)/deltim) - sum_ndemand_vr(j)),0._r8) + ELSE + sminn_to_denit_excess_vr(j,i) = 0._r8 + ENDIF + ENDDO + + ! sum up N fluxes to immobilization + actual_immob = 0._r8 + potential_immob = 0._r8 + DO j = 1, nl_soil + actual_immob = actual_immob + actual_immob_vr(j,i) * dz_soi(j) + potential_immob = potential_immob + potential_immob_vr(j,i) * dz_soi(j) + ENDDO + + ! calculate the fraction of potential growth that can be + ! achieved with the N available to plants + IF (plant_ndemand(i) > 0.0_r8) THEN + fpg(i) = sminn_to_plant(i) / plant_ndemand(i) + ELSE + fpg(i) = 1.0_r8 + ENDIF + + ! calculate the fraction of immobilization realized (for diagnostic purposes) + IF (potential_immob > 0.0_r8) THEN + fpi(i) = actual_immob / potential_immob + ELSE + fpi(i) = 1.0_r8 + ENDIF + + ELSE + ! init total mineral N pools + sminn_tot = 0. + + ! sum up total mineral N pools + DO j = 1, nl_soil + sminn_tot = sminn_tot + (smin_no3_vr(j,i) + smin_nh4_vr(j,i)) * dz_soi(j) + ENDDO + + ! define N uptake profile for initial vertical distribution of plant N uptake, assuming plant seeks N from WHERE it is most abundant + DO j = 1, nl_soil + IF (sminn_tot > 0.) THEN + nuptake_prof(j) = sminn_vr(j,i) / sminn_tot + ELSE + nuptake_prof(j) = nfixation_prof(j,i) + ENDIF + ENDDO + + ! main column/vertical loop + DO j = 1, nl_soil + ! first compete for nh4 + sum_nh4_demand(j) = plant_ndemand(i) * nuptake_prof(j) + potential_immob_vr(j,i) + pot_f_nit_vr(j,i) + sum_nh4_demand_scaled(j) = plant_ndemand(i)* nuptake_prof(j) * compet_plant_nh4 + & + potential_immob_vr(j,i)*compet_decomp_nh4 + pot_f_nit_vr(j,i)*compet_nit + + IF (sum_nh4_demand(j)*deltim < smin_nh4_vr(j,i)) THEN + + ! NH4 availability is not limiting immobilization or plant + ! uptake, and all can proceed at their potential rates + nlimit_nh4(j) = 0 + fpi_nh4_vr(j) = 1.0_r8 + actual_immob_nh4_vr(j,i) = potential_immob_vr(j,i) + !RF added new term. + + f_nit_vr(j,i) = pot_f_nit_vr(j,i) + + smin_nh4_to_plant_vr(j,i) = plant_ndemand(i) * nuptake_prof(j) + + ELSE + + ! NH4 availability can not satisfy the sum of immobilization, nitrification, and + ! plant growth demands, so these three demands compete for available + ! soil mineral NH4 resource. + nlimit_nh4(j) = 1 + IF (sum_nh4_demand(j) > 0.0_r8) THEN + ! RF microbes compete based on the hypothesised plant demand. + actual_immob_nh4_vr(j,i) = min((smin_nh4_vr(j,i)/deltim)*(potential_immob_vr(j,i)* & + compet_decomp_nh4 / sum_nh4_demand_scaled(j)), potential_immob_vr(j,i)) + + f_nit_vr(j,i) = min((smin_nh4_vr(j,i)/deltim)*(pot_f_nit_vr(j,i)*compet_nit / & + sum_nh4_demand_scaled(j)), pot_f_nit_vr(j,i)) + + smin_nh4_to_plant_vr(j,i) = min((smin_nh4_vr(j,i)/deltim)*(plant_ndemand(i)* & + nuptake_prof(j)*compet_plant_nh4 / sum_nh4_demand_scaled(j)), plant_ndemand(i)*nuptake_prof(j)) + + ELSE + actual_immob_nh4_vr(j,i) = 0.0_r8 + smin_nh4_to_plant_vr(j,i) = 0.0_r8 + f_nit_vr(j,i) = 0.0_r8 + ENDIF + + IF (potential_immob_vr(j,i) > 0.0_r8) THEN + fpi_nh4_vr(j) = actual_immob_nh4_vr(j,i) / potential_immob_vr(j,i) + ELSE + fpi_nh4_vr(j) = 0.0_r8 + ENDIF + + ENDIF + sum_no3_demand(j) = (plant_ndemand(i)*nuptake_prof(j)-smin_nh4_to_plant_vr(j,i)) & + + (potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i)) + pot_f_denit_vr(j,i) + sum_no3_demand_scaled(j) = (plant_ndemand(i)*nuptake_prof(j) & + - smin_nh4_to_plant_vr(j,i))*compet_plant_no3 & + + (potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i))*compet_decomp_no3 + pot_f_denit_vr(j,i)*compet_denit + + IF (sum_no3_demand(j)*deltim < smin_no3_vr(j,i)) THEN + + ! NO3 availability is not limiting immobilization or plant + ! uptake, and all can proceed at their potential rates + nlimit_no3(j) = 0 + fpi_no3_vr(j) = 1.0_r8 - fpi_nh4_vr(j) + actual_immob_no3_vr(j,i) = (potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i)) + + f_denit_vr(j,i) = pot_f_denit_vr(j,i) + + smin_no3_to_plant_vr(j,i) = (plant_ndemand(i)*nuptake_prof(j)-smin_nh4_to_plant_vr(j,i)) + ELSE + + ! NO3 availability can not satisfy the sum of immobilization, denitrification, and + ! plant growth demands, so these three demands compete for available + ! soil mineral NO3 resource. + nlimit_no3(j) = 1 + + IF (sum_no3_demand(j) > 0.0_r8) THEN + actual_immob_no3_vr(j,i) = min((smin_no3_vr(j,i)/deltim)*((potential_immob_vr(j,i) & + - actual_immob_nh4_vr(j,i))*compet_decomp_no3 / sum_no3_demand_scaled(j)), & + potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i)) + + smin_no3_to_plant_vr(j,i) = min((smin_no3_vr(j,i)/deltim)*((plant_ndemand(i) & + * nuptake_prof(j)-smin_nh4_to_plant_vr(j,i))*compet_plant_no3 / sum_no3_demand_scaled(j)), & + plant_ndemand(i)*nuptake_prof(j)-smin_nh4_to_plant_vr(j,i)) + + f_denit_vr(j,i) = min((smin_no3_vr(j,i)/deltim)*(pot_f_denit_vr(j,i)*compet_denit / & + sum_no3_demand_scaled(j)), pot_f_denit_vr(j,i)) + + ELSE ! no no3 demand. no uptake fluxes. + actual_immob_no3_vr(j,i) = 0.0_r8 + smin_no3_to_plant_vr(j,i) = 0.0_r8 + f_denit_vr(j,i) = 0.0_r8 + + ENDIF !any no3 demand? + + IF (potential_immob_vr(j,i) > 0.0_r8) THEN + fpi_no3_vr(j) = actual_immob_no3_vr(j,i) / potential_immob_vr(j,i) + ELSE + fpi_no3_vr(j) = 0.0_r8 + ENDIF + + ENDIF + + ! n2o emissions: n2o from nitr is const fraction, n2o from denitr is calculated in nitrif_denitrif + f_n2o_nit_vr(j,i) = f_nit_vr(j,i) * nitrif_n2o_loss_frac + f_n2o_denit_vr(j,i) = f_denit_vr(j,i) / (1._r8 + n2_n2o_ratio_denit_vr(j,i)) + + + ! this code block controls the addition of N to sminn pool + ! to eliminate any N limitation, when Carbon_Only is set. This lets the + ! model behave essentially as a carbon-only model, but with the + ! benefit of keeping track of the N additions needed to + ! eliminate N limitations, so there is still a diagnostic quantity + ! that describes the degree of N limitation at steady-state. + IF (DEF_USE_NOSTRESSNITROGEN) THEN + ps = patch_pft_s(i) + pe = patch_pft_e(i) + DO m = ps, pe + ivt = pftclass(m) + IF (ivt >= npcropmin) THEN + IF (fpi_no3_vr(j) + fpi_nh4_vr(j) < 1._r8) THEN + fpi_nh4_vr(j) = 1.0_r8 - fpi_no3_vr(j) + supplement_to_sminn_vr(j,i) = (potential_immob_vr(j,i) & + - actual_immob_no3_vr(j,i)) - actual_immob_nh4_vr(j,i) + ! update to new values that satisfy demand + actual_immob_nh4_vr(j,i) = potential_immob_vr(j,i) - actual_immob_no3_vr(j,i) + ENDIF + IF (smin_no3_to_plant_vr(j,i) + smin_nh4_to_plant_vr(j,i) < plant_ndemand(i)*nuptake_prof(j)) THEN + supplement_to_sminn_vr(j,i) = supplement_to_sminn_vr(j,i) + & + (plant_ndemand(i)*nuptake_prof(j) - smin_no3_to_plant_vr(j,i)) - smin_nh4_to_plant_vr(j,i) ! use old values + smin_nh4_to_plant_vr(j,i) = plant_ndemand(i)*nuptake_prof(j) - smin_no3_to_plant_vr(j,i) + ENDIF + sminn_to_plant_vr(j,i) = smin_no3_to_plant_vr(j,i) + smin_nh4_to_plant_vr(j,i) + ENDIF + ENDDO + ENDIF + ! sum up no3 and nh4 fluxes + fpi_vr(j,i) = fpi_no3_vr(j) + fpi_nh4_vr(j) + sminn_to_plant_vr(j,i) = smin_no3_to_plant_vr(j,i) + smin_nh4_to_plant_vr(j,i) + actual_immob_vr(j,i) = actual_immob_no3_vr(j,i) + actual_immob_nh4_vr(j,i) + ENDDO + + ! sum up N fluxes to plant after initial competition + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant(i) = sminn_to_plant(i) + sminn_to_plant_vr(j,i) * dz_soi(j) + ENDDO + ! give plants a second pass to see IF there is any mineral N left over with which to satisfy residual N demand. + ! first take frm nh4 pool; THEN take from no3 pool + residual_plant_ndemand = plant_ndemand(i) - sminn_to_plant(i) + residual_smin_nh4 = 0._r8 + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF (nlimit_nh4(j) .eq. 0) THEN + residual_smin_nh4_vr(j) = max(smin_nh4_vr(j,i) - (actual_immob_nh4_vr(j,i) + & + smin_nh4_to_plant_vr(j,i) + f_nit_vr(j,i) ) * deltim, 0._r8) + + residual_smin_nh4 = residual_smin_nh4 + residual_smin_nh4_vr(j) * dz_soi(j) + ELSE + residual_smin_nh4_vr(j) = 0._r8 + ENDIF + ENDIF + ENDDO + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF ( residual_smin_nh4 > 0._r8 .and. nlimit_nh4(j) .eq. 0 ) THEN + smin_nh4_to_plant_vr(j,i) = smin_nh4_to_plant_vr(j,i) + residual_smin_nh4_vr(j) * & + min(( residual_plant_ndemand * deltim ) / residual_smin_nh4, 1._r8) / deltim + ENDIF + ENDIF + ENDDO + + ! re-sum up N fluxes to plant after second pass for nh4 + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant_vr(j,i) = smin_nh4_to_plant_vr(j,i) + smin_no3_to_plant_vr(j,i) + sminn_to_plant(i) = sminn_to_plant(i) + (sminn_to_plant_vr(j,i)) * dz_soi(j) + ENDDO + + ! + ! and now DO second pass for no3 + residual_plant_ndemand = plant_ndemand(i) - sminn_to_plant(i) + residual_smin_no3 = 0._r8 + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF (nlimit_no3(j) .eq. 0) THEN + residual_smin_no3_vr(j) = max(smin_no3_vr(j,i) - (actual_immob_no3_vr(j,i) + & + smin_no3_to_plant_vr(j,i) + f_denit_vr(j,i) ) * deltim, 0._r8) + residual_smin_no3 = residual_smin_no3 + residual_smin_no3_vr(j) * dz_soi(j) + ELSE + residual_smin_no3_vr(j) = 0._r8 + ENDIF + ENDIF + ENDDO + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF ( residual_smin_no3 > 0._r8 .and. nlimit_no3(j) .eq. 0) THEN + smin_no3_to_plant_vr(j,i) = smin_no3_to_plant_vr(j,i) + residual_smin_no3_vr(j) * & + min(( residual_plant_ndemand * deltim ) / residual_smin_no3, 1._r8) / deltim + ENDIF + ENDIF + ENDDO + + ! re-sum up N fluxes to plant after second passes of both no3 and nh4 + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant_vr(j,i) = smin_nh4_to_plant_vr(j,i) + smin_no3_to_plant_vr(j,i) + sminn_to_plant(i) = sminn_to_plant(i) + (sminn_to_plant_vr(j,i)) * dz_soi(j) + ENDDO + + ! sum up N fluxes to immobilization + actual_immob = 0._r8 + potential_immob = 0._r8 + DO j = 1, nl_soil + actual_immob = actual_immob + actual_immob_vr(j,i) * dz_soi(j) + potential_immob = potential_immob + potential_immob_vr(j,i) * dz_soi(j) + ENDDO + + ! calculate the fraction of potential growth that can be + ! achieved with the N available to plants + ! calculate the fraction of immobilization realized (for diagnostic purposes) + + IF (plant_ndemand(i) > 0.0_r8) THEN + fpg(i) = sminn_to_plant(i) / plant_ndemand(i) + ELSE + fpg(i) = 1._r8 + ENDIF + + IF (potential_immob > 0.0_r8) THEN + fpi(i) = actual_immob / potential_immob + ELSE + fpi(i) = 1._r8 + ENDIF + ENDIF + + END SUBROUTINE SoilBiogeochemCompetition + +END MODULE MOD_BGC_Soil_BiogeochemCompetition +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 new file mode 100644 index 0000000000..0ba34efc97 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 @@ -0,0 +1,122 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemDecomp + +!----------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE calculates the CN transfer fluxes between different soil and litter pools, +! which includes CN transfer fluxes (decomp_ctransfer or decomp_ntransfer), heterotrophic respiration (decomp_hr), +! net mineralisation and gross mineralisation. Denitrification flux will be also calculated when nitrification model +! is activated. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + USE MOD_BGC_Vars_TimeInvariants, only: & + floating_cn_ratio, initial_cn_ratio, dnp, rf_decomp, receiver_pool, donor_pool, i_atm + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition carbon & nitrogen pools + decomp_cpools_vr, decomp_npools_vr, & + + ! other variables + cn_decomp_pools, fpi_vr + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition fluxes variables + decomp_sminn_flux_vr, decomp_hr_vr, decomp_ctransfer_vr, decomp_ntransfer_vr, & + pmnf_decomp, p_decomp_cpool_loss, sminn_to_denit_decomp_vr, & + net_nmin_vr, gross_nmin_vr, net_nmin, gross_nmin + + + IMPLICIT NONE + + PUBLIC SoilBiogeochemDecomp + +CONTAINS + + SUBROUTINE SoilBiogeochemDecomp(i,nl_soil,ndecomp_pools,ndecomp_transitions, dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer ,intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer j,k,l + ! calculate c:n ratios of applicable pools + DO l = 1, ndecomp_pools + IF ( floating_cn_ratio(l) ) THEN + DO j = 1,nl_soil + IF ( decomp_npools_vr(j,l,i) > 0._r8 ) THEN + cn_decomp_pools(j,l,i) = decomp_cpools_vr(j,l,i) / decomp_npools_vr(j,l,i) + ENDIF + ENDDO + ELSE + DO j = 1,nl_soil + cn_decomp_pools(j,l,i) = initial_cn_ratio(l) + ENDDO + ENDIF + ENDDO + + ! column loop to calculate actual immobilization and decomp rates, following + ! resolution of plant/heterotroph competition for mineral N + + ! upon RETURN from SoilBiogeochemCompetition, the fraction of potential immobilization + ! has been set (soilbiogeochem_state_inst%fpi_vr_col). now finish the decomp calculations. + ! only the immobilization steps are limited by fpi_vr (pmnf > 0) + ! Also calculate denitrification losses as a simple proportion + ! of mineralization flux. + + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + IF (decomp_cpools_vr(j,donor_pool(k),i) > 0._r8) THEN + IF ( pmnf_decomp(j,k,i) > 0._r8 ) THEN + p_decomp_cpool_loss(j,k,i) = p_decomp_cpool_loss(j,k,i) * fpi_vr(j,i) + pmnf_decomp(j,k,i) = pmnf_decomp(j,k,i) * fpi_vr(j,i) + IF(.not. DEF_USE_NITRIF)THEN + sminn_to_denit_decomp_vr(j,k,i) = 0._r8 + ENDIF + ELSE + IF(.not. DEF_USE_NITRIF)THEN + sminn_to_denit_decomp_vr(j,k,i) = -dnp * pmnf_decomp(j,k,i) + ENDIF + ENDIF + decomp_hr_vr(j,k,i) = rf_decomp(j,k,i) * p_decomp_cpool_loss(j,k,i) + decomp_ctransfer_vr(j,k,i) = (1._r8 - rf_decomp(j,k,i)) * p_decomp_cpool_loss(j,k,i) + IF (decomp_npools_vr(j,donor_pool(k),i) > 0._r8 .and. receiver_pool(k) /= i_atm) THEN + decomp_ntransfer_vr(j,k,i) = p_decomp_cpool_loss(j,k,i) / cn_decomp_pools(j,donor_pool(k),i) + ELSE + decomp_ntransfer_vr(j,k,i) = 0._r8 + ENDIF + IF ( receiver_pool(k) /= 0 ) THEN + decomp_sminn_flux_vr(j,k,i) = pmnf_decomp(j,k,i) + ELSE ! keep sign convention negative for terminal pools + decomp_sminn_flux_vr(j,k,i) = - pmnf_decomp(j,k,i) + ENDIF + net_nmin_vr(j,i) = net_nmin_vr(j,i) - pmnf_decomp(j,k,i) + ELSE + decomp_ntransfer_vr(j,k,i) = 0._r8 + IF(.not. DEF_USE_NITRIF)THEN + sminn_to_denit_decomp_vr(j,k,i) = 0._r8 + ENDIF + decomp_sminn_flux_vr(j,k,i) = 0._r8 + ENDIF + + ENDDO + ENDDO + + DO j = 1,nl_soil + net_nmin(i) = net_nmin(i) + net_nmin_vr(j,i) * dz_soi(j) + gross_nmin(i) = gross_nmin(i) + gross_nmin_vr(j,i) * dz_soi(j) + ENDDO + + END SUBROUTINE SoilBiogeochemDecomp + +END MODULE MOD_BGC_Soil_BiogeochemDecomp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 new file mode 100644 index 0000000000..23f23f2056 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 @@ -0,0 +1,122 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemDecompCascadeBGC + +!--------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil decomposition rate according to soil temperature, soil matric potential, and depth +! +! !REFERENCES: +! Koven, C.D., Riley, W.J., Subin, Z.M., Tang, J.Y., Torn, M.S., Collins, W.D., Bonan, G.B., Lawrence, +! D.M. and Swenson, S.C., 2013. The effect of vertically resolved soil biogeochemistry and alternate +! soil C and N models on C dynamics of CLM4. Biogeosciences, 10(11), 7109-7131. +! Thornton, P.E., Law, B.E., Gholz, H.L., Clark, K.L., Falge, E., Ellsworth, D.S., Goldstein, A.H., Monson, +! R.K., Hollinger, D., Falk, M. and Chen, J., 2002. Modeling and measuring the effects of disturbance +! history and climate on carbon and water budgets in evergreen needleleaf forests. +! Agricultural and forest meteorology, 113(1-4), 185-222. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Vars_TimeInvariants, only: & + Q10, smpmax_hr, smpmin_hr, tau_l1, tau_l2_l3, tau_s1, tau_s2, tau_s3, tau_cwd, froz_q10, & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd,i_soil1,i_soil2,i_soil3 + USE MOD_Vars_TimeVariables, only: & + smp, t_soisno, t_scalar, w_scalar, o_scalar, depth_scalar, decomp_k + USE MOD_Vars_Global, only: PI + + IMPLICIT NONE + + PUBLIC decomp_rate_constants_bgc + +CONTAINS + + SUBROUTINE decomp_rate_constants_bgc(i,nl_soil,z_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: z_soi(1:nl_soil) ! depth of each soil layer + + real(r8) normalization_factor ! factor by which to offset the decomposition rates frm century to a q10 formulation + real(r8),parameter :: decomp_depth_efolding = 10._r8 + real(r8) k_l1, k_l2_l3, k_s1, k_s2, k_s3, k_frag + real(r8) psi + integer j + real(r8) catanf + real(r8) catanf_30 + real(r8) t1 + + catanf(t1) = 11.75_r8 +(29.7_r8 / PI) * atan( PI * 0.031_r8 * ( t1 - 15.4_r8 )) + + ! translate to per-second time constant + k_l1 = 1._r8 / (86400._r8 * 365._r8 * tau_l1) + k_l2_l3 = 1._r8 / (86400._r8 * 365._r8 * tau_l2_l3) + k_s1 = 1._r8 / (86400._r8 * 365._r8 * tau_s1) + k_s2 = 1._r8 / (86400._r8 * 365._r8 * tau_s2) + k_s3 = 1._r8 / (86400._r8 * 365._r8 * tau_s3) + k_frag = 1._r8 / (86400._r8 * 365._r8 * tau_cwd) + + ! calc ref rate + catanf_30 = catanf(30._r8) + + DO j = 1, nl_soil + IF (t_soisno(j,i) >= 273.15_r8) THEN + t_scalar(j,i)= (Q10**((t_soisno(j,i)-(273.15_r8+25._r8))/10._r8)) + ELSE + t_scalar(j,i)= (Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(j,i)-273.15_r8)/10._r8)) + ENDIF + ENDDO + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + DO j = 1,nl_soil + psi = min(smp(j,i),smpmax_hr) + ! decomp only IF soilpsi is higher than minpsi + IF (psi > smpmin_hr) THEN + w_scalar(j,i) = (log(smpmin_hr/psi)/log(smpmin_hr/smpmax_hr)) + ELSE + w_scalar(j,i) = 0.001_r8 + ! update froot_prof_p for root carbon turnover when soil is frozen + ENDIF + ENDDO + + o_scalar(1:nl_soil,i) = 1._r8 + + ! scale all decomposition rates by a constant to compensate for offset between original CENTURY temp func and Q10 + normalization_factor = (catanf(15._r8)/catanf_30) / (Q10**((15._r8-25._r8)/10._r8)) + DO j = 1, nl_soil + t_scalar(j,i) = t_scalar(j,i) * normalization_factor + ENDDO + + DO j = 1, nl_soil + depth_scalar(j,i) = exp(-z_soi(j)/decomp_depth_efolding) + ENDDO + + DO j = 1, nl_soil + decomp_k(j,i_met_lit,i) = k_l1 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_cel_lit,i) = k_l2_l3 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_lig_lit,i) = k_l2_l3 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_soil1 ,i) = k_s1 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_soil2 ,i) = k_s2 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_soil3 ,i) = k_s3 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + ENDDO + + DO j = 1,nl_soil + decomp_k(j,i_cwd,i) = k_frag * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * & + o_scalar(j,i) + ENDDO + + END SUBROUTINE decomp_rate_constants_bgc + +END MODULE MOD_BGC_Soil_BiogeochemDecompCascadeBGC +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 new file mode 100644 index 0000000000..27a2cb36e3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 @@ -0,0 +1,333 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemLittVertTransp + +!---------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Simulate the soil and litter CN vertical mixing (diffusion and advection) processes. Solve the dynamics +! of soil and litter vertical profile with a tridiagonal matrix. +! +! !REFERENCES: +! Koven, C.D., Riley, W.J., Subin, Z.M., Tang, J.Y., Torn, M.S., Collins, W.D., Bonan, G.B., Lawrence, +! D.M. and Swenson, S.C., 2013. The effect of vertically resolved soil biogeochemistry and alternate +! soil C and N models on C dynamics of CLM4. Biogeosciences, 10(11), 7109-7131. +! Thornton, P.E., Law, B.E., Gholz, H.L., Clark, K.L., Falge, E., Ellsworth, D.S., Goldstein, A.H., Monson, +! R.K., Hollinger, D., Falk, M. and Chen, J., 2002. Modeling and measuring the effects of disturbance +! history and climate on carbon and water budgets in evergreen needleleaf forests. +! Agricultural and forest meteorology, 113(1-4), 185-222. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, 1) Revised the CLM5 code to be compatible with CoLM code structure. +! 2) Record accumulated organic CN vertical transfer rates for semi-analytic spin-up. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + is_cwd, som_adv_flux, som_diffus, cryoturb_diffusion_k, max_altdepth_cryoturbation, max_depth_cryoturb + USE MOD_BGC_Vars_TimeVariables, only: & + altmax, altmax_lastyear, som_adv_coef, som_diffus_coef, & + decomp_cpools_vr, decomp_npools_vr, & + diagVX_c_vr_acc, upperVX_c_vr_acc, lowerVX_c_vr_acc, & + diagVX_n_vr_acc, upperVX_n_vr_acc, lowerVX_n_vr_acc + USE MOD_BGC_Vars_1DFluxes, only: & + decomp_cpools_sourcesink, decomp_npools_sourcesink, & + decomp_cpools_transport_tendency, decomp_npools_transport_tendency + USE MOD_Utils, only: tridia + + IMPLICIT NONE + + PUBLIC SoilBiogeochemLittVertTransp + +CONTAINS + + SUBROUTINE SoilBiogeochemLittVertTransp(i,deltim,nl_soil,nl_soil_full,ndecomp_pools,nbedrock,z_soi,zi_soi,dz_soi) + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: nl_soil_full ! number of total soil layers plus bedrock layers + integer ,intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer ,intent(in) :: nbedrock ! where bedrock layer starts + real(r8),intent(in) :: z_soi (1:nl_soil_full) ! depth of each soil layer (m) + real(r8),intent(in) :: zi_soi(0:nl_soil_full) ! interface level below a zsoi level (m) + real(r8),intent(in) :: dz_soi(1:nl_soil_full) ! thicknesses of each soil layer (m) + + ! !LOCAL VARIABLES: + real(r8) :: diffus (1:nl_soil+1) ! diffusivity (m2/s) (includes spinup correction, if any) + real(r8) :: adv_flux(1:nl_soil+1) ! advective flux (m/s) (includes spinup correction, if any) + real(r8) :: aaa ! "A" function in Patankar + real(r8) :: pe ! Pe for "A" function in Patankar + real(r8) :: w_m1, w_p1 ! Weights for calculating harmonic mean of diffusivity + real(r8) :: d_m1, d_p1 ! Harmonic mean of diffusivity + real(r8) :: a_tri(0:nl_soil+1) ! "a" vector for tridiagonal matrix + real(r8) :: b_tri(0:nl_soil+1) ! "b" vector for tridiagonal matrix + real(r8) :: c_tri(0:nl_soil+1) ! "c" vector for tridiagonal matrix + real(r8) :: r_tri_c(0:nl_soil+1) ! "r" vector for tridiagonal solution for soil C + real(r8) :: r_tri_n(0:nl_soil+1) ! "r" vector for tridiagonal solution for soil N + real(r8) :: d_p1_zp1(1:nl_soil+1) ! diffusivity/delta_z for next j (set to zero for no diffusion) + real(r8) :: d_m1_zm1(1:nl_soil+1) ! diffusivity/delta_z for previous j (set to zero for no diffusion) + real(r8) :: f_p1(1:nl_soil+1) ! water flux for next j + real(r8) :: f_m1(1:nl_soil+1) ! water flux for previous j + real(r8) :: pe_p1(1:nl_soil+1) ! Peclet # for next j + real(r8) :: pe_m1(1:nl_soil+1) ! Peclet # for previous j + real(r8) :: dz_node(1:nl_soil+1) ! difference between nodes + real(r8) :: conc_trcr_c(0:nl_soil+1) ! dummy term + real(r8) :: conc_trcr_n(0:nl_soil+1) ! dummy term + real(r8) :: a_p_0 + integer :: s,j,l ! indices + integer :: jtop ! top level at each column + real(r8) :: spinup_term ! spinup accelerated decomposition factor, used to accelerate transport as well + real(r8) :: epsilon ! small number + + aaa (pe) = max (0._r8, (1._r8 - 0.1_r8 * abs(pe))**5) ! A function from Patankar, Table 5.2, pg 95 + + epsilon = 1.e-30 + spinup_term = 1._r8 + + IF (( max(altmax(i), altmax_lastyear(i)) <= max_altdepth_cryoturbation ) .and. & + ( max(altmax(i), altmax_lastyear(i)) > 0._r8) ) THEN + ! use mixing profile modified slightly from Koven et al. (2009): constant through active layer, linear decrease from base of active layer to zero at a fixed depth + DO j = 1,nl_soil+1 + IF ( j <= nbedrock+1 ) THEN + IF ( zi_soi(j) < max(altmax(i), altmax_lastyear(i)) ) THEN + som_diffus_coef(j,i) = cryoturb_diffusion_k + som_adv_coef(j,i) = 0._r8 + ELSE + som_diffus_coef(j,i) = max(cryoturb_diffusion_k * & + ( 1._r8 - ( zi_soi(j) - max(altmax(i), altmax_lastyear(i)) ) / & + ( min(max_depth_cryoturb, zi_soi(nbedrock+1)) - max(altmax(i), altmax_lastyear(i)) ) ), 0._r8) ! go linearly to zero between ALT and max_depth_cryoturb + som_adv_coef(j,i) = 0._r8 + ENDIF + ELSE + som_adv_coef(j,i) = 0._r8 + som_diffus_coef(j,i) = 0._r8 + ENDIF + ENDDO + ELSEIF ( max(altmax(i), altmax_lastyear(i)) > 0._r8 ) THEN + ! constant advection, constant diffusion + DO j = 1,nl_soil+1 + IF ( j <= nbedrock+1 ) THEN + som_adv_coef(j,i) = som_adv_flux + som_diffus_coef(j,i) = som_diffus + ELSE + som_adv_coef(j,i) = 0._r8 + som_diffus_coef(j,i) = 0._r8 + ENDIF + ENDDO + ELSE + ! completely frozen soils--no mixing + DO j = 1,nl_soil+1 + som_adv_coef(j,i) = 0._r8 + som_diffus_coef(j,i) = 0._r8 + ENDDO + ENDIF + + ! Set the distance between the node and the one ABOVE it + dz_node(1) = z_soi(1) + DO j = 2, nl_soil+1 + dz_node(j)= z_soi(j) - z_soi(j-1) + ENDDO + + DO s = 1, ndecomp_pools + IF ( .not. is_cwd(s) ) THEN + DO j = 1,nl_soil+1 + IF ( abs(som_adv_coef(j,i)) * spinup_term < epsilon ) THEN + adv_flux(j) = epsilon + ELSE + adv_flux(j) = som_adv_coef(j,i) * spinup_term + ENDIF + ! + IF ( abs(som_diffus_coef(j,i)) * spinup_term < epsilon ) THEN + diffus(j) = epsilon + ELSE + diffus(j) = som_diffus_coef(j,i) * spinup_term + ENDIF + ! + ENDDO + + ! Set Pe (Peclet #) and D/dz throughout column + conc_trcr_c(0) = 0._r8 + conc_trcr_n(0) = 0._r8 + conc_trcr_c(nbedrock+1:nl_soil+1) = 0._r8 + conc_trcr_n(nbedrock+1:nl_soil+1) = 0._r8 + + DO j = 1,nl_soil+1 + conc_trcr_c(j) = decomp_cpools_vr(j,s,i) + conc_trcr_n(j) = decomp_npools_vr(j,s,i) + + ! dz_tracer below is the difference between gridcell edges (dz_soi) + ! dz_node_tracer is difference between cell centers + + ! Calculate the D and F terms in the Patankar algorithm + IF (j == 1) THEN + d_m1_zm1(j) = 0._r8 + w_p1 = (z_soi(j+1) - zi_soi(j)) / dz_node(j+1) + IF ( diffus(j+1) > 0._r8 .and. diffus(j) > 0._r8) THEN + d_p1 = 1._r8 / ((1._r8 - w_p1) / diffus(j) + w_p1 / diffus(j+1)) ! Harmonic mean of diffus + ELSE + d_p1 = 0._r8 + ENDIF + d_p1_zp1(j) = d_p1 / dz_node(j+1) + f_m1(j) = adv_flux(j) ! Include infiltration here + f_p1(j) = adv_flux(j+1) + pe_m1(j) = 0._r8 + pe_p1(j) = f_p1(j) / d_p1_zp1(j) ! Peclet # + ELSEIF (j >= nbedrock+1) THEN + ! At the bottom, assume no gradient in d_z (i.e., they're the same) + w_m1 = (zi_soi(j-1) - z_soi(j-1)) / dz_node(j) + IF ( diffus(j) > 0._r8 .and. diffus(j-1) > 0._r8) THEN + d_m1 = 1._r8 / ((1._r8 - w_m1) / diffus(j) + w_m1 / diffus(j-1)) ! Harmonic mean of diffus + ELSE + d_m1 = 0._r8 + ENDIF + d_m1_zm1(j) = d_m1 / dz_node(j) + d_p1_zp1(j) = d_m1_zm1(j) ! Set to be the same + f_m1(j) = adv_flux(j) + f_p1(j) = 0._r8 + pe_m1(j) = f_m1(j) / d_m1_zm1(j) ! Peclet # + pe_p1(j) = f_p1(j) / d_p1_zp1(j) ! Peclet # + ELSE + ! Use distance from j-1 node to interface with j divided by distance between nodes + w_m1 = (zi_soi(j-1) - z_soi(j-1)) / dz_node(j) + IF ( diffus(j-1) > 0._r8 .and. diffus(j) > 0._r8) THEN + d_m1 = 1._r8 / ((1._r8 - w_m1) / diffus(j) + w_m1 / diffus(j-1)) ! Harmonic mean of diffus + ELSE + d_m1 = 0._r8 + ENDIF + w_p1 = (z_soi(j+1) - zi_soi(j)) / dz_node(j+1) + IF ( diffus(j+1) > 0._r8 .and. diffus(j) > 0._r8) THEN + d_p1 = 1._r8 / ((1._r8 - w_p1) / diffus(j) + w_p1 / diffus(j+1)) ! Harmonic mean of diffus + ELSE + d_p1 = (1._r8 - w_p1) * diffus(j) + w_p1 * diffus(j+1) ! Arithmetic mean of diffus + ENDIF + d_m1_zm1(j) = d_m1 / dz_node(j) + d_p1_zp1(j) = d_p1 / dz_node(j+1) + f_m1(j) = adv_flux(j) + f_p1(j) = adv_flux(j+1) + pe_m1(j) = f_m1(j) / d_m1_zm1(j) ! Peclet # + pe_p1(j) = f_p1(j) / d_p1_zp1(j) ! Peclet # + ENDIF + ENDDO ! j; nl_soil + + ! Calculate the tridiagonal coefficients + DO j = 0,nl_soil +1 + + IF (j > 0 .and. j < nl_soil+1) THEN + a_p_0 = dz_soi(j) / deltim + ENDIF + + IF (j == 0) THEN ! top layer (atmosphere) + a_tri(j) = 0._r8 + b_tri(j) = 1._r8 + c_tri(j) = -1._r8 + r_tri_c(j) = 0._r8 + r_tri_n(j) = 0._r8 + ELSEIF (j == 1) THEN + a_tri(j) = -(d_m1_zm1(j) * aaa(pe_m1(j)) + max( f_m1(j), 0._r8)) ! Eqn 5.47 Patankar + c_tri(j) = -(d_p1_zp1(j) * aaa(pe_p1(j)) + max(-f_p1(j), 0._r8)) + b_tri(j) = - a_tri(j) - c_tri(j) + a_p_0 + r_tri_c(j) = decomp_cpools_sourcesink(j,s,i) * dz_soi(j) /deltim + (a_p_0 - adv_flux(j)) * conc_trcr_c(j) + r_tri_n(j) = decomp_npools_sourcesink(j,s,i) * dz_soi(j) /deltim + (a_p_0 - adv_flux(j)) * conc_trcr_n(j) + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + upperVX_c_vr_acc(j,s,i) = upperVX_c_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j+1)! upwards transfer + diagVX_c_vr_acc (j,s,i) = diagVX_c_vr_acc (j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j)! EXIT flux + upperVX_n_vr_acc(j,s,i) = upperVX_n_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j+1)! upwards transfer + diagVX_n_vr_acc (j,s,i) = diagVX_n_vr_acc (j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j)! EXIT flux + ENDIF + ELSEIF (j < nl_soil+1) THEN + + a_tri(j) = -(d_m1_zm1(j) * aaa(pe_m1(j)) + max( f_m1(j), 0._r8)) ! Eqn 5.47 Patankar + c_tri(j) = -(d_p1_zp1(j) * aaa(pe_p1(j)) + max(-f_p1(j), 0._r8)) + b_tri(j) = - a_tri(j) - c_tri(j) + a_p_0 + r_tri_c(j) = decomp_cpools_sourcesink(j,s,i) * dz_soi(j) /deltim + a_p_0 * conc_trcr_c(j) + r_tri_n(j) = decomp_npools_sourcesink(j,s,i) * dz_soi(j) /deltim + a_p_0 * conc_trcr_n(j) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + IF(j .le. nbedrock)THEN + lowerVX_c_vr_acc(j,s,i) = lowerVX_c_vr_acc(j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j-1) + lowerVX_n_vr_acc(j,s,i) = lowerVX_n_vr_acc(j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j-1) + IF(j .ne. nl_soil)THEN + upperVX_c_vr_acc(j,s,i) = upperVX_c_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j+1) + upperVX_n_vr_acc(j,s,i) = upperVX_n_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j+1) + diagVX_c_vr_acc(j,s,i) = diagVX_c_vr_acc(j,s,i) + (b_tri(j) - a_p_0) / dz_soi(j) * deltim * conc_trcr_c(j) + diagVX_n_vr_acc(j,s,i) = diagVX_n_vr_acc(j,s,i) + (b_tri(j) - a_p_0) / dz_soi(j) * deltim * conc_trcr_n(j) + ELSE + diagVX_c_vr_acc(j,s,i) = diagVX_c_vr_acc (j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j) + diagVX_n_vr_acc(j,s,i) = diagVX_n_vr_acc (j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j) + ENDIF + ELSE + IF(j .eq. nbedrock + 1 .and. j .ne. nl_soil .and. j .gt. 1)THEN + diagVX_c_vr_acc(j-1,s,i) = diagVX_c_vr_acc(j-1,s,i) + a_tri(j) / dz_soi(j-1) * deltim * conc_trcr_c(j-1) + diagVX_n_vr_acc(j-1,s,i) = diagVX_n_vr_acc(j-1,s,i) + a_tri(j) / dz_soi(j-1) * deltim * conc_trcr_n(j-1) + ENDIF + ENDIF + ENDIF + ELSE ! j==nl_soil+1; 0 concentration gradient at bottom + a_tri(j) = -1._r8 + b_tri(j) = 1._r8 + c_tri(j) = 0._r8 + r_tri_c(j) = 0._r8 + r_tri_n(j) = 0._r8 + ENDIF + ENDDO ! j; nl_soil + + jtop = 0 + + ! subtract initial concentration and source terms for tendency calculation + DO j = 1, nl_soil + decomp_cpools_transport_tendency(j,s,i) = 0.-(conc_trcr_c(j) + decomp_cpools_sourcesink(j,s,i)) + decomp_npools_transport_tendency(j,s,i) = 0.-(conc_trcr_n(j) + decomp_npools_sourcesink(j,s,i)) + ENDDO + + CALL tridia(nl_soil+2, a_tri (:), b_tri(:), c_tri(:), r_tri_c(:), conc_trcr_c(0:nl_soil+1)) + CALL tridia(nl_soil+2, a_tri (:), b_tri(:), c_tri(:), r_tri_n(:), conc_trcr_n(0:nl_soil+1)) + + ! add post-transport concentration to calculate tendency term + DO j = 1, nl_soil + decomp_cpools_transport_tendency(j,s,i) = decomp_cpools_transport_tendency(j,s,i) + conc_trcr_c(j) + decomp_cpools_transport_tendency(j,s,i) = decomp_cpools_transport_tendency(j,s,i) / deltim + decomp_npools_transport_tendency(j,s,i) = decomp_npools_transport_tendency(j,s,i) + conc_trcr_n(j) + decomp_npools_transport_tendency(j,s,i) = decomp_npools_transport_tendency(j,s,i) / deltim + ENDDO + ELSE + ! for CWD pools, just add + DO j = 1,nl_soil + conc_trcr_c(j) = decomp_cpools_vr(j,s,i) + decomp_cpools_sourcesink(j,s,i) + conc_trcr_n(j) = decomp_npools_vr(j,s,i) + decomp_npools_sourcesink(j,s,i) + IF (j > nbedrock .and. decomp_cpools_sourcesink(j,s,i) > 0._r8) THEN + write(*,*) 'C source >0',i,j,s,decomp_cpools_sourcesink(j,s,i) + ENDIF + IF (j > nbedrock .and. decomp_cpools_vr(j,s,i) > 0._r8) THEN + write(*,*) 'C conc_ptr >0',i,j,s,decomp_cpools_vr(j,s,i) + ENDIF + IF (j > nbedrock .and. decomp_npools_sourcesink(j,s,i) > 0._r8) THEN + write(*,*) 'N source >0',i,j,s,decomp_npools_sourcesink(j,s,i) + ENDIF + IF (j > nbedrock .and. decomp_npools_vr(j,s,i) > 0._r8) THEN + write(*,*) 'N conc_ptr >0',i,j,s,decomp_npools_vr(j,s,i) + ENDIF + ENDDO + ENDIF ! not CWD + + DO j = 1,nl_soil + decomp_cpools_vr(j,s,i) = conc_trcr_c(j) + decomp_npools_vr(j,s,i) = conc_trcr_n(j) + ! Correct for small amounts of carbon that leak into bedrock + IF (j > nbedrock) THEN + decomp_cpools_vr(nbedrock,s,i) = decomp_cpools_vr(nbedrock,s,i) + & + conc_trcr_c(j) * (dz_soi(j) / dz_soi(nbedrock)) + decomp_cpools_vr(j,s,i) = 0._r8 + decomp_npools_vr(nbedrock,s,i) = decomp_npools_vr(nbedrock,s,i) + & + conc_trcr_n(j) * (dz_soi(j) / dz_soi(nbedrock)) + decomp_npools_vr(j,s,i) = 0._r8 + ENDIF + ENDDO + ENDDO ! s (pool loop) + + END SUBROUTINE SoilBiogeochemLittVertTransp + +END MODULE MOD_BGC_Soil_BiogeochemLittVertTransp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 new file mode 100644 index 0000000000..d5f322a15c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 @@ -0,0 +1,167 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_Soil_BiogeochemNLeaching + +!---------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates the soil mineral N loss due to leaching. The leaching flux is a function of +! dissolved N concentration and sub-surface drainage flux. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + USE MOD_BGC_Vars_TimeInvariants, only: sf, sf_no3 + USE MOD_Vars_TimeVariables, only: wliq_soisno + USE MOD_BGC_Vars_TimeVariables, only: sminn_vr, smin_no3_vr + USE MOD_Vars_1DFluxes, only: rnof, rsur + USE MOD_BGC_Vars_1DFluxes, only: & + sminn_leached_vr, smin_no3_leached_vr, smin_no3_runoff_vr + + IMPLICIT NONE + + PUBLIC SoilBiogeochemNLeaching + +CONTAINS + + SUBROUTINE SoilBiogeochemNLeaching(i,deltim,nl_soil,zi_soi,dz_soi) + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: zi_soi(0:nl_soil) ! interface level below a zsoi level (m) + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + + integer :: j ! indices + real(r8) :: disn_conc ! dissolved mineral N concentration (gN/kg water) + real(r8) :: tot_water ! total column liquid water (kg water/m2) + real(r8) :: surface_water ! liquid water to shallow surface depth (kg water/m2) + real(r8) :: drain_tot ! total drainage flux (mm H2O /s) + real(r8), parameter :: depth_runoff_Nloss = 0.05 ! (m) depth over which runoff mixes with soil water for N loss to runoff + + ! calculate the total soil water + tot_water = 0._r8 + DO j = 1,nl_soil + tot_water = tot_water + wliq_soisno(j,i) + ENDDO + + ! for runoff calculation; calculate total water to a given depth + surface_water = 0._r8 + DO j = 1,nl_soil + IF ( zi_soi(j) <= depth_runoff_Nloss) THEN + surface_water = surface_water + wliq_soisno(j,i) + elseif ( zi_soi(j-1) < depth_runoff_Nloss) THEN + surface_water = surface_water + wliq_soisno(j,i) * ( (depth_runoff_Nloss - zi_soi(j-1)) / dz_soi(j)) + ENDIF + ENDDO + + ! Loop through columns + drain_tot = rnof(i) - rsur(i) + + + IF(.not. DEF_USE_NITRIF)THEN + !---------------------------------------- + ! --------- NITRIF_NITRIF OFF------------ + !---------------------------------------- + DO j = 1,nl_soil + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + IF (wliq_soisno(j,i) > 0._r8) THEN + disn_conc = (sf * sminn_vr(j,i) * dz_soi(j) )/(wliq_soisno(j,i) ) + ENDIF + + ! calculate the N leaching flux as a FUNCTION of the dissolved + ! concentration and the sub-surface drainage flux + IF(tot_water > 0._r8)THEN + sminn_leached_vr(j,i) = disn_conc * drain_tot * wliq_soisno(j,i) / ( tot_water * dz_soi(j) ) + ELSE + sminn_leached_vr(j,i) = 0._r8 + ENDIF + + ! limit the flux based on current sminn state + ! only let at most the assumed soluble fraction + ! of sminn be leached on any given timestep + sminn_leached_vr(j,i) = min(sminn_leached_vr(j,i), (sf * sminn_vr(j,i))/deltim) + + ! limit the flux to a positive value + sminn_leached_vr(j,i) = max(sminn_leached_vr(j,i), 0._r8) + + ENDDO + + ELSE + + !---------------------------------------- + ! --------- NITRIF_NITRIF ON------------- + !---------------------------------------- + + DO j = 1,nl_soil + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + IF (wliq_soisno(j,i) > 0._r8) THEN + disn_conc = (sf_no3 * smin_no3_vr(j,i) * dz_soi(j) )/(wliq_soisno(j,i) ) + ENDIF + ! + ! calculate the N leaching flux as a FUNCTION of the dissolved + ! concentration and the sub-surface drainage flux + IF(tot_water > 0._r8)THEN + smin_no3_leached_vr(j,i) = disn_conc * drain_tot * wliq_soisno(j,i) / ( tot_water * dz_soi(j) ) + ELSE + smin_no3_leached_vr(j,i) = 0._r8 + ENDIF + ! + ! ensure that leaching rate isn't larger than soil N pool + smin_no3_leached_vr(j,i) = min(smin_no3_leached_vr(j,i), smin_no3_vr(j,i) / deltim ) + ! + ! limit the leaching flux to a positive value + smin_no3_leached_vr(j,i) = max(smin_no3_leached_vr(j,i), 0._r8) + ! + ! + ! calculate the N loss from surface runoff, assuming a shallow mixing of surface waters into soil and removal based on runoff + IF ( zi_soi(j) <= depth_runoff_Nloss ) THEN + IF(surface_water > 0._r8)THEN + smin_no3_runoff_vr(j,i) = disn_conc * rsur(i) * & + wliq_soisno(j,i) / ( surface_water * dz_soi(j) ) + ELSE + smin_no3_runoff_vr(j,i) = 0._r8 + ENDIF + ELSEIF ( zi_soi(j-1) < depth_runoff_Nloss ) THEN + IF(surface_water > 0._r8)THEN + smin_no3_runoff_vr(j,i) = disn_conc * rsur(i) * & + wliq_soisno(j,i) * ((depth_runoff_Nloss - zi_soi(j-1)) / & + dz_soi(j)) / ( surface_water * (depth_runoff_Nloss-zi_soi(j-1) )) + ELSE + smin_no3_runoff_vr(j,i) = 0._r8 + ENDIF + ELSE + smin_no3_runoff_vr(j,i) = 0._r8 + ENDIF + ! + ! ensure that runoff rate isn't larger than soil N pool + smin_no3_runoff_vr(j,i) = min(smin_no3_runoff_vr(j,i), smin_no3_vr(j,i) / deltim - smin_no3_leached_vr(j,i)) + ! + ! limit the flux to a positive value + smin_no3_runoff_vr(j,i) = max(smin_no3_runoff_vr(j,i), 0._r8) + + + ! limit the flux based on current smin_no3 state + ! only let at most the assumed soluble fraction + ! of smin_no3 be leached on any given timestep + smin_no3_leached_vr(j,i) = min(smin_no3_leached_vr(j,i), (sf_no3 * smin_no3_vr(j,i))/deltim) + + ! limit the flux to a positive value + smin_no3_leached_vr(j,i) = max(smin_no3_leached_vr(j,i), 0._r8) + + ENDDO + ENDIF + + END SUBROUTINE SoilBiogeochemNLeaching + +END MODULE MOD_BGC_Soil_BiogeochemNLeaching +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 new file mode 100644 index 0000000000..aa07e6c7c3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 @@ -0,0 +1,244 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_Soil_BiogeochemNStateUpdate1 + +!--------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Updates soil mineral nitrogen pool sizes. The dynamics of soil mineral nitrogen pool is +! simulated according to fertilisation, nitrogen deposition, biological fixation, plant uptake, +! mineralisation and immobilisation in this module. IF nitrification is activated, nitrate nitrogen +! has a separated pool against ammonium nitrogen pool. Accumulated nitrogen transfer +! network is also recorded for semi-analytic spinup. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record accumulated nitrogen transfer network for semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix, DEF_USE_NITRIF, DEF_USE_CNSOYFIXN + USE MOD_BGC_Vars_TimeInvariants, only: & + ! bgc constants + i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3 + USE MOD_BGC_Vars_TimeInvariants, only: & + receiver_pool, donor_pool, nitrif_n2o_loss_frac + + USE MOD_BGC_Vars_TimeVariables, only: & + ! Mineral nitrogen pools (inout) + sminn_vr , smin_nh4_vr , smin_no3_vr , & + ndep_prof , nfixation_prof , & + AKX_met_to_soil1_n_vr_acc , AKX_cel_to_soil1_n_vr_acc , AKX_lig_to_soil2_n_vr_acc , AKX_soil1_to_soil2_n_vr_acc, & + AKX_cwd_to_cel_n_vr_acc , AKX_cwd_to_lig_n_vr_acc , AKX_soil1_to_soil3_n_vr_acc, AKX_soil2_to_soil1_n_vr_acc, & + AKX_soil2_to_soil3_n_vr_acc, AKX_soil3_to_soil1_n_vr_acc, & + AKX_met_exit_n_vr_acc , AKX_cel_exit_n_vr_acc , AKX_lig_exit_n_vr_acc , AKX_cwd_exit_n_vr_acc , & + AKX_soil1_exit_n_vr_acc , AKX_soil2_exit_n_vr_acc , AKX_soil3_exit_n_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + ! Decomposition fluxes variables (inout) + decomp_npools_sourcesink, decomp_ntransfer_vr , decomp_sminn_flux_vr , sminn_to_denit_decomp_vr, & + gross_nmin_vr , actual_immob_nh4_vr , actual_immob_no3_vr , & + sminn_to_plant_vr , smin_nh4_to_plant_vr , smin_no3_to_plant_vr , supplement_to_sminn_vr, & + sminn_to_plant_fun_vr , sminn_to_plant_fun_nh4_vr, sminn_to_plant_fun_no3_vr, & + sminn_to_denit_excess_vr, f_nit_vr , f_denit_vr , soyfixn_to_sminn, & + ndep_to_sminn , ffix_to_sminn , nfix_to_sminn , fert_to_sminn + USE MOD_SPMD_Task + + IMPLICIT NONE + + PUBLIC SoilBiogeochemNStateUpdate1 + +CONTAINS + + SUBROUTINE SoilBiogeochemNStateUpdate1(i,deltim,nl_soil,ndecomp_transitions,dz_soi) + + integer ,intent(in) :: i ! patch idnex + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_transitions! number of total transfers between soil and litter pools in the decomposition + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + + integer j,k + real(r8):: sminflux,minerflux + + IF(.not. DEF_USE_NITRIF)THEN + DO j = 1, nl_soil + ! N deposition and fixation + sminn_vr(j,i) = sminn_vr(j,i) + ndep_to_sminn(i)*deltim * ndep_prof(j,i) + sminn_vr(j,i) = sminn_vr(j,i) + nfix_to_sminn(i)*deltim * nfixation_prof(j,i) + ENDDO + ELSE + DO j = 1, nl_soil + ! N deposition and fixation (put all into NH4 pool) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + ndep_to_sminn(i)*deltim * ndep_prof(j,i) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + nfix_to_sminn(i)*deltim * nfixation_prof(j,i) + ENDDO + ENDIF + + ! repeating N dep and fixation for crops +#ifdef CROP + IF(.not. DEF_USE_NITRIF)THEN + DO j = 1, nl_soil + ! column loop + ! N deposition and fixation + sminn_vr(j,i) = sminn_vr(j,i) & + + fert_to_sminn(i) * deltim * ndep_prof(j,i) + ENDDO + IF(DEF_USE_CNSOYFIXN)THEN + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) & + + soyfixn_to_sminn(i) * deltim * nfixation_prof(j,i) + ENDDO + ENDIF + ELSE + DO j = 1, nl_soil + ! N deposition and fixation (put all into NH4 pool) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) & + + fert_to_sminn(i) * deltim * ndep_prof(j,i) + ENDDO + IF(DEF_USE_CNSOYFIXN)THEN + DO j = 1, nl_soil + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) & + + soyfixn_to_sminn(i) * deltim * nfixation_prof(j,i) + ENDDO + ENDIF + ENDIF +#endif + + ! decomposition fluxes + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + decomp_npools_sourcesink(j,donor_pool(k),i) = & + decomp_npools_sourcesink(j,donor_pool(k),i) - & + decomp_ntransfer_vr(j,k,i) * deltim + ENDDO + ENDDO + + + DO k = 1, ndecomp_transitions + IF ( receiver_pool(k) /= 0 ) THEN ! skip terminal transitions + DO j = 1, nl_soil + decomp_npools_sourcesink(j,receiver_pool(k),i) = & + decomp_npools_sourcesink(j,receiver_pool(k),i) + & + (decomp_ntransfer_vr(j,k,i) + & + decomp_sminn_flux_vr(j,k,i)) * deltim + ENDDO + ELSE ! terminal transitions + DO j = 1, nl_soil + decomp_npools_sourcesink(j,donor_pool(k),i) = & + decomp_npools_sourcesink(j,donor_pool(k),i) - & + decomp_sminn_flux_vr(j,k,i) * deltim + ENDDO + ENDIF + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j = 1, nl_soil + AKX_met_to_soil1_n_vr_acc (j,i) = AKX_met_to_soil1_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 1,i) + decomp_sminn_flux_vr(j, 1,i)) * deltim + AKX_cel_to_soil1_n_vr_acc (j,i) = AKX_cel_to_soil1_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 2,i) + decomp_sminn_flux_vr(j, 2,i)) * deltim + AKX_lig_to_soil2_n_vr_acc (j,i) = AKX_lig_to_soil2_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 3,i) + decomp_sminn_flux_vr(j, 3,i)) * deltim + AKX_soil1_to_soil2_n_vr_acc(j,i) = AKX_soil1_to_soil2_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 4,i) + decomp_sminn_flux_vr(j, 4,i)) * deltim + AKX_cwd_to_cel_n_vr_acc (j,i) = AKX_cwd_to_cel_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 5,i) + decomp_sminn_flux_vr(j, 5,i)) * deltim + AKX_cwd_to_lig_n_vr_acc (j,i) = AKX_cwd_to_lig_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 6,i) + decomp_sminn_flux_vr(j, 6,i)) * deltim + AKX_soil1_to_soil3_n_vr_acc(j,i) = AKX_soil1_to_soil3_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 7,i) + decomp_sminn_flux_vr(j, 7,i)) * deltim + AKX_soil2_to_soil1_n_vr_acc(j,i) = AKX_soil2_to_soil1_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 8,i) + decomp_sminn_flux_vr(j, 8,i)) * deltim + AKX_soil2_to_soil3_n_vr_acc(j,i) = AKX_soil2_to_soil3_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 9,i) + decomp_sminn_flux_vr(j, 9,i)) * deltim + AKX_soil3_to_soil1_n_vr_acc(j,i) = AKX_soil3_to_soil1_n_vr_acc(j,i) + (decomp_ntransfer_vr(j,10,i) + decomp_sminn_flux_vr(j,10,i)) * deltim + + AKX_met_exit_n_vr_acc (j,i) = AKX_met_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 1,i) * deltim + AKX_cel_exit_n_vr_acc (j,i) = AKX_cel_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 2,i) * deltim + AKX_lig_exit_n_vr_acc (j,i) = AKX_lig_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 3,i) * deltim + AKX_soil1_exit_n_vr_acc (j,i) = AKX_soil1_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 4,i) * deltim + AKX_cwd_exit_n_vr_acc (j,i) = AKX_cwd_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 5,i) * deltim + AKX_cwd_exit_n_vr_acc (j,i) = AKX_cwd_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 6,i) * deltim + AKX_soil1_exit_n_vr_acc (j,i) = AKX_soil1_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 7,i) * deltim + AKX_soil2_exit_n_vr_acc (j,i) = AKX_soil2_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 8,i) * deltim + AKX_soil2_exit_n_vr_acc (j,i) = AKX_soil2_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 9,i) * deltim + AKX_soil3_exit_n_vr_acc (j,i) = AKX_soil3_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j,10,i) * deltim + ENDDO + ENDIF + + IF(.not. DEF_USE_NITRIF)THEN + + !-------------------------------------------------------- + !------------- NITRIF_DENITRIF OFF ------------------- + !-------------------------------------------------------- + + ! immobilization/mineralization in litter-to-SOM and SOM-to-SOM fluxes and denitrification fluxes + DO k = 1, ndecomp_transitions + IF ( receiver_pool(k) /= 0 ) THEN ! skip terminal transitions + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) - & + (sminn_to_denit_decomp_vr(j,k,i) + & + decomp_sminn_flux_vr(j,k,i))* deltim + ENDDO + ELSE + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) - & + sminn_to_denit_decomp_vr(j,k,i)* deltim + + sminn_vr(j,i) = sminn_vr(j,i) + & + decomp_sminn_flux_vr(j,k,i)* deltim + + ENDDO + ENDIF + ENDDO + + + DO j = 1, nl_soil + ! "bulk denitrification" + sminn_vr(j,i) = sminn_vr(j,i) - sminn_to_denit_excess_vr(j,i) * deltim + + ! total plant uptake from mineral N + sminn_vr(j,i) = sminn_vr(j,i) - sminn_to_plant_vr(j,i)*deltim + ! flux that prevents N limitation (when Carbon_only is set) + sminn_vr(j,i) = sminn_vr(j,i) + supplement_to_sminn_vr(j,i)*deltim + ENDDO + + ELSE + + !-------------------------------------------------------- + !------------- NITRIF_DENITRIF ON -------------------- + !-------------------------------------------------------- + + DO j = 1, nl_soil + + ! mineralization fluxes (divert a fraction of this stream to nitrification flux, add the rest to NH4 pool) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + gross_nmin_vr(j,i)*deltim + + ! immobilization fluxes + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) - actual_immob_nh4_vr(j,i)*deltim + + smin_no3_vr(j,i) = smin_no3_vr(j,i) - actual_immob_no3_vr(j,i)*deltim + + ! plant uptake fluxes + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) - smin_nh4_to_plant_vr(j,i)*deltim + + smin_no3_vr(j,i) = smin_no3_vr(j,i) - smin_no3_to_plant_vr(j,i)*deltim + + + ! Account for nitrification fluxes + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) - f_nit_vr(j,i) * deltim + + smin_no3_vr(j,i) = smin_no3_vr(j,i) + f_nit_vr(j,i) * deltim & + * (1._r8 - nitrif_n2o_loss_frac) + + ! Account for denitrification fluxes + smin_no3_vr(j,i) = smin_no3_vr(j,i) - f_denit_vr(j,i) * deltim + + ! flux that prevents N limitation (when Carbon_only is set; put all into NH4) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + supplement_to_sminn_vr(j,i)*deltim + + ! update diagnostic total + sminn_vr(j,i) = smin_nh4_vr(j,i) + smin_no3_vr(j,i) + + ENDDO + + ENDIF + + END SUBROUTINE SoilBiogeochemNStateUpdate1 + +END MODULE MOD_BGC_Soil_BiogeochemNStateUpdate1 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 new file mode 100644 index 0000000000..54a1f5ec02 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 @@ -0,0 +1,186 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemNitrifDenitrif + +!-------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the potential nitrification and dentrification rate. +! +! !REFERENCES: +! Parton, W. et al. 1996. Generalized model for N2 and N2O production from nitrification and +! denitrification. Global Biogeochemical Cycles 10(3):401-412. +! Parton, W.J. et al. 2001. Generalized model for NOx and N2O emissions from soils. J. Geophys. Res. +! 106(D15):17403-17419 +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_Vars_TimeVariables, only: t_soisno, wliq_soisno, wice_soisno, t_scalar, w_scalar, smp + USE MOD_Vars_TimeInvariants, only: & + porsl, wfc, bsw, BD_all, OM_density + + USE MOD_BGC_Vars_TimeInvariants, only: & + surface_tension_water, rij_kro_a, rij_kro_alpha, rij_kro_beta, rij_kro_gamma, rij_kro_delta, organic_max, & + k_nitr_max, d_con_g21, d_con_g22, d_con_w21, d_con_w22, d_con_w23, & + denit_resp_coef, denit_resp_exp, denit_nitrate_coef, denit_nitrate_exp + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition carbon & nitrogen pools + to2_decomp_depth_unsat, tconc_o2_unsat, smin_nh4_vr, smin_no3_vr + + + ! other variables + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition fluxes variables + + ! mineral N fluxes + phr_vr, pot_f_nit_vr, pot_f_denit_vr, n2_n2o_ratio_denit_vr + + IMPLICIT NONE + + PUBLIC SoilBiogeochemNitrifDenitrif + +CONTAINS + + SUBROUTINE SoilBiogeochemNitrifDenitrif(i,nl_soil,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi (1:nl_soil) ! thicknesses of each soil layer (m) + + integer j + + real(r8) :: soil_hr_vr ! total soil respiration rate (g C / m3 / s) + real(r8) :: soil_bulkdensity + real(r8) :: g_per_m3__to__ug_per_gsoil + real(r8) :: g_per_m3_sec__to__ug_per_gsoil_day + real(r8) :: pH + real(r8) :: eps + real(r8) :: f_a + real(r8) :: rho_w = 1.e3_r8 ! (kg/m3) + real(r8) :: r_max + real(r8) :: r_min(1:nl_soil), r_psi(1:nl_soil) + real(r8) :: ratio_diffusivity_water_gas(1:nl_soil) + real(r8) :: om_frac + real(r8) :: diffus + real(r8) :: vol_ice, vol_liq, eff_porosity, anaerobic_frac + real(r8) :: k_nitr_t_vr, k_nitr_ph_vr, k_nitr_h2o_vr, k_nitr_vr + real(r8) :: smin_no3_massdens_vr, soil_co2_prod, fmax_denit_carbonsubstrate_vr, fmax_denit_nitrate_vr + real(r8) :: f_denit_base_vr, ratio_k1, ratio_no3_co2, wfps_vr, fr_WFPS + real(r8),parameter :: PI = 4.*atan(1.) + + pH = 6.5 + + DO j = 1, nl_soil + + f_a = 1._r8 - wfc(j,i) / porsl(j,i) + eps = porsl(j,i)-wfc(j,i) ! Air-filled fraction of total soil volume + + ! use diffusivity calculation including peat + IF (organic_max > 0._r8) THEN + om_frac = min(OM_density(j,i)/organic_max, 1._r8) + ! Use first power, not square as in iniTimeConst + ELSE + om_frac = 1._r8 + ENDIF + diffus = (d_con_g21 + d_con_g22*t_soisno(j,i)) * 1.e-4_r8 * & + (om_frac * f_a**(10._r8/3._r8) / porsl(j,i)**2 + & + (1._r8-om_frac) * eps**2 * f_a**(3._r8 / bsw(j,i)) ) + + ! calculate anoxic fraction of soils + ! use rijtema and kroess model after Riley et al., 2000 + ! caclulated r_psi as a FUNCTION of psi + r_min(j) = 2 * surface_tension_water / (rho_w * 9.80616_r8 * amax1(abs(smp(j,i) * 1.e-5_r8),1.e-10)) + r_max = 2 * surface_tension_water / (rho_w * 9.80616_r8 * 0.1_r8) + r_psi(j) = sqrt(r_min(j) * r_max) + ratio_diffusivity_water_gas(j) = (d_con_g21 + d_con_g22*t_soisno(j,i) ) * 1.e-4_r8 / & + ((d_con_w21 + d_con_w22*t_soisno(j,i) + d_con_w23*t_soisno(j,i)**2) * 1.e-9_r8) + + vol_ice = min(porsl(j,i), wice_soisno(j,i)/(dz_soi(j)*denice)) + eff_porosity = max(0.01, porsl(j,i)-vol_ice) + vol_liq = min(eff_porosity, wliq_soisno(j,i)/(dz_soi(j)*denh2o)) + IF (to2_decomp_depth_unsat(j,i) > 0._r8) THEN + anaerobic_frac = exp(-rij_kro_a * r_psi(j)**(-rij_kro_alpha) * & + to2_decomp_depth_unsat(j,i)**(-rij_kro_beta) * & + tconc_o2_unsat(j,i)**rij_kro_gamma * (vol_liq + ratio_diffusivity_water_gas(j) * & + porsl(j,i))**rij_kro_delta) + ELSE + anaerobic_frac = 0._r8 + ENDIF + + k_nitr_t_vr = min(t_scalar(j,i), 1._r8) + + ! ph function from Parton et al., (2001, 1996) + k_nitr_ph_vr = 0.56 + atan(PI * 0.45 * (-5.+ pH))/PI + + ! moisture function-- assume the same moisture function as limits heterotrophic respiration + ! Parton et al. base their nitrification- soil moisture rate constants based on heterotrophic rates-- can we DO the same? + k_nitr_h2o_vr = w_scalar(j,i) + + ! nitrification constant is a set scalar * temp, moisture, and ph scalars + k_nitr_vr = k_nitr_max * k_nitr_t_vr * k_nitr_h2o_vr * k_nitr_ph_vr + + ! first-order decay of ammonium pool with scalar defined above + pot_f_nit_vr(j,i) = max(smin_nh4_vr(j,i) * k_nitr_vr, 0._r8) + + ! limit to oxic fraction of soils + pot_f_nit_vr(j,i) = pot_f_nit_vr(j,i) * (1._r8 - anaerobic_frac) + + !---------------- denitrification + ! first some input variables an unit conversions + soil_hr_vr = phr_vr(j,i) + + ! CENTURY papers give denitrification in units of per gram soil; need to convert from volumetric to mass-based units here + soil_bulkdensity = BD_all(j,i) + wliq_soisno(j,i)/dz_soi(j) + + g_per_m3__to__ug_per_gsoil = 1.e3_r8 / soil_bulkdensity + + g_per_m3_sec__to__ug_per_gsoil_day = g_per_m3__to__ug_per_gsoil * 86400._r8 + + smin_no3_massdens_vr = max(smin_no3_vr(j,i), 0._r8) * g_per_m3__to__ug_per_gsoil + + soil_co2_prod = (soil_hr_vr * (g_per_m3_sec__to__ug_per_gsoil_day)) + + !! maximum potential denitrification rates based on heterotrophic respiration rates or nitrate concentrations, + !! from (del Grosso et al., 2000) + fmax_denit_carbonsubstrate_vr = (denit_resp_coef * (soil_co2_prod**denit_resp_exp)) & + / g_per_m3_sec__to__ug_per_gsoil_day + ! + fmax_denit_nitrate_vr = (denit_nitrate_coef * smin_no3_massdens_vr**denit_nitrate_exp) & + / g_per_m3_sec__to__ug_per_gsoil_day + + ! find limiting denitrification rate + f_denit_base_vr = max(min(fmax_denit_carbonsubstrate_vr, fmax_denit_nitrate_vr),0._r8) + + ! limit to anoxic fraction of soils + pot_f_denit_vr(j,i) = f_denit_base_vr * anaerobic_frac + + ! now calculate the ratio of N2O to N2 from denitrifictaion, following Del Grosso et al., 2000 + ! diffusivity constant (figure 6b) + ratio_k1 = max(1.7_r8, 38.4_r8 - 350._r8 * diffus) + + ! ratio function (figure 7c) + IF ( soil_co2_prod > 1.0e-9_r8 ) THEN + ratio_no3_co2 = smin_no3_massdens_vr / soil_co2_prod + ELSE + ! fucntion saturates at large no3/co2 ratios, so set as some nominally large number + ratio_no3_co2 = 100._r8 + ENDIF + + ! total water limitation function (Del Grosso et al., 2000, figure 7a) + wfps_vr = max(min(vol_liq/porsl(j,i), 1._r8), 0._r8) * 100._r8 + fr_WFPS = max(0.1_r8, 0.015_r8 * wfps_vr - 0.32_r8) + + ! final ratio expression + n2_n2o_ratio_denit_vr(j,i) = max(0.16*ratio_k1, ratio_k1*exp(-0.8 * ratio_no3_co2)) * fr_WFPS + + ENDDO + END SUBROUTINE SoilBiogeochemNitrifDenitrif +END MODULE MOD_BGC_Soil_BiogeochemNitrifDenitrif +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 new file mode 100644 index 0000000000..e65bdc2177 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 @@ -0,0 +1,150 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemPotential + +!--------------------------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates the potential C exit flux and the potential N immobilisation and mineralisation flux. The potential C exit flux +! (p_decomp_cpool_loss) equals the product of donor C pool size (decomp_cpools_vr) and transfer pathway fraction (pathfrac_decomp). +! The potential N immobilisation and mineralisation flux (pmnf_decomp) equals: +! the receiver's N demand to immobalize new carbon (p_decomp_cpool_loss * (1 - rf_decomp)/cn_decomp_pools(receiver)) minus actual N +! transfer (p_decomp_cpool_loss * cn_decomp_pools(donor)) +! p_decomp_cpool_loss and pmnf_decomp are THEN used in bgc_soil_SoilBiogeochemDecompMod.F90 +! +! !REFERENCES: +! Thornton, P.E., Law, B.E., Gholz, H.L., Clark, K.L., Falge, E., Ellsworth, D.S., Goldstein, A.H., Monson, +! R.K., Hollinger, D., Falk, M. and Chen, J., 2002. Modeling and measuring the effects of disturbance +! history and climate on carbon and water budgets in evergreen needleleaf forests. +! Agricultural and forest meteorology, 113(1-4), 185-222. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_BGC_Vars_TimeInvariants, only: & + floating_cn_ratio, initial_cn_ratio, rf_decomp, receiver_pool, donor_pool, i_atm, pathfrac_decomp + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition carbon & nitrogen pools + decomp_cpools_vr, decomp_npools_vr, decomp_k, & + + ! other variables + cn_decomp_pools + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition fluxes variables + pmnf_decomp, p_decomp_cpool_loss, gross_nmin_vr, & + + ! mineral N fluxes + potential_immob_vr, phr_vr + + + IMPLICIT NONE + + PUBLIC SoilBiogeochemPotential + +CONTAINS + + SUBROUTINE SoilBiogeochemPotential(i,nl_soil,ndecomp_pools,ndecomp_transitions) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer ,intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + + integer j,k,l + real(r8) immob(1:nl_soil) + real(r8) ratio + + p_decomp_cpool_loss(:, :, i) = 0._r8 + pmnf_decomp(:, :, i) = 0._r8 + + ! column loop to calculate potential decomp rates and total immobilization demand + + !! calculate c:n ratios of applicable pools + DO l = 1, ndecomp_pools + IF ( floating_cn_ratio(l) ) THEN + DO j = 1,nl_soil + IF ( decomp_npools_vr(j,l,i) > 0._r8 ) THEN + cn_decomp_pools(j,l,i) = decomp_cpools_vr(j,l,i) / decomp_npools_vr(j,l,i) + ENDIF + ENDDO + ELSE + DO j = 1,nl_soil + cn_decomp_pools(j,l,i) = initial_cn_ratio(l) + ENDDO + ENDIF + ENDDO + + ! calculate the non-nitrogen-limited fluxes + ! these fluxes include the "/ dt" term to put them on a + ! per second basis, since the rate constants have been + ! calculated on a per timestep basis. + + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + + IF (decomp_cpools_vr(j,donor_pool(k),i) > 0._r8 .and. & + decomp_k(j,donor_pool(k),i) > 0._r8 ) THEN + p_decomp_cpool_loss(j,k,i) = decomp_cpools_vr(j,donor_pool(k),i) & + * decomp_k(j,donor_pool(k),i) * pathfrac_decomp(j,k,i) + IF ( .not. floating_cn_ratio(receiver_pool(k)) ) THEN !! not transition of cwd to litter + + IF (receiver_pool(k) /= i_atm ) THEN ! not 100% respiration + ratio = 0._r8 + + IF (decomp_npools_vr(j,donor_pool(k),i) > 0._r8) THEN + ratio = cn_decomp_pools(j,receiver_pool(k),i)/cn_decomp_pools(j,donor_pool(k),i) + ENDIF + + pmnf_decomp(j,k,i) = (p_decomp_cpool_loss(j,k,i) * (1.0_r8 - rf_decomp(j,k,i) - ratio) & + / cn_decomp_pools(j,receiver_pool(k),i) ) + + ELSE ! 100% respiration + pmnf_decomp(j,k,i) = - p_decomp_cpool_loss(j,k,i) / cn_decomp_pools(j,donor_pool(k),i) + ENDIF + + ELSE ! CWD -> litter + pmnf_decomp(j,k,i) = 0._r8 + ENDIF + ENDIF + + ENDDO + ENDDO + + ! Sum up all the potential immobilization fluxes (positive pmnf flux) + ! and all the mineralization fluxes (negative pmnf flux) + DO j = 1,nl_soil + immob(j) = 0._r8 + ENDDO + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + IF (pmnf_decomp(j,k,i) > 0._r8) THEN + immob(j) = immob(j) + pmnf_decomp(j,k,i) + ELSE + gross_nmin_vr(j,i) = gross_nmin_vr(j,i) - pmnf_decomp(j,k,i) + ENDIF + ENDDO + ENDDO + + DO j = 1,nl_soil + potential_immob_vr(j,i) = immob(j) + ENDDO + + ! Add up potential hr for methane calculations + DO j = 1,nl_soil + phr_vr(j,i) = 0._r8 + ENDDO + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + phr_vr(j,i) = phr_vr(j,i) + rf_decomp(j,k,i) * p_decomp_cpool_loss(j,k,i) + ENDDO + ENDDO + + END SUBROUTINE SoilBiogeochemPotential + +END MODULE MOD_BGC_Soil_BiogeochemPotential +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 new file mode 100644 index 0000000000..b255dfe366 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 @@ -0,0 +1,237 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemVerticalProfile + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! This MODULE calculate soil vertical profile of different C and N inputs, including: +! nitrogen fixation, nitrogen deposition, fine root litter, coarse root litter, +! leaf litter and stem litter. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + + USE MOD_Precision + USE MOD_Const_PFT, only: rootfr_p + USE MOD_BGC_Vars_TimeVariables, only: & + nfixation_prof, ndep_prof, altmax_lastyear_indx, w_scalar + USE MOD_Vars_TimeVariables, only: t_soisno + USE MOD_BGC_Vars_PFTimeVariables, only: & + leaf_prof_p, froot_prof_p, croot_prof_p, stem_prof_p, cinput_rootfr_p + USE MOD_Vars_PFTimeInvariants, only: & + pftclass, pftfrac + IMPLICIT NONE + + PUBLIC SoilBiogeochemVerticalProfile + + real(r8), PUBLIC :: surfprof_exp = 10. ! how steep profile is for surface components (1/ e_folding depth) (1/m) + +CONTAINS + + SUBROUTINE SoilBiogeochemVerticalProfile(i,ps,pe,nl_soil,nl_soil_full,nbedrock,zmin_bedrock,z_soi,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: nl_soil_full ! number of total soil layers plus bedrock layers + integer ,intent(in) :: nbedrock ! where bedrock layer starts (ith soil layer) + real(r8),intent(in) :: zmin_bedrock ! depth where bedrock layer starts (m) + real(r8),intent(in) :: z_soi (1:nl_soil_full) ! depth of each soil layer (m) + real(r8),intent(in) :: dz_soi(1:nl_soil_full) ! thicknesses of each soil layer (m) + + ! !LOCAL VARIABLES: + real(r8) :: surface_prof(1:nl_soil) + real(r8) :: surface_prof_tot + real(r8) :: rootfr_tot + real(r8) :: col_cinput_rootfr(1:nl_soil_full) + integer :: ivt, m + integer :: j + ! debugging temp variables + real(r8) :: froot_prof_sum + real(r8) :: croot_prof_sum + real(r8) :: leaf_prof_sum + real(r8) :: stem_prof_sum + real(r8) :: ndep_prof_sum + real(r8) :: nfixation_prof_sum + real(r8) :: delta = 1.e-10 + real(r8) :: sumprof + + surface_prof(:) = 0._r8 + DO j = 1, nl_soil + surface_prof(j) = exp(-surfprof_exp * z_soi(j)) / dz_soi(j) + IF (z_soi(j) > zmin_bedrock) THEN + surface_prof(j) = 0._r8 + ENDIF + ENDDO + + ! initialize profiles to zero + col_cinput_rootfr(:) = 0._r8 + nfixation_prof (:,i) = 0._r8 + ndep_prof (:,i) = 0._r8 + DO m = ps , pe + ivt = pftclass(m) + leaf_prof_p (:,m) = 0._r8 + froot_prof_p(:,m) = 0._r8 + croot_prof_p(:,m) = 0._r8 + stem_prof_p (:,m) = 0._r8 + + cinput_rootfr_p(:,m) = 0._r8 + + IF (ivt /= 0) THEN + DO j = 1, nl_soil + cinput_rootfr_p(j,m) = rootfr_p(j,ivt) / dz_soi(j) + ENDDO + + ELSE + cinput_rootfr_p(1,m) = 0. + ENDIF + ENDDO + + DO m = ps , pe + ! integrate rootfr over active layer of soil column + rootfr_tot = 0._r8 + surface_prof_tot = 0._r8 + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + rootfr_tot = rootfr_tot + cinput_rootfr_p(j,m) * dz_soi(j) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dz_soi(j) + ENDDO + IF ( (altmax_lastyear_indx(i) > 0) .and. (rootfr_tot > 0._r8) .and. (surface_prof_tot > 0._r8) ) THEN + ! WHERE there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalnet to integrating over all soil layers outside of permafrost regions + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + froot_prof_p(j,m) = cinput_rootfr_p(j,m) / rootfr_tot + croot_prof_p(j,m) = cinput_rootfr_p(j,m) / rootfr_tot + + IF (j > nbedrock .and. cinput_rootfr_p(j,m) > 0._r8) THEN + write(*,*) 'ERROR: cinput_rootfr_p > 0 in bedrock' + ENDIF + ! set all surface processes to shallower profile + leaf_prof_p(j,m) = surface_prof(j)/ surface_prof_tot + stem_prof_p(j,m) = surface_prof(j)/ surface_prof_tot + ENDDO + ELSE + ! IF fully frozen, or no roots, put everything in the top layer + froot_prof_p(1,m) = 1./dz_soi(1) + croot_prof_p(1,m) = 1./dz_soi(1) + leaf_prof_p(1,m) = 1./dz_soi(1) + stem_prof_p(1,m) = 1./dz_soi(1) + ENDIF + DO j = 1, nl_soil + IF(w_scalar(j,i) .eq. 0._r8 .and. t_soisno(j,i) < 273.15_r8)THEN + froot_prof_p(j,m) = 0._r8 + croot_prof_p(j,m) = 0._r8 + stem_prof_p (j,m) = 0._r8 + leaf_prof_p (j,m) = 0._r8 + ENDIF + ENDDO + sumprof = sum(froot_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + froot_prof_p(j,m) = froot_prof_p(j,m) / sumprof + ENDDO + ELSE + froot_prof_p(1,m) = 1./dz_soi(1) + ENDIF + sumprof = sum(croot_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + croot_prof_p(j,m) = croot_prof_p(j,m) / sumprof + ENDDO + ELSE + croot_prof_p(1,m) = 1./dz_soi(1) + ENDIF + sumprof = sum(stem_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + stem_prof_p(j,m) = stem_prof_p(j,m) / sumprof + ENDDO + ELSE + stem_prof_p(1,m) = 1./dz_soi(1) + ENDIF + sumprof = sum(leaf_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + leaf_prof_p(j,m) = leaf_prof_p(j,m) / sumprof + ENDDO + ELSE + leaf_prof_p(1,m) = 1./dz_soi(1) + ENDIF + ENDDO + + + + !! aggregate root profile to column + DO m = ps , pe + DO j = 1,nl_soil + col_cinput_rootfr(j) = col_cinput_rootfr(j) + cinput_rootfr_p(j,m) * pftfrac(m) + ENDDO + ENDDO + + ! repeat for column-native profiles: Ndep and Nfix + rootfr_tot = 0._r8 + surface_prof_tot = 0._r8 + ! redo column ntegration over active layer for column-native profiles + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + rootfr_tot = rootfr_tot + col_cinput_rootfr(j) * dz_soi(j) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dz_soi(j) + ENDDO + IF ( (altmax_lastyear_indx(i) > 0) .and. (rootfr_tot > 0._r8) .and. (surface_prof_tot > 0._r8) ) THEN + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + nfixation_prof(j,i) = col_cinput_rootfr(j) / rootfr_tot + ndep_prof(j,i) = surface_prof(j)/ surface_prof_tot + ENDDO + ELSE + nfixation_prof(1,i) = 1./dz_soi(1) + ndep_prof(1,i) = 1./dz_soi(1) + ENDIF + + ! check to make sure integral of all profiles = 1. + ndep_prof_sum = 0. + nfixation_prof_sum = 0. + DO j = 1, nl_soil + ndep_prof_sum = ndep_prof_sum + ndep_prof(j,i) * dz_soi(j) + nfixation_prof_sum = nfixation_prof_sum + nfixation_prof(j,i) * dz_soi(j) + ENDDO + IF ( ( abs(ndep_prof_sum - 1._r8) > delta ) .or. ( abs(nfixation_prof_sum - 1._r8) > delta ) ) THEN + print*,'i',i,delta + write(*,*) 'profile sums:',ndep_prof_sum-1._r8,nfixation_prof_sum-1._r8 + write(*,*) 'altmax_lastyear_indx: ', altmax_lastyear_indx(i) + write(*,*) 'nfixation_prof: ', nfixation_prof(:,i) + write(*,*) 'ndep_prof: ', ndep_prof(:,i) + write(*,*) 'cinput_rootfr: ', cinput_rootfr_p(:,ps:pe) + write(*,*) 'dz_soi: ', dz_soi(:) + write(*,*) 'surface_prof: ', surface_prof(:) + write(*,*) 'p, itype(p) : ', i, pftclass(ps:pe) + write(*,*) 'cinput_rootfr(p,:): ', cinput_rootfr_p(:,ps:pe) + write(*,*) 'ERROR: _prof_sum-1>delta' + CALL abort() + ENDIF + + DO m = ps , pe + froot_prof_sum = 0. + croot_prof_sum = 0. + leaf_prof_sum = 0. + stem_prof_sum = 0. + DO j = 1, nl_soil + froot_prof_sum = froot_prof_sum + froot_prof_p(j,m) * dz_soi(j) + croot_prof_sum = croot_prof_sum + croot_prof_p(j,m) * dz_soi(j) + leaf_prof_sum = leaf_prof_sum + leaf_prof_p(j,m) * dz_soi(j) + stem_prof_sum = stem_prof_sum + stem_prof_p(j,m) * dz_soi(j) + ENDDO + IF ( ( abs(froot_prof_sum - 1._r8) > delta ) .or. ( abs(croot_prof_sum - 1._r8) > delta ) .or. & + ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) THEN + write(*,*) 'profile sums: ', froot_prof_sum, croot_prof_sum, leaf_prof_sum, stem_prof_sum + write(*,*) ' ERROR: sum-1 > delta' + CALL abort + ENDIF + ENDDO + + END SUBROUTINE SoilBiogeochemVerticalProfile + +END MODULE MOD_BGC_Soil_BiogeochemVerticalProfile +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..79e7a927ba --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 @@ -0,0 +1,740 @@ +#include + +MODULE MOD_BGC_Vars_1DFluxes +#ifdef BGC +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical flux variables at patch level + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + + + USE MOD_Precision + IMPLICIT NONE + SAVE + +!--------------------- BGC variables -------------------------------------- +! ecosystem vegetation carbon/nitrogen flux + real(r8), allocatable :: gpp (:) ! gross primary productivity (gC m-2 s-1) + real(r8), allocatable :: gpp_enftemp (:) ! gross primary productivity for needleleaf evergreen temperate tree (gC m-2 s-1) + real(r8), allocatable :: gpp_enfboreal (:) ! gross primary productivity for needleleaf evergreen boreal tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dnfboreal (:) ! gross primary productivity for needleleaf deciduous boreal tree (gC m-2 s-1) + real(r8), allocatable :: gpp_ebftrop (:) ! gross primary productivity for broadleaf evergreen tropical tree (gC m-2 s-1) + real(r8), allocatable :: gpp_ebftemp (:) ! gross primary productivity for broadleaf evergreen temperate tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dbftrop (:) ! gross primary productivity for broadleaf deciduous tropical tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dbftemp (:) ! gross primary productivity for broadleaf deciduous temperate tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dbfboreal (:) ! gross primary productivity for broadleaf deciduous boreal tree (gC m-2 s-1) + real(r8), allocatable :: gpp_ebstemp (:) ! gross primary productivity for broadleaf evergreen temperate shrub (gC m-2 s-1) + real(r8), allocatable :: gpp_dbstemp (:) ! gross primary productivity for broadleaf deciduous temperate shrub (gC m-2 s-1) + real(r8), allocatable :: gpp_dbsboreal (:) ! gross primary productivity for broadleaf deciduous boreal shrub (gC m-2 s-1) + real(r8), allocatable :: gpp_c3arcgrass (:) ! gross primary productivity for c3 arctic grass (gC m-2 s-1) + real(r8), allocatable :: gpp_c3grass (:) ! gross primary productivity for c3 grass (gC m-2 s-1) + real(r8), allocatable :: gpp_c4grass (:) ! gross primary productivity for c4 grass (gC m-2 s-1) + real(r8), allocatable :: npp_enftemp (:) ! leaf carbon display pool for needleleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npp_enfboreal (:) ! leaf carbon display pool for needleleaf evergreen boreal tree (gC m-2) + real(r8), allocatable :: npp_dnfboreal (:) ! leaf carbon display pool for needleleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npp_ebftrop (:) ! leaf carbon display pool for broadleaf evergreen tropical tree (gC m-2) + real(r8), allocatable :: npp_ebftemp (:) ! leaf carbon display pool for broadleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npp_dbftrop (:) ! leaf carbon display pool for broadleaf deciduous tropical tree (gC m-2) + real(r8), allocatable :: npp_dbftemp (:) ! leaf carbon display pool for broadleaf deciduous temperate tree (gC m-2) + real(r8), allocatable :: npp_dbfboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npp_ebstemp (:) ! leaf carbon display pool for broadleaf evergreen temperate shrub (gC m-2) + real(r8), allocatable :: npp_dbstemp (:) ! leaf carbon display pool for broadleaf deciduous temperate shrub (gC m-2) + real(r8), allocatable :: npp_dbsboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal shrub (gC m-2) + real(r8), allocatable :: npp_c3arcgrass (:) ! leaf carbon display pool for c3 arctic grass (gC m-2) + real(r8), allocatable :: npp_c3grass (:) ! leaf carbon display pool for c3 grass (gC m-2) + real(r8), allocatable :: npp_c4grass (:) ! leaf carbon display pool for c4 grass (gC m-2) + real(r8), allocatable :: npptoleafc_enftemp (:) ! leaf carbon display pool for needleleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npptoleafc_enfboreal (:) ! leaf carbon display pool for needleleaf evergreen boreal tree (gC m-2) + real(r8), allocatable :: npptoleafc_dnfboreal (:) ! leaf carbon display pool for needleleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npptoleafc_ebftrop (:) ! leaf carbon display pool for broadleaf evergreen tropical tree (gC m-2) + real(r8), allocatable :: npptoleafc_ebftemp (:) ! leaf carbon display pool for broadleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npptoleafc_dbftrop (:) ! leaf carbon display pool for broadleaf deciduous tropical tree (gC m-2) + real(r8), allocatable :: npptoleafc_dbftemp (:) ! leaf carbon display pool for broadleaf deciduous temperate tree (gC m-2) + real(r8), allocatable :: npptoleafc_dbfboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npptoleafc_ebstemp (:) ! leaf carbon display pool for broadleaf evergreen temperate shrub (gC m-2) + real(r8), allocatable :: npptoleafc_dbstemp (:) ! leaf carbon display pool for broadleaf deciduous temperate shrub (gC m-2) + real(r8), allocatable :: npptoleafc_dbsboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal shrub (gC m-2) + real(r8), allocatable :: npptoleafc_c3arcgrass (:) ! leaf carbon display pool for c3 arctic grass (gC m-2) + real(r8), allocatable :: npptoleafc_c3grass (:) ! leaf carbon display pool for c3 grass (gC m-2) + real(r8), allocatable :: npptoleafc_c4grass (:) ! leaf carbon display pool for c4 grass (gC m-2) + real(r8), allocatable :: leafc_enftemp (:) ! leaf carbon display pool for needleleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: leafc_enfboreal (:) ! leaf carbon display pool for needleleaf evergreen boreal tree (gC m-2) + real(r8), allocatable :: leafc_dnfboreal (:) ! leaf carbon display pool for needleleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: leafc_ebftrop (:) ! leaf carbon display pool for broadleaf evergreen tropical tree (gC m-2) + real(r8), allocatable :: leafc_ebftemp (:) ! leaf carbon display pool for broadleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: leafc_dbftrop (:) ! leaf carbon display pool for broadleaf deciduous tropical tree (gC m-2) + real(r8), allocatable :: leafc_dbftemp (:) ! leaf carbon display pool for broadleaf deciduous temperate tree (gC m-2) + real(r8), allocatable :: leafc_dbfboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: leafc_ebstemp (:) ! leaf carbon display pool for broadleaf evergreen temperate shrub (gC m-2) + real(r8), allocatable :: leafc_dbstemp (:) ! leaf carbon display pool for broadleaf deciduous temperate shrub (gC m-2) + real(r8), allocatable :: leafc_dbsboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal shrub (gC m-2) + real(r8), allocatable :: leafc_c3arcgrass (:) ! leaf carbon display pool for c3 arctic grass (gC m-2) + real(r8), allocatable :: leafc_c3grass (:) ! leaf carbon display pool for c3 grass (gC m-2) + real(r8), allocatable :: leafc_c4grass (:) ! leaf carbon display pool for c4 grass (gC m-2) + real(r8), allocatable :: ar (:) ! autotrophic respiration (gC m-2 s-1) + real(r8), allocatable :: cwdprod (:) ! CWD production (gC m-2 s-1) + real(r8), allocatable :: cwddecomp (:) ! CWD decomposition (gC m-2 s-1) + real(r8), allocatable :: hr (:) ! heterotrophic respiration (gC m-2 s-1) + real(r8), allocatable :: er (:) ! total ecosystem respiration, autotrophic + heterotrophic (gC m-2 s-1) + real(r8), allocatable :: fire_closs (:) ! total C emissions due to fire (gC m-2 s-1) + real(r8), allocatable :: fire_nloss (:) ! total N emissions due to fire (gN m-2 s-1) + real(r8), allocatable :: hrv_xsmrpool_to_atm (:) ! maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) + real(r8), allocatable :: wood_harvestc (:) ! harvested wood C (gC m-2 s-1) + real(r8), allocatable :: wood_harvestn (:) ! harvested wood N (gN m-2 s-1) + real(r8), allocatable :: grainc_to_cropprodc (:) ! grain to crop production carbon (gC m-2 s-1) + real(r8), allocatable :: grainc_to_seed (:) ! grain to crop seed carbon (gC m-2 s-1) + real(r8), allocatable :: grainn_to_cropprodn (:) ! grain to crop production nitrogen (gN m-2 s-1) + real(r8), allocatable :: cropprod1c_loss (:) ! loss rate of 1-yr crop production carbon (gC m-2 s-1) + + ! decomposition carbon fluxes + real(r8), allocatable :: decomp_cpools_sourcesink (:,:,:) ! vertical resolved: the input of litter & soil carbon pools (donor or receiver) from phenology-associated litterfall and decomposition (gC m-3 timestep-1) + real(r8), allocatable :: decomp_ctransfer_vr (:,:,:) ! vertical resolved: the non-respiratory portion of potential carbon transfer from one litter & soil carbon pool to another (gC m-3 s-1) + real(r8), allocatable :: decomp_hr_vr (:,:,:) ! vertical resolved: the heterotrophic respiration portion of potential carbon loss from one litter & soil carbon pool to another (gC m-3 s-1) + real(r8), allocatable :: decomp_hr (:) ! the heterotrophic respiration portion of potential carbon loss from one decomposition carbon pool to another (gC m-3 s-1) + real(r8), allocatable :: phr_vr (:,:) ! vertical resolved: the potential heterotrophic respiration carbon flux (gC m-3 s-1) + real(r8), allocatable :: m_decomp_cpools_to_fire_vr (:,:,:) ! vertical resolved: the carbon from decomposition pools to fire emissions (gC m-3 s-1) + real(r8), allocatable :: decomp_cpools_transport_tendency(:,:,:) ! vertical resolved: the carbon tendency due to vertical transport in decomposition carbon pools (gC m-3 s-1) + real(r8), allocatable :: som_c_leached (:) ! total soil organic matter C loss from vertical transport (gC m-2 s-1) + + ! vegetation to decomposition carbon fluxes + real(r8), allocatable :: phenology_to_met_c (:,:) ! phenology-associated plant C loss to metabolic litter C (gC m-3 s-1) + real(r8), allocatable :: phenology_to_cel_c (:,:) ! phenology-associated plant C loss to cellulosic litter C (gC m-3 s-1) + real(r8), allocatable :: phenology_to_lig_c (:,:) ! phenology-associated plant C loss to lignin litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_met_c (:,:) ! gap mortality-associated plant C loss to metabolic litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cel_c (:,:) ! gap mortality-associated plant C loss to cellulosic litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_lig_c (:,:) ! gap mortality-associated plant C loss to lignin litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cwdc (:,:) ! gap mortality-associated plant C loss to coarse woody debris C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_met_c (:,:) ! fire mortality-associated plant C loss to metabolic litter C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cel_c (:,:) ! fire mortality-associated plant C loss to cellulosic litter C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_lig_c (:,:) ! fire mortality-associated plant C loss to lignin litter C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cwdc (:,:) ! fire mortality-associated plant C loss to coarse woody debris C (gC m-3 s-1) + + ! decomposition nitrogen fluxes + real(r8), allocatable :: decomp_npools_sourcesink (:,:,:) ! vertical resolved: the the input of litter & soil nitrogen pools (donor or receiver) (gN m-3 timestep) + real(r8), allocatable :: decomp_ntransfer_vr (:,:,:) ! vertical resolved: the nitrogen flux transfer from one litter & soil nitrogen pool to another (gN m-3 s-1) + real(r8), allocatable :: decomp_sminn_flux_vr (:,:,:) ! vertical resolved: the nitrogen mineralization flux from each nitrogen transfer between litter & soil pools (gN m-3 s-1) + real(r8), allocatable :: sminn_to_denit_decomp_vr (:,:,:) ! vertical resolved: the nitrogen denitrification flux from each nitrogen transfer between litter & soil pools (gN m-3 s-1) + real(r8), allocatable :: m_decomp_npools_to_fire_vr (:,:,:) ! vertical resolved: the litter & soil nitrogen loss associated to the fire (gN m-3 s-1) + real(r8), allocatable :: decomp_npools_transport_tendency(:,:,:) ! vertical resolved: the nitrogen tendency due to vertical transport in decomposition nitrogen pools (gN m-3 s-1) + real(r8), allocatable :: som_n_leached (:) ! total soil organic matter N loss from vertical transport (gN m-2 s-1) + + ! vegetation to decomposition nitrogen fluxes + real(r8), allocatable :: phenology_to_met_n (:,:) ! phenology-associated plant N loss to metabolic litter N (gN m-3 s-1) + real(r8), allocatable :: phenology_to_cel_n (:,:) ! phenology-associated plant N loss to cellulosic litter N (gN m-3 s-1) + real(r8), allocatable :: phenology_to_lig_n (:,:) ! phenology-associated plant N loss to lignin litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_met_n (:,:) ! gap mortality-associated plant N loss to metabolic litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cel_n (:,:) ! gap mortality-associated plant N loss to cellulosic litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_lig_n (:,:) ! gap mortality-associated plant N loss to lignin litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cwdn (:,:) ! gap mortality-associated plant N loss to coarse woody debris N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_met_n (:,:) ! fire mortality-associated plant N loss to metabolic litter N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cel_n (:,:) ! fire mortality-associated plant N loss to cellulosic litter N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_lig_n (:,:) ! fire mortality-associated plant N loss to lignin litter N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cwdn (:,:) ! fire mortality-associated plant N loss to coarse woody debris N (gN m-3 s-1) + + real(r8), allocatable :: sminn_leached_vr (:,:) ! vertical resolved: soil mineral N loss due to leaching (gN m-3 s-1) + real(r8), allocatable :: smin_no3_leached_vr (:,:) ! vertical resolved: soil mineral NO3 loss due to leaching (gN m-3 s-1) + real(r8), allocatable :: smin_no3_runoff_vr (:,:) ! vertical resolved: soil mineral NO3 loss due to runoff (gN m-3 s-1) + real(r8), allocatable :: net_nmin_vr (:,:) ! vertical resolved: net N mineralization (gN m-3 s-1) + real(r8), allocatable :: gross_nmin_vr (:,:) ! vertical resolved: total N mineralization (gN m-3 s-1) + real(r8), allocatable :: net_nmin (:) ! net N mineralization (gN m-2 s-1) + real(r8), allocatable :: gross_nmin (:) ! total N mineralization (gN m-2 s-1) + real(r8), allocatable :: plant_ndemand (:) ! potential plant N uptake (gN m-2 s-1) + real(r8), allocatable :: actual_immob_vr (:,:) ! vertical resolved: actual N immobilization (gN m-3 s-1) + real(r8), allocatable :: actual_immob_nh4_vr (:,:) ! vertical resolved: actual NH4 immobilization (gN m-3 s-1) + real(r8), allocatable :: actual_immob_no3_vr (:,:) ! vertical resolved: actual NO3 immobilization (gN m-3 s-1) + real(r8), allocatable :: potential_immob_vr (:,:) ! vertical resolved: potential N immobilization (gN m-3 s-1) + real(r8), allocatable :: pmnf_decomp (:,:,:) ! vertical resolved: potential N mineralization flux of each transfer between litter & soil pools (gN m-3 s-1) + real(r8), allocatable :: p_decomp_cpool_loss (:,:,:) ! vertical resolved: potential C exit rate (transfer+hr) of the donor pool of each transfer between litter & soil pools (gC m-3 s-1) + real(r8), allocatable :: sminn_to_plant (:) ! plant uptake N (gN m-2 s-1) + real(r8), allocatable :: sminn_to_plant_vr (:,:) ! vertical resolved: plant uptake N (gN m-3 s-1) + real(r8), allocatable :: smin_nh4_to_plant_vr (:,:) ! vertical resolved: plant uptake NH4 (gN m-3 s-1) + real(r8), allocatable :: smin_no3_to_plant_vr (:,:) ! vertical resolved: plant uptake NO3 (gN m-3 s-1) + real(r8), allocatable :: supplement_to_sminn_vr (:,:) ! vertical resolved: supplemental N supply to soil mineral N (gN m-3 s-1) + real(r8), allocatable :: sminn_to_plant_fun_vr (:,:) ! vertical resolved: plant uptake N by FUN (gN m-3 s-1) + real(r8), allocatable :: sminn_to_plant_fun_nh4_vr(:,:) ! vertical resolved: plant uptake NH4 by FUN (gN m-3 s-1) + real(r8), allocatable :: sminn_to_plant_fun_no3_vr(:,:) ! vertical resolved: plant uptake NO3 by FUN (gN m-3 s-1) + real(r8), allocatable :: sminn_to_denit_excess_vr (:,:) ! vertical resolved: denitrification from excess mineral N (gN m-3 s-1) + real(r8), allocatable :: f_nit_vr (:,:) ! vertical resolved: nitrification (gN m-3 s-1) + real(r8), allocatable :: f_denit_vr (:,:) ! vertical resolved: denitrification (gN m-3 s-1) + real(r8), allocatable :: f_n2o_nit_vr (:,:) ! vertical resolved: N2O emission from N nitrification (gN m-3 s-1) + real(r8), allocatable :: f_n2o_denit_vr (:,:) ! vertical resolved: N2O emission from N denitrification (gN m-3 s-1) + real(r8), allocatable :: pot_f_nit_vr (:,:) ! vertical resolved: potential N nitrification (gN m-3 s-1) + real(r8), allocatable :: pot_f_denit_vr (:,:) ! vertical resolved: potential N denitrification (gN m-3 s-1) + real(r8), allocatable :: n2_n2o_ratio_denit_vr (:,:) ! vertical resolved: ratio of N2 to N2O production by denitrification (gN gN-1) + real(r8), allocatable :: ndep_to_sminn (:) ! atmospheric N deposition to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: ffix_to_sminn (:) ! free living N fixation to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: nfix_to_sminn (:) ! N fixation to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: somc_fire (:) ! soil organic matters C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: supplement_to_sminn (:) ! supplemental N supply to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: fert_to_sminn (:) ! fertilizer N to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: soyfixn_to_sminn (:) ! soybean N fixation to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: denit (:) ! total N denitrification (gN m-2 s-1) + real(r8), allocatable :: sminn_leached (:) ! soil mineral N loss due to leaching (gN m-2 s-1) + real(r8), allocatable :: f_n2o_nit (:) ! flux of N2O from N nitrification (gN m-2 s-1) + real(r8), allocatable :: smin_no3_leached (:) ! soil mineral NO3 loss due to leaching (gN m-2 s-1) + real(r8), allocatable :: smin_no3_runoff (:) ! soil mineral NO3 loss due to runoff (gN m-2 s-1) + !----------------- end BGC variables ----------------------------------- + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_BGCFluxes + PUBLIC :: deallocate_1D_BGCFluxes + PUBLIC :: set_1D_BGCFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_BGCFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch + IMPLICIT NONE + + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + +! bgc variables +! ecosystem carbon flux + allocate (gpp (numpatch)) ; gpp (:) = spval + allocate (gpp_enftemp (numpatch)) ; gpp_enftemp (:) = spval + allocate (gpp_enfboreal (numpatch)) ; gpp_enfboreal (:) = spval + allocate (gpp_dnfboreal (numpatch)) ; gpp_dnfboreal (:) = spval + allocate (gpp_ebftrop (numpatch)) ; gpp_ebftrop (:) = spval + allocate (gpp_ebftemp (numpatch)) ; gpp_ebftemp (:) = spval + allocate (gpp_dbftrop (numpatch)) ; gpp_dbftrop (:) = spval + allocate (gpp_dbftemp (numpatch)) ; gpp_dbftemp (:) = spval + allocate (gpp_dbfboreal (numpatch)) ; gpp_dbfboreal (:) = spval + allocate (gpp_ebstemp (numpatch)) ; gpp_ebstemp (:) = spval + allocate (gpp_dbstemp (numpatch)) ; gpp_dbstemp (:) = spval + allocate (gpp_dbsboreal (numpatch)) ; gpp_dbsboreal (:) = spval + allocate (gpp_c3arcgrass (numpatch)) ; gpp_c3arcgrass (:) = spval + allocate (gpp_c3grass (numpatch)) ; gpp_c3grass (:) = spval + allocate (gpp_c4grass (numpatch)) ; gpp_c4grass (:) = spval + allocate (npp_enftemp (numpatch)) ; npp_enftemp (:) = spval + allocate (npp_enfboreal (numpatch)) ; npp_enfboreal (:) = spval + allocate (npp_dnfboreal (numpatch)) ; npp_dnfboreal (:) = spval + allocate (npp_ebftrop (numpatch)) ; npp_ebftrop (:) = spval + allocate (npp_ebftemp (numpatch)) ; npp_ebftemp (:) = spval + allocate (npp_dbftrop (numpatch)) ; npp_dbftrop (:) = spval + allocate (npp_dbftemp (numpatch)) ; npp_dbftemp (:) = spval + allocate (npp_dbfboreal (numpatch)) ; npp_dbfboreal (:) = spval + allocate (npp_ebstemp (numpatch)) ; npp_ebstemp (:) = spval + allocate (npp_dbstemp (numpatch)) ; npp_dbstemp (:) = spval + allocate (npp_dbsboreal (numpatch)) ; npp_dbsboreal (:) = spval + allocate (npp_c3arcgrass (numpatch)) ; npp_c3arcgrass (:) = spval + allocate (npp_c3grass (numpatch)) ; npp_c3grass (:) = spval + allocate (npp_c4grass (numpatch)) ; npp_c4grass (:) = spval + allocate (npptoleafc_enftemp (numpatch)) ; npptoleafc_enftemp (:) = spval + allocate (npptoleafc_enfboreal (numpatch)) ; npptoleafc_enfboreal (:) = spval + allocate (npptoleafc_dnfboreal (numpatch)) ; npptoleafc_dnfboreal (:) = spval + allocate (npptoleafc_ebftrop (numpatch)) ; npptoleafc_ebftrop (:) = spval + allocate (npptoleafc_ebftemp (numpatch)) ; npptoleafc_ebftemp (:) = spval + allocate (npptoleafc_dbftrop (numpatch)) ; npptoleafc_dbftrop (:) = spval + allocate (npptoleafc_dbftemp (numpatch)) ; npptoleafc_dbftemp (:) = spval + allocate (npptoleafc_dbfboreal (numpatch)) ; npptoleafc_dbfboreal (:) = spval + allocate (npptoleafc_ebstemp (numpatch)) ; npptoleafc_ebstemp (:) = spval + allocate (npptoleafc_dbstemp (numpatch)) ; npptoleafc_dbstemp (:) = spval + allocate (npptoleafc_dbsboreal (numpatch)) ; npptoleafc_dbsboreal (:) = spval + allocate (npptoleafc_c3arcgrass (numpatch)) ; npptoleafc_c3arcgrass (:) = spval + allocate (npptoleafc_c3grass (numpatch)) ; npptoleafc_c3grass (:) = spval + allocate (npptoleafc_c4grass (numpatch)) ; npptoleafc_c4grass (:) = spval + allocate (leafc_enftemp (numpatch)) ; leafc_enftemp (:) = spval + allocate (leafc_enfboreal (numpatch)) ; leafc_enfboreal (:) = spval + allocate (leafc_dnfboreal (numpatch)) ; leafc_dnfboreal (:) = spval + allocate (leafc_ebftrop (numpatch)) ; leafc_ebftrop (:) = spval + allocate (leafc_ebftemp (numpatch)) ; leafc_ebftemp (:) = spval + allocate (leafc_dbftrop (numpatch)) ; leafc_dbftrop (:) = spval + allocate (leafc_dbftemp (numpatch)) ; leafc_dbftemp (:) = spval + allocate (leafc_dbfboreal (numpatch)) ; leafc_dbfboreal (:) = spval + allocate (leafc_ebstemp (numpatch)) ; leafc_ebstemp (:) = spval + allocate (leafc_dbstemp (numpatch)) ; leafc_dbstemp (:) = spval + allocate (leafc_dbsboreal (numpatch)) ; leafc_dbsboreal (:) = spval + allocate (leafc_c3arcgrass (numpatch)) ; leafc_c3arcgrass (:) = spval + allocate (leafc_c3grass (numpatch)) ; leafc_c3grass (:) = spval + allocate (leafc_c4grass (numpatch)) ; leafc_c4grass (:) = spval + allocate (ar (numpatch)) ; ar (:) = spval + allocate (cwdprod (numpatch)) ; cwdprod (:) = spval + allocate (cwddecomp (numpatch)) ; cwddecomp (:) = spval + allocate (hr (numpatch)) ; hr (:) = spval + allocate (er (numpatch)) ; er (:) = spval + allocate (fire_closs (numpatch)) ; fire_closs (:) = spval + allocate (fire_nloss (numpatch)) ; fire_nloss (:) = spval + allocate (hrv_xsmrpool_to_atm (numpatch)) ; hrv_xsmrpool_to_atm (:) = spval + allocate (wood_harvestc (numpatch)) ; wood_harvestc (:) = spval + allocate (wood_harvestn (numpatch)) ; wood_harvestn (:) = spval + allocate (grainc_to_cropprodc (numpatch)) ; grainc_to_cropprodc (:) = spval + allocate (grainc_to_seed (numpatch)) ; grainc_to_seed (:) = spval + allocate (grainn_to_cropprodn (numpatch)) ; grainn_to_cropprodn (:) = spval + allocate (cropprod1c_loss (numpatch)) ; cropprod1c_loss (:) = spval + + +! decomposition carbon fluxes + allocate (decomp_cpools_sourcesink (nl_soil_full,ndecomp_pools,numpatch)); decomp_cpools_sourcesink (:,:,:) = spval + allocate (decomp_ctransfer_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_ctransfer_vr (:,:,:) = spval + allocate (decomp_hr_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_hr_vr (:,:,:) = spval + allocate (decomp_hr (numpatch)) ; decomp_hr (:) = spval + allocate (phr_vr (nl_soil_full,numpatch)); phr_vr (:,:) = spval + allocate (m_decomp_cpools_to_fire_vr (nl_soil_full,ndecomp_pools,numpatch)); m_decomp_cpools_to_fire_vr (:,:,:) = spval + allocate (decomp_cpools_transport_tendency(nl_soil_full,ndecomp_pools,numpatch)); decomp_cpools_transport_tendency(:,:,:) = spval + allocate (som_c_leached (numpatch)) ; som_c_leached (:) = spval + +! vegetation to decomposition carbon fluxes + allocate (phenology_to_met_c (nl_soil,numpatch)); phenology_to_met_c (:,:) = spval + allocate (phenology_to_cel_c (nl_soil,numpatch)); phenology_to_cel_c (:,:) = spval + allocate (phenology_to_lig_c (nl_soil,numpatch)); phenology_to_lig_c (:,:) = spval + allocate (gap_mortality_to_met_c (nl_soil,numpatch)); gap_mortality_to_met_c (:,:) = spval + allocate (gap_mortality_to_cel_c (nl_soil,numpatch)); gap_mortality_to_cel_c (:,:) = spval + allocate (gap_mortality_to_lig_c (nl_soil,numpatch)); gap_mortality_to_lig_c (:,:) = spval + allocate (gap_mortality_to_cwdc (nl_soil,numpatch)); gap_mortality_to_cwdc (:,:) = spval + allocate (fire_mortality_to_met_c (nl_soil,numpatch)); fire_mortality_to_met_c (:,:) = spval + allocate (fire_mortality_to_cel_c (nl_soil,numpatch)); fire_mortality_to_cel_c (:,:) = spval + allocate (fire_mortality_to_lig_c (nl_soil,numpatch)); fire_mortality_to_lig_c (:,:) = spval + allocate (fire_mortality_to_cwdc (nl_soil,numpatch)); fire_mortality_to_cwdc (:,:) = spval + +! decomposition nitrogen fluxes + allocate (decomp_npools_sourcesink (nl_soil_full,ndecomp_pools,numpatch)); decomp_npools_sourcesink (:,:,:) = spval + allocate (decomp_ntransfer_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_ntransfer_vr (:,:,:) = spval + allocate (decomp_sminn_flux_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_sminn_flux_vr (:,:,:) = spval + allocate (sminn_to_denit_decomp_vr (nl_soil_full,ndecomp_transitions,numpatch)); sminn_to_denit_decomp_vr(:,:,:) = spval + allocate (m_decomp_npools_to_fire_vr (nl_soil_full,ndecomp_pools,numpatch)); m_decomp_npools_to_fire_vr (:,:,:) = spval + allocate (decomp_npools_transport_tendency(nl_soil_full,ndecomp_pools,numpatch)); decomp_npools_transport_tendency(:,:,:) = spval + allocate (som_n_leached (numpatch)) ; som_n_leached (:) = spval + +! vegetation to decomposition nitrogen fluxes + allocate (phenology_to_met_n (nl_soil,numpatch)); phenology_to_met_n (:,:) = spval + allocate (phenology_to_cel_n (nl_soil,numpatch)); phenology_to_cel_n (:,:) = spval + allocate (phenology_to_lig_n (nl_soil,numpatch)); phenology_to_lig_n (:,:) = spval + allocate (gap_mortality_to_met_n (nl_soil,numpatch)); gap_mortality_to_met_n (:,:) = spval + allocate (gap_mortality_to_cel_n (nl_soil,numpatch)); gap_mortality_to_cel_n (:,:) = spval + allocate (gap_mortality_to_lig_n (nl_soil,numpatch)); gap_mortality_to_lig_n (:,:) = spval + allocate (gap_mortality_to_cwdn (nl_soil,numpatch)); gap_mortality_to_cwdn (:,:) = spval + allocate (fire_mortality_to_met_n (nl_soil,numpatch)); fire_mortality_to_met_n (:,:) = spval + allocate (fire_mortality_to_cel_n (nl_soil,numpatch)); fire_mortality_to_cel_n (:,:) = spval + allocate (fire_mortality_to_lig_n (nl_soil,numpatch)); fire_mortality_to_lig_n (:,:) = spval + allocate (fire_mortality_to_cwdn (nl_soil,numpatch)); fire_mortality_to_cwdn (:,:) = spval + + allocate (sminn_leached_vr (nl_soil,numpatch)); sminn_leached_vr (:,:) = spval + allocate (smin_no3_leached_vr (nl_soil,numpatch)); smin_no3_leached_vr (:,:) = spval + allocate (smin_no3_runoff_vr (nl_soil,numpatch)); smin_no3_runoff_vr (:,:) = spval + allocate (net_nmin_vr (nl_soil,numpatch)); net_nmin_vr (:,:) = spval + allocate (gross_nmin_vr (nl_soil,numpatch)); gross_nmin_vr (:,:) = spval + allocate (net_nmin (numpatch)) ; net_nmin (:) = spval + allocate (gross_nmin (numpatch)) ; gross_nmin (:) = spval + allocate (plant_ndemand (numpatch)) ; plant_ndemand (:) = spval + allocate (actual_immob_vr (nl_soil,numpatch)); actual_immob_vr (:,:) = spval + allocate (actual_immob_nh4_vr (nl_soil,numpatch)); actual_immob_nh4_vr (:,:) = spval + allocate (actual_immob_no3_vr (nl_soil,numpatch)); actual_immob_no3_vr (:,:) = spval + allocate (potential_immob_vr (nl_soil,numpatch)); potential_immob_vr (:,:) = spval + allocate (pmnf_decomp (nl_soil,ndecomp_transitions,numpatch)); pmnf_decomp (:,:,:) = spval + allocate (p_decomp_cpool_loss (nl_soil,ndecomp_transitions,numpatch)); p_decomp_cpool_loss (:,:,:) = spval + allocate (sminn_to_plant (numpatch)) ; sminn_to_plant (:) = spval + allocate (sminn_to_plant_vr (nl_soil,numpatch)); sminn_to_plant_vr (:,:) = spval + allocate (smin_nh4_to_plant_vr (nl_soil,numpatch)); smin_nh4_to_plant_vr (:,:) = spval + allocate (smin_no3_to_plant_vr (nl_soil,numpatch)); smin_no3_to_plant_vr (:,:) = spval + allocate (supplement_to_sminn_vr (nl_soil,numpatch)); supplement_to_sminn_vr (:,:) = spval + allocate (sminn_to_plant_fun_vr (nl_soil,numpatch)); sminn_to_plant_fun_vr (:,:) = spval + allocate (sminn_to_plant_fun_nh4_vr(nl_soil,numpatch)); sminn_to_plant_fun_nh4_vr(:,:) = spval + allocate (sminn_to_plant_fun_no3_vr(nl_soil,numpatch)); sminn_to_plant_fun_no3_vr(:,:) = spval + allocate (sminn_to_denit_excess_vr (nl_soil,numpatch)); sminn_to_denit_excess_vr (:,:) = spval + allocate (f_nit_vr (nl_soil,numpatch)); f_nit_vr (:,:) = spval + allocate (f_denit_vr (nl_soil,numpatch)); f_denit_vr (:,:) = spval + allocate (f_n2o_nit_vr (nl_soil,numpatch)); f_n2o_nit_vr (:,:) = spval + allocate (f_n2o_denit_vr (nl_soil,numpatch)); f_n2o_denit_vr (:,:) = spval + allocate (pot_f_nit_vr (nl_soil,numpatch)); pot_f_nit_vr (:,:) = spval + allocate (pot_f_denit_vr (nl_soil,numpatch)); pot_f_denit_vr (:,:) = spval + allocate (n2_n2o_ratio_denit_vr (nl_soil,numpatch)); n2_n2o_ratio_denit_vr (:,:) = spval + allocate (ndep_to_sminn (numpatch)) ; ndep_to_sminn (:) = spval + allocate (ffix_to_sminn (numpatch)) ; ffix_to_sminn (:) = spval + allocate (nfix_to_sminn (numpatch)) ; nfix_to_sminn (:) = spval + allocate (somc_fire (numpatch)) ; somc_fire (:) = spval + allocate (supplement_to_sminn (numpatch)) ; supplement_to_sminn (:) = spval + allocate (fert_to_sminn (numpatch)) ; fert_to_sminn (:) = spval + allocate (soyfixn_to_sminn (numpatch)) ; soyfixn_to_sminn (:) = spval + allocate (denit (numpatch)) ; denit (:) = spval + allocate (sminn_leached (numpatch)) ; sminn_leached (:) = spval + allocate (f_n2o_nit (numpatch)) ; f_n2o_nit (:) = spval + allocate (smin_no3_leached (numpatch)) ; smin_no3_leached (:) = spval + allocate (smin_no3_runoff (numpatch)) ; smin_no3_runoff (:) = spval + ENDIF + ENDIF + + + END SUBROUTINE allocate_1D_BGCFluxes + + SUBROUTINE deallocate_1D_BGCFluxes () + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPatch + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + +! bgc variables +! ecosystem carbon flux + deallocate (gpp ) + deallocate (gpp_enftemp ) !1 + deallocate (gpp_enfboreal ) !2 + deallocate (gpp_dnfboreal ) !3 + deallocate (gpp_ebftrop ) !4 + deallocate (gpp_ebftemp ) !5 + deallocate (gpp_dbftrop ) !6 + deallocate (gpp_dbftemp ) !7 + deallocate (gpp_dbfboreal ) !8 + deallocate (gpp_ebstemp ) !9 + deallocate (gpp_dbstemp ) !10 + deallocate (gpp_dbsboreal ) !11 + deallocate (gpp_c3arcgrass ) !12 + deallocate (gpp_c3grass ) !13 + deallocate (gpp_c4grass ) !14 + deallocate (npp_enftemp ) !1 + deallocate (npp_enfboreal ) !2 + deallocate (npp_dnfboreal ) !3 + deallocate (npp_ebftrop ) !4 + deallocate (npp_ebftemp ) !5 + deallocate (npp_dbftrop ) !6 + deallocate (npp_dbftemp ) !7 + deallocate (npp_dbfboreal ) !8 + deallocate (npp_ebstemp ) !9 + deallocate (npp_dbstemp ) !10 + deallocate (npp_dbsboreal ) !11 + deallocate (npp_c3arcgrass ) !12 + deallocate (npp_c3grass ) !13 + deallocate (npp_c4grass ) !14 + deallocate (npptoleafc_enftemp ) !1 + deallocate (npptoleafc_enfboreal ) !2 + deallocate (npptoleafc_dnfboreal ) !3 + deallocate (npptoleafc_ebftrop ) !4 + deallocate (npptoleafc_ebftemp ) !5 + deallocate (npptoleafc_dbftrop ) !6 + deallocate (npptoleafc_dbftemp ) !7 + deallocate (npptoleafc_dbfboreal ) !8 + deallocate (npptoleafc_ebstemp ) !9 + deallocate (npptoleafc_dbstemp ) !10 + deallocate (npptoleafc_dbsboreal ) !11 + deallocate (npptoleafc_c3arcgrass ) !12 + deallocate (npptoleafc_c3grass ) !13 + deallocate (npptoleafc_c4grass ) !14 + deallocate (leafc_enftemp ) !1 + deallocate (leafc_enfboreal ) !2 + deallocate (leafc_dnfboreal ) !3 + deallocate (leafc_ebftrop ) !4 + deallocate (leafc_ebftemp ) !5 + deallocate (leafc_dbftrop ) !6 + deallocate (leafc_dbftemp ) !7 + deallocate (leafc_dbfboreal ) !8 + deallocate (leafc_ebstemp ) !9 + deallocate (leafc_dbstemp ) !10 + deallocate (leafc_dbsboreal ) !11 + deallocate (leafc_c3arcgrass ) !12 + deallocate (leafc_c3grass ) !13 + deallocate (leafc_c4grass ) !14 + deallocate (ar ) + deallocate (cwdprod ) + deallocate (cwddecomp ) + deallocate (hr ) + deallocate (er ) + deallocate (fire_closs ) + deallocate (fire_nloss ) + deallocate (hrv_xsmrpool_to_atm ) + deallocate (wood_harvestc ) + deallocate (wood_harvestn ) + deallocate (grainc_to_cropprodc ) + deallocate (grainc_to_seed ) + deallocate (grainn_to_cropprodn ) + deallocate (cropprod1c_loss ) + + + ! decomposition carbon fluxes + deallocate (decomp_cpools_sourcesink ) + deallocate (decomp_ctransfer_vr ) + deallocate (decomp_hr_vr ) + deallocate (decomp_hr ) + deallocate (phr_vr ) + deallocate (m_decomp_cpools_to_fire_vr ) + deallocate (decomp_cpools_transport_tendency) + deallocate (som_c_leached ) + + ! vegetation to decomposition carbon fluxes + deallocate (phenology_to_met_c ) + deallocate (phenology_to_cel_c ) + deallocate (phenology_to_lig_c ) + deallocate (gap_mortality_to_met_c ) + deallocate (gap_mortality_to_cel_c ) + deallocate (gap_mortality_to_lig_c ) + deallocate (gap_mortality_to_cwdc ) + deallocate (fire_mortality_to_met_c ) + deallocate (fire_mortality_to_cel_c ) + deallocate (fire_mortality_to_lig_c ) + deallocate (fire_mortality_to_cwdc ) + + ! decomposition nitrogen fluxes + deallocate (decomp_npools_sourcesink ) + deallocate (decomp_ntransfer_vr ) + deallocate (decomp_sminn_flux_vr ) + deallocate (sminn_to_denit_decomp_vr ) + deallocate (m_decomp_npools_to_fire_vr ) + deallocate (decomp_npools_transport_tendency) + deallocate (som_n_leached ) + + ! vegetation to decomposition nitrogen fluxes + deallocate (phenology_to_met_n ) + deallocate (phenology_to_cel_n ) + deallocate (phenology_to_lig_n ) + deallocate (gap_mortality_to_met_n ) + deallocate (gap_mortality_to_cel_n ) + deallocate (gap_mortality_to_lig_n ) + deallocate (gap_mortality_to_cwdn ) + deallocate (fire_mortality_to_met_n ) + deallocate (fire_mortality_to_cel_n ) + deallocate (fire_mortality_to_lig_n ) + deallocate (fire_mortality_to_cwdn ) + + deallocate (sminn_leached_vr ) + deallocate (smin_no3_leached_vr ) + deallocate (smin_no3_runoff_vr ) + deallocate (net_nmin_vr ) + deallocate (gross_nmin_vr ) + deallocate (net_nmin ) + deallocate (gross_nmin ) + deallocate (plant_ndemand ) + deallocate (actual_immob_vr ) + deallocate (actual_immob_nh4_vr ) + deallocate (actual_immob_no3_vr ) + deallocate (potential_immob_vr ) + deallocate (pmnf_decomp ) + deallocate (p_decomp_cpool_loss ) + deallocate (sminn_to_plant ) + deallocate (sminn_to_plant_vr ) + deallocate (smin_nh4_to_plant_vr ) + deallocate (smin_no3_to_plant_vr ) + deallocate (supplement_to_sminn_vr ) + deallocate (sminn_to_plant_fun_vr ) + deallocate (sminn_to_plant_fun_nh4_vr) + deallocate (sminn_to_plant_fun_no3_vr) + deallocate (sminn_to_denit_excess_vr ) + deallocate (f_nit_vr ) + deallocate (f_denit_vr ) + deallocate (f_n2o_nit_vr ) + deallocate (f_n2o_denit_vr ) + deallocate (pot_f_nit_vr ) + deallocate (pot_f_denit_vr ) + deallocate (n2_n2o_ratio_denit_vr ) + deallocate (ndep_to_sminn ) + deallocate (ffix_to_sminn ) + deallocate (nfix_to_sminn ) + deallocate (somc_fire ) + deallocate (supplement_to_sminn ) + deallocate (fert_to_sminn ) + deallocate (soyfixn_to_sminn ) + deallocate (denit ) + deallocate (sminn_leached ) + deallocate (f_n2o_nit ) + deallocate (smin_no3_leached ) + deallocate (smin_no3_runoff ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_1D_BGCFluxes + +SUBROUTINE set_1D_BGCFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + +! bgc variables +! ecosystem carbon flux + gpp (:) = Values + gpp_enftemp (:) = Values !1 + gpp_enfboreal (:) = Values !2 + gpp_dnfboreal (:) = Values !3 + gpp_ebftrop (:) = Values !4 + gpp_ebftemp (:) = Values !5 + gpp_dbftrop (:) = Values !6 + gpp_dbftemp (:) = Values !7 + gpp_dbfboreal (:) = Values !8 + gpp_ebstemp (:) = Values !9 + gpp_dbstemp (:) = Values !10 + gpp_dbsboreal (:) = Values !11 + gpp_c3arcgrass (:) = Values !12 + gpp_c3grass (:) = Values !13 + gpp_c4grass (:) = Values !14 + npp_enftemp (:) = Values !1 + npp_enfboreal (:) = Values !2 + npp_dnfboreal (:) = Values !3 + npp_ebftrop (:) = Values !4 + npp_ebftemp (:) = Values !5 + npp_dbftrop (:) = Values !6 + npp_dbftemp (:) = Values !7 + npp_dbfboreal (:) = Values !8 + npp_ebstemp (:) = Values !9 + npp_dbstemp (:) = Values !10 + npp_dbsboreal (:) = Values !11 + npp_c3arcgrass (:) = Values !12 + npp_c3grass (:) = Values !13 + npp_c4grass (:) = Values !14 + npptoleafc_enftemp (:) = Values !1 + npptoleafc_enfboreal (:) = Values !2 + npptoleafc_dnfboreal (:) = Values !3 + npptoleafc_ebftrop (:) = Values !4 + npptoleafc_ebftemp (:) = Values !5 + npptoleafc_dbftrop (:) = Values !6 + npptoleafc_dbftemp (:) = Values !7 + npptoleafc_dbfboreal (:) = Values !8 + npptoleafc_ebstemp (:) = Values !9 + npptoleafc_dbstemp (:) = Values !10 + npptoleafc_dbsboreal (:) = Values !11 + npptoleafc_c3arcgrass (:) = Values !12 + npptoleafc_c3grass (:) = Values !13 + npptoleafc_c4grass (:) = Values !14 + leafc_enftemp (:) = Values !1 + leafc_enfboreal (:) = Values !2 + leafc_dnfboreal (:) = Values !3 + leafc_ebftrop (:) = Values !4 + leafc_ebftemp (:) = Values !5 + leafc_dbftrop (:) = Values !6 + leafc_dbftemp (:) = Values !7 + leafc_dbfboreal (:) = Values !8 + leafc_ebstemp (:) = Values !9 + leafc_dbstemp (:) = Values !10 + leafc_dbsboreal (:) = Values !11 + leafc_c3arcgrass (:) = Values !12 + leafc_c3grass (:) = Values !13 + leafc_c4grass (:) = Values !14 + ar (:) = Values + cwdprod (:) = Values + cwddecomp (:) = Values + hr (:) = Values + er (:) = Values + fire_closs (:) = Values + fire_nloss (:) = Values + hrv_xsmrpool_to_atm (:) = Values + wood_harvestc (:) = Values + wood_harvestn (:) = Values + grainc_to_cropprodc (:) = Values + grainc_to_seed (:) = Values + grainn_to_cropprodn (:) = Values + cropprod1c_loss (:) = Values + + +! decomposition carbon fluxes + decomp_cpools_sourcesink (:,:,:) = Values + decomp_ctransfer_vr (:,:,:) = Values + decomp_hr_vr (:,:,:) = Values + decomp_hr (:) = Values + phr_vr (:,: ) = Values + m_decomp_cpools_to_fire_vr (:,:,:) = Values + decomp_cpools_transport_tendency(:,:,:) = Values + som_c_leached (:) = Values + +! vegetation to decomposition carbon fluxes + phenology_to_met_c (:,:) = Values + phenology_to_cel_c (:,:) = Values + phenology_to_lig_c (:,:) = Values + gap_mortality_to_met_c (:,:) = Values + gap_mortality_to_cel_c (:,:) = Values + gap_mortality_to_lig_c (:,:) = Values + gap_mortality_to_cwdc (:,:) = Values + fire_mortality_to_met_c (:,:) = Values + fire_mortality_to_cel_c (:,:) = Values + fire_mortality_to_lig_c (:,:) = Values + fire_mortality_to_cwdc (:,:) = Values + +! decomposition nitrogen fluxes + decomp_npools_sourcesink (:,:,:) = Values + decomp_ntransfer_vr (:,:,:) = Values + decomp_sminn_flux_vr (:,:,:) = Values + sminn_to_denit_decomp_vr (:,:,:) = Values + m_decomp_npools_to_fire_vr (:,:,:) = Values + decomp_npools_transport_tendency(:,:,:) = Values + som_n_leached (:) = Values + +! vegetation to decomposition nitrogen fluxes + phenology_to_met_n (:,:) = Values + phenology_to_cel_n (:,:) = Values + phenology_to_lig_n (:,:) = Values + gap_mortality_to_met_n (:,:) = Values + gap_mortality_to_cel_n (:,:) = Values + gap_mortality_to_lig_n (:,:) = Values + gap_mortality_to_cwdn (:,:) = Values + fire_mortality_to_met_n (:,:) = Values + fire_mortality_to_cel_n (:,:) = Values + fire_mortality_to_lig_n (:,:) = Values + fire_mortality_to_cwdn (:,:) = Values + + sminn_leached_vr (:,:) = Values + smin_no3_leached_vr (:,:) = Values + smin_no3_runoff_vr (:,:) = Values + net_nmin_vr (:,:) = Values + gross_nmin_vr (:,:) = Values + net_nmin (:) = Values + gross_nmin (:) = Values + plant_ndemand (:) = Values + actual_immob_vr (:,:) = Values + actual_immob_nh4_vr (:,:) = Values + actual_immob_no3_vr (:,:) = Values + potential_immob_vr (:,:) = Values + pmnf_decomp (:,:,:) = Values + p_decomp_cpool_loss (:,:,:) = Values + sminn_to_plant (:) = Values + sminn_to_plant_vr (:,:) = Values + smin_nh4_to_plant_vr (:,:) = Values + smin_no3_to_plant_vr (:,:) = Values + supplement_to_sminn_vr (:,:) = Values + sminn_to_plant_fun_vr (:,:) = Values + sminn_to_plant_fun_nh4_vr(:,:) = Values + sminn_to_plant_fun_no3_vr(:,:) = Values + sminn_to_denit_excess_vr (:,:) = Values + f_nit_vr (:,:) = Values + f_denit_vr (:,:) = Values + f_n2o_nit_vr (:,:) = Values + f_n2o_denit_vr (:,:) = Values + pot_f_nit_vr (:,:) = Values + pot_f_denit_vr (:,:) = Values + n2_n2o_ratio_denit_vr (:,:) = Values + ndep_to_sminn (:) = Values + ffix_to_sminn (:) = Values + nfix_to_sminn (:) = Values + somc_fire (:) = Values + supplement_to_sminn (:) = Values + fert_to_sminn (:) = Values + soyfixn_to_sminn (:) = Values + denit (:) = Values + sminn_leached (:) = Values + f_n2o_nit (:) = Values + smin_no3_leached (:) = Values + smin_no3_runoff (:) = Values + ENDIF + ENDIF + + END SUBROUTINE set_1D_BGCFluxes + +#endif +END MODULE MOD_BGC_Vars_1DFluxes +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 new file mode 100644 index 0000000000..2cfbe3eda7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 @@ -0,0 +1,1313 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_BGC_Vars_1DPFTFluxes +#ifdef BGC +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical flux variables at pft level + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! bgc variables + real(r8), allocatable :: leafc_xfer_to_leafc_p (:) ! pft level: phenology-associated flux: leaf transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: frootc_xfer_to_frootc_p (:) ! pft level: phenology-associated flux: fine root transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: livestemc_xfer_to_livestemc_p (:) ! pft level: phenology-associated flux: live stem transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: deadstemc_xfer_to_deadstemc_p (:) ! pft level: phenology-associated flux: dead stem transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: livecrootc_xfer_to_livecrootc_p (:) ! pft level: phenology-associated flux: live coarse root transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: deadcrootc_xfer_to_deadcrootc_p (:) ! pft level: phenology-associated flux: dead coarse root transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: grainc_xfer_to_grainc_p (:) ! pft level: phenology-associated flux: grain transfer C to display C (gC m-2 s-1) + + real(r8), allocatable :: leafc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: leaf storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: frootc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: fine root storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: livestemc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live stem storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: deadstemc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead stem storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: livecrootc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live coarse root storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: deadcrootc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead coarse root storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: grainc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: grain storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: gresp_storage_to_xfer_p (:) ! pft level: phenology-associated flux: growth respiration storage C to transfer C (gC m-2 s-1) + + real(r8), allocatable :: leafc_to_litter_p (:) ! pft level: phenology-associated flux: leaf display C to litter C (gC m-2 s-1) + real(r8), allocatable :: frootc_to_litter_p (:) ! pft level: phenology-associated flux: fine root display C to litter C (gC m-2 s-1) + real(r8), allocatable :: grainc_to_food_p (:) ! pft level: phenology-associated flux: grain display C to product C (gC m-2 s-1) + real(r8), allocatable :: grainc_to_seed_p (:) ! pft level: phenology-associated flux: grain display C to seed C (gC m-2 s-1) + real(r8), allocatable :: crop_seedc_to_leaf_p (:) ! pft level: phenology-associated flux: seed C to leaf display C (gC m-2 s-1) + real(r8), allocatable :: livestemc_to_litter_p (:) ! pft level: phenology-associated flux: live stem display C to litter C (gC m-2 s-1) + real(r8), allocatable :: livestemc_to_deadstemc_p (:) ! pft level: phenology-associated flux: live stem display C to dead stem display C (gC m-2 s-1) + real(r8), allocatable :: livecrootc_to_deadcrootc_p (:) ! pft level: phenology-associated flux: live coarse root display C to dead coarse root display C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_frootc_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root display C to litter C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_frootc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_gresp_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: growth respiration storage C to litter C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_frootc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_gresp_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: growth respiration transfer C to litter C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_frootc_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display C to fire emissions (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_frootc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_gresp_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration storage C to fire emissions (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_frootc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_gresp_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration transfer C to fire emissions (gC m-2 s-1) + + real(r8), allocatable :: m_livestemc_to_deadstemc_fire_p (:) ! pft level: fire mortality-associated flux: live stem display C to dead stem display C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_deadcrootc_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display C to dead coarse root display C due to fire (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_frootc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display C to litter C due to fire (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_frootc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: live coarse root storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: dead coarse root storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_gresp_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration storage C to litter C due to fire (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_frootc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_gresp_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration transfer C to litter C due to fire (gC m-2 s-1) + + real(r8), allocatable :: cpool_to_xsmrpool_p (:) ! pft level: allocation-associated flux: available C allocated to maintenance respiration storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_gresp_storage_p (:) ! pft level: allocation-associated flux: available C allocated to growth respiration storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_leafc_p (:) ! pft level: allocation-associated flux: available C allocated to leaf display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_leafc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to leaf storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_frootc_p (:) ! pft level: allocation-associated flux: available C allocated to fine root display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_frootc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to fine root storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livestemc_p (:) ! pft level: allocation-associated flux: available C allocated to live stem display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livestemc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to live stem storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadstemc_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadstemc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livecrootc_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livecrootc_storage_p(:) ! pft level: allocation-associated flux: available C allocated to live coarse storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadcrootc_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse root display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadcrootc_storage_p(:) ! pft level: allocation-associated flux: available C allocated to dead coarse root storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_grainc_p (:) ! pft level: allocation-associated flux: available C allocated to grain display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_grainc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to grain storage C (gC m-2 s-1) + + real(r8), allocatable :: leaf_xsmr_p (:) ! pft level: leaf maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: froot_xsmr_p (:) ! pft level: fine root maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: livestem_xsmr_p (:) ! pft level: live stem maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: livecroot_xsmr_p (:) ! pft level: live coarse root maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: grain_xsmr_p (:) ! pft level: grain maintenance respiration storage C due to available C deficit (gC m-2 s-1) + + real(r8), allocatable :: cpool_leaf_gr_p (:) ! pft level: allocation-associated flux: available C allocated to leaf display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_froot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to fine root display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livestem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live stem display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadstem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livecroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadcroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_grain_gr_p (:) ! pft level: allocation-associated flux: available C allocated to grain display growth respiration (gC m-2 s-1) + + real(r8), allocatable :: cpool_leaf_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to leaf storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_froot_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to fine root storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livestem_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live stem storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadstem_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livecroot_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadcroot_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_grain_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to grain storage growth respiration (gC m-2 s-1) + + real(r8), allocatable :: transfer_leaf_gr_p (:) ! pft level: allocation-associated flux: available C allocated to leaf transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_froot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to fine root transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_livestem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live stem transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_deadstem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_livecroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_deadcroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_grain_gr_p (:) ! pft level: allocation-associated flux: available C allocated to grain transfer growth respiration (gC m-2 s-1) + + real(r8), allocatable :: xsmrpool_to_atm_p (:) ! pft level: maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) + + real(r8), allocatable :: cropprod1c_loss_p (:) ! pft level: product loss (gC m-2 s-1) + + real(r8), allocatable :: plant_ndemand_p (:) ! pft level: plant potential demand N (gN m-2 s-1) + + real(r8), allocatable :: leafn_xfer_to_leafn_p (:) ! pft level: phenology-associated flux: leaf transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: frootn_xfer_to_frootn_p (:) ! pft level: phenology-associated flux: fine root transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: livestemn_xfer_to_livestemn_p (:) ! pft level: phenology-associated flux: live stem transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: deadstemn_xfer_to_deadstemn_p (:) ! pft level: phenology-associated flux: dead stem transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_xfer_to_livecrootn_p (:) ! pft level: phenology-associated flux: live coarse root transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: deadcrootn_xfer_to_deadcrootn_p (:) ! pft level: phenology-associated flux: dead coarse root transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: grainn_xfer_to_grainn_p (:) ! pft level: phenology-associated flux: grain transfer N to display N (gN m-2 s-1) + + real(r8), allocatable :: leafn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: leaf storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: frootn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: fine root storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: livestemn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live stem storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: deadstemn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead stem storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live coarse root storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: deadcrootn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead coarse root storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: grainn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: grain storage N to transfer N (gN m-2 s-1) + + real(r8), allocatable :: leafn_to_litter_p (:) ! pft level: phenology-associated flux: leaf display N to litter N (gN m-2 s-1) + real(r8), allocatable :: frootn_to_litter_p (:) ! pft level: phenology-associated flux: fine root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: grainn_to_food_p (:) ! pft level: phenology-associated flux: grain display N to product N (gN m-2 s-1) + real(r8), allocatable :: grainn_to_seed_p (:) ! pft level: phenology-associated flux: grain display N to seed N (gN m-2 s-1) + real(r8), allocatable :: crop_seedn_to_leaf_p (:) ! pft level: phenology-associated flux: seed N to leaf display N (gN m-2 s-1) + real(r8), allocatable :: livestemn_to_litter_p (:) ! pft level: phenology-associated flux: live stem display N to litter N (gN m-2 s-1) + real(r8), allocatable :: livestemn_to_deadstemn_p (:) ! pft level: phenology-associated flux: live stem display N to dead stem display N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_to_deadcrootn_p (:) ! pft level: phenology-associated flux: live coarse root display N to dead coarse root display N (gN m-2 s-1) + + real(r8), allocatable :: leafn_to_retransn_p (:) ! pft level: phenology-associated flux: leaf display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: frootn_to_retransn_p (:) ! pft level: phenology-associated flux: fine root display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: livestemn_to_retransn_p (:) ! pft level: phenology-associated flux: live stem display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_to_retransn_p (:) ! pft level: phenology-associated flux: live coarse root display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: retransn_to_npool_p (:) ! pft level: phenology-associated flux: retranslocated N to available N (gN m-2 s-1) + real(r8), allocatable :: free_retransn_to_npool_p (:) ! pft level: phenology-associated flux: retranslocated N to available N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_frootn_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_retransn_to_litter_p (:) ! pft level: gap mortality-associated flux: retranslocated N to litter N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_frootn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root storage N to litter N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_frootn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root transfer N to litter N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_frootn_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_frootn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root storage N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_frootn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_livestemn_to_deadstemn_fire_p (:) ! pft level: fire mortality-associated flux: live stem display N to dead stem display N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_deadcrootn_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display N to dead coarse root display N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_retransn_to_fire_p (:) ! pft level: fire mortality-associated flux: retranslocated N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_frootn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_frootn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: live coarse root storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: dead coarse root storage N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_frootn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_retransn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: retranslocated N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: npool_to_leafn_p (:) ! pft level: allocation-associated flux: available N allocated to leaf display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_leafn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to leaf storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_frootn_p (:) ! pft level: allocation-associated flux: available N allocated to fine root display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_frootn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to fine root storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livestemn_p (:) ! pft level: allocation-associated flux: available N allocated to live stem display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livestemn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to live stem storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadstemn_p (:) ! pft level: allocation-associated flux: available N allocated to dead stem display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadstemn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to dead stem storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livecrootn_p (:) ! pft level: allocation-associated flux: available N allocated to live coarse display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livecrootn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to live coarse storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadcrootn_p (:) ! pft level: allocation-associated flux: available N allocated to dead coarse root display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadcrootn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to dead coarse root storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_grainn_p (:) ! pft level: allocation-associated flux: available N allocated to grain display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_grainn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to grain storage N (gN m-2 s-1) + + real(r8), allocatable :: respcsun_p (:) ! pft level: sunlit leaf respiration (gC m-2 s-1) + real(r8), allocatable :: respcsha_p (:) ! pft level: shaded leaf respiration (gC m-2 s-1) + real(r8), allocatable :: leaf_mr_p (:) ! pft level: leaf maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: froot_mr_p (:) ! pft level: fine root maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: livestem_mr_p (:) ! pft level: live stem maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: livecroot_mr_p (:) ! pft level: live coarse root maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: grain_mr_p (:) ! pft level: grain maintenance respiration (gC m-2 s-1) + + real(r8), allocatable :: soil_change_p (:) ! pft level: soil carbon used by FUN (gC m-2 s-1) + + real(r8), allocatable :: psn_to_cpool_p (:) ! pft level: photosynthesis rate (gC m-2 s-1) + real(r8), allocatable :: gpp_p (:) ! pft level: gross primary production (gC m-2 s-1) + real(r8), allocatable :: availc_p (:) ! pft level: available C (gC m-2 s-1) + real(r8), allocatable :: avail_retransn_p (:) ! pft level: available retranslocated N (gN m-2 s-1) + real(r8), allocatable :: xsmrpool_recover_p (:) ! pft level: available C to maintenance respiration storage C to recover previous excess mainte + real(r8), allocatable :: excess_cflux_p (:) ! pft level: excess C due to N limitation (gC m-2 s-1) + real(r8), allocatable :: sminn_to_npool_p (:) ! pft level: soil mineral N uptake for plant growth (gN m-2 s-1) + + real(r8), allocatable :: plant_calloc_p (:) ! pft level: actual available C for plant grwoth (gC m-2 s-1) + real(r8), allocatable :: plant_nalloc_p (:) ! pft level: actual available N for plant growth (gN m-2 s-1) + real(r8), allocatable :: leaf_curmr_p (:) ! pft level: leaf maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: froot_curmr_p (:) ! pft level: fine root maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: livestem_curmr_p (:) ! pft level: live stem maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: livecroot_curmr_p (:) ! pft level: live coarse root maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: grain_curmr_p (:) ! pft level: grain maintenance respiration from current available C (gC m-2 s-1) + + real(r8), allocatable :: fire_closs_p (:) ! pft level: total C emissions due to fire (gC m-2 s-1) + real(r8), allocatable :: fire_nloss_p (:) ! pft level: total N emissions due to fire (gN m-2 s-1) + real(r8), allocatable :: wood_harvestc_p (:) ! pft level: harvested wood C (gC m-2 s-1) + real(r8), allocatable :: wood_harvestn_p (:) ! pft level: harvested wood N (gN m-2 s-1) + real(r8), allocatable :: grainc_to_cropprodc_p (:) ! pft level: harvested grain C (gC m-2 s-1) + real(r8), allocatable :: grainn_to_cropprodn_p (:) ! pft level: harvested grain N (gN m-2 s-1) + real(r8), allocatable :: hrv_xsmrpool_to_atm_p (:) ! pft level: maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) + real(r8), allocatable :: soyfixn_p (:) ! pft level: soybean fixed nitrogen rate (gN m-2 s-1) + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_BGCPFTFluxes + PUBLIC :: deallocate_1D_BGCPFTFluxes + PUBLIC :: set_1D_BGCPFTFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_BGCPFTFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + ! bgc variables + allocate (leafc_xfer_to_leafc_p (numpft)) ; leafc_xfer_to_leafc_p (:) = spval + allocate (frootc_xfer_to_frootc_p (numpft)) ; frootc_xfer_to_frootc_p (:) = spval + allocate (livestemc_xfer_to_livestemc_p (numpft)) ; livestemc_xfer_to_livestemc_p (:) = spval + allocate (deadstemc_xfer_to_deadstemc_p (numpft)) ; deadstemc_xfer_to_deadstemc_p (:) = spval + allocate (livecrootc_xfer_to_livecrootc_p (numpft)) ; livecrootc_xfer_to_livecrootc_p (:) = spval + allocate (deadcrootc_xfer_to_deadcrootc_p (numpft)) ; deadcrootc_xfer_to_deadcrootc_p (:) = spval + allocate (grainc_xfer_to_grainc_p (numpft)) ; grainc_xfer_to_grainc_p (:) = spval + + allocate (leafc_storage_to_xfer_p (numpft)) ; leafc_storage_to_xfer_p (:) = spval + allocate (frootc_storage_to_xfer_p (numpft)) ; frootc_storage_to_xfer_p (:) = spval + allocate (livestemc_storage_to_xfer_p (numpft)) ; livestemc_storage_to_xfer_p (:) = spval + allocate (deadstemc_storage_to_xfer_p (numpft)) ; deadstemc_storage_to_xfer_p (:) = spval + allocate (livecrootc_storage_to_xfer_p (numpft)) ; livecrootc_storage_to_xfer_p (:) = spval + allocate (deadcrootc_storage_to_xfer_p (numpft)) ; deadcrootc_storage_to_xfer_p (:) = spval + allocate (grainc_storage_to_xfer_p (numpft)) ; grainc_storage_to_xfer_p (:) = spval + allocate (gresp_storage_to_xfer_p (numpft)) ; gresp_storage_to_xfer_p (:) = spval + + allocate (leafc_to_litter_p (numpft)) ; leafc_to_litter_p (:) = spval + allocate (frootc_to_litter_p (numpft)) ; frootc_to_litter_p (:) = spval + allocate (grainc_to_food_p (numpft)) ; grainc_to_food_p (:) = spval + allocate (grainc_to_seed_p (numpft)) ; grainc_to_seed_p (:) = spval + allocate (crop_seedc_to_leaf_p (numpft)) ; crop_seedc_to_leaf_p (:) = spval + allocate (livestemc_to_litter_p (numpft)) ; livestemc_to_litter_p (:) = spval + allocate (livestemc_to_deadstemc_p (numpft)) ; livestemc_to_deadstemc_p (:) = spval + allocate (livecrootc_to_deadcrootc_p (numpft)) ; livecrootc_to_deadcrootc_p (:) = spval + + allocate (m_leafc_to_litter_p (numpft)) ; m_leafc_to_litter_p (:) = spval + allocate (m_frootc_to_litter_p (numpft)) ; m_frootc_to_litter_p (:) = spval + allocate (m_livestemc_to_litter_p (numpft)) ; m_livestemc_to_litter_p (:) = spval + allocate (m_deadstemc_to_litter_p (numpft)) ; m_deadstemc_to_litter_p (:) = spval + allocate (m_livecrootc_to_litter_p (numpft)) ; m_livecrootc_to_litter_p (:) = spval + allocate (m_deadcrootc_to_litter_p (numpft)) ; m_deadcrootc_to_litter_p (:) = spval + + allocate (m_leafc_storage_to_litter_p (numpft)) ; m_leafc_storage_to_litter_p (:) = spval + allocate (m_frootc_storage_to_litter_p (numpft)) ; m_frootc_storage_to_litter_p (:) = spval + allocate (m_livestemc_storage_to_litter_p (numpft)) ; m_livestemc_storage_to_litter_p (:) = spval + allocate (m_deadstemc_storage_to_litter_p (numpft)) ; m_deadstemc_storage_to_litter_p (:) = spval + allocate (m_livecrootc_storage_to_litter_p (numpft)) ; m_livecrootc_storage_to_litter_p (:) = spval + allocate (m_deadcrootc_storage_to_litter_p (numpft)) ; m_deadcrootc_storage_to_litter_p (:) = spval + allocate (m_gresp_storage_to_litter_p (numpft)) ; m_gresp_storage_to_litter_p (:) = spval + + allocate (m_leafc_xfer_to_litter_p (numpft)) ; m_leafc_xfer_to_litter_p (:) = spval + allocate (m_frootc_xfer_to_litter_p (numpft)) ; m_frootc_xfer_to_litter_p (:) = spval + allocate (m_livestemc_xfer_to_litter_p (numpft)) ; m_livestemc_xfer_to_litter_p (:) = spval + allocate (m_deadstemc_xfer_to_litter_p (numpft)) ; m_deadstemc_xfer_to_litter_p (:) = spval + allocate (m_livecrootc_xfer_to_litter_p (numpft)) ; m_livecrootc_xfer_to_litter_p (:) = spval + allocate (m_deadcrootc_xfer_to_litter_p (numpft)) ; m_deadcrootc_xfer_to_litter_p (:) = spval + allocate (m_gresp_xfer_to_litter_p (numpft)) ; m_gresp_xfer_to_litter_p (:) = spval + + allocate (m_leafc_to_fire_p (numpft)) ; m_leafc_to_fire_p (:) = spval + allocate (m_frootc_to_fire_p (numpft)) ; m_frootc_to_fire_p (:) = spval + allocate (m_livestemc_to_fire_p (numpft)) ; m_livestemc_to_fire_p (:) = spval + allocate (m_deadstemc_to_fire_p (numpft)) ; m_deadstemc_to_fire_p (:) = spval + allocate (m_livecrootc_to_fire_p (numpft)) ; m_livecrootc_to_fire_p (:) = spval + allocate (m_deadcrootc_to_fire_p (numpft)) ; m_deadcrootc_to_fire_p (:) = spval + + allocate (m_leafc_storage_to_fire_p (numpft)) ; m_leafc_storage_to_fire_p (:) = spval + allocate (m_frootc_storage_to_fire_p (numpft)) ; m_frootc_storage_to_fire_p (:) = spval + allocate (m_livestemc_storage_to_fire_p (numpft)) ; m_livestemc_storage_to_fire_p (:) = spval + allocate (m_deadstemc_storage_to_fire_p (numpft)) ; m_deadstemc_storage_to_fire_p (:) = spval + allocate (m_livecrootc_storage_to_fire_p (numpft)) ; m_livecrootc_storage_to_fire_p (:) = spval + allocate (m_deadcrootc_storage_to_fire_p (numpft)) ; m_deadcrootc_storage_to_fire_p (:) = spval + allocate (m_gresp_storage_to_fire_p (numpft)) ; m_gresp_storage_to_fire_p (:) = spval + + allocate (m_leafc_xfer_to_fire_p (numpft)) ; m_leafc_xfer_to_fire_p (:) = spval + allocate (m_frootc_xfer_to_fire_p (numpft)) ; m_frootc_xfer_to_fire_p (:) = spval + allocate (m_livestemc_xfer_to_fire_p (numpft)) ; m_livestemc_xfer_to_fire_p (:) = spval + allocate (m_deadstemc_xfer_to_fire_p (numpft)) ; m_deadstemc_xfer_to_fire_p (:) = spval + allocate (m_livecrootc_xfer_to_fire_p (numpft)) ; m_livecrootc_xfer_to_fire_p (:) = spval + allocate (m_deadcrootc_xfer_to_fire_p (numpft)) ; m_deadcrootc_xfer_to_fire_p (:) = spval + allocate (m_gresp_xfer_to_fire_p (numpft)) ; m_gresp_xfer_to_fire_p (:) = spval + + allocate (m_livestemc_to_deadstemc_fire_p (numpft)) ; m_livestemc_to_deadstemc_fire_p (:) = spval + allocate (m_livecrootc_to_deadcrootc_fire_p (numpft)) ; m_livecrootc_to_deadcrootc_fire_p (:) = spval + + allocate (m_leafc_to_litter_fire_p (numpft)) ; m_leafc_to_litter_fire_p (:) = spval + allocate (m_frootc_to_litter_fire_p (numpft)) ; m_frootc_to_litter_fire_p (:) = spval + allocate (m_livestemc_to_litter_fire_p (numpft)) ; m_livestemc_to_litter_fire_p (:) = spval + allocate (m_deadstemc_to_litter_fire_p (numpft)) ; m_deadstemc_to_litter_fire_p (:) = spval + allocate (m_livecrootc_to_litter_fire_p (numpft)) ; m_livecrootc_to_litter_fire_p (:) = spval + allocate (m_deadcrootc_to_litter_fire_p (numpft)) ; m_deadcrootc_to_litter_fire_p (:) = spval + + allocate (m_leafc_storage_to_litter_fire_p (numpft)) ; m_leafc_storage_to_litter_fire_p (:) = spval + allocate (m_frootc_storage_to_litter_fire_p (numpft)) ; m_frootc_storage_to_litter_fire_p (:) = spval + allocate (m_livestemc_storage_to_litter_fire_p (numpft)) ; m_livestemc_storage_to_litter_fire_p (:) = spval + allocate (m_deadstemc_storage_to_litter_fire_p (numpft)) ; m_deadstemc_storage_to_litter_fire_p (:) = spval + allocate (m_livecrootc_storage_to_litter_fire_p(numpft)) ; m_livecrootc_storage_to_litter_fire_p(:) = spval + allocate (m_deadcrootc_storage_to_litter_fire_p(numpft)) ; m_deadcrootc_storage_to_litter_fire_p(:) = spval + allocate (m_gresp_storage_to_litter_fire_p (numpft)) ; m_gresp_storage_to_litter_fire_p (:) = spval + + allocate (m_leafc_xfer_to_litter_fire_p (numpft)) ; m_leafc_xfer_to_litter_fire_p (:) = spval + allocate (m_frootc_xfer_to_litter_fire_p (numpft)) ; m_frootc_xfer_to_litter_fire_p (:) = spval + allocate (m_livestemc_xfer_to_litter_fire_p (numpft)) ; m_livestemc_xfer_to_litter_fire_p (:) = spval + allocate (m_deadstemc_xfer_to_litter_fire_p (numpft)) ; m_deadstemc_xfer_to_litter_fire_p (:) = spval + allocate (m_livecrootc_xfer_to_litter_fire_p (numpft)) ; m_livecrootc_xfer_to_litter_fire_p (:) = spval + allocate (m_deadcrootc_xfer_to_litter_fire_p (numpft)) ; m_deadcrootc_xfer_to_litter_fire_p (:) = spval + allocate (m_gresp_xfer_to_litter_fire_p (numpft)) ; m_gresp_xfer_to_litter_fire_p (:) = spval + + allocate (cpool_to_xsmrpool_p (numpft)) ; cpool_to_xsmrpool_p (:) = spval + allocate (cpool_to_gresp_storage_p (numpft)) ; cpool_to_gresp_storage_p (:) = spval + allocate (cpool_to_leafc_p (numpft)) ; cpool_to_leafc_p (:) = spval + allocate (cpool_to_leafc_storage_p (numpft)) ; cpool_to_leafc_storage_p (:) = spval + allocate (cpool_to_frootc_p (numpft)) ; cpool_to_frootc_p (:) = spval + allocate (cpool_to_frootc_storage_p (numpft)) ; cpool_to_frootc_storage_p (:) = spval + allocate (cpool_to_livestemc_p (numpft)) ; cpool_to_livestemc_p (:) = spval + allocate (cpool_to_livestemc_storage_p (numpft)) ; cpool_to_livestemc_storage_p (:) = spval + allocate (cpool_to_deadstemc_p (numpft)) ; cpool_to_deadstemc_p (:) = spval + allocate (cpool_to_deadstemc_storage_p (numpft)) ; cpool_to_deadstemc_storage_p (:) = spval + allocate (cpool_to_livecrootc_p (numpft)) ; cpool_to_livecrootc_p (:) = spval + allocate (cpool_to_livecrootc_storage_p(numpft)) ; cpool_to_livecrootc_storage_p(:) = spval + allocate (cpool_to_deadcrootc_p (numpft)) ; cpool_to_deadcrootc_p (:) = spval + allocate (cpool_to_deadcrootc_storage_p(numpft)) ; cpool_to_deadcrootc_storage_p(:) = spval + allocate (cpool_to_grainc_p (numpft)) ; cpool_to_grainc_p (:) = spval + allocate (cpool_to_grainc_storage_p (numpft)) ; cpool_to_grainc_storage_p (:) = spval + + allocate (leaf_xsmr_p (numpft)) ; leaf_xsmr_p (:) = spval + allocate (froot_xsmr_p (numpft)) ; froot_xsmr_p (:) = spval + allocate (livestem_xsmr_p (numpft)) ; livestem_xsmr_p (:) = spval + allocate (livecroot_xsmr_p (numpft)) ; livecroot_xsmr_p (:) = spval + allocate (grain_xsmr_p (numpft)) ; grain_xsmr_p (:) = spval + + allocate (cpool_leaf_gr_p (numpft)) ; cpool_leaf_gr_p (:) = spval + allocate (cpool_froot_gr_p (numpft)) ; cpool_froot_gr_p (:) = spval + allocate (cpool_livestem_gr_p (numpft)) ; cpool_livestem_gr_p (:) = spval + allocate (cpool_deadstem_gr_p (numpft)) ; cpool_deadstem_gr_p (:) = spval + allocate (cpool_livecroot_gr_p (numpft)) ; cpool_livecroot_gr_p (:) = spval + allocate (cpool_deadcroot_gr_p (numpft)) ; cpool_deadcroot_gr_p (:) = spval + allocate (cpool_grain_gr_p (numpft)) ; cpool_grain_gr_p (:) = spval + + allocate (cpool_leaf_storage_gr_p (numpft)) ; cpool_leaf_storage_gr_p (:) = spval + allocate (cpool_froot_storage_gr_p (numpft)) ; cpool_froot_storage_gr_p (:) = spval + allocate (cpool_livestem_storage_gr_p (numpft)) ; cpool_livestem_storage_gr_p (:) = spval + allocate (cpool_deadstem_storage_gr_p (numpft)) ; cpool_deadstem_storage_gr_p (:) = spval + allocate (cpool_livecroot_storage_gr_p (numpft)) ; cpool_livecroot_storage_gr_p (:) = spval + allocate (cpool_deadcroot_storage_gr_p (numpft)) ; cpool_deadcroot_storage_gr_p (:) = spval + allocate (cpool_grain_storage_gr_p (numpft)) ; cpool_grain_storage_gr_p (:) = spval + + allocate (transfer_leaf_gr_p (numpft)) ; transfer_leaf_gr_p (:) = spval + allocate (transfer_froot_gr_p (numpft)) ; transfer_froot_gr_p (:) = spval + allocate (transfer_livestem_gr_p (numpft)) ; transfer_livestem_gr_p (:) = spval + allocate (transfer_deadstem_gr_p (numpft)) ; transfer_deadstem_gr_p (:) = spval + allocate (transfer_livecroot_gr_p (numpft)) ; transfer_livecroot_gr_p (:) = spval + allocate (transfer_deadcroot_gr_p (numpft)) ; transfer_deadcroot_gr_p (:) = spval + allocate (transfer_grain_gr_p (numpft)) ; transfer_grain_gr_p (:) = spval + + allocate (xsmrpool_to_atm_p (numpft)) ; xsmrpool_to_atm_p (:) = spval + + allocate (cropprod1c_loss_p (numpft)) ; cropprod1c_loss_p (:) = spval + + allocate (plant_ndemand_p (numpft)) ; plant_ndemand_p (:) = spval + + allocate (leafn_xfer_to_leafn_p (numpft)) ; leafn_xfer_to_leafn_p (:) = spval + allocate (frootn_xfer_to_frootn_p (numpft)) ; frootn_xfer_to_frootn_p (:) = spval + allocate (livestemn_xfer_to_livestemn_p (numpft)) ; livestemn_xfer_to_livestemn_p (:) = spval + allocate (deadstemn_xfer_to_deadstemn_p (numpft)) ; deadstemn_xfer_to_deadstemn_p (:) = spval + allocate (livecrootn_xfer_to_livecrootn_p (numpft)) ; livecrootn_xfer_to_livecrootn_p (:) = spval + allocate (deadcrootn_xfer_to_deadcrootn_p (numpft)) ; deadcrootn_xfer_to_deadcrootn_p (:) = spval + allocate (grainn_xfer_to_grainn_p (numpft)) ; grainn_xfer_to_grainn_p (:) = spval + + allocate (leafn_storage_to_xfer_p (numpft)) ; leafn_storage_to_xfer_p (:) = spval + allocate (frootn_storage_to_xfer_p (numpft)) ; frootn_storage_to_xfer_p (:) = spval + allocate (livestemn_storage_to_xfer_p (numpft)) ; livestemn_storage_to_xfer_p (:) = spval + allocate (deadstemn_storage_to_xfer_p (numpft)) ; deadstemn_storage_to_xfer_p (:) = spval + allocate (livecrootn_storage_to_xfer_p (numpft)) ; livecrootn_storage_to_xfer_p (:) = spval + allocate (deadcrootn_storage_to_xfer_p (numpft)) ; deadcrootn_storage_to_xfer_p (:) = spval + allocate (grainn_storage_to_xfer_p (numpft)) ; grainn_storage_to_xfer_p (:) = spval + + allocate (leafn_to_litter_p (numpft)) ; leafn_to_litter_p (:) = spval + allocate (frootn_to_litter_p (numpft)) ; frootn_to_litter_p (:) = spval + allocate (grainn_to_food_p (numpft)) ; grainn_to_food_p (:) = spval + allocate (grainn_to_seed_p (numpft)) ; grainn_to_seed_p (:) = spval + allocate (crop_seedn_to_leaf_p (numpft)) ; crop_seedn_to_leaf_p (:) = spval + allocate (livestemn_to_litter_p (numpft)) ; livestemn_to_litter_p (:) = spval + allocate (livestemn_to_deadstemn_p (numpft)) ; livestemn_to_deadstemn_p (:) = spval + allocate (livecrootn_to_deadcrootn_p (numpft)) ; livecrootn_to_deadcrootn_p (:) = spval + + allocate (leafn_to_retransn_p (numpft)) ; leafn_to_retransn_p (:) = spval + allocate (frootn_to_retransn_p (numpft)) ; frootn_to_retransn_p (:) = spval + allocate (livestemn_to_retransn_p (numpft)) ; livestemn_to_retransn_p (:) = spval + allocate (livecrootn_to_retransn_p (numpft)) ; livecrootn_to_retransn_p (:) = spval + allocate (retransn_to_npool_p (numpft)) ; retransn_to_npool_p (:) = spval + allocate (free_retransn_to_npool_p (numpft)) ; free_retransn_to_npool_p (:) = spval + + allocate (m_leafn_to_litter_p (numpft)) ; m_leafn_to_litter_p (:) = spval + allocate (m_frootn_to_litter_p (numpft)) ; m_frootn_to_litter_p (:) = spval + allocate (m_livestemn_to_litter_p (numpft)) ; m_livestemn_to_litter_p (:) = spval + allocate (m_deadstemn_to_litter_p (numpft)) ; m_deadstemn_to_litter_p (:) = spval + allocate (m_livecrootn_to_litter_p (numpft)) ; m_livecrootn_to_litter_p (:) = spval + allocate (m_deadcrootn_to_litter_p (numpft)) ; m_deadcrootn_to_litter_p (:) = spval + allocate (m_retransn_to_litter_p (numpft)) ; m_retransn_to_litter_p (:) = spval + + allocate (m_leafn_storage_to_litter_p (numpft)) ; m_leafn_storage_to_litter_p (:) = spval + allocate (m_frootn_storage_to_litter_p (numpft)) ; m_frootn_storage_to_litter_p (:) = spval + allocate (m_livestemn_storage_to_litter_p (numpft)) ; m_livestemn_storage_to_litter_p (:) = spval + allocate (m_deadstemn_storage_to_litter_p (numpft)) ; m_deadstemn_storage_to_litter_p (:) = spval + allocate (m_livecrootn_storage_to_litter_p (numpft)) ; m_livecrootn_storage_to_litter_p (:) = spval + allocate (m_deadcrootn_storage_to_litter_p (numpft)) ; m_deadcrootn_storage_to_litter_p (:) = spval + + allocate (m_leafn_xfer_to_litter_p (numpft)) ; m_leafn_xfer_to_litter_p (:) = spval + allocate (m_frootn_xfer_to_litter_p (numpft)) ; m_frootn_xfer_to_litter_p (:) = spval + allocate (m_livestemn_xfer_to_litter_p (numpft)) ; m_livestemn_xfer_to_litter_p (:) = spval + allocate (m_deadstemn_xfer_to_litter_p (numpft)) ; m_deadstemn_xfer_to_litter_p (:) = spval + allocate (m_livecrootn_xfer_to_litter_p (numpft)) ; m_livecrootn_xfer_to_litter_p (:) = spval + allocate (m_deadcrootn_xfer_to_litter_p (numpft)) ; m_deadcrootn_xfer_to_litter_p (:) = spval + + allocate (m_leafn_to_fire_p (numpft)) ; m_leafn_to_fire_p (:) = spval + allocate (m_frootn_to_fire_p (numpft)) ; m_frootn_to_fire_p (:) = spval + allocate (m_livestemn_to_fire_p (numpft)) ; m_livestemn_to_fire_p (:) = spval + allocate (m_deadstemn_to_fire_p (numpft)) ; m_deadstemn_to_fire_p (:) = spval + allocate (m_livecrootn_to_fire_p (numpft)) ; m_livecrootn_to_fire_p (:) = spval + allocate (m_deadcrootn_to_fire_p (numpft)) ; m_deadcrootn_to_fire_p (:) = spval + + allocate (m_leafn_storage_to_fire_p (numpft)) ; m_leafn_storage_to_fire_p (:) = spval + allocate (m_frootn_storage_to_fire_p (numpft)) ; m_frootn_storage_to_fire_p (:) = spval + allocate (m_livestemn_storage_to_fire_p (numpft)) ; m_livestemn_storage_to_fire_p (:) = spval + allocate (m_deadstemn_storage_to_fire_p (numpft)) ; m_deadstemn_storage_to_fire_p (:) = spval + allocate (m_livecrootn_storage_to_fire_p (numpft)) ; m_livecrootn_storage_to_fire_p (:) = spval + allocate (m_deadcrootn_storage_to_fire_p (numpft)) ; m_deadcrootn_storage_to_fire_p (:) = spval + + allocate (m_leafn_xfer_to_fire_p (numpft)) ; m_leafn_xfer_to_fire_p (:) = spval + allocate (m_frootn_xfer_to_fire_p (numpft)) ; m_frootn_xfer_to_fire_p (:) = spval + allocate (m_livestemn_xfer_to_fire_p (numpft)) ; m_livestemn_xfer_to_fire_p (:) = spval + allocate (m_deadstemn_xfer_to_fire_p (numpft)) ; m_deadstemn_xfer_to_fire_p (:) = spval + allocate (m_livecrootn_xfer_to_fire_p (numpft)) ; m_livecrootn_xfer_to_fire_p (:) = spval + allocate (m_deadcrootn_xfer_to_fire_p (numpft)) ; m_deadcrootn_xfer_to_fire_p (:) = spval + + allocate (m_livestemn_to_deadstemn_fire_p (numpft)) ; m_livestemn_to_deadstemn_fire_p (:) = spval + allocate (m_livecrootn_to_deadcrootn_fire_p (numpft)) ; m_livecrootn_to_deadcrootn_fire_p (:) = spval + + allocate (m_retransn_to_fire_p (numpft)) ; m_retransn_to_fire_p (:) = spval + + allocate (m_leafn_to_litter_fire_p (numpft)) ; m_leafn_to_litter_fire_p (:) = spval + allocate (m_frootn_to_litter_fire_p (numpft)) ; m_frootn_to_litter_fire_p (:) = spval + allocate (m_livestemn_to_litter_fire_p (numpft)) ; m_livestemn_to_litter_fire_p (:) = spval + allocate (m_deadstemn_to_litter_fire_p (numpft)) ; m_deadstemn_to_litter_fire_p (:) = spval + allocate (m_livecrootn_to_litter_fire_p (numpft)) ; m_livecrootn_to_litter_fire_p (:) = spval + allocate (m_deadcrootn_to_litter_fire_p (numpft)) ; m_deadcrootn_to_litter_fire_p (:) = spval + + allocate (m_leafn_storage_to_litter_fire_p (numpft)) ; m_leafn_storage_to_litter_fire_p (:) = spval + allocate (m_frootn_storage_to_litter_fire_p (numpft)) ; m_frootn_storage_to_litter_fire_p (:) = spval + allocate (m_livestemn_storage_to_litter_fire_p (numpft)) ; m_livestemn_storage_to_litter_fire_p (:) = spval + allocate (m_deadstemn_storage_to_litter_fire_p (numpft)) ; m_deadstemn_storage_to_litter_fire_p (:) = spval + allocate (m_livecrootn_storage_to_litter_fire_p(numpft)) ; m_livecrootn_storage_to_litter_fire_p(:) = spval + allocate (m_deadcrootn_storage_to_litter_fire_p(numpft)) ; m_deadcrootn_storage_to_litter_fire_p(:) = spval + + allocate (m_leafn_xfer_to_litter_fire_p (numpft)) ; m_leafn_xfer_to_litter_fire_p (:) = spval + allocate (m_frootn_xfer_to_litter_fire_p (numpft)) ; m_frootn_xfer_to_litter_fire_p (:) = spval + allocate (m_livestemn_xfer_to_litter_fire_p (numpft)) ; m_livestemn_xfer_to_litter_fire_p (:) = spval + allocate (m_deadstemn_xfer_to_litter_fire_p (numpft)) ; m_deadstemn_xfer_to_litter_fire_p (:) = spval + allocate (m_livecrootn_xfer_to_litter_fire_p (numpft)) ; m_livecrootn_xfer_to_litter_fire_p (:) = spval + allocate (m_deadcrootn_xfer_to_litter_fire_p (numpft)) ; m_deadcrootn_xfer_to_litter_fire_p (:) = spval + + allocate (m_retransn_to_litter_fire_p (numpft)) ; m_retransn_to_litter_fire_p (:) = spval + + allocate (npool_to_leafn_p (numpft)) ; npool_to_leafn_p (:) = spval + allocate (npool_to_leafn_storage_p (numpft)) ; npool_to_leafn_storage_p (:) = spval + allocate (npool_to_frootn_p (numpft)) ; npool_to_frootn_p (:) = spval + allocate (npool_to_frootn_storage_p (numpft)) ; npool_to_frootn_storage_p (:) = spval + allocate (npool_to_livestemn_p (numpft)) ; npool_to_livestemn_p (:) = spval + allocate (npool_to_livestemn_storage_p (numpft)) ; npool_to_livestemn_storage_p (:) = spval + allocate (npool_to_deadstemn_p (numpft)) ; npool_to_deadstemn_p (:) = spval + allocate (npool_to_deadstemn_storage_p (numpft)) ; npool_to_deadstemn_storage_p (:) = spval + allocate (npool_to_livecrootn_p (numpft)) ; npool_to_livecrootn_p (:) = spval + allocate (npool_to_livecrootn_storage_p (numpft)) ; npool_to_livecrootn_storage_p (:) = spval + allocate (npool_to_deadcrootn_p (numpft)) ; npool_to_deadcrootn_p (:) = spval + allocate (npool_to_deadcrootn_storage_p (numpft)) ; npool_to_deadcrootn_storage_p (:) = spval + allocate (npool_to_grainn_p (numpft)) ; npool_to_grainn_p (:) = spval + allocate (npool_to_grainn_storage_p (numpft)) ; npool_to_grainn_storage_p (:) = spval + + allocate (respcsun_p (numpft)) ; respcsun_p (:) = spval + allocate (respcsha_p (numpft)) ; respcsha_p (:) = spval + allocate (leaf_mr_p (numpft)) ; leaf_mr_p (:) = spval + allocate (froot_mr_p (numpft)) ; froot_mr_p (:) = spval + allocate (livestem_mr_p (numpft)) ; livestem_mr_p (:) = spval + allocate (livecroot_mr_p (numpft)) ; livecroot_mr_p (:) = spval + allocate (grain_mr_p (numpft)) ; grain_mr_p (:) = spval + + allocate (soil_change_p (numpft)) ; soil_change_p (:) = spval + + allocate (psn_to_cpool_p (numpft)) ; psn_to_cpool_p (:) = spval + allocate (gpp_p (numpft)) ; gpp_p (:) = spval + allocate (availc_p (numpft)) ; availc_p (:) = spval + allocate (avail_retransn_p (numpft)) ; avail_retransn_p (:) = spval + allocate (xsmrpool_recover_p (numpft)) ; xsmrpool_recover_p (:) = spval + allocate (excess_cflux_p (numpft)) ; excess_cflux_p (:) = spval + allocate (sminn_to_npool_p (numpft)) ; sminn_to_npool_p (:) = spval + + allocate (plant_calloc_p (numpft)) ; plant_calloc_p (:) = spval + allocate (plant_nalloc_p (numpft)) ; plant_nalloc_p (:) = spval + allocate (leaf_curmr_p (numpft)) ; leaf_curmr_p (:) = spval + allocate (froot_curmr_p (numpft)) ; froot_curmr_p (:) = spval + allocate (livestem_curmr_p (numpft)) ; livestem_curmr_p (:) = spval + allocate (livecroot_curmr_p (numpft)) ; livecroot_curmr_p (:) = spval + allocate (grain_curmr_p (numpft)) ; grain_curmr_p (:) = spval + + allocate (fire_closs_p (numpft)) ; fire_closs_p (:) = spval + allocate (fire_nloss_p (numpft)) ; fire_nloss_p (:) = spval + allocate (wood_harvestc_p (numpft)) ; wood_harvestc_p (:) = spval + allocate (wood_harvestn_p (numpft)) ; wood_harvestn_p (:) = spval + allocate (grainc_to_cropprodc_p (numpft)) ; grainc_to_cropprodc_p (:) = spval + allocate (grainn_to_cropprodn_p (numpft)) ; grainn_to_cropprodn_p (:) = spval + allocate (hrv_xsmrpool_to_atm_p (numpft)) ; hrv_xsmrpool_to_atm_p (:) = spval + allocate (soyfixn_p (numpft)) ; soyfixn_p (:) = spval + + ENDIF + ENDIF + +!-------- + + END SUBROUTINE allocate_1D_BGCPFTFluxes + + SUBROUTINE deallocate_1D_BGCPFTFluxes + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPFT + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + +! bgc variables + deallocate (leafc_xfer_to_leafc_p ) + deallocate (frootc_xfer_to_frootc_p ) + deallocate (livestemc_xfer_to_livestemc_p ) + deallocate (deadstemc_xfer_to_deadstemc_p ) + deallocate (livecrootc_xfer_to_livecrootc_p ) + deallocate (deadcrootc_xfer_to_deadcrootc_p ) + deallocate (grainc_xfer_to_grainc_p ) + + deallocate (leafc_storage_to_xfer_p ) + deallocate (frootc_storage_to_xfer_p ) + deallocate (livestemc_storage_to_xfer_p ) + deallocate (deadstemc_storage_to_xfer_p ) + deallocate (livecrootc_storage_to_xfer_p ) + deallocate (deadcrootc_storage_to_xfer_p ) + deallocate (grainc_storage_to_xfer_p ) + deallocate (gresp_storage_to_xfer_p ) + + deallocate (leafc_to_litter_p ) + deallocate (frootc_to_litter_p ) + deallocate (grainc_to_food_p ) + deallocate (grainc_to_seed_p ) + deallocate (crop_seedc_to_leaf_p ) + deallocate (livestemc_to_litter_p ) + deallocate (livestemc_to_deadstemc_p ) + deallocate (livecrootc_to_deadcrootc_p ) + + deallocate (m_leafc_to_litter_p ) + deallocate (m_frootc_to_litter_p ) + deallocate (m_livestemc_to_litter_p ) + deallocate (m_deadstemc_to_litter_p ) + deallocate (m_livecrootc_to_litter_p ) + deallocate (m_deadcrootc_to_litter_p ) + + deallocate (m_leafc_storage_to_litter_p ) + deallocate (m_frootc_storage_to_litter_p ) + deallocate (m_livestemc_storage_to_litter_p ) + deallocate (m_deadstemc_storage_to_litter_p ) + deallocate (m_livecrootc_storage_to_litter_p ) + deallocate (m_deadcrootc_storage_to_litter_p ) + deallocate (m_gresp_storage_to_litter_p ) + + deallocate (m_leafc_xfer_to_litter_p ) + deallocate (m_frootc_xfer_to_litter_p ) + deallocate (m_livestemc_xfer_to_litter_p ) + deallocate (m_deadstemc_xfer_to_litter_p ) + deallocate (m_livecrootc_xfer_to_litter_p ) + deallocate (m_deadcrootc_xfer_to_litter_p ) + deallocate (m_gresp_xfer_to_litter_p ) + + deallocate (m_leafc_to_fire_p ) + deallocate (m_frootc_to_fire_p ) + deallocate (m_livestemc_to_fire_p ) + deallocate (m_deadstemc_to_fire_p ) + deallocate (m_livecrootc_to_fire_p ) + deallocate (m_deadcrootc_to_fire_p ) + + deallocate (m_leafc_storage_to_fire_p ) + deallocate (m_frootc_storage_to_fire_p ) + deallocate (m_livestemc_storage_to_fire_p ) + deallocate (m_deadstemc_storage_to_fire_p ) + deallocate (m_livecrootc_storage_to_fire_p ) + deallocate (m_deadcrootc_storage_to_fire_p ) + deallocate (m_gresp_storage_to_fire_p ) + + deallocate (m_leafc_xfer_to_fire_p ) + deallocate (m_frootc_xfer_to_fire_p ) + deallocate (m_livestemc_xfer_to_fire_p ) + deallocate (m_deadstemc_xfer_to_fire_p ) + deallocate (m_livecrootc_xfer_to_fire_p ) + deallocate (m_deadcrootc_xfer_to_fire_p ) + deallocate (m_gresp_xfer_to_fire_p ) + + deallocate (m_livestemc_to_deadstemc_fire_p ) + deallocate (m_livecrootc_to_deadcrootc_fire_p ) + + deallocate (m_leafc_to_litter_fire_p ) + deallocate (m_frootc_to_litter_fire_p ) + deallocate (m_livestemc_to_litter_fire_p ) + deallocate (m_deadstemc_to_litter_fire_p ) + deallocate (m_livecrootc_to_litter_fire_p ) + deallocate (m_deadcrootc_to_litter_fire_p ) + + deallocate (m_leafc_storage_to_litter_fire_p ) + deallocate (m_frootc_storage_to_litter_fire_p ) + deallocate (m_livestemc_storage_to_litter_fire_p ) + deallocate (m_deadstemc_storage_to_litter_fire_p ) + deallocate (m_livecrootc_storage_to_litter_fire_p) + deallocate (m_deadcrootc_storage_to_litter_fire_p) + deallocate (m_gresp_storage_to_litter_fire_p ) + + deallocate (m_leafc_xfer_to_litter_fire_p ) + deallocate (m_frootc_xfer_to_litter_fire_p ) + deallocate (m_livestemc_xfer_to_litter_fire_p ) + deallocate (m_deadstemc_xfer_to_litter_fire_p ) + deallocate (m_livecrootc_xfer_to_litter_fire_p ) + deallocate (m_deadcrootc_xfer_to_litter_fire_p ) + deallocate (m_gresp_xfer_to_litter_fire_p ) + + deallocate (cpool_to_xsmrpool_p ) + deallocate (cpool_to_gresp_storage_p ) + deallocate (cpool_to_leafc_p ) + deallocate (cpool_to_leafc_storage_p ) + deallocate (cpool_to_frootc_p ) + deallocate (cpool_to_frootc_storage_p ) + deallocate (cpool_to_livestemc_p ) + deallocate (cpool_to_livestemc_storage_p ) + deallocate (cpool_to_deadstemc_p ) + deallocate (cpool_to_deadstemc_storage_p ) + deallocate (cpool_to_livecrootc_p ) + deallocate (cpool_to_livecrootc_storage_p) + deallocate (cpool_to_deadcrootc_p ) + deallocate (cpool_to_deadcrootc_storage_p) + deallocate (cpool_to_grainc_p ) + deallocate (cpool_to_grainc_storage_p ) + + deallocate (leaf_xsmr_p ) + deallocate (froot_xsmr_p ) + deallocate (livestem_xsmr_p ) + deallocate (livecroot_xsmr_p ) + deallocate (grain_xsmr_p ) + + deallocate (cpool_leaf_gr_p ) + deallocate (cpool_froot_gr_p ) + deallocate (cpool_livestem_gr_p ) + deallocate (cpool_deadstem_gr_p ) + deallocate (cpool_livecroot_gr_p ) + deallocate (cpool_deadcroot_gr_p ) + deallocate (cpool_grain_gr_p ) + + deallocate (cpool_leaf_storage_gr_p ) + deallocate (cpool_froot_storage_gr_p ) + deallocate (cpool_livestem_storage_gr_p ) + deallocate (cpool_deadstem_storage_gr_p ) + deallocate (cpool_livecroot_storage_gr_p ) + deallocate (cpool_deadcroot_storage_gr_p ) + deallocate (cpool_grain_storage_gr_p ) + + deallocate (transfer_leaf_gr_p ) + deallocate (transfer_froot_gr_p ) + deallocate (transfer_livestem_gr_p ) + deallocate (transfer_deadstem_gr_p ) + deallocate (transfer_livecroot_gr_p ) + deallocate (transfer_deadcroot_gr_p ) + deallocate (transfer_grain_gr_p ) + + deallocate (xsmrpool_to_atm_p ) + + deallocate (cropprod1c_loss_p ) + + deallocate (plant_ndemand_p ) + + deallocate (leafn_xfer_to_leafn_p ) + deallocate (frootn_xfer_to_frootn_p ) + deallocate (livestemn_xfer_to_livestemn_p ) + deallocate (deadstemn_xfer_to_deadstemn_p ) + deallocate (livecrootn_xfer_to_livecrootn_p ) + deallocate (deadcrootn_xfer_to_deadcrootn_p ) + deallocate (grainn_xfer_to_grainn_p ) + + deallocate (leafn_storage_to_xfer_p ) + deallocate (frootn_storage_to_xfer_p ) + deallocate (livestemn_storage_to_xfer_p ) + deallocate (deadstemn_storage_to_xfer_p ) + deallocate (livecrootn_storage_to_xfer_p ) + deallocate (deadcrootn_storage_to_xfer_p ) + deallocate (grainn_storage_to_xfer_p ) + + deallocate (leafn_to_litter_p ) + deallocate (frootn_to_litter_p ) + deallocate (grainn_to_food_p ) + deallocate (grainn_to_seed_p ) + deallocate (crop_seedn_to_leaf_p ) + deallocate (livestemn_to_litter_p ) + deallocate (livestemn_to_deadstemn_p ) + deallocate (livecrootn_to_deadcrootn_p ) + + deallocate (leafn_to_retransn_p ) + deallocate (frootn_to_retransn_p ) + deallocate (livestemn_to_retransn_p ) + deallocate (livecrootn_to_retransn_p ) + deallocate (retransn_to_npool_p ) + deallocate (free_retransn_to_npool_p ) + + deallocate (m_leafn_to_litter_p ) + deallocate (m_frootn_to_litter_p ) + deallocate (m_livestemn_to_litter_p ) + deallocate (m_deadstemn_to_litter_p ) + deallocate (m_livecrootn_to_litter_p ) + deallocate (m_deadcrootn_to_litter_p ) + deallocate (m_retransn_to_litter_p ) + + deallocate (m_leafn_storage_to_litter_p ) + deallocate (m_frootn_storage_to_litter_p ) + deallocate (m_livestemn_storage_to_litter_p ) + deallocate (m_deadstemn_storage_to_litter_p ) + deallocate (m_livecrootn_storage_to_litter_p ) + deallocate (m_deadcrootn_storage_to_litter_p ) + + deallocate (m_leafn_xfer_to_litter_p ) + deallocate (m_frootn_xfer_to_litter_p ) + deallocate (m_livestemn_xfer_to_litter_p ) + deallocate (m_deadstemn_xfer_to_litter_p ) + deallocate (m_livecrootn_xfer_to_litter_p ) + deallocate (m_deadcrootn_xfer_to_litter_p ) + + deallocate (m_leafn_to_fire_p ) + deallocate (m_frootn_to_fire_p ) + deallocate (m_livestemn_to_fire_p ) + deallocate (m_deadstemn_to_fire_p ) + deallocate (m_livecrootn_to_fire_p ) + deallocate (m_deadcrootn_to_fire_p ) + + deallocate (m_leafn_storage_to_fire_p ) + deallocate (m_frootn_storage_to_fire_p ) + deallocate (m_livestemn_storage_to_fire_p ) + deallocate (m_deadstemn_storage_to_fire_p ) + deallocate (m_livecrootn_storage_to_fire_p ) + deallocate (m_deadcrootn_storage_to_fire_p ) + + deallocate (m_leafn_xfer_to_fire_p ) + deallocate (m_frootn_xfer_to_fire_p ) + deallocate (m_livestemn_xfer_to_fire_p ) + deallocate (m_deadstemn_xfer_to_fire_p ) + deallocate (m_livecrootn_xfer_to_fire_p ) + deallocate (m_deadcrootn_xfer_to_fire_p ) + + deallocate (m_livestemn_to_deadstemn_fire_p ) + deallocate (m_livecrootn_to_deadcrootn_fire_p ) + + deallocate (m_retransn_to_fire_p ) + + deallocate (m_leafn_to_litter_fire_p ) + deallocate (m_frootn_to_litter_fire_p ) + deallocate (m_livestemn_to_litter_fire_p ) + deallocate (m_deadstemn_to_litter_fire_p ) + deallocate (m_livecrootn_to_litter_fire_p ) + deallocate (m_deadcrootn_to_litter_fire_p ) + + deallocate (m_leafn_storage_to_litter_fire_p ) + deallocate (m_frootn_storage_to_litter_fire_p ) + deallocate (m_livestemn_storage_to_litter_fire_p ) + deallocate (m_deadstemn_storage_to_litter_fire_p ) + deallocate (m_livecrootn_storage_to_litter_fire_p) + deallocate (m_deadcrootn_storage_to_litter_fire_p) + + deallocate (m_leafn_xfer_to_litter_fire_p ) + deallocate (m_frootn_xfer_to_litter_fire_p ) + deallocate (m_livestemn_xfer_to_litter_fire_p ) + deallocate (m_deadstemn_xfer_to_litter_fire_p ) + deallocate (m_livecrootn_xfer_to_litter_fire_p ) + deallocate (m_deadcrootn_xfer_to_litter_fire_p ) + + deallocate (m_retransn_to_litter_fire_p ) + + deallocate (npool_to_leafn_p ) + deallocate (npool_to_leafn_storage_p ) + deallocate (npool_to_frootn_p ) + deallocate (npool_to_frootn_storage_p ) + deallocate (npool_to_livestemn_p ) + deallocate (npool_to_livestemn_storage_p ) + deallocate (npool_to_deadstemn_p ) + deallocate (npool_to_deadstemn_storage_p ) + deallocate (npool_to_livecrootn_p ) + deallocate (npool_to_livecrootn_storage_p ) + deallocate (npool_to_deadcrootn_p ) + deallocate (npool_to_deadcrootn_storage_p ) + deallocate (npool_to_grainn_p ) + deallocate (npool_to_grainn_storage_p ) + + deallocate (respcsun_p ) + deallocate (respcsha_p ) + deallocate (leaf_mr_p ) + deallocate (froot_mr_p ) + deallocate (livestem_mr_p ) + deallocate (livecroot_mr_p ) + deallocate (grain_mr_p ) + + deallocate (soil_change_p ) + + deallocate (psn_to_cpool_p ) + deallocate (gpp_p ) + deallocate (availc_p ) + deallocate (avail_retransn_p ) + deallocate (xsmrpool_recover_p ) + deallocate (excess_cflux_p ) + deallocate (sminn_to_npool_p ) + + deallocate (plant_calloc_p ) + deallocate (plant_nalloc_p ) + deallocate (leaf_curmr_p ) + deallocate (froot_curmr_p ) + deallocate (livestem_curmr_p ) + deallocate (livecroot_curmr_p ) + deallocate (grain_curmr_p ) + + deallocate (fire_closs_p ) + deallocate (fire_nloss_p ) + deallocate (wood_harvestc_p ) + deallocate (wood_harvestn_p ) + deallocate (grainc_to_cropprodc_p ) + deallocate (grainn_to_cropprodn_p ) + deallocate (hrv_xsmrpool_to_atm_p ) + deallocate (soyfixn_p ) + + ENDIF + ENDIF + + + END SUBROUTINE deallocate_1D_BGCPFTFluxes + + SUBROUTINE set_1D_BGCPFTFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + ! bgc variables + leafc_xfer_to_leafc_p (:) = Values + frootc_xfer_to_frootc_p (:) = Values + livestemc_xfer_to_livestemc_p (:) = Values + deadstemc_xfer_to_deadstemc_p (:) = Values + livecrootc_xfer_to_livecrootc_p (:) = Values + deadcrootc_xfer_to_deadcrootc_p (:) = Values + grainc_xfer_to_grainc_p (:) = Values + + leafc_storage_to_xfer_p (:) = Values + frootc_storage_to_xfer_p (:) = Values + livestemc_storage_to_xfer_p (:) = Values + deadstemc_storage_to_xfer_p (:) = Values + livecrootc_storage_to_xfer_p (:) = Values + deadcrootc_storage_to_xfer_p (:) = Values + grainc_storage_to_xfer_p (:) = Values + gresp_storage_to_xfer_p (:) = Values + + leafc_to_litter_p (:) = Values + frootc_to_litter_p (:) = Values + grainc_to_food_p (:) = Values + grainc_to_seed_p (:) = Values + crop_seedc_to_leaf_p (:) = Values + livestemc_to_litter_p (:) = Values + livestemc_to_deadstemc_p (:) = Values + livecrootc_to_deadcrootc_p (:) = Values + + m_leafc_to_litter_p (:) = Values + m_frootc_to_litter_p (:) = Values + m_livestemc_to_litter_p (:) = Values + m_deadstemc_to_litter_p (:) = Values + m_livecrootc_to_litter_p (:) = Values + m_deadcrootc_to_litter_p (:) = Values + + m_leafc_storage_to_litter_p (:) = Values + m_frootc_storage_to_litter_p (:) = Values + m_livestemc_storage_to_litter_p (:) = Values + m_deadstemc_storage_to_litter_p (:) = Values + m_livecrootc_storage_to_litter_p (:) = Values + m_deadcrootc_storage_to_litter_p (:) = Values + m_gresp_storage_to_litter_p (:) = Values + + m_leafc_xfer_to_litter_p (:) = Values + m_frootc_xfer_to_litter_p (:) = Values + m_livestemc_xfer_to_litter_p (:) = Values + m_deadstemc_xfer_to_litter_p (:) = Values + m_livecrootc_xfer_to_litter_p (:) = Values + m_deadcrootc_xfer_to_litter_p (:) = Values + m_gresp_xfer_to_litter_p (:) = Values + + m_leafc_to_fire_p (:) = Values + m_frootc_to_fire_p (:) = Values + m_livestemc_to_fire_p (:) = Values + m_deadstemc_to_fire_p (:) = Values + m_livecrootc_to_fire_p (:) = Values + m_deadcrootc_to_fire_p (:) = Values + + m_leafc_storage_to_fire_p (:) = Values + m_frootc_storage_to_fire_p (:) = Values + m_livestemc_storage_to_fire_p (:) = Values + m_deadstemc_storage_to_fire_p (:) = Values + m_livecrootc_storage_to_fire_p (:) = Values + m_deadcrootc_storage_to_fire_p (:) = Values + m_gresp_storage_to_fire_p (:) = Values + + m_leafc_xfer_to_fire_p (:) = Values + m_frootc_xfer_to_fire_p (:) = Values + m_livestemc_xfer_to_fire_p (:) = Values + m_deadstemc_xfer_to_fire_p (:) = Values + m_livecrootc_xfer_to_fire_p (:) = Values + m_deadcrootc_xfer_to_fire_p (:) = Values + m_gresp_xfer_to_fire_p (:) = Values + + m_livestemc_to_deadstemc_fire_p (:) = Values + m_livecrootc_to_deadcrootc_fire_p (:) = Values + + m_leafc_to_litter_fire_p (:) = Values + m_frootc_to_litter_fire_p (:) = Values + m_livestemc_to_litter_fire_p (:) = Values + m_deadstemc_to_litter_fire_p (:) = Values + m_livecrootc_to_litter_fire_p (:) = Values + m_deadcrootc_to_litter_fire_p (:) = Values + + m_leafc_storage_to_litter_fire_p (:) = Values + m_frootc_storage_to_litter_fire_p (:) = Values + m_livestemc_storage_to_litter_fire_p (:) = Values + m_deadstemc_storage_to_litter_fire_p (:) = Values + m_livecrootc_storage_to_litter_fire_p(:) = Values + m_deadcrootc_storage_to_litter_fire_p(:) = Values + m_gresp_storage_to_litter_fire_p (:) = Values + + m_leafc_xfer_to_litter_fire_p (:) = Values + m_frootc_xfer_to_litter_fire_p (:) = Values + m_livestemc_xfer_to_litter_fire_p (:) = Values + m_deadstemc_xfer_to_litter_fire_p (:) = Values + m_livecrootc_xfer_to_litter_fire_p (:) = Values + m_deadcrootc_xfer_to_litter_fire_p (:) = Values + m_gresp_xfer_to_litter_fire_p (:) = Values + + cpool_to_xsmrpool_p (:) = Values + cpool_to_gresp_storage_p (:) = Values + cpool_to_leafc_p (:) = Values + cpool_to_leafc_storage_p (:) = Values + cpool_to_frootc_p (:) = Values + cpool_to_frootc_storage_p (:) = Values + cpool_to_livestemc_p (:) = Values + cpool_to_livestemc_storage_p (:) = Values + cpool_to_deadstemc_p (:) = Values + cpool_to_deadstemc_storage_p (:) = Values + cpool_to_livecrootc_p (:) = Values + cpool_to_livecrootc_storage_p (:) = Values + cpool_to_deadcrootc_p (:) = Values + cpool_to_deadcrootc_storage_p (:) = Values + cpool_to_grainc_p (:) = Values + cpool_to_grainc_storage_p (:) = Values + + leaf_xsmr_p (:) = Values + froot_xsmr_p (:) = Values + livestem_xsmr_p (:) = Values + livecroot_xsmr_p (:) = Values + grain_xsmr_p (:) = Values + + cpool_leaf_gr_p (:) = Values + cpool_froot_gr_p (:) = Values + cpool_livestem_gr_p (:) = Values + cpool_deadstem_gr_p (:) = Values + cpool_livecroot_gr_p (:) = Values + cpool_deadcroot_gr_p (:) = Values + cpool_grain_gr_p (:) = Values + + cpool_leaf_storage_gr_p (:) = Values + cpool_froot_storage_gr_p (:) = Values + cpool_livestem_storage_gr_p (:) = Values + cpool_deadstem_storage_gr_p (:) = Values + cpool_livecroot_storage_gr_p (:) = Values + cpool_deadcroot_storage_gr_p (:) = Values + cpool_grain_storage_gr_p (:) = Values + + transfer_leaf_gr_p (:) = Values + transfer_froot_gr_p (:) = Values + transfer_livestem_gr_p (:) = Values + transfer_deadstem_gr_p (:) = Values + transfer_livecroot_gr_p (:) = Values + transfer_deadcroot_gr_p (:) = Values + transfer_grain_gr_p (:) = Values + + xsmrpool_to_atm_p (:) = Values + + cropprod1c_loss_p (:) = Values + + plant_ndemand_p (:) = Values + + leafn_xfer_to_leafn_p (:) = Values + frootn_xfer_to_frootn_p (:) = Values + livestemn_xfer_to_livestemn_p (:) = Values + deadstemn_xfer_to_deadstemn_p (:) = Values + livecrootn_xfer_to_livecrootn_p (:) = Values + deadcrootn_xfer_to_deadcrootn_p (:) = Values + grainn_xfer_to_grainn_p (:) = Values + + leafn_storage_to_xfer_p (:) = Values + frootn_storage_to_xfer_p (:) = Values + livestemn_storage_to_xfer_p (:) = Values + deadstemn_storage_to_xfer_p (:) = Values + livecrootn_storage_to_xfer_p (:) = Values + deadcrootn_storage_to_xfer_p (:) = Values + grainn_storage_to_xfer_p (:) = Values + + leafn_to_litter_p (:) = Values + frootn_to_litter_p (:) = Values + grainn_to_food_p (:) = Values + grainn_to_seed_p (:) = Values + crop_seedn_to_leaf_p (:) = Values + livestemn_to_litter_p (:) = Values + livestemn_to_deadstemn_p (:) = Values + livecrootn_to_deadcrootn_p (:) = Values + + leafn_to_retransn_p (:) = Values + frootn_to_retransn_p (:) = Values + livestemn_to_retransn_p (:) = Values + livecrootn_to_retransn_p (:) = Values + retransn_to_npool_p (:) = Values + free_retransn_to_npool_p (:) = Values + + m_leafn_to_litter_p (:) = Values + m_frootn_to_litter_p (:) = Values + m_livestemn_to_litter_p (:) = Values + m_deadstemn_to_litter_p (:) = Values + m_livecrootn_to_litter_p (:) = Values + m_deadcrootn_to_litter_p (:) = Values + m_retransn_to_litter_p (:) = Values + + m_leafn_storage_to_litter_p (:) = Values + m_frootn_storage_to_litter_p (:) = Values + m_livestemn_storage_to_litter_p (:) = Values + m_deadstemn_storage_to_litter_p (:) = Values + m_livecrootn_storage_to_litter_p (:) = Values + m_deadcrootn_storage_to_litter_p (:) = Values + + m_leafn_xfer_to_litter_p (:) = Values + m_frootn_xfer_to_litter_p (:) = Values + m_livestemn_xfer_to_litter_p (:) = Values + m_deadstemn_xfer_to_litter_p (:) = Values + m_livecrootn_xfer_to_litter_p (:) = Values + m_deadcrootn_xfer_to_litter_p (:) = Values + + m_leafn_to_fire_p (:) = Values + m_frootn_to_fire_p (:) = Values + m_livestemn_to_fire_p (:) = Values + m_deadstemn_to_fire_p (:) = Values + m_livecrootn_to_fire_p (:) = Values + m_deadcrootn_to_fire_p (:) = Values + + m_leafn_storage_to_fire_p (:) = Values + m_frootn_storage_to_fire_p (:) = Values + m_livestemn_storage_to_fire_p (:) = Values + m_deadstemn_storage_to_fire_p (:) = Values + m_livecrootn_storage_to_fire_p (:) = Values + m_deadcrootn_storage_to_fire_p (:) = Values + + m_leafn_xfer_to_fire_p (:) = Values + m_frootn_xfer_to_fire_p (:) = Values + m_livestemn_xfer_to_fire_p (:) = Values + m_deadstemn_xfer_to_fire_p (:) = Values + m_livecrootn_xfer_to_fire_p (:) = Values + m_deadcrootn_xfer_to_fire_p (:) = Values + + m_livestemn_to_deadstemn_fire_p (:) = Values + m_livecrootn_to_deadcrootn_fire_p (:) = Values + + m_retransn_to_fire_p (:) = Values + + m_leafn_to_litter_fire_p (:) = Values + m_frootn_to_litter_fire_p (:) = Values + m_livestemn_to_litter_fire_p (:) = Values + m_deadstemn_to_litter_fire_p (:) = Values + m_livecrootn_to_litter_fire_p (:) = Values + m_deadcrootn_to_litter_fire_p (:) = Values + + m_leafn_storage_to_litter_fire_p (:) = Values + m_frootn_storage_to_litter_fire_p (:) = Values + m_livestemn_storage_to_litter_fire_p (:) = Values + m_deadstemn_storage_to_litter_fire_p (:) = Values + m_livecrootn_storage_to_litter_fire_p(:) = Values + m_deadcrootn_storage_to_litter_fire_p(:) = Values + + m_leafn_xfer_to_litter_fire_p (:) = Values + m_frootn_xfer_to_litter_fire_p (:) = Values + m_livestemn_xfer_to_litter_fire_p (:) = Values + m_deadstemn_xfer_to_litter_fire_p (:) = Values + m_livecrootn_xfer_to_litter_fire_p (:) = Values + m_deadcrootn_xfer_to_litter_fire_p (:) = Values + + m_retransn_to_litter_fire_p (:) = Values + + npool_to_leafn_p (:) = Values + npool_to_leafn_storage_p (:) = Values + npool_to_frootn_p (:) = Values + npool_to_frootn_storage_p (:) = Values + npool_to_livestemn_p (:) = Values + npool_to_livestemn_storage_p (:) = Values + npool_to_deadstemn_p (:) = Values + npool_to_deadstemn_storage_p (:) = Values + npool_to_livecrootn_p (:) = Values + npool_to_livecrootn_storage_p (:) = Values + npool_to_deadcrootn_p (:) = Values + npool_to_deadcrootn_storage_p (:) = Values + npool_to_grainn_p (:) = Values + npool_to_grainn_storage_p (:) = Values + + respcsun_p (:) = Values!sunlit leaf respiration + respcsha_p (:) = Values!shaded leaf respiration + leaf_mr_p (:) = Values!leaf maintenance respiration + froot_mr_p (:) = Values!fine root maintenance respiration + livestem_mr_p (:) = Values!live stem maintenance respiration + livecroot_mr_p (:) = Values!live coarse root maintenance respiration + grain_mr_p (:) = Values!grain maintenance respiration + + soil_change_p (:) = Values + + psn_to_cpool_p (:) = Values + gpp_p (:) = Values + availc_p (:) = Values + avail_retransn_p (:) = Values + xsmrpool_recover_p (:) = Values + excess_cflux_p (:) = Values + sminn_to_npool_p (:) = Values + + plant_calloc_p (:) = Values + plant_nalloc_p (:) = Values + leaf_curmr_p (:) = Values + froot_curmr_p (:) = Values + livestem_curmr_p (:) = Values + livecroot_curmr_p (:) = Values + grain_curmr_p (:) = Values + + fire_closs_p (:) = Values + fire_nloss_p (:) = Values + wood_harvestc_p (:) = Values + wood_harvestn_p (:) = Values + grainc_to_cropprodc_p (:) = Values + grainn_to_cropprodn_p (:) = Values + hrv_xsmrpool_to_atm_p (:) = Values + soyfixn_p (:) = Values + + ENDIF + ENDIF + +!-------- + + END SUBROUTINE set_1D_BGCPFTFluxes +#endif + +END MODULE MOD_BGC_Vars_1DPFTFluxes + +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 new file mode 100644 index 0000000000..4bc5a1675f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 @@ -0,0 +1,2696 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_BGC_Vars_PFTimeVariables + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical state variables at pft level. +! Read and write biogeochemical state variables at pft level from/to restart files. + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + +#ifdef BGC + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_TimeManager + + IMPLICIT NONE + SAVE +! ----------------------------------------------------------------- +! Time-varying state variables which required by restart run +!--------------------- bgc variables --------------------------------------- + real(r8), allocatable :: leafc_p (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafc_storage_p (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafc_xfer_p (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootc_p (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootc_storage_p (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootc_xfer_p (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemc_p (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemc_storage_p (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemc_xfer_p (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemc_p (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc_storage_p (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc_xfer_p (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootc_p (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc_storage_p (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc_xfer_p (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootc_p (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc_storage_p (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc_xfer_p (:) ! dead coarse root transfer C (gC m-2) + real(r8), allocatable :: grainc_p (:) ! grain display C (gC m-2) + real(r8), allocatable :: grainc_storage_p (:) ! grain storage C (gC m-2) + real(r8), allocatable :: grainc_xfer_p (:) ! grain transfer C (gC m-2) + real(r8), allocatable :: cropseedc_deficit_p (:) ! crop seed deficit C (gC m-2) + real(r8), allocatable :: cropprod1c_p (:) ! product C (gC m-2) + real(r8), allocatable :: xsmrpool_p (:) ! maintenance respiration storage C (gC m-2) + real(r8), allocatable :: gresp_storage_p (:) ! growth respiration storage C (gC m-2) + real(r8), allocatable :: gresp_xfer_p (:) ! growth respiration transfer C (gC m-2) + real(r8), allocatable :: cpool_p (:) ! available C (gC m-2) + real(r8), allocatable :: totvegc_p (:) ! total vegetation C, including available C (gC m-2) + + real(r8), allocatable :: leaf_prof_p (:,:) ! vertical profile of leaves input to litter (m-1) + real(r8), allocatable :: stem_prof_p (:,:) ! vertical profile of stem input to litter (m-1) + real(r8), allocatable :: froot_prof_p (:,:) ! vertical profile of fine roots input to litter (m-1) + real(r8), allocatable :: croot_prof_p (:,:) ! vertical profile of coarse roots input to litter (m-1) + real(r8), allocatable :: cinput_rootfr_p (:,:) ! root fraction used for calculating vertical profile of roots input to litter (m-1) + + real(r8), allocatable :: leafn_p (:) ! leaf display N (gN m-2) + real(r8), allocatable :: leafn_storage_p (:) ! leaf storage N (gN m-2) + real(r8), allocatable :: leafn_xfer_p (:) ! leaf transfer N (gN m-2) + real(r8), allocatable :: frootn_p (:) ! fine root display N (gN m-2) + real(r8), allocatable :: frootn_storage_p (:) ! fine root storage N (gN m-2) + real(r8), allocatable :: frootn_xfer_p (:) ! fine root transfer N (gN m-2) + real(r8), allocatable :: livestemn_p (:) ! live stem display N (gN m-2) + real(r8), allocatable :: livestemn_storage_p (:) ! live stem storage N (gN m-2) + real(r8), allocatable :: livestemn_xfer_p (:) ! live stem transfer N (gN m-2) + real(r8), allocatable :: deadstemn_p (:) ! dead stem display N (gN m-2) + real(r8), allocatable :: deadstemn_storage_p (:) ! dead stem storage N (gN m-2) + real(r8), allocatable :: deadstemn_xfer_p (:) ! dead stem transfer N (gN m-2) + real(r8), allocatable :: livecrootn_p (:) ! live coarse root display N (gN m-2) + real(r8), allocatable :: livecrootn_storage_p (:) ! live coarse root storage N (gN m-2) + real(r8), allocatable :: livecrootn_xfer_p (:) ! live coarse root transfer N (gN m-2) + real(r8), allocatable :: deadcrootn_p (:) ! dead coarse root display N (gN m-2) + real(r8), allocatable :: deadcrootn_storage_p (:) ! dead coarse root storage N (gN m-2) + real(r8), allocatable :: deadcrootn_xfer_p (:) ! dead coarse root transfer N (gN m-2) + real(r8), allocatable :: grainn_p (:) ! grain display N (gN m-2) + real(r8), allocatable :: grainn_storage_p (:) ! grain storage N (gN m-2) + real(r8), allocatable :: grainn_xfer_p (:) ! grain transfer N (gN m-2) + real(r8), allocatable :: cropseedn_deficit_p (:) ! crop seed deficit N (gN m-2) + real(r8), allocatable :: harvdate_p (:) ! harvest date + integer , allocatable :: nyrs_crop_active_p (:) ! number of years of this crop has been active to calculate climate GDD + real(r8), allocatable :: retransn_p (:) ! retranslocated N (gN m-2) + real(r8), allocatable :: totvegn_p (:) ! total vegetation N, including available N (gN m-2) + + real(r8), allocatable :: tempsum_potential_gpp_p (:) ! temporary annual sum of potential GPP (gC m-2) + real(r8), allocatable :: tempmax_retransn_p (:) ! temporary annual max of retranslocated N (gN m-2) + real(r8), allocatable :: tempavg_tref_p (:) ! temporary annual average 2m air temperature (degree C) + real(r8), allocatable :: tempsum_npp_p (:) ! temporary annual sum NPP (gC m-2) + real(r8), allocatable :: tempsum_litfall_p (:) ! temporary annual sum litterfall (gC m-2) + real(r8), allocatable :: annsum_potential_gpp_p (:) ! annual sum of potential GPP (gC m-2) + real(r8), allocatable :: annmax_retransn_p (:) ! annual max of retranslocated N (gN m-2) + real(r8), allocatable :: annavg_tref_p (:) ! annual average 2m air temperature (degree C) + real(r8), allocatable :: annsum_npp_p (:) ! annual sum NPP (gC m-2) + real(r8), allocatable :: annsum_litfall_p (:) ! annual sum litterfall (gC m-2) + + real(r8), allocatable :: bglfr_p (:) ! background litterfall rate (1/s) + real(r8), allocatable :: bgtr_p (:) ! background transfer rate (1/s) + real(r8), allocatable :: lgsf_p (:) ! long growing season factor (0-1) + real(r8), allocatable :: gdd0_p (:) ! GDD based on 0 degree C + real(r8), allocatable :: gdd8_p (:) ! GDD based on 8 degree C + real(r8), allocatable :: gdd10_p (:) ! GDD based on 10 degree C + real(r8), allocatable :: gdd020_p (:) ! 20-year mean of GDD based on 0 degree C + real(r8), allocatable :: gdd820_p (:) ! 20-year mean of GDD based on 8 degree C + real(r8), allocatable :: gdd1020_p (:) ! 20-year mean of GDD based on 10 degree C + + real(r8), allocatable :: offset_flag_p (:) ! flag, 1 if offset + real(r8), allocatable :: offset_counter_p (:) ! time left for offset (s) + real(r8), allocatable :: onset_flag_p (:) ! flag, 1 if onset + real(r8), allocatable :: onset_counter_p (:) ! time left for onset (s) + real(r8), allocatable :: onset_gddflag_p (:) ! flag, 1 if begin to accumulate GDD for onset + real(r8), allocatable :: onset_gdd_p (:) ! onset GDD + real(r8), allocatable :: onset_fdd_p (:) ! onset freezing degree days counter + real(r8), allocatable :: onset_swi_p (:) ! onset soil water index + real(r8), allocatable :: offset_fdd_p (:) ! offset freezing degree days counter + real(r8), allocatable :: offset_swi_p (:) ! offset soil water index + real(r8), allocatable :: dormant_flag_p (:) ! flag, 1 if dormancy, 0 if not + real(r8), allocatable :: prev_leafc_to_litter_p (:) ! previous timestep leaf display C to litter C (gN m-2 s-1) + real(r8), allocatable :: prev_frootc_to_litter_p (:) ! previous timestep fine root display C to litter C (gN m-2 s-1) + real(r8), allocatable :: days_active_p (:) ! phenology-associated state: number of days since last dormancy + + real(r8), allocatable :: burndate_p (:) ! burn date for crop + + real(r8), allocatable :: c_allometry_p (:) ! C allocation index + real(r8), allocatable :: n_allometry_p (:) ! N allocation index + real(r8), allocatable :: downreg_p (:) ! fractional reduction in GPP due to N limitation + real(r8), allocatable :: grain_flag_p (:) ! flag, 1 if grain fill, 0 if not + + real(r8), allocatable :: ctrunc_p (:) ! additional carbon from precision control, currently not used + real(r8), allocatable :: ntrunc_p (:) ! additional nitrogen from precision control, currently not used + real(r8), allocatable :: npool_p (:) ! available N (gN m-2) + +!--------------------- CROP variables for GPAM------------------------------ +#ifdef CROP + logical, allocatable :: croplive_p (:) ! flag, true if crop live, not harvested + real(r8),allocatable :: hui_p (:) ! heat unit index since planting + real(r8),allocatable :: gddplant_p (:) ! GDD since planting + integer ,allocatable :: peaklai_p (:) ! flag, 1 if lai at maximum allowed, 0 if lai not at maximum allowed + real(r8),allocatable :: aroot_p (:) ! root allocation coefficient + real(r8),allocatable :: astem_p (:) ! stem allocation coefficient + real(r8),allocatable :: arepr_p (:) ! reproduction (fruit) allocation coefficient + real(r8),allocatable :: aleaf_p (:) ! leaf allocation coefficient + real(r8),allocatable :: astemi_p (:) ! stem allocation coefficient of phase 2 + real(r8),allocatable :: aleafi_p (:) ! leaf allocation coefficient of phase 2 + real(r8),allocatable :: gddmaturity_p (:) ! gdd needed to harvest + + logical, allocatable :: cropplant_p (:) ! flag, true if crop planted, not harvested; but if winter cereal still live at begin of the year, it will be set false + integer ,allocatable :: idop_p (:) ! planting date + real(r8),allocatable :: a5tmin_p (:) ! 5-day running mean of min 2 m temperature (degree C) + real(r8),allocatable :: a10tmin_p (:) ! 10-day running mean of min 2 m temperature (degree C) + real(r8),allocatable :: t10_p (:) ! 10-day running mean of 2 m temperature (degree C) + real(r8),allocatable :: cumvd_p (:) ! effective vernalization days (d) + real(r8),allocatable :: vf_p (:) ! vernalization factor (0-1) + real(r8),allocatable :: cphase_p (:) ! phenology phase + real(r8),allocatable :: fert_counter_p (:) ! time left to fertilize (s) + real(r8),allocatable :: tref_min_p (:) ! daily min of average 2-m temperature (degree C) + real(r8),allocatable :: tref_max_p (:) ! daily max of average 2-m temperature (degree C) + real(r8),allocatable :: tref_min_inst_p (:) ! temporary daily min of average 2-m temperature (degree C) + real(r8),allocatable :: tref_max_inst_p (:) ! temporary daily max of average 2-m temperature (degree C) + real(r8),allocatable :: fertnitro_p (:) ! fertilizer nitrogen (gN m-2) + real(r8),allocatable :: manunitro_p (:) ! manure nitrogen (gN m-2) + real(r8),allocatable :: fert_p (:) ! fertilizer nitrogen (gN m-2) including manure + real(r8),allocatable :: latbaset_p (:) ! latitude vary base temperature for gddplant (degree C) + real(r8),allocatable :: plantdate_p (:) ! planting date (input) +#endif +! --------------------- END CROP variables ------------------------- + +! --------------------- SASU variables ----------------------------- + real(r8), allocatable :: leafcCap_p (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafc_storageCap_p (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafc_xferCap_p (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootcCap_p (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootc_storageCap_p (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootc_xferCap_p (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemcCap_p (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemc_storageCap_p (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemc_xferCap_p (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemcCap_p (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc_storageCap_p (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc_xferCap_p (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootcCap_p (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc_storageCap_p (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc_xferCap_p (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootcCap_p (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc_storageCap_p (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc_xferCap_p (:) ! dead coarse root transfer C (gC m-2) + + real(r8), allocatable :: leafnCap_p (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafn_storageCap_p (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafn_xferCap_p (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootnCap_p (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootn_storageCap_p (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootn_xferCap_p (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemnCap_p (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemn_storageCap_p (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemn_xferCap_p (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemnCap_p (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemn_storageCap_p (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemn_xferCap_p (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootnCap_p (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootn_storageCap_p (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootn_xferCap_p (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootnCap_p (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootn_storageCap_p (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootn_xferCap_p (:) ! dead coarse root transfer C (gC m-2) + + real(r8), allocatable :: leafc0_p (:) ! SASU spinup initial value: leaf display C (gC m-2) + real(r8), allocatable :: leafc0_storage_p (:) ! SASU spinup initial value: leaf storage C (gC m-2) + real(r8), allocatable :: leafc0_xfer_p (:) ! SASU spinup initial value: leaf transfer C (gC m-2) + real(r8), allocatable :: frootc0_p (:) ! SASU spinup initial value: fine root display C (gC m-2) + real(r8), allocatable :: frootc0_storage_p (:) ! SASU spinup initial value: fine root storage C (gC m-2) + real(r8), allocatable :: frootc0_xfer_p (:) ! SASU spinup initial value: fine root transfer C (gC m-2) + real(r8), allocatable :: livestemc0_p (:) ! SASU spinup initial value: live stem display C (gC m-2) + real(r8), allocatable :: livestemc0_storage_p (:) ! SASU spinup initial value: live stem storage C (gC m-2) + real(r8), allocatable :: livestemc0_xfer_p (:) ! SASU spinup initial value: live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemc0_p (:) ! SASU spinup initial value: dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc0_storage_p (:) ! SASU spinup initial value: dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc0_xfer_p (:) ! SASU spinup initial value: dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootc0_p (:) ! SASU spinup initial value: live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc0_storage_p (:) ! SASU spinup initial value: live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc0_xfer_p (:) ! SASU spinup initial value: live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootc0_p (:) ! SASU spinup initial value: dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc0_storage_p (:) ! SASU spinup initial value: dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc0_xfer_p (:) ! SASU spinup initial value: dead coarse root transfer C (gC m-2) + real(r8), allocatable :: grainc0_p (:) ! SASU spinup initial value: grain display C (gC m-2) + real(r8), allocatable :: grainc0_storage_p (:) ! SASU spinup initial value: grain storage C (gC m-2) + real(r8), allocatable :: grainc0_xfer_p (:) ! SASU spinup initial value: grain transfer C (gC m-2) + + real(r8), allocatable :: leafn0_p (:) ! SASU spinup initial value: leaf display N (gN m-2) + real(r8), allocatable :: leafn0_storage_p (:) ! SASU spinup initial value: leaf storage N (gN m-2) + real(r8), allocatable :: leafn0_xfer_p (:) ! SASU spinup initial value: leaf transfer N (gN m-2) + real(r8), allocatable :: frootn0_p (:) ! SASU spinup initial value: fine root display N (gN m-2) + real(r8), allocatable :: frootn0_storage_p (:) ! SASU spinup initial value: fine root storage N (gN m-2) + real(r8), allocatable :: frootn0_xfer_p (:) ! SASU spinup initial value: fine root transfer N (gN m-2) + real(r8), allocatable :: livestemn0_p (:) ! SASU spinup initial value: live stem display N (gN m-2) + real(r8), allocatable :: livestemn0_storage_p (:) ! SASU spinup initial value: live stem storage N (gN m-2) + real(r8), allocatable :: livestemn0_xfer_p (:) ! SASU spinup initial value: live stem transfer N (gN m-2) + real(r8), allocatable :: deadstemn0_p (:) ! SASU spinup initial value: dead stem display N (gN m-2) + real(r8), allocatable :: deadstemn0_storage_p (:) ! SASU spinup initial value: dead stem storage N (gN m-2) + real(r8), allocatable :: deadstemn0_xfer_p (:) ! SASU spinup initial value: dead stem transfer N (gN m-2) + real(r8), allocatable :: livecrootn0_p (:) ! SASU spinup initial value: live coarse root display N (gN m-2) + real(r8), allocatable :: livecrootn0_storage_p (:) ! SASU spinup initial value: live coarse root storage N (gN m-2) + real(r8), allocatable :: livecrootn0_xfer_p (:) ! SASU spinup initial value: live coarse root transfer N (gN m-2) + real(r8), allocatable :: deadcrootn0_p (:) ! SASU spinup initial value: dead coarse root display N (gN m-2) + real(r8), allocatable :: deadcrootn0_storage_p (:) ! SASU spinup initial value: dead coarse root storage N (gN m-2) + real(r8), allocatable :: deadcrootn0_xfer_p (:) ! SASU spinup initial value: dead coarse root transfer N (gN m-2) + real(r8), allocatable :: grainn0_p (:) ! SASU spinup initial value: grain display N (gN m-2) + real(r8), allocatable :: grainn0_storage_p (:) ! SASU spinup initial value: grain storage N (gN m-2) + real(r8), allocatable :: grainn0_xfer_p (:) ! SASU spinup initial value: grain transfer N (gN m-2) + real(r8), allocatable :: retransn0_p (:) ! SASU spinup initial value: retranslocated N (gN m-2) + + real(r8), allocatable :: I_leafc_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf display C (gC m-2) + real(r8), allocatable :: I_leafc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf storage C (gC m-2) + real(r8), allocatable :: I_frootc_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root display C (gC m-2) + real(r8), allocatable :: I_frootc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root storage C (gC m-2) + real(r8), allocatable :: I_livestemc_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem display C (gC m-2) + real(r8), allocatable :: I_livestemc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem storage C (gC m-2) + real(r8), allocatable :: I_deadstemc_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem display C (gC m-2) + real(r8), allocatable :: I_deadstemc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem storage C (gC m-2) + real(r8), allocatable :: I_livecrootc_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root display C (gC m-2) + real(r8), allocatable :: I_livecrootc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root storage C (gC m-2) + real(r8), allocatable :: I_deadcrootc_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root display C (gC m-2) + real(r8), allocatable :: I_deadcrootc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root storage C (gC m-2) + real(r8), allocatable :: I_grainc_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain display C (gC m-2) + real(r8), allocatable :: I_grainc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain storage C (gC m-2) + real(r8), allocatable :: I_leafn_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf display N (gN m-2) + real(r8), allocatable :: I_leafn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf storage N (gN m-2) + real(r8), allocatable :: I_frootn_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root display N (gN m-2) + real(r8), allocatable :: I_frootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root storage N (gN m-2) + real(r8), allocatable :: I_livestemn_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem display N (gN m-2) + real(r8), allocatable :: I_livestemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem storage N (gN m-2) + real(r8), allocatable :: I_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem display N (gN m-2) + real(r8), allocatable :: I_deadstemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem storage N (gN m-2) + real(r8), allocatable :: I_livecrootn_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root display N (gN m-2) + real(r8), allocatable :: I_livecrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root storage N (gN m-2) + real(r8), allocatable :: I_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root display N (gN m-2) + real(r8), allocatable :: I_deadcrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root storage N (gN m-2) + real(r8), allocatable :: I_grainn_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain display N (gN m-2) + real(r8), allocatable :: I_grainn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain storage N (gN m-2) + + real(r8), allocatable :: AKX_leafc_xf_to_leafc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_frootc_xf_to_frootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_livestemc_xf_to_livestemc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_xf_to_deadstemc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_xf_to_livecrootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_xf_to_deadcrootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_grainc_xf_to_grainc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_livestemc_to_deadstemc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem display C to dead stem display C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_to_deadcrootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root display C to dead coarse root display C (gC m-2) + + real(r8), allocatable :: AKX_leafc_st_to_leafc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_frootc_st_to_frootc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_livestemc_st_to_livestemc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_st_to_deadstemc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_st_to_livecrootc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_grainc_st_to_grainc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain storage C to transfer C (gC m-2) + + real(r8), allocatable :: AKX_leafc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf display C (gC m-2) + real(r8), allocatable :: AKX_frootc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root display C (gC m-2) + real(r8), allocatable :: AKX_livestemc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem display C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem display C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root display C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root display C (gC m-2) + real(r8), allocatable :: AKX_grainc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain display C (gC m-2) + + real(r8), allocatable :: AKX_leafc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf storage C (gC m-2) + real(r8), allocatable :: AKX_frootc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root storage C (gC m-2) + real(r8), allocatable :: AKX_livestemc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem storage C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem storage C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root storage C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root storage C (gC m-2) + real(r8), allocatable :: AKX_grainc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain storage C (gC m-2) + + real(r8), allocatable :: AKX_leafc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf transfer C (gC m-2) + real(r8), allocatable :: AKX_frootc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root transfer C (gC m-2) + real(r8), allocatable :: AKX_livestemc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem transfer C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem transfer C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root transfer C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root transfer C (gC m-2) + real(r8), allocatable :: AKX_grainc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain transfer C (gC m-2) + + real(r8), allocatable :: AKX_leafn_xf_to_leafn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_frootn_xf_to_frootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_livestemn_xf_to_livestemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_xf_to_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_xf_to_livecrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_xf_to_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_grainn_xf_to_grainn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_livestemn_to_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem display N to dead stem display N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_to_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root display N to dead coarse root display N (gN m-2) + + real(r8), allocatable :: AKX_leafn_st_to_leafn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_frootn_st_to_frootn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_livestemn_st_to_livestemn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_st_to_deadstemn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_st_to_livecrootn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_grainn_st_to_grainn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain storage N to transfer N (gN m-2) + + real(r8), allocatable :: AKX_leafn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf display N to retranslocated N (gN m-2) + real(r8), allocatable :: AKX_frootn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root display N to retranslocated N (gN m-2) + real(r8), allocatable :: AKX_livestemn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem display N to retranslocated N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root display N to retranslocated N (gN m-2) + + real(r8), allocatable :: AKX_retransn_to_leafn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to leaf display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_frootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to fine root display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livestemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live stem display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead stem display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livecrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live coarse root display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead coarse root display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_grainn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to grain display N (gN m-2) + + real(r8), allocatable :: AKX_retransn_to_leafn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to leaf storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_frootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to fine root storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livestemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live stem storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadstemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead stem storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livecrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live coarse root storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadcrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead coarse root storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_grainn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to grain storage N (gN m-2) + + real(r8), allocatable :: AKX_leafn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf display N (gN m-2) + real(r8), allocatable :: AKX_frootn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root display N (gN m-2) + real(r8), allocatable :: AKX_livestemn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem display N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem display N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root display N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root display N (gN m-2) + real(r8), allocatable :: AKX_grainn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain display N (gN m-2) + real(r8), allocatable :: AKX_retransn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from retranslocated N (gN m-2) + + real(r8), allocatable :: AKX_leafn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf storge N (gN m-2) + real(r8), allocatable :: AKX_frootn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root storge N (gN m-2) + real(r8), allocatable :: AKX_livestemn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem storge N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem storge N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root storge N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root storge N (gN m-2) + real(r8), allocatable :: AKX_grainn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain storge N (gN m-2) + + real(r8), allocatable :: AKX_leafn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf transfer N (gN m-2) + real(r8), allocatable :: AKX_frootn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root transfer N (gN m-2) + real(r8), allocatable :: AKX_livestemn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem transfer N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem transfer N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root transfer N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root transfer N (gN m-2) + real(r8), allocatable :: AKX_grainn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain transfer N (gN m-2) + !------------------------- END BGC/SASU variables --------------------- + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_BGCPFTimeVariables + PUBLIC :: deallocate_BGCPFTimeVariables + PUBLIC :: READ_BGCPFTimeVariables + PUBLIC :: WRITE_BGCPFTimeVariables +#ifdef RangeCheck + PUBLIC :: check_BGCPFTimeVariables +#endif + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_BGCPFTimeVariables () +! ------------------------------------------------------ +! Allocates memory for CoLM 1d [numpft] variables +! ------------------------------------------------------ + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + USE MOD_Vars_Global + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + ! bgc variables + allocate (leafc_p (numpft)); leafc_p (:) = spval + allocate (leafc_storage_p (numpft)); leafc_storage_p (:) = spval + allocate (leafc_xfer_p (numpft)); leafc_xfer_p (:) = spval + allocate (frootc_p (numpft)); frootc_p (:) = spval + allocate (frootc_storage_p (numpft)); frootc_storage_p (:) = spval + allocate (frootc_xfer_p (numpft)); frootc_xfer_p (:) = spval + allocate (livestemc_p (numpft)); livestemc_p (:) = spval + allocate (livestemc_storage_p (numpft)); livestemc_storage_p (:) = spval + allocate (livestemc_xfer_p (numpft)); livestemc_xfer_p (:) = spval + allocate (deadstemc_p (numpft)); deadstemc_p (:) = spval + allocate (deadstemc_storage_p (numpft)); deadstemc_storage_p (:) = spval + allocate (deadstemc_xfer_p (numpft)); deadstemc_xfer_p (:) = spval + allocate (livecrootc_p (numpft)); livecrootc_p (:) = spval + allocate (livecrootc_storage_p (numpft)); livecrootc_storage_p (:) = spval + allocate (livecrootc_xfer_p (numpft)); livecrootc_xfer_p (:) = spval + allocate (deadcrootc_p (numpft)); deadcrootc_p (:) = spval + allocate (deadcrootc_storage_p (numpft)); deadcrootc_storage_p (:) = spval + allocate (deadcrootc_xfer_p (numpft)); deadcrootc_xfer_p (:) = spval + allocate (grainc_p (numpft)); grainc_p (:) = spval + allocate (grainc_storage_p (numpft)); grainc_storage_p (:) = spval + allocate (grainc_xfer_p (numpft)); grainc_xfer_p (:) = spval + allocate (cropseedc_deficit_p (numpft)); cropseedc_deficit_p (:) = spval + allocate (xsmrpool_p (numpft)); xsmrpool_p (:) = spval + allocate (gresp_storage_p (numpft)); gresp_storage_p (:) = spval + allocate (gresp_xfer_p (numpft)); gresp_xfer_p (:) = spval + allocate (cpool_p (numpft)); cpool_p (:) = spval + allocate (totvegc_p (numpft)); totvegc_p (:) = spval + allocate (cropprod1c_p (numpft)); cropprod1c_p (:) = spval + + allocate (leaf_prof_p (nl_soil,numpft)) ; leaf_prof_p (:,:) = spval + allocate (froot_prof_p (nl_soil,numpft)) ; froot_prof_p (:,:) = spval + allocate (croot_prof_p (nl_soil,numpft)) ; croot_prof_p (:,:) = spval + allocate (stem_prof_p (nl_soil,numpft)) ; stem_prof_p (:,:) = spval + allocate (cinput_rootfr_p (nl_soil,numpft)) ; cinput_rootfr_p (:,:) = spval + + allocate (leafn_p (numpft)); leafn_p (:) = spval + allocate (leafn_storage_p (numpft)); leafn_storage_p (:) = spval + allocate (leafn_xfer_p (numpft)); leafn_xfer_p (:) = spval + allocate (frootn_p (numpft)); frootn_p (:) = spval + allocate (frootn_storage_p (numpft)); frootn_storage_p (:) = spval + allocate (frootn_xfer_p (numpft)); frootn_xfer_p (:) = spval + allocate (livestemn_p (numpft)); livestemn_p (:) = spval + allocate (livestemn_storage_p (numpft)); livestemn_storage_p (:) = spval + allocate (livestemn_xfer_p (numpft)); livestemn_xfer_p (:) = spval + allocate (deadstemn_p (numpft)); deadstemn_p (:) = spval + allocate (deadstemn_storage_p (numpft)); deadstemn_storage_p (:) = spval + allocate (deadstemn_xfer_p (numpft)); deadstemn_xfer_p (:) = spval + allocate (livecrootn_p (numpft)); livecrootn_p (:) = spval + allocate (livecrootn_storage_p (numpft)); livecrootn_storage_p (:) = spval + allocate (livecrootn_xfer_p (numpft)); livecrootn_xfer_p (:) = spval + allocate (deadcrootn_p (numpft)); deadcrootn_p (:) = spval + allocate (deadcrootn_storage_p (numpft)); deadcrootn_storage_p (:) = spval + allocate (deadcrootn_xfer_p (numpft)); deadcrootn_xfer_p (:) = spval + allocate (grainn_p (numpft)); grainn_p (:) = spval + allocate (grainn_storage_p (numpft)); grainn_storage_p (:) = spval + allocate (grainn_xfer_p (numpft)); grainn_xfer_p (:) = spval + allocate (cropseedn_deficit_p (numpft)); cropseedn_deficit_p (:) = spval + allocate (retransn_p (numpft)); retransn_p (:) = spval + allocate (totvegn_p (numpft)); totvegn_p (:) = spval + + allocate (harvdate_p (numpft)); harvdate_p (:) = spval + + allocate (tempsum_potential_gpp_p (numpft)); tempsum_potential_gpp_p (:) = spval + allocate (tempmax_retransn_p (numpft)); tempmax_retransn_p (:) = spval + allocate (tempavg_tref_p (numpft)); tempavg_tref_p (:) = spval + allocate (tempsum_npp_p (numpft)); tempsum_npp_p (:) = spval + allocate (tempsum_litfall_p (numpft)); tempsum_litfall_p (:) = spval + allocate (annsum_potential_gpp_p (numpft)); annsum_potential_gpp_p (:) = spval + allocate (annmax_retransn_p (numpft)); annmax_retransn_p (:) = spval + allocate (annavg_tref_p (numpft)); annavg_tref_p (:) = spval + allocate (annsum_npp_p (numpft)); annsum_npp_p (:) = spval + allocate (annsum_litfall_p (numpft)); annsum_litfall_p (:) = spval + + allocate (bglfr_p (numpft)); bglfr_p (:) = spval + allocate (bgtr_p (numpft)); bgtr_p (:) = spval + allocate (lgsf_p (numpft)); lgsf_p (:) = spval + allocate (gdd0_p (numpft)); gdd0_p (:) = spval + allocate (gdd8_p (numpft)); gdd8_p (:) = spval + allocate (gdd10_p (numpft)); gdd10_p (:) = spval + allocate (gdd020_p (numpft)); gdd020_p (:) = spval + allocate (gdd820_p (numpft)); gdd820_p (:) = spval + allocate (gdd1020_p (numpft)); gdd1020_p (:) = spval + allocate (nyrs_crop_active_p (numpft)); nyrs_crop_active_p (:) = spval_i4 + + allocate (offset_flag_p (numpft)); offset_flag_p (:) = spval + allocate (offset_counter_p (numpft)); offset_counter_p (:) = spval + allocate (onset_flag_p (numpft)); onset_flag_p (:) = spval + allocate (onset_counter_p (numpft)); onset_counter_p (:) = spval + allocate (onset_gddflag_p (numpft)); onset_gddflag_p (:) = spval + allocate (onset_gdd_p (numpft)); onset_gdd_p (:) = spval + allocate (onset_fdd_p (numpft)); onset_fdd_p (:) = spval + allocate (onset_swi_p (numpft)); onset_swi_p (:) = spval + allocate (offset_fdd_p (numpft)); offset_fdd_p (:) = spval + allocate (offset_swi_p (numpft)); offset_swi_p (:) = spval + allocate (dormant_flag_p (numpft)); dormant_flag_p (:) = spval + allocate (prev_leafc_to_litter_p (numpft)); prev_leafc_to_litter_p (:) = spval + allocate (prev_frootc_to_litter_p (numpft)); prev_frootc_to_litter_p (:) = spval + allocate (days_active_p (numpft)); days_active_p (:) = spval + + allocate (burndate_p (numpft)); burndate_p (:) = spval + + allocate (c_allometry_p (numpft)); c_allometry_p (:) = spval + allocate (n_allometry_p (numpft)); n_allometry_p (:) = spval + allocate (downreg_p (numpft)); downreg_p (:) = spval + allocate (grain_flag_p (numpft)); grain_flag_p (:) = spval + + allocate (ctrunc_p (numpft)); ctrunc_p (:) = spval + allocate (ntrunc_p (numpft)); ntrunc_p (:) = spval + allocate (npool_p (numpft)); npool_p (:) = spval + +#ifdef CROP +! crop variables + allocate (croplive_p (numpft)); croplive_p (:) = .false. + allocate (hui_p (numpft)); hui_p (:) = spval + allocate (gddplant_p (numpft)); gddplant_p (:) = spval + allocate (peaklai_p (numpft)); peaklai_p (:) = spval_i4 + allocate (aroot_p (numpft)); aroot_p (:) = spval + allocate (astem_p (numpft)); astem_p (:) = spval + allocate (arepr_p (numpft)); arepr_p (:) = spval + allocate (aleaf_p (numpft)); aleaf_p (:) = spval + allocate (astemi_p (numpft)); astemi_p (:) = spval + allocate (aleafi_p (numpft)); aleafi_p (:) = spval + allocate (gddmaturity_p (numpft)); gddmaturity_p (:) = spval + + allocate (cropplant_p (numpft)); cropplant_p (:) = .false. + allocate (idop_p (numpft)); idop_p (:) = spval_i4 + allocate (a5tmin_p (numpft)); a5tmin_p (:) = spval + allocate (a10tmin_p (numpft)); a10tmin_p (:) = spval + allocate (t10_p (numpft)); t10_p (:) = spval + allocate (cumvd_p (numpft)); cumvd_p (:) = spval + allocate (vf_p (numpft)); vf_p (:) = spval + allocate (cphase_p (numpft)); cphase_p (:) = spval + allocate (fert_counter_p (numpft)); fert_counter_p (:) = spval + allocate (tref_min_p (numpft)); tref_min_p (:) = spval + allocate (tref_max_p (numpft)); tref_max_p (:) = spval + allocate (tref_min_inst_p (numpft)); tref_min_inst_p (:) = spval + allocate (tref_max_inst_p (numpft)); tref_max_inst_p (:) = spval + allocate (fertnitro_p (numpft)); fertnitro_p (:) = spval + allocate (manunitro_p (numpft)); manunitro_p (:) = spval + allocate (fert_p (numpft)); fert_p (:) = spval + allocate (latbaset_p (numpft)); latbaset_p (:) = spval + allocate (plantdate_p (numpft)); plantdate_p (:) = spval +#endif + +! SASU variables + allocate (leafcCap_p (numpft)); leafcCap_p (:) = spval + allocate (leafc_storageCap_p (numpft)); leafc_storageCap_p (:) = spval + allocate (leafc_xferCap_p (numpft)); leafc_xferCap_p (:) = spval + allocate (frootcCap_p (numpft)); frootcCap_p (:) = spval + allocate (frootc_storageCap_p (numpft)); frootc_storageCap_p (:) = spval + allocate (frootc_xferCap_p (numpft)); frootc_xferCap_p (:) = spval + allocate (livestemcCap_p (numpft)); livestemcCap_p (:) = spval + allocate (livestemc_storageCap_p (numpft)); livestemc_storageCap_p (:) = spval + allocate (livestemc_xferCap_p (numpft)); livestemc_xferCap_p (:) = spval + allocate (deadstemcCap_p (numpft)); deadstemcCap_p (:) = spval + allocate (deadstemc_storageCap_p (numpft)); deadstemc_storageCap_p (:) = spval + allocate (deadstemc_xferCap_p (numpft)); deadstemc_xferCap_p (:) = spval + allocate (livecrootcCap_p (numpft)); livecrootcCap_p (:) = spval + allocate (livecrootc_storageCap_p (numpft)); livecrootc_storageCap_p (:) = spval + allocate (livecrootc_xferCap_p (numpft)); livecrootc_xferCap_p (:) = spval + allocate (deadcrootcCap_p (numpft)); deadcrootcCap_p (:) = spval + allocate (deadcrootc_storageCap_p (numpft)); deadcrootc_storageCap_p (:) = spval + allocate (deadcrootc_xferCap_p (numpft)); deadcrootc_xferCap_p (:) = spval + + allocate (leafnCap_p (numpft)); leafnCap_p (:) = spval + allocate (leafn_storageCap_p (numpft)); leafn_storageCap_p (:) = spval + allocate (leafn_xferCap_p (numpft)); leafn_xferCap_p (:) = spval + allocate (frootnCap_p (numpft)); frootnCap_p (:) = spval + allocate (frootn_storageCap_p (numpft)); frootn_storageCap_p (:) = spval + allocate (frootn_xferCap_p (numpft)); frootn_xferCap_p (:) = spval + allocate (livestemnCap_p (numpft)); livestemnCap_p (:) = spval + allocate (livestemn_storageCap_p (numpft)); livestemn_storageCap_p (:) = spval + allocate (livestemn_xferCap_p (numpft)); livestemn_xferCap_p (:) = spval + allocate (deadstemnCap_p (numpft)); deadstemnCap_p (:) = spval + allocate (deadstemn_storageCap_p (numpft)); deadstemn_storageCap_p (:) = spval + allocate (deadstemn_xferCap_p (numpft)); deadstemn_xferCap_p (:) = spval + allocate (livecrootnCap_p (numpft)); livecrootnCap_p (:) = spval + allocate (livecrootn_storageCap_p (numpft)); livecrootn_storageCap_p (:) = spval + allocate (livecrootn_xferCap_p (numpft)); livecrootn_xferCap_p (:) = spval + allocate (deadcrootnCap_p (numpft)); deadcrootnCap_p (:) = spval + allocate (deadcrootn_storageCap_p (numpft)); deadcrootn_storageCap_p (:) = spval + allocate (deadcrootn_xferCap_p (numpft)); deadcrootn_xferCap_p (:) = spval + + allocate (leafc0_p (numpft)); leafc0_p (:) = spval + allocate (leafc0_storage_p (numpft)); leafc0_storage_p (:) = spval + allocate (leafc0_xfer_p (numpft)); leafc0_xfer_p (:) = spval + allocate (frootc0_p (numpft)); frootc0_p (:) = spval + allocate (frootc0_storage_p (numpft)); frootc0_storage_p (:) = spval + allocate (frootc0_xfer_p (numpft)); frootc0_xfer_p (:) = spval + allocate (livestemc0_p (numpft)); livestemc0_p (:) = spval + allocate (livestemc0_storage_p (numpft)); livestemc0_storage_p (:) = spval + allocate (livestemc0_xfer_p (numpft)); livestemc0_xfer_p (:) = spval + allocate (deadstemc0_p (numpft)); deadstemc0_p (:) = spval + allocate (deadstemc0_storage_p (numpft)); deadstemc0_storage_p (:) = spval + allocate (deadstemc0_xfer_p (numpft)); deadstemc0_xfer_p (:) = spval + allocate (livecrootc0_p (numpft)); livecrootc0_p (:) = spval + allocate (livecrootc0_storage_p (numpft)); livecrootc0_storage_p (:) = spval + allocate (livecrootc0_xfer_p (numpft)); livecrootc0_xfer_p (:) = spval + allocate (deadcrootc0_p (numpft)); deadcrootc0_p (:) = spval + allocate (deadcrootc0_storage_p (numpft)); deadcrootc0_storage_p (:) = spval + allocate (deadcrootc0_xfer_p (numpft)); deadcrootc0_xfer_p (:) = spval + allocate (grainc0_p (numpft)); grainc0_p (:) = spval + allocate (grainc0_storage_p (numpft)); grainc0_storage_p (:) = spval + allocate (grainc0_xfer_p (numpft)); grainc0_xfer_p (:) = spval + + allocate (leafn0_p (numpft)); leafn0_p (:) = spval + allocate (leafn0_storage_p (numpft)); leafn0_storage_p (:) = spval + allocate (leafn0_xfer_p (numpft)); leafn0_xfer_p (:) = spval + allocate (frootn0_p (numpft)); frootn0_p (:) = spval + allocate (frootn0_storage_p (numpft)); frootn0_storage_p (:) = spval + allocate (frootn0_xfer_p (numpft)); frootn0_xfer_p (:) = spval + allocate (livestemn0_p (numpft)); livestemn0_p (:) = spval + allocate (livestemn0_storage_p (numpft)); livestemn0_storage_p (:) = spval + allocate (livestemn0_xfer_p (numpft)); livestemn0_xfer_p (:) = spval + allocate (deadstemn0_p (numpft)); deadstemn0_p (:) = spval + allocate (deadstemn0_storage_p (numpft)); deadstemn0_storage_p (:) = spval + allocate (deadstemn0_xfer_p (numpft)); deadstemn0_xfer_p (:) = spval + allocate (livecrootn0_p (numpft)); livecrootn0_p (:) = spval + allocate (livecrootn0_storage_p (numpft)); livecrootn0_storage_p (:) = spval + allocate (livecrootn0_xfer_p (numpft)); livecrootn0_xfer_p (:) = spval + allocate (deadcrootn0_p (numpft)); deadcrootn0_p (:) = spval + allocate (deadcrootn0_storage_p (numpft)); deadcrootn0_storage_p (:) = spval + allocate (deadcrootn0_xfer_p (numpft)); deadcrootn0_xfer_p (:) = spval + allocate (grainn0_p (numpft)); grainn0_p (:) = spval + allocate (grainn0_storage_p (numpft)); grainn0_storage_p (:) = spval + allocate (grainn0_xfer_p (numpft)); grainn0_xfer_p (:) = spval + allocate (retransn0_p (numpft)); retransn0_p (:) = spval + + allocate (I_leafc_p_acc (numpft)); I_leafc_p_acc (:) = spval + allocate (I_leafc_st_p_acc (numpft)); I_leafc_st_p_acc (:) = spval + allocate (I_frootc_p_acc (numpft)); I_frootc_p_acc (:) = spval + allocate (I_frootc_st_p_acc (numpft)); I_frootc_st_p_acc (:) = spval + allocate (I_livestemc_p_acc (numpft)); I_livestemc_p_acc (:) = spval + allocate (I_livestemc_st_p_acc (numpft)); I_livestemc_st_p_acc (:) = spval + allocate (I_deadstemc_p_acc (numpft)); I_deadstemc_p_acc (:) = spval + allocate (I_deadstemc_st_p_acc (numpft)); I_deadstemc_st_p_acc (:) = spval + allocate (I_livecrootc_p_acc (numpft)); I_livecrootc_p_acc (:) = spval + allocate (I_livecrootc_st_p_acc (numpft)); I_livecrootc_st_p_acc (:) = spval + allocate (I_deadcrootc_p_acc (numpft)); I_deadcrootc_p_acc (:) = spval + allocate (I_deadcrootc_st_p_acc (numpft)); I_deadcrootc_st_p_acc (:) = spval + allocate (I_grainc_p_acc (numpft)); I_grainc_p_acc (:) = spval + allocate (I_grainc_st_p_acc (numpft)); I_grainc_st_p_acc (:) = spval + allocate (I_leafn_p_acc (numpft)); I_leafn_p_acc (:) = spval + allocate (I_leafn_st_p_acc (numpft)); I_leafn_st_p_acc (:) = spval + allocate (I_frootn_p_acc (numpft)); I_frootn_p_acc (:) = spval + allocate (I_frootn_st_p_acc (numpft)); I_frootn_st_p_acc (:) = spval + allocate (I_livestemn_p_acc (numpft)); I_livestemn_p_acc (:) = spval + allocate (I_livestemn_st_p_acc (numpft)); I_livestemn_st_p_acc (:) = spval + allocate (I_deadstemn_p_acc (numpft)); I_deadstemn_p_acc (:) = spval + allocate (I_deadstemn_st_p_acc (numpft)); I_deadstemn_st_p_acc (:) = spval + allocate (I_livecrootn_p_acc (numpft)); I_livecrootn_p_acc (:) = spval + allocate (I_livecrootn_st_p_acc (numpft)); I_livecrootn_st_p_acc (:) = spval + allocate (I_deadcrootn_p_acc (numpft)); I_deadcrootn_p_acc (:) = spval + allocate (I_deadcrootn_st_p_acc (numpft)); I_deadcrootn_st_p_acc (:) = spval + allocate (I_grainn_p_acc (numpft)); I_grainn_p_acc (:) = spval + allocate (I_grainn_st_p_acc (numpft)); I_grainn_st_p_acc (:) = spval + + allocate (AKX_leafc_xf_to_leafc_p_acc (numpft)); AKX_leafc_xf_to_leafc_p_acc (:) = spval + allocate (AKX_frootc_xf_to_frootc_p_acc (numpft)); AKX_frootc_xf_to_frootc_p_acc (:) = spval + allocate (AKX_livestemc_xf_to_livestemc_p_acc (numpft)); AKX_livestemc_xf_to_livestemc_p_acc (:) = spval + allocate (AKX_deadstemc_xf_to_deadstemc_p_acc (numpft)); AKX_deadstemc_xf_to_deadstemc_p_acc (:) = spval + allocate (AKX_livecrootc_xf_to_livecrootc_p_acc (numpft)); AKX_livecrootc_xf_to_livecrootc_p_acc (:) = spval + allocate (AKX_deadcrootc_xf_to_deadcrootc_p_acc (numpft)); AKX_deadcrootc_xf_to_deadcrootc_p_acc (:) = spval + allocate (AKX_grainc_xf_to_grainc_p_acc (numpft)); AKX_grainc_xf_to_grainc_p_acc (:) = spval + allocate (AKX_livestemc_to_deadstemc_p_acc (numpft)); AKX_livestemc_to_deadstemc_p_acc (:) = spval + allocate (AKX_livecrootc_to_deadcrootc_p_acc (numpft)); AKX_livecrootc_to_deadcrootc_p_acc (:) = spval + + allocate (AKX_leafc_st_to_leafc_xf_p_acc (numpft)); AKX_leafc_st_to_leafc_xf_p_acc (:) = spval + allocate (AKX_frootc_st_to_frootc_xf_p_acc (numpft)); AKX_frootc_st_to_frootc_xf_p_acc (:) = spval + allocate (AKX_livestemc_st_to_livestemc_xf_p_acc (numpft)); AKX_livestemc_st_to_livestemc_xf_p_acc (:) = spval + allocate (AKX_deadstemc_st_to_deadstemc_xf_p_acc (numpft)); AKX_deadstemc_st_to_deadstemc_xf_p_acc (:) = spval + allocate (AKX_livecrootc_st_to_livecrootc_xf_p_acc (numpft)); AKX_livecrootc_st_to_livecrootc_xf_p_acc (:) = spval + allocate (AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (numpft)); AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (:) = spval + allocate (AKX_grainc_st_to_grainc_xf_p_acc (numpft)); AKX_grainc_st_to_grainc_xf_p_acc (:) = spval + + allocate (AKX_leafc_exit_p_acc (numpft)); AKX_leafc_exit_p_acc (:) = spval + allocate (AKX_frootc_exit_p_acc (numpft)); AKX_frootc_exit_p_acc (:) = spval + allocate (AKX_livestemc_exit_p_acc (numpft)); AKX_livestemc_exit_p_acc (:) = spval + allocate (AKX_deadstemc_exit_p_acc (numpft)); AKX_deadstemc_exit_p_acc (:) = spval + allocate (AKX_livecrootc_exit_p_acc (numpft)); AKX_livecrootc_exit_p_acc (:) = spval + allocate (AKX_deadcrootc_exit_p_acc (numpft)); AKX_deadcrootc_exit_p_acc (:) = spval + allocate (AKX_grainc_exit_p_acc (numpft)); AKX_grainc_exit_p_acc (:) = spval + + allocate (AKX_leafc_st_exit_p_acc (numpft)); AKX_leafc_st_exit_p_acc (:) = spval + allocate (AKX_frootc_st_exit_p_acc (numpft)); AKX_frootc_st_exit_p_acc (:) = spval + allocate (AKX_livestemc_st_exit_p_acc (numpft)); AKX_livestemc_st_exit_p_acc (:) = spval + allocate (AKX_deadstemc_st_exit_p_acc (numpft)); AKX_deadstemc_st_exit_p_acc (:) = spval + allocate (AKX_livecrootc_st_exit_p_acc (numpft)); AKX_livecrootc_st_exit_p_acc (:) = spval + allocate (AKX_deadcrootc_st_exit_p_acc (numpft)); AKX_deadcrootc_st_exit_p_acc (:) = spval + allocate (AKX_grainc_st_exit_p_acc (numpft)); AKX_grainc_st_exit_p_acc (:) = spval + + allocate (AKX_leafc_xf_exit_p_acc (numpft)); AKX_leafc_xf_exit_p_acc (:) = spval + allocate (AKX_frootc_xf_exit_p_acc (numpft)); AKX_frootc_xf_exit_p_acc (:) = spval + allocate (AKX_livestemc_xf_exit_p_acc (numpft)); AKX_livestemc_xf_exit_p_acc (:) = spval + allocate (AKX_deadstemc_xf_exit_p_acc (numpft)); AKX_deadstemc_xf_exit_p_acc (:) = spval + allocate (AKX_livecrootc_xf_exit_p_acc (numpft)); AKX_livecrootc_xf_exit_p_acc (:) = spval + allocate (AKX_deadcrootc_xf_exit_p_acc (numpft)); AKX_deadcrootc_xf_exit_p_acc (:) = spval + allocate (AKX_grainc_xf_exit_p_acc (numpft)); AKX_grainc_xf_exit_p_acc (:) = spval + + allocate (AKX_leafn_xf_to_leafn_p_acc (numpft)); AKX_leafn_xf_to_leafn_p_acc (:) = spval + allocate (AKX_frootn_xf_to_frootn_p_acc (numpft)); AKX_frootn_xf_to_frootn_p_acc (:) = spval + allocate (AKX_livestemn_xf_to_livestemn_p_acc (numpft)); AKX_livestemn_xf_to_livestemn_p_acc (:) = spval + allocate (AKX_deadstemn_xf_to_deadstemn_p_acc (numpft)); AKX_deadstemn_xf_to_deadstemn_p_acc (:) = spval + allocate (AKX_livecrootn_xf_to_livecrootn_p_acc (numpft)); AKX_livecrootn_xf_to_livecrootn_p_acc (:) = spval + allocate (AKX_deadcrootn_xf_to_deadcrootn_p_acc (numpft)); AKX_deadcrootn_xf_to_deadcrootn_p_acc (:) = spval + allocate (AKX_grainn_xf_to_grainn_p_acc (numpft)); AKX_grainn_xf_to_grainn_p_acc (:) = spval + allocate (AKX_livestemn_to_deadstemn_p_acc (numpft)); AKX_livestemn_to_deadstemn_p_acc (:) = spval + allocate (AKX_livecrootn_to_deadcrootn_p_acc (numpft)); AKX_livecrootn_to_deadcrootn_p_acc (:) = spval + + allocate (AKX_leafn_st_to_leafn_xf_p_acc (numpft)); AKX_leafn_st_to_leafn_xf_p_acc (:) = spval + allocate (AKX_frootn_st_to_frootn_xf_p_acc (numpft)); AKX_frootn_st_to_frootn_xf_p_acc (:) = spval + allocate (AKX_livestemn_st_to_livestemn_xf_p_acc (numpft)); AKX_livestemn_st_to_livestemn_xf_p_acc (:) = spval + allocate (AKX_deadstemn_st_to_deadstemn_xf_p_acc (numpft)); AKX_deadstemn_st_to_deadstemn_xf_p_acc (:) = spval + allocate (AKX_livecrootn_st_to_livecrootn_xf_p_acc (numpft)); AKX_livecrootn_st_to_livecrootn_xf_p_acc (:) = spval + allocate (AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (numpft)); AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (:) = spval + allocate (AKX_grainn_st_to_grainn_xf_p_acc (numpft)); AKX_grainn_st_to_grainn_xf_p_acc (:) = spval + + allocate (AKX_leafn_to_retransn_p_acc (numpft)); AKX_leafn_to_retransn_p_acc (:) = spval + allocate (AKX_frootn_to_retransn_p_acc (numpft)); AKX_frootn_to_retransn_p_acc (:) = spval + allocate (AKX_livestemn_to_retransn_p_acc (numpft)); AKX_livestemn_to_retransn_p_acc (:) = spval + allocate (AKX_livecrootn_to_retransn_p_acc (numpft)); AKX_livecrootn_to_retransn_p_acc (:) = spval + + allocate (AKX_retransn_to_leafn_p_acc (numpft)); AKX_retransn_to_leafn_p_acc (:) = spval + allocate (AKX_retransn_to_frootn_p_acc (numpft)); AKX_retransn_to_frootn_p_acc (:) = spval + allocate (AKX_retransn_to_livestemn_p_acc (numpft)); AKX_retransn_to_livestemn_p_acc (:) = spval + allocate (AKX_retransn_to_deadstemn_p_acc (numpft)); AKX_retransn_to_deadstemn_p_acc (:) = spval + allocate (AKX_retransn_to_livecrootn_p_acc (numpft)); AKX_retransn_to_livecrootn_p_acc (:) = spval + allocate (AKX_retransn_to_deadcrootn_p_acc (numpft)); AKX_retransn_to_deadcrootn_p_acc (:) = spval + allocate (AKX_retransn_to_grainn_p_acc (numpft)); AKX_retransn_to_grainn_p_acc (:) = spval + + allocate (AKX_retransn_to_leafn_st_p_acc (numpft)); AKX_retransn_to_leafn_st_p_acc (:) = spval + allocate (AKX_retransn_to_frootn_st_p_acc (numpft)); AKX_retransn_to_frootn_st_p_acc (:) = spval + allocate (AKX_retransn_to_livestemn_st_p_acc (numpft)); AKX_retransn_to_livestemn_st_p_acc (:) = spval + allocate (AKX_retransn_to_deadstemn_st_p_acc (numpft)); AKX_retransn_to_deadstemn_st_p_acc (:) = spval + allocate (AKX_retransn_to_livecrootn_st_p_acc (numpft)); AKX_retransn_to_livecrootn_st_p_acc (:) = spval + allocate (AKX_retransn_to_deadcrootn_st_p_acc (numpft)); AKX_retransn_to_deadcrootn_st_p_acc (:) = spval + allocate (AKX_retransn_to_grainn_st_p_acc (numpft)); AKX_retransn_to_grainn_st_p_acc (:) = spval + + allocate (AKX_leafn_exit_p_acc (numpft)); AKX_leafn_exit_p_acc (:) = spval + allocate (AKX_frootn_exit_p_acc (numpft)); AKX_frootn_exit_p_acc (:) = spval + allocate (AKX_livestemn_exit_p_acc (numpft)); AKX_livestemn_exit_p_acc (:) = spval + allocate (AKX_deadstemn_exit_p_acc (numpft)); AKX_deadstemn_exit_p_acc (:) = spval + allocate (AKX_livecrootn_exit_p_acc (numpft)); AKX_livecrootn_exit_p_acc (:) = spval + allocate (AKX_deadcrootn_exit_p_acc (numpft)); AKX_deadcrootn_exit_p_acc (:) = spval + allocate (AKX_grainn_exit_p_acc (numpft)); AKX_grainn_exit_p_acc (:) = spval + allocate (AKX_retransn_exit_p_acc (numpft)); AKX_retransn_exit_p_acc (:) = spval + + allocate (AKX_leafn_st_exit_p_acc (numpft)); AKX_leafn_st_exit_p_acc (:) = spval + allocate (AKX_frootn_st_exit_p_acc (numpft)); AKX_frootn_st_exit_p_acc (:) = spval + allocate (AKX_livestemn_st_exit_p_acc (numpft)); AKX_livestemn_st_exit_p_acc (:) = spval + allocate (AKX_deadstemn_st_exit_p_acc (numpft)); AKX_deadstemn_st_exit_p_acc (:) = spval + allocate (AKX_livecrootn_st_exit_p_acc (numpft)); AKX_livecrootn_st_exit_p_acc (:) = spval + allocate (AKX_deadcrootn_st_exit_p_acc (numpft)); AKX_deadcrootn_st_exit_p_acc (:) = spval + allocate (AKX_grainn_st_exit_p_acc (numpft)); AKX_grainn_st_exit_p_acc (:) = spval + + allocate (AKX_leafn_xf_exit_p_acc (numpft)); AKX_leafn_xf_exit_p_acc (:) = spval + allocate (AKX_frootn_xf_exit_p_acc (numpft)); AKX_frootn_xf_exit_p_acc (:) = spval + allocate (AKX_livestemn_xf_exit_p_acc (numpft)); AKX_livestemn_xf_exit_p_acc (:) = spval + allocate (AKX_deadstemn_xf_exit_p_acc (numpft)); AKX_deadstemn_xf_exit_p_acc (:) = spval + allocate (AKX_livecrootn_xf_exit_p_acc (numpft)); AKX_livecrootn_xf_exit_p_acc (:) = spval + allocate (AKX_deadcrootn_xf_exit_p_acc (numpft)); AKX_deadcrootn_xf_exit_p_acc (:) = spval + allocate (AKX_grainn_xf_exit_p_acc (numpft)); AKX_grainn_xf_exit_p_acc (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_BGCPFTimeVariables + + SUBROUTINE READ_BGCPFTimeVariables (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +! bgc variables + CALL ncio_read_vector (file_restart, 'leafc_p ', landpft, leafc_p ) + CALL ncio_read_vector (file_restart, 'leafc_storage_p ', landpft, leafc_storage_p ) + CALL ncio_read_vector (file_restart, 'leafc_xfer_p ', landpft, leafc_xfer_p ) + CALL ncio_read_vector (file_restart, 'frootc_p ', landpft, frootc_p ) + CALL ncio_read_vector (file_restart, 'frootc_storage_p ', landpft, frootc_storage_p ) + CALL ncio_read_vector (file_restart, 'frootc_xfer_p ', landpft, frootc_xfer_p ) + CALL ncio_read_vector (file_restart, 'livestemc_p ', landpft, livestemc_p ) + CALL ncio_read_vector (file_restart, 'livestemc_storage_p ', landpft, livestemc_storage_p ) + CALL ncio_read_vector (file_restart, 'livestemc_xfer_p ', landpft, livestemc_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadstemc_p ', landpft, deadstemc_p ) + CALL ncio_read_vector (file_restart, 'deadstemc_storage_p ', landpft, deadstemc_storage_p ) + CALL ncio_read_vector (file_restart, 'deadstemc_xfer_p ', landpft, deadstemc_xfer_p ) + CALL ncio_read_vector (file_restart, 'livecrootc_p ', landpft, livecrootc_p ) + CALL ncio_read_vector (file_restart, 'livecrootc_storage_p ', landpft, livecrootc_storage_p ) + CALL ncio_read_vector (file_restart, 'livecrootc_xfer_p ', landpft, livecrootc_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadcrootc_p ', landpft, deadcrootc_p ) + CALL ncio_read_vector (file_restart, 'deadcrootc_storage_p ', landpft, deadcrootc_storage_p ) + CALL ncio_read_vector (file_restart, 'deadcrootc_xfer_p ', landpft, deadcrootc_xfer_p ) + CALL ncio_read_vector (file_restart, 'grainc_p ', landpft, grainc_p ) + CALL ncio_read_vector (file_restart, 'grainc_storage_p ', landpft, grainc_storage_p ) + CALL ncio_read_vector (file_restart, 'grainc_xfer_p ', landpft, grainc_xfer_p ) + CALL ncio_read_vector (file_restart, 'cropseedc_deficit_p ', landpft, cropseedc_deficit_p ) + CALL ncio_read_vector (file_restart, 'xsmrpool_p ', landpft, xsmrpool_p ) + CALL ncio_read_vector (file_restart, 'gresp_storage_p ', landpft, gresp_storage_p ) + CALL ncio_read_vector (file_restart, 'gresp_xfer_p ', landpft, gresp_xfer_p ) + CALL ncio_read_vector (file_restart, 'cpool_p ', landpft, cpool_p ) + ! CALL ncio_read_vector (file_restart, 'totvegc_p ', landpft, totvegc_p ) + CALL ncio_read_vector (file_restart, 'cropprod1c_p ', landpft, cropprod1c_p ) + + CALL ncio_read_vector (file_restart, 'leafn_p ', landpft, leafn_p ) + CALL ncio_read_vector (file_restart, 'leafn_storage_p ', landpft, leafn_storage_p ) + CALL ncio_read_vector (file_restart, 'leafn_xfer_p ', landpft, leafn_xfer_p ) + CALL ncio_read_vector (file_restart, 'frootn_p ', landpft, frootn_p ) + CALL ncio_read_vector (file_restart, 'frootn_storage_p ', landpft, frootn_storage_p ) + CALL ncio_read_vector (file_restart, 'frootn_xfer_p ', landpft, frootn_xfer_p ) + CALL ncio_read_vector (file_restart, 'livestemn_p ', landpft, livestemn_p ) + CALL ncio_read_vector (file_restart, 'livestemn_storage_p ', landpft, livestemn_storage_p ) + CALL ncio_read_vector (file_restart, 'livestemn_xfer_p ', landpft, livestemn_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadstemn_p ', landpft, deadstemn_p ) + CALL ncio_read_vector (file_restart, 'deadstemn_storage_p ', landpft, deadstemn_storage_p ) + CALL ncio_read_vector (file_restart, 'deadstemn_xfer_p ', landpft, deadstemn_xfer_p ) + CALL ncio_read_vector (file_restart, 'livecrootn_p ', landpft, livecrootn_p ) + CALL ncio_read_vector (file_restart, 'livecrootn_storage_p ', landpft, livecrootn_storage_p ) + CALL ncio_read_vector (file_restart, 'livecrootn_xfer_p ', landpft, livecrootn_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadcrootn_p ', landpft, deadcrootn_p ) + CALL ncio_read_vector (file_restart, 'deadcrootn_storage_p ', landpft, deadcrootn_storage_p ) + CALL ncio_read_vector (file_restart, 'deadcrootn_xfer_p ', landpft, deadcrootn_xfer_p ) + CALL ncio_read_vector (file_restart, 'grainn_p ', landpft, grainn_p ) + CALL ncio_read_vector (file_restart, 'grainn_storage_p ', landpft, grainn_storage_p ) + CALL ncio_read_vector (file_restart, 'grainn_xfer_p ', landpft, grainn_xfer_p ) + CALL ncio_read_vector (file_restart, 'cropseedn_deficit_p ', landpft, cropseedn_deficit_p ) + CALL ncio_read_vector (file_restart, 'retransn_p ', landpft, retransn_p ) + ! CALL ncio_read_vector (file_restart, 'totvegn_p ', landpft, totvegn_p ) + + CALL ncio_read_vector (file_restart, 'harvdate_p ', landpft, harvdate_p ) + + CALL ncio_read_vector (file_restart, 'tempsum_potential_gpp_p', landpft, tempsum_potential_gpp_p) + CALL ncio_read_vector (file_restart, 'tempmax_retransn_p ', landpft, tempmax_retransn_p ) + CALL ncio_read_vector (file_restart, 'tempavg_tref_p ', landpft, tempavg_tref_p ) + CALL ncio_read_vector (file_restart, 'tempsum_npp_p ', landpft, tempsum_npp_p ) + CALL ncio_read_vector (file_restart, 'tempsum_litfall_p ', landpft, tempsum_litfall_p ) + CALL ncio_read_vector (file_restart, 'annsum_potential_gpp_p ', landpft, annsum_potential_gpp_p) + CALL ncio_read_vector (file_restart, 'annmax_retransn_p ', landpft, annmax_retransn_p ) + CALL ncio_read_vector (file_restart, 'annavg_tref_p ', landpft, annavg_tref_p ) + CALL ncio_read_vector (file_restart, 'annsum_npp_p ', landpft, annsum_npp_p ) + CALL ncio_read_vector (file_restart, 'annsum_litfall_p ', landpft, annsum_litfall_p ) + + CALL ncio_read_vector (file_restart, 'bglfr_p ', landpft, bglfr_p ) + CALL ncio_read_vector (file_restart, 'bgtr_p ', landpft, bgtr_p ) + CALL ncio_read_vector (file_restart, 'lgsf_p ', landpft, lgsf_p ) + CALL ncio_read_vector (file_restart, 'gdd0_p ', landpft, gdd0_p ) + CALL ncio_read_vector (file_restart, 'gdd8_p ', landpft, gdd8_p ) + CALL ncio_read_vector (file_restart, 'gdd10_p ', landpft, gdd10_p ) + CALL ncio_read_vector (file_restart, 'gdd020_p ', landpft, gdd020_p ) + CALL ncio_read_vector (file_restart, 'gdd820_p ', landpft, gdd820_p ) + CALL ncio_read_vector (file_restart, 'gdd1020_p ', landpft, gdd1020_p ) + CALL ncio_read_vector (file_restart, 'nyrs_crop_active_p ', landpft, nyrs_crop_active_p ) + + CALL ncio_read_vector (file_restart, 'offset_flag_p ', landpft, offset_flag_p ) + CALL ncio_read_vector (file_restart, 'offset_counter_p ', landpft, offset_counter_p ) + CALL ncio_read_vector (file_restart, 'onset_flag_p ', landpft, onset_flag_p ) + CALL ncio_read_vector (file_restart, 'onset_counter_p ', landpft, onset_counter_p ) + CALL ncio_read_vector (file_restart, 'onset_gddflag_p ', landpft, onset_gddflag_p ) + CALL ncio_read_vector (file_restart, 'onset_gdd_p ', landpft, onset_gdd_p ) + CALL ncio_read_vector (file_restart, 'onset_fdd_p ', landpft, onset_fdd_p ) + CALL ncio_read_vector (file_restart, 'onset_swi_p ', landpft, onset_swi_p ) + CALL ncio_read_vector (file_restart, 'offset_fdd_p ', landpft, offset_fdd_p ) + CALL ncio_read_vector (file_restart, 'offset_swi_p ', landpft, offset_swi_p ) + CALL ncio_read_vector (file_restart, 'dormant_flag_p ', landpft, dormant_flag_p ) + CALL ncio_read_vector (file_restart, 'prev_leafc_to_litter_p ', landpft, prev_leafc_to_litter_p) + CALL ncio_read_vector (file_restart, 'prev_frootc_to_litter_p', landpft, prev_frootc_to_litter_p) + CALL ncio_read_vector (file_restart, 'days_active_p ', landpft, days_active_p ) + + CALL ncio_read_vector (file_restart, 'burndate_p ', landpft, burndate_p ) + CALL ncio_read_vector (file_restart, 'grain_flag_p ', landpft, grain_flag_p ) + CALL ncio_read_vector (file_restart, 'ctrunc_p ', landpft, ctrunc_p ) + CALL ncio_read_vector (file_restart, 'ntrunc_p ', landpft, ntrunc_p ) + CALL ncio_read_vector (file_restart, 'npool_p ', landpft, npool_p ) + +#ifdef CROP +! crop variables + CALL ncio_read_vector (file_restart, 'croplive_p ', landpft, croplive_p ) + CALL ncio_read_vector (file_restart, 'hui_p ', landpft, hui_p ) + CALL ncio_read_vector (file_restart, 'gddplant_p ', landpft, gddplant_p ) + CALL ncio_read_vector (file_restart, 'peaklai_p ', landpft, peaklai_p ) + CALL ncio_read_vector (file_restart, 'aroot_p ', landpft, aroot_p ) + CALL ncio_read_vector (file_restart, 'astem_p ', landpft, astem_p ) + CALL ncio_read_vector (file_restart, 'arepr_p ', landpft, arepr_p ) + CALL ncio_read_vector (file_restart, 'aleaf_p ', landpft, aleaf_p ) + CALL ncio_read_vector (file_restart, 'astemi_p ', landpft, astemi_p ) + CALL ncio_read_vector (file_restart, 'aleafi_p ', landpft, aleafi_p ) + CALL ncio_read_vector (file_restart, 'gddmaturity_p ', landpft, gddmaturity_p ) + + CALL ncio_read_vector (file_restart, 'cropplant_p ', landpft, cropplant_p ) + CALL ncio_read_vector (file_restart, 'idop_p ', landpft, idop_p ) + CALL ncio_read_vector (file_restart, 'a5tmin_p ', landpft, a5tmin_p ) + CALL ncio_read_vector (file_restart, 'a10tmin_p ', landpft, a10tmin_p ) + CALL ncio_read_vector (file_restart, 't10_p ', landpft, t10_p ) + CALL ncio_read_vector (file_restart, 'cumvd_p ', landpft, cumvd_p ) + CALL ncio_read_vector (file_restart, 'vf_p ', landpft, vf_p ) + CALL ncio_read_vector (file_restart, 'cphase_p ', landpft, cphase_p ) + CALL ncio_read_vector (file_restart, 'fert_counter_p ', landpft, fert_counter_p ) + CALL ncio_read_vector (file_restart, 'tref_min_p ', landpft, tref_min_p ) + CALL ncio_read_vector (file_restart, 'tref_max_p ', landpft, tref_max_p ) + CALL ncio_read_vector (file_restart, 'tref_min_inst_p ', landpft, tref_min_inst_p ) + CALL ncio_read_vector (file_restart, 'tref_max_inst_p ', landpft, tref_max_inst_p ) + CALL ncio_read_vector (file_restart, 'fertnitro_p ', landpft, fertnitro_p ) + CALL ncio_read_vector (file_restart, 'manunitro_p ', landpft, manunitro_p ) + CALL ncio_read_vector (file_restart, 'fert_p ', landpft, fert_p ) + CALL ncio_read_vector (file_restart, 'latbaset_p ', landpft, latbaset_p ) + CALL ncio_read_vector (file_restart, 'plantdate_p ', landpft, plantdate_p ) +#endif + + IF(DEF_USE_DiagMatrix)THEN +! SASU variables + CALL ncio_read_vector (file_restart, 'leafcCap_p ', landpft, leafcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc_storageCap_p ', landpft, leafc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc_xferCap_p ', landpft, leafc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootcCap_p ', landpft, frootcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc_storageCap_p ', landpft, frootc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc_xferCap_p ', landpft, frootc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemcCap_p ', landpft, livestemcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc_storageCap_p ', landpft, livestemc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc_xferCap_p ', landpft, livestemc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemcCap_p ', landpft, deadstemcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc_storageCap_p ', landpft, deadstemc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc_xferCap_p ', landpft, deadstemc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootcCap_p ', landpft, livecrootcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc_storageCap_p', landpft, livecrootc_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc_xferCap_p ', landpft, livecrootc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootcCap_p ', landpft, deadcrootcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc_storageCap_p', landpft, deadcrootc_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc_xferCap_p ', landpft, deadcrootc_xferCap_p , defval = 1._r8) + + CALL ncio_read_vector (file_restart, 'leafnCap_p ', landpft, leafnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn_storageCap_p ', landpft, leafn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn_xferCap_p ', landpft, leafn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootnCap_p ', landpft, frootnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn_storageCap_p ', landpft, frootn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn_xferCap_p ', landpft, frootn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemnCap_p ', landpft, livestemnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn_storageCap_p ', landpft, livestemn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn_xferCap_p ', landpft, livestemn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemnCap_p ', landpft, deadstemnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn_storageCap_p ', landpft, deadstemn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn_xferCap_p ', landpft, deadstemn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootnCap_p ', landpft, livecrootnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn_storageCap_p', landpft, livecrootn_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn_xferCap_p ', landpft, livecrootn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootnCap_p ', landpft, deadcrootnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn_storageCap_p', landpft, deadcrootn_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn_xferCap_p ', landpft, deadcrootn_xferCap_p , defval = 1._r8) + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL ncio_read_vector (file_restart, 'leafc0_p ', landpft, leafc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc0_storage_p ', landpft, leafc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc0_xfer_p ', landpft, leafc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc0_p ', landpft, frootc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc0_storage_p ', landpft, frootc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc0_xfer_p ', landpft, frootc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc0_p ', landpft, livestemc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc0_storage_p ', landpft, livestemc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc0_xfer_p ', landpft, livestemc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc0_p ', landpft, deadstemc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc0_storage_p ', landpft, deadstemc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc0_xfer_p ', landpft, deadstemc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc0_p ', landpft, livecrootc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc0_storage_p ', landpft, livecrootc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc0_xfer_p ', landpft, livecrootc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc0_p ', landpft, deadcrootc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc0_storage_p ', landpft, deadcrootc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc0_xfer_p ', landpft, deadcrootc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainc0_p ', landpft, grainc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainc0_storage_p ', landpft, grainc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainc0_xfer_p ', landpft, grainc0_xfer_p , defval = 1._r8) + + CALL ncio_read_vector (file_restart, 'leafn0_p ', landpft, leafn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn0_storage_p ', landpft, leafn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn0_xfer_p ', landpft, leafn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn0_p ', landpft, frootn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn0_storage_p ', landpft, frootn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn0_xfer_p ', landpft, frootn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn0_p ', landpft, livestemn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn0_storage_p ', landpft, livestemn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn0_xfer_p ', landpft, livestemn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn0_p ', landpft, deadstemn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn0_storage_p ', landpft, deadstemn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn0_xfer_p ', landpft, deadstemn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn0_p ', landpft, livecrootn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn0_storage_p ', landpft, livecrootn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn0_xfer_p ', landpft, livecrootn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn0_p ', landpft, deadcrootn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn0_storage_p ', landpft, deadcrootn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn0_xfer_p ', landpft, deadcrootn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainn0_p ', landpft, grainn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainn0_storage_p ', landpft, grainn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainn0_xfer_p ', landpft, grainn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'retransn0_p ', landpft, retransn0_p , defval = 1._r8) + + CALL ncio_read_vector (file_restart, 'I_leafc_p_acc ', landpft, I_leafc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_leafc_st_p_acc ', landpft, I_leafc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootc_p_acc ', landpft, I_frootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootc_st_p_acc ', landpft, I_frootc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemc_p_acc ', landpft, I_livestemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemc_st_p_acc ', landpft, I_livestemc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemc_p_acc ', landpft, I_deadstemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemc_st_p_acc ', landpft, I_deadstemc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootc_p_acc ', landpft, I_livecrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootc_st_p_acc ', landpft, I_livecrootc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootc_p_acc ', landpft, I_deadcrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootc_st_p_acc ', landpft, I_deadcrootc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainc_p_acc ', landpft, I_grainc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainc_st_p_acc ', landpft, I_grainc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_leafn_p_acc ', landpft, I_leafn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_leafn_st_p_acc ', landpft, I_leafn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootn_p_acc ', landpft, I_frootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootn_st_p_acc ', landpft, I_frootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemn_p_acc ', landpft, I_livestemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemn_st_p_acc ', landpft, I_livestemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemn_p_acc ', landpft, I_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemn_st_p_acc ', landpft, I_deadstemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootn_p_acc ', landpft, I_livecrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootn_st_p_acc ', landpft, I_livecrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootn_p_acc ', landpft, I_deadcrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootn_st_p_acc ', landpft, I_deadcrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainn_p_acc ', landpft, I_grainn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainn_st_p_acc ', landpft, I_grainn_st_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_xf_to_leafc_p_acc ', landpft, & + AKX_leafc_xf_to_leafc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_xf_to_frootc_p_acc ', landpft, & + AKX_frootc_xf_to_frootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_xf_to_livestemc_p_acc ', landpft, & + AKX_livestemc_xf_to_livestemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_xf_to_deadstemc_p_acc ', landpft, & + AKX_deadstemc_xf_to_deadstemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_xf_to_livecrootc_p_acc ', landpft, & + AKX_livecrootc_xf_to_livecrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_xf_to_deadcrootc_p_acc ', landpft, & + AKX_deadcrootc_xf_to_deadcrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_xf_to_grainc_p_acc ', landpft, & + AKX_grainc_xf_to_grainc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_to_deadstemc_p_acc ', landpft, & + AKX_livestemc_to_deadstemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_to_deadcrootc_p_acc ', landpft, & + AKX_livecrootc_to_deadcrootc_p_acc , defval = 0._r8) + + + CALL ncio_read_vector (file_restart, 'AKX_leafc_st_to_leafc_xf_p_acc ', landpft, & + AKX_leafc_st_to_leafc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_st_to_frootc_xf_p_acc ', landpft, & + AKX_frootc_st_to_frootc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_st_to_livestemc_xf_p_acc ', landpft, & + AKX_livestemc_st_to_livestemc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_st_to_deadstemc_xf_p_acc ', landpft, & + AKX_deadstemc_st_to_deadstemc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_st_to_livecrootc_xf_p_acc ', landpft, & + AKX_livecrootc_st_to_livecrootc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ', landpft, & + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_st_to_grainc_xf_p_acc ', landpft, & + AKX_grainc_st_to_grainc_xf_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_exit_p_acc ', landpft, & + AKX_leafc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_exit_p_acc ', landpft, & + AKX_frootc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_exit_p_acc ', landpft, & + AKX_livestemc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_exit_p_acc ', landpft, & + AKX_deadstemc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_exit_p_acc ', landpft, & + AKX_livecrootc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_exit_p_acc ', landpft, & + AKX_deadcrootc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_exit_p_acc ', landpft, & + AKX_grainc_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_st_exit_p_acc ', landpft, & + AKX_leafc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_st_exit_p_acc ', landpft, & + AKX_frootc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_st_exit_p_acc ', landpft, & + AKX_livestemc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_st_exit_p_acc ', landpft, & + AKX_deadstemc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_st_exit_p_acc ', landpft, & + AKX_livecrootc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_st_exit_p_acc ', landpft, & + AKX_deadcrootc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_st_exit_p_acc ', landpft, & + AKX_grainc_st_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_xf_exit_p_acc ', landpft, & + AKX_leafc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_xf_exit_p_acc ', landpft, & + AKX_frootc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_xf_exit_p_acc ', landpft, & + AKX_livestemc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_xf_exit_p_acc ', landpft, & + AKX_deadstemc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_xf_exit_p_acc ', landpft, & + AKX_livecrootc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_xf_exit_p_acc ', landpft, & + AKX_deadcrootc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_xf_exit_p_acc ', landpft, & + AKX_grainc_xf_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_xf_to_leafn_p_acc ', landpft, & + AKX_leafn_xf_to_leafn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_xf_to_frootn_p_acc ', landpft, & + AKX_frootn_xf_to_frootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_xf_to_livestemn_p_acc ', landpft, & + AKX_livestemn_xf_to_livestemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_xf_to_deadstemn_p_acc ', landpft, & + AKX_deadstemn_xf_to_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_xf_to_livecrootn_p_acc ', landpft, & + AKX_livecrootn_xf_to_livecrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_xf_to_deadcrootn_p_acc ', landpft, & + AKX_deadcrootn_xf_to_deadcrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_xf_to_grainn_p_acc ', landpft, & + AKX_grainn_xf_to_grainn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_to_deadstemn_p_acc ', landpft, & + AKX_livestemn_to_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_to_deadcrootn_p_acc ', landpft, & + AKX_livecrootn_to_deadcrootn_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_st_to_leafn_xf_p_acc ', landpft, & + AKX_leafn_st_to_leafn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_st_to_frootn_xf_p_acc ', landpft, & + AKX_frootn_st_to_frootn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_st_to_livestemn_xf_p_acc ', landpft, & + AKX_livestemn_st_to_livestemn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_st_to_deadstemn_xf_p_acc ', landpft, & + AKX_deadstemn_st_to_deadstemn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_st_to_livecrootn_xf_p_acc ', landpft, & + AKX_livecrootn_st_to_livecrootn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ', landpft, & + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_st_to_grainn_xf_p_acc ', landpft, & + AKX_grainn_st_to_grainn_xf_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_to_retransn_p_acc ', landpft, & + AKX_leafn_to_retransn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_to_retransn_p_acc ', landpft, & + AKX_frootn_to_retransn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_to_retransn_p_acc ', landpft, & + AKX_livestemn_to_retransn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_to_retransn_p_acc ', landpft, & + AKX_livecrootn_to_retransn_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_leafn_p_acc ', landpft, & + AKX_retransn_to_leafn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_frootn_p_acc ', landpft, & + AKX_retransn_to_frootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livestemn_p_acc ', landpft, & + AKX_retransn_to_livestemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadstemn_p_acc ', landpft, & + AKX_retransn_to_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livecrootn_p_acc ', landpft, & + AKX_retransn_to_livecrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadcrootn_p_acc ', landpft, & + AKX_retransn_to_deadcrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_grainn_p_acc ', landpft, & + AKX_retransn_to_grainn_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_leafn_st_p_acc ', landpft, & + AKX_retransn_to_leafn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_frootn_st_p_acc ', landpft, & + AKX_retransn_to_frootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livestemn_st_p_acc ', landpft, & + AKX_retransn_to_livestemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadstemn_st_p_acc ', landpft, & + AKX_retransn_to_deadstemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livecrootn_st_p_acc ', landpft, & + AKX_retransn_to_livecrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadcrootn_st_p_acc ', landpft, & + AKX_retransn_to_deadcrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_grainn_st_p_acc ', landpft, & + AKX_retransn_to_grainn_st_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_exit_p_acc ', landpft, & + AKX_leafn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_exit_p_acc ', landpft, & + AKX_frootn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_exit_p_acc ', landpft, & + AKX_livestemn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_exit_p_acc ', landpft, & + AKX_deadstemn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_exit_p_acc ', landpft, & + AKX_livecrootn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_exit_p_acc ', landpft, & + AKX_deadcrootn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_exit_p_acc ', landpft, & + AKX_grainn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_exit_p_acc ', landpft, & + AKX_retransn_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_st_exit_p_acc ', landpft, & + AKX_leafn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_st_exit_p_acc ', landpft, & + AKX_frootn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_st_exit_p_acc ', landpft, & + AKX_livestemn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_st_exit_p_acc ', landpft, & + AKX_deadstemn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_st_exit_p_acc ', landpft, & + AKX_livecrootn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_st_exit_p_acc ', landpft, & + AKX_deadcrootn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_st_exit_p_acc ', landpft, & + AKX_grainn_st_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_xf_exit_p_acc ', landpft, & + AKX_leafn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_xf_exit_p_acc ', landpft, & + AKX_frootn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_xf_exit_p_acc ', landpft, & + AKX_livestemn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_xf_exit_p_acc ', landpft, & + AKX_deadstemn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_xf_exit_p_acc ', landpft, & + AKX_livecrootn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_xf_exit_p_acc ', landpft, & + AKX_deadcrootn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_xf_exit_p_acc ', landpft, & + AKX_grainn_xf_exit_p_acc , defval = 0._r8) + ENDIF + END SUBROUTINE READ_BGCPFTimeVariables + + SUBROUTINE WRITE_BGCPFTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_REST_CompressLevel + USE MOD_LandPFT + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + ! bgc variables + CALL ncio_write_vector (file_restart, 'leafc_p ', 'pft', landpft, & + leafc_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_storage_p ', 'pft', landpft, & + leafc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_xfer_p ', 'pft', landpft, & + leafc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_p ', 'pft', landpft, & + frootc_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_storage_p ', 'pft', landpft, & + frootc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_xfer_p ', 'pft', landpft, & + frootc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_p ', 'pft', landpft, & + livestemc_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_storage_p ', 'pft', landpft, & + livestemc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_xfer_p ', 'pft', landpft, & + livestemc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_p ', 'pft', landpft, & + deadstemc_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_storage_p ', 'pft', landpft, & + deadstemc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_xfer_p ', 'pft', landpft, & + deadstemc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_p ', 'pft', landpft, & + livecrootc_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_storage_p ', 'pft', landpft, & + livecrootc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_xfer_p ', 'pft', landpft, & + livecrootc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_p ', 'pft', landpft, & + deadcrootc_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_storage_p ', 'pft', landpft, & + deadcrootc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_xfer_p ', 'pft', landpft, & + deadcrootc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainc_p ', 'pft', landpft, & + grainc_p , compress) + CALL ncio_write_vector (file_restart, 'grainc_storage_p ', 'pft', landpft, & + grainc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainc_xfer_p ', 'pft', landpft, & + grainc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'cropseedc_deficit_p ', 'pft', landpft, & + cropseedc_deficit_p , compress) + CALL ncio_write_vector (file_restart, 'xsmrpool_p ', 'pft', landpft, & + xsmrpool_p , compress) + CALL ncio_write_vector (file_restart, 'gresp_storage_p ', 'pft', landpft, & + gresp_storage_p , compress) + CALL ncio_write_vector (file_restart, 'gresp_xfer_p ', 'pft', landpft, & + gresp_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'cpool_p ', 'pft', landpft, & + cpool_p , compress) + ! CALL ncio_write_vector (file_restart, 'totvegc_p ', 'pft', landpft, & + ! totvegc_p , compress) + CALL ncio_write_vector (file_restart, 'cropprod1c_p ', 'pft', landpft, & + cropprod1c_p , compress) + + CALL ncio_write_vector (file_restart, 'leafn_p ', 'pft', landpft, & + leafn_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_storage_p ', 'pft', landpft, & + leafn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_xfer_p ', 'pft', landpft, & + leafn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_p ', 'pft', landpft, & + frootn_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_storage_p ', 'pft', landpft, & + frootn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_xfer_p ', 'pft', landpft, & + frootn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_p ', 'pft', landpft, & + livestemn_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_storage_p ', 'pft', landpft, & + livestemn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_xfer_p ', 'pft', landpft, & + livestemn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_p ', 'pft', landpft, & + deadstemn_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_storage_p ', 'pft', landpft, & + deadstemn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_xfer_p ', 'pft', landpft, & + deadstemn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_p ', 'pft', landpft, & + livecrootn_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_storage_p ', 'pft', landpft, & + livecrootn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_xfer_p ', 'pft', landpft, & + livecrootn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_p ', 'pft', landpft, & + deadcrootn_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_storage_p ', 'pft', landpft, & + deadcrootn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_xfer_p ', 'pft', landpft, & + deadcrootn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainn_p ', 'pft', landpft, & + grainn_p , compress) + CALL ncio_write_vector (file_restart, 'grainn_storage_p ', 'pft', landpft, & + grainn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainn_xfer_p ', 'pft', landpft, & + grainn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'cropseedn_deficit_p ', 'pft', landpft, & + cropseedn_deficit_p , compress) + CALL ncio_write_vector (file_restart, 'retransn_p ', 'pft', landpft, & + retransn_p , compress) + ! CALL ncio_write_vector (file_restart, 'totvegn_p ', 'pft', landpft, & + ! totvegn_p , compress) + + CALL ncio_write_vector (file_restart, 'harvdate_p ', 'pft', landpft, & + harvdate_p , compress) + + CALL ncio_write_vector (file_restart, 'tempsum_potential_gpp_p', 'pft', landpft, & + tempsum_potential_gpp_p, compress) + CALL ncio_write_vector (file_restart, 'tempmax_retransn_p ', 'pft', landpft, & + tempmax_retransn_p , compress) + CALL ncio_write_vector (file_restart, 'tempavg_tref_p ', 'pft', landpft, & + tempavg_tref_p , compress) + CALL ncio_write_vector (file_restart, 'tempsum_npp_p ', 'pft', landpft, & + tempsum_npp_p , compress) + CALL ncio_write_vector (file_restart, 'tempsum_litfall_p ', 'pft', landpft, & + tempsum_litfall_p , compress) + CALL ncio_write_vector (file_restart, 'annsum_potential_gpp_p ', 'pft', landpft, & + annsum_potential_gpp_p, compress) + CALL ncio_write_vector (file_restart, 'annmax_retransn_p ', 'pft', landpft, & + annmax_retransn_p , compress) + CALL ncio_write_vector (file_restart, 'annavg_tref_p ', 'pft', landpft, & + annavg_tref_p , compress) + CALL ncio_write_vector (file_restart, 'annsum_npp_p ', 'pft', landpft, & + annsum_npp_p , compress) + CALL ncio_write_vector (file_restart, 'annsum_litfall_p ', 'pft', landpft, & + annsum_litfall_p , compress) + + CALL ncio_write_vector (file_restart, 'bglfr_p ', 'pft', landpft, & + bglfr_p , compress) + CALL ncio_write_vector (file_restart, 'bgtr_p ', 'pft', landpft, & + bgtr_p , compress) + CALL ncio_write_vector (file_restart, 'lgsf_p ', 'pft', landpft, & + lgsf_p , compress) + CALL ncio_write_vector (file_restart, 'gdd0_p ', 'pft', landpft, & + gdd0_p , compress) + CALL ncio_write_vector (file_restart, 'gdd8_p ', 'pft', landpft, & + gdd8_p , compress) + CALL ncio_write_vector (file_restart, 'gdd10_p ', 'pft', landpft, & + gdd10_p , compress) + CALL ncio_write_vector (file_restart, 'gdd020_p ', 'pft', landpft, & + gdd020_p , compress) + CALL ncio_write_vector (file_restart, 'gdd820_p ', 'pft', landpft, & + gdd820_p , compress) + CALL ncio_write_vector (file_restart, 'gdd1020_p ', 'pft', landpft, & + gdd1020_p , compress) + CALL ncio_write_vector (file_restart, 'nyrs_crop_active_p ', 'pft', landpft, & + nyrs_crop_active_p , compress) + + CALL ncio_write_vector (file_restart, 'offset_flag_p ', 'pft', landpft, & + offset_flag_p , compress) + CALL ncio_write_vector (file_restart, 'offset_counter_p ', 'pft', landpft, & + offset_counter_p , compress) + CALL ncio_write_vector (file_restart, 'onset_flag_p ', 'pft', landpft, & + onset_flag_p , compress) + CALL ncio_write_vector (file_restart, 'onset_counter_p ', 'pft', landpft, & + onset_counter_p , compress) + CALL ncio_write_vector (file_restart, 'onset_gddflag_p ', 'pft', landpft, & + onset_gddflag_p , compress) + CALL ncio_write_vector (file_restart, 'onset_gdd_p ', 'pft', landpft, & + onset_gdd_p , compress) + CALL ncio_write_vector (file_restart, 'onset_fdd_p ', 'pft', landpft, & + onset_fdd_p , compress) + CALL ncio_write_vector (file_restart, 'onset_swi_p ', 'pft', landpft, & + onset_swi_p , compress) + CALL ncio_write_vector (file_restart, 'offset_fdd_p ', 'pft', landpft, & + offset_fdd_p , compress) + CALL ncio_write_vector (file_restart, 'offset_swi_p ', 'pft', landpft, & + offset_swi_p , compress) + CALL ncio_write_vector (file_restart, 'dormant_flag_p ', 'pft', landpft, & + dormant_flag_p , compress) + CALL ncio_write_vector (file_restart, 'prev_leafc_to_litter_p ', 'pft', landpft, & + prev_leafc_to_litter_p, compress) + CALL ncio_write_vector (file_restart, 'prev_frootc_to_litter_p', 'pft', landpft, & + prev_frootc_to_litter_p, compress) + CALL ncio_write_vector (file_restart, 'days_active_p ', 'pft', landpft, & + days_active_p , compress) + + CALL ncio_write_vector (file_restart, 'burndate_p ', 'pft', landpft, & + burndate_p , compress) + CALL ncio_write_vector (file_restart, 'grain_flag_p ', 'pft', landpft, & + grain_flag_p , compress) + CALL ncio_write_vector (file_restart, 'ctrunc_p ', 'pft', landpft, & + ctrunc_p , compress) + CALL ncio_write_vector (file_restart, 'ntrunc_p ', 'pft', landpft, & + ntrunc_p , compress) + CALL ncio_write_vector (file_restart, 'npool_p ', 'pft', landpft, & + npool_p , compress) + +#ifdef CROP +! crop variables + CALL ncio_write_vector (file_restart, 'croplive_p ', 'pft', landpft, & + croplive_p , compress) + CALL ncio_write_vector (file_restart, 'hui_p ', 'pft', landpft, & + hui_p , compress) + CALL ncio_write_vector (file_restart, 'gddplant_p ', 'pft', landpft, & + gddplant_p , compress) + CALL ncio_write_vector (file_restart, 'peaklai_p ', 'pft', landpft, & + peaklai_p , compress) + CALL ncio_write_vector (file_restart, 'aroot_p ', 'pft', landpft, & + aroot_p , compress) + CALL ncio_write_vector (file_restart, 'astem_p ', 'pft', landpft, & + astem_p , compress) + CALL ncio_write_vector (file_restart, 'arepr_p ', 'pft', landpft, & + arepr_p , compress) + CALL ncio_write_vector (file_restart, 'aleaf_p ', 'pft', landpft, & + aleaf_p , compress) + CALL ncio_write_vector (file_restart, 'astemi_p ', 'pft', landpft, & + astemi_p , compress) + CALL ncio_write_vector (file_restart, 'aleafi_p ', 'pft', landpft, & + aleafi_p , compress) + CALL ncio_write_vector (file_restart, 'gddmaturity_p ', 'pft', landpft, & + gddmaturity_p , compress) + + CALL ncio_write_vector (file_restart, 'cropplant_p ', 'pft', landpft, & + cropplant_p , compress) + CALL ncio_write_vector (file_restart, 'idop_p ', 'pft', landpft, & + idop_p , compress) + CALL ncio_write_vector (file_restart, 'a5tmin_p ', 'pft', landpft, & + a5tmin_p , compress) + CALL ncio_write_vector (file_restart, 'a10tmin_p ', 'pft', landpft, & + a10tmin_p , compress) + CALL ncio_write_vector (file_restart, 't10_p ', 'pft', landpft, & + t10_p , compress) + CALL ncio_write_vector (file_restart, 'cumvd_p ', 'pft', landpft, & + cumvd_p , compress) + CALL ncio_write_vector (file_restart, 'vf_p ', 'pft', landpft, & + vf_p , compress) + CALL ncio_write_vector (file_restart, 'cphase_p ', 'pft', landpft, & + cphase_p , compress) + CALL ncio_write_vector (file_restart, 'fert_counter_p ', 'pft', landpft, & + fert_counter_p , compress) + CALL ncio_write_vector (file_restart, 'tref_min_p ', 'pft', landpft, & + tref_min_p , compress) + CALL ncio_write_vector (file_restart, 'tref_max_p ', 'pft', landpft, & + tref_max_p , compress) + CALL ncio_write_vector (file_restart, 'tref_min_inst_p ', 'pft', landpft, & + tref_min_inst_p , compress) + CALL ncio_write_vector (file_restart, 'tref_max_inst_p ', 'pft', landpft, & + tref_max_inst_p , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_p ', 'pft', landpft, & + fertnitro_p , compress) + CALL ncio_write_vector (file_restart, 'manunitro_p ', 'pft', landpft, & + manunitro_p , compress) + CALL ncio_write_vector (file_restart, 'fert_p ', 'pft', landpft, & + fert_p , compress) + CALL ncio_write_vector (file_restart, 'latbaset_p ', 'pft', landpft, & + latbaset_p , compress) + CALL ncio_write_vector (file_restart, 'plantdate_p ', 'pft', landpft, & + plantdate_p , compress) +#endif + + IF(DEF_USE_DiagMatrix)THEN +! SASU variables + CALL ncio_write_vector (file_restart, 'leafcCap_p ', 'pft', landpft, & + leafcCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_storageCap_p ', 'pft', landpft, & + leafc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_xferCap_p ', 'pft', landpft, & + leafc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootcCap_p ', 'pft', landpft, & + frootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_storageCap_p ', 'pft', landpft, & + frootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_xferCap_p ', 'pft', landpft, & + frootc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemcCap_p ', 'pft', landpft, & + livestemcCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_storageCap_p ', 'pft', landpft, & + livestemc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_xferCap_p ', 'pft', landpft, & + livestemc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemcCap_p ', 'pft', landpft, & + deadstemcCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_storageCap_p ', 'pft', landpft, & + deadstemc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_xferCap_p ', 'pft', landpft, & + deadstemc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootcCap_p ', 'pft', landpft, & + livecrootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_storageCap_p ', 'pft', landpft, & + livecrootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_xferCap_p ', 'pft', landpft, & + livecrootc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootcCap_p ', 'pft', landpft, & + deadcrootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_storageCap_p ', 'pft', landpft, & + deadcrootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_xferCap_p ', 'pft', landpft, & + deadcrootc_xferCap_p , compress) + + CALL ncio_write_vector (file_restart, 'leafnCap_p ', 'pft', landpft, & + leafcCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_storageCap_p ', 'pft', landpft, & + leafc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_xferCap_p ', 'pft', landpft, & + leafc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootnCap_p ', 'pft', landpft, & + frootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_storageCap_p ', 'pft', landpft, & + frootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_xferCap_p ', 'pft', landpft, & + frootc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemnCap_p ', 'pft', landpft, & + livestemnCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_storageCap_p ', 'pft', landpft, & + livestemn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_xferCap_p ', 'pft', landpft, & + livestemn_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemnCap_p ', 'pft', landpft, & + deadstemnCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_storageCap_p ', 'pft', landpft, & + deadstemn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_xferCap_p ', 'pft', landpft, & + deadstemn_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootnCap_p ', 'pft', landpft, & + livecrootnCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_storageCap_p ', 'pft', landpft, & + livecrootn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_xferCap_p ', 'pft', landpft, & + livecrootn_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootnCap_p ', 'pft', landpft, & + deadcrootnCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_storageCap_p ', 'pft', landpft, & + deadcrootn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_xferCap_p ', 'pft', landpft, & + deadcrootn_xferCap_p , compress) + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL ncio_write_vector (file_restart, 'leafc0_p ', 'pft', landpft, & + leafc0_p , compress) + CALL ncio_write_vector (file_restart, 'leafc0_storage_p ', 'pft', landpft, & + leafc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafc0_xfer_p ', 'pft', landpft, & + leafc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootc0_p ', 'pft', landpft, & + frootc0_p , compress) + CALL ncio_write_vector (file_restart, 'frootc0_storage_p ', 'pft', landpft, & + frootc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootc0_xfer_p ', 'pft', landpft, & + frootc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc0_p ', 'pft', landpft, & + livestemc0_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc0_storage_p ', 'pft', landpft, & + livestemc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc0_xfer_p ', 'pft', landpft, & + livestemc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc0_p ', 'pft', landpft, & + deadstemc0_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc0_storage_p ', 'pft', landpft, & + deadstemc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc0_xfer_p ', 'pft', landpft, & + deadstemc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc0_p ', 'pft', landpft, & + livecrootc0_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc0_storage_p ', 'pft', landpft, & + livecrootc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc0_xfer_p ', 'pft', landpft, & + livecrootc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc0_p ', 'pft', landpft, & + deadcrootc0_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc0_storage_p ', 'pft', landpft, & + deadcrootc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc0_xfer_p ', 'pft', landpft, & + deadcrootc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainc0_p ', 'pft', landpft, & + grainc0_p , compress) + CALL ncio_write_vector (file_restart, 'grainc0_storage_p ', 'pft', landpft, & + grainc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainc0_xfer_p ', 'pft', landpft, & + grainc0_xfer_p , compress) + + CALL ncio_write_vector (file_restart, 'leafn0_p ', 'pft', landpft, & + leafn0_p , compress) + CALL ncio_write_vector (file_restart, 'leafn0_storage_p ', 'pft', landpft, & + leafn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafn0_xfer_p ', 'pft', landpft, & + leafn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootn0_p ', 'pft', landpft, & + frootn0_p , compress) + CALL ncio_write_vector (file_restart, 'frootn0_storage_p ', 'pft', landpft, & + frootn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootn0_xfer_p ', 'pft', landpft, & + frootn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn0_p ', 'pft', landpft, & + livestemn0_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn0_storage_p ', 'pft', landpft, & + livestemn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn0_xfer_p ', 'pft', landpft, & + livestemn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn0_p ', 'pft', landpft, & + deadstemn0_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn0_storage_p ', 'pft', landpft, & + deadstemn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn0_xfer_p ', 'pft', landpft, & + deadstemn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn0_p ', 'pft', landpft, & + livecrootn0_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn0_storage_p ', 'pft', landpft, & + livecrootn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn0_xfer_p ', 'pft', landpft, & + livecrootn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn0_p ', 'pft', landpft, & + deadcrootn0_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn0_storage_p ', 'pft', landpft, & + deadcrootn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn0_xfer_p ', 'pft', landpft, & + deadcrootn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainn0_p ', 'pft', landpft, & + grainn0_p , compress) + CALL ncio_write_vector (file_restart, 'grainn0_storage_p ', 'pft', landpft, & + grainn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainn0_xfer_p ', 'pft', landpft, & + grainn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'retransn0_p ', 'pft', landpft, & + retransn0_p , compress) + + CALL ncio_write_vector (file_restart, 'I_leafc_p_acc ', 'pft', landpft, & + I_leafc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_leafc_st_p_acc ', 'pft', landpft, & + I_leafc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootc_p_acc ', 'pft', landpft, & + I_frootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootc_st_p_acc ', 'pft', landpft, & + I_frootc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemc_p_acc ', 'pft', landpft, & + I_livestemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemc_st_p_acc ', 'pft', landpft, & + I_livestemc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemc_p_acc ', 'pft', landpft, & + I_deadstemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemc_st_p_acc ', 'pft', landpft, & + I_deadstemc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootc_p_acc ', 'pft', landpft, & + I_livecrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootc_st_p_acc ', 'pft', landpft, & + I_livecrootc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootc_p_acc ', 'pft', landpft, & + I_deadcrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootc_st_p_acc ', 'pft', landpft, & + I_deadcrootc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainc_p_acc ', 'pft', landpft, & + I_grainc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainc_st_p_acc ', 'pft', landpft, & + I_grainc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_leafn_p_acc ', 'pft', landpft, & + I_leafn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_leafn_st_p_acc ', 'pft', landpft, & + I_leafn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootn_p_acc ', 'pft', landpft, & + I_frootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootn_st_p_acc ', 'pft', landpft, & + I_frootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemn_p_acc ', 'pft', landpft, & + I_livestemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemn_st_p_acc ', 'pft', landpft, & + I_livestemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemn_p_acc ', 'pft', landpft, & + I_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemn_st_p_acc ', 'pft', landpft, & + I_deadstemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootn_p_acc ', 'pft', landpft, & + I_livecrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootn_st_p_acc ', 'pft', landpft, & + I_livecrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootn_p_acc ', 'pft', landpft, & + I_deadcrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootn_st_p_acc ', 'pft', landpft, & + I_deadcrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainn_p_acc ', 'pft', landpft, & + I_grainn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainn_st_p_acc ', 'pft', landpft, & + I_grainn_st_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_xf_to_leafc_p_acc ', 'pft', landpft, & + AKX_leafc_xf_to_leafc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_xf_to_frootc_p_acc ', 'pft', landpft, & + AKX_frootc_xf_to_frootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_xf_to_livestemc_p_acc ', 'pft', landpft, & + AKX_livestemc_xf_to_livestemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_xf_to_deadstemc_p_acc ', 'pft', landpft, & + AKX_deadstemc_xf_to_deadstemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_xf_to_livecrootc_p_acc ', 'pft', landpft, & + AKX_livecrootc_xf_to_livecrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_xf_to_deadcrootc_p_acc ', 'pft', landpft, & + AKX_deadcrootc_xf_to_deadcrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_xf_to_grainc_p_acc ', 'pft', landpft, & + AKX_grainc_xf_to_grainc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_to_deadstemc_p_acc ', 'pft', landpft, & + AKX_livestemc_to_deadstemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_to_deadcrootc_p_acc ', 'pft', landpft, & + AKX_livecrootc_to_deadcrootc_p_acc , compress) + + + CALL ncio_write_vector (file_restart, 'AKX_leafc_st_to_leafc_xf_p_acc ', 'pft', landpft, & + AKX_leafc_st_to_leafc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_st_to_frootc_xf_p_acc ', 'pft', landpft, & + AKX_frootc_st_to_frootc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_st_to_livestemc_xf_p_acc ', 'pft', landpft, & + AKX_livestemc_st_to_livestemc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_st_to_deadstemc_xf_p_acc ', 'pft', landpft, & + AKX_deadstemc_st_to_deadstemc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_st_to_livecrootc_xf_p_acc ', 'pft', landpft, & + AKX_livecrootc_st_to_livecrootc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ', 'pft', landpft, & + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_st_to_grainc_xf_p_acc ', 'pft', landpft, & + AKX_grainc_st_to_grainc_xf_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_exit_p_acc ', 'pft', landpft, & + AKX_leafc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_exit_p_acc ', 'pft', landpft, & + AKX_frootc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_exit_p_acc ', 'pft', landpft, & + AKX_livestemc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_exit_p_acc ', 'pft', landpft, & + AKX_deadstemc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_exit_p_acc ', 'pft', landpft, & + AKX_livecrootc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_exit_p_acc ', 'pft', landpft, & + AKX_grainc_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_st_exit_p_acc ', 'pft', landpft, & + AKX_leafc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_st_exit_p_acc ', 'pft', landpft, & + AKX_frootc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_st_exit_p_acc ', 'pft', landpft, & + AKX_livestemc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_st_exit_p_acc ', 'pft', landpft, & + AKX_deadstemc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_st_exit_p_acc ', 'pft', landpft, & + AKX_livecrootc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_st_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_st_exit_p_acc ', 'pft', landpft, & + AKX_grainc_st_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_xf_exit_p_acc ', 'pft', landpft, & + AKX_leafc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_xf_exit_p_acc ', 'pft', landpft, & + AKX_frootc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_xf_exit_p_acc ', 'pft', landpft, & + AKX_livestemc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadstemc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_xf_exit_p_acc ', 'pft', landpft, & + AKX_livecrootc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_xf_exit_p_acc ', 'pft', landpft, & + AKX_grainc_xf_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_xf_to_leafn_p_acc ', 'pft', landpft, & + AKX_leafn_xf_to_leafn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_xf_to_frootn_p_acc ', 'pft', landpft, & + AKX_frootn_xf_to_frootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_xf_to_livestemn_p_acc ', 'pft', landpft, & + AKX_livestemn_xf_to_livestemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_xf_to_deadstemn_p_acc ', 'pft', landpft, & + AKX_deadstemn_xf_to_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_xf_to_livecrootn_p_acc ', 'pft', landpft, & + AKX_livecrootn_xf_to_livecrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_xf_to_deadcrootn_p_acc ', 'pft', landpft, & + AKX_deadcrootn_xf_to_deadcrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_xf_to_grainn_p_acc ', 'pft', landpft, & + AKX_grainn_xf_to_grainn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_to_deadstemn_p_acc ', 'pft', landpft, & + AKX_livestemn_to_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_to_deadcrootn_p_acc ', 'pft', landpft, & + AKX_livecrootn_to_deadcrootn_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_st_to_leafn_xf_p_acc ', 'pft', landpft, & + AKX_leafn_st_to_leafn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_st_to_frootn_xf_p_acc ', 'pft', landpft, & + AKX_frootn_st_to_frootn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_st_to_livestemn_xf_p_acc ', 'pft', landpft, & + AKX_livestemn_st_to_livestemn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_st_to_deadstemn_xf_p_acc ', 'pft', landpft, & + AKX_deadstemn_st_to_deadstemn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_st_to_livecrootn_xf_p_acc ', 'pft', landpft, & + AKX_livecrootn_st_to_livecrootn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ', 'pft', landpft, & + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_st_to_grainn_xf_p_acc ', 'pft', landpft, & + AKX_grainn_st_to_grainn_xf_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_to_retransn_p_acc ', 'pft', landpft, & + AKX_leafn_to_retransn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_to_retransn_p_acc ', 'pft', landpft, & + AKX_frootn_to_retransn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_to_retransn_p_acc ', 'pft', landpft, & + AKX_livestemn_to_retransn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_to_retransn_p_acc ', 'pft', landpft, & + AKX_livecrootn_to_retransn_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_leafn_p_acc ', 'pft', landpft, & + AKX_retransn_to_leafn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_frootn_p_acc ', 'pft', landpft, & + AKX_retransn_to_frootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livestemn_p_acc ', 'pft', landpft, & + AKX_retransn_to_livestemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadstemn_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livecrootn_p_acc ', 'pft', landpft, & + AKX_retransn_to_livecrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadcrootn_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadcrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_grainn_p_acc ', 'pft', landpft, & + AKX_retransn_to_grainn_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_leafn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_leafn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_frootn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_frootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livestemn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_livestemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadstemn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadstemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livecrootn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_livecrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadcrootn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadcrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_grainn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_grainn_st_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_exit_p_acc ', 'pft', landpft, & + AKX_leafn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_exit_p_acc ', 'pft', landpft, & + AKX_frootn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_exit_p_acc ', 'pft', landpft, & + AKX_livestemn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_exit_p_acc ', 'pft', landpft, & + AKX_deadstemn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_exit_p_acc ', 'pft', landpft, & + AKX_livecrootn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_exit_p_acc ', 'pft', landpft, & + AKX_grainn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_exit_p_acc ', 'pft', landpft, & + AKX_retransn_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_st_exit_p_acc ', 'pft', landpft, & + AKX_leafn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_st_exit_p_acc ', 'pft', landpft, & + AKX_frootn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_st_exit_p_acc ', 'pft', landpft, & + AKX_livestemn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_st_exit_p_acc ', 'pft', landpft, & + AKX_deadstemn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_st_exit_p_acc ', 'pft', landpft, & + AKX_livecrootn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_st_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_st_exit_p_acc ', 'pft', landpft, & + AKX_grainn_st_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_xf_exit_p_acc ', 'pft', landpft, & + AKX_leafn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_xf_exit_p_acc ', 'pft', landpft, & + AKX_frootn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_xf_exit_p_acc ', 'pft', landpft, & + AKX_livestemn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadstemn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_xf_exit_p_acc ', 'pft', landpft, & + AKX_livecrootn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_xf_exit_p_acc ', 'pft', landpft, & + AKX_grainn_xf_exit_p_acc , compress) + ENDIF + END SUBROUTINE WRITE_BGCPFTimeVariables + + + SUBROUTINE deallocate_BGCPFTimeVariables () +! -------------------------------------------------- +! Deallocates memory for CoLM 1d [numpft/numpc] variables +! -------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPFT + + IF (p_is_worker) THEN + IF (numpft > 0) THEN +! bgc variables + deallocate (leafc_p ) + deallocate (leafc_storage_p ) + deallocate (leafc_xfer_p ) + deallocate (frootc_p ) + deallocate (frootc_storage_p ) + deallocate (frootc_xfer_p ) + deallocate (livestemc_p ) + deallocate (livestemc_storage_p ) + deallocate (livestemc_xfer_p ) + deallocate (deadstemc_p ) + deallocate (deadstemc_storage_p ) + deallocate (deadstemc_xfer_p ) + deallocate (livecrootc_p ) + deallocate (livecrootc_storage_p ) + deallocate (livecrootc_xfer_p ) + deallocate (deadcrootc_p ) + deallocate (deadcrootc_storage_p ) + deallocate (deadcrootc_xfer_p ) + deallocate (grainc_p ) + deallocate (grainc_storage_p ) + deallocate (grainc_xfer_p ) + deallocate (cropseedc_deficit_p ) + deallocate (xsmrpool_p ) + deallocate (gresp_storage_p ) + deallocate (gresp_xfer_p ) + deallocate (cpool_p ) + deallocate (totvegc_p ) + deallocate (cropprod1c_p ) + + deallocate (leaf_prof_p ) + deallocate (froot_prof_p ) + deallocate (croot_prof_p ) + deallocate (stem_prof_p ) + deallocate (cinput_rootfr_p ) + + deallocate (leafn_p ) + deallocate (leafn_storage_p ) + deallocate (leafn_xfer_p ) + deallocate (frootn_p ) + deallocate (frootn_storage_p ) + deallocate (frootn_xfer_p ) + deallocate (livestemn_p ) + deallocate (livestemn_storage_p ) + deallocate (livestemn_xfer_p ) + deallocate (deadstemn_p ) + deallocate (deadstemn_storage_p ) + deallocate (deadstemn_xfer_p ) + deallocate (livecrootn_p ) + deallocate (livecrootn_storage_p ) + deallocate (livecrootn_xfer_p ) + deallocate (deadcrootn_p ) + deallocate (deadcrootn_storage_p ) + deallocate (deadcrootn_xfer_p ) + deallocate (grainn_p ) + deallocate (grainn_storage_p ) + deallocate (grainn_xfer_p ) + deallocate (cropseedn_deficit_p ) + deallocate (retransn_p ) + deallocate (totvegn_p ) + + deallocate (harvdate_p ) + + deallocate (tempsum_potential_gpp_p ) + deallocate (tempmax_retransn_p ) + deallocate (tempavg_tref_p ) + deallocate (tempsum_npp_p ) + deallocate (tempsum_litfall_p ) + deallocate (annsum_potential_gpp_p ) + deallocate (annmax_retransn_p ) + deallocate (annavg_tref_p ) + deallocate (annsum_npp_p ) + deallocate (annsum_litfall_p ) + + deallocate (bglfr_p ) + deallocate (bgtr_p ) + deallocate (lgsf_p ) + deallocate (gdd0_p ) + deallocate (gdd8_p ) + deallocate (gdd10_p ) + deallocate (gdd020_p ) + deallocate (gdd820_p ) + deallocate (gdd1020_p ) + deallocate (nyrs_crop_active_p ) + + deallocate (offset_flag_p ) + deallocate (offset_counter_p ) + deallocate (onset_flag_p ) + deallocate (onset_counter_p ) + deallocate (onset_gddflag_p ) + deallocate (onset_gdd_p ) + deallocate (onset_fdd_p ) + deallocate (onset_swi_p ) + deallocate (offset_fdd_p ) + deallocate (offset_swi_p ) + deallocate (dormant_flag_p ) + deallocate (prev_leafc_to_litter_p ) + deallocate (prev_frootc_to_litter_p ) + deallocate (days_active_p ) + + deallocate (burndate_p ) + + deallocate (c_allometry_p ) + deallocate (n_allometry_p ) + deallocate (downreg_p ) + deallocate (grain_flag_p ) + + deallocate (ctrunc_p ) + deallocate (ntrunc_p ) + deallocate (npool_p ) + +#ifdef CROP +! crop variables + deallocate (croplive_p ) + deallocate (hui_p ) + deallocate (gddplant_p ) + deallocate (peaklai_p ) + deallocate (aroot_p ) + deallocate (astem_p ) + deallocate (arepr_p ) + deallocate (aleaf_p ) + deallocate (astemi_p ) + deallocate (aleafi_p ) + deallocate (gddmaturity_p ) + + deallocate (cropplant_p ) + deallocate (idop_p ) + deallocate (a5tmin_p ) + deallocate (a10tmin_p ) + deallocate (t10_p ) + deallocate (cumvd_p ) + deallocate (vf_p ) + deallocate (cphase_p ) + deallocate (fert_counter_p ) + deallocate (tref_min_p ) + deallocate (tref_max_p ) + deallocate (tref_min_inst_p ) + deallocate (tref_max_inst_p ) + deallocate (fertnitro_p ) + deallocate (manunitro_p ) + deallocate (fert_p ) + deallocate (latbaset_p ) + deallocate (plantdate_p ) +#endif + +! SASU variables + deallocate (leafcCap_p ) + deallocate (leafc_storageCap_p ) + deallocate (leafc_xferCap_p ) + deallocate (frootcCap_p ) + deallocate (frootc_storageCap_p ) + deallocate (frootc_xferCap_p ) + deallocate (livestemcCap_p ) + deallocate (livestemc_storageCap_p ) + deallocate (livestemc_xferCap_p ) + deallocate (deadstemcCap_p ) + deallocate (deadstemc_storageCap_p ) + deallocate (deadstemc_xferCap_p ) + deallocate (livecrootcCap_p ) + deallocate (livecrootc_storageCap_p ) + deallocate (livecrootc_xferCap_p ) + deallocate (deadcrootcCap_p ) + deallocate (deadcrootc_storageCap_p ) + deallocate (deadcrootc_xferCap_p ) + + deallocate (leafnCap_p ) + deallocate (leafn_storageCap_p ) + deallocate (leafn_xferCap_p ) + deallocate (frootnCap_p ) + deallocate (frootn_storageCap_p ) + deallocate (frootn_xferCap_p ) + deallocate (livestemnCap_p ) + deallocate (livestemn_storageCap_p ) + deallocate (livestemn_xferCap_p ) + deallocate (deadstemnCap_p ) + deallocate (deadstemn_storageCap_p ) + deallocate (deadstemn_xferCap_p ) + deallocate (livecrootnCap_p ) + deallocate (livecrootn_storageCap_p ) + deallocate (livecrootn_xferCap_p ) + deallocate (deadcrootnCap_p ) + deallocate (deadcrootn_storageCap_p ) + deallocate (deadcrootn_xferCap_p ) + + deallocate (leafc0_p ) + deallocate (leafc0_storage_p ) + deallocate (leafc0_xfer_p ) + deallocate (frootc0_p ) + deallocate (frootc0_storage_p ) + deallocate (frootc0_xfer_p ) + deallocate (livestemc0_p ) + deallocate (livestemc0_storage_p ) + deallocate (livestemc0_xfer_p ) + deallocate (deadstemc0_p ) + deallocate (deadstemc0_storage_p ) + deallocate (deadstemc0_xfer_p ) + deallocate (livecrootc0_p ) + deallocate (livecrootc0_storage_p ) + deallocate (livecrootc0_xfer_p ) + deallocate (deadcrootc0_p ) + deallocate (deadcrootc0_storage_p ) + deallocate (deadcrootc0_xfer_p ) + deallocate (grainc0_p ) + deallocate (grainc0_storage_p ) + deallocate (grainc0_xfer_p ) + + deallocate (leafn0_p ) + deallocate (leafn0_storage_p ) + deallocate (leafn0_xfer_p ) + deallocate (frootn0_p ) + deallocate (frootn0_storage_p ) + deallocate (frootn0_xfer_p ) + deallocate (livestemn0_p ) + deallocate (livestemn0_storage_p ) + deallocate (livestemn0_xfer_p ) + deallocate (deadstemn0_p ) + deallocate (deadstemn0_storage_p ) + deallocate (deadstemn0_xfer_p ) + deallocate (livecrootn0_p ) + deallocate (livecrootn0_storage_p ) + deallocate (livecrootn0_xfer_p ) + deallocate (deadcrootn0_p ) + deallocate (deadcrootn0_storage_p ) + deallocate (deadcrootn0_xfer_p ) + deallocate (grainn0_p ) + deallocate (grainn0_storage_p ) + deallocate (grainn0_xfer_p ) + deallocate (retransn0_p ) + + deallocate (I_leafc_p_acc ) + deallocate (I_leafc_st_p_acc ) + deallocate (I_frootc_p_acc ) + deallocate (I_frootc_st_p_acc ) + deallocate (I_livestemc_p_acc ) + deallocate (I_livestemc_st_p_acc ) + deallocate (I_deadstemc_p_acc ) + deallocate (I_deadstemc_st_p_acc ) + deallocate (I_livecrootc_p_acc ) + deallocate (I_livecrootc_st_p_acc ) + deallocate (I_deadcrootc_p_acc ) + deallocate (I_deadcrootc_st_p_acc ) + deallocate (I_grainc_p_acc ) + deallocate (I_grainc_st_p_acc ) + deallocate (I_leafn_p_acc ) + deallocate (I_leafn_st_p_acc ) + deallocate (I_frootn_p_acc ) + deallocate (I_frootn_st_p_acc ) + deallocate (I_livestemn_p_acc ) + deallocate (I_livestemn_st_p_acc ) + deallocate (I_deadstemn_p_acc ) + deallocate (I_deadstemn_st_p_acc ) + deallocate (I_livecrootn_p_acc ) + deallocate (I_livecrootn_st_p_acc ) + deallocate (I_deadcrootn_p_acc ) + deallocate (I_deadcrootn_st_p_acc ) + deallocate (I_grainn_p_acc ) + deallocate (I_grainn_st_p_acc ) + + deallocate (AKX_leafc_xf_to_leafc_p_acc ) + deallocate (AKX_frootc_xf_to_frootc_p_acc ) + deallocate (AKX_livestemc_xf_to_livestemc_p_acc ) + deallocate (AKX_deadstemc_xf_to_deadstemc_p_acc ) + deallocate (AKX_livecrootc_xf_to_livecrootc_p_acc ) + deallocate (AKX_deadcrootc_xf_to_deadcrootc_p_acc ) + deallocate (AKX_grainc_xf_to_grainc_p_acc ) + deallocate (AKX_livestemc_to_deadstemc_p_acc ) + deallocate (AKX_livecrootc_to_deadcrootc_p_acc ) + + deallocate (AKX_leafc_st_to_leafc_xf_p_acc ) + deallocate (AKX_frootc_st_to_frootc_xf_p_acc ) + deallocate (AKX_livestemc_st_to_livestemc_xf_p_acc ) + deallocate (AKX_deadstemc_st_to_deadstemc_xf_p_acc ) + deallocate (AKX_livecrootc_st_to_livecrootc_xf_p_acc ) + deallocate (AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ) + deallocate (AKX_grainc_st_to_grainc_xf_p_acc ) + + deallocate (AKX_leafc_exit_p_acc ) + deallocate (AKX_frootc_exit_p_acc ) + deallocate (AKX_livestemc_exit_p_acc ) + deallocate (AKX_deadstemc_exit_p_acc ) + deallocate (AKX_livecrootc_exit_p_acc ) + deallocate (AKX_deadcrootc_exit_p_acc ) + deallocate (AKX_grainc_exit_p_acc ) + + deallocate (AKX_leafc_st_exit_p_acc ) + deallocate (AKX_frootc_st_exit_p_acc ) + deallocate (AKX_livestemc_st_exit_p_acc ) + deallocate (AKX_deadstemc_st_exit_p_acc ) + deallocate (AKX_livecrootc_st_exit_p_acc ) + deallocate (AKX_deadcrootc_st_exit_p_acc ) + deallocate (AKX_grainc_st_exit_p_acc ) + + deallocate (AKX_leafc_xf_exit_p_acc ) + deallocate (AKX_frootc_xf_exit_p_acc ) + deallocate (AKX_livestemc_xf_exit_p_acc ) + deallocate (AKX_deadstemc_xf_exit_p_acc ) + deallocate (AKX_livecrootc_xf_exit_p_acc ) + deallocate (AKX_deadcrootc_xf_exit_p_acc ) + deallocate (AKX_grainc_xf_exit_p_acc ) + + deallocate (AKX_leafn_xf_to_leafn_p_acc ) + deallocate (AKX_frootn_xf_to_frootn_p_acc ) + deallocate (AKX_livestemn_xf_to_livestemn_p_acc ) + deallocate (AKX_deadstemn_xf_to_deadstemn_p_acc ) + deallocate (AKX_livecrootn_xf_to_livecrootn_p_acc ) + deallocate (AKX_deadcrootn_xf_to_deadcrootn_p_acc ) + deallocate (AKX_grainn_xf_to_grainn_p_acc ) + deallocate (AKX_livestemn_to_deadstemn_p_acc ) + deallocate (AKX_livecrootn_to_deadcrootn_p_acc ) + + deallocate (AKX_leafn_st_to_leafn_xf_p_acc ) + deallocate (AKX_frootn_st_to_frootn_xf_p_acc ) + deallocate (AKX_livestemn_st_to_livestemn_xf_p_acc ) + deallocate (AKX_deadstemn_st_to_deadstemn_xf_p_acc ) + deallocate (AKX_livecrootn_st_to_livecrootn_xf_p_acc ) + deallocate (AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ) + deallocate (AKX_grainn_st_to_grainn_xf_p_acc ) + + deallocate (AKX_leafn_to_retransn_p_acc ) + deallocate (AKX_frootn_to_retransn_p_acc ) + deallocate (AKX_livestemn_to_retransn_p_acc ) + deallocate (AKX_livecrootn_to_retransn_p_acc ) + + deallocate (AKX_retransn_to_leafn_p_acc ) + deallocate (AKX_retransn_to_frootn_p_acc ) + deallocate (AKX_retransn_to_livestemn_p_acc ) + deallocate (AKX_retransn_to_deadstemn_p_acc ) + deallocate (AKX_retransn_to_livecrootn_p_acc ) + deallocate (AKX_retransn_to_deadcrootn_p_acc ) + deallocate (AKX_retransn_to_grainn_p_acc ) + + deallocate (AKX_retransn_to_leafn_st_p_acc ) + deallocate (AKX_retransn_to_frootn_st_p_acc ) + deallocate (AKX_retransn_to_livestemn_st_p_acc ) + deallocate (AKX_retransn_to_deadstemn_st_p_acc ) + deallocate (AKX_retransn_to_livecrootn_st_p_acc ) + deallocate (AKX_retransn_to_deadcrootn_st_p_acc ) + deallocate (AKX_retransn_to_grainn_st_p_acc ) + + deallocate (AKX_leafn_exit_p_acc ) + deallocate (AKX_frootn_exit_p_acc ) + deallocate (AKX_livestemn_exit_p_acc ) + deallocate (AKX_deadstemn_exit_p_acc ) + deallocate (AKX_livecrootn_exit_p_acc ) + deallocate (AKX_deadcrootn_exit_p_acc ) + deallocate (AKX_grainn_exit_p_acc ) + deallocate (AKX_retransn_exit_p_acc ) + + deallocate (AKX_leafn_st_exit_p_acc ) + deallocate (AKX_frootn_st_exit_p_acc ) + deallocate (AKX_livestemn_st_exit_p_acc ) + deallocate (AKX_deadstemn_st_exit_p_acc ) + deallocate (AKX_livecrootn_st_exit_p_acc ) + deallocate (AKX_deadcrootn_st_exit_p_acc ) + deallocate (AKX_grainn_st_exit_p_acc ) + + deallocate (AKX_leafn_xf_exit_p_acc ) + deallocate (AKX_frootn_xf_exit_p_acc ) + deallocate (AKX_livestemn_xf_exit_p_acc ) + deallocate (AKX_deadstemn_xf_exit_p_acc ) + deallocate (AKX_livecrootn_xf_exit_p_acc ) + deallocate (AKX_deadcrootn_xf_exit_p_acc ) + deallocate (AKX_grainn_xf_exit_p_acc ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_BGCPFTimeVariables + +#ifdef RangeCheck + SUBROUTINE check_BGCPFTimeVariables + + USE MOD_RangeCheck + USE MOD_SPMD_Task + IMPLICIT NONE + +! bgc variables + CALL check_vector_data ('leafc_p ', leafc_p ) + CALL check_vector_data ('leafc_storage_p ', leafc_storage_p ) + CALL check_vector_data ('leafc_xfer_p ', leafc_xfer_p ) + CALL check_vector_data ('frootc_p ', frootc_p ) + CALL check_vector_data ('frootc_storage_p ', frootc_storage_p ) + CALL check_vector_data ('frootc_xfer_p ', frootc_xfer_p ) + CALL check_vector_data ('livestemc_p ', livestemc_p ) + CALL check_vector_data ('livestemc_storage_p ', livestemc_storage_p ) + CALL check_vector_data ('livestemc_xfer_p ', livestemc_xfer_p ) + CALL check_vector_data ('deadstemc_p ', deadstemc_p ) + CALL check_vector_data ('deadstemc_storage_p ', deadstemc_storage_p ) + CALL check_vector_data ('deadstemc_xfer_p ', deadstemc_xfer_p ) + CALL check_vector_data ('livecrootc_p ', livecrootc_p ) + CALL check_vector_data ('livecrootc_storage_p ', livecrootc_storage_p ) + CALL check_vector_data ('livecrootc_xfer_p ', livecrootc_xfer_p ) + CALL check_vector_data ('deadcrootc_p ', deadcrootc_p ) + CALL check_vector_data ('deadcrootc_storage_p ', deadcrootc_storage_p ) + CALL check_vector_data ('deadcrootc_xfer_p ', deadcrootc_xfer_p ) + CALL check_vector_data ('grainc_p ', grainc_p ) + CALL check_vector_data ('grainc_storage_p ', grainc_storage_p ) + CALL check_vector_data ('grainc_xfer_p ', grainc_xfer_p ) + CALL check_vector_data ('cropseedc_deficit_p ', cropseedc_deficit_p ) + CALL check_vector_data ('xsmrpool_p ', xsmrpool_p ) + CALL check_vector_data ('gresp_storage_p ', gresp_storage_p ) + CALL check_vector_data ('gresp_xfer_p ', gresp_xfer_p ) + CALL check_vector_data ('cpool_p ', cpool_p ) + CALL check_vector_data ('totvegc_p ', totvegc_p ) + CALL check_vector_data ('cropprod1c_p ', cropprod1c_p ) + + CALL check_vector_data ('leaf_prof_p ', leaf_prof_p ) + CALL check_vector_data ('froot_prof_p ', froot_prof_p ) + CALL check_vector_data ('croot_prof_p ', croot_prof_p ) + CALL check_vector_data ('stem_prof_p ', stem_prof_p ) + CALL check_vector_data ('cinput_rootfr_p ', cinput_rootfr_p ) + + CALL check_vector_data ('leafn_p ', leafn_p ) + CALL check_vector_data ('leafn_storage_p ', leafn_storage_p ) + CALL check_vector_data ('leafn_xfer_p ', leafn_xfer_p ) + CALL check_vector_data ('frootn_p ', frootn_p ) + CALL check_vector_data ('frootn_storage_p ', frootn_storage_p ) + CALL check_vector_data ('frootn_xfer_p ', frootn_xfer_p ) + CALL check_vector_data ('livestemn_p ', livestemn_p ) + CALL check_vector_data ('livestemn_storage_p ', livestemn_storage_p ) + CALL check_vector_data ('livestemn_xfer_p ', livestemn_xfer_p ) + CALL check_vector_data ('deadstemn_p ', deadstemn_p ) + CALL check_vector_data ('deadstemn_storage_p ', deadstemn_storage_p ) + CALL check_vector_data ('deadstemn_xfer_p ', deadstemn_xfer_p ) + CALL check_vector_data ('livecrootn_p ', livecrootn_p ) + CALL check_vector_data ('livecrootn_storage_p ', livecrootn_storage_p ) + CALL check_vector_data ('livecrootn_xfer_p ', livecrootn_xfer_p ) + CALL check_vector_data ('deadcrootn_p ', deadcrootn_p ) + CALL check_vector_data ('deadcrootn_storage_p ', deadcrootn_storage_p ) + CALL check_vector_data ('deadcrootn_xfer_p ', deadcrootn_xfer_p ) + CALL check_vector_data ('grainn_p ', grainn_p ) + CALL check_vector_data ('grainn_storage_p ', grainn_storage_p ) + CALL check_vector_data ('grainn_xfer_p ', grainn_xfer_p ) + CALL check_vector_data ('cropseedn_deficit_p ', cropseedn_deficit_p ) + CALL check_vector_data ('retransn_p ', retransn_p ) + CALL check_vector_data ('totvegn_p ', totvegn_p ) + + CALL check_vector_data ('harvdate_p ', harvdate_p ) + + CALL check_vector_data ('tempsum_potential_gpp_p', tempsum_potential_gpp_p) + CALL check_vector_data ('tempmax_retransn_p ', tempmax_retransn_p ) + CALL check_vector_data ('tempavg_tref_p ', tempavg_tref_p ) + CALL check_vector_data ('tempsum_npp_p ', tempsum_npp_p ) + CALL check_vector_data ('tempsum_litfall_p ', tempsum_litfall_p ) + CALL check_vector_data ('annsum_potential_gpp_p ', annsum_potential_gpp_p ) + CALL check_vector_data ('annmax_retransn_p ', annmax_retransn_p ) + CALL check_vector_data ('annavg_tref_p ', annavg_tref_p ) + CALL check_vector_data ('annsum_npp_p ', annsum_npp_p ) + CALL check_vector_data ('annsum_litfall_p ', annsum_litfall_p ) + + CALL check_vector_data ('bglfr_p ', bglfr_p ) + CALL check_vector_data ('bgtr_p ', bgtr_p ) + CALL check_vector_data ('lgsf_p ', lgsf_p ) + CALL check_vector_data ('gdd0_p ', gdd0_p ) + CALL check_vector_data ('gdd8_p ', gdd8_p ) + CALL check_vector_data ('gdd10_p ', gdd10_p ) + CALL check_vector_data ('gdd020_p ', gdd020_p ) + CALL check_vector_data ('gdd820_p ', gdd820_p ) + CALL check_vector_data ('gdd1020_p ', gdd1020_p ) + + CALL check_vector_data ('offset_flag_p ', offset_flag_p ) + CALL check_vector_data ('offset_counter_p ', offset_counter_p ) + CALL check_vector_data ('onset_flag_p ', onset_flag_p ) + CALL check_vector_data ('onset_counter_p ', onset_counter_p ) + CALL check_vector_data ('onset_gddflag_p ', onset_gddflag_p ) + CALL check_vector_data ('onset_gdd_p ', onset_gdd_p ) + CALL check_vector_data ('onset_fdd_p ', onset_fdd_p ) + CALL check_vector_data ('onset_swi_p ', onset_swi_p ) + CALL check_vector_data ('offset_fdd_p ', offset_fdd_p ) + CALL check_vector_data ('offset_swi_p ', offset_swi_p ) + CALL check_vector_data ('dormant_flag_p ', dormant_flag_p ) + CALL check_vector_data ('prev_leafc_to_litter_p ', prev_leafc_to_litter_p ) + CALL check_vector_data ('prev_frootc_to_litter_p', prev_frootc_to_litter_p) + CALL check_vector_data ('days_active_p ', days_active_p ) + + CALL check_vector_data ('burndate_p ', burndate_p ) + + CALL check_vector_data ('c_allometry_p ', c_allometry_p ) + CALL check_vector_data ('n_allometry_p ', n_allometry_p ) + CALL check_vector_data ('downreg_p ', downreg_p ) + CALL check_vector_data ('grain_flag_p ', grain_flag_p ) + + CALL check_vector_data ('ctrunc_p ', ctrunc_p ) + CALL check_vector_data ('ntrunc_p ', ntrunc_p ) + CALL check_vector_data ('npool_p ', npool_p ) + +#ifdef CROP +! crop variables + CALL check_vector_data ('hui_p ', hui_p ) + CALL check_vector_data ('gddplant_p ', gddplant_p ) + CALL check_vector_data ('aroot_p ', aroot_p ) + CALL check_vector_data ('astem_p ', astem_p ) + CALL check_vector_data ('arepr_p ', arepr_p ) + CALL check_vector_data ('aleaf_p ', aleaf_p ) + CALL check_vector_data ('astemi_p ', astemi_p ) + CALL check_vector_data ('aleafi_p ', aleafi_p ) + CALL check_vector_data ('gddmaturity_p ', gddmaturity_p ) + + CALL check_vector_data ('a5tmin_p ', a5tmin_p ) + CALL check_vector_data ('a10tmin_p ', a10tmin_p ) + CALL check_vector_data ('t10_p ', t10_p ) + CALL check_vector_data ('cumvd_p ', cumvd_p ) + CALL check_vector_data ('vf_p ', vf_p ) + CALL check_vector_data ('cphase_p ', cphase_p ) + CALL check_vector_data ('fert_counter_p ', fert_counter_p ) + CALL check_vector_data ('tref_min_p ', tref_min_p ) + CALL check_vector_data ('tref_max_p ', tref_max_p ) + CALL check_vector_data ('tref_min_inst_p ', tref_min_inst_p ) + CALL check_vector_data ('tref_max_inst_p ', tref_max_inst_p ) + CALL check_vector_data ('fertnitro_p ', fertnitro_p ) + CALL check_vector_data ('manunitro_p ', manunitro_p ) + CALL check_vector_data ('fert_p ', fert_p ) + CALL check_vector_data ('latbaset_p ', latbaset_p ) + CALL check_vector_data ('plantdate_p ', plantdate_p ) +#endif + + IF(DEF_USE_DiagMatrix)THEN +! SASU variables + CALL check_vector_data ('leafcCap_p ', leafcCap_p ) + CALL check_vector_data ('leafc_storageCap_p ', leafc_storageCap_p ) + CALL check_vector_data ('leafc_xferCap_p ', leafc_xferCap_p ) + CALL check_vector_data ('frootcCap_p ', frootcCap_p ) + CALL check_vector_data ('frootc_storageCap_p ', frootc_storageCap_p ) + CALL check_vector_data ('frootc_xferCap_p ', frootc_xferCap_p ) + CALL check_vector_data ('livestemcCap_p ', livestemcCap_p ) + CALL check_vector_data ('livestemc_storageCap_p ', livestemc_storageCap_p ) + CALL check_vector_data ('livestemc_xferCap_p ', livestemc_xferCap_p ) + CALL check_vector_data ('deadstemcCap_p ', deadstemcCap_p ) + CALL check_vector_data ('deadstemc_storageCap_p ', deadstemc_storageCap_p ) + CALL check_vector_data ('deadstemc_xferCap_p ', deadstemc_xferCap_p ) + CALL check_vector_data ('livecrootcCap_p ', livecrootcCap_p ) + CALL check_vector_data ('livecrootc_storageCap_p ', livecrootc_storageCap_p ) + CALL check_vector_data ('livecrootc_xferCap_p ', livecrootc_xferCap_p ) + CALL check_vector_data ('deadcrootcCap_p ', deadcrootcCap_p ) + CALL check_vector_data ('deadcrootc_storageCap_p ', deadcrootc_storageCap_p ) + CALL check_vector_data ('deadcrootc_xferCap_p ', deadcrootc_xferCap_p ) + + CALL check_vector_data ('leafnCap_p ', leafnCap_p ) + CALL check_vector_data ('leafn_storageCap_p ', leafn_storageCap_p ) + CALL check_vector_data ('leafn_xferCap_p ', leafn_xferCap_p ) + CALL check_vector_data ('frootnCap_p ', frootnCap_p ) + CALL check_vector_data ('frootn_storageCap_p ', frootn_storageCap_p ) + CALL check_vector_data ('frootn_xferCap_p ', frootn_xferCap_p ) + CALL check_vector_data ('livestemnCap_p ', livestemnCap_p ) + CALL check_vector_data ('livestemn_storageCap_p ', livestemn_storageCap_p ) + CALL check_vector_data ('livestemn_xferCap_p ', livestemn_xferCap_p ) + CALL check_vector_data ('deadstemnCap_p ', deadstemnCap_p ) + CALL check_vector_data ('deadstemn_storageCap_p ', deadstemn_storageCap_p ) + CALL check_vector_data ('deadstemn_xferCap_p ', deadstemn_xferCap_p ) + CALL check_vector_data ('livecrootnCap_p ', livecrootnCap_p ) + CALL check_vector_data ('livecrootn_storageCap_p ', livecrootn_storageCap_p ) + CALL check_vector_data ('livecrootn_xferCap_p ', livecrootn_xferCap_p ) + CALL check_vector_data ('deadcrootnCap_p ', deadcrootnCap_p ) + CALL check_vector_data ('deadcrootn_storageCap_p ', deadcrootn_storageCap_p ) + CALL check_vector_data ('deadcrootn_xferCap_p ', deadcrootn_xferCap_p ) + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('leafc0_p ', leafc0_p ) + CALL check_vector_data ('leafc0_storage_p ', leafc0_storage_p ) + CALL check_vector_data ('leafc0_xfer_p ', leafc0_xfer_p ) + CALL check_vector_data ('frootc0_p ', frootc0_p ) + CALL check_vector_data ('frootc0_storage_p ', frootc0_storage_p ) + CALL check_vector_data ('frootc0_xfer_p ', frootc0_xfer_p ) + CALL check_vector_data ('livestemc0_p ', livestemc0_p ) + CALL check_vector_data ('livestemc0_storage_p ', livestemc0_storage_p ) + CALL check_vector_data ('livestemc0_xfer_p ', livestemc0_xfer_p ) + CALL check_vector_data ('deadstemc0_p ', deadstemc0_p ) + CALL check_vector_data ('deadstemc0_storage_p ', deadstemc0_storage_p ) + CALL check_vector_data ('deadstemc0_xfer_p ', deadstemc0_xfer_p ) + CALL check_vector_data ('livecrootc0_p ', livecrootc0_p ) + CALL check_vector_data ('livecrootc0_storage_p ', livecrootc0_storage_p ) + CALL check_vector_data ('livecrootc0_xfer_p ', livecrootc0_xfer_p ) + CALL check_vector_data ('deadcrootc0_p ', deadcrootc0_p ) + CALL check_vector_data ('deadcrootc0_storage_p ', deadcrootc0_storage_p ) + CALL check_vector_data ('deadcrootc0_xfer_p ', deadcrootc0_xfer_p ) + CALL check_vector_data ('grainc0_p ', grainc0_p ) + CALL check_vector_data ('grainc0_storage_p ', grainc0_storage_p ) + CALL check_vector_data ('grainc0_xfer_p ', grainc0_xfer_p ) + + CALL check_vector_data ('leafn0_p ', leafn0_p ) + CALL check_vector_data ('leafn0_storage_p ', leafn0_storage_p ) + CALL check_vector_data ('leafn0_xfer_p ', leafn0_xfer_p ) + CALL check_vector_data ('frootn0_p ', frootn0_p ) + CALL check_vector_data ('frootn0_storage_p ', frootn0_storage_p ) + CALL check_vector_data ('frootn0_xfer_p ', frootn0_xfer_p ) + CALL check_vector_data ('livestemn0_p ', livestemn0_p ) + CALL check_vector_data ('livestemn0_storage_p ', livestemn0_storage_p ) + CALL check_vector_data ('livestemn0_xfer_p ', livestemn0_xfer_p ) + CALL check_vector_data ('deadstemn0_p ', deadstemn0_p ) + CALL check_vector_data ('deadstemn0_storage_p ', deadstemn0_storage_p ) + CALL check_vector_data ('deadstemn0_xfer_p ', deadstemn0_xfer_p ) + CALL check_vector_data ('livecrootn0_p ', livecrootn0_p ) + CALL check_vector_data ('livecrootn0_storage_p ', livecrootn0_storage_p ) + CALL check_vector_data ('livecrootn0_xfer_p ', livecrootn0_xfer_p ) + CALL check_vector_data ('deadcrootn0_p ', deadcrootn0_p ) + CALL check_vector_data ('deadcrootn0_storage_p ', deadcrootn0_storage_p ) + CALL check_vector_data ('deadcrootn0_xfer_p ', deadcrootn0_xfer_p ) + CALL check_vector_data ('grainn0_p ', grainn0_p ) + CALL check_vector_data ('grainn0_storage_p ', grainn0_storage_p ) + CALL check_vector_data ('grainn0_xfer_p ', grainn0_xfer_p ) + CALL check_vector_data ('retransn0_p ', retransn0_p ) + + CALL check_vector_data ('I_leafc_p_acc ', I_leafc_p_acc ) + CALL check_vector_data ('I_leafc_st_p_acc ', I_leafc_st_p_acc ) + CALL check_vector_data ('I_frootc_p_acc ', I_frootc_p_acc ) + CALL check_vector_data ('I_frootc_st_p_acc ', I_frootc_st_p_acc ) + CALL check_vector_data ('I_livestemc_p_acc ', I_livestemc_p_acc ) + CALL check_vector_data ('I_livestemc_st_p_acc ', I_livestemc_st_p_acc ) + CALL check_vector_data ('I_deadstemc_p_acc ', I_deadstemc_p_acc ) + CALL check_vector_data ('I_deadstemc_st_p_acc ', I_deadstemc_st_p_acc ) + CALL check_vector_data ('I_livecrootc_p_acc ', I_livecrootc_p_acc ) + CALL check_vector_data ('I_livecrootc_st_p_acc ', I_livecrootc_st_p_acc ) + CALL check_vector_data ('I_deadcrootc_p_acc ', I_deadcrootc_p_acc ) + CALL check_vector_data ('I_deadcrootc_st_p_acc ', I_deadcrootc_st_p_acc ) + CALL check_vector_data ('I_grainc_p_acc ', I_grainc_p_acc ) + CALL check_vector_data ('I_grainc_st_p_acc ', I_grainc_st_p_acc ) + CALL check_vector_data ('I_leafn_p_acc ', I_leafn_p_acc ) + CALL check_vector_data ('I_leafn_st_p_acc ', I_leafn_st_p_acc ) + CALL check_vector_data ('I_frootn_p_acc ', I_frootn_p_acc ) + CALL check_vector_data ('I_frootn_st_p_acc ', I_frootn_st_p_acc ) + CALL check_vector_data ('I_livestemn_p_acc ', I_livestemn_p_acc ) + CALL check_vector_data ('I_livestemn_st_p_acc ', I_livestemn_st_p_acc ) + CALL check_vector_data ('I_deadstemn_p_acc ', I_deadstemn_p_acc ) + CALL check_vector_data ('I_deadstemn_st_p_acc ', I_deadstemn_st_p_acc ) + CALL check_vector_data ('I_livecrootn_p_acc ', I_livecrootn_p_acc ) + CALL check_vector_data ('I_livecrootn_st_p_acc ', I_livecrootn_st_p_acc ) + CALL check_vector_data ('I_deadcrootn_p_acc ', I_deadcrootn_p_acc ) + CALL check_vector_data ('I_deadcrootn_st_p_acc ', I_deadcrootn_st_p_acc ) + CALL check_vector_data ('I_grainn_p_acc ', I_grainn_p_acc ) + CALL check_vector_data ('I_grainn_st_p_acc ', I_grainn_st_p_acc ) + + CALL check_vector_data ('AKX_leafc_xf_to_leafc_p_acc ', AKX_leafc_xf_to_leafc_p_acc ) + CALL check_vector_data ('AKX_frootc_xf_to_frootc_p_acc ', AKX_frootc_xf_to_frootc_p_acc ) + CALL check_vector_data ('AKX_livestemc_xf_to_livestemc_p_acc ', AKX_livestemc_xf_to_livestemc_p_acc ) + CALL check_vector_data ('AKX_deadstemc_xf_to_deadstemc_p_acc ', AKX_deadstemc_xf_to_deadstemc_p_acc ) + CALL check_vector_data ('AKX_livecrootc_xf_to_livecrootc_p_acc ', AKX_livecrootc_xf_to_livecrootc_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_xf_to_deadcrootc_p_acc ', AKX_deadcrootc_xf_to_deadcrootc_p_acc ) + CALL check_vector_data ('AKX_grainc_xf_to_grainc_p_acc ', AKX_grainc_xf_to_grainc_p_acc ) + CALL check_vector_data ('AKX_livestemc_to_deadstemc_p_acc ', AKX_livestemc_to_deadstemc_p_acc ) + CALL check_vector_data ('AKX_livecrootc_to_deadcrootc_p_acc ', AKX_livecrootc_to_deadcrootc_p_acc ) + CALL check_vector_data ('AKX_leafc_st_to_leafc_xf_p_acc ', AKX_leafc_st_to_leafc_xf_p_acc ) + CALL check_vector_data ('AKX_frootc_st_to_frootc_xf_p_acc ', AKX_frootc_st_to_frootc_xf_p_acc ) + CALL check_vector_data ('AKX_livestemc_st_to_livestemc_xf_p_acc ', AKX_livestemc_st_to_livestemc_xf_p_acc ) + CALL check_vector_data ('AKX_deadstemc_st_to_deadstemc_xf_p_acc ', AKX_deadstemc_st_to_deadstemc_xf_p_acc ) + CALL check_vector_data ('AKX_livecrootc_st_to_livecrootc_xf_p_acc ', AKX_livecrootc_st_to_livecrootc_xf_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ', AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ) + CALL check_vector_data ('AKX_grainc_st_to_grainc_xf_p_acc ', AKX_grainc_st_to_grainc_xf_p_acc ) + CALL check_vector_data ('AKX_leafc_exit_p_acc ', AKX_leafc_exit_p_acc ) + CALL check_vector_data ('AKX_frootc_exit_p_acc ', AKX_frootc_exit_p_acc ) + CALL check_vector_data ('AKX_livestemc_exit_p_acc ', AKX_livestemc_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemc_exit_p_acc ', AKX_deadstemc_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootc_exit_p_acc ', AKX_livecrootc_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_exit_p_acc ', AKX_deadcrootc_exit_p_acc ) + CALL check_vector_data ('AKX_grainc_exit_p_acc ', AKX_grainc_exit_p_acc ) + + CALL check_vector_data ('AKX_leafc_st_exit_p_acc ', AKX_leafc_st_exit_p_acc ) + CALL check_vector_data ('AKX_frootc_st_exit_p_acc ', AKX_frootc_st_exit_p_acc ) + CALL check_vector_data ('AKX_livestemc_st_exit_p_acc ', AKX_livestemc_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemc_st_exit_p_acc ', AKX_deadstemc_st_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootc_st_exit_p_acc ', AKX_livecrootc_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_st_exit_p_acc ', AKX_deadcrootc_st_exit_p_acc ) + CALL check_vector_data ('AKX_grainc_st_exit_p_acc ', AKX_grainc_st_exit_p_acc ) + + CALL check_vector_data ('AKX_leafc_xf_exit_p_acc ', AKX_leafc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_frootc_xf_exit_p_acc ', AKX_frootc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livestemc_xf_exit_p_acc ', AKX_livestemc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemc_xf_exit_p_acc ', AKX_deadstemc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootc_xf_exit_p_acc ', AKX_livecrootc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_xf_exit_p_acc ', AKX_deadcrootc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_grainc_xf_exit_p_acc ', AKX_grainc_xf_exit_p_acc ) + + CALL check_vector_data ('AKX_leafn_xf_to_leafn_p_acc ', AKX_leafn_xf_to_leafn_p_acc ) + CALL check_vector_data ('AKX_frootn_xf_to_frootn_p_acc ', AKX_frootn_xf_to_frootn_p_acc ) + CALL check_vector_data ('AKX_livestemn_xf_to_livestemn_p_acc ', AKX_livestemn_xf_to_livestemn_p_acc ) + CALL check_vector_data ('AKX_deadstemn_xf_to_deadstemn_p_acc ', AKX_deadstemn_xf_to_deadstemn_p_acc ) + CALL check_vector_data ('AKX_livecrootn_xf_to_livecrootn_p_acc ', AKX_livecrootn_xf_to_livecrootn_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_xf_to_deadcrootn_p_acc ', AKX_deadcrootn_xf_to_deadcrootn_p_acc ) + CALL check_vector_data ('AKX_grainn_xf_to_grainn_p_acc ', AKX_grainn_xf_to_grainn_p_acc ) + CALL check_vector_data ('AKX_livestemn_to_deadstemn_p_acc ', AKX_livestemn_to_deadstemn_p_acc ) + CALL check_vector_data ('AKX_livecrootn_to_deadcrootn_p_acc ', AKX_livecrootn_to_deadcrootn_p_acc ) + + CALL check_vector_data ('AKX_leafn_st_to_leafn_xf_p_acc ', AKX_leafn_st_to_leafn_xf_p_acc ) + CALL check_vector_data ('AKX_frootn_st_to_frootn_xf_p_acc ', AKX_frootn_st_to_frootn_xf_p_acc ) + CALL check_vector_data ('AKX_livestemn_st_to_livestemn_xf_p_acc ', AKX_livestemn_st_to_livestemn_xf_p_acc ) + CALL check_vector_data ('AKX_deadstemn_st_to_deadstemn_xf_p_acc ', AKX_deadstemn_st_to_deadstemn_xf_p_acc ) + CALL check_vector_data ('AKX_livecrootn_st_to_livecrootn_xf_p_acc ', AKX_livecrootn_st_to_livecrootn_xf_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ', AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ) + CALL check_vector_data ('AKX_grainn_st_to_grainn_xf_p_acc ', AKX_grainn_st_to_grainn_xf_p_acc ) + + CALL check_vector_data ('AKX_leafn_to_retransn_p_acc ', AKX_leafn_to_retransn_p_acc ) + CALL check_vector_data ('AKX_frootn_to_retransn_p_acc ', AKX_frootn_to_retransn_p_acc ) + CALL check_vector_data ('AKX_livestemn_to_retransn_p_acc ', AKX_livestemn_to_retransn_p_acc ) + CALL check_vector_data ('AKX_livecrootn_to_retransn_p_acc ', AKX_livecrootn_to_retransn_p_acc ) + + CALL check_vector_data ('AKX_retransn_to_leafn_p_acc ', AKX_retransn_to_leafn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_frootn_p_acc ', AKX_retransn_to_frootn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livestemn_p_acc ', AKX_retransn_to_livestemn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadstemn_p_acc ', AKX_retransn_to_deadstemn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livecrootn_p_acc ', AKX_retransn_to_livecrootn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadcrootn_p_acc ', AKX_retransn_to_deadcrootn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_grainn_p_acc ', AKX_retransn_to_grainn_p_acc ) + + CALL check_vector_data ('AKX_retransn_to_leafn_st_p_acc ', AKX_retransn_to_leafn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_frootn_st_p_acc ', AKX_retransn_to_frootn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livestemn_st_p_acc ', AKX_retransn_to_livestemn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadstemn_st_p_acc ', AKX_retransn_to_deadstemn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livecrootn_st_p_acc ', AKX_retransn_to_livecrootn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadcrootn_st_p_acc ', AKX_retransn_to_deadcrootn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_grainn_st_p_acc ', AKX_retransn_to_grainn_st_p_acc ) + + CALL check_vector_data ('AKX_leafn_exit_p_acc ', AKX_leafn_exit_p_acc ) + CALL check_vector_data ('AKX_frootn_exit_p_acc ', AKX_frootn_exit_p_acc ) + CALL check_vector_data ('AKX_livestemn_exit_p_acc ', AKX_livestemn_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemn_exit_p_acc ', AKX_deadstemn_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootn_exit_p_acc ', AKX_livecrootn_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_exit_p_acc ', AKX_deadcrootn_exit_p_acc ) + CALL check_vector_data ('AKX_grainn_exit_p_acc ', AKX_grainn_exit_p_acc ) + CALL check_vector_data ('AKX_retransn_exit_p_acc ', AKX_retransn_exit_p_acc ) + + CALL check_vector_data ('AKX_leafn_st_exit_p_acc ', AKX_leafn_st_exit_p_acc ) + CALL check_vector_data ('AKX_frootn_st_exit_p_acc ', AKX_frootn_st_exit_p_acc ) + CALL check_vector_data ('AKX_livestemn_st_exit_p_acc ', AKX_livestemn_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemn_st_exit_p_acc ', AKX_deadstemn_st_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootn_st_exit_p_acc ', AKX_livecrootn_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_st_exit_p_acc ', AKX_deadcrootn_st_exit_p_acc ) + CALL check_vector_data ('AKX_grainn_st_exit_p_acc ', AKX_grainn_st_exit_p_acc ) + + CALL check_vector_data ('AKX_leafn_xf_exit_p_acc ', AKX_leafn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_frootn_xf_exit_p_acc ', AKX_frootn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livestemn_xf_exit_p_acc ', AKX_livestemn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemn_xf_exit_p_acc ', AKX_deadstemn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootn_xf_exit_p_acc ', AKX_livecrootn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_xf_exit_p_acc ', AKX_deadcrootn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_grainn_xf_exit_p_acc ', AKX_grainn_xf_exit_p_acc ) + ENDIF + END SUBROUTINE check_BGCPFTimeVariables +#endif + +#endif +END MODULE MOD_BGC_Vars_PFTimeVariables + +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..d0a115898f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 @@ -0,0 +1,512 @@ +#include + +MODULE MOD_BGC_Vars_TimeInvariants + +! -------------------------------------------------------------------- + +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical constant at patch level. +! Read and write biogeochemical constant at patch level from/to restart files. + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version +! ------------------------------- +#ifdef BGC + + USE MOD_Precision + IMPLICIT NONE + SAVE +!------------------------- BGC constant -------------------------------------- + integer , allocatable :: donor_pool (:) ! soil or litter pools where each decomposition transfered C&N is from. + integer , allocatable :: receiver_pool (:) ! soil or litter pools where each decomposition transfered C&N is to + real(r8) :: am ! gap-mortality rate constant (year-1) + logical , allocatable :: floating_cn_ratio(:) ! flag, soil or litter pool has 1) true: flexible or 2) false: fixed C:N ratio. + real(r8), allocatable :: initial_cn_ratio (:) ! initial c:n ratio of each litter and soil pool + real(r8), allocatable :: rf_decomp (:,:,:) ! respiratory fraction of the ith transfer hr(i) / (hr(i) + ctransfer(i)) + real(r8), allocatable :: pathfrac_decomp (:,:,:) ! pathway fraction of each transfer from the same donor pool & + ! (hr(i)+ctransfer(i))/sum(hr(donor_pool(:)==donor_pool(i))+ctransfer(donor_pool(:)==donor_pool(i))) + + integer :: i_met_lit ! index of metabolic litter pool + integer :: i_cel_lit ! index of cellulose litter pool + integer :: i_lig_lit ! index of lignin litter pool + integer :: i_cwd ! index of coarse woody debris pool + integer :: i_soil1 ! index of active soil organic matter pool + integer :: i_soil2 ! index of slow soil organic matter pool + integer :: i_soil3 ! index of passive soil organic matter pool + integer :: i_atm ! index of atmosphere pool + + logical , allocatable :: is_cwd (:) ! (1:ndecomp_pools) ! True => is a coarse woody debris pool + logical , allocatable :: is_litter (:) ! (1:ndecomp_pools) ! True => is a litter pool + logical , allocatable :: is_soil (:) ! (1:ndecomp_pools) ! True => is a soil pool + + real(r8), allocatable :: gdp_lf (:) ! gdp data + real(r8), allocatable :: abm_lf (:) ! prescribed crop fire time + real(r8), allocatable :: peatf_lf (:) ! peatland fraction data + real(r8), allocatable :: cmb_cmplt_fact(:) ! combustion completion factor + integer , allocatable :: rice2pdt (:) ! rice2 planting date + + real(r8) :: nitrif_n2o_loss_frac ! fraction of N lost as N2O in nitrification (unitless) + real(r8) :: dnp ! denitrification proportion (unitless) + real(r8) :: bdnr ! bulk denitrification rate (1/day) + real(r8) :: compet_plant_no3 ! relative compettiveness of plants for NO3 (unitless) + real(r8) :: compet_plant_nh4 ! relative compettiveness of plants for NH4 (unitless) + real(r8) :: compet_decomp_no3 ! relative competitiveness of immobilizers for NO3 (unitless) + real(r8) :: compet_decomp_nh4 ! relative competitiveness of immobilizers for NH4 (unitless) + real(r8) :: compet_denit ! relative competitiveness of denitrifiers for NO3 (unitless) + real(r8) :: compet_nit ! relative competitiveness of nitrifiers for NH4 (unitless) + real(r8) :: surface_tension_water ! surface tension of water (J m-2) + real(r8) :: rij_kro_a ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_alpha ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_beta ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_gamma ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_delta ! parameters for calculation of anoxic fraction of soil + real(r8) :: nfix_timeconst ! timescale for smoothing npp in N fixation term + real(r8) :: organic_max ! organic matter content (kg m-3) where soil is assumed to act like peat + real(r8) :: d_con_g21 ! O2 diffusivity constants in gas (cm2 s-1) + real(r8) :: d_con_g22 ! O2 diffusivity constants in gas (cm2 s-1) + real(r8) :: d_con_w21 ! O2 diffusivity constants in water (cm2 s-1) + real(r8) :: d_con_w22 ! O2 diffusivity constants in water (cm2 s-1) + real(r8) :: d_con_w23 ! O2 diffusivity constants in water (cm2 s-1) + real(r8) :: denit_resp_coef ! coefficient for maximum N denitrification rate based on respiration + real(r8) :: denit_resp_exp ! exponent for maximum N denitrification rate based on respiration + real(r8) :: denit_nitrate_coef ! coefficient for maximum N denitrification rate based on nitrate concentration + real(r8) :: denit_nitrate_exp ! exponent for maximum N denitrification rate based on nitrate concentration + real(r8) :: k_nitr_max ! maximum N nitrification rate (day-1) + real(r8) :: Q10 ! respiration rate increments when temperature rising 10 degree C + real(r8) :: froz_q10 ! respiration rate increments when temperature rising 10 degree C for frozen soil + real(r8) :: tau_l1 ! baseline turnover rate of metabolic litter from Century (year-1) + real(r8) :: tau_l2_l3 ! baseline turnover rate of cellulose litter and lignin litter from Century (year-1) + real(r8) :: tau_s1 ! baseline turnover rate of active soil organic matter from Century (year-1) + real(r8) :: tau_s2 ! baseline turnover rate of slow soil organic matter from Century (year-1) + real(r8) :: tau_s3 ! baseline turnover rate of passive soil organic matter from Century (year-1) + real(r8) :: tau_cwd ! baseline turnover rate of CWD (year-1) + real(r8) :: lwtop ! live wood turnover proportion + + real(r8) :: som_adv_flux ! the advection term in soil organic matter mixing + real(r8) :: som_diffus ! the diffusion term in soil organic matter mixing + real(r8) :: cryoturb_diffusion_k ! the cryoturbation diffusive constant cryoturbation to the active layer thickness (m2 s-1) + real(r8) :: max_altdepth_cryoturbation ! maximum active layer thickness for cryoturbation to occur (m) + real(r8) :: max_depth_cryoturb ! the maximum depth of cryoturbation (m) + + real(r8) :: br ! basal maintenance respiration rate for aboveground biomass (gC gN-1 s-1) + real(r8) :: br_root ! basal maintenance respiration rate for belowground biomass (gC gN-1 s-1) + real(r8) :: fstor2tran ! fraction of storage to transfer pool at each onset event + real(r8) :: ndays_on ! number of days to complete leaf onset + real(r8) :: ndays_off ! number of days to complete leaf offset + real(r8) :: crit_dayl ! critical day length for senescence (s) + real(r8) :: crit_onset_fdd ! critical number of freezing days to begin gdd accumulation + real(r8) :: crit_onset_swi ! critical number of days exceeding soil water potential threshold to initiate onset + real(r8) :: crit_offset_fdd ! critical number of freezing days to initiate offset + real(r8) :: crit_offset_swi ! critical number of days below soil water potential threshold to initiate offset + real(r8) :: soilpsi_on ! critical soil water potential threshold for onset + real(r8) :: soilpsi_off ! critical soil water potential threshold for offset + + real(r8) :: occur_hi_gdp_tree ! fire occurance for high GDP areas that are tree dominated (fraction) + real(r8) :: lfuel ! lower threshold of fuel mass (gC/m2) for ignition, Li et al.(2014) + real(r8) :: ufuel ! upper threshold of fuel mass (gC/m2) for ignition, Li et al.(2014) + real(r8) :: cropfire_a1 ! a1 parameter for cropland fire in (Li et. al., 2014) (1/hr) + real(r8) :: borealat ! Latitude bound for boreal peat fires + real(r8) :: troplat ! Latitude bound for tropical + real(r8) :: non_boreal_peatfire_c ! c parameter for non-boreal peatland fire in Li et. al. (2013) (1/hr) + real(r8) :: boreal_peatfire_c ! c parameter for boreal peatland fire in Li et. al. (2013) (/hr) + real(r8) :: rh_low ! parameter for lower relative humidity on fire (%) + real(r8) :: rh_hgh ! parameter for higher relative humidity on fire (%) + real(r8) :: bt_min ! minimum water stress factor + real(r8) :: bt_max ! maximum water stress factor + real(r8) :: pot_hmn_ign_counts_alpha ! Potential human ignition counts (alpha in Li et. al. 2012) (1/person/month) + real(r8) :: g0_fire ! constant for fire spread estimates + + real(r8) :: sf ! soluble fraction of mineral N (unitless) + real(r8) :: sf_no3 ! soluble fraction of NO3 (unitless) + +!----------------------------------- END BGC constants ----------------- + + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_BGCTimeInvariants + PUBLIC :: deallocate_BGCTimeInvariants + PUBLIC :: READ_BGCTimeInvariants + PUBLIC :: WRITE_BGCTimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_BGCTimeInvariants () + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global, only: nl_soil, ndecomp_transitions, ndecomp_pools, spval_i4, spval + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + ! bgc variables + allocate (donor_pool (ndecomp_transitions)) ; donor_pool (:) = spval_i4 + allocate (receiver_pool (ndecomp_transitions)) ; receiver_pool (:) = spval_i4 + allocate (floating_cn_ratio (ndecomp_pools)) ; floating_cn_ratio (:) = .false. + allocate (initial_cn_ratio (ndecomp_pools)) ; initial_cn_ratio (:) = spval + allocate (rf_decomp (nl_soil,ndecomp_transitions,numpatch)) ; rf_decomp (:,:,:) = spval + allocate (pathfrac_decomp (nl_soil,ndecomp_transitions,numpatch)) ; pathfrac_decomp(:,:,:) = spval + allocate (is_cwd (ndecomp_pools)) ; is_cwd (:) = .false. ! True => is a coarse woody debris pool + allocate (is_litter (ndecomp_pools)) ; is_litter (:) = .false. ! True => is a litter pool + allocate (is_soil (ndecomp_pools)) ; is_soil (:) = .false. ! True => is a soil pool + allocate (gdp_lf (numpatch)) ; gdp_lf (:) = spval + allocate (abm_lf (numpatch)) ; abm_lf (:) = spval + allocate (peatf_lf (numpatch)) ; peatf_lf (:) = spval + allocate (cmb_cmplt_fact (2)) ; cmb_cmplt_fact (:) = spval + allocate (rice2pdt (numpatch)) ; rice2pdt (:) = spval_i4 + + ! END bgc variables + ENDIF + ENDIF + + END SUBROUTINE allocate_BGCTimeInvariants + + !--------------------------------------- + SUBROUTINE READ_BGCTimeInvariants (file_restart) + + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= + + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector + USE MOD_NetCDFSerial +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +! bgc constants + CALL ncio_read_bcast_serial (file_restart, 'donor_pool ', donor_pool ) + CALL ncio_read_bcast_serial (file_restart, 'receiver_pool ', receiver_pool ) + CALL ncio_read_bcast_serial (file_restart, 'floating_cn_ratio', floating_cn_ratio) + CALL ncio_read_bcast_serial (file_restart, 'initial_cn_ratio' , initial_cn_ratio) + CALL ncio_read_vector (file_restart, 'rf_decomp ', nl_soil,ndecomp_transitions,landpatch, rf_decomp ) + CALL ncio_read_vector (file_restart, 'pathfrac_decomp ', nl_soil,ndecomp_transitions,landpatch,pathfrac_decomp ) + + CALL ncio_read_bcast_serial (file_restart, 'i_met_lit ', i_met_lit ) + CALL ncio_read_bcast_serial (file_restart, 'i_cel_lit ', i_cel_lit ) + CALL ncio_read_bcast_serial (file_restart, 'i_lig_lit ', i_lig_lit ) + CALL ncio_read_bcast_serial (file_restart, 'i_cwd ', i_cwd ) + CALL ncio_read_bcast_serial (file_restart, 'i_soil1 ', i_soil1 ) + CALL ncio_read_bcast_serial (file_restart, 'i_soil2 ', i_soil2 ) + CALL ncio_read_bcast_serial (file_restart, 'i_soil3 ', i_soil3 ) + CALL ncio_read_bcast_serial (file_restart, 'i_atm ', i_atm ) + CALL ncio_read_bcast_serial (file_restart, 'is_cwd ', is_cwd ) + CALL ncio_read_bcast_serial (file_restart, 'is_litter ', is_litter ) + CALL ncio_read_bcast_serial (file_restart, 'is_soil ', is_soil ) + + ! CALL ncio_read_vector (file_restart, 'gdp_lf ', landpatch, gdp_lf ) + ! CALL ncio_read_vector (file_restart, 'abm_lf ', landpatch, abm_lf ) + ! CALL ncio_read_vector (file_restart, 'peatf_lf ', landpatch, peatf_lf ) + CALL ncio_read_bcast_serial (file_restart, 'cmb_cmplt_fact ', cmb_cmplt_fact ) + CALL ncio_read_vector (file_restart, 'rice2pdt ', landpatch, rice2pdt ) + + CALL ncio_read_bcast_serial (file_restart, 'nitrif_n2o_loss_frac', nitrif_n2o_loss_frac) + CALL ncio_read_bcast_serial (file_restart, 'dnp ', dnp )! + CALL ncio_read_bcast_serial (file_restart, 'bdnr ', bdnr )! + CALL ncio_read_bcast_serial (file_restart, 'compet_plant_no3 ', compet_plant_no3 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_plant_nh4 ', compet_plant_nh4 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_decomp_no3 ', compet_decomp_no3 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_decomp_nh4 ', compet_decomp_nh4 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_denit ', compet_denit )! + CALL ncio_read_bcast_serial (file_restart, 'compet_nit ', compet_nit )! + CALL ncio_read_bcast_serial (file_restart, 'surface_tension_water',surface_tension_water) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_a ', rij_kro_a ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_alpha ', rij_kro_alpha ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_beta ', rij_kro_beta ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_gamma ', rij_kro_gamma ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_delta ', rij_kro_delta ) + CALL ncio_read_bcast_serial (file_restart, 'nfix_timeconst ', nfix_timeconst ) + CALL ncio_read_bcast_serial (file_restart, 'organic_max ', organic_max ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_g21 ', d_con_g21 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_g22 ', d_con_g22 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_w21 ', d_con_w21 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_w22 ', d_con_w22 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_w23 ', d_con_w23 ) + CALL ncio_read_bcast_serial (file_restart, 'denit_resp_coef ', denit_resp_coef ) + CALL ncio_read_bcast_serial (file_restart, 'denit_resp_exp ', denit_resp_exp ) + CALL ncio_read_bcast_serial (file_restart, 'denit_nitrate_coef ', denit_nitrate_coef ) + CALL ncio_read_bcast_serial (file_restart, 'denit_nitrate_exp ', denit_nitrate_exp )! + CALL ncio_read_bcast_serial (file_restart, 'k_nitr_max ', k_nitr_max )! + CALL ncio_read_bcast_serial (file_restart, 'Q10 ', Q10 )! + CALL ncio_read_bcast_serial (file_restart, 'froz_q10 ', froz_q10 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_l1 ', tau_l1 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_l2_l3 ', tau_l2_l3 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_s1 ', tau_s1 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_s2 ', tau_s2 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_s3 ', tau_s3 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_cwd ', tau_cwd ) + CALL ncio_read_bcast_serial (file_restart, 'lwtop ', lwtop ) + + CALL ncio_read_bcast_serial (file_restart, 'som_adv_flux ', som_adv_flux ) + CALL ncio_read_bcast_serial (file_restart, 'som_diffus ', som_diffus ) + CALL ncio_read_bcast_serial (file_restart, 'cryoturb_diffusion_k', cryoturb_diffusion_k) + CALL ncio_read_bcast_serial (file_restart, 'max_altdepth_cryoturbation', max_altdepth_cryoturbation) + CALL ncio_read_bcast_serial (file_restart, 'max_depth_cryoturb ', max_depth_cryoturb ) + + CALL ncio_read_bcast_serial (file_restart, 'am ', am ) + CALL ncio_read_bcast_serial (file_restart, 'br ', br ) + CALL ncio_read_bcast_serial (file_restart, 'br_root ', br_root ) + CALL ncio_read_bcast_serial (file_restart, 'fstor2tran ', fstor2tran ) + CALL ncio_read_bcast_serial (file_restart, 'ndays_on ', ndays_on ) + CALL ncio_read_bcast_serial (file_restart, 'ndays_off ', ndays_off ) + CALL ncio_read_bcast_serial (file_restart, 'crit_dayl ', crit_dayl ) + CALL ncio_read_bcast_serial (file_restart, 'crit_onset_fdd ', crit_onset_fdd ) + CALL ncio_read_bcast_serial (file_restart, 'crit_onset_swi ', crit_onset_swi ) + CALL ncio_read_bcast_serial (file_restart, 'crit_offset_fdd ', crit_offset_fdd ) + CALL ncio_read_bcast_serial (file_restart, 'crit_offset_swi ', crit_offset_swi ) + CALL ncio_read_bcast_serial (file_restart, 'soilpsi_on ', soilpsi_on ) + CALL ncio_read_bcast_serial (file_restart, 'soilpsi_off ', soilpsi_off ) + + CALL ncio_read_bcast_serial (file_restart, 'occur_hi_gdp_tree ', occur_hi_gdp_tree ) + CALL ncio_read_bcast_serial (file_restart, 'lfuel ', lfuel ) + CALL ncio_read_bcast_serial (file_restart, 'ufuel ', ufuel ) + CALL ncio_read_bcast_serial (file_restart, 'cropfire_a1 ', cropfire_a1 ) + CALL ncio_read_bcast_serial (file_restart, 'borealat ', borealat ) + CALL ncio_read_bcast_serial (file_restart, 'troplat ', troplat ) + CALL ncio_read_bcast_serial (file_restart, 'non_boreal_peatfire_c', non_boreal_peatfire_c) + CALL ncio_read_bcast_serial (file_restart, 'boreal_peatfire_c ', boreal_peatfire_c ) + CALL ncio_read_bcast_serial (file_restart, 'rh_low ', rh_low ) + CALL ncio_read_bcast_serial (file_restart, 'rh_hgh ', rh_hgh ) + CALL ncio_read_bcast_serial (file_restart, 'bt_min ', bt_min ) + CALL ncio_read_bcast_serial (file_restart, 'bt_max ', bt_max ) + CALL ncio_read_bcast_serial (file_restart, 'pot_hmn_ign_counts_alpha', pot_hmn_ign_counts_alpha) + CALL ncio_read_bcast_serial (file_restart, 'g0_fire', g0_fire) + + CALL ncio_read_bcast_serial (file_restart, 'sf', sf) + CALL ncio_read_bcast_serial (file_restart, 'sf_no3', sf_no3) + +#ifdef RangeCheck + CALL check_BGCTimeInvariants () +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE READ_BGCTimeInvariants + + !--------------------------------------- + SUBROUTINE WRITE_BGCTimeInvariants (file_restart) + + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= + + USE MOD_Namelist, only: DEF_REST_CompressLevel + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local Variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'ndecomp_transitions',ndecomp_transitions) + + CALL ncio_write_vector (file_restart, 'rf_decomp ', 'soil' , nl_soil , & + 'ndecomp_transitions', ndecomp_transitions,'patch', landpatch, rf_decomp , compress) + CALL ncio_write_vector (file_restart, 'pathfrac_decomp', 'soil' , nl_soil , & + 'ndecomp_transitions', ndecomp_transitions,'patch', landpatch, pathfrac_decomp, compress) + ! CALL ncio_write_vector (file_restart, 'gdp_lf ', 'patch', landpatch, gdp_lf , compress) + ! CALL ncio_write_vector (file_restart, 'abm_lf ', 'patch', landpatch, abm_lf , compress) + ! CALL ncio_write_vector (file_restart, 'peatf_lf ', 'patch', landpatch, peatf_lf , compress) + CALL ncio_write_vector (file_restart, 'rice2pdt ', 'patch', landpatch, rice2pdt , compress) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + +#if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) + CALL ncio_create_file (file_restart) +#endif + CALL ncio_define_dimension(file_restart, 'ndecomp_transitions',ndecomp_transitions) + CALL ncio_define_dimension(file_restart, 'ndecomp_pools' ,ndecomp_pools) + CALL ncio_define_dimension(file_restart, 'nlitter_fire' ,2 ) + + ! bgc constants + CALL ncio_write_serial (file_restart, 'donor_pool ' , donor_pool , 'ndecomp_transitions') + CALL ncio_write_serial (file_restart, 'receiver_pool ' , receiver_pool , 'ndecomp_transitions') + CALL ncio_write_serial (file_restart, 'floating_cn_ratio', floating_cn_ratio, 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'initial_cn_ratio' , initial_cn_ratio , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'is_cwd ' , is_cwd , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'is_litter ' , is_litter , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'is_soil ' , is_soil , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'cmb_cmplt_fact ' , cmb_cmplt_fact , 'nlitter_fire' ) + + CALL ncio_write_serial (file_restart, 'i_met_lit ', i_met_lit ) + CALL ncio_write_serial (file_restart, 'i_cel_lit ', i_cel_lit ) + CALL ncio_write_serial (file_restart, 'i_lig_lit ', i_lig_lit ) + CALL ncio_write_serial (file_restart, 'i_cwd ', i_cwd ) + CALL ncio_write_serial (file_restart, 'i_soil1 ', i_soil1 ) + CALL ncio_write_serial (file_restart, 'i_soil2 ', i_soil2 ) + CALL ncio_write_serial (file_restart, 'i_soil3 ', i_soil3 ) + CALL ncio_write_serial (file_restart, 'i_atm ', i_atm ) + + + CALL ncio_write_serial (file_restart, 'nitrif_n2o_loss_frac', nitrif_n2o_loss_frac) + CALL ncio_write_serial (file_restart, 'dnp ', dnp )! + CALL ncio_write_serial (file_restart, 'bdnr ', bdnr )! + CALL ncio_write_serial (file_restart, 'compet_plant_no3 ', compet_plant_no3 )! + CALL ncio_write_serial (file_restart, 'compet_plant_nh4 ', compet_plant_nh4 )! + CALL ncio_write_serial (file_restart, 'compet_decomp_no3 ', compet_decomp_no3 )! + CALL ncio_write_serial (file_restart, 'compet_decomp_nh4 ', compet_decomp_nh4 )! + CALL ncio_write_serial (file_restart, 'compet_denit ', compet_denit )! + CALL ncio_write_serial (file_restart, 'compet_nit ', compet_nit )! + CALL ncio_write_serial (file_restart, 'surface_tension_water',surface_tension_water) + CALL ncio_write_serial (file_restart, 'rij_kro_a ', rij_kro_a ) + CALL ncio_write_serial (file_restart, 'rij_kro_alpha ', rij_kro_alpha ) + CALL ncio_write_serial (file_restart, 'rij_kro_beta ', rij_kro_beta ) + CALL ncio_write_serial (file_restart, 'rij_kro_gamma ', rij_kro_gamma ) + CALL ncio_write_serial (file_restart, 'rij_kro_delta ', rij_kro_delta ) + CALL ncio_write_serial (file_restart, 'nfix_timeconst ', nfix_timeconst ) + CALL ncio_write_serial (file_restart, 'organic_max ', organic_max ) + CALL ncio_write_serial (file_restart, 'd_con_g21 ', d_con_g21 ) + CALL ncio_write_serial (file_restart, 'd_con_g22 ', d_con_g22 ) + CALL ncio_write_serial (file_restart, 'd_con_w21 ', d_con_w21 ) + CALL ncio_write_serial (file_restart, 'd_con_w22 ', d_con_w22 ) + CALL ncio_write_serial (file_restart, 'd_con_w23 ', d_con_w23 ) + CALL ncio_write_serial (file_restart, 'denit_resp_coef ', denit_resp_coef ) + CALL ncio_write_serial (file_restart, 'denit_resp_exp ', denit_resp_exp ) + CALL ncio_write_serial (file_restart, 'denit_nitrate_coef ', denit_nitrate_coef ) + CALL ncio_write_serial (file_restart, 'denit_nitrate_exp ', denit_nitrate_exp )! + CALL ncio_write_serial (file_restart, 'k_nitr_max ', k_nitr_max )! + CALL ncio_write_serial (file_restart, 'Q10 ', Q10 )! + CALL ncio_write_serial (file_restart, 'froz_q10 ', froz_q10 )! + CALL ncio_write_serial (file_restart, 'tau_l1 ', tau_l1 )! + CALL ncio_write_serial (file_restart, 'tau_l2_l3 ', tau_l2_l3 )! + CALL ncio_write_serial (file_restart, 'tau_s1 ', tau_s1 )! + CALL ncio_write_serial (file_restart, 'tau_s2 ', tau_s2 )! + CALL ncio_write_serial (file_restart, 'tau_s3 ', tau_s3 )! + CALL ncio_write_serial (file_restart, 'tau_cwd ', tau_cwd ) + CALL ncio_write_serial (file_restart, 'lwtop ', lwtop ) + + CALL ncio_write_serial (file_restart, 'som_adv_flux ', som_adv_flux ) + CALL ncio_write_serial (file_restart, 'som_diffus ', som_diffus ) + CALL ncio_write_serial (file_restart, 'cryoturb_diffusion_k', cryoturb_diffusion_k) + CALL ncio_write_serial (file_restart, 'max_altdepth_cryoturbation', max_altdepth_cryoturbation) + CALL ncio_write_serial (file_restart, 'max_depth_cryoturb ', max_depth_cryoturb ) + + CALL ncio_write_serial (file_restart, 'am ', am ) + CALL ncio_write_serial (file_restart, 'br ', br ) + CALL ncio_write_serial (file_restart, 'br_root ', br_root ) + CALL ncio_write_serial (file_restart, 'fstor2tran ', fstor2tran ) + CALL ncio_write_serial (file_restart, 'ndays_on ', ndays_on ) + CALL ncio_write_serial (file_restart, 'ndays_off ', ndays_off ) + CALL ncio_write_serial (file_restart, 'crit_dayl ', crit_dayl ) + CALL ncio_write_serial (file_restart, 'crit_onset_fdd ', crit_onset_fdd ) + CALL ncio_write_serial (file_restart, 'crit_onset_swi ', crit_onset_swi ) + CALL ncio_write_serial (file_restart, 'crit_offset_fdd ', crit_offset_fdd ) + CALL ncio_write_serial (file_restart, 'crit_offset_swi ', crit_offset_swi ) + CALL ncio_write_serial (file_restart, 'soilpsi_on ', soilpsi_on ) + CALL ncio_write_serial (file_restart, 'soilpsi_off ', soilpsi_off ) + + CALL ncio_write_serial (file_restart, 'occur_hi_gdp_tree ', occur_hi_gdp_tree ) + CALL ncio_write_serial (file_restart, 'lfuel ', lfuel ) + CALL ncio_write_serial (file_restart, 'ufuel ', ufuel ) + CALL ncio_write_serial (file_restart, 'cropfire_a1 ', cropfire_a1 ) + CALL ncio_write_serial (file_restart, 'borealat ', borealat ) + CALL ncio_write_serial (file_restart, 'troplat ', troplat ) + CALL ncio_write_serial (file_restart, 'non_boreal_peatfire_c', non_boreal_peatfire_c) + CALL ncio_write_serial (file_restart, 'boreal_peatfire_c ', boreal_peatfire_c ) + CALL ncio_write_serial (file_restart, 'rh_low ', rh_low ) + CALL ncio_write_serial (file_restart, 'rh_hgh ', rh_hgh ) + CALL ncio_write_serial (file_restart, 'bt_min ', bt_min ) + CALL ncio_write_serial (file_restart, 'bt_max ', bt_max ) + CALL ncio_write_serial (file_restart, 'pot_hmn_ign_counts_alpha', pot_hmn_ign_counts_alpha) + CALL ncio_write_serial (file_restart, 'g0_fire', g0_fire) + + CALL ncio_write_serial (file_restart, 'sf', sf) + CALL ncio_write_serial (file_restart, 'sf_no3', sf_no3) + + ENDIF + + END SUBROUTINE WRITE_BGCTimeInvariants + + SUBROUTINE deallocate_BGCTimeInvariants () + + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + ! -------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------- + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + ! bgc variables + deallocate (donor_pool ) + deallocate (receiver_pool ) + deallocate (floating_cn_ratio) + deallocate (initial_cn_ratio ) + deallocate (rf_decomp ) + deallocate (pathfrac_decomp) + deallocate (is_cwd ) + deallocate (is_litter ) + deallocate (is_soil ) + deallocate (gdp_lf ) + deallocate (abm_lf ) + deallocate (peatf_lf ) + deallocate (cmb_cmplt_fact ) + deallocate (rice2pdt ) + + ENDIF + ENDIF + + END SUBROUTINE deallocate_BGCTimeInvariants + +#ifdef RangeCheck + !--------------------------------------- + SUBROUTINE check_BGCTimeInvariants () + + USE MOD_SPMD_Task + USE MOD_RangeCheck + + IMPLICIT NONE + + CALL check_vector_data ('rf_decomp ', rf_decomp ) + CALL check_vector_data ('pathfrac_decomp', pathfrac_decomp) + CALL check_vector_data ('gdp_lf ', gdp_lf ) + CALL check_vector_data ('abm_lf ', abm_lf ) + CALL check_vector_data ('peatf_lf ', peatf_lf ) + CALL check_vector_data ('rice2pdt ', rice2pdt ) + + END SUBROUTINE check_BGCTimeInvariants +#endif + +#endif +END MODULE MOD_BGC_Vars_TimeInvariants diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..2f97a68863 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 @@ -0,0 +1,1543 @@ +#include + +MODULE MOD_BGC_Vars_TimeVariables +#ifdef BGC +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical state variables at patch level. +! Read and write biogeochemical state variables at patch level from/to restart files. + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_TimeManager + IMPLICIT NONE + SAVE +!------------------------- BGC variables ------------------------------- + real(r8), allocatable :: decomp_cpools_vr (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil organic matter) carbon pools (gC m-3) + real(r8), allocatable :: decomp_cpools (:,:) ! soil decomposition (litter, cwd, soil) carbon pools (gC m-2) + real(r8), allocatable :: decomp_cpools_vr_Cap (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil organic matter) carbon Capacity (gC m-3) + real(r8), allocatable :: decomp_k (:,:,:) ! soil decomposition rate (s-1) + real(r8), allocatable :: ctrunc_vr (:,:) ! currently not used + real(r8), allocatable :: ctrunc_veg (:) ! currently not used + real(r8), allocatable :: ctrunc_soil (:) ! currently not used + + real(r8), allocatable :: t_scalar (:,:) ! vertical resolved: soil decomposition temperature scalars + real(r8), allocatable :: w_scalar (:,:) ! vertical resolved: soil decomposition water scalars + real(r8), allocatable :: o_scalar (:,:) ! vertical resolved: soil decomposition oxygen scalars + real(r8), allocatable :: depth_scalar (:,:) ! vertical resolved: soil decomposition depth scalars + +!Soil CN diffusion and advection + real(r8), allocatable :: som_adv_coef (:,:) ! vertical resolved: soil organic matter advective flux (m2 s-1) + real(r8), allocatable :: som_diffus_coef (:,:) ! vertical resolved: soil organic matter diffusion flux (m2 s-1) + +!Active Layer + real(r8), allocatable :: altmax (:) ! maximum annual depth of thaw (m) + real(r8), allocatable :: altmax_lastyear (:) ! previous year maximum annual depth of thaw (m) + integer , allocatable :: altmax_lastyear_indx (:) ! previous year maximum annual soil layer of thaw + + real(r8), allocatable :: totlitc (:) ! carbon balance diagnostics: total column litter carbon (gC m-2) + real(r8), allocatable :: totvegc (:) ! carbon balance diagnostics: total column vegetation carbon (gC m-2) + real(r8), allocatable :: totsomc (:) ! carbon balance diagnostics: total column soil organic matter carbon (gC m-2) + real(r8), allocatable :: totcwdc (:) ! carbon balance diagnostics: total column coarse woody debris carbon (gC m-2) + real(r8), allocatable :: totcolc (:) ! carbon balance diagnostics: total column carbon (veg, soil, litter, et al) (gC m-2) + real(r8), allocatable :: col_begcb (:) ! carbon balance diagnostics: column carbon, begin of time step (gC m-2) + real(r8), allocatable :: col_endcb (:) ! carbon balance diagnostics: column carbon, END of time step (gC m-2) + real(r8), allocatable :: col_vegbegcb (:) ! carbon balance diagnostics: column vegetation carbon, begin of time step (gC m-2) + real(r8), allocatable :: col_vegendcb (:) ! carbon balance diagnostics: column vegetation carbon, end of time step (gC m-2) + real(r8), allocatable :: col_soilbegcb (:) ! carbon balance diagnostics: column soil carbon, begin of time step (gC m-2) + real(r8), allocatable :: col_soilendcb (:) ! carbon balance diagnostics: column soil carbon, end of time step (gC m-2) + + real(r8), allocatable :: totlitn (:) ! nitrogen balance diagnostics: total column litter nitrogen (gN m-2) + real(r8), allocatable :: totvegn (:) ! nitrogen balance diagnostics: total column vegetation nitrogen (gN m-2) + real(r8), allocatable :: totsomn (:) ! nitrogen balance diagnostics: total column soil organic matter nitrogen (gN m-2) + real(r8), allocatable :: totcwdn (:) ! nitrogen balance diagnostics: total column coarse woody debris nitrogen (gN m-2) + real(r8), allocatable :: totcoln (:) ! nitrogen balance diagnostics: total column nitrogen (veg, soil, litter, et al) (gN m-2) + real(r8), allocatable :: col_begnb (:) ! nitrogen balance diagnostics: column nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_endnb (:) ! nitrogen balance diagnostics: column nitrogen, end of time step (gN m-2) + real(r8), allocatable :: col_vegbegnb (:) ! nitrogen balance diagnostics: column vegetation nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_vegendnb (:) ! nitrogen balance diagnostics: column vegetation nitrogen, end of time step (gN m-2) + real(r8), allocatable :: col_soilbegnb (:) ! nitrogen balance diagnostics: column soil organic nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_soilendnb (:) ! nitrogen balance diagnostics: column soil organic nitrogen, end of time step (gN m-2) + real(r8), allocatable :: col_sminnbegnb (:) ! nitrogen balance diagnostics: column soil mineral nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_sminnendnb (:) ! nitrogen balance diagnostics: column soil mineral nitrogen, end of time step (gN m-2) + + real(r8), allocatable :: leafc (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafc_storage (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafc_xfer (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootc (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootc_storage (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootc_xfer (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemc (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemc_storage (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemc_xfer (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemc (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc_storage (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc_xfer (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootc (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc_storage (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc_xfer (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootc (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc_storage (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc_xfer (:) ! dead coarse root transfer C (gC m-2) + real(r8), allocatable :: grainc (:) ! grain display C (gC m-2) + real(r8), allocatable :: grainc_storage (:) ! grain storage C (gC m-2) + real(r8), allocatable :: grainc_xfer (:) ! grain transfer C (gC m-2) + real(r8), allocatable :: xsmrpool (:) ! maintenance respiration storage C (gC m-2) + real(r8), allocatable :: downreg (:) ! fractional reduction in GPP due to N limitation + real(r8), allocatable :: cropprod1c (:) ! product C (gC m-2) + real(r8), allocatable :: cropseedc_deficit (:) ! crop seed deficit C (gC m-2) + + real(r8), allocatable :: leafn (:) ! leaf display N (gN m-2) + real(r8), allocatable :: leafn_storage (:) ! leaf storage N (gN m-2) + real(r8), allocatable :: leafn_xfer (:) ! leaf transfer N (gN m-2) + real(r8), allocatable :: frootn (:) ! fine root display N (gN m-2)d + real(r8), allocatable :: frootn_storage (:) ! fine root storage N (gN m-2)d + real(r8), allocatable :: frootn_xfer (:) ! fine root transfer N (gN m-2)d + real(r8), allocatable :: livestemn (:) ! live stem display N (gN m-2)d + real(r8), allocatable :: livestemn_storage (:) ! live stem storage N (gN m-2)d + real(r8), allocatable :: livestemn_xfer (:) ! live stem transfer N (gN m-2)d + real(r8), allocatable :: deadstemn (:) ! dead stem display N (gN m-2)d + real(r8), allocatable :: deadstemn_storage (:) ! dead stem storage N (gN m-2)d + real(r8), allocatable :: deadstemn_xfer (:) ! dead stem transfer N (gN m-2)d + real(r8), allocatable :: livecrootn (:) ! live coarse root display N (gN m-2) + real(r8), allocatable :: livecrootn_storage (:) ! live coarse root storage N (gN m-2) + real(r8), allocatable :: livecrootn_xfer (:) ! live coarse root transfer N (gN m-2) + real(r8), allocatable :: deadcrootn (:) ! dead coarse root display N (gN m-2) + real(r8), allocatable :: deadcrootn_storage (:) ! dead coarse root storage N (gN m-2) + real(r8), allocatable :: deadcrootn_xfer (:) ! dead coarse root transfer N (gN m-2) + real(r8), allocatable :: grainn (:) ! grain display N (gN m-2) + real(r8), allocatable :: grainn_storage (:) ! grain storage N (gN m-2) + real(r8), allocatable :: grainn_xfer (:) ! grain transfer N (gN m-2) + real(r8), allocatable :: retransn (:) ! retranslocated N (gN m-2) + + real(r8), allocatable :: leafcCap (:) ! leaf display C capacity (gC m-2) + real(r8), allocatable :: leafc_storageCap (:) ! leaf storage C capacity (gC m-2) + real(r8), allocatable :: leafc_xferCap (:) ! leaf transfer C capacity (gC m-2) + real(r8), allocatable :: frootcCap (:) ! fine root display C capacity (gC m-2) + real(r8), allocatable :: frootc_storageCap (:) ! fine root storage C capacity (gC m-2) + real(r8), allocatable :: frootc_xferCap (:) ! fine root transfer C capacity (gC m-2) + real(r8), allocatable :: livestemcCap (:) ! live stem display C capacity (gC m-2) + real(r8), allocatable :: livestemc_storageCap (:) ! live stem storage C capacity (gC m-2) + real(r8), allocatable :: livestemc_xferCap (:) ! live stem transfer C capacity (gC m-2) + real(r8), allocatable :: deadstemcCap (:) ! dead stem display C capacity (gC m-2) + real(r8), allocatable :: deadstemc_storageCap (:) ! dead stem storage C capacity (gC m-2) + real(r8), allocatable :: deadstemc_xferCap (:) ! dead stem transfer C capacity (gC m-2) + real(r8), allocatable :: livecrootcCap (:) ! live coarse root display C capacity (gC m-2) + real(r8), allocatable :: livecrootc_storageCap (:) ! live coarse root storage C capacity (gC m-2) + real(r8), allocatable :: livecrootc_xferCap (:) ! live coarse root transfer C capacity (gC m-2) + real(r8), allocatable :: deadcrootcCap (:) ! dead coarse root display C capacity (gC m-2) + real(r8), allocatable :: deadcrootc_storageCap (:) ! dead coarse root storage C capacity (gC m-2) + real(r8), allocatable :: deadcrootc_xferCap (:) ! dead coarse root transfer C capacity (gC m-2) + + real(r8), allocatable :: leafnCap (:) ! leaf display N capacity (gN m-2) + real(r8), allocatable :: leafn_storageCap (:) ! leaf storage N capacity (gN m-2) + real(r8), allocatable :: leafn_xferCap (:) ! leaf transfer N capacity (gN m-2) + real(r8), allocatable :: frootnCap (:) ! fine root display N capacity (gN m-2) + real(r8), allocatable :: frootn_storageCap (:) ! fine root storage N capacity (gN m-2) + real(r8), allocatable :: frootn_xferCap (:) ! fine root transfer N capacity (gN m-2) + real(r8), allocatable :: livestemnCap (:) ! live stem display N capacity (gN m-2) + real(r8), allocatable :: livestemn_storageCap (:) ! live stem storage N capacity (gN m-2) + real(r8), allocatable :: livestemn_xferCap (:) ! live stem transfer N capacity (gN m-2) + real(r8), allocatable :: deadstemnCap (:) ! dead stem display N capacity (gN m-2) + real(r8), allocatable :: deadstemn_storageCap (:) ! dead stem storage N capacity (gN m-2) + real(r8), allocatable :: deadstemn_xferCap (:) ! dead stem transfer N capacity (gN m-2) + real(r8), allocatable :: livecrootnCap (:) ! live coarse root display N capacity (gN m-2) + real(r8), allocatable :: livecrootn_storageCap (:) ! live coarse root storage N capacity (gN m-2) + real(r8), allocatable :: livecrootn_xferCap (:) ! live coarse root transfer N capacity (gN m-2) + real(r8), allocatable :: deadcrootnCap (:) ! dead coarse root display N capacity (gN m-2) + real(r8), allocatable :: deadcrootn_storageCap (:) ! dead coarse root storage N capacity (gN m-2) + real(r8), allocatable :: deadcrootn_xferCap (:) ! dead coarse root transfer N capacity (gN m-2) + + real(r8), allocatable :: decomp_npools_vr (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil) nitrogen (gN m-3) + real(r8), allocatable :: decomp_npools (:,:) ! soil decomposition (litter, cwd, soil) nitrogen (gN m-2) + real(r8), allocatable :: decomp_npools_vr_Cap (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil organic matter) carbon Capacity (gC m-3) + real(r8), allocatable :: totsoiln_vr (:,:) ! vertical resolved: total soil nitrogen (%: gN/gSoil*100) + real(r8), allocatable :: ntrunc_vr (:,:) ! currently not used + real(r8), allocatable :: ntrunc_veg (:) ! currently not used + real(r8), allocatable :: ntrunc_soil (:) ! currently not used + + real(r8), allocatable :: sminn_vr (:,:) ! vertical resolved: soil mineral nitrogen (gN m-3) + real(r8), allocatable :: smin_no3_vr (:,:) ! vertical resolved: soil mineral NO3 (gN m-3) + real(r8), allocatable :: smin_nh4_vr (:,:) ! vertical resolved: soil mineral NH4 (gN m-3) + real(r8), allocatable :: sminn (:) ! soil mineral nitrogen (gN m-2) + real(r8), allocatable :: ndep (:) ! atmospheric nitrogen deposition (gN m-2) + + real(r8), allocatable :: to2_decomp_depth_unsat (:,:) ! vertical resolved: O2 soil consumption from heterotrophic respiration and autotrophic respiration (mol m-3 s-1) + real(r8), allocatable :: tconc_o2_unsat (:,:) ! vertical resolved: O2 soil consumption (mol m-3 s-1) + + real(r8), allocatable :: ndep_prof (:,:) ! vertical resolved: atmospheric N deposition input to soil (m-1) + real(r8), allocatable :: nfixation_prof (:,:) ! vertical resolved: N fixation input to soil (m-1) + + real(r8), allocatable :: cn_decomp_pools (:,:,:) ! vertical resolved: c:n ratios of each decomposition pools + real(r8), allocatable :: fpi_vr (:,:) ! vertical resolved: actual immobilization N :potential immobilization N + real(r8), allocatable :: fpi (:) ! actual immobilization N : potential immobilization N + real(r8), allocatable :: fpg (:) ! actual plant uptake N : plant potential need N + + real(r8), allocatable :: cropf (:) ! + real(r8), allocatable :: lfwt (:) ! + real(r8), allocatable :: fuelc (:) ! + real(r8), allocatable :: fuelc_crop (:) ! + real(r8), allocatable :: fsr (:) ! + real(r8), allocatable :: fd (:) ! + real(r8), allocatable :: rootc (:) ! + real(r8), allocatable :: lgdp (:) ! + real(r8), allocatable :: lgdp1 (:) ! + real(r8), allocatable :: lpop (:) ! + real(r8), allocatable :: wtlf (:) ! + real(r8), allocatable :: trotr1 (:) ! + real(r8), allocatable :: trotr2 (:) ! + real(r8), allocatable :: hdm_lf (:) ! + real(r8), allocatable :: lnfm (:) ! + real(r8), allocatable :: baf_crop (:) ! + real(r8), allocatable :: baf_peatf (:) ! + real(r8), allocatable :: farea_burned (:) ! total fractional area burned (s-1) + real(r8), allocatable :: nfire (:) ! fire counts (count km-2 s-1) + real(r8), allocatable :: fsat (:) ! + real(r8), allocatable :: prec10 (:) ! 10-day running mean of total precipitation (mm -1) + real(r8), allocatable :: prec60 (:) ! 60-day running mean of total precipitation (mm -1) + real(r8), allocatable :: prec365 (:) ! 365-day running mean of tota l precipitation (mm -1) + real(r8), allocatable :: prec_today (:) ! today's daily precipitation (mm -1) + real(r8), allocatable :: prec_daily (:,:) ! daily total precipitation (mm -1) + real(r8), allocatable :: wf2 (:) ! soil moisture (K) + real(r8), allocatable :: tsoi17 (:) ! soil temperature (cm3 cm-3) + real(r8), allocatable :: rh30 (:) ! 30-day running mean of relative humidity (%) + real(r8), allocatable :: accumnstep (:) ! timestep accumulator + + real(r8), allocatable :: dayl (:) ! day length (s) + real(r8), allocatable :: prev_dayl (:) ! day length from previous day (s) + +!-------------BGC/SASU variables--------------------------- + real(r8), allocatable :: decomp0_cpools_vr (:,:,:) ! SASU spinup diagnostics vertical-resolved: soil decomposition (litter, cwd, soil organic matter) carbon pools (gC m-3) + real(r8), allocatable :: I_met_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to metabolic litter C (gC m-3) + real(r8), allocatable :: I_cel_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to cellulosic litter C (gC m-3) + real(r8), allocatable :: I_lig_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to lignin litter C (gC m-3) + real(r8), allocatable :: I_cwd_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to coarse woody debris C (gC m-3) + real(r8), allocatable :: AKX_met_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from metabolic litter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_cel_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from cellulosic litter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_lig_to_soil2_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from lignin litter C to slow soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil1_to_soil2_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter C to slow soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_cwd_to_cel_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris C to cellulosic litter C (gC m-3) + real(r8), allocatable :: AKX_cwd_to_lig_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris C to lignin litter C (gC m-3) + real(r8), allocatable :: AKX_soil1_to_soil3_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter C to passive soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil2_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil2_to_soil3_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter C to passive soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil3_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from passive soil organic matter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_met_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from metabolic litter C (gC m-3) + real(r8), allocatable :: AKX_cel_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from cellulosic litter C (gC m-3) + real(r8), allocatable :: AKX_lig_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from lignin litter C (gC m-3) + real(r8), allocatable :: AKX_cwd_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from coarse woody debris C (gC m-3) + real(r8), allocatable :: AKX_soil1_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil2_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from slow soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil3_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from passive soil organic matter C (gC m-3) + + real(r8), allocatable :: decomp0_npools_vr (:,:,:) ! SASU spinup diagnostics vertical-resolved: soil decomposition (litter, cwd, soil organic matter) carbon pools (gN m-3) + real(r8), allocatable :: I_met_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to metabolic litter N (gN m-3) + real(r8), allocatable :: I_cel_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to cellulosic litter N (gN m-3) + real(r8), allocatable :: I_lig_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to lignin litter N (gN m-3) + real(r8), allocatable :: I_cwd_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to coarse woody debris N (gN m-3) + real(r8), allocatable :: AKX_met_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from metabolic litter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_cel_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from cellulosic litter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_lig_to_soil2_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from lignin litter N to slow soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil1_to_soil2_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter N to slow soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_cwd_to_cel_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris N to cellulosic litter N (gN m-3) + real(r8), allocatable :: AKX_cwd_to_lig_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris N to lignin litter N (gN m-3) + real(r8), allocatable :: AKX_soil1_to_soil3_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter N to passive soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil2_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil2_to_soil3_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter N to passive soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil3_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from passive soil organic matter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_met_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from metabolic litter N (gN m-3) + real(r8), allocatable :: AKX_cel_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from cellulosic litter N (gN m-3) + real(r8), allocatable :: AKX_lig_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from lignin litter N (gN m-3) + real(r8), allocatable :: AKX_cwd_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from coarse woody debris N (gN m-3) + real(r8), allocatable :: AKX_soil1_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil2_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from slow soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil3_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from passive soil organic matter N (gN m-3) + + real(r8), allocatable :: diagVX_c_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated carbon EXIT flux due to the vertical mixing in soil and litter pools (gC m-3) + real(r8), allocatable :: upperVX_c_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated carbon upward flux due to the vertical mixing in soil and litter pools (gC m-3) + real(r8), allocatable :: lowerVX_c_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated carbon downward flux due to the vertical mixing in soil and litter pools (gC m-3) + real(r8), allocatable :: diagVX_n_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated nitrogen EXIT flux due to the vertical mixing in soil and litter pools (gN m-3) + real(r8), allocatable :: upperVX_n_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated nitrogen upward flux due to the vertical mixing in soil and litter pools (gN m-3) + real(r8), allocatable :: lowerVX_n_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated nitrogen downward flux due to the vertical mixing in soil and litter pools (gN m-3) + logical , allocatable :: skip_balance_check (:) ! When we estimate the steady state and update the actcual pool with steady state in SASU, the CN balance check is expected to fail. & + ! Skip the balance check at END of the year when SASU is on +#ifdef CROP + real(r8), allocatable :: cphase (:) ! crop phasecrop phase + real(r8), allocatable :: vf (:) ! vernalization response + real(r8), allocatable :: gddplant (:) ! gdd since planting (ddays) + real(r8), allocatable :: gddmaturity (:) ! gdd needed to harvest (ddays) + real(r8), allocatable :: hui (:) ! heat unit index + real(r8), allocatable :: huiswheat (:) ! heat unit index (rainfed spring wheat) + real(r8), allocatable :: pdcorn (:) ! planting date of corn + real(r8), allocatable :: pdswheat (:) ! planting date of spring wheat + real(r8), allocatable :: pdwwheat (:) ! planting date of winter wheat + real(r8), allocatable :: pdsoybean (:) ! planting date of soybean + real(r8), allocatable :: pdcotton (:) ! planting date of cotton + real(r8), allocatable :: pdrice1 (:) ! planting date of rice1 + real(r8), allocatable :: pdrice2 (:) ! planting date of rice2 + real(r8), allocatable :: pdsugarcane (:) ! planting date of sugarcane + real(r8), allocatable :: plantdate (:) ! planting date + real(r8), allocatable :: manunitro (:) ! nitrogen fertilizer for corn (gN m-2) + real(r8), allocatable :: fertnitro_corn (:) ! nitrogen fertilizer for corn (gN m-2) + real(r8), allocatable :: fertnitro_swheat (:) ! nitrogen fertilizer for spring wheat (gN m-2) + real(r8), allocatable :: fertnitro_wwheat (:) ! nitrogen fertilizer for winter wheat (gN m-2) + real(r8), allocatable :: fertnitro_soybean (:) ! nitrogen fertilizer for soybean (gN m-2) + real(r8), allocatable :: fertnitro_cotton (:) ! nitrogen fertilizer for cotton (gN m-2) + real(r8), allocatable :: fertnitro_rice1 (:) ! nitrogen fertilizer for rice1 (gN m-2) + real(r8), allocatable :: fertnitro_rice2 (:) ! nitrogen fertilizer for rice2 (gN m-2) + real(r8), allocatable :: fertnitro_sugarcane (:) ! nitrogen fertilizer for sugarcane (gN m-2) +#endif + real(r8), allocatable :: lag_npp (:) !!! lagged net primary production (gC m-2) +!------------------------------------------------------ + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_BGCTimeVariables + PUBLIC :: deallocate_BGCTimeVariables + PUBLIC :: READ_BGCTimeVariables + PUBLIC :: WRITE_BGCTimeVariables +#ifdef RangeCheck + PUBLIC :: check_BGCTimeVariables +#endif + +! PRIVATE MEMBER FUNCTIONS: + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_BGCTimeVariables +! -------------------------------------------------------------------- +! Allocates memory for CoLM 1d [numpatch] variables +! ------------------------------------------------------ + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + ! bgc variables + allocate (decomp_cpools_vr (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_cpools_vr (:,:,:) = spval + allocate (decomp_cpools (ndecomp_pools,numpatch)) ; decomp_cpools (:,:) = spval + allocate (decomp_cpools_vr_Cap (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_cpools_vr_Cap(:,:,:) = spval + allocate (ctrunc_vr (nl_soil,numpatch)) ; ctrunc_vr (:,:) = spval + allocate (ctrunc_veg (numpatch)) ; ctrunc_veg (:) = spval + allocate (ctrunc_soil (numpatch)) ; ctrunc_soil (:) = spval + allocate (decomp_k (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_k (:,:,:) = spval + + allocate (t_scalar (nl_soil,numpatch)) ; t_scalar (:,:) = spval + allocate (w_scalar (nl_soil,numpatch)) ; w_scalar (:,:) = spval + allocate (o_scalar (nl_soil,numpatch)) ; o_scalar (:,:) = spval + allocate (depth_scalar (nl_soil,numpatch)) ; depth_scalar (:,:) = spval + + allocate (som_adv_coef (nl_soil_full,numpatch)) ; som_adv_coef (:,:) = spval + allocate (som_diffus_coef (nl_soil_full,numpatch)) ; som_diffus_coef (:,:) = spval + + allocate (altmax (numpatch)) ; altmax (:) = spval + allocate (altmax_lastyear (numpatch)) ; altmax_lastyear (:) = spval + allocate (altmax_lastyear_indx (numpatch)) ; altmax_lastyear_indx (:) = spval_i4 + + allocate (totlitc (numpatch)) ; totlitc (:) = spval + allocate (totvegc (numpatch)) ; totvegc (:) = spval + allocate (totsomc (numpatch)) ; totsomc (:) = spval + allocate (totcwdc (numpatch)) ; totcwdc (:) = spval + allocate (totcolc (numpatch)) ; totcolc (:) = spval + allocate (col_begcb (numpatch)) ; col_begcb (:) = spval + allocate (col_endcb (numpatch)) ; col_endcb (:) = spval + allocate (col_vegbegcb (numpatch)) ; col_vegbegcb (:) = spval + allocate (col_vegendcb (numpatch)) ; col_vegendcb (:) = spval + allocate (col_soilbegcb (numpatch)) ; col_soilbegcb (:) = spval + allocate (col_soilendcb (numpatch)) ; col_soilendcb (:) = spval + + allocate (totlitn (numpatch)) ; totlitn (:) = spval + allocate (totvegn (numpatch)) ; totvegn (:) = spval + allocate (totsomn (numpatch)) ; totsomn (:) = spval + allocate (totcwdn (numpatch)) ; totcwdn (:) = spval + allocate (totcoln (numpatch)) ; totcoln (:) = spval + allocate (col_begnb (numpatch)) ; col_begnb (:) = spval + allocate (col_endnb (numpatch)) ; col_endnb (:) = spval + allocate (col_vegbegnb (numpatch)) ; col_vegbegnb (:) = spval + allocate (col_vegendnb (numpatch)) ; col_vegendnb (:) = spval + allocate (col_soilbegnb (numpatch)) ; col_soilbegnb (:) = spval + allocate (col_soilendnb (numpatch)) ; col_soilendnb (:) = spval + allocate (col_sminnbegnb (numpatch)) ; col_sminnbegnb (:) = spval + allocate (col_sminnendnb (numpatch)) ; col_sminnendnb (:) = spval + + allocate (leafc (numpatch)) ; leafc (:) = spval + allocate (leafc_storage (numpatch)) ; leafc_storage (:) = spval + allocate (leafc_xfer (numpatch)) ; leafc_xfer (:) = spval + allocate (frootc (numpatch)) ; frootc (:) = spval + allocate (frootc_storage (numpatch)) ; frootc_storage (:) = spval + allocate (frootc_xfer (numpatch)) ; frootc_xfer (:) = spval + allocate (livestemc (numpatch)) ; livestemc (:) = spval + allocate (livestemc_storage (numpatch)) ; livestemc_storage (:) = spval + allocate (livestemc_xfer (numpatch)) ; livestemc_xfer (:) = spval + allocate (deadstemc (numpatch)) ; deadstemc (:) = spval + allocate (deadstemc_storage (numpatch)) ; deadstemc_storage (:) = spval + allocate (deadstemc_xfer (numpatch)) ; deadstemc_xfer (:) = spval + allocate (livecrootc (numpatch)) ; livecrootc (:) = spval + allocate (livecrootc_storage (numpatch)) ; livecrootc_storage (:) = spval + allocate (livecrootc_xfer (numpatch)) ; livecrootc_xfer (:) = spval + allocate (deadcrootc (numpatch)) ; deadcrootc (:) = spval + allocate (deadcrootc_storage (numpatch)) ; deadcrootc_storage (:) = spval + allocate (deadcrootc_xfer (numpatch)) ; deadcrootc_xfer (:) = spval + allocate (grainc (numpatch)) ; grainc (:) = spval + allocate (grainc_storage (numpatch)) ; grainc_storage (:) = spval + allocate (grainc_xfer (numpatch)) ; grainc_xfer (:) = spval + allocate (xsmrpool (numpatch)) ; xsmrpool (:) = spval + allocate (downreg (numpatch)) ; downreg (:) = spval + allocate (cropprod1c (numpatch)) ; cropprod1c (:) = spval + allocate (cropseedc_deficit (numpatch)) ; cropseedc_deficit (:) = spval + + allocate (leafn (numpatch)) ; leafn (:) = spval + allocate (leafn_storage (numpatch)) ; leafn_storage (:) = spval + allocate (leafn_xfer (numpatch)) ; leafn_xfer (:) = spval + allocate (frootn (numpatch)) ; frootn (:) = spval + allocate (frootn_storage (numpatch)) ; frootn_storage (:) = spval + allocate (frootn_xfer (numpatch)) ; frootn_xfer (:) = spval + allocate (livestemn (numpatch)) ; livestemn (:) = spval + allocate (livestemn_storage (numpatch)) ; livestemn_storage (:) = spval + allocate (livestemn_xfer (numpatch)) ; livestemn_xfer (:) = spval + allocate (deadstemn (numpatch)) ; deadstemn (:) = spval + allocate (deadstemn_storage (numpatch)) ; deadstemn_storage (:) = spval + allocate (deadstemn_xfer (numpatch)) ; deadstemn_xfer (:) = spval + allocate (livecrootn (numpatch)) ; livecrootn (:) = spval + allocate (livecrootn_storage (numpatch)) ; livecrootn_storage (:) = spval + allocate (livecrootn_xfer (numpatch)) ; livecrootn_xfer (:) = spval + allocate (deadcrootn (numpatch)) ; deadcrootn (:) = spval + allocate (deadcrootn_storage (numpatch)) ; deadcrootn_storage (:) = spval + allocate (deadcrootn_xfer (numpatch)) ; deadcrootn_xfer (:) = spval + allocate (grainn (numpatch)) ; grainn (:) = spval + allocate (grainn_storage (numpatch)) ; grainn_storage (:) = spval + allocate (grainn_xfer (numpatch)) ; grainn_xfer (:) = spval + allocate (retransn (numpatch)) ; retransn (:) = spval + + allocate (leafcCap (numpatch)) ; leafcCap (:) = spval + allocate (leafc_storageCap (numpatch)) ; leafc_storageCap (:) = spval + allocate (leafc_xferCap (numpatch)) ; leafc_xferCap (:) = spval + allocate (frootcCap (numpatch)) ; frootcCap (:) = spval + allocate (frootc_storageCap (numpatch)) ; frootc_storageCap (:) = spval + allocate (frootc_xferCap (numpatch)) ; frootc_xferCap (:) = spval + allocate (livestemcCap (numpatch)) ; livestemcCap (:) = spval + allocate (livestemc_storageCap (numpatch)) ; livestemc_storageCap (:) = spval + allocate (livestemc_xferCap (numpatch)) ; livestemc_xferCap (:) = spval + allocate (deadstemcCap (numpatch)) ; deadstemcCap (:) = spval + allocate (deadstemc_storageCap (numpatch)) ; deadstemc_storageCap (:) = spval + allocate (deadstemc_xferCap (numpatch)) ; deadstemc_xferCap (:) = spval + allocate (livecrootcCap (numpatch)) ; livecrootcCap (:) = spval + allocate (livecrootc_storageCap (numpatch)) ; livecrootc_storageCap (:) = spval + allocate (livecrootc_xferCap (numpatch)) ; livecrootc_xferCap (:) = spval + allocate (deadcrootcCap (numpatch)) ; deadcrootcCap (:) = spval + allocate (deadcrootc_storageCap (numpatch)) ; deadcrootc_storageCap (:) = spval + allocate (deadcrootc_xferCap (numpatch)) ; deadcrootc_xferCap (:) = spval + + allocate (leafnCap (numpatch)) ; leafnCap (:) = spval + allocate (leafn_storageCap (numpatch)) ; leafn_storageCap (:) = spval + allocate (leafn_xferCap (numpatch)) ; leafn_xferCap (:) = spval + allocate (frootnCap (numpatch)) ; frootnCap (:) = spval + allocate (frootn_storageCap (numpatch)) ; frootn_storageCap (:) = spval + allocate (frootn_xferCap (numpatch)) ; frootn_xferCap (:) = spval + allocate (livestemnCap (numpatch)) ; livestemnCap (:) = spval + allocate (livestemn_storageCap (numpatch)) ; livestemn_storageCap (:) = spval + allocate (livestemn_xferCap (numpatch)) ; livestemn_xferCap (:) = spval + allocate (deadstemnCap (numpatch)) ; deadstemnCap (:) = spval + allocate (deadstemn_storageCap (numpatch)) ; deadstemn_storageCap (:) = spval + allocate (deadstemn_xferCap (numpatch)) ; deadstemn_xferCap (:) = spval + allocate (livecrootnCap (numpatch)) ; livecrootnCap (:) = spval + allocate (livecrootn_storageCap (numpatch)) ; livecrootn_storageCap (:) = spval + allocate (livecrootn_xferCap (numpatch)) ; livecrootn_xferCap (:) = spval + allocate (deadcrootnCap (numpatch)) ; deadcrootnCap (:) = spval + allocate (deadcrootn_storageCap (numpatch)) ; deadcrootn_storageCap (:) = spval + allocate (deadcrootn_xferCap (numpatch)) ; deadcrootn_xferCap (:) = spval + + allocate (decomp_npools_vr (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_npools_vr (:,:,:) = spval + allocate (decomp_npools (ndecomp_pools,numpatch)) ; decomp_npools (:,:) = spval + allocate (decomp_npools_vr_Cap (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_npools_vr_Cap(:,:,:) = spval + allocate (totsoiln_vr (nl_soil,numpatch)) ; totsoiln_vr (:,:) = spval + allocate (ntrunc_vr (nl_soil,numpatch)) ; ntrunc_vr (:,:) = spval + allocate (ntrunc_veg (numpatch)) ; ntrunc_veg (:) = spval + allocate (ntrunc_soil (numpatch)) ; ntrunc_soil (:) = spval + allocate (sminn_vr (nl_soil,numpatch)) ; sminn_vr (:,:) = spval + allocate (smin_no3_vr (nl_soil,numpatch)) ; smin_no3_vr (:,:) = spval + allocate (smin_nh4_vr (nl_soil,numpatch)) ; smin_nh4_vr (:,:) = spval + allocate (sminn (numpatch)) ; sminn (:) = spval + allocate (ndep (numpatch)) ; ndep (:) = spval + + allocate (to2_decomp_depth_unsat (nl_soil,numpatch)) ; to2_decomp_depth_unsat (:,:) = spval + allocate (tconc_o2_unsat (nl_soil,numpatch)) ; tconc_o2_unsat (:,:) = spval + + allocate (ndep_prof (nl_soil,numpatch)) ; ndep_prof (:,:) = spval + allocate (nfixation_prof (nl_soil,numpatch)) ; nfixation_prof (:,:) = spval + + allocate (cn_decomp_pools (nl_soil,ndecomp_pools,numpatch)) ; cn_decomp_pools (:,:,:) = spval + allocate (fpi_vr (nl_soil,numpatch)) ; fpi_vr (:,:) = spval + allocate (fpi (numpatch)) ; fpi (:) = spval + allocate (fpg (numpatch)) ; fpg (:) = spval + + allocate (cropf (numpatch)) ; cropf (:) = spval + allocate (lfwt (numpatch)) ; lfwt (:) = spval + allocate (fuelc (numpatch)) ; fuelc (:) = spval + allocate (fuelc_crop (numpatch)) ; fuelc_crop (:) = spval + allocate (fsr (numpatch)) ; fsr (:) = spval + allocate (fd (numpatch)) ; fd (:) = spval + allocate (rootc (numpatch)) ; rootc (:) = spval + allocate (lgdp (numpatch)) ; lgdp (:) = spval + allocate (lgdp1 (numpatch)) ; lgdp1 (:) = spval + allocate (lpop (numpatch)) ; lpop (:) = spval + allocate (wtlf (numpatch)) ; wtlf (:) = spval + allocate (trotr1 (numpatch)) ; trotr1 (:) = spval + allocate (trotr2 (numpatch)) ; trotr2 (:) = spval + allocate (hdm_lf (numpatch)) ; hdm_lf (:) = spval + allocate (lnfm (numpatch)) ; lnfm (:) = spval + allocate (baf_crop (numpatch)) ; baf_crop (:) = spval + allocate (baf_peatf (numpatch)) ; baf_peatf (:) = spval + allocate (farea_burned (numpatch)) ; farea_burned (:) = spval + allocate (nfire (numpatch)) ; nfire (:) = spval + allocate (fsat (numpatch)) ; fsat (:) = spval + allocate (prec10 (numpatch)) ; prec10 (:) = spval + allocate (prec60 (numpatch)) ; prec60 (:) = spval + allocate (prec365 (numpatch)) ; prec365 (:) = spval + allocate (prec_today (numpatch)) ; prec_today (:) = spval + allocate (prec_daily (365,numpatch)) ; prec_daily (:,:) = spval! daily total precipitation [mm/day] + allocate (wf2 (numpatch)) ; wf2 (:) = spval + allocate (tsoi17 (numpatch)) ; tsoi17 (:) = spval + allocate (rh30 (numpatch)) ; rh30 (:) = spval + allocate (accumnstep (numpatch)) ; accumnstep (:) = spval + ; + allocate (dayl (numpatch)) ; dayl (:) = spval + allocate (prev_dayl (numpatch)) ; prev_dayl (:) = spval + + !---------------------------SASU variables-------------------------------------- + allocate (decomp0_cpools_vr (nl_soil,ndecomp_pools,numpatch)) ; decomp0_cpools_vr (:,:,:) = spval + allocate (I_met_c_vr_acc (nl_soil,numpatch)) ; I_met_c_vr_acc (:,:) = spval + allocate (I_cel_c_vr_acc (nl_soil,numpatch)) ; I_cel_c_vr_acc (:,:) = spval + allocate (I_lig_c_vr_acc (nl_soil,numpatch)) ; I_lig_c_vr_acc (:,:) = spval + allocate (I_cwd_c_vr_acc (nl_soil,numpatch)) ; I_cwd_c_vr_acc (:,:) = spval + allocate (AKX_met_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_met_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_cel_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_cel_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_lig_to_soil2_c_vr_acc (nl_soil,numpatch)) ; AKX_lig_to_soil2_c_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil2_c_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil2_c_vr_acc (:,:) = spval + allocate (AKX_cwd_to_cel_c_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_cel_c_vr_acc (:,:) = spval + allocate (AKX_cwd_to_lig_c_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_lig_c_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil3_c_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil3_c_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil3_c_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil3_c_vr_acc (:,:) = spval + allocate (AKX_soil3_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_soil3_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_met_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_met_exit_c_vr_acc (:,:) = spval + allocate (AKX_cel_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_cel_exit_c_vr_acc (:,:) = spval + allocate (AKX_lig_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_lig_exit_c_vr_acc (:,:) = spval + allocate (AKX_cwd_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_cwd_exit_c_vr_acc (:,:) = spval + allocate (AKX_soil1_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_soil1_exit_c_vr_acc (:,:) = spval + allocate (AKX_soil2_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_soil2_exit_c_vr_acc (:,:) = spval + allocate (AKX_soil3_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_soil3_exit_c_vr_acc (:,:) = spval + + allocate (decomp0_npools_vr (nl_soil,ndecomp_pools,numpatch)) ; decomp0_npools_vr (:,:,:) = spval + allocate (I_met_n_vr_acc (nl_soil,numpatch)) ; I_met_n_vr_acc (:,:) = spval + allocate (I_cel_n_vr_acc (nl_soil,numpatch)) ; I_cel_n_vr_acc (:,:) = spval + allocate (I_lig_n_vr_acc (nl_soil,numpatch)) ; I_lig_n_vr_acc (:,:) = spval + allocate (I_cwd_n_vr_acc (nl_soil,numpatch)) ; I_cwd_n_vr_acc (:,:) = spval + allocate (AKX_met_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_met_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_cel_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_cel_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_lig_to_soil2_n_vr_acc (nl_soil,numpatch)) ; AKX_lig_to_soil2_n_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil2_n_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil2_n_vr_acc (:,:) = spval + allocate (AKX_cwd_to_cel_n_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_cel_n_vr_acc (:,:) = spval + allocate (AKX_cwd_to_lig_n_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_lig_n_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil3_n_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil3_n_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil3_n_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil3_n_vr_acc (:,:) = spval + allocate (AKX_soil3_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_soil3_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_met_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_met_exit_n_vr_acc (:,:) = spval + allocate (AKX_cel_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_cel_exit_n_vr_acc (:,:) = spval + allocate (AKX_lig_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_lig_exit_n_vr_acc (:,:) = spval + allocate (AKX_cwd_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_cwd_exit_n_vr_acc (:,:) = spval + allocate (AKX_soil1_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_soil1_exit_n_vr_acc (:,:) = spval + allocate (AKX_soil2_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_soil2_exit_n_vr_acc (:,:) = spval + allocate (AKX_soil3_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_soil3_exit_n_vr_acc (:,:) = spval + + allocate (diagVX_c_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; diagVX_c_vr_acc (:,:,:) = spval + allocate (upperVX_c_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; upperVX_c_vr_acc (:,:,:) = spval + allocate (lowerVX_c_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; lowerVX_c_vr_acc (:,:,:) = spval + allocate (diagVX_n_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; diagVX_n_vr_acc (:,:,:) = spval + allocate (upperVX_n_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; upperVX_n_vr_acc (:,:,:) = spval + allocate (lowerVX_n_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; lowerVX_n_vr_acc (:,:,:) = spval + + !--------------------------------------------------------------------------- + allocate (skip_balance_check (numpatch)) ; skip_balance_check (:) = .false. + +#ifdef CROP + allocate (cphase (numpatch)) ; cphase (:) = spval ! 30-day running mean of relative humidity + allocate (vf (numpatch)) ; vf (:) = spval + allocate (gddmaturity (numpatch)) ; gddmaturity (:) = spval + allocate (gddplant (numpatch)) ; gddplant (:) = spval + allocate (hui (numpatch)) ; hui (:) = spval + allocate (huiswheat (numpatch)) ; huiswheat (:) = spval + allocate (pdcorn (numpatch)) ; pdcorn (:) = spval + allocate (pdswheat (numpatch)) ; pdswheat (:) = spval + allocate (pdwwheat (numpatch)) ; pdwwheat (:) = spval + allocate (pdsoybean (numpatch)) ; pdsoybean (:) = spval + allocate (pdcotton (numpatch)) ; pdcotton (:) = spval + allocate (pdrice1 (numpatch)) ; pdrice1 (:) = spval + allocate (pdrice2 (numpatch)) ; pdrice2 (:) = spval + allocate (plantdate (numpatch)) ; plantdate (:) = spval + allocate (pdsugarcane (numpatch)) ; pdsugarcane (:) = spval + allocate (manunitro (numpatch)) ; manunitro (:) = spval + allocate (fertnitro_corn (numpatch)) ; fertnitro_corn (:) = spval + allocate (fertnitro_swheat (numpatch)) ; fertnitro_swheat (:) = spval + allocate (fertnitro_wwheat (numpatch)) ; fertnitro_wwheat (:) = spval + allocate (fertnitro_soybean (numpatch)) ; fertnitro_soybean (:) = spval + allocate (fertnitro_cotton (numpatch)) ; fertnitro_cotton (:) = spval + allocate (fertnitro_rice1 (numpatch)) ; fertnitro_rice1 (:) = spval + allocate (fertnitro_rice2 (numpatch)) ; fertnitro_rice2 (:) = spval + allocate (fertnitro_sugarcane (numpatch)) ; fertnitro_sugarcane (:) = spval +#endif + allocate (lag_npp (numpatch)) ; lag_npp (:) = spval + ENDIF + ENDIF + + + END SUBROUTINE allocate_BGCTimeVariables + + + SUBROUTINE deallocate_BGCTimeVariables () + + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + +! -------------------------------------------------- +! Deallocates memory for CoLM 1d [numpatch] variables +! -------------------------------------------------- + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + ! bgc variables + deallocate (decomp_cpools_vr ) + deallocate (decomp_cpools ) + deallocate (decomp_cpools_vr_Cap ) + deallocate (ctrunc_vr ) + deallocate (ctrunc_veg ) + deallocate (ctrunc_soil ) + deallocate (decomp_k ) + + deallocate (t_scalar ) + deallocate (w_scalar ) + deallocate (o_scalar ) + deallocate (depth_scalar ) + + deallocate (som_adv_coef ) + deallocate (som_diffus_coef ) + + deallocate (altmax ) + deallocate (altmax_lastyear ) + deallocate (altmax_lastyear_indx ) + + deallocate (totlitc ) + deallocate (totvegc ) + deallocate (totsomc ) + deallocate (totcwdc ) + deallocate (totcolc ) + deallocate (col_begcb ) + deallocate (col_endcb ) + deallocate (col_vegbegcb ) + deallocate (col_vegendcb ) + deallocate (col_soilbegcb ) + deallocate (col_soilendcb ) + + deallocate (totlitn ) + deallocate (totvegn ) + deallocate (totsomn ) + deallocate (totcwdn ) + deallocate (totcoln ) + deallocate (col_begnb ) + deallocate (col_endnb ) + deallocate (col_vegbegnb ) + deallocate (col_vegendnb ) + deallocate (col_soilbegnb ) + deallocate (col_soilendnb ) + deallocate (col_sminnbegnb ) + deallocate (col_sminnendnb ) + + deallocate (leafc ) + deallocate (leafc_storage ) + deallocate (leafc_xfer ) + deallocate (frootc ) + deallocate (frootc_storage ) + deallocate (frootc_xfer ) + deallocate (livestemc ) + deallocate (livestemc_storage ) + deallocate (livestemc_xfer ) + deallocate (deadstemc ) + deallocate (deadstemc_storage ) + deallocate (deadstemc_xfer ) + deallocate (livecrootc ) + deallocate (livecrootc_storage ) + deallocate (livecrootc_xfer ) + deallocate (deadcrootc ) + deallocate (deadcrootc_storage ) + deallocate (deadcrootc_xfer ) + deallocate (grainc ) + deallocate (grainc_storage ) + deallocate (grainc_xfer ) + deallocate (xsmrpool ) + deallocate (downreg ) + deallocate (cropprod1c ) + deallocate (cropseedc_deficit ) + + deallocate (leafn ) + deallocate (leafn_storage ) + deallocate (leafn_xfer ) + deallocate (frootn ) + deallocate (frootn_storage ) + deallocate (frootn_xfer ) + deallocate (livestemn ) + deallocate (livestemn_storage ) + deallocate (livestemn_xfer ) + deallocate (deadstemn ) + deallocate (deadstemn_storage ) + deallocate (deadstemn_xfer ) + deallocate (livecrootn ) + deallocate (livecrootn_storage ) + deallocate (livecrootn_xfer ) + deallocate (deadcrootn ) + deallocate (deadcrootn_storage ) + deallocate (deadcrootn_xfer ) + deallocate (grainn ) + deallocate (grainn_storage ) + deallocate (grainn_xfer ) + deallocate (retransn ) + + deallocate (leafcCap ) + deallocate (leafc_storageCap ) + deallocate (leafc_xferCap ) + deallocate (frootcCap ) + deallocate (frootc_storageCap ) + deallocate (frootc_xferCap ) + deallocate (livestemcCap ) + deallocate (livestemc_storageCap ) + deallocate (livestemc_xferCap ) + deallocate (deadstemcCap ) + deallocate (deadstemc_storageCap ) + deallocate (deadstemc_xferCap ) + deallocate (livecrootcCap ) + deallocate (livecrootc_storageCap ) + deallocate (livecrootc_xferCap ) + deallocate (deadcrootcCap ) + deallocate (deadcrootc_storageCap ) + deallocate (deadcrootc_xferCap ) + + deallocate (leafnCap ) + deallocate (leafn_storageCap ) + deallocate (leafn_xferCap ) + deallocate (frootnCap ) + deallocate (frootn_storageCap ) + deallocate (frootn_xferCap ) + deallocate (livestemnCap ) + deallocate (livestemn_storageCap ) + deallocate (livestemn_xferCap ) + deallocate (deadstemnCap ) + deallocate (deadstemn_storageCap ) + deallocate (deadstemn_xferCap ) + deallocate (livecrootnCap ) + deallocate (livecrootn_storageCap ) + deallocate (livecrootn_xferCap ) + deallocate (deadcrootnCap ) + deallocate (deadcrootn_storageCap ) + deallocate (deadcrootn_xferCap ) + + deallocate (decomp_npools_vr ) + deallocate (decomp_npools ) + deallocate (decomp_npools_vr_Cap ) + deallocate (totsoiln_vr ) + deallocate (ntrunc_vr ) + deallocate (ntrunc_veg ) + deallocate (ntrunc_soil ) + deallocate (sminn_vr ) + deallocate (smin_no3_vr ) + deallocate (smin_nh4_vr ) + deallocate (sminn ) + deallocate (ndep ) + + deallocate (to2_decomp_depth_unsat ) + deallocate (tconc_o2_unsat ) + + deallocate (ndep_prof ) + deallocate (nfixation_prof ) + + deallocate (cn_decomp_pools ) + deallocate (fpi_vr ) + deallocate (fpi ) + deallocate (fpg ) + + deallocate (cropf ) + deallocate (lfwt ) + deallocate (fuelc ) + deallocate (fuelc_crop ) + deallocate (fsr ) + deallocate (fd ) + deallocate (rootc ) + deallocate (lgdp ) + deallocate (lgdp1 ) + deallocate (lpop ) + deallocate (wtlf ) + deallocate (trotr1 ) + deallocate (trotr2 ) + deallocate (hdm_lf ) + deallocate (lnfm ) + deallocate (baf_crop ) + deallocate (baf_peatf ) + deallocate (farea_burned ) + deallocate (nfire ) + deallocate (fsat ) + deallocate (prec10 ) + deallocate (prec60 ) + deallocate (prec365 ) + deallocate (prec_today ) + deallocate (prec_daily ) + deallocate (wf2 ) + deallocate (tsoi17 ) + deallocate (rh30 ) + deallocate (accumnstep ) + + deallocate (dayl ) + deallocate (prev_dayl ) + + !---------------------------SASU variables-------------------------------------- + deallocate (decomp0_cpools_vr ) + deallocate (I_met_c_vr_acc ) + deallocate (I_cel_c_vr_acc ) + deallocate (I_lig_c_vr_acc ) + deallocate (I_cwd_c_vr_acc ) + deallocate (AKX_met_to_soil1_c_vr_acc ) + deallocate (AKX_cel_to_soil1_c_vr_acc ) + deallocate (AKX_lig_to_soil2_c_vr_acc ) + deallocate (AKX_soil1_to_soil2_c_vr_acc ) + deallocate (AKX_cwd_to_cel_c_vr_acc ) + deallocate (AKX_cwd_to_lig_c_vr_acc ) + deallocate (AKX_soil1_to_soil3_c_vr_acc ) + deallocate (AKX_soil2_to_soil1_c_vr_acc ) + deallocate (AKX_soil2_to_soil3_c_vr_acc ) + deallocate (AKX_soil3_to_soil1_c_vr_acc ) + deallocate (AKX_met_exit_c_vr_acc ) + deallocate (AKX_cel_exit_c_vr_acc ) + deallocate (AKX_lig_exit_c_vr_acc ) + deallocate (AKX_cwd_exit_c_vr_acc ) + deallocate (AKX_soil1_exit_c_vr_acc ) + deallocate (AKX_soil2_exit_c_vr_acc ) + deallocate (AKX_soil3_exit_c_vr_acc ) + + deallocate (decomp0_npools_vr ) + deallocate (I_met_n_vr_acc ) + deallocate (I_cel_n_vr_acc ) + deallocate (I_lig_n_vr_acc ) + deallocate (I_cwd_n_vr_acc ) + deallocate (AKX_met_to_soil1_n_vr_acc ) + deallocate (AKX_cel_to_soil1_n_vr_acc ) + deallocate (AKX_lig_to_soil2_n_vr_acc ) + deallocate (AKX_soil1_to_soil2_n_vr_acc ) + deallocate (AKX_cwd_to_cel_n_vr_acc ) + deallocate (AKX_cwd_to_lig_n_vr_acc ) + deallocate (AKX_soil1_to_soil3_n_vr_acc ) + deallocate (AKX_soil2_to_soil1_n_vr_acc ) + deallocate (AKX_soil2_to_soil3_n_vr_acc ) + deallocate (AKX_soil3_to_soil1_n_vr_acc ) + deallocate (AKX_met_exit_n_vr_acc ) + deallocate (AKX_cel_exit_n_vr_acc ) + deallocate (AKX_lig_exit_n_vr_acc ) + deallocate (AKX_cwd_exit_n_vr_acc ) + deallocate (AKX_soil1_exit_n_vr_acc ) + deallocate (AKX_soil2_exit_n_vr_acc ) + deallocate (AKX_soil3_exit_n_vr_acc ) + + deallocate (diagVX_c_vr_acc ) + deallocate (upperVX_c_vr_acc ) + deallocate (lowerVX_c_vr_acc ) + deallocate (diagVX_n_vr_acc ) + deallocate (upperVX_n_vr_acc ) + deallocate (lowerVX_n_vr_acc ) + + !--------------------------------------------------------------------------- + deallocate (skip_balance_check ) +#ifdef CROP + deallocate (cphase ) + deallocate (vf ) + deallocate (gddplant ) + deallocate (gddmaturity) + deallocate (hui ) + deallocate (huiswheat ) + deallocate (pdcorn ) + deallocate (pdswheat ) + deallocate (pdwwheat ) + deallocate (pdsoybean ) + deallocate (pdcotton ) + deallocate (pdrice1 ) + deallocate (pdrice2 ) + deallocate (plantdate ) + deallocate (pdsugarcane) + deallocate (manunitro ) + deallocate (fertnitro_corn ) + deallocate (fertnitro_swheat ) + deallocate (fertnitro_wwheat ) + deallocate (fertnitro_soybean ) + deallocate (fertnitro_cotton ) + deallocate (fertnitro_rice1 ) + deallocate (fertnitro_rice2 ) + deallocate (fertnitro_sugarcane) +#endif + deallocate (lag_npp ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_BGCTimeVariables + + + !--------------------------------------- + SUBROUTINE WRITE_BGCTimeVariables (file_restart) + +!======================================================================= +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +!======================================================================= + + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_NITRIF + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil_full', nl_soil_full) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'ndecomp_pools', ndecomp_pools) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'doy' , 365) + + ! bgc variables + CALL ncio_write_vector (file_restart, 'totlitc ', 'patch', landpatch, totlitc ) + CALL ncio_write_vector (file_restart, 'totvegc ', 'patch', landpatch, totvegc ) + CALL ncio_write_vector (file_restart, 'totsomc ', 'patch', landpatch, totsomc ) + CALL ncio_write_vector (file_restart, 'totcwdc ', 'patch', landpatch, totcwdc ) + CALL ncio_write_vector (file_restart, 'totcolc ', 'patch', landpatch, totcolc ) + CALL ncio_write_vector (file_restart, 'totlitn ', 'patch', landpatch, totlitn ) + CALL ncio_write_vector (file_restart, 'totvegn ', 'patch', landpatch, totvegn ) + CALL ncio_write_vector (file_restart, 'totsomn ', 'patch', landpatch, totsomn ) + CALL ncio_write_vector (file_restart, 'totcwdn ', 'patch', landpatch, totcwdn ) + CALL ncio_write_vector (file_restart, 'totcoln ', 'patch', landpatch, totcoln ) + + CALL ncio_write_vector (file_restart, 'sminn ', 'patch', landpatch, sminn ) + CALL ncio_write_vector (file_restart, 'ndep ', 'patch', landpatch, ndep ) + + CALL ncio_write_vector (file_restart, 'decomp_cpools_vr ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_cpools_vr) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_write_vector (file_restart, 'decomp_cpools_vr_Cap ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_cpools_vr_Cap) + ENDIF + CALL ncio_write_vector (file_restart, 'ctrunc_vr ', 'soil' , nl_soil, 'patch', landpatch, ctrunc_vr) + CALL ncio_write_vector (file_restart, 'ctrunc_veg ', 'patch', landpatch, ctrunc_veg ) + CALL ncio_write_vector (file_restart, 'ctrunc_soil ', 'patch', landpatch, ctrunc_soil ) + + CALL ncio_write_vector (file_restart, 'altmax ', 'patch', landpatch, altmax ) + CALL ncio_write_vector (file_restart, 'altmax_lastyear ', 'patch', landpatch, altmax_lastyear ) + CALL ncio_write_vector (file_restart, 'altmax_lastyear_indx ', 'patch', landpatch, altmax_lastyear_indx ) + + CALL ncio_write_vector (file_restart, 'decomp_npools_vr ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_npools_vr) + CALL ncio_write_vector (file_restart, 'totsoiln_vr ', 'soil' , nl_soil, 'patch', landpatch, totsoiln_vr ) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_write_vector (file_restart, 'decomp_npools_vr_Cap ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_npools_vr_Cap) + ENDIF + CALL ncio_write_vector (file_restart, 'ntrunc_vr ', 'soil' , nl_soil, 'patch', landpatch, ntrunc_vr ) + CALL ncio_write_vector (file_restart, 'ntrunc_veg ', 'patch', landpatch, ntrunc_veg ) + CALL ncio_write_vector (file_restart, 'ntrunc_soil ', 'patch', landpatch, ntrunc_soil ) + CALL ncio_write_vector (file_restart, 'sminn_vr ', 'soil' , nl_soil, 'patch', landpatch, sminn_vr ) + CALL ncio_write_vector (file_restart, 'smin_no3_vr ', 'soil' , nl_soil, 'patch', landpatch, smin_no3_vr ) + CALL ncio_write_vector (file_restart, 'smin_nh4_vr ', 'soil' , nl_soil, 'patch', landpatch, smin_nh4_vr ) + CALL ncio_write_vector (file_restart, 'lag_npp ', 'patch', landpatch, lag_npp ) + + IF(DEF_USE_NITRIF)THEN + CALL ncio_write_vector (file_restart, 'tCONC_O2_UNSAT ', 'soil' , nl_soil, 'patch', landpatch, tconc_o2_unsat) + CALL ncio_write_vector (file_restart, 'tO2_DECOMP_DEPTH_UNSAT','soil' , nl_soil, 'patch', landpatch, to2_decomp_depth_unsat) + ENDIF + + CALL ncio_write_vector (file_restart, 'prec10 ', 'patch', landpatch, prec10 ) + CALL ncio_write_vector (file_restart, 'prec60 ', 'patch', landpatch, prec60 ) + CALL ncio_write_vector (file_restart, 'prec365 ', 'patch', landpatch, prec365 ) + CALL ncio_write_vector (file_restart, 'prec_today ', 'patch', landpatch, prec_today ) + CALL ncio_write_vector (file_restart, 'prec_daily ', 'doy' , 365, 'patch', landpatch, prec_daily ) + CALL ncio_write_vector (file_restart, 'tsoi17 ', 'patch', landpatch, tsoi17 ) + CALL ncio_write_vector (file_restart, 'rh30 ', 'patch', landpatch, rh30 ) + CALL ncio_write_vector (file_restart, 'accumnstep ', 'patch', landpatch, accumnstep ) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + !---------------SASU variables----------------------- + CALL ncio_write_vector (file_restart, 'decomp0_cpools_vr ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp0_cpools_vr ) + CALL ncio_write_vector (file_restart, 'I_met_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_met_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cel_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cel_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_lig_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_lig_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cwd_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cwd_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_to_soil2_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_to_soil2_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil2_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil2_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_cel_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_cel_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_lig_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_lig_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil3_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil3_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil3_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil3_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_exit_c_vr_acc ) + + CALL ncio_write_vector (file_restart, 'decomp0_npools_vr ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp0_npools_vr ) + CALL ncio_write_vector (file_restart, 'I_met_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_met_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cel_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cel_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_lig_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_lig_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cwd_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cwd_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_to_soil2_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_to_soil2_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil2_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil2_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_cel_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_cel_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_lig_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_lig_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil3_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil3_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil3_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil3_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_exit_n_vr_acc ) + + CALL ncio_write_vector (file_restart, 'diagVX_c_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, diagVX_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'upperVX_c_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, upperVX_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'lowerVX_c_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, lowerVX_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'diagVX_n_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, diagVX_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'upperVX_n_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, upperVX_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'lowerVX_n_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, lowerVX_n_vr_acc ) + + !---------------------------------------------------- + ENDIF + CALL ncio_write_vector (file_restart, 'skip_balance_check ', 'patch', landpatch, skip_balance_check ) + +#ifdef CROP + CALL ncio_write_vector (file_restart, 'cphase ' , 'patch', landpatch, cphase ) + CALL ncio_write_vector (file_restart, 'pdcorn ' , 'patch', landpatch, pdcorn , compress) + CALL ncio_write_vector (file_restart, 'pdswheat ' , 'patch', landpatch, pdswheat , compress) + CALL ncio_write_vector (file_restart, 'pdwwheat ' , 'patch', landpatch, pdwwheat , compress) + CALL ncio_write_vector (file_restart, 'pdsoybean ' , 'patch', landpatch, pdsoybean , compress) + CALL ncio_write_vector (file_restart, 'pdcotton ' , 'patch', landpatch, pdcotton , compress) + CALL ncio_write_vector (file_restart, 'pdrice1 ' , 'patch', landpatch, pdrice1 , compress) + CALL ncio_write_vector (file_restart, 'pdrice2 ' , 'patch', landpatch, pdrice2 , compress) + CALL ncio_write_vector (file_restart, 'pdsugarcane' , 'patch', landpatch, pdsugarcane, compress) + CALL ncio_write_vector (file_restart, 'fertnitro_corn ' , 'patch', landpatch, fertnitro_corn , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_swheat ' , 'patch', landpatch, fertnitro_swheat , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_wwheat ' , 'patch', landpatch, fertnitro_wwheat , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_soybean ' , 'patch', landpatch, fertnitro_soybean , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_cotton ' , 'patch', landpatch, fertnitro_cotton , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_rice1 ' , 'patch', landpatch, fertnitro_rice1 , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_rice2 ' , 'patch', landpatch, fertnitro_rice2 , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_sugarcane' , 'patch', landpatch, fertnitro_sugarcane, compress) +#endif + + END SUBROUTINE WRITE_BGCTimeVariables + + !--------------------------------------- + SUBROUTINE READ_BGCTimeVariables (file_restart) + +!======================================================================= +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +!======================================================================= + + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +! bgc variables + CALL ncio_read_vector (file_restart, 'totlitc ', landpatch, totlitc ) + CALL ncio_read_vector (file_restart, 'totvegc ', landpatch, totvegc ) + CALL ncio_read_vector (file_restart, 'totsomc ', landpatch, totsomc ) + CALL ncio_read_vector (file_restart, 'totcwdc ', landpatch, totcwdc ) + CALL ncio_read_vector (file_restart, 'totcolc ', landpatch, totcolc ) + CALL ncio_read_vector (file_restart, 'totlitn ', landpatch, totlitn ) + CALL ncio_read_vector (file_restart, 'totvegn ', landpatch, totvegn ) + CALL ncio_read_vector (file_restart, 'totsomn ', landpatch, totsomn ) + CALL ncio_read_vector (file_restart, 'totcwdn ', landpatch, totcwdn ) + CALL ncio_read_vector (file_restart, 'totcoln ', landpatch, totcoln ) + + CALL ncio_read_vector (file_restart, 'sminn ', landpatch, sminn ) + CALL ncio_read_vector (file_restart, 'ndep ', landpatch, ndep ) + + CALL ncio_read_vector (file_restart, 'decomp_cpools_vr ', nl_soil_full, ndecomp_pools, landpatch, decomp_cpools_vr) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_read_vector (file_restart, 'decomp_cpools_vr_Cap ', nl_soil_full, ndecomp_pools, landpatch, decomp_cpools_vr_Cap, defval = 1._r8) + ENDIF + CALL ncio_read_vector (file_restart, 'ctrunc_vr ', nl_soil, landpatch, ctrunc_vr ) + CALL ncio_read_vector (file_restart, 'ctrunc_veg ', landpatch, ctrunc_veg ) + CALL ncio_read_vector (file_restart, 'ctrunc_soil ', landpatch, ctrunc_soil ) + + CALL ncio_read_vector (file_restart, 'altmax ', landpatch, altmax ) + CALL ncio_read_vector (file_restart, 'altmax_lastyear ', landpatch, altmax_lastyear ) + CALL ncio_read_vector (file_restart, 'altmax_lastyear_indx ', landpatch, altmax_lastyear_indx ) + + CALL ncio_read_vector (file_restart, 'decomp_npools_vr ', nl_soil_full, ndecomp_pools, landpatch, decomp_npools_vr) + CALL ncio_read_vector (file_restart, 'totsoiln_vr ', nl_soil, landpatch, totsoiln_vr, defval = 1._r8) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_read_vector (file_restart, 'decomp_npools_vr_Cap ',nl_soil_full, ndecomp_pools, landpatch, decomp_npools_vr_Cap, defval = 1._r8) + ENDIF + CALL ncio_read_vector (file_restart, 'ntrunc_vr ', nl_soil, landpatch, ntrunc_vr ) + CALL ncio_read_vector (file_restart, 'ntrunc_veg ', landpatch, ntrunc_veg ) + CALL ncio_read_vector (file_restart, 'ntrunc_soil ', landpatch, ntrunc_soil ) + CALL ncio_read_vector (file_restart, 'sminn_vr ', nl_soil, landpatch, sminn_vr ) + CALL ncio_read_vector (file_restart, 'smin_no3_vr ', nl_soil, landpatch, smin_no3_vr) + CALL ncio_read_vector (file_restart, 'smin_nh4_vr ', nl_soil, landpatch, smin_nh4_vr) + CALL ncio_read_vector (file_restart, 'lag_npp ', landpatch, lag_npp, defval =spval ) + + IF(DEF_USE_NITRIF)THEN + CALL ncio_read_vector (file_restart, 'tCONC_O2_UNSAT ', nl_soil, landpatch, tconc_o2_unsat ) + CALL ncio_read_vector (file_restart, 'tO2_DECOMP_DEPTH_UNSAT', nl_soil, landpatch, to2_decomp_depth_unsat ) + ENDIF + + CALL ncio_read_vector (file_restart, 'prec10 ', landpatch, prec10 ) + CALL ncio_read_vector (file_restart, 'prec60 ', landpatch, prec60 ) + CALL ncio_read_vector (file_restart, 'prec365 ', landpatch, prec365 ) + CALL ncio_read_vector (file_restart, 'prec_today ', landpatch, prec_today ) + CALL ncio_read_vector (file_restart, 'prec_daily ', 365, landpatch, prec_daily) + CALL ncio_read_vector (file_restart, 'tsoi17 ', landpatch, tsoi17 ) + CALL ncio_read_vector (file_restart, 'rh30 ', landpatch, rh30 ) + CALL ncio_read_vector (file_restart, 'accumnstep ', landpatch, accumnstep ) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + !---------------SASU variables----------------------- + CALL ncio_read_vector (file_restart, 'decomp0_cpools_vr ', nl_soil, ndecomp_pools, landpatch, decomp0_cpools_vr, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'I_met_c_vr_acc ', nl_soil, landpatch, I_met_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cel_c_vr_acc ', nl_soil, landpatch, I_cel_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_lig_c_vr_acc ', nl_soil, landpatch, I_lig_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cwd_c_vr_acc ', nl_soil, landpatch, I_cwd_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_met_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_cel_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_to_soil2_c_vr_acc ', nl_soil, landpatch, AKX_lig_to_soil2_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil2_c_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil2_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_cel_c_vr_acc ', nl_soil, landpatch, AKX_cwd_to_cel_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_lig_c_vr_acc ', nl_soil, landpatch, AKX_cwd_to_lig_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil3_c_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil3_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil3_c_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil3_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_soil3_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_exit_c_vr_acc ', nl_soil, landpatch, AKX_met_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_exit_c_vr_acc ', nl_soil, landpatch, AKX_cel_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_exit_c_vr_acc ', nl_soil, landpatch, AKX_lig_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_exit_c_vr_acc ', nl_soil, landpatch, AKX_cwd_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_exit_c_vr_acc ', nl_soil, landpatch, AKX_soil1_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_exit_c_vr_acc ', nl_soil, landpatch, AKX_soil2_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_exit_c_vr_acc ', nl_soil, landpatch, AKX_soil3_exit_c_vr_acc, defval = 0._r8 ) + + CALL ncio_read_vector (file_restart, 'decomp0_npools_vr ', nl_soil, ndecomp_pools, landpatch, decomp0_npools_vr, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'I_met_n_vr_acc ', nl_soil, landpatch, I_met_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cel_n_vr_acc ', nl_soil, landpatch, I_cel_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_lig_n_vr_acc ', nl_soil, landpatch, I_lig_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cwd_n_vr_acc ', nl_soil, landpatch, I_cwd_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_met_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_cel_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_to_soil2_n_vr_acc ', nl_soil, landpatch, AKX_lig_to_soil2_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil2_n_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil2_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_cel_n_vr_acc ', nl_soil, landpatch, AKX_cwd_to_cel_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_lig_n_vr_acc ', nl_soil, landpatch, AKX_cwd_to_lig_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil3_n_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil3_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil3_n_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil3_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_soil3_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_exit_n_vr_acc ', nl_soil, landpatch, AKX_met_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_exit_n_vr_acc ', nl_soil, landpatch, AKX_cel_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_exit_n_vr_acc ', nl_soil, landpatch, AKX_lig_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_exit_n_vr_acc ', nl_soil, landpatch, AKX_cwd_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_exit_n_vr_acc ', nl_soil, landpatch, AKX_soil1_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_exit_n_vr_acc ', nl_soil, landpatch, AKX_soil2_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_exit_n_vr_acc ', nl_soil, landpatch, AKX_soil3_exit_n_vr_acc, defval = 0._r8 ) + + CALL ncio_read_vector (file_restart, 'diagVX_c_vr_acc ', nl_soil, ndecomp_pools, landpatch, diagVX_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'upperVX_c_vr_acc ', nl_soil, ndecomp_pools, landpatch, upperVX_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'lowerVX_c_vr_acc ', nl_soil, ndecomp_pools, landpatch, lowerVX_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'diagVX_n_vr_acc ', nl_soil, ndecomp_pools, landpatch, diagVX_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'upperVX_n_vr_acc ', nl_soil, ndecomp_pools, landpatch, upperVX_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'lowerVX_n_vr_acc ', nl_soil, ndecomp_pools, landpatch, lowerVX_n_vr_acc, defval = 0._r8 ) + ENDIF + + !---------------------------------------------------- + CALL ncio_read_vector (file_restart, 'skip_balance_check ', landpatch, skip_balance_check ) +#ifdef CROP + CALL ncio_read_vector (file_restart, 'cphase ' , landpatch, cphase ) + CALL ncio_read_vector (file_restart, 'pdcorn ' , landpatch, pdcorn ) + CALL ncio_read_vector (file_restart, 'pdswheat ' , landpatch, pdswheat ) + CALL ncio_read_vector (file_restart, 'pdwwheat ' , landpatch, pdwwheat ) + CALL ncio_read_vector (file_restart, 'pdsoybean ' , landpatch, pdsoybean ) + CALL ncio_read_vector (file_restart, 'pdcotton ' , landpatch, pdcotton ) + CALL ncio_read_vector (file_restart, 'pdrice1 ' , landpatch, pdrice1 ) + CALL ncio_read_vector (file_restart, 'pdrice2 ' , landpatch, pdrice2 ) + CALL ncio_read_vector (file_restart, 'pdsugarcane' , landpatch, pdsugarcane) + CALL ncio_read_vector (file_restart, 'fertnitro_corn ' , landpatch, fertnitro_corn ) + CALL ncio_read_vector (file_restart, 'fertnitro_swheat ' , landpatch, fertnitro_swheat ) + CALL ncio_read_vector (file_restart, 'fertnitro_wwheat ' , landpatch, fertnitro_wwheat ) + CALL ncio_read_vector (file_restart, 'fertnitro_soybean ' , landpatch, fertnitro_soybean ) + CALL ncio_read_vector (file_restart, 'fertnitro_cotton ' , landpatch, fertnitro_cotton ) + CALL ncio_read_vector (file_restart, 'fertnitro_rice1 ' , landpatch, fertnitro_rice1 ) + CALL ncio_read_vector (file_restart, 'fertnitro_rice2 ' , landpatch, fertnitro_rice2 ) + CALL ncio_read_vector (file_restart, 'fertnitro_sugarcane' , landpatch, fertnitro_sugarcane) +#endif + +#ifdef RangeCheck + CALL check_BGCTimeVariables +#endif + + END SUBROUTINE READ_BGCTimeVariables + + !--------------------------------------- +#ifdef RangeCheck + SUBROUTINE check_BGCTimeVariables () + + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_SASU, DEF_USE_DiagMatrix + + IMPLICIT NONE + +! bgc variables + CALL check_vector_data ('decomp_cpools_vr ', decomp_cpools_vr ) + CALL check_vector_data ('decomp_cpools ', decomp_cpools ) + IF(DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('decomp_cpools_vr_Cap',decomp_cpools_vr_Cap) + ENDIF + CALL check_vector_data ('decomp_k ', decomp_k ) + CALL check_vector_data ('ctrunc_vr ', ctrunc_vr ) + CALL check_vector_data ('ctrunc_veg ', ctrunc_veg ) + CALL check_vector_data ('ctrunc_soil ', ctrunc_soil ) + + CALL check_vector_data ('t_scalar ', t_scalar ) + CALL check_vector_data ('w_scalar ', w_scalar ) + CALL check_vector_data ('o_scalar ', o_scalar ) + CALL check_vector_data ('depth_scalar ', depth_scalar ) + + ! Soil CN diffusion and advection + CALL check_vector_data ('som_adv_coef ', som_adv_coef ) + CALL check_vector_data ('som_diffus_coef ', som_diffus_coef ) + + ! Active Layer + CALL check_vector_data ('altmax ', altmax ) + CALL check_vector_data ('altmax_lastyear ', altmax_lastyear ) + !CALL check_vector_data ('altmax_lastyear_indx ', altmax_lastyear_indx ) + + CALL check_vector_data ('totlitc ', totlitc ) + CALL check_vector_data ('totvegc ', totvegc ) + CALL check_vector_data ('totsomc ', totsomc ) + CALL check_vector_data ('totcwdc ', totcwdc ) + CALL check_vector_data ('totcolc ', totcolc ) + CALL check_vector_data ('col_begcb ', col_begcb ) + CALL check_vector_data ('col_endcb ', col_endcb ) + CALL check_vector_data ('col_vegbegcb ', col_vegbegcb ) + CALL check_vector_data ('col_vegendcb ', col_vegendcb ) + CALL check_vector_data ('col_soilbegcb ', col_soilbegcb ) + CALL check_vector_data ('col_soilendcb ', col_soilendcb ) + + CALL check_vector_data ('totlitn ', totlitn ) + CALL check_vector_data ('totvegn ', totvegn ) + CALL check_vector_data ('totsomn ', totsomn ) + CALL check_vector_data ('totcwdn ', totcwdn ) + CALL check_vector_data ('totcoln ', totcoln ) + CALL check_vector_data ('col_begnb ', col_begnb ) + CALL check_vector_data ('col_endnb ', col_endnb ) + CALL check_vector_data ('col_vegbegnb ', col_vegbegnb ) + CALL check_vector_data ('col_vegendnb ', col_vegendnb ) + CALL check_vector_data ('col_soilbegnb ', col_soilbegnb ) + CALL check_vector_data ('col_soilendnb ', col_soilendnb ) + CALL check_vector_data ('col_sminnbegnb ', col_sminnbegnb ) + CALL check_vector_data ('col_sminnendnb ', col_sminnendnb ) + + CALL check_vector_data ('leafc ', leafc ) + CALL check_vector_data ('leafc_storage ', leafc_storage ) + CALL check_vector_data ('leafc_xfer ', leafc_xfer ) + CALL check_vector_data ('frootc ', frootc ) + CALL check_vector_data ('frootc_storage ', frootc_storage ) + CALL check_vector_data ('frootc_xfer ', frootc_xfer ) + CALL check_vector_data ('livestemc ', livestemc ) + CALL check_vector_data ('livestemc_storage ', livestemc_storage ) + CALL check_vector_data ('livestemc_xfer ', livestemc_xfer ) + CALL check_vector_data ('deadstemc ', deadstemc ) + CALL check_vector_data ('deadstemc_storage ', deadstemc_storage ) + CALL check_vector_data ('deadstemc_xfer ', deadstemc_xfer ) + CALL check_vector_data ('livecrootc ', livecrootc ) + CALL check_vector_data ('livecrootc_storage ', livecrootc_storage ) + CALL check_vector_data ('livecrootc_xfer ', livecrootc_xfer ) + CALL check_vector_data ('deadcrootc ', deadcrootc ) + CALL check_vector_data ('deadcrootc_storage ', deadcrootc_storage ) + CALL check_vector_data ('deadcrootc_xfer ', deadcrootc_xfer ) + CALL check_vector_data ('grainc ', grainc ) + CALL check_vector_data ('grainc_storage ', grainc_storage ) + CALL check_vector_data ('grainc_xfer ', grainc_xfer ) + CALL check_vector_data ('xsmrpool ', xsmrpool ) + CALL check_vector_data ('downreg ', downreg ) + CALL check_vector_data ('cropprod1c ', cropprod1c ) + CALL check_vector_data ('cropseedc_deficit ', cropseedc_deficit ) + + CALL check_vector_data ('leafn ', leafn ) + CALL check_vector_data ('leafn_storage ', leafn_storage ) + CALL check_vector_data ('leafn_xfer ', leafn_xfer ) + CALL check_vector_data ('frootn ', frootn ) + CALL check_vector_data ('frootn_storage ', frootn_storage ) + CALL check_vector_data ('frootn_xfer ', frootn_xfer ) + CALL check_vector_data ('livestemn ', livestemn ) + CALL check_vector_data ('livestemn_storage ', livestemn_storage ) + CALL check_vector_data ('livestemn_xfer ', livestemn_xfer ) + CALL check_vector_data ('deadstemn ', deadstemn ) + CALL check_vector_data ('deadstemn_storage ', deadstemn_storage ) + CALL check_vector_data ('deadstemn_xfer ', deadstemn_xfer ) + CALL check_vector_data ('livecrootn ', livecrootn ) + CALL check_vector_data ('livecrootn_storage ', livecrootn_storage ) + CALL check_vector_data ('livecrootn_xfer ', livecrootn_xfer ) + CALL check_vector_data ('deadcrootn ', deadcrootn ) + CALL check_vector_data ('deadcrootn_storage ', deadcrootn_storage ) + CALL check_vector_data ('deadcrootn_xfer ', deadcrootn_xfer ) + CALL check_vector_data ('grainn ', grainn ) + CALL check_vector_data ('grainn_storage ', grainn_storage ) + CALL check_vector_data ('grainn_xfer ', grainn_xfer ) + CALL check_vector_data ('retransn ', retransn ) + + IF(DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('leafcCap ', leafcCap ) + CALL check_vector_data ('leafc_storageCap ', leafc_storageCap ) + CALL check_vector_data ('leafc_xferCap ', leafc_xferCap ) + CALL check_vector_data ('frootcCap ', frootcCap ) + CALL check_vector_data ('frootc_storageCap ', frootc_storageCap ) + CALL check_vector_data ('frootc_xferCap ', frootc_xferCap ) + CALL check_vector_data ('livestemcCap ', livestemcCap ) + CALL check_vector_data ('livestemc_storageCap ', livestemc_storageCap ) + CALL check_vector_data ('livestemc_xferCap ', livestemc_xferCap ) + CALL check_vector_data ('deadstemcCap ', deadstemcCap ) + CALL check_vector_data ('deadstemc_storageCap ', deadstemc_storageCap ) + CALL check_vector_data ('deadstemc_xferCap ', deadstemc_xferCap ) + CALL check_vector_data ('livecrootcCap ', livecrootcCap ) + CALL check_vector_data ('livecrootc_storageCap ', livecrootc_storageCap ) + CALL check_vector_data ('livecrootc_xferCap ', livecrootc_xferCap ) + CALL check_vector_data ('deadcrootcCap ', deadcrootcCap ) + CALL check_vector_data ('deadcrootc_storageCap ', deadcrootc_storageCap ) + CALL check_vector_data ('deadcrootc_xferCap ', deadcrootc_xferCap ) + + CALL check_vector_data ('leafnCap ', leafnCap ) + CALL check_vector_data ('leafn_storageCap ', leafn_storageCap ) + CALL check_vector_data ('leafn_xferCap ', leafn_xferCap ) + CALL check_vector_data ('frootnCap ', frootnCap ) + CALL check_vector_data ('frootn_storageCap ', frootn_storageCap ) + CALL check_vector_data ('frootn_xferCap ', frootn_xferCap ) + CALL check_vector_data ('livestemnCap ', livestemnCap ) + CALL check_vector_data ('livestemn_storageCap ', livestemn_storageCap ) + CALL check_vector_data ('livestemn_xferCap ', livestemn_xferCap ) + CALL check_vector_data ('deadstemnCap ', deadstemnCap ) + CALL check_vector_data ('deadstemn_storageCap ', deadstemn_storageCap ) + CALL check_vector_data ('deadstemn_xferCap ', deadstemn_xferCap ) + CALL check_vector_data ('livecrootnCap ', livecrootnCap ) + CALL check_vector_data ('livecrootn_storageCap ', livecrootn_storageCap ) + CALL check_vector_data ('livecrootn_xferCap ', livecrootn_xferCap ) + CALL check_vector_data ('deadcrootnCap ', deadcrootnCap ) + CALL check_vector_data ('deadcrootn_storageCap ', deadcrootn_storageCap ) + CALL check_vector_data ('deadcrootn_xferCap ', deadcrootn_xferCap ) + + ENDIF + + CALL check_vector_data ('decomp_npools_vr ', decomp_npools_vr ) + CALL check_vector_data ('decomp_npools ', decomp_npools ) + CALL check_vector_data ('totsoiln_vr ', totsoiln_vr ) + IF(DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('decomp_npools_vr_Cap ',decomp_npools_vr_Cap ) + ENDIF + CALL check_vector_data ('ntrunc_vr ', ntrunc_vr ) + CALL check_vector_data ('ntrunc_veg ', ntrunc_veg ) + CALL check_vector_data ('ntrunc_soil ', ntrunc_soil ) + + CALL check_vector_data ('sminn_vr ', sminn_vr ) + CALL check_vector_data ('smin_no3_vr ', smin_no3_vr ) + CALL check_vector_data ('smin_nh4_vr ', smin_nh4_vr ) + + IF(DEF_USE_NITRIF)THEN + CALL check_vector_data ('tCONC_O2_UNSAT ', tconc_o2_unsat ) + CALL check_vector_data ('tO2_DECOMP_DEPTH_UNSAT ', to2_decomp_depth_unsat) + ENDIF + + CALL check_vector_data ('sminn ', sminn ) + CALL check_vector_data ('ndep ', ndep ) + + CALL check_vector_data ('ndep_prof ', ndep_prof ) + CALL check_vector_data ('nfixation_prof ', nfixation_prof ) + + CALL check_vector_data ('cn_decomp_pools ', cn_decomp_pools ) + CALL check_vector_data ('fpi_vr ', fpi_vr ) + CALL check_vector_data ('fpi ', fpi ) + CALL check_vector_data ('fpg ', fpg ) + + CALL check_vector_data ('cropf ', cropf ) + CALL check_vector_data ('lfwt ', lfwt ) + CALL check_vector_data ('fuelc ', fuelc ) + CALL check_vector_data ('fuelc_crop ', fuelc_crop ) + CALL check_vector_data ('fsr ', fsr ) + CALL check_vector_data ('fd ', fd ) + CALL check_vector_data ('rootc ', rootc ) + CALL check_vector_data ('lgdp ', lgdp ) + CALL check_vector_data ('lgdp1 ', lgdp1 ) + CALL check_vector_data ('lpop ', lpop ) + CALL check_vector_data ('wtlf ', wtlf ) + CALL check_vector_data ('trotr1 ', trotr1 ) + CALL check_vector_data ('trotr2 ', trotr2 ) + CALL check_vector_data ('hdm_lf ', hdm_lf ) + CALL check_vector_data ('lnfm ', lnfm ) + CALL check_vector_data ('baf_crop ', baf_crop ) + CALL check_vector_data ('baf_peatf ', baf_peatf ) + CALL check_vector_data ('farea_burned ', farea_burned ) + CALL check_vector_data ('nfire ', nfire ) + CALL check_vector_data ('fsat ', fsat ) + CALL check_vector_data ('prec10 ', prec10 ) + CALL check_vector_data ('prec60 ', prec60 ) + CALL check_vector_data ('prec365 ', prec365 ) + CALL check_vector_data ('prec_today ', prec_today ) + CALL check_vector_data ('prec_daily ', prec_daily ) + CALL check_vector_data ('wf2 ', wf2 ) + CALL check_vector_data ('tsoi17 ', tsoi17 ) + CALL check_vector_data ('rh30 ', rh30 ) + CALL check_vector_data ('accumnstep ', accumnstep ) + + CALL check_vector_data ('dayl ', dayl ) + CALL check_vector_data ('prev_dayl ', prev_dayl ) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + !--------------SASU variables--------------------------- + CALL check_vector_data ('decomp0_cpools_vr ', decomp0_cpools_vr ) + CALL check_vector_data ('I_met_c_vr_acc ', I_met_c_vr_acc ) + CALL check_vector_data ('I_cel_c_vr_acc ', I_cel_c_vr_acc ) + CALL check_vector_data ('I_lig_c_vr_acc ', I_lig_c_vr_acc ) + CALL check_vector_data ('I_cwd_c_vr_acc ', I_cwd_c_vr_acc ) + CALL check_vector_data ('AKX_met_to_soil1_c_vr_acc ', AKX_met_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_cel_to_soil1_c_vr_acc ', AKX_cel_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_lig_to_soil2_c_vr_acc ', AKX_lig_to_soil2_c_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil2_c_vr_acc ', AKX_soil1_to_soil2_c_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_cel_c_vr_acc ', AKX_cwd_to_cel_c_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_lig_c_vr_acc ', AKX_cwd_to_lig_c_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil3_c_vr_acc ', AKX_soil1_to_soil3_c_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil1_c_vr_acc ', AKX_soil2_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil3_c_vr_acc ', AKX_soil2_to_soil3_c_vr_acc ) + CALL check_vector_data ('AKX_soil3_to_soil1_c_vr_acc ', AKX_soil3_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_met_exit_c_vr_acc ', AKX_met_exit_c_vr_acc ) + CALL check_vector_data ('AKX_cel_exit_c_vr_acc ', AKX_cel_exit_c_vr_acc ) + CALL check_vector_data ('AKX_lig_exit_c_vr_acc ', AKX_lig_exit_c_vr_acc ) + CALL check_vector_data ('AKX_cwd_exit_c_vr_acc ', AKX_cwd_exit_c_vr_acc ) + CALL check_vector_data ('AKX_soil1_exit_c_vr_acc ', AKX_soil1_exit_c_vr_acc ) + CALL check_vector_data ('AKX_soil2_exit_c_vr_acc ', AKX_soil2_exit_c_vr_acc ) + CALL check_vector_data ('AKX_soil3_exit_c_vr_acc ', AKX_soil3_exit_c_vr_acc ) + + CALL check_vector_data ('decomp0_npools_vr ', decomp0_npools_vr ) + CALL check_vector_data ('I_met_n_vr_acc ', I_met_n_vr_acc ) + CALL check_vector_data ('I_cel_n_vr_acc ', I_cel_n_vr_acc ) + CALL check_vector_data ('I_lig_n_vr_acc ', I_lig_n_vr_acc ) + CALL check_vector_data ('I_cwd_n_vr_acc ', I_cwd_n_vr_acc ) + CALL check_vector_data ('AKX_met_to_soil1_n_vr_acc ', AKX_met_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_cel_to_soil1_n_vr_acc ', AKX_cel_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_lig_to_soil2_n_vr_acc ', AKX_lig_to_soil2_n_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil2_n_vr_acc ', AKX_soil1_to_soil2_n_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_cel_n_vr_acc ', AKX_cwd_to_cel_n_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_lig_n_vr_acc ', AKX_cwd_to_lig_n_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil3_n_vr_acc ', AKX_soil1_to_soil3_n_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil1_n_vr_acc ', AKX_soil2_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil3_n_vr_acc ', AKX_soil2_to_soil3_n_vr_acc ) + CALL check_vector_data ('AKX_soil3_to_soil1_n_vr_acc ', AKX_soil3_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_met_exit_n_vr_acc ', AKX_met_exit_n_vr_acc ) + CALL check_vector_data ('AKX_cel_exit_n_vr_acc ', AKX_cel_exit_n_vr_acc ) + CALL check_vector_data ('AKX_lig_exit_n_vr_acc ', AKX_lig_exit_n_vr_acc ) + CALL check_vector_data ('AKX_cwd_exit_n_vr_acc ', AKX_cwd_exit_n_vr_acc ) + CALL check_vector_data ('AKX_soil1_exit_n_vr_acc ', AKX_soil1_exit_n_vr_acc ) + CALL check_vector_data ('AKX_soil2_exit_n_vr_acc ', AKX_soil2_exit_n_vr_acc ) + CALL check_vector_data ('AKX_soil3_exit_n_vr_acc ', AKX_soil3_exit_n_vr_acc ) + + CALL check_vector_data ('diagVX_c_vr_acc ', diagVX_c_vr_acc ) + CALL check_vector_data ('upperVX_c_vr_acc ', upperVX_c_vr_acc ) + CALL check_vector_data ('lowerVX_c_vr_acc ', lowerVX_c_vr_acc ) + CALL check_vector_data ('diagVX_n_vr_acc ', diagVX_n_vr_acc ) + CALL check_vector_data ('upperVX_n_vr_acc ', upperVX_n_vr_acc ) + CALL check_vector_data ('lowerVX_n_vr_acc ', lowerVX_n_vr_acc ) + ! CALL check_vector_data ('skip_balance_check ', skip_balance_check ) + !------------------------------------------------------ + ENDIF +#ifdef CROP + CALL check_vector_data ('cphase ' , cphase ) + CALL check_vector_data ('vf ' , vf ) + CALL check_vector_data ('hui ' , hui ) + CALL check_vector_data ('huiswheat ' , huiswheat ) + CALL check_vector_data ('gddplant ' , gddplant ) + CALL check_vector_data ('gddmaturity' , gddmaturity) + CALL check_vector_data ('pdcorn ' , pdcorn ) + CALL check_vector_data ('pdswheat ' , pdswheat ) + CALL check_vector_data ('pdwwheat ' , pdwwheat ) + CALL check_vector_data ('pdsoybean ' , pdsoybean ) + CALL check_vector_data ('pdcotton ' , pdcotton ) + CALL check_vector_data ('pdrice1 ' , pdrice1 ) + CALL check_vector_data ('pdrice2 ' , pdrice2 ) + CALL check_vector_data ('plantdate ' , plantdate ) + CALL check_vector_data ('pdsugarcane' , pdsugarcane) + CALL check_vector_data ('manunitro ' , manunitro ) + CALL check_vector_data ('fertnitro_corn ' , fertnitro_corn ) + CALL check_vector_data ('fertnitro_swheat ' , fertnitro_swheat ) + CALL check_vector_data ('fertnitro_wwheat ' , fertnitro_wwheat ) + CALL check_vector_data ('fertnitro_soybean ' , fertnitro_soybean ) + CALL check_vector_data ('fertnitro_cotton ' , fertnitro_cotton ) + CALL check_vector_data ('fertnitro_rice1 ' , fertnitro_rice1 ) + CALL check_vector_data ('fertnitro_rice2 ' , fertnitro_rice2 ) + CALL check_vector_data ('fertnitro_sugarcane' , fertnitro_sugarcane) +#endif + CALL check_vector_data ('lag_npp ' , lag_npp ) + + END SUBROUTINE check_BGCTimeVariables +#endif + +#endif +END MODULE MOD_BGC_Vars_TimeVariables +! ------ EOP -------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 new file mode 100644 index 0000000000..cc4be943a1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 @@ -0,0 +1,421 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNFireBase + +!--------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE calculate fire-induced vegetation and litter CN transfers flux, the calculation is based on the fire-induced +! CN loss rates (f). The CN loss rates (f) is calculated from bgc_veg_CNFireLi2016Mod.F90. +! +! !REFERENCES: +! Li, F., Levis, S., and Ward, D. S. 2013a. Quantifying the role of fire in the Earth system - Part 1: Improved global fire +! modeling in the Community Earth System Model (CESM1). Biogeosciences 10:2293-2314. +! Li, F., and Lawrence, D. 2017. Role of fire in the global land water budget during the 20th century through changing +! ecosystems. J. Clim. 30: 1894-1908. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + + USE MOD_Precision + USE MOD_Const_PFT, only: & + cc_leaf , cc_lstem , cc_dstem , cc_other, fm_leaf, fm_lstem, fm_lroot, fm_root, fm_droot, fm_other, & + fr_fcel , fr_flig , fr_flab , lf_fcel , lf_flig, lf_flab + USE MOD_Vars_TimeInvariants, only: & + cmb_cmplt_fact, patchlatr, borealat, is_cwd, is_litter + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition pools & fluxes variables (inout) + decomp_cpools_vr, decomp_npools_vr, cropf, farea_burned, baf_crop, baf_peatf, totsomc + + USE MOD_BGC_Vars_1DFluxes, only: & + m_decomp_cpools_to_fire_vr, m_decomp_npools_to_fire_vr, & + fire_mortality_to_met_c, fire_mortality_to_cel_c, fire_mortality_to_lig_c, fire_mortality_to_cwdc, & + fire_mortality_to_met_n, fire_mortality_to_cel_n, fire_mortality_to_lig_n, fire_mortality_to_cwdn, & + somc_fire + + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p , leafc_storage_p , leafc_xfer_p , frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p, livecrootc_storage_p, livecrootc_xfer_p, deadcrootc_p, deadcrootc_storage_p, deadcrootc_xfer_p, & + leafn_p , leafn_storage_p , leafn_xfer_p , frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p, livecrootn_storage_p, livecrootn_xfer_p, deadcrootn_p, deadcrootn_storage_p, deadcrootn_xfer_p, & + livecrootn_p, livecrootn_storage_p, livecrootn_xfer_p, deadcrootn_p, deadcrootn_storage_p, deadcrootn_xfer_p, & + gresp_xfer_p, gresp_storage_p , retransn_p , & + leaf_prof_p , froot_prof_p , croot_prof_p , stem_prof_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + m_leafc_to_fire_p , m_leafc_storage_to_fire_p , m_leafc_xfer_to_fire_p , & + m_frootc_to_fire_p , m_frootc_storage_to_fire_p , m_frootc_xfer_to_fire_p , & + m_livestemc_to_fire_p , m_livestemc_storage_to_fire_p , m_livestemc_xfer_to_fire_p , & + m_deadstemc_to_fire_p , m_deadstemc_storage_to_fire_p , m_deadstemc_xfer_to_fire_p , & + m_livecrootc_to_fire_p , m_livecrootc_storage_to_fire_p , m_livecrootc_xfer_to_fire_p, & + m_deadcrootc_to_fire_p , m_deadcrootc_storage_to_fire_p , m_deadcrootc_xfer_to_fire_p, & + m_livestemc_to_deadstemc_fire_p, m_livecrootc_to_deadcrootc_fire_p, & + m_gresp_xfer_to_fire_p , m_gresp_storage_to_fire_p , m_retransn_to_fire_p , & + m_leafn_to_fire_p , m_leafn_storage_to_fire_p , m_leafn_xfer_to_fire_p , & + m_frootn_to_fire_p , m_frootn_storage_to_fire_p , m_frootn_xfer_to_fire_p , & + m_livestemn_to_fire_p , m_livestemn_storage_to_fire_p , m_livestemn_xfer_to_fire_p , & + m_deadstemn_to_fire_p , m_deadstemn_storage_to_fire_p , m_deadstemn_xfer_to_fire_p , & + m_livecrootn_to_fire_p , m_livecrootn_storage_to_fire_p , m_livecrootn_xfer_to_fire_p, & + m_deadcrootn_to_fire_p , m_deadcrootn_storage_to_fire_p , m_deadcrootn_xfer_to_fire_p, & + m_livestemn_to_deadstemn_fire_p, m_livecrootn_to_deadcrootn_fire_p, & + + m_leafc_to_litter_fire_p , m_leafc_storage_to_litter_fire_p , m_leafc_xfer_to_litter_fire_p , & + m_frootc_to_litter_fire_p , m_frootc_storage_to_litter_fire_p , m_frootc_xfer_to_litter_fire_p , & + m_livestemc_to_litter_fire_p , m_livestemc_storage_to_litter_fire_p , m_livestemc_xfer_to_litter_fire_p , & + m_deadstemc_to_litter_fire_p , m_deadstemc_storage_to_litter_fire_p , m_deadstemc_xfer_to_litter_fire_p , & + m_livecrootc_to_litter_fire_p, m_livecrootc_storage_to_litter_fire_p, m_livecrootc_xfer_to_litter_fire_p, & + m_deadcrootc_to_litter_fire_p, m_deadcrootc_storage_to_litter_fire_p, m_deadcrootc_xfer_to_litter_fire_p, & + m_gresp_xfer_to_litter_fire_p, m_gresp_storage_to_litter_fire_p , m_retransn_to_litter_fire_p , & + m_leafn_to_litter_fire_p , m_leafn_storage_to_litter_fire_p , m_leafn_xfer_to_litter_fire_p , & + m_frootn_to_litter_fire_p , m_frootn_storage_to_litter_fire_p , m_frootn_xfer_to_litter_fire_p , & + m_livestemn_to_litter_fire_p , m_livestemn_storage_to_litter_fire_p , m_livestemn_xfer_to_litter_fire_p , & + m_deadstemn_to_litter_fire_p , m_deadstemn_storage_to_litter_fire_p , m_deadstemn_xfer_to_litter_fire_p , & + m_livecrootn_to_litter_fire_p, m_livecrootn_storage_to_litter_fire_p, m_livecrootn_xfer_to_litter_fire_p, & + m_deadcrootn_to_litter_fire_p, m_deadcrootn_storage_to_litter_fire_p, m_deadcrootn_xfer_to_litter_fire_p + + USE MOD_Vars_PFTimeInvariants, only: pftfrac + + IMPLICIT NONE + + PUBLIC CNFireFluxes + +CONTAINS + + SUBROUTINE CNFireFluxes(i,ps,pe,dlat,nl_soil,ndecomp_pools) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: dlat ! latitude (degree) + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_pools! number of total soil & litter pools in the decomposition + + ! !LOCAL VARIABLES: + integer :: j,l ! indices + real(r8):: f + real(r8):: mort + integer :: ivt, m + + integer, parameter :: lit_fp = 1 ! Pool for liter + integer, parameter :: cwd_fp = 2 ! Pool for CWD Course woody debris + + + DO m = ps, pe + IF(cropf(i) < 1.0_r8)THEN + ! For non-crop (bare-soil and natural vegetation) + f = (farea_burned(i)-baf_crop(i))/(1.0_r8-cropf(i)) + ELSE + ! For crops + IF(cropf(i) > 0._r8)THEN + f = baf_crop(i) /cropf(i) + ELSE + f = 0._r8 + ENDIF + ENDIF + + ! apply this rate to the patch state variables to get flux rates + ! biomass burning + ! carbon fluxes + mort = 1._r8 + m_leafc_to_fire_p(m) = leafc_p(m) * f * cc_leaf(ivt) + m_leafc_storage_to_fire_p(m) = leafc_storage_p(m) * f * cc_other(ivt) + m_leafc_xfer_to_fire_p(m) = leafc_xfer_p(m) * f * cc_other(ivt) + m_livestemc_to_fire_p(m) = livestemc_p(m) * f * cc_lstem(ivt) + m_livestemc_storage_to_fire_p(m) = livestemc_storage_p(m) * f * cc_other(ivt) + m_livestemc_xfer_to_fire_p(m) = livestemc_xfer_p(m) * f * cc_other(ivt) + m_deadstemc_to_fire_p(m) = deadstemc_p(m) * f * cc_dstem(ivt) + m_deadstemc_storage_to_fire_p(m) = deadstemc_storage_p(m) * f * cc_other(ivt) + m_deadstemc_xfer_to_fire_p(m) = deadstemc_xfer_p(m) * f * cc_other(ivt) + m_frootc_to_fire_p(m) = frootc_p(m) * f * 0._r8 + m_frootc_storage_to_fire_p(m) = frootc_storage_p(m) * f * cc_other(ivt) + m_frootc_xfer_to_fire_p(m) = frootc_xfer_p(m) * f * cc_other(ivt) + m_livecrootc_to_fire_p(m) = livecrootc_p(m) * f * 0._r8 + m_livecrootc_storage_to_fire_p(m) = livecrootc_storage_p(m) * f * cc_other(ivt) + m_livecrootc_xfer_to_fire_p(m) = livecrootc_xfer_p(m) * f * cc_other(ivt) + m_deadcrootc_to_fire_p(m) = deadcrootc_p(m) * f * 0._r8 + m_deadcrootc_storage_to_fire_p(m) = deadcrootc_storage_p(m) * f* cc_other(ivt) + m_deadcrootc_xfer_to_fire_p(m) = deadcrootc_xfer_p(m) * f * cc_other(ivt) + m_gresp_storage_to_fire_p(m) = gresp_storage_p(m) * f * cc_other(ivt) + m_gresp_xfer_to_fire_p(m) = gresp_xfer_p(m) * f * cc_other(ivt) + + + ! nitrogen fluxes + m_leafn_to_fire_p(m) = leafn_p(m) * f * cc_leaf(ivt) + m_leafn_storage_to_fire_p(m) = leafn_storage_p(m) * f * cc_other(ivt) + m_leafn_xfer_to_fire_p(m) = leafn_xfer_p(m) * f * cc_other(ivt) + m_livestemn_to_fire_p(m) = livestemn_p(m) * f * cc_lstem(ivt) + m_livestemn_storage_to_fire_p(m) = livestemn_storage_p(m) * f * cc_other(ivt) + m_livestemn_xfer_to_fire_p(m) = livestemn_xfer_p(m) * f * cc_other(ivt) + m_deadstemn_to_fire_p(m) = deadstemn_p(m) * f * cc_dstem(ivt) + m_deadstemn_storage_to_fire_p(m) = deadstemn_storage_p(m) * f * cc_other(ivt) + m_deadstemn_xfer_to_fire_p(m) = deadstemn_xfer_p(m) * f * cc_other(ivt) + m_frootn_to_fire_p(m) = frootn_p(m) * f * 0._r8 + m_frootn_storage_to_fire_p(m) = frootn_storage_p(m) * f * cc_other(ivt) + m_frootn_xfer_to_fire_p(m) = frootn_xfer_p(m) * f * cc_other(ivt) + m_livecrootn_to_fire_p(m) = livecrootn_p(m) * f * 0._r8 + m_livecrootn_storage_to_fire_p(m) = livecrootn_storage_p(m) * f * cc_other(ivt) + m_livecrootn_xfer_to_fire_p(m) = livecrootn_xfer_p(m) * f * cc_other(ivt) + m_deadcrootn_to_fire_p(m) = deadcrootn_p(m) * f * 0._r8 + m_deadcrootn_xfer_to_fire_p(m) = deadcrootn_xfer_p(m) * f * cc_other(ivt) + m_deadcrootn_storage_to_fire_p(m) = deadcrootn_storage_p(m) * f * cc_other(ivt) + m_retransn_to_fire_p(m) = retransn_p(m) * f * cc_other(ivt) + + ! mortality due to fire + ! carbon pools + m_leafc_to_litter_fire_p(m) = leafc_p(m) * f * & + (1._r8 - cc_leaf(ivt)) * & + fm_leaf(ivt) + m_leafc_storage_to_litter_fire_p(m) = leafc_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_leafc_xfer_to_litter_fire_p(m) = leafc_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemc_to_litter_fire_p(m) = livestemc_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + fm_droot(ivt) + m_livestemc_storage_to_litter_fire_p(m) = livestemc_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemc_xfer_to_litter_fire_p(m) = livestemc_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemc_to_deadstemc_fire_p(m) = livestemc_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + (fm_lstem(ivt)-fm_droot(ivt)) + m_deadstemc_to_litter_fire_p(m) = deadstemc_p(m) * f * m * & + (1._r8 - cc_dstem(ivt)) * & + fm_droot(ivt) + m_deadstemc_storage_to_litter_fire_p(m) = deadstemc_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_deadstemc_xfer_to_litter_fire_p(m) = deadstemc_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_frootc_to_litter_fire_p(m) = frootc_p(m) * f * & + fm_root(ivt) + m_frootc_storage_to_litter_fire_p(m) = frootc_storage_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_frootc_xfer_to_litter_fire_p(m) = frootc_xfer_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_livecrootc_to_litter_fire_p(m) = livecrootc_p(m) * f * & + fm_droot(ivt) + m_livecrootc_storage_to_litter_fire_p(m) = livecrootc_storage_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_livecrootc_xfer_to_litter_fire_p(m) = livecrootc_xfer_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_livecrootc_to_deadcrootc_fire_p(m) = livecrootc_p(m) * f * & + (fm_lroot(ivt)-fm_droot(ivt)) + m_deadcrootc_to_litter_fire_p(m) = deadcrootc_p(m) * f * m * & + fm_droot(ivt) + m_deadcrootc_storage_to_litter_fire_p(m) = deadcrootc_storage_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_deadcrootc_xfer_to_litter_fire_p(m) = deadcrootc_xfer_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_gresp_storage_to_litter_fire_p(m) = gresp_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_gresp_xfer_to_litter_fire_p(m) = gresp_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + + + ! nitrogen pools + m_leafn_to_litter_fire_p(m) = leafn_p(m) * f * & + (1._r8 - cc_leaf(ivt)) * & + fm_leaf(ivt) + m_leafn_storage_to_litter_fire_p(m) = leafn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_leafn_xfer_to_litter_fire_p(m) = leafn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemn_to_litter_fire_p(m) = livestemn_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + fm_droot(ivt) + m_livestemn_storage_to_litter_fire_p(m) = livestemn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemn_xfer_to_litter_fire_p(m) = livestemn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemn_to_deadstemn_fire_p(m) = livestemn_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + (fm_lstem(ivt)-fm_droot(ivt)) + m_deadstemn_to_litter_fire_p(m) = deadstemn_p(m) * f * m * & + (1._r8 - cc_dstem(ivt)) * & + fm_droot(ivt) + m_deadstemn_storage_to_litter_fire_p(m) = deadstemn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_deadstemn_xfer_to_litter_fire_p(m) = deadstemn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_frootn_to_litter_fire_p(m) = frootn_p(m) * f * & + fm_root(ivt) + m_frootn_storage_to_litter_fire_p(m) = frootn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_frootn_xfer_to_litter_fire_p(m) = frootn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livecrootn_to_litter_fire_p(m) = livecrootn_p(m) * f * & + fm_droot(ivt) + m_livecrootn_storage_to_litter_fire_p(m) = livecrootn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livecrootn_xfer_to_litter_fire_p(m) = livecrootn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livecrootn_to_deadcrootn_fire_p(m) = livecrootn_p(m) * f * & + (fm_lroot(ivt)-fm_droot(ivt)) + m_deadcrootn_to_litter_fire_p(m) = deadcrootn_p(m) * f * & + fm_droot(ivt) + m_deadcrootn_storage_to_litter_fire_p(m) = deadcrootn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_deadcrootn_xfer_to_litter_fire_p(m) = deadcrootn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_retransn_to_litter_fire_p(m) = retransn_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + + ENDDO ! END of patches loop + + ! fire-induced transfer of carbon and nitrogen pools to litter and cwd + + DO j = 1,nl_soil + fire_mortality_to_cwdc (j,i) = 0._r8 + fire_mortality_to_cwdn (j,i) = 0._r8 + fire_mortality_to_met_c(j,i) = 0._r8 + DO m = ps, pe + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_deadstemc_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_deadcrootc_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_deadstemn_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_deadcrootn_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + + + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_livestemc_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_livecrootc_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_livestemn_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_livecrootn_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + + + fire_mortality_to_met_c(j,i)=fire_mortality_to_met_c(j,i) & + +((m_leafc_to_litter_fire_p(m)*lf_flab(ivt) & + + m_leafc_storage_to_litter_fire_p(m) & + + m_leafc_xfer_to_litter_fire_p(m) & + + m_gresp_storage_to_litter_fire_p(m) & + + m_gresp_xfer_to_litter_fire_p(m)) * leaf_prof_p(j,m) & + + (m_frootc_to_litter_fire_p(m)*fr_flab(ivt) & + + m_frootc_storage_to_litter_fire_p(m) & + + m_frootc_xfer_to_litter_fire_p(m)) * froot_prof_p(j,m) & + + (m_livestemc_storage_to_litter_fire_p(m) & + + m_livestemc_xfer_to_litter_fire_p(m) & + + m_deadstemc_storage_to_litter_fire_p(m) & + + m_deadstemc_xfer_to_litter_fire_p(m)) * stem_prof_p(j,m) & + + (m_livecrootc_storage_to_litter_fire_p(m) & + + m_livecrootc_xfer_to_litter_fire_p(m) & + + m_deadcrootc_storage_to_litter_fire_p(m) & + + m_deadcrootc_xfer_to_litter_fire_p(m)) * croot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_cel_c(j,i)=fire_mortality_to_cel_c(j,i) & + + (m_leafc_to_litter_fire_p(m)*lf_fcel(ivt)*leaf_prof_p(j,m) & + + m_frootc_to_litter_fire_p(m)*fr_fcel(ivt)*froot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_lig_c(j,i)=fire_mortality_to_lig_c(j,i) & + + (m_leafc_to_litter_fire_p(m)*lf_flig(ivt)*leaf_prof_p(j,m) & + + m_frootc_to_litter_fire_p(m)*fr_flig(ivt)*froot_prof_p(j,m)) * pftfrac(m) + + fire_mortality_to_met_n(j,i)=fire_mortality_to_met_n(j,i) & + + ((m_leafn_to_litter_fire_p(m)*lf_flab(ivt) & + + m_leafn_storage_to_litter_fire_p(m) & + + m_leafn_xfer_to_litter_fire_p(m) & + + m_retransn_to_litter_fire_p(m)) *leaf_prof_p(j,m) & + + (m_frootn_to_litter_fire_p(m)*fr_flab(ivt) & + + m_frootn_storage_to_litter_fire_p(m) & + + m_frootn_xfer_to_litter_fire_p(m))*froot_prof_p(j,m) & + + (m_livestemn_storage_to_litter_fire_p(m) & + + m_livestemn_xfer_to_litter_fire_p(m) & + + m_deadstemn_storage_to_litter_fire_p(m) & + + m_deadstemn_xfer_to_litter_fire_p(m))* stem_prof_p(j,m)& + + (m_livecrootn_storage_to_litter_fire_p(m) & + + m_livecrootn_xfer_to_litter_fire_p(m) & + + m_deadcrootn_storage_to_litter_fire_p(m) & + + m_deadcrootn_xfer_to_litter_fire_p(m)) * croot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_cel_n(j,i)=fire_mortality_to_cel_n(j,i) & + + (m_leafn_to_litter_fire_p(m)*lf_fcel(i)*leaf_prof_p(j,m) & + + m_frootn_to_litter_fire_p(m)*fr_fcel(i)*froot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_lig_n(j,i)=fire_mortality_to_lig_n(j,i) & + + (m_leafn_to_litter_fire_p(m)*lf_flig(i)*leaf_prof_p(j,m) & + + m_frootn_to_litter_fire_p(m)*fr_flig(i)*froot_prof_p(j,m)) * pftfrac(m) + ENDDO + ENDDO + ! + ! vertically-resolved decomposing C/N fire loss + ! column loop + ! + DO j = 1, nl_soil + ! carbon fluxes + DO l = 1, ndecomp_pools + IF ( is_litter(l) ) THEN + m_decomp_cpools_to_fire_vr(j,l,i) = decomp_cpools_vr(j,l,i) * f * & + cmb_cmplt_fact(lit_fp) + ENDIF + IF ( is_cwd(l) ) THEN + m_decomp_cpools_to_fire_vr(j,l,i) = decomp_cpools_vr(j,l,i) * & + (f-baf_crop(i)) * cmb_cmplt_fact(cwd_fp) + ENDIF + ENDDO + + ! nitrogen fluxes + DO l = 1, ndecomp_pools + IF ( is_litter(l) ) THEN + m_decomp_npools_to_fire_vr(j,l,i) = decomp_npools_vr(j,l,i) * f * & + cmb_cmplt_fact(lit_fp) + ENDIF + IF ( is_cwd(l) ) THEN + m_decomp_npools_to_fire_vr(j,l,i) = decomp_npools_vr(j,l,i) * & + (f-baf_crop(i)) * cmb_cmplt_fact(cwd_fp) + ENDIF + ENDDO + + ENDDO + ! Carbon loss due to peat fires + ! + ! somc_fire is not connected to clm45 soil carbon pool, ie does not decrease + ! soil carbon b/c clm45 soil carbon was very low in several peatland grids + IF( patchlatr(i) < borealat)THEN + somc_fire(i)= totsomc(i)*baf_peatf(i)*6.0_r8/33.9_r8 + ELSE + somc_fire(i)= baf_peatf(i)*2.2e3_r8 + ENDIF + + ! Fang Li has not added aerosol and trace gas emissions due to fire, yet + ! They will be added here in proportion to the carbon emission + ! Emission factors differ for various fire types + + + END SUBROUTINE CNFireFluxes + +END MODULE MOD_BGC_Veg_CNFireBase +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 new file mode 100644 index 0000000000..c2b77e572e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 @@ -0,0 +1,320 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNFireLi2016 + +!------------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculate burned area of each fire. The burned area is used to calculate fire induced CN loss rates +! in bgc_veg_CNFireBaseMod.F90 +! +! !REFERENCES: +! Li, F., Levis, S., and Ward, D. S. 2013a. Quantifying the role of fire in the Earth system - Part 1: Improved global fire +! modeling in the Community Earth System Model (CESM1). Biogeosciences 10:2293-2314. +! Li, F., and Lawrence, D. 2017. Role of fire in the global land water budget during the 20th century through changing +! ecosystems. J. Clim. 30: 1894-1908. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Const_Physical, only: tfrz + USE MOD_Vars_1DForcing, only: & + forc_q, forc_t, forc_psrf, forc_us, forc_vs + USE MOD_Const_PFT, only: isshrub, isgrass, isbetr, isbdtr, isbare, iscrop, isnatveg, fd_pft, fsr_pft, rootfr_p + USE MOD_Vars_TimeInvariants, only: & + i_cwd, occur_hi_gdp_tree, gdp_lf, abm_lf, peatf_lf, & + lfuel, ufuel, cropfire_a1, borealat, troplat, non_boreal_peatfire_c, boreal_peatfire_c, rh_low, rh_hgh, & + bt_min, bt_max, pot_hmn_ign_counts_alpha, g0_fire, psi0, porsl, bsw +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Vars_TimeInvariants, only: theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm +#endif + USE MOD_Vars_TimeVariables, only: & + decomp_cpools_vr , totlitc , totvegc , cropf , lfwt , fuelc , fuelc_crop , fsr , & + fd , rootc , lgdp , lgdp1 , lpop , wtlf , & + trotr1 , trotr2 , hdm_lf , lnfm , baf_crop , baf_peatf , & + farea_burned , nfire , fsat , prec60 , wf2 , & + tsoi17 , rh30 , t_soisno , wliq_soisno + USE MOD_BGC_Vars_PFTimeVariables, only: & + burndate_p + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_BGC_Vars_PFTimeVariables, only: leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + deadcrootc_p, deadcrootc_storage_p, deadcrootc_xfer_p, & + livecrootc_p, livecrootc_storage_p, livecrootc_xfer_p + USE MOD_Eroot, only: eroot + USE MOD_Qsadv + + IMPLICIT NONE + + PUBLIC CNFireArea + +CONTAINS + + SUBROUTINE CNFireArea(i,ps,pe,dlat,nl_soil,idate,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: dlat ! latitude (degree) + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer :: g,l,c,p,j,fc,fp,kyr, kmo, kda, mcsec ! index variables + integer :: ivt + real(r8) :: dayspyr ! days per year + real(r8) :: fb ! availability of fuel for regs A and C + real(r8) :: fhd ! impact of hd on agricultural fire + real(r8) :: fgdp ! impact of gdp on agricultural fire + real(r8) :: fire_m ! combustability of fuel for fire occurrence + real(r8) :: spread_m ! combustability of fuel for fire spread + real(r8) :: Lb_lf ! length-to-breadth ratio added by Lifang + real(r8) :: lh ! anthro. ignitions (count/km2/hr) + real(r8) :: fs ! hd-dependent fires suppression (0-1) + real(r8) :: ig ! total ignitions (count/km2/hr) + real(r8) :: arh, arh30 !combustability of fuel related to RH and RH30 + real(r8) :: afuel !weight for arh and arh30 + real(r8) :: eq + real(r8) :: deqdT + real(r8) :: qsatq + real(r8) :: qsatqdT + real(r8) :: forc_rh + real(r8) :: rootr(nl_soil) + real(r8) :: rresis(nl_soil) + real(r8) :: smp_node + real(r8) :: s_node + real(r8) :: tmp1d(nl_soil) + real(r8) :: tmp0d + real(r8) :: btran2 + real(r8) :: btran2_p(ps:pe) + + real(r8),parameter :: secsphr = 3600._r8 + real(r8),parameter :: secspday = 86400._r8 + real(r8),parameter :: PI = 4.*atan(1.) + integer m + + tsoi17 = forc_t(i) ! Temporarily use air temperature for tsoi17, need to revised later. + prec60 = 0 ! Temporarily use 0 for prec60, need to revised later + wf2 = 0.5 ! Temporarily set up, need to revise later. + fsat = 0 ! Temporarily set up, need to revise later. + rh30 = 0 ! Temporarily set up, need to revise later. + + CALL julian2monthday(idate(1),idate(2),kmo,kda) + + DO m = ps, pe + CALL eroot(nl_soil,0._r8,porsl(1:,i),& +#ifdef Campbell_SOIL_MODEL + bsw(1:,i),& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), sc_vgm(1:,i), fc_vgm(1:,i), & +#endif + psi0(1:,i),rootfr_p(1:,pftclass(m)),dz_soi(1:),& + t_soisno(1:,i),wliq_soisno(1:,i),tmp1d,tmp0d,btran2_p(m)) + btran2 = sum(btran2_p(ps:pe) * pftfrac(m)) + ENDDO + ! + ! Calculate fraction of crop (cropf_col) and non-crop and non-bare-soil + ! vegetation (lfwt) in vegetated column + ! + cropf(i) = 0._r8 + lfwt (i) = 0._r8 + + ! For crop veg types + DO m = ps, pe + IF( iscrop(pftclass(m)) )THEN + cropf(i) = cropf(i) + pftfrac(m) + ENDIF + ! For natural vegetation (non-crop and non-bare-soil) + IF( isnatveg(pftclass(m)))THEN + lfwt (i) = lfwt(i) + pftfrac(m) + ENDIF + ENDDO + + ! + ! Calculate crop fuel + ! + fuelc_crop(i)=0._r8 + + ! For crop PFTs, fuel load includes leaf and litter; only + ! column-level litter carbon + ! is available, so we use leaf carbon to estimate the + ! litter carbon for crop PFTs + DO m = ps, pe + IF( iscrop(pftclass(m)) .and. sum(leafc_p(ps:pe)*pftfrac(ps:pe)) > 0._r8 )THEN + fuelc_crop(i)= fuelc_crop(i) + (leafc_p(m) + leafc_storage_p(m) + leafc_xfer_p(m))*pftfrac(m)/cropf(i) & + + totlitc(i)*leafc_p(m)/sum(leafc_p(ps:pe)*pftfrac(ps:pe))*pftfrac(m)/cropf(i) + ENDIF + ENDDO + ! + ! Calculate noncrop column variables + ! + fsr (i) = 0._r8 + fd (i) = 0._r8 + rootc (i) = 0._r8 + lgdp (i) = 0._r8 + lgdp1 (i) = 0._r8 + lpop (i) = 0._r8 + wtlf (i) = 0._r8 + trotr1(i) = 0._r8 + trotr2(i) = 0._r8 + + ! Warning : ivt is not initialized. + ! For non-crop -- natural vegetation and bare-soil + IF( isnatveg(ivt) .or. isbare(ivt) )THEN + IF (btran2 <= 1._r8 ) THEN + wtlf(i) = 1._r8 + ENDIF + + IF( isbetr(ivt) )THEN + trotr1(i)=1._r8 + ENDIF + IF( isbdtr(ivt) .and. abs(dlat) .lt. troplat)THEN + trotr2(i)=1._r8 + ENDIF + + rootc(i) = rootc(i) + sum((frootc_p(ps:pe) + frootc_storage_p(ps:pe) + & + frootc_xfer_p(ps:pe) + deadcrootc_p(ps:pe) + & + deadcrootc_storage_p(ps:pe) + deadcrootc_xfer_p(ps:pe) + & + livecrootc_p(ps:pe)+livecrootc_storage_p(ps:pe) + & + livecrootc_xfer_p(ps:pe)) * pftfrac(ps:pe)) + + fsr(i) = fsr_pft(ivt) + + ! all these constants are in Li et al. BG (2012a,b;2013) + + IF( hdm_lf(i) > 0.1_r8 )THEN + ! For not bare-soil + IF(.not. isbare(ivt) )THEN + ! For shrub and grass (crop already excluded above) + IF( isshrub(ivt) .or. isgrass(ivt) )THEN !for shurb and grass + lgdp(i) = lgdp(i) + (0.1_r8 + 0.9_r8* & + exp(-1._r8*PI* & + (gdp_lf(i)/8._r8)**0.5_r8))/(1.0_r8-cropf(i)) + lgdp1(i) = lgdp1(i) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*PI* & + (gdp_lf(i)/7._r8)))/(1._r8-cropf(i)) + lpop(i) = lpop(i) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*PI* & + (hdm_lf(i)/450._r8)**0.5_r8))/(1._r8-cropf(i)) + ELSE ! for trees + IF( gdp_lf(i) > 20._r8 )THEN + lgdp(i) =lgdp(i)+occur_hi_gdp_tree/(1._r8-cropf(i)) + lgdp1(i) =lgdp1(i)+0.62_r8/(1._r8-cropf(i)) + ELSE + IF( gdp_lf(i) > 8._r8 )THEN + lgdp(i)=lgdp(i)+0.79_r8/(1._r8-cropf(i)) + lgdp1(i)=lgdp1(i)+0.83_r8/(1._r8-cropf(i)) + ELSE + lgdp(i) = lgdp(i)+1._r8/(1._r8-cropf(i)) + lgdp1(i)=lgdp1(i)+1._r8/(1._r8-cropf(i)) + ENDIF + ENDIF + lpop(i) = lpop(i) + (0.4_r8 + 0.6_r8* & + exp(-1._r8*PI* & + (hdm_lf(i)/125._r8)))/(1._r8-cropf(i)) + ENDIF + ENDIF + ELSE + lgdp(i) = lgdp(i) + 1._r8/(1._r8-cropf(i)) + lgdp1(i) = lgdp1(i) + 1._r8/(1._r8-cropf(i)) + lpop(i) = lpop(i) + 1._r8/(1._r8-cropf(i)) + ENDIF + + fd(i) = fd_pft(ivt) * secsphr / (1.0_r8-cropf(i)) + ENDIF + ! + ! calculate burned area fraction in cropland + ! + baf_crop(i)=0._r8 + + DO m = ps, pe + IF( kmo == 1 .and. kda == 1 .and. idate(3) == 0 )THEN + burndate_p(m) = 10000 ! init. value; actual range [0 365] + ENDIF + ENDDO + + ! For crop + DO m = ps, pe + IF( forc_t(i) >= tfrz .and. iscrop(ivt) .and. & + kmo == abm_lf(i) .and. burndate_p(m) >= 999)THEN ! catch crop burn time + + ! calculate human density impact on ag. fire + fhd = 0.04_r8+0.96_r8*exp(-1._r8*PI*(hdm_lf(i)/350._r8)**0.5_r8) + + ! calculate impact of GDP on ag. fire + fgdp = 0.01_r8+0.99_r8*exp(-1._r8*PI*(gdp_lf(i)/10._r8)) + + ! calculate burned area + fb = max(0.0_r8,min(1.0_r8,(fuelc_crop(i)-lfuel)/(ufuel-lfuel))) + + ! crop fire only for generic crop types at this time + ! managed crops are treated as grasses IF crop model is turned on + baf_crop(i) = baf_crop(i) + cropfire_a1/secsphr*fhd*fgdp + IF( fb*fhd*fgdp > 0._r8)THEN + burndate_p(m) = kda + ENDIF + ENDIF + ENDDO + + ! + ! calculate peatland fire + ! + IF(dlat < borealat )THEN + baf_peatf(i) = non_boreal_peatfire_c/secsphr*max(0._r8, & + min(1._r8,(4.0_r8-prec60(i)*secspday)/ & + 4.0_r8))**2*peatf_lf(i)*(1._r8-fsat(i)) + ELSE + baf_peatf(i) = boreal_peatfire_c/secsphr*exp(-PI*(max(wf2(i),0._r8)/0.3_r8))* & + max(0._r8,min(1._r8,(tsoi17(i)-tfrz)/10._r8))*peatf_lf(i)* & + (1._r8-fsat(i)) + ENDIF + ! + ! calculate other fires + ! + + CALL qsadv(forc_t(i),forc_psrf(i),eq,deqdT,qsatq,qsatqdT) + forc_rh = forc_q(i) / eq + + IF( cropf(i) < 1._r8 )THEN + fuelc(i) = totlitc(i)+totvegc(i)-rootc(i)-fuelc_crop(i)*cropf(i) + DO j = 1, nl_soil + fuelc(i) = fuelc(i)+decomp_cpools_vr(j,i_cwd,i) * dz_soi(j) + ENDDO + fuelc(i) = fuelc(i)/(1._r8-cropf(i)) + fb = max(0.0_r8,min(1.0_r8,(fuelc(i)-lfuel)/(ufuel-lfuel))) + IF (trotr1(i)+trotr2(i)<=0.6_r8) THEN + afuel =min(1._r8,max(0._r8,(fuelc(i)-2500._r8)/(5000._r8-2500._r8))) + arh=1._r8-max(0._r8, min(1._r8,(forc_rh-rh_low)/(rh_hgh-rh_low))) + arh30=1._r8-max(0.7_r8, min(1._r8,rh30(i)/90._r8)) + IF (forc_rh < rh_hgh.and. wtlf(i) > 0._r8 .and. tsoi17(i)> tfrz)THEN + fire_m = ((afuel*arh30+(1._r8-afuel)*arh)**1.5_r8)*((1._r8 -max(0._r8,& + min(1._r8,(btran2/wtlf(i)-bt_min)/(bt_max-bt_min))))**0.5_r8) + ELSE + fire_m = 0._r8 + ENDIF + lh = pot_hmn_ign_counts_alpha*6.8_r8*hdm_lf(i)**(0.43_r8)/30._r8/24._r8 + fs = 1._r8-(0.01_r8+0.98_r8*exp(-0.025_r8*hdm_lf(i))) + ig = (lh+lnfm(i)/(5.16_r8+2.16_r8*cos(PI/180._r8*3*min(60._r8,abs(dlat/PI*180))))*0.22_r8) & + *(1._r8-fs)*(1._r8-cropf(i)) + nfire(i) = ig/secsphr*fb*fire_m*lgdp(i) !fire counts/km2/sec + Lb_lf = 1._r8+10._r8*(1._r8-EXP(-0.06_r8*sqrt(forc_us(i)*forc_us(i)+forc_vs(i)*forc_vs(i)))) + spread_m = fire_m**0.5_r8 + farea_burned(i) = min(1._r8,(g0_fire*spread_m*fsr(i)* & + fd(i)/1000._r8)**2*lgdp1(i)* & + lpop(i)*nfire(i)*PI*Lb_lf+ & + baf_crop(i)+baf_peatf(i)) ! fraction (0-1) per sec + ELSE + farea_burned(i)=min(1._r8,baf_crop(i)+baf_peatf(i)) + ENDIF + ELSE + farea_burned(i) = min(1._r8,baf_crop(i)+baf_peatf(i)) + ENDIF + END SUBROUTINE CNFireArea + +END MODULE MOD_BGC_Veg_CNFireLi2016 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 new file mode 100644 index 0000000000..9fcc35bb6d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 @@ -0,0 +1,139 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNGResp + +!----------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculate growth respiration rate. +! +! !REFERENCES: +! Atkin, O.K., Bahar, N.H., Bloomfield, K.J., Griffin, K.L., Heskel, M.A., Huntingford, C., de la Torre, A.M. +! and Turnbull, M.H., 2017. Leaf respiration in terrestrial biosphere models. Plant respiration: metabolic +! fluxes and carbon balance, pp.107-142. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Const_PFT, only: & + grperc, grpnow, woody + + USE MOD_Vars_PFTimeInvariants, only: pftclass + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + cpool_to_leafc_p , cpool_to_leafc_storage_p , leafc_xfer_to_leafc_p , & + cpool_to_frootc_p , cpool_to_frootc_storage_p , frootc_xfer_to_frootc_p , & + cpool_to_livestemc_p , cpool_to_livestemc_storage_p , livestemc_xfer_to_livestemc_p , & + cpool_to_deadstemc_p , cpool_to_deadstemc_storage_p , deadstemc_xfer_to_deadstemc_p , & + cpool_to_livecrootc_p, cpool_to_livecrootc_storage_p, livecrootc_xfer_to_livecrootc_p, & + cpool_to_deadcrootc_p, cpool_to_deadcrootc_storage_p, deadcrootc_xfer_to_deadcrootc_p, & + cpool_to_grainc_p , cpool_to_grainc_storage_p , grainc_xfer_to_grainc_p , & + cpool_leaf_gr_p , cpool_leaf_storage_gr_p , transfer_leaf_gr_p , & + cpool_froot_gr_p , cpool_froot_storage_gr_p , transfer_froot_gr_p , & + cpool_livestem_gr_p , cpool_livestem_storage_gr_p , transfer_livestem_gr_p , & + cpool_deadstem_gr_p , cpool_deadstem_storage_gr_p , transfer_deadstem_gr_p , & + cpool_livecroot_gr_p , cpool_livecroot_storage_gr_p , transfer_livecroot_gr_p , & + cpool_deadcroot_gr_p , cpool_deadcroot_storage_gr_p , transfer_deadcroot_gr_p , & + cpool_grain_gr_p , cpool_grain_storage_gr_p , transfer_grain_gr_p + + IMPLICIT NONE + + PUBLIC CNGResp + +CONTAINS + + SUBROUTINE CNGResp(i, ps, pe, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! end pft index + integer ,intent(in) :: npcropmin ! first crop pft index + + ! !LOCAL VARIABLES: + real(r8):: respfact_leaf + real(r8):: respfact_froot + real(r8):: respfact_livecroot + real(r8):: respfact_livestem + real(r8):: respfact_leaf_storage + real(r8):: respfact_froot_storage + real(r8):: respfact_livecroot_storage + real(r8):: respfact_livestem_storage + integer :: ivt, m + + + DO m = ps, pe + ivt = pftclass(m) + respfact_leaf = 1.0_r8 + respfact_froot = 1.0_r8 + respfact_livecroot = 1.0_r8 + respfact_livestem = 1.0_r8 + respfact_livecroot = 1.0_r8 + respfact_livestem = 1.0_r8 + respfact_leaf_storage = 1.0_r8 + respfact_froot_storage = 1.0_r8 + respfact_livecroot_storage = 1.0_r8 + respfact_livestem_storage = 1.0_r8 + respfact_livecroot_storage = 1.0_r8 + respfact_livestem_storage = 1.0_r8 + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cpool_livestem_gr_p (m) = cpool_to_livestemc_p (m) * grperc(ivt) * respfact_livestem + + cpool_livestem_storage_gr_p (m) = cpool_to_livestemc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_livestem_storage + + transfer_livestem_gr_p (m) = livestemc_xfer_to_livestemc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_livestem_storage + + cpool_grain_gr_p (m) = cpool_to_grainc_p (m) * grperc(ivt) + + cpool_grain_storage_gr_p (m) = cpool_to_grainc_storage_p (m) * grperc(ivt) * grpnow(ivt) + + transfer_grain_gr_p (m) = grainc_xfer_to_grainc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) + ENDIF + + ! leaf and fine root growth respiration + cpool_leaf_gr_p (m) = cpool_to_leafc_p (m) * grperc(ivt) * respfact_leaf + + cpool_leaf_storage_gr_p (m) = cpool_to_leafc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_leaf_storage + + transfer_leaf_gr_p (m) = leafc_xfer_to_leafc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_leaf_storage + + cpool_froot_gr_p (m) = cpool_to_frootc_p (m) * grperc(ivt) * respfact_froot + + cpool_froot_storage_gr_p (m) = cpool_to_frootc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_froot_storage + + transfer_froot_gr_p (m) = frootc_xfer_to_frootc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_froot_storage + + IF (woody(ivt) == 1._r8) THEN + cpool_livestem_gr_p (m) = cpool_to_livestemc_p (m) * grperc(ivt) * respfact_livestem + + cpool_livestem_storage_gr_p (m) = cpool_to_livestemc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_livestem_storage + + transfer_livestem_gr_p (m) = livestemc_xfer_to_livestemc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_livestem_storage + + cpool_deadstem_gr_p (m) = cpool_to_deadstemc_p (m) * grperc(ivt) + + cpool_deadstem_storage_gr_p (m) = cpool_to_deadstemc_storage_p (m) * grperc(ivt) * grpnow(ivt) + + transfer_deadstem_gr_p (m) = deadstemc_xfer_to_deadstemc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) + + cpool_livecroot_gr_p (m) = cpool_to_livecrootc_p (m) * grperc(ivt) * respfact_livecroot + + cpool_livecroot_storage_gr_p(m) = cpool_to_livecrootc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_livecroot_storage + + transfer_livecroot_gr_p (m) = livecrootc_xfer_to_livecrootc_p(m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_livecroot_storage + + cpool_deadcroot_gr_p (m) = cpool_to_deadcrootc_p (m) * grperc(ivt) + + cpool_deadcroot_storage_gr_p(m) = cpool_to_deadcrootc_storage_p (m) * grperc(ivt) * grpnow(ivt) + + transfer_deadcroot_gr_p (m) = deadcrootc_xfer_to_deadcrootc_p(m) * grperc(ivt) * (1._r8 - grpnow(ivt)) + ENDIF + ENDDO + + END SUBROUTINE CNGResp + +END MODULE MOD_BGC_Veg_CNGResp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 new file mode 100644 index 0000000000..b4f22dfb92 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 @@ -0,0 +1,274 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNGapMortality + +!--------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates the CN fluxes from vegetation to litterfall due to gap mortality. +! The mortality rates are assumed constant for all vegetation function types. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Const_PFT, only: lf_flab, lf_fcel, lf_flig, fr_flab, fr_fcel, fr_flig + USE MOD_BGC_Vars_TimeInvariants, only: & + ! bgc constants + am + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition carbon flux varables (in) + gap_mortality_to_met_c, gap_mortality_to_cel_c , & + gap_mortality_to_lig_c, gap_mortality_to_cwdc , & + + ! decompositionn nitrogen fluxes variables (inout) + gap_mortality_to_met_n, gap_mortality_to_cel_n , & + gap_mortality_to_lig_n, gap_mortality_to_cwdn + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation carbon flux variables + m_leafc_to_litter_p , m_leafc_storage_to_litter_p , m_leafc_xfer_to_litter_p , & + m_frootc_to_litter_p , m_frootc_storage_to_litter_p , m_frootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , m_livestemc_storage_to_litter_p , m_livestemc_xfer_to_litter_p , & + m_deadstemc_to_litter_p , m_deadstemc_storage_to_litter_p , m_deadstemc_xfer_to_litter_p , & + m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & + m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & + m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p , & + + ! vegetation nitrogen flux variables + m_leafn_to_litter_p , m_leafn_storage_to_litter_p , m_leafn_xfer_to_litter_p , & + m_frootn_to_litter_p , m_frootn_storage_to_litter_p , m_frootn_xfer_to_litter_p , & + m_livestemn_to_litter_p , m_livestemn_storage_to_litter_p , m_livestemn_xfer_to_litter_p , & + m_deadstemn_to_litter_p , m_deadstemn_storage_to_litter_p , m_deadstemn_xfer_to_litter_p , & + m_livecrootn_to_litter_p , m_livecrootn_storage_to_litter_p, m_livecrootn_xfer_to_litter_p, & + m_deadcrootn_to_litter_p , m_deadcrootn_storage_to_litter_p, m_deadcrootn_xfer_to_litter_p, & + m_retransn_to_litter_p + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + gresp_storage_p , gresp_xfer_p , & + + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + retransn_p , & + + ! profiles + leaf_prof_p, stem_prof_p, froot_prof_p, croot_prof_p + + IMPLICIT NONE + + PUBLIC CNGapMortality + + PRIVATE CNGap_VegToLitter + +CONTAINS + + SUBROUTINE CNGapMortality(i, ps, pe, nl_soil, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! end pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: npcropmin! first crop pft index + + real(r8):: mort ! rate for fractional mortality (1/s) + integer :: ivt, m + + DO m = ps , pe + ivt = pftclass(m) + + mort = am/(365._r8 * 86400._r8) + + !------------------------------------------------------ + ! pft-level gap mortality carbon fluxes + !------------------------------------------------------ + + ! displayed pools + m_leafc_to_litter_p (m) = leafc_p (m) * mort + m_frootc_to_litter_p (m) = frootc_p (m) * mort + m_livestemc_to_litter_p (m) = livestemc_p (m) * mort + m_livecrootc_to_litter_p (m) = livecrootc_p (m) * mort + m_deadstemc_to_litter_p (m) = deadstemc_p (m) * mort + m_deadcrootc_to_litter_p (m) = deadcrootc_p (m) * mort + + ! storage pools + m_leafc_storage_to_litter_p (m) = leafc_storage_p (m) * mort + m_frootc_storage_to_litter_p (m) = frootc_storage_p (m) * mort + m_livestemc_storage_to_litter_p (m) = livestemc_storage_p (m) * mort + m_deadstemc_storage_to_litter_p (m) = deadstemc_storage_p (m) * mort + m_livecrootc_storage_to_litter_p(m) = livecrootc_storage_p(m) * mort + m_deadcrootc_storage_to_litter_p(m) = deadcrootc_storage_p(m) * mort + m_gresp_storage_to_litter_p (m) = gresp_storage_p (m) * mort + + ! transfer pools + m_leafc_xfer_to_litter_p (m) = leafc_xfer_p (m) * mort + m_frootc_xfer_to_litter_p (m) = frootc_xfer_p (m) * mort + m_livestemc_xfer_to_litter_p (m) = livestemc_xfer_p (m) * mort + m_deadstemc_xfer_to_litter_p (m) = deadstemc_xfer_p (m) * mort + m_livecrootc_xfer_to_litter_p (m) = livecrootc_xfer_p (m) * mort + m_deadcrootc_xfer_to_litter_p (m) = deadcrootc_xfer_p (m) * mort + m_gresp_xfer_to_litter_p (m) = gresp_xfer_p (m) * mort + + !------------------------------------------------------ + ! pft-level gap mortality nitrogen fluxes + !------------------------------------------------------ + + ! displayed pools + m_leafn_to_litter_p (m) = leafn_p (m) * mort + m_frootn_to_litter_p (m) = frootn_p (m) * mort + m_livestemn_to_litter_p (m) = livestemn_p (m) * mort + m_livecrootn_to_litter_p (m) = livecrootn_p (m) * mort + + m_deadstemn_to_litter_p (m) = deadstemn_p (m) * mort + m_deadcrootn_to_litter_p (m) = deadcrootn_p (m) * mort + + IF (ivt < npcropmin) THEN + m_retransn_to_litter_p (m) = retransn_p (m) * mort + ENDIF + + ! storage pools + m_leafn_storage_to_litter_p (m) = leafn_storage_p (m) * mort + m_frootn_storage_to_litter_p (m) = frootn_storage_p (m) * mort + m_livestemn_storage_to_litter_p (m) = livestemn_storage_p (m) * mort + m_deadstemn_storage_to_litter_p (m) = deadstemn_storage_p (m) * mort + m_livecrootn_storage_to_litter_p(m) = livecrootn_storage_p(m) * mort + m_deadcrootn_storage_to_litter_p(m) = deadcrootn_storage_p(m) * mort + + ! transfer pools + m_leafn_xfer_to_litter_p (m) = leafn_xfer_p (m) * mort + m_frootn_xfer_to_litter_p (m) = frootn_xfer_p (m) * mort + m_livestemn_xfer_to_litter_p (m) = livestemn_xfer_p (m) * mort + m_deadstemn_xfer_to_litter_p (m) = deadstemn_xfer_p (m) * mort + m_livecrootn_xfer_to_litter_p (m) = livecrootn_xfer_p (m) * mort + m_deadcrootn_xfer_to_litter_p (m) = deadcrootn_xfer_p (m) * mort + ENDDO + + CALL CNGap_VegToLitter(i, ps, pe, nl_soil) + + END SUBROUTINE CNGapMortality + + SUBROUTINE CNGap_VegToLitter(i, ps, pe, nl_soil) + + integer ,intent(in) :: i + integer ,intent(in) :: ps + integer ,intent(in) :: pe + integer ,intent(in) :: nl_soil + + integer j,m,ivt + real(r8) :: wtcol + + DO j = 1,nl_soil + DO m = ps, pe + ivt = pftclass(m) + wtcol = pftfrac(m) + + ! leaf gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_leafc_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_cel_c(j,i) = gap_mortality_to_cel_c(j,i) + & + m_leafc_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_lig_c(j,i) = gap_mortality_to_lig_c(j,i) + & + m_leafc_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! fine root gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_frootc_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_cel_c(j,i) = gap_mortality_to_cel_c(j,i) + & + m_frootc_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_lig_c(j,i) = gap_mortality_to_lig_c(j,i) + & + m_frootc_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! wood gap mortality carbon fluxes + gap_mortality_to_cwdc(j,i) = gap_mortality_to_cwdc(j,i) + & + (m_livestemc_to_litter_p(m) + m_deadstemc_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_cwdc(j,i) = gap_mortality_to_cwdc(j,i) + & + (m_livecrootc_to_litter_p(m) + m_deadcrootc_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! storage gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_leafc_storage_to_litter_p(m) + m_gresp_storage_to_litter_p(m)) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_frootc_storage_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livestemc_storage_to_litter_p(m) + m_deadstemc_storage_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livecrootc_storage_to_litter_p(m) + m_deadcrootc_storage_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! transfer gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_leafc_xfer_to_litter_p(m) + m_gresp_xfer_to_litter_p(m)) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_frootc_xfer_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livestemc_xfer_to_litter_p(m) + m_deadstemc_xfer_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livecrootc_xfer_to_litter_p(m) + m_deadcrootc_xfer_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! leaf gap mortality nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_leafn_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_cel_n(j,i) = gap_mortality_to_cel_n(j,i) + & + m_leafn_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_lig_n(j,i) = gap_mortality_to_lig_n(j,i) + & + m_leafn_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! fine root litter nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_frootn_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_cel_n(j,i) = gap_mortality_to_cel_n(j,i) + & + m_frootn_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_lig_n(j,i) = gap_mortality_to_lig_n(j,i) + & + m_frootn_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! wood gap mortality nitrogen fluxes + gap_mortality_to_cwdn(j,i) = gap_mortality_to_cwdn(j,i) + & + (m_livestemn_to_litter_p(m) + m_deadstemn_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_cwdn(j,i) = gap_mortality_to_cwdn(j,i) + & + (m_livecrootn_to_litter_p(m) + m_deadcrootn_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! retranslocated N pool gap mortality fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_retransn_to_litter_p(m) * wtcol * leaf_prof_p(j,m) + + ! storage gap mortality nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_leafn_storage_to_litter_p(m) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_frootn_storage_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livestemn_storage_to_litter_p(m) + m_deadstemn_storage_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livecrootn_storage_to_litter_p(m) + m_deadcrootn_storage_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! transfer gap mortality nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_leafn_xfer_to_litter_p(m) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_frootn_xfer_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livestemn_xfer_to_litter_p(m) + m_deadstemn_xfer_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livecrootn_xfer_to_litter_p(m) + m_deadcrootn_xfer_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ENDDO + ENDDO + + END SUBROUTINE CNGap_VegToLitter + +END MODULE MOD_BGC_Veg_CNGapMortality +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 new file mode 100644 index 0000000000..a1a2dc434b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 @@ -0,0 +1,119 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNMResp + +!----------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates plant maintenance respiration +! +! !REFERENCES: +! Atkin OK, Bloomfield KJ, Reich PB, Tjoelker MG, Asner GP, Bonal D et al (2015) Global variability in leaf respiration +! in relation to climate, plant functional types and leaf traits. New Phytologist 206:614-636 +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_BGC_Vars_TimeInvariants, only: & + Q10,br, br_root + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_TimeVariables, only: & + t_soisno, tref + USE MOD_Vars_PFTimeVariables, only: & + laisun_p, laisha_p, sigf_p + USE MOD_BGC_Vars_PFTimeVariables, only: & + frootn_p, livestemn_p, livecrootn_p, grainn_p + USE MOD_Vars_1DPFTFluxes, only: & + respc_p + USE MOD_BGC_Vars_1DPFTFluxes, only: & + leaf_mr_p, froot_mr_p, livestem_mr_p, livecroot_mr_p, grain_mr_p + USE MOD_Const_PFT, only: & + woody, rootfr_p + + IMPLICIT NONE + + PUBLIC CNMResp + +CONTAINS + + SUBROUTINE CNMResp(i, ps, pe, nl_soil, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: npcropmin ! first crop pft index + + ! !LOCAL VARIABLES: + integer :: j ! indices + integer :: ivt, m + + real(r8):: tc ! temperature correction, 2m air temp (unitless) + real(r8):: tcsoi(nl_soil) ! temperature correction by soil layer (unitless) + +! base rate for maintenance respiration is from: +! M. Ryan, 1991. Effects of climate change on plant respiration. +! Ecological Applications, 1(2), 157-167. +! Original expression is br = 0.0106 molC/(molN h) +! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) +! set constants + +! Peter Thornton: 3/13/09 +! Q10 was originally set to 2.0, an arbitrary choice, but reduced to 1.5 as part of the tuning +! to improve seasonal CYCLE of atmospheric CO2 concentration in global +! simulatoins + +! column loop to calculate temperature factors in each soil layer + DO j=1,nl_soil + + ! calculate temperature corrections for each soil layer, for USE in + ! estimating fine root maintenance respiration with depth + tcsoi(j) = Q10**((t_soisno(j,i) - 273.15_r8 - 20.0_r8)/10.0_r8) + ENDDO + + ! calculate maintenance respiration fluxes in + ! gC/m2/s for each of the live plant tissues. + ! Leaf and live wood MR + + tc = Q10**((tref(i) - 273.15_r8 - 20.0_r8)/10.0_r8) + + !RF: acclimation of root and stem respiration fluxes + ! n.b. we DO not yet know IF this is defensible scientifically (awaiting data analysis) + ! turning this on will increase R and decrease productivity in boreal forests, A LOT. :) + + DO m = ps, pe + ivt = pftclass(m) + IF (sigf_p(m) == 1) THEN + leaf_mr_p(m) = respc_p(m) * 12.011_r8 + ELSE !nosno + leaf_mr_p(m) = 0._r8 + ENDIF + + IF (woody(ivt) == 1) THEN + livestem_mr_p (m) = livestemn_p (m)*br*tc + livecroot_mr_p(m) = livecrootn_p(m)*br_root*tc + ELSE IF (ivt >= npcropmin) THEN + livestem_mr_p (m) = livestemn_p (m)*br*tc + grain_mr_p (m) = grainn_p (m)*br*tc + ENDIF + ! soil and patch loop for fine root + + DO j = 1,nl_soil + + ! Fine root MR + ! crootfr(j) sums to 1.0 over all soil layers, and + ! describes the fraction of root mass for carbon that is in each + ! layer. This is used with the layer temperature correction + ! to estimate the total fine root maintenance respiration as a + ! function of temperature and N content. + froot_mr_p(m) = froot_mr_p(m) + frootn_p(m)*br_root*tcsoi(j)*rootfr_p(j,ivt) + ENDDO + ENDDO + + END SUBROUTINE CNMResp + +END MODULE MOD_BGC_Veg_CNMResp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 new file mode 100644 index 0000000000..cdea61366b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 @@ -0,0 +1,193 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNNDynamics + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE simulates the plant biological fixation (Cleveland et al., 1999), +! crop fertilisation (Lawrence et al., 2016, and soy nitrogen fixation (Neitsch et al., 2005). +! +! !REFERENCES: +! Cleveland, C.C., Townsend, A.R., Schimel, D.S., Fisher, H., Howarth, R.W., Hedin, L.O., Perakis, S.S., Latty, E.F., +! Von Fischer, J.C., Elseroad, A., and Wasson, M.F. 1999. Global patterns of terrestrial biological nitrogen (N2) fixation +! in natural ecosystems. Global Biogeochem. Cycles 13:623-645. +! Lawrence, D.M., Hurtt, G.C., Arneth, A., Brovkin, V., Calvin, K.V., Jones, A.D., Jones, C.D., Lawrence, P.J., de +! Noblet-Ducoudré, N., Pongratz, J., Seneviratne, S.I., and Shevliakova, E. 2016. The Land USE Model Intercomparison +! Project (LUMIP) contribution to CMIP6: rationale and experimental design. Geosci. Model Dev. 9:2973-2998. +! DOI:10.5194/gmd-9-2973-2016. +! Neitsch, S.L., Arnold, J.G., Kiniry, J.R., and Williams J.R. 2005. Soil and Water Assessment Tool, +! Theoretical Documentation: Version 2005. Temple, TX. USDA Agricultural Research Service and +! Texas A&M Blackland Research Center. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_Vars_TimeInvariants, only: porsl, psi0, bsw + USE MOD_Vars_TimeVariables, only: h2osoi + + USE MOD_BGC_Vars_1DFluxes, only: fert_to_sminn, soyfixn_to_sminn, nfix_to_sminn + + USE MOD_BGC_Vars_TimeVariables, only: sminn, fpg, lag_npp +#ifdef CROP + USE MOD_BGC_Vars_PFTimeVariables, only: croplive_p, hui_p + USE MOD_BGC_Vars_PFTimeVariables, only: fert_p +#endif + + USE MOD_BGC_Vars_1DPFTFluxes, only: plant_ndemand_p, soyfixn_p + + USE MOD_Vars_Global, only: z_soi, dz_soi, spval + USE MOD_TimeManager + IMPLICIT NONE + + PUBLIC CNNFixation +#ifdef CROP + PUBLIC CNNFert + PUBLIC CNSoyfix +#endif + +CONTAINS + + SUBROUTINE CNNFixation(i,idate) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8) t, dayspyr + + IF(isleapyear(idate(1)))THEN + dayspyr = 366 + ELSE + dayspyr = 365 + ENDIF + + IF (lag_npp(i) /= spval) THEN + ! need to put npp in units of gC/m^2/year here first + t = (1.8_r8 * (1._r8 - exp(-0.003_r8 * lag_npp(i)*(86400._r8 * dayspyr))))/(86400._r8 * dayspyr) + nfix_to_sminn(i) = max(0._r8,t) + ELSE + nfix_to_sminn(i) = 0._r8 + ENDIF + + END SUBROUTINE CNNFixation + +#ifdef CROP + SUBROUTINE CNNFert(i,ps,pe) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + + fert_to_sminn(i) = sum(fert_p(ps:pe)) + + END SUBROUTINE CNNFert + + SUBROUTINE CNSoyfix (i, ps, pe, nl_soil) + ! GPAM Soybean biological N fixation + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8):: fxw,fxn,fxg,fxr ! soil water factor, nitrogen factor, growth stage factor + real(r8):: soy_ndemand ! difference between nitrogen supply and demand + real(r8):: sminnthreshold1, sminnthreshold2 + real(r8):: GDDfracthreshold1, GDDfracthreshold2 + real(r8):: GDDfracthreshold3, GDDfracthreshold4 + integer m, ivt, j + real(r8) :: rwat, swat, rz, watdry, wf, tsw, stsw + + sminnthreshold1 = 30._r8 + sminnthreshold2 = 10._r8 + GDDfracthreshold1 = 0.15_r8 + GDDfracthreshold2 = 0.30_r8 + GDDfracthreshold3 = 0.55_r8 + GDDfracthreshold4 = 0.75_r8 + + rwat = 0._r8 + swat = 0._r8 + rz = 0._r8 + + DO j = 1, nl_soil + IF (z_soi(j)+0.5_r8*dz_soi(j) <= 0.05_r8) THEN + watdry = porsl(j,i) * (316230._r8/(-psi0(j,i))) ** (-1._r8/bsw(j,i)) + rwat = rwat + (h2osoi(j,i)-watdry) * dz_soi(j) + swat = swat + (porsl (j,i)-watdry) * dz_soi(j) + rz = rz + dz_soi(j) + ENDIF + ENDDO + + tsw = rwat/rz + stsw = swat/rz + IF (rz .gt. 0._r8 .and. stsw .gt. 0._r8) THEN + wf = tsw/stsw + ELSE + wf = 0._r8 + ENDIF + + DO m = ps, pe + ivt = pftclass(m) + IF(croplive_p(m) .and. (ivt == 23 .or. ivt == 24 .or. ivt == 77 .or. ivt == 78))THEN + + ! difference between supply and demand + + IF(fpg(i) .lt. 1._r8) THEN + soy_ndemand = plant_ndemand_p(m) - plant_ndemand_p(m) * fpg(i) + + ! fixation depends on nitrogen, soil water, and growth stage + ! soil water factor + + fxw = wf / 0.85_r8 + + ! soil nitrogen factor (Beth says: CHECK UNITS) + + IF (sminn(i) .gt. sminnthreshold1) THEN + fxn = 0._r8 + ELSE IF (sminn(i) > sminnthreshold2 .and. sminn(i) <= sminnthreshold1) THEN + fxn = 1.5_r8 - .005_r8 * (sminn(i) * 10._r8) + ELSE IF (sminn(i) <= sminnthreshold2) THEN + fxn = 1._r8 + ENDIF + + ! growth stage factor + + IF (hui_p(m) <= GDDfracthreshold1) THEN + fxg = 0._r8 + ELSE IF (hui_p(m) > GDDfracthreshold1 .and. hui_p(m) <= GDDfracthreshold2) THEN + fxg = 6.67_r8 * hui_p(m) - 1._r8 + ELSE IF (hui_p(m) > GDDfracthreshold2 .and. hui_p(m) <= GDDfracthreshold3) THEN + fxg = 1._r8 + ELSE IF (hui_p(m) > GDDfracthreshold3 .and. hui_p(m) <= GDDfracthreshold4) THEN + fxg = 3.75_r8 - 5._r8 * hui_p(m) + ELSE + fxg = 0._r8 + ENDIF + + ! calculate the nitrogen fixed by the soybean + + fxr = max(0._r8, min(1._r8, fxw, fxn) * fxg) + soyfixn_p(m) = min(fxr * soy_ndemand, soy_ndemand) + + ELSE ! IF nitrogen demand met, no fixation + + soyfixn_p(m) = 0._r8 + + ENDIF + + ELSE ! IF not live soybean, no fixation + + soyfixn_p(m) = 0._r8 + + ENDIF + ENDDO + + soyfixn_to_sminn(i) = sum(soyfixn_p(ps:pe)*pftfrac(ps:pe)) + + END SUBROUTINE CNSoyfix +#endif + +END MODULE MOD_BGC_Veg_CNNDynamics +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 new file mode 100644 index 0000000000..8513dde698 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 @@ -0,0 +1,1615 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNPhenology + +!-------------------- +! !DESCRIPTION: +! This MODULE holds all phenology related subroutines for natural vegetation and crop in the C and N cycle. +! CoLM Phenology controls the gain and loss of leaf carbon. LAI is then updated from leaf carbon. +! So, the seasonal variation in LAI can be simulated for different phenology types. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. +! Fang Li, 2022, implemented GPAM crop model in this MODULE. +! +! !USES: + USE MOD_Const_PFT, only: & + isevg , issed , isstd , leaf_long, woody , leafcn , frootcn, livewdcn, deadwdcn, & + lflitcn, lf_flab, lf_fcel, lf_flig , fr_flab, fr_fcel, fr_flig, & + + ! crop variables + lfemerg, mxmat, grnfill, baset + + USE MOD_BGC_Vars_TimeInvariants, only: & + ndays_on , ndays_off , fstor2tran, crit_dayl , crit_onset_fdd, crit_onset_swi, & + crit_offset_fdd , crit_offset_swi, soilpsi_on, soilpsi_off, lwtop, rice2pdt + + USE MOD_Vars_Global, only: & + !crop variables + nswheat , nirrig_swheat , nsugarcane , nirrig_sugarcane , & + nwwheat , nirrig_wwheat , ntmp_corn , nirrig_tmp_corn , & + ntrp_corn , nirrig_trp_corn , nmiscanthus , nirrig_miscanthus , & + nswitchgrass , nirrig_switchgrass, ncotton , nirrig_cotton , & + nrice , nirrig_rice , ntmp_soybean, nirrig_tmp_soybean, & + ntrp_soybean , nirrig_trp_soybean, & + spval + USE MOD_Const_Physical, only: tfrz + + USE MOD_Vars_TimeVariables, only: & + t_soisno, smp + + USE MOD_BGC_Vars_TimeVariables, only: & + dayl, prev_dayl, prec10, prec60, prec365, prec_today, prec_daily, accumnstep + + USE MOD_Vars_PFTimeVariables, only: & + tref_p ,tlai_p + + USE MOD_BGC_Vars_PFTimeVariables, only: & + tempavg_tref_p , annavg_tref_p , gdd0_p , gdd8_p , & + gdd10_p , gdd020_p , gdd820_p , gdd1020_p , nyrs_crop_active_p, & + bglfr_p , bgtr_p , lgsf_p , offset_flag_p , offset_counter_p , & + onset_flag_p , onset_counter_p, onset_gddflag_p, onset_gdd_p , onset_fdd_p , & + onset_swi_p , offset_fdd_p , offset_swi_p , dormant_flag_p, & + + prev_leafc_to_litter_p , prev_frootc_to_litter_p , days_active_p , & + + leafc_p , frootc_p , livestemc_p , & + livestemn_p , livecrootc_p , grainc_p, grainn_p , & + + leafc_storage_p , frootc_storage_p , livestemc_storage_p , & + deadstemc_storage_p, livecrootc_storage_p, deadcrootc_storage_p, & + leafn_storage_p , frootn_storage_p , livestemn_storage_p , & + deadstemn_storage_p, livecrootn_storage_p, deadcrootn_storage_p, & + + leafc_xfer_p , frootc_xfer_p , livestemc_xfer_p , & + deadstemc_xfer_p , livecrootc_xfer_p , deadcrootc_xfer_p , & + leafn_xfer_p , frootn_xfer_p , livestemn_xfer_p , & + deadstemn_xfer_p , livecrootn_xfer_p , deadcrootn_xfer_p , & + gresp_storage_p , & + +! crop variables +#ifdef CROP + cropplant_p , idop_p , a5tmin_p , a10tmin_p , t10_p , & + cumvd_p , vf_p , cphase_p , fert_counter_p , & + croplive_p , gddplant_p , harvdate_p , gddmaturity_p , & + hui_p , peaklai_p , & + tref_min_p , tref_max_p , tref_min_inst_p , tref_max_inst_p , & + manunitro_p , fertnitro_p , plantdate_p , fert_p , &! input from files +#endif + + leaf_prof_p , froot_prof_p , & + cropseedc_deficit_p, cropseedn_deficit_p + + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + livestemc_to_deadstemc_p , livecrootc_to_deadcrootc_p , & + + leafc_storage_to_xfer_p , frootc_storage_to_xfer_p , & + livestemc_storage_to_xfer_p , deadstemc_storage_to_xfer_p , & + livecrootc_storage_to_xfer_p , deadcrootc_storage_to_xfer_p , & + gresp_storage_to_xfer_p , & + + leafc_xfer_to_leafc_p , frootc_xfer_to_frootc_p , & + livestemc_xfer_to_livestemc_p , deadstemc_xfer_to_deadstemc_p , & + livecrootc_xfer_to_livecrootc_p, deadcrootc_xfer_to_deadcrootc_p, & + + livestemn_to_deadstemn_p , livecrootn_to_deadcrootn_p , & + livestemn_to_retransn_p , livecrootn_to_retransn_p , & + + leafn_storage_to_xfer_p , frootn_storage_to_xfer_p , & + livestemn_storage_to_xfer_p , deadstemn_storage_to_xfer_p , & + livecrootn_storage_to_xfer_p , deadcrootn_storage_to_xfer_p , & + + leafn_xfer_to_leafn_p , frootn_xfer_to_frootn_p , & + livestemn_xfer_to_livestemn_p , deadstemn_xfer_to_deadstemn_p , & + livecrootn_xfer_to_livecrootn_p, deadcrootn_xfer_to_deadcrootn_p, & + cpool_to_leafc_p , cpool_to_frootc_p , & + leafc_to_litter_p , frootc_to_litter_p , & + leafn_to_litter_p , frootn_to_litter_p , & + leafn_to_retransn_p , & + + crop_seedc_to_leaf_p , crop_seedn_to_leaf_p , & + grainc_to_seed_p , grainn_to_seed_p , & + grainc_to_food_p , grainn_to_food_p , & + cpool_to_grainc_p , npool_to_grainn_p , & + livestemc_to_litter_p , livestemn_to_litter_p , & + cpool_to_livestemc_p + + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_1DFluxes, only: & + phenology_to_met_c , phenology_to_cel_c , phenology_to_lig_c, & + phenology_to_met_n , phenology_to_cel_n , phenology_to_lig_n, & + grainc_to_cropprodc, grainn_to_cropprodn + + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl + + USE MOD_TimeManager + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_FERT + USE MOD_BGC_Daylength, only: daylength + USE MOD_SPMD_Task + + IMPLICIT NONE + + PUBLIC CNPhenology + + integer, parameter :: NOT_Planted = 999 ! If not planted yet in year + integer, parameter :: NOT_Harvested = 999 ! If not harvested yet in year + +CONTAINS + + SUBROUTINE CNPhenology(i,ps,pe,nl_soil,idate,dz_soi,deltim,dlat,npcropmin,phase) + +! !DESCRIPTION: +! The main driver of phenology model. Two phases are included: +! 1) phase==1: Calculates the phenology-related carbon and nitroge pool size changes, +! especially when specific phenology trigure is on (eg. leaf onset and offset). +! The pool size change rates is calculated from phase 2. +! 2) phase==2: Calculates phenology climatic diagnostics for onset and offset trigures +! Calculates the pool size change rates of all phenology processes. +! +! ! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + IMPLICIT NONE + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dlat ! latitude (degrees) + integer ,intent(in) :: npcropmin ! first crop pft index + real(r8),intent(in) :: dz_soi(nl_soil)! thicknesses of each soil layer + integer ,intent(in) :: phase ! indicator of the SUBROUTINE options (see DESCRIPTION above) + + real(r8) dayspyr + integer h ! 1 for north hemsiphere; 2 for south hemisphere + + IF(isleapyear(idate(1)))THEN + dayspyr = 366 + ELSE + dayspyr = 365 + ENDIF + + IF ( phase == 1 ) THEN + CALL CNPhenologyClimate (i,ps,pe,idate(1:3),deltim,dayspyr,npcropmin,nl_soil,dz_soi,dlat) + + CALL CNEvergreenPhenology (i,ps,pe,deltim,dayspyr) + + CALL CNSeasonDecidPhenology(i,ps,pe,idate(1:3),deltim,dayspyr,dlat) + + CALL CNStressDecidPhenology(i,ps,pe,deltim,dayspyr) + +#ifdef CROP + IF(dlat >= 0)THEN + h = 1 + ELSE + h = 2 + ENDIF + CALL CropPhenology(i,ps,pe,idate(1:3),h,deltim,dayspyr,npcropmin) +#endif + ELSE IF ( phase == 2 ) THEN + ! the same onset and offset routines are called regardless of + ! phenology type - they depend only on onset_flag, offset_flag, bglfr, and bgtr + + CALL CNOnsetGrowth(i,ps,pe,deltim) + + CALL CNOffsetLitterfall(i,ps,pe,deltim,npcropmin) + + CALL CNBackgroundLitterfall(i,ps,pe) + + CALL CNLivewoodTurnover(i,ps,pe) + + CALL CNLitterToColumn(i,ps,pe,nl_soil,npcropmin) + ELSE + write(*,*) 'bad phenology phase' + ENDIF + + END SUBROUTINE CNPhenology + + SUBROUTINE CNPhenologyClimate (i,ps,pe,idate,deltim,dayspyr,npcropmin,nl_soil,dz_soi,dlat) + +! !DESCRIPTION: +! This SUBROUTINE summaries climate statistics, such as annual averaged temperature, +! maximum and minimum temperature, averaged precipitation over recent 10 days, 60 days and 365 days, +! growing degree days above 0, 8, and 10 degrees celsius. These climate statistics will be +! used in following phenology simulations. +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + ! + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: idate(3) ! current date (year, days of the year, seconds of the day) + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! days per year (days) + integer ,intent(in) :: npcropmin! first crop pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(nl_soil) ! thicknesses of each soil layer + real(r8),intent(in) :: dlat ! latitude (degrees) + + ! !LOCAL VARIABLES: + real(r8), parameter :: yravg = 20.0_r8 ! length of years to average for gdd + real(r8), parameter :: yravgm1 = yravg-1.0_r8 ! minus 1 of above + integer :: m,ivt + logical , parameter :: isconst_baset = .true. ! .true. for constant base temperature + ! .false. for latidinal varied base temperature + real(r8) stepperday, nsteps + integer month, mday + !----------------------------------------------------------------------- + + ! set time steps + + stepperday = 86400._r8 / deltim + DO m = ps , pe + tempavg_tref_p(m) = tempavg_tref_p(m) + tref_p(m) * (deltim/86400._r8/dayspyr) +#ifdef CROP + IF(idate(3) .eq. deltim .or. tref_max_inst_p(m) .eq. spval)THEN + tref_max_inst_p(m) = tref_p(m) + ELSE + tref_max_inst_p(m) = max(tref_max_inst_p(m) , tref_p(m)) + ENDIF + + IF(idate(3) .eq. deltim .or. tref_min_inst_p(m) .eq. spval)THEN + tref_min_inst_p(m) = tref_p(m) + ELSE + tref_min_inst_p(m) = min(tref_min_inst_p(m) , tref_p(m)) + ENDIF + IF(idate(3) .eq. 86400 - nint(deltim))THEN + tref_max_p(m) = tref_max_inst_p(m) + tref_min_p(m) = tref_min_inst_p(m) + ENDIF +#endif + ENDDO + + accumnstep(i) = accumnstep(i) + 1 + prec_today(i) = forc_prc(i) + forc_prl(i) + + nsteps = amin1(10._r8 * stepperday, accumnstep(i)) + prec10 (i) = ( prec10 (i) * (nsteps - 1) + prec_today(i) ) / nsteps + + nsteps = amin1(60._r8 * stepperday, accumnstep(i)) + prec60 (i) = ( prec60 (i) * (nsteps - 1) + prec_today(i) ) / nsteps + + nsteps = amin1(365._r8 * stepperday, accumnstep(i)) + prec365 (i) = ( prec365(i) * (nsteps - 1) + prec_today(i) ) / nsteps + + CALL julian2monthday(idate(1),idate(2),month,mday) + !calculate gdd0,gdd8,gdd10,gddplant for GPAM crop phenology F. Li + DO m = ps , pe + ivt = pftclass(m) + IF(((month .ge. 4 .and. month .le. 9) .and. dlat .ge. 0) .or. & + ((month .gt. 9 .or. month .lt. 4) .and. dlat .lt. 0)) THEN + gdd0_p (m) = gdd0_p (m) + max(0._r8, tref_p(m) - 273.15) * deltim / 86400._r8 + gdd8_p (m) = gdd8_p (m) + max(0._r8, tref_p(m) - 273.15 - 8) * deltim / 86400._r8 + gdd10_p(m) = gdd10_p(m) + max(0._r8, tref_p(m) - 273.15 - 10) * deltim / 86400._r8 + ENDIF +#ifdef CROP + IF(croplive_p(m))THEN + IF((ivt == nwwheat .or. ivt == nirrig_wwheat).and.cphase_p(m) == 2._r8)THEN + gddplant_p(m) = gddplant_p(m) +vf_p(m) * max(0._r8, & + tref_p(m) - (273.15 + baset(ivt))) * deltim / 86400._r8 + ELSE + gddplant_p(m) = gddplant_p(m) + max(0._r8, & + tref_p(m) - (273.15 + baset(ivt))) * deltim / 86400._r8 + ENDIF + ELSE + gddplant_p(m) = 0._r8 + ENDIF +#endif + ENDDO + + !calculate gdd020,gdd820,gdd1020 for gddmaturity in GPAM crop phenology F. Li + DO m = ps , pe + ivt = pftclass(m) + IF (idate(2) == 1 .and. idate(3) == deltim)THEN + IF(nyrs_crop_active_p(m) == 0) THEN ! YR 1: + gdd020_p(m) = 0._r8 ! set gdd..20 variables to 0 + gdd820_p(m) = 0._r8 ! and crops will not be planted + gdd1020_p(m) = 0._r8 + ELSE + IF (nyrs_crop_active_p(m) == 1) THEN ! <-- END of YR 1 + gdd020_p(m) = gdd0_p(m) ! <-- END of YR 1 + gdd820_p(m) = gdd8_p(m) ! <-- END of YR 1 + gdd1020_p(m) = gdd10_p(m) ! <-- END of YR 1 + ELSE + gdd020_p(m) = (yravgm1* gdd020_p(m) + gdd0_p(m)) / yravg ! gdd..20 must be long term avgs + gdd820_p(m) = (yravgm1* gdd820_p(m) + gdd8_p(m)) / yravg ! so ignore results for yrs 1 & 2 + gdd1020_p(m) = (yravgm1* gdd1020_p(m) + gdd10_p(m)) / yravg + ENDIF + ENDIF ! <-- END of YR 1 + gdd0_p (m) = 0._r8 + gdd8_p (m) = 0._r8 + gdd10_p(m) = 0._r8 + ENDIF + IF (isendofyear(idate,deltim)) THEN ! <-- END of EVERY YR: + nyrs_crop_active_p(m) = nyrs_crop_active_p(m) + 1 + ENDIF + ENDDO + + END SUBROUTINE CNPhenologyClimate + + + SUBROUTINE CNEvergreenPhenology (i,ps,pe,deltim,dayspyr) +! +! !DESCRIPTION: +! Evergreen phenology assumes CN stock from vegetation storage pool go to transfer +! pool steadily with a constant rate 0.0002. All CN stock from transfer pool go to +! display pool immediately when it receives CN flow from storage pool. in recent version, +! Evergreen types only allocate NPP or N uptake to display pools. Storage and transfer +! pool stay 0 over whole simulation periods. Leaf litter fall simulation depends on a +! background turnover, which a constant parameter leaf_long was assigned (from MOD_Const_PFT.F90) +! to indicate the background turnover rates. +! +! Allocation NPP -> DISPLAY pool -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + +! +! !ARGUMENTS: + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! Days per year + ! + ! !LOCAL VARIABLES: + + real(r8):: tranr + real(r8):: t1 ! temporary variable + integer :: ivt, m + !----------------------------------------------------------------------- + + DO m = ps , pe + ivt = pftclass(m) + IF (isevg(ivt)) THEN + bglfr_p(m) = 1._r8/(leaf_long(ivt) * dayspyr * 86400._r8) + bgtr_p(m) = 0._r8 + lgsf_p(m) = 0._r8 + ENDIF + ENDDO + + DO m = ps , pe + ivt = pftclass(m) + IF (isevg(ivt)) THEN + + tranr=0.0002_r8 + ! set carbon fluxes for shifting storage pools to transfer pools + leafc_storage_to_xfer_p(m) = tranr * leafc_storage_p(m)/deltim + frootc_storage_to_xfer_p(m) = tranr * frootc_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = tranr * livestemc_storage_p(m)/deltim + deadstemc_storage_to_xfer_p(m) = tranr * deadstemc_storage_p(m)/deltim + livecrootc_storage_to_xfer_p(m) = tranr * livecrootc_storage_p(m)/deltim + deadcrootc_storage_to_xfer_p(m) = tranr * deadcrootc_storage_p(m)/deltim + gresp_storage_to_xfer_p(m) = tranr * gresp_storage_p(m)/deltim + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = tranr * leafn_storage_p(m)/deltim + frootn_storage_to_xfer_p(m) = tranr * frootn_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = tranr * livestemn_storage_p(m)/deltim + deadstemn_storage_to_xfer_p(m) = tranr * deadstemn_storage_p(m)/deltim + livecrootn_storage_to_xfer_p(m) = tranr * livecrootn_storage_p(m)/deltim + deadcrootn_storage_to_xfer_p(m) = tranr * deadcrootn_storage_p(m)/deltim + ENDIF + + t1 = 1.0_r8 / deltim + + leafc_xfer_to_leafc_p(m) = t1 * leafc_xfer_p(m) + frootc_xfer_to_frootc_p(m) = t1 * frootc_xfer_p(m) + + leafn_xfer_to_leafn_p(m) = t1 * leafn_xfer_p(m) + frootn_xfer_to_frootn_p(m) = t1 * frootn_xfer_p(m) + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = t1 * livestemc_xfer_p(m) + deadstemc_xfer_to_deadstemc_p(m) = t1 * deadstemc_xfer_p(m) + livecrootc_xfer_to_livecrootc_p(m) = t1 * livecrootc_xfer_p(m) + deadcrootc_xfer_to_deadcrootc_p(m) = t1 * deadcrootc_xfer_p(m) + + livestemn_xfer_to_livestemn_p(m) = t1 * livestemn_xfer_p(m) + deadstemn_xfer_to_deadstemn_p(m) = t1 * deadstemn_xfer_p(m) + livecrootn_xfer_to_livecrootn_p(m) = t1 * livecrootn_xfer_p(m) + deadcrootn_xfer_to_deadcrootn_p(m) = t1 * deadcrootn_xfer_p(m) + ENDIF + + ENDIF ! END of IF (isevg(ivt(p)) == 1._r8) THEN + + ENDDO ! END of pft loop + + END SUBROUTINE CNEvergreenPhenology + + SUBROUTINE CNSeasonDecidPhenology(i,ps,pe,idate,deltim,dayspyr,dlat) + +! +! !DESCRIPTION: +! This routine handles the seasonal deciduous phenology code (temperate deciduous +! vegetation that has only one growing season per year). Seasonal deciduous phenology +! assumes 0 background turnover rates. NPP or N uptake only allocated to storage pool. +! Display pool size changes occur only in onset and offset period. All CN stock from +! transfer pool go to display pool immediately when it receives CN flow from storage +! pool. +! +! Onset period: +! Allocation NPP -> STORAGE pool -> XFER pool -> DISPLAY pool +! Offset period: +! DISPLAY pool -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + +! !ARGUMENTS: + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: idate(3)! current date (year, day of the year, second of the day) + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! Days per year + real(r8),intent(in) :: dlat ! latitude (degree) + + ! + ! !LOCAL VARIABLES: + real(r8):: ws_flag !winter-summer solstice flag (0 or 1) + real(r8):: crit_onset_gdd !critical onset growing degree-day sum + real(r8):: soilt + integer :: idate2_last + integer :: ivt, m + !----------------------------------------------------------------------- + + + idate2_last = idate(2) - 1 + IF(idate2_last .le. 0)idate2_last=idate2_last+365 + prev_dayl(i)=daylength(dlat,idate2_last) + dayl(i) =daylength(dlat,idate(2)) + + DO m = ps , pe + ivt = pftclass(m) + IF (issed(ivt)) THEN + + ! set background litterfall rate, background transfer rate, and + ! long growing season factor to 0 for seasonal deciduous types + bglfr_p(m) = 0._r8 + bgtr_p(m) = 0._r8 + lgsf_p(m) = 0._r8 + + ! onset gdd sum from Biome-BGC, v4.1.2 + crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_tref_p(m) - 273.15_r8)) + + ! set flag for solstice period (winter->summer = 1, summer->winter = 0) + IF (dayl(i) >= prev_dayl(i)) THEN + ws_flag = 1._r8 + ELSE + ws_flag = 0._r8 + ENDIF + + ! update offset_counter and test for the END of the offset period + IF (offset_flag_p(m) == 1.0_r8) THEN + ! decrement counter for offset period + offset_counter_p(m) = offset_counter_p(m) - deltim + + ! IF this is the END of the offset_period, reset phenology + ! flags and indices + IF (abs(offset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_offset_cleanup(i) + ! inlined during vectorization + + offset_flag_p(m) = 0._r8 + offset_counter_p(m) = 0._r8 + dormant_flag_p(m) = 1._r8 + days_active_p(m) = 0._r8 + + ! reset the previous timestep litterfall flux memory + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ! update onset_counter and test for the END of the onset period + IF (onset_flag_p(m) == 1.0_r8) THEN + ! decrement counter for onset period + onset_counter_p(m) = onset_counter_p(m) - deltim + + ! IF this is the END of the onset period, reset phenology + ! flags and indices + IF (abs(onset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_onset_cleanup(i) + ! inlined during vectorization + + onset_flag_p(m) = 0.0_r8 + onset_counter_p(m) = 0.0_r8 + ! set all transfer growth rates to 0.0 + leafc_xfer_to_leafc_p(m) = 0.0_r8 + frootc_xfer_to_frootc_p(m) = 0.0_r8 + leafn_xfer_to_leafn_p(m) = 0.0_r8 + frootn_xfer_to_frootn_p(m) = 0.0_r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = 0.0_r8 + deadstemc_xfer_to_deadstemc_p(m) = 0.0_r8 + livecrootc_xfer_to_livecrootc_p(m) = 0.0_r8 + deadcrootc_xfer_to_deadcrootc_p(m) = 0.0_r8 + livestemn_xfer_to_livestemn_p(m) = 0.0_r8 + deadstemn_xfer_to_deadstemn_p(m) = 0.0_r8 + livecrootn_xfer_to_livecrootn_p(m) = 0.0_r8 + deadcrootn_xfer_to_deadcrootn_p(m) = 0.0_r8 + ENDIF + ! set transfer pools to 0.0 + leafc_xfer_p(m) = 0.0_r8 + leafn_xfer_p(m) = 0.0_r8 + frootc_xfer_p(m) = 0.0_r8 + frootn_xfer_p(m) = 0.0_r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_p(m) = 0.0_r8 + livestemn_xfer_p(m) = 0.0_r8 + deadstemc_xfer_p(m) = 0.0_r8 + deadstemn_xfer_p(m) = 0.0_r8 + livecrootc_xfer_p(m) = 0.0_r8 + livecrootn_xfer_p(m) = 0.0_r8 + deadcrootc_xfer_p(m) = 0.0_r8 + deadcrootn_xfer_p(m) = 0.0_r8 + ENDIF + ENDIF + ENDIF + + ! test for switching from dormant period to growth period + IF (dormant_flag_p(m) == 1.0_r8) THEN + + ! Test to turn on growing degree-day sum, IF off. + ! switch on the growing degree day sum on the winter solstice + + IF (onset_gddflag_p(m) == 0._r8 .and. ws_flag == 1._r8) THEN + onset_gddflag_p(m) = 1._r8 + onset_gdd_p(m) = 0._r8 + ENDIF + + ! Test to turn off growing degree-day sum, IF on. + ! This test resets the growing degree day sum IF it gets past + ! the summer solstice without reaching the threshold value. + ! in that CASE, it will take until the next winter solstice + ! before the growing degree-day summation starts again. + + IF (onset_gddflag_p(m) == 1._r8 .and. ws_flag == 0._r8) THEN + onset_gddflag_p(m) = 0._r8 + onset_gdd_p(m) = 0._r8 + ENDIF + + ! IF the gdd flag is set, and IF the soil is above freezing + ! THEN accumulate growing degree days for onset trigger + + soilt = t_soisno(3,i) + IF (onset_gddflag_p(m) == 1.0_r8 .and. soilt > 273.15_r8) THEN + onset_gdd_p(m) = onset_gdd_p(m) + (soilt-273.15_r8)*(deltim/86400._r8) + ENDIF + + ! set onset_flag IF critical growing degree-day sum is exceeded + IF (onset_gdd_p(m) > crit_onset_gdd) THEN + onset_flag_p(m) = 1.0_r8 + dormant_flag_p(m) = 0.0_r8 + onset_gddflag_p(m) = 0.0_r8 + onset_gdd_p(m) = 0.0_r8 + onset_counter_p(m) = ndays_on * 86400._r8 + + ! move all the storage pools into transfer pools, + ! WHERE they will be transfered to displayed growth over the onset period. + ! this code was originally handled with CALL cn_storage_to_xfer(p) + ! inlined during vectorization + + ! set carbon fluxes for shifting storage pools to transfer pools + leafc_storage_to_xfer_p(m) = fstor2tran * leafc_storage_p(m)/deltim + frootc_storage_to_xfer_p(m) = fstor2tran * frootc_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = fstor2tran * livestemc_storage_p(m)/deltim + deadstemc_storage_to_xfer_p(m) = fstor2tran * deadstemc_storage_p(m)/deltim + livecrootc_storage_to_xfer_p(m) = fstor2tran * livecrootc_storage_p(m)/deltim + deadcrootc_storage_to_xfer_p(m) = fstor2tran * deadcrootc_storage_p(m)/deltim + gresp_storage_to_xfer_p(m) = fstor2tran * gresp_storage_p(m)/deltim + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = fstor2tran * leafn_storage_p(m)/deltim + frootn_storage_to_xfer_p(m) = fstor2tran * frootn_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = fstor2tran * livestemn_storage_p(m)/deltim + deadstemn_storage_to_xfer_p(m) = fstor2tran * deadstemn_storage_p(m)/deltim + livecrootn_storage_to_xfer_p(m) = fstor2tran * livecrootn_storage_p(m)/deltim + deadcrootn_storage_to_xfer_p(m) = fstor2tran * deadcrootn_storage_p(m)/deltim + ENDIF + ENDIF + + ! test for switching from growth period to offset period + ELSE IF (offset_flag_p(m) == 0.0_r8) THEN + + ! only begin to test for offset daylength once past the summer sol + IF (ws_flag == 0._r8 .and. dayl(i) < crit_dayl) THEN + offset_flag_p(m) = 1._r8 + offset_counter_p(m) = ndays_off * 86400._r8 + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ENDIF ! ENDIF seasonal deciduous + ENDDO + + END SUBROUTINE CNSeasonDecidPhenology + + SUBROUTINE CNStressDecidPhenology(i,ps,pe,deltim,dayspyr) + +! +! !DESCRIPTION: +! This routine handles the stress deciduous phenology code (deciduous vegetation with +! one or more growing season per year). NPP or N uptake only allocated to storage pool. +! +! Onset period: +! Allocation NPP -> STORAGE pool -> XFER pool -> DISPLAY pool +! Offset period: +! DISPLAY pool -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! days per year + + ! !LOCAL VARIABLES: + real(r8),parameter :: secspqtrday = 86400._r8 / 4 ! seconds per quarter day + real(r8):: crit_onset_gdd ! degree days for onset trigger + real(r8):: soilt ! temperature of top soil layer + real(r8):: psi ! soil water potential [MPa] + real(r8):: rain_threshold ! rain threshold for leaf on [mm] + logical :: additional_onset_condition ! additional condition for leaf onset + integer :: ivt, m + !----------------------------------------------------------------------- + + + ! specify rain threshold for leaf onset + rain_threshold = 20._r8 + + DO m = ps , pe + ivt = pftclass(m) + IF (isstd(ivt)) THEN + soilt = t_soisno(3,i) + psi = smp(3,i) * 1.e-5 ! mmH2O -> MPa + + ! onset gdd sum from Biome-BGC, v4.1.2 + crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_tref_p(m) - 273.15_r8)) + + ! update offset_counter and test for the END of the offset period + IF (offset_flag_p(m) == 1._r8) THEN + ! decrement counter for offset period + offset_counter_p(m) = offset_counter_p(m) - deltim + + ! IF this is the END of the offset_period, reset phenology + ! flags and indices + IF (abs(offset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_offset_cleanup(i) + ! inlined during vectorization + offset_flag_p(m) = 0._r8 + offset_counter_p(m) = 0._r8 + dormant_flag_p(m) = 1._r8 + days_active_p(m) = 0._r8 + + ! reset the previous timestep litterfall flux memory + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ! update onset_counter and test for the END of the onset period + IF (onset_flag_p(m) == 1.0_r8) THEN + ! decrement counter for onset period + onset_counter_p(m) = onset_counter_p(m) - deltim + + ! IF this is the END of the onset period, reset phenology + ! flags and indices + IF (abs(onset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_onset_cleanup(i) + ! inlined during vectorization + onset_flag_p(m) = 0._r8 + onset_counter_p(m) = 0._r8 + ! set all transfer growth rates to 0.0 + leafc_xfer_to_leafc_p(m) = 0._r8 + frootc_xfer_to_frootc_p(m) = 0._r8 + leafn_xfer_to_leafn_p(m) = 0._r8 + frootn_xfer_to_frootn_p(m) = 0._r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = 0._r8 + deadstemc_xfer_to_deadstemc_p(m) = 0._r8 + livecrootc_xfer_to_livecrootc_p(m) = 0._r8 + deadcrootc_xfer_to_deadcrootc_p(m) = 0._r8 + livestemn_xfer_to_livestemn_p(m) = 0._r8 + deadstemn_xfer_to_deadstemn_p(m) = 0._r8 + livecrootn_xfer_to_livecrootn_p(m) = 0._r8 + deadcrootn_xfer_to_deadcrootn_p(m) = 0._r8 + ENDIF + ! set transfer pools to 0.0 + leafc_xfer_p(m) = 0._r8 + leafn_xfer_p(m) = 0._r8 + frootc_xfer_p(m) = 0._r8 + frootn_xfer_p(m) = 0._r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_p(m) = 0._r8 + livestemn_xfer_p(m) = 0._r8 + deadstemc_xfer_p(m) = 0._r8 + deadstemn_xfer_p(m) = 0._r8 + livecrootc_xfer_p(m) = 0._r8 + livecrootn_xfer_p(m) = 0._r8 + deadcrootc_xfer_p(m) = 0._r8 + deadcrootn_xfer_p(m) = 0._r8 + ENDIF + ENDIF + ENDIF + + ! test for switching from dormant period to growth period + IF (dormant_flag_p(m) == 1._r8) THEN + + ! keep track of the number of freezing degree days in this + ! dormancy period (only IF the freeze flag has not previously been set + ! for this dormancy period + + IF (onset_gddflag_p(m) == 0._r8 .and. soilt < 273.15_r8) onset_fdd_p(m) = onset_fdd_p(m) + deltim/86400._r8 + + ! IF the number of freezing degree days exceeds a critical value, + ! THEN onset will require both wet soils and a critical soil + ! temperature sum. IF this CASE is triggered, reset any previously + ! accumulated value in onset_swi, so that onset now depends on + ! the accumulated soil water index following the freeze trigger + + IF (onset_fdd_p(m) > crit_onset_fdd) THEN + onset_gddflag_p(m) = 1._r8 + onset_fdd_p(m) = 0._r8 + onset_swi_p(m) = 0._r8 + ENDIF + + ! IF the freeze flag is set, and IF the soil is above freezing + ! THEN accumulate growing degree days for onset trigger + + IF (onset_gddflag_p(m) == 1._r8 .and. soilt > 273.15_r8) THEN + onset_gdd_p(m) = onset_gdd_p(m) + (soilt-273.15_r8)*deltim/86400._r8 + ENDIF + + ! IF soils are wet, accumulate soil water index for onset trigger + additional_onset_condition = .true. + ! IF additional constraint condition not met, set to false + IF ((prec10(i) * (3600.0_r8*10.0_r8*24.0_r8)) < rain_threshold) THEN + additional_onset_condition = .false. + ENDIF + + IF (psi >= soilpsi_on) THEN + onset_swi_p(m) = onset_swi_p(m) + deltim/86400._r8 + ENDIF + + ! IF critical soil water index is exceeded, set onset_flag, and + ! THEN test for soil temperature criteria + + ! Adding in Kyla's rainfall trigger when fun on. RF. prec10 (mm/s) needs to be higher than 8mm over 10 days. + + IF (onset_swi_p(m) > crit_onset_swi.and. additional_onset_condition) THEN + onset_flag_p(m) = 1._r8 + + ! only check soil temperature criteria IF freeze flag set since + ! beginning of last dormancy. IF freeze flag set and growing + ! degree day sum (since freeze trigger) is lower than critical + ! value, THEN override the onset_flag set from soil water. + + IF (onset_gddflag_p(m) == 1._r8 .and. onset_gdd_p(m) < crit_onset_gdd) onset_flag_p(m) = 0._r8 + ENDIF + + ! only allow onset IF dayl > 6hrs + IF (onset_flag_p(m) == 1._r8 .and. dayl(i) <= secspqtrday) THEN + onset_flag_p(m) = 0._r8 + ENDIF + + ! IF this is the beginning of the onset period + ! THEN reset the phenology flags and indices + + IF (onset_flag_p(m) == 1._r8) THEN + dormant_flag_p(m) = 0._r8 + days_active_p(m) = 0._r8 + onset_gddflag_p(m) = 0._r8 + onset_fdd_p(m) = 0._r8 + onset_gdd_p(m) = 0._r8 + onset_swi_p(m) = 0._r8 + onset_counter_p(m) = ndays_on * 86400._r8 + + ! CALL SUBROUTINE to move all the storage pools into transfer pools, + ! WHERE they will be transfered to displayed growth over the onset period. + ! this code was originally handled with CALL cn_storage_to_xfer(i) + ! inlined during vectorization + + ! set carbon fluxes for shifting storage pools to transfer pools + leafc_storage_to_xfer_p(m) = fstor2tran * leafc_storage_p(m)/deltim + frootc_storage_to_xfer_p(m) = fstor2tran * frootc_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = fstor2tran * livestemc_storage_p(m)/deltim + deadstemc_storage_to_xfer_p(m) = fstor2tran * deadstemc_storage_p(m)/deltim + livecrootc_storage_to_xfer_p(m) = fstor2tran * livecrootc_storage_p(m)/deltim + deadcrootc_storage_to_xfer_p(m) = fstor2tran * deadcrootc_storage_p(m)/deltim + gresp_storage_to_xfer_p(m) = fstor2tran * gresp_storage_p(m)/deltim + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = fstor2tran * leafn_storage_p(m)/deltim + frootn_storage_to_xfer_p(m) = fstor2tran * frootn_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = fstor2tran * livestemn_storage_p(m)/deltim + deadstemn_storage_to_xfer_p(m) = fstor2tran * deadstemn_storage_p(m)/deltim + livecrootn_storage_to_xfer_p(m) = fstor2tran * livecrootn_storage_p(m)/deltim + deadcrootn_storage_to_xfer_p(m) = fstor2tran * deadcrootn_storage_p(m)/deltim + ENDIF + ENDIF + + ! test for switching from growth period to offset period + ELSE IF (offset_flag_p(m) == 0._r8) THEN + + ! IF soil water potential lower than critical value, accumulate + ! as stress in offset soil water index + + IF (psi <= soilpsi_off) THEN + offset_swi_p(m) = offset_swi_p(m) + deltim/86400._r8 + + ! IF the offset soil water index exceeds critical value, and + ! IF this is not the middle of a previously initiated onset period, + ! THEN set flag to start the offset period and reset index variables + + IF (offset_swi_p(m) >= crit_offset_swi .and. onset_flag_p(m) == 0._r8) offset_flag_p(m) = 1._r8 + + ! IF soil water potential higher than critical value, reduce the + ! offset water stress index. By this mechanism, there must be a + ! sustained period of water stress to initiate offset. + + ELSE IF (psi >= soilpsi_on) THEN + offset_swi_p(m) = offset_swi_p(m) - deltim/86400._r8 + offset_swi_p(m) = max(offset_swi_p(m),0._r8) + ENDIF + + ! decrease freezing day accumulator for warm soil + IF (offset_fdd_p(m) > 0._r8 .and. soilt > 273.15_r8) THEN + offset_fdd_p(m) = offset_fdd_p(m) - deltim/86400._r8 + offset_fdd_p(m) = max(0._r8, offset_fdd_p(m)) + ENDIF + + ! increase freezing day accumulator for cold soil + IF (soilt <= 273.15_r8) THEN + offset_fdd_p(m) = offset_fdd_p(m) + deltim/86400._r8 + + ! IF freezing degree day sum is greater than critical value, initiate offset + IF (offset_fdd_p(m) > crit_offset_fdd .and. onset_flag_p(m) == 0._r8) offset_flag_p(m) = 1._r8 + ENDIF + + ! force offset IF daylength is < 6 hrs + IF (dayl(i) <= secspqtrday) THEN + offset_flag_p(m) = 1._r8 + ENDIF + + ! IF this is the beginning of the offset period + ! THEN reset flags and indices + IF (offset_flag_p(m) == 1._r8) THEN + offset_fdd_p(m) = 0._r8 + offset_swi_p(m) = 0._r8 + offset_counter_p(m) = ndays_off * 86400._r8 + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ! keep track of number of days since last dormancy for control on + ! fraction of new growth to send to storage for next growing season + + IF (dormant_flag_p(m) == 0.0_r8) THEN + days_active_p(m) = days_active_p(m) + deltim/86400._r8 + ENDIF + + ! calculate long growing season factor (lgsf) + ! only begin to calculate a lgsf greater than 0.0 once the number + ! of days active exceeds days/year. + lgsf_p(m) = max(min(3.0_r8*(days_active_p(m)-leaf_long(ivt)*dayspyr )/dayspyr, 1._r8),0._r8) + ! RosieF. 5 Nov 2015. Changed this such that the increase in leaf turnover is faster after + ! trees enter the 'fake evergreen' state. Otherwise, they have a whole year of + ! cheating, with less litterfall than they should have, resulting in very high LAI. + ! Further, the 'fake evergreen' state (WHERE lgsf>0) is entered at the END of a single leaf lifespan + ! and not a whole year. The '3' is arbitrary, given that this entire system is quite abstract. + ! set background litterfall rate, when not in the phenological offset period + IF (offset_flag_p(m) == 1._r8) THEN + bglfr_p(m) = 0._r8 + ELSE + ! calculate the background litterfall rate (bglfr) + ! in units 1/s, based on leaf longevity (yrs) and correction for long growing season + + bglfr_p(m) = (1._r8/(leaf_long(ivt)*dayspyr*86400._r8))*lgsf_p(m) + ENDIF + + ! set background transfer rate when active but not in the phenological onset period + IF (onset_flag_p(m) == 1._r8) THEN + bgtr_p(m) = 0._r8 + ELSE + ! the background transfer rate is calculated as the rate that would result + ! in complete turnover of the storage pools in one year at steady state, + ! once lgsf has reached 1.0 (after 730 days active). + + bgtr_p(m) = (1._r8/(dayspyr*86400._r8))*lgsf_p(m) + + ! set carbon fluxes for shifting storage pools to transfer pools + + ! reduced the amount of stored carbon flowing to display pool by only counting the delta + ! between leafc and leafc_store in the flux. RosieF, Nov5 2015. + leafc_storage_to_xfer_p(m) = max(0.0_r8,(leafc_storage_p(m)-leafc_p(m))) * bgtr_p(m) + frootc_storage_to_xfer_p(m) = max(0.0_r8,(frootc_storage_p(m)-frootc_p(m))) * bgtr_p(m) + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = livestemc_storage_p(m) * bgtr_p(m) + deadstemc_storage_to_xfer_p(m) = deadstemc_storage_p(m) * bgtr_p(m) + livecrootc_storage_to_xfer_p(m) = livecrootc_storage_p(m) * bgtr_p(m) + deadcrootc_storage_to_xfer_p(m) = deadcrootc_storage_p(m) * bgtr_p(m) + gresp_storage_to_xfer_p(m) = gresp_storage_p(m) * bgtr_p(m) + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = leafn_storage_p(m) * bgtr_p(m) + frootn_storage_to_xfer_p(m) = frootn_storage_p(m) * bgtr_p(m) + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = livestemn_storage_p(m) * bgtr_p(m) + deadstemn_storage_to_xfer_p(m) = deadstemn_storage_p(m) * bgtr_p(m) + livecrootn_storage_to_xfer_p(m) = livecrootn_storage_p(m) * bgtr_p(m) + deadcrootn_storage_to_xfer_p(m) = deadcrootn_storage_p(m) * bgtr_p(m) + ENDIF + ENDIF + + ENDIF ! ENDIF stress deciduous + ENDDO !END pft loop + + END SUBROUTINE CNStressDecidPhenology + +#ifdef CROP + SUBROUTINE CropPhenology(i,ps,pe,idate,h,deltim,dayspyr,npcropmin) + +! !DESCRIPTION: +! GPAM crop phenology and code from CN to +! handle CN fluxes during the phenological onset & offset periods. +! +! ORIGINAL: The Community Land Model version 5.0 (CLM5.0) +! +! REVISION: F. Li, 2022, implemented GPAM in CoLM. + + integer, intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: idate(1:3)! current date (year, day of the year, second of the day) + integer ,intent(in) :: h ! hemisphere indicator: 1 for north hemisphere; 2 for south hemisphere + real(r8),intent(in) :: deltim ! timestep in seconds + real(r8),intent(in) :: dayspyr ! days per year + integer ,intent(in) :: npcropmin ! first crop pft index + + ! LOCAL VARAIBLES: + integer kyr ! current year + integer kmo ! month of year (1, ..., 12) + integer kda ! day of month (1, ..., 31) + integer mcsec + integer jday + integer fp,m ! patch indices + integer c ! column indices + integer g ! gridcell indices + integer idpp ! number of days past planting + real(r8) ndays_on ! number of days to fertilize + integer :: jdayyrstart(2) + real(r8) :: initial_seed_at_planting = 3._r8 ! Initial seed at planting + integer ivt + + !------------------------------------------------------------------------ + + jdayyrstart(1) = 1 + jdayyrstart(2) = 182 + + jday = idate(2) + mcsec = idate(3) + ! get time info + + ndays_on = 20._r8 ! number of days to fertilize + + ! background litterfall and transfer rates; long growing season factor + DO m = ps, pe + ivt = pftclass(m) + IF(ivt >= npcropmin)THEN + bglfr_p(m) = 0._r8 ! this value changes later in a crop's life CYCLE + bgtr_p(m) = 0._r8 + lgsf_p(m) = 0._r8 + + + ! plantdate is read in + ! determine IF the cft is planted in this time step + IF ( (.not. croplive_p(m)) .and. (.not. cropplant_p(m)) ) THEN + IF (jday == int(plantdate_p(m))) THEN + cumvd_p(m) = 0._r8 + vf_p(m) = 0._r8 + croplive_p(m) = .true. + cropplant_p(m) = .true. + idop_p(m) = jday + harvdate_p(m) = NOT_Harvested + leafc_xfer_p(m) = initial_seed_at_planting + leafn_xfer_p(m) = leafc_xfer_p(m) / leafcn(ivt) ! with onset + crop_seedc_to_leaf_p(m) = leafc_xfer_p(m)/deltim + crop_seedn_to_leaf_p(m) = leafn_xfer_p(m)/deltim + ENDIF + ENDIF + ! calculate gddmaturity + IF(croplive_p(m))THEN + IF (ivt == nwwheat .or. ivt == nirrig_wwheat)THEN + gddmaturity_p(m) = 0.42_r8 * gdd1020_p(m) + 440._r8 + ENDIF + IF ( ivt == ntmp_soybean .or. ivt == nirrig_tmp_soybean .or. & + ivt == ntrp_soybean .or. ivt == nirrig_trp_soybean) THEN + gddmaturity_p(m) = 0.30_r8 * gdd1020_p(m) + 710._r8 + ENDIF + IF (ivt == ntmp_corn .or. ivt == nirrig_tmp_corn .or. & + ivt == ntrp_corn .or. ivt == nirrig_trp_corn .or. & + ivt == nsugarcane .or. ivt == nirrig_sugarcane .or. & + ivt == nmiscanthus .or. ivt == nirrig_miscanthus .or. & + ivt == nswitchgrass .or. ivt == nirrig_switchgrass) THEN + gddmaturity_p(m) = 0.30_r8 * gdd820_p(m) + 816._r8 + ENDIF + IF (ivt == nswheat .or. ivt == nirrig_swheat .or. & + ivt == ncotton .or. ivt == nirrig_cotton)THEN + gddmaturity_p(m) = 0.24_r8 * gdd020_p(m) + 1349._r8 + ENDIF + IF (ivt == nrice .or. ivt == nirrig_rice) THEN + gddmaturity_p(m) = 0.35_r8 * gdd020_p(m) + 587._r8 + ENDIF + hui_p(m)=gddplant_p(m)/gddmaturity_p(m) + ENDIF + + ! all of the phenology changes are based on hui + + ! Phase 1: Planting to leaf emergence + ! Phase 2: Leaf emergence to beginning of grain fill (LAI increase) + ! Phase 3: Grain fill to physiological maturity and harvest (LAI decline) + ! Harvest: IF gdd past grain fill initiation exceeds limit + ! or number of days past planting reaches a maximum, the crop has + ! reached physiological maturity and plant is harvested; + ! --- --- --- + + onset_flag_p(m) = 0._r8 ! CN terminology to trigger certain + offset_flag_p(m) = 0._r8 ! carbon and nitrogen transfers + + IF (croplive_p(m)) THEN + cphase_p(m) = 1._r8 + ! days past planting may determine harvest + + IF (jday >= idop_p(m)) THEN + idpp = jday - idop_p(m) + ELSE + idpp = int(dayspyr) + jday - idop_p(m) + ENDIF + + ! onset_counter initialized to zero when .not. croplive + ! offset_counter relevant only at time step of harvest + + onset_counter_p(m) = onset_counter_p(m) - deltim + + ! enter phase 2 onset for one time step: + ! transfer seed carbon to leaf emergence + + ! IF (peaklai_p(m) >= 1) THEN + ! hui_p(m) = max(hui_p(m),grnfill(ivt)) + ! ENDIF + + IF (hui_p(m) >= lfemerg(ivt) .and. hui_p(m) < grnfill(ivt) .and. idpp < mxmat(ivt)) THEN + cphase_p(m) = 2._r8 + ! CALL vernalization IF winter temperate cereal planted, living, and the + ! vernalization factor is not 1; + ! vf affects the calculation of gddplant + IF ( vf_p(m) /= 1._r8 .and. (ivt == nwwheat .or. ivt == nirrig_wwheat) .and. hui_p(m) < 0.8_r8 * grnfill(ivt)) THEN + CALL vernalization(i,m,deltim) + ENDIF + + !fertilization + + IF (abs(onset_counter_p(m)) > 1.e-6_r8) THEN + onset_flag_p(m) = 1._r8 + onset_counter_p(m) = deltim + fert_counter_p(m) = ndays_on * 86400. + IF (ndays_on .gt. 0) THEN + IF(DEF_USE_FERT)THEN + fert_p(m) = (manunitro_p(m) + fertnitro_p(m))/ fert_counter_p(m) + ELSE + fert_p(m) = 0._r8 + ENDIF + ELSE + fert_p(m) = 0._r8 + ENDIF + ELSE + ! this ensures no re-entry to onset of phase2 + ! b/c onset_counter(p) = onset_counter(p) - deltim + ! at every time step + + onset_counter_p(m) = deltim + ENDIF + + ! enter harvest for one time step: + ! - transfer live biomass to litter and to crop yield + ! - send xsmrpool to the atmosphere + ! IF onset and harvest needed to last longer than one timestep + ! the onset_counter would change from dt and you'd need to make + ! changes to the offset SUBROUTINE below + + ELSE IF (hui_p(m) >= 1._r8 .or. idpp >= mxmat(ivt)) THEN + IF (harvdate_p(m) >= NOT_Harvested) harvdate_p(m) = jday + croplive_p(m) = .false. ! no re-entry in greater IF-block + cropplant_p(m)=.false. + cphase_p(m) = 4._r8 + hui_p(m)=0._r8 + IF (tlai_p(m) > 0._r8) THEN ! plant had emerged before harvest + offset_flag_p(m) = 1._r8 + offset_counter_p(m) = deltim + ELSE ! plant never emerged from the ground + ! Revert planting transfers; this will replenish the crop seed deficit. + ! We subtract from any existing value in crop_seedc_to_leaf / + ! crop_seedn_to_leaf in the unlikely event that we enter this block of + ! code in the same time step WHERE the planting transfer originally + ! occurred. + crop_seedc_to_leaf_p(m) = crop_seedc_to_leaf_p(m) - leafc_xfer_p(m)/deltim + crop_seedn_to_leaf_p(m) = crop_seedn_to_leaf_p(m) - leafn_xfer_p(m)/deltim + leafc_xfer_p(m) = 0._r8 + leafn_xfer_p(m) = leafc_xfer_p(m) / leafcn(ivt) + ENDIF + + ! enter phase 3 WHILE previous criteria fail and next is true; + ! in terms of order, phase 3 occurs before harvest, but when + ! harvest *can* occur, we want it to have first priority. + ! AgroIBIS uses a complex formula for lai decline. + ! USE CN's simple formula at least as a place holder (slevis) + + ELSE IF (hui_p(m) >= grnfill(ivt)) THEN + cphase_p(m) = 3._r8 + bglfr_p(m) = 1._r8/(leaf_long(ivt)*dayspyr*86400.) + ENDIF + + ! continue fertilizer application WHILE in phase 2; + ! assumes that onset of phase 2 took one time step only + + IF (fert_counter_p(m) <= 0._r8) THEN + fert_p(m) = 0._r8 + ELSE ! continue same fert application every timestep + fert_counter_p(m) = fert_counter_p(m) - deltim + ENDIF + + ELSE ! crop not live + ! next 2 lines conserve mass IF leaf*_xfer > 0 due to interpinic. + ! We subtract from any existing value in crop_seedc_to_leaf / + ! crop_seedn_to_leaf in the unlikely event that we enter this block of + ! code in the same time step WHERE the planting transfer originally + ! occurred. + crop_seedc_to_leaf_p(m) = crop_seedc_to_leaf_p(m) - leafc_xfer_p(m)/deltim + crop_seedn_to_leaf_p(m) = crop_seedn_to_leaf_p(m) - leafn_xfer_p(m)/deltim + onset_counter_p(m) = 0._r8 + leafc_xfer_p(m) = 0._r8 + leafn_xfer_p(m) = leafc_xfer_p(m) / leafcn(ivt) + IF(DEF_USE_FERT)THEN + fert_p(m) = 0._r8 + ENDIF + ENDIF ! croplive + ELSE + fert_p(m) = 0._r8 + ENDIF + ENDDO ! prognostic crops loop + + END SUBROUTINE CropPhenology +#endif + + !--------------------------------------------------------- + SUBROUTINE CNOnsetGrowth(i,ps,pe,deltim) + +! !DESCRIPTION: +! Calculates flux from transfer CN to display CN during onset period. +! Transfer CN -> DISPLAY CN + +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + + ! !LOCAL VARIABLES: + real(r8):: t1 ! temporary variable + integer :: ivt, m + + ! only calculate these fluxes during onset period + + DO m = ps, pe + ivt = pftclass(m) + IF (onset_flag_p(m) == 1._r8) THEN + + ! The transfer rate is a linearly decreasing FUNCTION of time, + ! going to zero on the last timestep of the onset period + + IF (onset_counter_p(m) == deltim) THEN + t1 = 1.0_r8 / deltim + ELSE + t1 = 2.0_r8 / (onset_counter_p(m)) + ENDIF + leafc_xfer_to_leafc_p(m) = t1 * leafc_xfer_p(m) + frootc_xfer_to_frootc_p(m) = t1 * frootc_xfer_p(m) + leafn_xfer_to_leafn_p(m) = t1 * leafn_xfer_p(m) + frootn_xfer_to_frootn_p(m) = t1 * frootn_xfer_p(m) + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = t1 * livestemc_xfer_p(m) + deadstemc_xfer_to_deadstemc_p(m) = t1 * deadstemc_xfer_p(m) + livecrootc_xfer_to_livecrootc_p(m) = t1 * livecrootc_xfer_p(m) + deadcrootc_xfer_to_deadcrootc_p(m) = t1 * deadcrootc_xfer_p(m) + livestemn_xfer_to_livestemn_p(m) = t1 * livestemn_xfer_p(m) + deadstemn_xfer_to_deadstemn_p(m) = t1 * deadstemn_xfer_p(m) + livecrootn_xfer_to_livecrootn_p(m) = t1 * livecrootn_xfer_p(m) + deadcrootn_xfer_to_deadcrootn_p(m) = t1 * deadcrootn_xfer_p(m) + ENDIF + + ENDIF ! ENDIF onset period + + ! calculate the background rate of transfer growth (used for stress + ! deciduous algorithm). in this CASE, all of the mass in the transfer + ! pools should be moved to displayed growth in each timestep. + + IF (bgtr_p(m) > 0._r8) THEN + leafc_xfer_to_leafc_p(m) = leafc_xfer_p(m) / deltim + frootc_xfer_to_frootc_p(m) = frootc_xfer_p(m) / deltim + leafn_xfer_to_leafn_p(m) = leafn_xfer_p(m) / deltim + frootn_xfer_to_frootn_p(m) = frootn_xfer_p(m) / deltim + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = livestemc_xfer_p(m) / deltim + deadstemc_xfer_to_deadstemc_p(m) = deadstemc_xfer_p(m) / deltim + livecrootc_xfer_to_livecrootc_p(m) = livecrootc_xfer_p(m) / deltim + deadcrootc_xfer_to_deadcrootc_p(m) = deadcrootc_xfer_p(m) / deltim + livestemn_xfer_to_livestemn_p(m) = livestemn_xfer_p(m) / deltim + deadstemn_xfer_to_deadstemn_p(m) = deadstemn_xfer_p(m) / deltim + livecrootn_xfer_to_livecrootn_p(m) = livecrootn_xfer_p(m) / deltim + deadcrootn_xfer_to_deadcrootn_p(m) = deadcrootn_xfer_p(m) / deltim + ENDIF + ENDIF ! ENDIF bgtr + ENDDO + + END SUBROUTINE CNOnsetGrowth + + SUBROUTINE CNOffsetLitterfall(i,ps,pe,deltim,npcropmin) +! !DESCRIPTION: +! Calculates flux from display CN to litter CN during offset period. +! DISPLAY CN -> litter CN + +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: npcropmin ! first crop pft index + + real(r8) :: t1 ! temporary variable + real(r8) :: denom ! temporary variable for divisor + real(r8) :: ntovr_leaf + real(r8) :: fr_leafn_to_litter ! fraction of the nitrogen turnover that goes to litter; remaining fraction is retranslocated + integer :: ivt, m + + DO m = ps, pe + ivt = pftclass(m) + ! only calculate fluxes during offset period + IF (offset_flag_p(m) == 1._r8) THEN + + IF (offset_counter_p(m) == deltim) THEN + t1 = 1.0_r8 / deltim + leafc_to_litter_p(m) = t1 * leafc_p(m) + cpool_to_leafc_p(m) + frootc_to_litter_p(m) = t1 * frootc_p(m) + cpool_to_frootc_p(m) + ! this assumes that offset_counter == dt for crops + ! IF this were ever changed, we'd need to add code to the "ELSE" + IF (ivt >= npcropmin) THEN + ! Replenish the seed deficits from grain, IF there is enough + ! available grain. (IF there is not enough available grain, the seed + ! deficits will accumulate until there is eventually enough grain to + ! replenish them.) + grainc_to_seed_p(m) = t1 * min(-cropseedc_deficit_p(m), grainc_p(m)) + grainn_to_seed_p(m) = t1 * min(-cropseedn_deficit_p(m), grainn_p(m)) + ! Send the remaining grain to the food product pool + grainc_to_food_p(m) = t1 * grainc_p(m) + cpool_to_grainc_p(m) - grainc_to_seed_p(m) + grainn_to_food_p(m) = t1 * grainn_p(m) + npool_to_grainn_p(m) - grainn_to_seed_p(m) + + livestemc_to_litter_p(m) = t1 * livestemc_p(m) + cpool_to_livestemc_p(m) + ENDIF + ELSE + t1 = deltim * 2.0_r8 / (offset_counter_p(m) * offset_counter_p(m)) + leafc_to_litter_p(m) = prev_leafc_to_litter_p(m) + t1*(leafc_p(m) - prev_leafc_to_litter_p(m)*offset_counter_p(m)) + frootc_to_litter_p(m) = prev_frootc_to_litter_p(m) + t1*(frootc_p(m) - prev_frootc_to_litter_p(m)*offset_counter_p(m)) + + ENDIF + + leafn_to_litter_p(m) = leafc_to_litter_p(m) / lflitcn(ivt) + leafn_to_retransn_p(m) = (leafc_to_litter_p(m) / leafcn(ivt)) - leafn_to_litter_p(m) + + + ! calculate fine root N litterfall (no retranslocation of fine root N) + frootn_to_litter_p(m) = frootc_to_litter_p(m) / frootcn(ivt) + + IF (ivt >= npcropmin) THEN + ! NOTE(slevis, 2014-12) results in -ve livestemn and -ve totpftn + !X! livestemn_to_litter(p) = livestemc_to_litter(p) / livewdcn(ivt(p)) + ! NOTE(slevis, 2014-12) Beth Drewniak suggested this instead + livestemn_to_litter_p(m) = livestemn_p(m) / deltim + ENDIF + + ! SAVE the current litterfall fluxes + prev_leafc_to_litter_p(m) = leafc_to_litter_p(m) + prev_frootc_to_litter_p(m) = frootc_to_litter_p(m) + + ENDIF ! ENDIF offset period + ENDDO + + END SUBROUTINE CNOffsetLitterfall + + SUBROUTINE CNBackgroundLitterfall(i,ps,pe) + +! !DESCRIPTION: +! Calculate leaf and fine root background turnover. +! DISPLAY -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + + ! !LOCAL VARIABLES: + real(r8) :: fr_leafn_to_litter ! fraction of the nitrogen turnover that goes to litter; remaining fraction is retranslocated + real(r8) :: ntovr_leaf + real(r8) :: denom + integer :: ivt, m + !----------------------------------------------------------------------- + + DO m = ps , pe + ! only calculate these fluxes IF the background litterfall rate is non-zero + ivt = pftclass(m) + IF (bglfr_p(m) > 0._r8) THEN + ! units for bglfr are already 1/s + leafc_to_litter_p(m) = bglfr_p(m) * leafc_p(m) + frootc_to_litter_p(m) = bglfr_p(m) * frootc_p(m) + ! calculate the leaf N litterfall and retranslocation + leafn_to_litter_p(m) = leafc_to_litter_p(m) / lflitcn(ivt) + leafn_to_retransn_p(m) = (leafc_to_litter_p(m) / leafcn(ivt)) - leafn_to_litter_p(m) + + frootn_to_litter_p(m) = frootc_to_litter_p(m) / frootcn(ivt) + ENDIF + ENDDO + + END SUBROUTINE CNBackgroundLitterfall + + SUBROUTINE CNLivewoodTurnover(i,ps,pe) + +! !DESCRIPTION: +! Livewood transfer to deadwood each year +! +! !ORIGINAL: +! Community Land Model Version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2022, Revise the code to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + + ! !LOCAL VARIABLES: + real(r8):: ctovr ! temporary variable for carbon turnover + real(r8):: ntovr ! temporary variable for nitrogen turnover + integer :: ivt, m + !----------------------------------------------------------------------- + + DO m = ps, pe + ! only calculate these fluxes for woody types + ivt = pftclass(m) + IF (woody(ivt) > 0._r8) THEN + + ! live stem to dead stem turnover + + ctovr = livestemc_p(m) * lwtop + ntovr = ctovr / livewdcn(ivt) + livestemc_to_deadstemc_p(m) = ctovr + livestemn_to_deadstemn_p(m) = ctovr / deadwdcn(ivt) + + livestemn_to_retransn_p(m) = ntovr - livestemn_to_deadstemn_p(m) + !matrix for livestemn_to_retransn will be added in allocation SUBROUTINE + + ! live coarse root to dead coarse root turnover + + ctovr = livecrootc_p(m) * lwtop + ntovr = ctovr / livewdcn(ivt) + livecrootc_to_deadcrootc_p(m) = ctovr + livecrootn_to_deadcrootn_p(m) = ctovr / deadwdcn(ivt) + + livecrootn_to_retransn_p(m) = ntovr - livecrootn_to_deadcrootn_p(m) + ENDIF + ENDDO ! END pft loop + + END SUBROUTINE CNLivewoodTurnover + + SUBROUTINE CNGrainToProductPools(i,ps,pe) +! !DESCRIPTION: +! Summary crop production C & N from pft to patch +! +! !ORIGINAL: +! Community Land Model Version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2022, revised the code to be compatible with CoLM code structure + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + + integer m + real(r8) wtcol + + DO m = ps, pe + wtcol = pftfrac(m) + grainc_to_cropprodc(i) = grainc_to_cropprodc(i) + grainc_to_food_p(m) * wtcol + grainn_to_cropprodn(i) = grainn_to_cropprodn(i) + grainn_to_food_p(m) * wtcol + ENDDO + + END SUBROUTINE CNGrainToProductPools + + SUBROUTINE CNLitterToColumn(i,ps,pe,nl_soil,npcropmin) + +! !DESCRIPTION: +! Calculate column level litterfall flux from pft level litterfall. + +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: npcropmin ! first crop pft index + + integer j + integer ivt,m + real(r8):: wtcol + + DO j = 1, nl_soil + DO m = ps,pe + ivt = pftclass(m) + wtcol = pftfrac(m) + ! leaf litter carbon fluxes + phenology_to_met_c(j,i) = phenology_to_met_c(j,i) & + + leafc_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_c(j,i) = phenology_to_cel_c(j,i) & + + leafc_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_c(j,i) = phenology_to_lig_c(j,i) & + + leafc_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! leaf litter nitrogen fluxes + phenology_to_met_n(j,i) = phenology_to_met_n(j,i) & + + leafn_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_n(j,i) = phenology_to_cel_n(j,i) & + + leafn_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_n(j,i) = phenology_to_lig_n(j,i) & + + leafn_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! fine root litter carbon fluxes + phenology_to_met_c(j,i) = phenology_to_met_c(j,i) & + + frootc_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_cel_c(j,i) = phenology_to_cel_c(j,i) & + + frootc_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_lig_c(j,i) = phenology_to_lig_c(j,i) & + + frootc_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! fine root litter nitrogen fluxes + phenology_to_met_n(j,i) = phenology_to_met_n(j,i) & + + frootn_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_cel_n(j,i) = phenology_to_cel_n(j,i) & + + frootn_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_lig_n(j,i) = phenology_to_lig_n(j,i) & + + frootn_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! agroibis puts crop stem litter together with leaf litter + ! so I've used the leaf lf_f* parameters instead of making + ! new ones for now (slevis) + ! also for simplicity I've put "food" into the litter pools + + IF (ivt >= npcropmin) THEN ! add livestemc to litter + ! stem litter carbon fluxes + phenology_to_met_c(j,i) = phenology_to_met_c(j,i) & + + livestemc_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_c(j,i) = phenology_to_cel_c(j,i) & + + livestemc_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_c(j,i) = phenology_to_lig_c(j,i) & + + livestemc_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! stem litter nitrogen fluxes + phenology_to_met_n(j,i) = phenology_to_met_n(j,i) & + + livestemn_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_n(j,i) = phenology_to_cel_n(j,i) & + + livestemn_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_n(j,i) = phenology_to_lig_n(j,i) & + + livestemn_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ENDIF + ENDDO !END pft loop + ENDDO! END soil level loop + + END SUBROUTINE CNLitterToColumn + +#ifdef CROP + SUBROUTINE vernalization(i,m,deltim) +! !DESCRIPTION +! vernalizatoin for winter wheat. + +! ORITINAL: F. Li's GPAM model + integer, intent(in) :: i ! patch index + integer, intent(in) :: m ! pft index + real(r8),intent(in) :: deltim ! time step in seconds + ! LOCAL VARAIBLES: + real(r8) vtmin,vtopt,vtmax ! vernalization minimum, optimum, maximum temperature + real(r8) alpha ! parameter in calculating vernalization rate + real(r8) tc ! t_ref2m in degree C + real(r8) dt ! convert dtime from sec to hour + + +! for all equations - temperatures must be in degrees (C) +! calculate temperature of crown of crop (e.g., 3 cm soil temperature) +! snow depth in centimeters + + vtmin=-1.3_r8 + vtopt=4.9_r8 + vtmax=15.7_r8 + dt=deltim/3600.0_r8 !dt is the time step in hour + alpha=log(2._r8)/log((vtmax-vtmin)/(vtopt-vtmin)) + + tc = tref_p(m)-tfrz + IF(tc >=vtmin .and. tc <= vtmax) THEN + cumvd_p(m)=cumvd_p(m) + (2._r8*((tc-vtmin)**alpha)*(vtopt-vtmin)**alpha & + - (tc-vtmin)**(2._r8*alpha))/(vtopt-vtmin)**(2._r8*alpha)*(dt/24._r8) + ENDIF + + vf_p(m)=(cumvd_p(m)**5._r8)/(22.5_r8**5._r8+cumvd_p(m)**5._r8) + + END SUBROUTINE vernalization +#endif + +END MODULE MOD_BGC_Veg_CNPhenology +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 new file mode 100644 index 0000000000..5ad9767291 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 @@ -0,0 +1,159 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNVegStructUpdate + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! On the radiation time step, USE C state variables and epc to diagnose +! vegetation structure (LAI, SAI, height) +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. +! + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_LAIFEEDBACK, DEF_USE_Fire + USE MOD_Vars_Global, only: nc3crop, nc3irrig, nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub, & + npcropmin, ntmp_corn, nirrig_tmp_corn, ntrp_corn, nirrig_trp_corn, & + nsugarcane, nirrig_sugarcane, nmiscanthus, nirrig_miscanthus, & + nswitchgrass, nirrig_switchgrass, noveg + + USE MOD_Vars_PFTimeVariables, only: lai_p, tlai_p, tsai_p, leafc_p, deadstemc_p, harvdate_p + USE MOD_Vars_TimeVariables, only: lai, tlai +#ifdef CROP + USE MOD_BGC_Vars_PFTimeVariables, only: peaklai_p +#endif + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_BGC_Vars_TimeVariables, only: farea_burned + USE MOD_Const_PFT, only: dsladlai, slatop, laimx, woody + + !CLM5 + PUBLIC :: CNVegStructUpdate + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + SUBROUTINE CNVegStructUpdate(i,ps,pe,deltim,npcropmin) + + integer,intent(in) :: i ! patch index + integer,intent(in) :: ps ! start pft index + integer,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer,intent(in) :: npcropmin ! first crop pft index + + ! !LOCAL VARIABLES: + integer :: p,c,g ! indices + integer :: fp ! lake filter indices + real(r8) :: stocking ! #stems / ha (stocking density) + real(r8) :: ol ! thickness of canopy layer covered by snow (m) + real(r8) :: fb ! fraction of canopy layer covered by snow + real(r8) :: tlai_old ! for USE in Zeng tsai formula + real(r8) :: tsai_old ! for USE in Zeng tsai formula + real(r8) :: tsai_min ! PATCH derived minimum tsai + real(r8) :: tsai_alpha ! monthly decay rate of tsai + real(r8) :: frac_sno_adjusted ! frac_sno adjusted per frac_sno_threshold + + real(r8), parameter :: dtsmonth = 2592000._r8 ! number of seconds in a 30 day month (60x60x24x30) + real(r8), parameter :: frac_sno_threshold = 0.999_r8 ! frac_sno values greater than this are treated as 1 + real(r8), parameter :: natlaimx = 8._r8 + real(r8), parameter :: theta = 0.8_r8 + integer m, ivt +!----------------------------------------------------------------------- +! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 +! +! tsai(m) = max( tsai_alpha(ivt(m))*tsai_old + max(tlai_old-tlai(m),0_r8), tsai_min(ivt(m)) ) +! notes: +! * RHS tsai & tlai are from previous timestep +! * should create tsai_alpha(ivt(m)) & tsai_min(ivt(m)) in pftconMod.F90 - slevis +! * all non-crop patches USE same values: +! crop tsai_alpha,tsai_min = 0.0,0.1 +! noncrop tsai_alpha,tsai_min = 0.5,1.0 (includes bare soil and urban) +!------------------------------------------------------------------------------- + + ! patch loop + + lai (i) = 0._r8 + DO m = ps, pe + ivt = pftclass(m) + IF (ivt /= noveg) THEN + + tlai_old = tlai_p(m) ! n-1 value + tsai_old = tsai_p(m) ! n-1 value + + IF(DEF_USE_LAIFEEDBACK)THEN + tlai_p(m) = ((natlaimx + slatop(ivt) * leafc_p(m)) & + - sqrt((natlaimx + slatop(ivt) * leafc_p(m))**2 & + - 4 * theta * natlaimx * slatop(ivt) * leafc_p(m)))/ (2*theta) + tlai_p(m) = max(0._r8, tlai_p(m)) + lai_p (m) = tlai_p(m) + ENDIF + + ! update the stem area index and height based on LAI, stem mass, and veg type. + ! With the exception of htop for woody vegetation, this follows the DGVM logic. + + ! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 (see notes) + ! Assumes doalb time step .eq. CLM time step, SAI min and monthly decay factor + ! alpha are set by PFT, and alpha is scaled to CLM time step by multiplying by + ! deltim and dividing by dtsmonth (seconds in average 30 day month) + ! tsai_min scaled by 0.5 to match MODIS satellite derived values + IF (ivt == nc3crop .or. ivt == nc3irrig) THEN ! generic crops + + tsai_alpha = 1.0_r8-1.0_r8*deltim/dtsmonth + tsai_min = 0.1_r8 + ELSE + tsai_alpha = 1.0_r8-0.5_r8*deltim/dtsmonth + tsai_min = 1.0_r8 + ENDIF + tsai_min = tsai_min * 0.5_r8 + tsai_p(m) = max(tsai_alpha*tsai_old+max(tlai_old-tlai_p(m),0._r8),tsai_min) + + ! calculate vegetation physiological parameters used in biomass heat storage + ! + IF (woody(ivt) == 1._r8) THEN + + ! trees and shrubs for now have a very simple allometry, with hard-wired + ! stem taper (height:radius) and nstem from PFT parameter file + ELSE IF (ivt >= npcropmin) THEN ! prognostic crops +#ifdef CROP + IF (tlai_p(m) >= laimx(ivt)) peaklai_p(m) = 1 ! used in CNAllocation + + IF (ivt == ntmp_corn .or. ivt == nirrig_tmp_corn .or. & + ivt == ntrp_corn .or. ivt == nirrig_trp_corn .or. & + ivt == nsugarcane .or. ivt == nirrig_sugarcane .or. & + ivt == nmiscanthus .or. ivt == nirrig_miscanthus .or. & + ivt == nswitchgrass .or. ivt == nirrig_switchgrass) THEN + tsai_p(m) = 0.1_r8 * tlai_p(m) + ELSE + tsai_p(m) = 0.2_r8 * tlai_p(m) + ENDIF + + ! "stubble" after harvest + IF (harvdate_p(m) < 999 .and. tlai_p(m) == 0._r8) THEN + peaklai_p(m) = 0 + IF(DEF_USE_Fire)THEN + tsai_p(m) = 0.25_r8*(1._r8-farea_burned(i)*0.90_r8) !changed by F. Li and S. Levis + ENDIF + ENDIF +#endif + ENDIF + + ENDIF + +! adjust lai and sai for burying by snow. +! snow burial fraction for short vegetation (e.g. grasses, crops) changes with vegetation height +! accounts for a 20% bending factor, as used in Lombardozzi et al. (2018) GRL 45(18), 9889-9897 + +! NOTE: The following snow burial code is duplicated in SatellitePhenologyMod. +! Changes in one place should be accompanied by similar changes in the other. + lai(i) = lai(i) + lai_p(m) * pftfrac(m) + ENDDO + tlai(i) = lai(i) + + END SUBROUTINE CNVegStructUpdate + +END MODULE MOD_BGC_Veg_CNVegStructUpdate +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 new file mode 100644 index 0000000000..3dba43ad97 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 @@ -0,0 +1,539 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_NutrientCompetition + +!---------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! This MODULE simulates the plant growth with regard to the available soil mineral nitrogen. +! Allocation of NPP and N uptake to different vegetation CN pools uses allocation scheme from CLM4.5. +! CALL sequence is: calc_plant_nutrient_demand_CLM45_default => calc_plant_nutrient_competition_CLM45_default +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! Fang Li, 2022, add GPAM C allocation scheme for crop. + + ! + USE MOD_Precision + USE MOD_Const_PFT, only: & + woody, leafcn, frootcn, livewdcn, deadwdcn, graincn, & + froot_leaf, croot_stem, stem_leaf, flivewd, grperc, grpnow, fcur2, & +! crop variables + astemf, arooti, arootf, fleafi, bfact, declfact, allconss, allconsl, fleafcn, fstemcn, ffrootcn, & + lfemerg, grnfill + + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_PFTimeVariables, only: & + xsmrpool_p, retransn_p, tempsum_npp_p, & + tempsum_potential_gpp_p, tempmax_retransn_p, annmax_retransn_p, annsum_potential_gpp_p, & +! crop variables +#ifdef CROP + croplive_p, hui_p, peaklai_p, & + aroot_p, astem_p, arepr_p, aleaf_p, astemi_p, aleafi_p, vf_p, & +#endif + c_allometry_p, n_allometry_p, downreg_p, grain_flag_p, annsum_npp_p, & + leafc_p, livestemc_p, frootc_p + USE MOD_Vars_Global, only: nwwheat, nirrig_wwheat + + USE MOD_BGC_Vars_TimeVariables, only: fpg + USE MOD_Vars_Global, only: ntmp_soybean, ntrp_soybean, nirrig_tmp_soybean, nirrig_trp_soybean + + USE MOD_Vars_1DPFTFluxes, only: assim_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + leaf_xsmr_p, froot_xsmr_p, livestem_xsmr_p, livecroot_xsmr_p, grain_xsmr_p, cpool_to_xsmrpool_p, & + leaf_mr_p, froot_mr_p, livestem_mr_p, livecroot_mr_p, grain_mr_p, & + plant_ndemand_p, retransn_to_npool_p, cpool_to_leafc_p, cpool_to_leafc_storage_p, & + cpool_to_frootc_p, cpool_to_frootc_storage_p, cpool_to_livestemc_p, cpool_to_livestemc_storage_p, & + cpool_to_deadstemc_p, cpool_to_deadstemc_storage_p, cpool_to_livecrootc_p, cpool_to_livecrootc_storage_p, & + cpool_to_deadcrootc_p, cpool_to_deadcrootc_storage_p, cpool_to_grainc_p, cpool_to_grainc_storage_p, & + cpool_to_gresp_storage_p, npool_to_leafn_p, npool_to_leafn_storage_p, & + npool_to_frootn_p, npool_to_frootn_storage_p, npool_to_livestemn_p, npool_to_livestemn_storage_p, & + npool_to_deadstemn_p, npool_to_deadstemn_storage_p, npool_to_livecrootn_p, npool_to_livecrootn_storage_p, & + npool_to_deadcrootn_p, npool_to_deadcrootn_storage_p, npool_to_grainn_p, npool_to_grainn_storage_p, & + leafn_to_retransn_p, livestemn_to_retransn_p, frootn_to_retransn_p, & + plant_calloc_p, plant_nalloc_p, leaf_curmr_p, froot_curmr_p, livestem_curmr_p, livecroot_curmr_p, grain_curmr_p, & + psn_to_cpool_p, gpp_p, availc_p, avail_retransn_p, xsmrpool_recover_p, sminn_to_npool_p, excess_cflux_p + + IMPLICIT NONE + + PUBLIC calc_plant_nutrient_competition_CLM45_default + PUBLIC calc_plant_nutrient_demand_CLM45_default + +CONTAINS + + SUBROUTINE calc_plant_nutrient_competition_CLM45_default(i,ps,pe,npcropmin) + +!---------------------------------------------------------------------------- +! !DESCRIPTION +! Calulate the nitrogen limitation on the plant growth based on the available +! nitrogen and nitrogen demand from "calc_plant_nutrient_demand_CLM45_default". +! +! !Original: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! Fang Li, 2022, add GPAM C allocation scheme for crop. + + integer ,intent(in) :: i + integer ,intent(in) :: ps + integer ,intent(in) :: pe + integer ,intent(in) :: npcropmin + + ! !LOCAL VARIABLES: + real(r8):: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8):: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8):: fcur ! fraction of current psn displayed as growth + real(r8):: gresp_storage ! temporary variable for growth resp to storage + real(r8):: nlc ! temporary variable for total new leaf carbon allocation + real(r8):: f5 ! grain allocation parameter + real(r8):: cng ! C:N ratio for grain (= cnlw for now; slevis) + integer :: ivt, m + + DO m = ps, pe + ivt = pftclass(m) + ! set some local allocation variables + f1 = froot_leaf(ivt) + f2 = croot_stem(ivt) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! There was an error in this formula in previous version, WHERE the coefficient + ! was 0.004 instead of 0.0025. + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiology file. The value is also used + ! as a trigger here: -1.0 means to USE the dynamic allocation (trees). + IF (stem_leaf(ivt) == -1._r8) THEN + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp_p(m) - 300.0)))) - 0.4 + ELSE + f3 = stem_leaf(ivt) + ENDIF + + f4 = flivewd(ivt) + g1 = grperc(ivt) + g2 = grpnow(ivt) + cnl = leafcn(ivt) + cnfr = frootcn(ivt) + cnlw = livewdcn(ivt) + cndw = deadwdcn(ivt) + fcur = fcur2(ivt) + +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + IF (croplive_p(m)) THEN + f1 = aroot_p(m) / aleaf_p(m) + f3 = astem_p(m) / aleaf_p(m) + f5 = arepr_p(m) / aleaf_p(m) + g1 = grperc(ivt) + ELSE + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = grperc(ivt) + ENDIF + ENDIF +#endif + + sminn_to_npool_p(m) = plant_ndemand_p(m) * fpg(i) + + plant_nalloc_p(m) = sminn_to_npool_p(m) + retransn_to_npool_p(m) + plant_calloc_p(m) = plant_nalloc_p(m) * (c_allometry_p(m)/n_allometry_p(m)) + + + excess_cflux_p(m) = availc_p(m) - plant_calloc_p(m) + ! reduce gpp fluxes due to N limitation + IF (gpp_p(m) > 0.0_r8) THEN + downreg_p(m) = excess_cflux_p(m)/gpp_p(m) + psn_to_cpool_p(m) = psn_to_cpool_p(m) * (1._r8 - downreg_p(m)) + ELSE + downreg_p(m) = 0._r8 + ENDIF + + ! calculate the amount of new leaf C dictated by these allocation + ! decisions, and calculate the daily fluxes of C and N to current + ! growth and storage pools + + ! fcur is the proportion of this day's growth that is displayed now, + ! the remainder going into storage for display next year through the + ! transfer pools + + nlc = plant_calloc_p(m) / c_allometry_p(m) + cpool_to_leafc_p(m) = nlc * fcur + cpool_to_leafc_storage_p(m) = nlc * (1._r8 - fcur) + cpool_to_frootc_p(m) = nlc * f1 * fcur + cpool_to_frootc_storage_p(m) = nlc * f1 * (1._r8 - fcur) + IF (woody(ivt) == 1._r8) THEN + cpool_to_livestemc_p(m) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage_p(m) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc_p(m) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage_p(m) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc_p(m) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage_p(m) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc_p(m) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage_p(m) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + ENDIF +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cpool_to_livestemc_p(m) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage_p(m) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc_p(m) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage_p(m) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc_p(m) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage_p(m) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc_p(m) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage_p(m) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_grainc_p(m) = nlc * f5 * fcur + cpool_to_grainc_storage_p(m) = nlc * f5 * (1._r8 -fcur) + ENDIF +#endif + + ! corresponding N fluxes + npool_to_leafn_p(m) = (nlc / cnl) * fcur + npool_to_leafn_storage_p(m) = (nlc / cnl) * (1._r8 - fcur) + npool_to_frootn_p(m) = (nlc * f1 / cnfr) * fcur + npool_to_frootn_storage_p(m) = (nlc * f1 / cnfr) * (1._r8 - fcur) + IF (woody(ivt) == 1._r8) THEN + npool_to_livestemn_p(m) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage_p(m) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn_p(m) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage_p(m) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + ENDIF +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cng = graincn(ivt) + npool_to_livestemn_p(m) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage_p(m) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn_p(m) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage_p(m) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_grainn_p(m) = (nlc * f5 / cng) * fcur + npool_to_grainn_storage_p(m) = (nlc * f5 / cng) * (1._r8 -fcur) + ENDIF +#endif + + ! Calculate the amount of carbon that needs to go into growth + ! respiration storage to satisfy all of the storage growth demands. + ! Allows for the fraction of growth respiration that is released at the + ! time of fixation, versus the remaining fraction that is stored for + ! release at the time of display. Note that all the growth respiration + ! fluxes that get released on a given timestep are calculated in growth_resp(), + ! but that the storage of C for growth resp during display of transferred + ! growth is assigned here. + + gresp_storage = cpool_to_leafc_storage_p(m) + cpool_to_frootc_storage_p(m) + IF (woody(ivt) == 1._r8) THEN + gresp_storage = gresp_storage + cpool_to_livestemc_storage_p(m) + gresp_storage = gresp_storage + cpool_to_deadstemc_storage_p(m) + + gresp_storage = gresp_storage + cpool_to_livecrootc_storage_p(m) + gresp_storage = gresp_storage + cpool_to_deadcrootc_storage_p(m) + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + gresp_storage = gresp_storage + cpool_to_livestemc_storage_p(m) + gresp_storage = gresp_storage + cpool_to_grainc_storage_p(m) + ENDIF + cpool_to_gresp_storage_p(m) = gresp_storage * g1 * (1._r8 - g2) + + tempsum_npp_p(m) = tempsum_npp_p(m) + plant_calloc_p(m) + + + ENDDO ! END patch loop + + END SUBROUTINE calc_plant_nutrient_competition_CLM45_default + + SUBROUTINE calc_plant_nutrient_demand_CLM45_default(i,ps,pe,deltim,npcropmin) + +!---------------------------------------------------------------------------- +! !DESCRIPTION +! Calculate allocation fraction and plant nitrogen demand. +! +! !Original: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! Fang Li, 2022, add GPAM C allocation scheme for crop. + + + integer ,intent(in) :: i + integer ,intent(in) :: ps + integer ,intent(in) :: pe + real(r8),intent(in) :: deltim + integer ,intent(in) :: npcropmin + + ! !LOCAL VARIABLES: + integer :: j ! indices + real(r8):: mr ! maintenance respiration (gC/m2/s) + real(r8):: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8):: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8):: curmr, curmr_ratio ! xsmrpool temporary variables + real(r8):: f5 ! grain allocation parameter + real(r8):: cng ! C:N ratio for grain (= cnlw for now; slevis) + real(r8):: fleaf ! fraction allocated to leaf + real(r8):: t1 ! temporary variable + real(r8):: dayscrecover ! number of days to recover negative cpool + integer :: ivt, m + dayscrecover = 30._r8 + + DO m = ps, pe + ivt = pftclass(m) + psn_to_cpool_p(m) = assim_p(m) * 12.011_r8 + + gpp_p(m) = psn_to_cpool_p(m) + + ! get the time step total maintenance respiration + ! These fluxes should already be in gC/m2/s + + mr = leaf_mr_p(m) + froot_mr_p(m) + IF (woody(ivt) == 1.0_r8) THEN + mr = mr + livestem_mr_p(m) + livecroot_mr_p(m) + ELSE IF (ivt >= npcropmin) THEN +#ifdef CROP + IF (croplive_p(m)) mr = mr + livestem_mr_p(m) + grain_mr_p(m) +#endif + ENDIF + + ! carbon flux available for allocation + availc_p(m) = gpp_p(m) - mr + + ! new code added for isotope calculations, 7/1/05, PET + ! IF mr > gpp, THEN some mr comes from gpp, the rest comes from + ! cpool (xsmr) + IF (mr > 0._r8 .and. availc_p(m) < 0._r8) THEN + curmr = gpp_p(m) + curmr_ratio = curmr / mr + ELSE + curmr_ratio = 1._r8 + ENDIF + leaf_curmr_p(m) = leaf_mr_p(m) * curmr_ratio + leaf_xsmr_p(m) = leaf_mr_p(m) - leaf_curmr_p(m) + froot_curmr_p(m) = froot_mr_p(m) * curmr_ratio + froot_xsmr_p(m) = froot_mr_p(m) - froot_curmr_p(m) + livestem_curmr_p(m) = livestem_mr_p(m) * curmr_ratio + livestem_xsmr_p(m) = livestem_mr_p(m) - livestem_curmr_p(m) + livecroot_curmr_p(m) = livecroot_mr_p(m) * curmr_ratio + livecroot_xsmr_p(m) = livecroot_mr_p(m) - livecroot_curmr_p(m) + grain_curmr_p(m) = grain_mr_p(m) * curmr_ratio + grain_xsmr_p(m) = grain_mr_p(m) - grain_curmr_p(m) + + ! no allocation when available c is negative + availc_p(m) = max(availc_p(m),0.0_r8) + + ! test for an xsmrpool deficit + IF (xsmrpool_p(m) < 0.0_r8) THEN + ! Running a deficit in the xsmrpool, so the first priority is to let + ! some availc from this timestep accumulate in xsmrpool. + ! Determine rate of recovery for xsmrpool deficit + + xsmrpool_recover_p(m) = -xsmrpool_p(m)/(dayscrecover*86400._r8) + IF (xsmrpool_recover_p(m) < availc_p(m)) THEN + ! available carbon reduced by amount for xsmrpool recovery + availc_p(m) = availc_p(m) - xsmrpool_recover_p(m) + ELSE + ! all of the available carbon goes to xsmrpool recovery + xsmrpool_recover_p(m) = availc_p(m) + availc_p(m) = 0.0_r8 + ENDIF + cpool_to_xsmrpool_p(m) = xsmrpool_recover_p(m) + ENDIF + + f1 = froot_leaf(ivt) + f2 = croot_stem(ivt) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiologfy file. The value is also used + ! as a trigger here: -1.0 means to USE the dynamic allocation (trees). + + IF (stem_leaf(ivt) == -1._r8) THEN + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp_p(m) - 300.0)))) - 0.4 + ELSE + f3 = stem_leaf(ivt) + ENDIF + + f4 = flivewd(ivt) + g1 = grperc(ivt) + g2 = grpnow(ivt) + cnl = leafcn(ivt) + cnfr = frootcn(ivt) + cnlw = livewdcn(ivt) + cndw = deadwdcn(ivt) + + ! calculate f1 to f5 for prog crops following AgroIBIS subr phenocrop + + f5 = 0._r8 ! continued intializations from above +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + + IF (croplive_p(m)) THEN + ! same phases appear in SUBROUTINE CropPhenology + + ! Phase 1 completed: + ! ================== + ! Next phase: leaf emergence to start of leaf decline + + IF (hui_p(m) >= lfemerg(ivt) .and. hui_p(m) < grnfill(ivt)) THEN + ! allocation rules for crops based on maturity and linear decrease + ! of amount allocated to roots over course of the growing season + + IF (peaklai_p(m) == 1) THEN ! lai at maximum allowed + arepr_p(m) = 0._r8 + aleaf_p(m) = 1.e-5_r8 + astem_p(m) = 0._r8 + aroot_p(m) = 1._r8 - arepr_p(m) - aleaf_p(m) - astem_p(m) + ELSE + arepr_p(m) = 0._r8 + aroot_p(m) = arooti(ivt) - (arooti(ivt) - arootf(ivt)) * hui_p(m) + fleaf = fleafi(ivt) * (exp(-bfact(ivt)) - & + exp(-bfact(ivt)*hui_p(m)/grnfill(ivt))) / & + (exp(-bfact(ivt))-1) ! fraction alloc to leaf (from J Norman alloc curve) + aleaf_p(m) = max(1.e-5_r8, (1._r8 - aroot_p(m)) * fleaf) + astem_p(m) = 1._r8 - arepr_p(m) - aleaf_p(m) - aroot_p(m) + ENDIF + ! AgroIBIS included here an immediate adjustment to aleaf & astem IF the + ! predicted lai from the above allocation coefficients exceeded laimx. + ! We have decided to live with lais slightly higher than laimx by + ! enforcing the cap in the following tstep through the peaklai logic above. + + astemi_p(m) = astem_p(m) ! SAVE for USE by equations after shift to reproductive + grain_flag_p(m) = 0._r8 ! phenology stage begins setting to 0 WHILE in phase 2 + + ! Phase 2 completed: + ! ================== + ! shift allocation either when enough hui are accumulated or maximum number + ! of days has elapsed since planting + + ELSE IF (hui_p(m) >= grnfill(ivt)) THEN + + aroot_p(m) = arooti(ivt) - (arooti(ivt) - arootf(ivt)) * min(1._r8, hui_p(m)) + astem_p(m) = max(astemf(ivt), astem_p(m) * max(0._r8, (1._r8-hui_p(m))/ & + (1._r8-grnfill(ivt)))**allconss(ivt)) + aleaf_p(m) = 1.e-5_r8 + + !Beth's retranslocation of leafn, stemn, rootn to organ + !Filter excess plant N to retransn pool for organ N + !only DO one time THEN hold grain_flag till onset next season + + IF (astem_p(m) == astemf(ivt) .or. & + (ivt /= ntmp_soybean .and. ivt /= nirrig_tmp_soybean .and.& + ivt /= ntrp_soybean .and. ivt /= nirrig_trp_soybean)) THEN + IF (grain_flag_p(m) == 0._r8)THEN + t1 = 1._r8 / deltim + leafn_to_retransn_p(m) = t1 * ((leafc_p(m) / leafcn(ivt)) - (leafc_p(m) / & + fleafcn(ivt))) + livestemn_to_retransn_p(m) = t1 * ((livestemc_p(m) / livewdcn(ivt)) - (livestemc_p(m) / & + fstemcn(ivt))) + frootn_to_retransn_p(m) = 0._r8 + IF (ffrootcn(ivt) > 0._r8) THEN + frootn_to_retransn_p(m) = t1 * ((frootc_p(m) / frootcn(ivt)) - (frootc_p(m) / & + ffrootcn(ivt))) + ENDIF + grain_flag_p(m) = 1._r8 + ENDIF + ENDIF + + arepr_p(m) = 1._r8 - aroot_p(m) - astem_p(m) - aleaf_p(m) + !F. Li for vernalization effect 2 + IF(ivt == nwwheat .or. ivt == nirrig_wwheat) THEN + arepr_p(m) = arepr_p(m)*vf_p(m) + aroot_p(m) = 1._r8 - aleaf_p(m) - astem_p(m) - arepr_p(m) + ENDIF + ELSE ! pre emergence + aleaf_p(m) = 1.e-5_r8 ! allocation coefficients should be irrelevant + astem_p(m) = 0._r8 ! because crops have no live carbon pools; + aroot_p(m) = 0._r8 ! this applies to this "ELSE" and to the "ELSE" + arepr_p(m) = 0._r8 ! a few lines down + ENDIF + + f1 = aroot_p(m) / aleaf_p(m) + f3 = astem_p(m) / aleaf_p(m) + f5 = arepr_p(m) / aleaf_p(m) + g1 = grperc(ivt) + + ELSE ! .not croplive + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = grperc(ivt) + ENDIF + ENDIF +#endif + +! based on available C, USE constant allometric relationships to +! determine N requirements + +!RF. I removed the growth respiration from this, because it is used to calculate +!plantCN for N uptake and c_allometry for allocation. IF we add gresp to the +!allometry calculation THEN we allocate too much carbon since gresp is not allocated here. + IF (woody(ivt) == 1.0_r8) THEN + c_allometry_p(m) = (1._r8+g1)*(1._r8+f1+f3*(1._r8+f2)) + n_allometry_p(m) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + ELSE IF (ivt >= npcropmin) THEN ! skip generic crops +#ifdef CROP + cng = graincn(ivt) + c_allometry_p(m) = (1._r8+g1)*(1._r8+f1+f5+f3*(1._r8+f2)) + n_allometry_p(m) = 1._r8/cnl + f1/cnfr + f5/cng + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw +#endif + ELSE + c_allometry_p(m) = 1._r8+g1+f1+f1*g1 + n_allometry_p(m) = 1._r8/cnl + f1/cnfr + ENDIF + + plant_ndemand_p(m) = availc_p(m)*(n_allometry_p(m)/c_allometry_p(m)) + + ! retranslocated N deployment depends on seasonal CYCLE of potential GPP + ! (requires one year run to accumulate demand) + + tempsum_potential_gpp_p(m) = tempsum_potential_gpp_p(m) + gpp_p(m) + + ! Adding the following line to carry max retransn info to CN Annual Update + tempmax_retransn_p(m) = max(tempmax_retransn_p(m),retransn_p(m)) + + ! Beth's code: crops pull from retransn pool only during grain fill; + ! retransn pool has N from leaves, stems, and roots for + ! retranslocation + + IF (ivt >= npcropmin .and. grain_flag_p(m) == 1._r8) THEN + avail_retransn_p(m) = plant_ndemand_p(m) + ELSE IF (ivt < npcropmin .and. annsum_potential_gpp_p(m) > 0._r8) THEN + avail_retransn_p(m) = (annmax_retransn_p(m)/2._r8)*(gpp_p(m)/annsum_potential_gpp_p(m))/deltim + ELSE + avail_retransn_p(m) = 0.0_r8 + ENDIF + + ! make sure available retrans N doesn't exceed storage + avail_retransn_p(m) = min(avail_retransn_p(m), retransn_p(m)/deltim) + + ! modify plant N demand according to the availability of + ! retranslocated N + ! take from retransn pool at most the flux required to meet + ! plant ndemand + + IF (plant_ndemand_p(m) > avail_retransn_p(m)) THEN + retransn_to_npool_p(m) = avail_retransn_p(m) + ELSE + retransn_to_npool_p(m) = plant_ndemand_p(m) + ENDIF + + plant_ndemand_p(m) = plant_ndemand_p(m) - retransn_to_npool_p(m) + + ENDDO ! END loop pft patch. + + END SUBROUTINE calc_plant_nutrient_demand_CLM45_default + +END MODULE MOD_BGC_Veg_NutrientCompetition +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 new file mode 100644 index 0000000000..6f386687ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 @@ -0,0 +1,166 @@ +#include +#ifdef BGC + + SUBROUTINE bgc_driver (i,idate,deltim,dlat,dlon) + +!----------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! The trunk subroutine of the CoLM biogeochemistry module. The bgc_driver link different bgc processes, and +! sequentially run each process step by step. bgc_driver was called by CoLMDRIVER includes vegetation +! and soil CN cycle processes. +! +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REFERENCES: +! Lawrence, D.M., Fisher, R.A., Koven, C.D., Oleson, K.W., Swenson, S.C., Bonan, G., Collier, N., +! Ghimire, B., van Kampenhout, L., Kennedy, D. and Kluzek, E., 2019. +! The Community Land Model version 5: Description of new features, benchmarking, +! and impact of forcing uncertainty. Journal of Advances in Modeling Earth Systems, 11(12), 4245-4287. +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix, DEF_USE_NITRIF, DEF_USE_CNSOYFIXN, DEF_USE_FIRE, DEF_USE_IRRIGATION + USE MOD_Const_Physical, only: tfrz, denh2o, denice + USE MOD_Vars_PFTimeInvariants, only: pftfrac + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_BGC_Vars_1DFluxes, only: plant_ndemand, ndep_to_sminn + USE MOD_BGC_Vars_1DPFTFluxes, only: plant_ndemand_p, cpool_to_leafc_p, crop_seedc_to_leaf_p + USE MOD_BGC_Veg_CNMResp, only: CNMResp + USE MOD_BGC_Soil_BiogeochemDecompCascadeBGC, only: decomp_rate_constants_bgc + USE MOD_BGC_Soil_BiogeochemPotential, only: SoilBiogeochemPotential + USE MOD_BGC_Soil_BiogeochemVerticalProfile, only: SoilBiogeochemVerticalProfile + USE MOD_BGC_Veg_NutrientCompetition, only: calc_plant_nutrient_demand_CLM45_default,& + calc_plant_nutrient_competition_CLM45_default + USE MOD_BGC_Soil_BiogeochemNitrifDenitrif, only: SoilBiogeochemNitrifDenitrif + + USE MOD_BGC_Soil_BiogeochemCompetition, only: SoilBiogeochemCompetition + USE MOD_BGC_Soil_BiogeochemDecomp, only: SoilBiogeochemDecomp + USE MOD_BGC_Veg_CNPhenology, only: CNPhenology + USE MOD_BGC_Veg_CNGResp, only: CNGResp + USE MOD_BGC_CNCStateUpdate1, only: CStateUpdate1 + USE MOD_BGC_CNNStateUpdate1, only: NStateUpdate1 + USE MOD_BGC_Soil_BiogeochemNStateUpdate1, only: SoilBiogeochemNStateUpdate1 + USE MOD_BGC_Soil_BiogeochemLittVertTransp, only: SoilBiogeochemLittVertTransp + USE MOD_BGC_Veg_CNGapMortality, only: CNGapMortality + USE MOD_BGC_CNCStateUpdate2, only: CStateUpdate2 + USE MOD_BGC_CNNStateUpdate2, only: NStateUpdate2 + USE MOD_BGC_CNCStateUpdate3, only: CStateUpdate3 + USE MOD_BGC_Soil_BiogeochemNLeaching, only: SoilBiogeochemNLeaching + USE MOD_BGC_CNNStateUpdate3, only: NstateUpdate3 + USE MOD_BGC_CNSummary, only: CNDriverSummarizeStates, CNDriverSummarizeFluxes + USE MOD_BGC_CNAnnualUpdate, only: CNAnnualUpdate + USE MOD_BGC_CNZeroFluxes, only: CNZeroFluxes + USE MOD_BGC_Veg_CNVegStructUpdate, only: CNVegStructUpdate + USE MOD_BGC_CNBalanceCheck, only: BeginCNBalance, CBalanceCheck, NBalanceCheck + USE MOD_BGC_CNSASU, only: CNSASU + USE MOD_BGC_Veg_CNNDynamics, only: CNNFixation +#ifdef CROP + USE MOD_BGC_Veg_CNNDynamics, only: CNNFert, CNSoyfix + USE MOD_Irrigation, only: CalIrrigationNeeded +#endif + USE MOD_TimeManager + USE MOD_Vars_Global, only: nl_soil, nl_soil_full, ndecomp_pools, ndecomp_pools_vr, ndecomp_transitions, npcropmin, & + z_soi,dz_soi,zi_soi,nbedrock,zmin_bedrock + + USE MOD_BGC_Vars_TimeVariables, only: sminn_vr, col_begnb, skip_balance_check, decomp_cpools_vr + USE MOD_BGC_Veg_CNFireBase, only: CNFireFluxes + USE MOD_BGC_Veg_CNFireLi2016, only: CNFireArea + + IMPLICIT NONE + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8),intent(in) :: dlat ! latitude (degrees) + real(r8),intent(in) :: dlon ! longitude (degrees) + + integer :: ps, pe + integer j + ps = patch_pft_s(i) + pe = patch_pft_e(i) + CALL BeginCNBalance(i) + CALL CNZeroFluxes(i, ps, pe, nl_soil, ndecomp_pools, ndecomp_transitions) + CALL CNNFixation(i,idate) + CALL CNMResp(i, ps, pe, nl_soil, npcropmin) + CALL decomp_rate_constants_bgc(i, nl_soil, z_soi) + CALL SoilBiogeochemPotential(i,nl_soil,ndecomp_pools,ndecomp_transitions) + CALL SoilBiogeochemVerticalProfile(i,ps,pe,nl_soil,nl_soil_full,nbedrock,zmin_bedrock,z_soi,dz_soi) + IF(DEF_USE_NITRIF)THEN + CALL SoilBiogeochemNitrifDenitrif(i,nl_soil,dz_soi) + ENDIF + CALL calc_plant_nutrient_demand_CLM45_default(i,ps,pe,deltim,npcropmin) + + plant_ndemand(i) = sum( plant_ndemand_p(ps:pe)*pftfrac(ps:pe) ) + + CALL SoilBiogeochemCompetition(i,deltim,nl_soil,dz_soi) + CALL calc_plant_nutrient_competition_CLM45_default(i,ps,pe,npcropmin) +#ifdef CROP + IF(DEF_USE_CNSOYFIXN)THEN + CALL CNSoyfix (i, ps, pe, nl_soil) + ENDIF +#endif + + CALL SoilBiogeochemDecomp(i,nl_soil,ndecomp_pools,ndecomp_transitions, dz_soi) + CALL CNPhenology(i,ps,pe,nl_soil,idate(1:3),dz_soi,deltim,dlat,npcropmin,phase=1) + CALL CNPhenology(i,ps,pe,nl_soil,idate(1:3),dz_soi,deltim,dlat,npcropmin,phase=2) +#ifdef CROP + CALL CNNFert(i, ps, pe) +#endif + CALL CNGResp(i, ps, pe, npcropmin) +#ifdef CROP + IF(DEF_USE_IRRIGATION)THEN + CALL CalIrrigationNeeded(i,idate,nl_soil,nbedrock,z_soi,zi_soi,dz_soi,deltim,dlon,npcropmin) + ENDIF +#endif + ! update vegetation pools from phenology, allocation and nitrogen uptake + ! update soil N pools from decomposition and nitrogen competition + CALL CStateUpdate1(i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin) + CALL NStateUpdate1(i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin,dz_soi) + CALL SoilBiogeochemNStateUpdate1(i,deltim,nl_soil,ndecomp_transitions,dz_soi) + + ! update soil pools from soil vertical mixing + CALL SoilBiogeochemLittVertTransp(i,deltim,nl_soil,nl_soil_full,ndecomp_pools,nbedrock,z_soi,zi_soi,dz_soi) + + ! update vegetation pools from gap mortality + CALL CNGapMortality(i, ps, pe, nl_soil, npcropmin) + CALL CStateUpdate2(i, ps, pe, deltim, nl_soil) + CALL NStateUpdate2(i, ps, pe, deltim, nl_soil, dz_soi) + + IF(DEF_USE_FIRE)THEN + ! update vegetation and fire pools from fire + CALL CNFireArea(i,ps,pe,dlat,nl_soil,idate,dz_soi) + CALL CNFireFluxes(i,ps,pe,dlat,nl_soil,ndecomp_pools) + ENDIF + CALL CStateUpdate3(i,ps,pe,deltim, nl_soil, ndecomp_pools) + CALL CNAnnualUpdate(i,ps,pe,deltim,idate(1:3)) + + ! update soil mineral nitrogen pools leaching + CALL SoilBiogeochemNLeaching(i,deltim,nl_soil,zi_soi,dz_soi) + CALL NstateUpdate3(i, ps, pe, deltim, nl_soil, ndecomp_pools,dz_soi) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL CNSASU(i,ps,pe,deltim,idate(1:3),nl_soil,ndecomp_transitions,ndecomp_pools,ndecomp_pools_vr)! only for spin up + ENDIF + + CALL CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools, .false.) + CALL CNDriverSummarizeFluxes(i,ps,pe,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools,deltim) + + IF( .not. skip_balance_check(i) )THEN + CALL CBalanceCheck(i,ps,pe,nl_soil,dz_soi,deltim,dlat,dlon) + CALL NBalanceCheck(i,ps,pe,deltim,dlat,dlon) + + + ELSE + skip_balance_check(i) = .false. + ENDIF + + CALL CNVegStructUpdate(i,ps,pe,deltim,npcropmin) + + END SUBROUTINE bgc_driver + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 new file mode 100644 index 0000000000..e4f9b1063c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 @@ -0,0 +1,371 @@ +#include + +SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) + + +!======================================================================= +! +! CoLM MODEL DRIVER +! +! Initial : Yongjiu Dai, 1999-2014 +! Revised : Hua Yuan, Shupeng Zhang, Nan Wei, Xingjie Lu, Zhongwang Wei, Yongjiu Dai +! 2014-2024 +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, rgas, vonkar + USE MOD_Const_LC + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Vars_1DForcing + USE MOD_Vars_1DFluxes + USE MOD_LandPatch, only: numpatch,landpatch + USE MOD_LandUrban, only: patch2urban + USE MOD_Namelist, only: DEF_forcing, DEF_URBAN_RUN + USE MOD_Forcing, only: forcmask_pch + USE omp_lib +#ifdef HYPERSPECTRAL + USE MOD_HighRes_Parameters +#endif +#ifdef CaMa_Flood + ! get flood variables: inundation depth[mm], inundation fraction [0-1], + ! inundation evaporation [mm/s], inundation re-infiltration[mm/s] + USE MOD_CaMa_Vars, only: flddepth_cama,fldfrc_cama,fevpg_fld,finfg_fld +#endif + + IMPLICIT NONE + + integer, intent(in) :: idate(3) ! model calendar for next time step (year, julian day, seconds) + real(r8), intent(in) :: deltim ! seconds in a time-step + + logical, intent(in) :: dolai ! true if time for time-varying vegetation parameter + logical, intent(in) :: doalb ! true if time for surface albedo calculation + logical, intent(in) :: dosst ! true if time for update sst/ice/snow + + real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag + + real(r8) :: deltim_phy + integer :: steps_in_one_deltim + integer :: i, m, u, k + +! ====================================================================== + +#ifdef OPENMP +!$OMP PARALLEL DO NUM_THREADS(OPENMP) & +!$OMP PRIVATE(i, m, u, k, steps_in_one_deltim, deltim_phy) & +!$OMP SCHEDULE(STATIC, 1) +#endif + + DO i = 1, numpatch + + ! Apply forcing mask + IF (DEF_forcing%has_missing_value) THEN + IF (.not. forcmask_pch(i)) CYCLE + ENDIF + + ! Apply patch mask, but still run virtual 2m WMO patch (patch ipxstt=-1) + IF (DEF_Output_2mWMO) THEN + IF (.not. patchmask(i) .and. (landpatch%ipxstt(i)>0) ) CYCLE + ELSE + IF (.not. patchmask(i)) CYCLE + ENDIF + + m = patchclass(i) + + steps_in_one_deltim = 1 + ! deltim need to be within 1800s for water body with snow in order to avoid large + ! temperature fluctuations due to rapid snow heat conductance + IF(m == WATERBODY) steps_in_one_deltim = ceiling(deltim/1800.) + deltim_phy = deltim/steps_in_one_deltim + + ! For non urban patch or slab urban + IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN + + DO k = 1, steps_in_one_deltim + ! ***** Call CoLM main program ***** + ! + CALL CoLMMAIN ( i,idate, coszen(i), deltim_phy, & + patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & + doalb, dolai, dosst, oro(i), & + + ! SOIL INFORMATION AND LAKE DEPTH + soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & + vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & + wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & + bsw(1:,i), theta_r(1:,i), fsatmax(i), fsatdcf(i), & + topoweti(i), alp_twi(i), chi_twi(i), mu_twi(i), & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & + sc_vgm(1:,i), fc_vgm(1:,i), & +#endif + hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & + dksatf(1:,i), dkdry(1:,i), BA_alpha(1:,i), BA_beta(1:,i), & + rootfr(1:,m), lakedepth(i), dz_lake(1:,i), elvstd(i), & + BVIC(i), & +#if (defined CaMa_Flood) + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i), fevpg_fld(i), finfg_fld(i), & +#endif + + ! VEGETATION INFORMATION + htop(i), hbot(i), sqrtdi(m), & + effcon(m), vmax25(m), c3c4(m), & + kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & + psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & + ck(m), slti(m), hlti(m), shti(m), & + hhti(m), trda(m), trdm(m), trop(m), & + g1(m), g0(m), gradm(m), binter(m), & + extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & +#ifdef HYPERSPECTRAL + ! variables for high spectral resolution + ! note that rho & tau are depend on wavelength + clr_frac, cld_frac, & + reflectance(0:,1:,1:), transmittance(0:,1:,1:), & + soil_alb(1:,i), kw(1:), nw(1:), & +#endif + + ! ATMOSPHERIC FORCING + forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & + forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & + forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & + forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & + forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & + forc_rhoair(i), & +#ifdef HYPERSPECTRAL + ! solar forcing + forc_solarin(i), & +#endif + ! CBL height forcing + forc_hpbl(i), & + ! Aerosol deposition + forc_aerdep(:,i), & + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & + t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & + wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & + t_grnd(i), tleaf(i), ldew(i), ldew_rain(i), & + ldew_snow(i), fwet_snow(i), sag(i), scv(i), & + snowdp(i), fveg(i), fsno(i), sigf(i), & + green(i), lai(i), sai(i), alb(1:,1:,i), & + ssun(1:,1:,i), ssha(1:,1:,i), ssoi(:,:,i), ssno(:,:,i), & + thermk(i), extkb(i), extkd(i), vegwp(1:,i), & + gs0sun(i), gs0sha(i), & +#ifdef HYPERSPECTRAL + ! high-res variables + alb_hires(1:,1:,i), & + sol_dir_ln_hires(1:,i), sol_dif_ln_hires(1:,i) ,& + sr_dir_ln_hires(1:,i) , sr_dif_ln_hires (1:,i) ,& + reflectance_out(:,:,i), transmittance_out(:,:,i),& +#endif + ! Ozone Stress Variables + o3coefv_sun(i), o3coefv_sha(i), o3coefg_sun(i), o3coefg_sha(i), & + lai_old(i), o3uptakesun(i), o3uptakesha(i), forc_ozone(i), & + ! End ozone stress variables + ! WUE stomata model parameter + lambda(m), & + ! End WUE model parameter + zwt(i), wdsrf(i), wa(i), wetwat(i), & + t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & + + ! SNICAR snow model related + snw_rds(:,i), ssno_lyr(:,:,:,i), & + mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & + mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & + + ! additional diagnostic variables for output + laisun(i), laisha(i), rootr(1:,i), rootflux(1:,i), & + rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & + assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & + h2osoi(1:,i), wat(i), rss(i), & + + ! FLUXES + taux(i), tauy(i), fsena(i), fevpa(i), & + lfevpa(i), fsenl(i), fevpl(i), etr(i), & + fseng(i), fevpg(i), olrg(i), fgrnd(i), & + trad(i), tref(i), qref(i), t2m_wmo(i), & + frcsat(i), rsur(i), rsur_se(i), rsur_ie(i), & + rsub(i), & + rnof(i), qintr(i), qinfl(i), qlayer(0:,i), & + lake_deficit(i), qdrip(i), rst(i), assim(i), & + respc(i), sabvsun(i), sabvsha(i), sabg(i), & + sr(i), solvd(i), solvi(i), solnd(i), & + solni(i), srvd(i), srvi(i), srnd(i), & + srni(i), solvdln(i), solviln(i), solndln(i), & + solniln(i), srvdln(i), srviln(i), srndln(i), & + srniln(i), qcharge(i), xerr(i), zerr(i), & + + ! TUNABLE modle constants + zlnd, zsno, csoilc, dewmx, & + ! 'wtfact' is updated to gridded 'fsatmax' data. + capr, cnfac, ssi, wimp, & + pondmx, smpmax, smpmin, trsmx0, & + tcrit, & + + ! additional variables required by coupling with WRF model + emis(i), z0m(i), zol(i), rib(i), & + ustar(i), qstar(i), tstar(i), & + fm(i), fh(i), fq(i) ) + + ENDDO + ENDIF + + +#if (defined BGC) + IF(patchtype(i) .eq. 0)THEN + ! + ! ***** Call CoLM BGC model ***** + ! + CALL bgc_driver (i,idate(1:3),deltim, patchlatr(i)*180/PI,patchlonr(i)*180/PI) + ENDIF +#endif + + +#ifdef URBAN_MODEL + ! For urban model and urban patches + IF (DEF_URBAN_RUN .and. m.eq.URBAN) THEN + + u = patch2urban(i) + ! + ! ***** Call CoLM urban model ***** + ! + CALL CoLMMAIN_Urban ( & + ! MODEL RUNNING PARAMETERS + i ,idate ,coszen(i) ,deltim ,& + patchlonr(i) ,patchlatr(i) ,patchclass(i) ,patchtype(i) ,& + + ! URBAN PARAMETERS + froof(u) ,flake(u) ,hroof(u) ,hlr(u) ,& + fgper(u) ,em_roof(u) ,em_wall(u) ,em_gimp(u) ,& + em_gper(u) ,cv_roof(:,u) ,cv_wall(:,u) ,cv_gimp(:,u) ,& + tk_roof(:,u) ,tk_wall(:,u) ,tk_gimp(:,u) ,z_roof(:,u) ,& + z_wall(:,u) ,dz_roof(:,u) ,dz_wall(:,u) ,lakedepth(i) ,& + dz_lake(1:,i) ,elvstd(i) ,BVIC(i) ,& + + ! LUCY INPUT PARAMETERS + fix_holiday(:,u),week_holiday(:,u),hum_prof(:,u) ,pop_den(u) ,& + vehicle(:,u) ,weh_prof(:,u) ,wdh_prof(:,u) ,& + + ! SOIL INFORMATION AND LAKE DEPTH + vf_quartz(1:,i) ,vf_gravels(1:,i),vf_om(1:,i) ,vf_sand(1:,i) ,& + wf_gravels(1:,i),wf_sand(1:,i) ,porsl(1:,i) ,psi0(1:,i) ,& + bsw(1:,i) ,theta_r(1:,i) ,fsatmax(i) ,fsatdcf(i) ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:,i) ,n_vgm(1:,i) ,L_vgm(1:,i) ,& + sc_vgm(1:,i) ,fc_vgm(1:,i) ,& +#endif + hksati(1:,i) ,csol(1:,i) ,k_solids(1:,i) ,dksatu(1:,i) ,& + dksatf(1:,i) ,dkdry(1:,i) ,BA_alpha(1:,i) ,BA_beta(1:,i) ,& + alb_roof(:,:,u) ,alb_wall(:,:,u) ,alb_gimp(:,:,u) ,alb_gper(:,:,u) ,& + + ! VEGETATION INFORMATION + htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& + effcon(m) ,vmax25(m) ,c3c4(m) ,slti(m) ,hlti(m) ,& + shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& + trop(m) ,g1(m) ,g0(m) ,gradm(m) ,& + binter(m) ,extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,& + rootfr(1:,m) ,& + ! WUE model parameter + lambda(m) ,& + ! END WUE model parameter + + ! ATMOSPHERIC FORCING + forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& + forc_t(i) ,forc_q(i) ,forc_prc(i) ,forc_prl(i) ,& + forc_rain(i) ,forc_snow(i) ,forc_psrf(i) ,forc_pbot(i) ,& + forc_sols(i) ,forc_soll(i) ,forc_solsd(i) ,forc_solld(i) ,& + forc_frl(i) ,forc_hgt_u(i) ,forc_hgt_t(i) ,forc_hgt_q(i) ,& + forc_rhoair(i) ,Fhac(u) ,Fwst(u) ,Fach(u) ,& + Fahe(u) ,Fhah(u) ,vehc(u) ,meta(u) ,& + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno_roof (maxsnl+1:,u) ,z_sno_gimp (maxsnl+1:,u) ,& + z_sno_gper (maxsnl+1:,u) ,z_sno_lake (maxsnl+1:,u) ,& + dz_sno_roof (maxsnl+1:,u) ,dz_sno_gimp (maxsnl+1:,u) ,& + dz_sno_gper (maxsnl+1:,u) ,dz_sno_lake (maxsnl+1:,u) ,& + t_roofsno (maxsnl+1:,u) ,t_gimpsno (maxsnl+1:,u) ,& + t_gpersno (maxsnl+1:,u) ,t_lakesno (maxsnl+1:,u) ,& + wliq_roofsno(maxsnl+1:,u) ,wliq_gimpsno(maxsnl+1:,u) ,& + wliq_gpersno(maxsnl+1:,u) ,wliq_lakesno(maxsnl+1:,u) ,& + wice_roofsno(maxsnl+1:,u) ,wice_gimpsno(maxsnl+1:,u) ,& + wice_gpersno(maxsnl+1:,u) ,wice_lakesno(maxsnl+1:,u) ,& + z_sno (maxsnl+1:,i) ,dz_sno (maxsnl+1:,i) ,& + wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& + t_soisno (maxsnl+1:,i) ,& + smp (1:,i) ,hk (1:,i) ,& + t_wallsun (1:,u) ,t_wallsha (1:,u) ,& + + lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& + green(i) ,tleaf(i) ,ldew(i) ,ldew_rain(i) ,& + ldew_snow(i) ,fwet_snow(i) ,t_grnd(i) ,& + + sag_roof(u) ,sag_gimp(u) ,sag_gper(u) ,sag_lake(u) ,& + scv_roof(u) ,scv_gimp(u) ,scv_gper(u) ,scv_lake(u) ,& + snowdp_roof(u) ,snowdp_gimp(u) ,snowdp_gper(u) ,snowdp_lake(u) ,& + fsno_roof(u) ,fsno_gimp(u) ,fsno_gper(u) ,fsno_lake(u) ,& + sag(i) ,scv(i) ,snowdp(i) ,fsno(i) ,& + extkd(i) ,alb(1:,1:,i) ,ssun(1:,1:,i) ,ssha(1:,1:,i) ,& + sroof(1:,1:,u) ,swsun(1:,1:,u) ,swsha(1:,1:,u) ,sgimp(1:,1:,u) ,& + sgper(1:,1:,u) ,slake(1:,1:,u) ,lwsun(u) ,lwsha(u) ,& + lgimp(u) ,lgper(u) ,lveg(u) ,fwsun(u) ,& + dfwsun(u) ,t_room(u) ,troof_inner(u) ,twsun_inner(u) ,& + twsha_inner(u) ,t_roommax(u) ,t_roommin(u) ,tafu(u) ,& + + zwt(i) ,wdsrf(i) ,wa(i) ,& + t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& + + ! SNICAR snow model related + snw_rds(:,i) ,ssno_lyr(:,:,:,i) ,& + mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& + mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& + +#if (defined CaMa_Flood) + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i) ,fevpg_fld(i) ,finfg_fld(i) ,& +#endif + + ! additional diagnostic variables for output + laisun(i) ,laisha(i) ,rss(i) ,& + rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& + + ! FLUXES + taux(i) ,tauy(i) ,fsena(i) ,fevpa(i) ,& + lfevpa(i) ,fsenl(i) ,fevpl(i) ,etr(i) ,& + fseng(i) ,fevpg(i) ,olrg(i) ,fgrnd(i) ,& + fsen_roof(u) ,fsen_wsun(u) ,fsen_wsha(u) ,fsen_gimp(u) ,& + fsen_gper(u) ,fsen_urbl(u) ,t_roof(u) ,t_wall(u) ,& + lfevp_roof(u) ,lfevp_gimp(u) ,lfevp_gper(u) ,lfevp_urbl(u) ,& + trad(i) ,tref(i) ,& + qref(i) ,rsur(i) ,rnof(i) ,qintr(i) ,& + qinfl(i) ,qdrip(i) ,rst(i) ,assim(i) ,& + respc(i) ,sabvsun(i) ,sabvsha(i) ,sabg(i) ,& + sr(i) ,solvd(i) ,solvi(i) ,solnd(i) ,& + solni(i) ,srvd(i) ,srvi(i) ,srnd(i) ,& + srni(i) ,solvdln(i) ,solviln(i) ,solndln(i) ,& + solniln(i) ,srvdln(i) ,srviln(i) ,srndln(i) ,& + srniln(i) ,qcharge(i) ,xerr(i) ,zerr(i) ,& + + ! TUNABLE model constants + zlnd ,zsno ,csoilc ,dewmx ,& + ! 'wtfact' is updated to gridded 'fsatmax' data. + capr ,cnfac ,ssi ,wimp ,& + pondmx ,smpmax ,smpmin ,trsmx0 ,& + tcrit ,& + + ! additional variables required by coupling with WRF model + emis(i) ,z0m(i) ,zol(i) ,rib(i) ,& + ustar(i) ,qstar(i) ,tstar(i) ,fm(i) ,& + fh(i) ,fq(i) ,forc_hpbl(i) ) + rsub(i) = rnof(i) - rsur(i) + ENDIF + +#endif + ENDDO +#ifdef OPENMP +!$OMP END PARALLEL DO +#endif + +END SUBROUTINE CoLMDRIVER +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 new file mode 100644 index 0000000000..8f53a8a6f2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 @@ -0,0 +1,1739 @@ +#include + +SUBROUTINE CoLMMAIN ( & + + ! model running information + ipatch, idate, coszen, deltim, & + patchlonr, patchlatr, patchclass, patchtype, & + doalb, dolai, dosst, oro, & + + ! soil information and lake depth + soil_s_v_alb, soil_d_v_alb, soil_s_n_alb, soil_d_n_alb, & + vf_quartz, vf_gravels, vf_om, vf_sand, & + wf_gravels, wf_sand, porsl, psi0, & + bsw, theta_r, fsatmax, fsatdcf, & + topoweti, alp_twi, chi_twi, mu_twi, & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm, n_vgm, L_vgm, & + sc_vgm, fc_vgm, & +#endif + hksati, csol, k_solids, dksatu, & + dksatf, dkdry, BA_alpha, BA_beta, & + rootfr, lakedepth, dz_lake, elvstd, BVIC,& +#if (defined CaMa_Flood) + ! add flood depth, flood fraction, flood evaporation and + ! flood re-infiltration + flddepth, fldfrc, fevpg_fld, qinfl_fld, & +#endif + + ! vegetation information + htop, hbot, sqrtdi, & + effcon, vmax25, c3c4, & + kmax_sun, kmax_sha, kmax_xyl, kmax_root, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, & + ck, slti, hlti, shti, & + hhti, trda, trdm, trop, & + g1, g0, gradm, binter, & + extkn, chil, rho, tau, & +#ifdef HYPERSPECTRAL + ! variables for hyperspectral scheme + clr_frac, cld_frac, & + reflectance, transmittance, & + soil_alb, kw, nw, & +#endif + + ! atmospheric forcing + forc_pco2m, forc_po2m, forc_us, forc_vs, & + forc_t, forc_q, forc_prc, forc_prl, & + forc_rain, forc_snow, forc_psrf, forc_pbot, & + forc_sols, forc_soll, forc_solsd, forc_solld, & + forc_frl, forc_hgt_u, forc_hgt_t, forc_hgt_q, & + forc_rhoair, & +#ifdef HYPERSPECTRAL + forc_solarin, & +#endif + + ! cbl forcing + forc_hpbl, & + ! aerosol deposition + forc_aerdep, & + + ! land surface variables required for restart + z_sno, dz_sno, t_soisno, wliq_soisno, & + wice_soisno, smp, hk, t_grnd, & + tleaf, ldew, ldew_rain, ldew_snow, & + fwet_snow, sag, scv, snowdp, & + fveg, fsno, sigf, green, & + lai, sai, alb, ssun, & + ssha, ssoi, ssno, thermk, & + extkb, extkd, vegwp, gs0sun, & + gs0sha, & +#ifdef HYPERSPECTRAL + alb_hires, & + sol_dir_ln_hires, sol_dif_ln_hires ,& + sr_dir_ln_hires , sr_dif_ln_hires ,& + reflectance_out , transmittance_out,& +#endif + !Ozone stress variables + o3coefv_sun, o3coefv_sha, o3coefg_sun, o3coefg_sha, & + lai_old, o3uptakesun, o3uptakesha, forc_ozone, & + !End ozone stress variables + !WUE stomata model parameter + lambda, & + !End WUE stomata model parameter + zwt, wdsrf, wa, wetwat, & + t_lake, lake_icefrac, savedtke1, & + + ! SNICAR snow model related + snw_rds, ssno_lyr, & + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi, & + mss_dst1, mss_dst2, mss_dst3, mss_dst4, & + + ! additional diagnostic variables for output + laisun, laisha, rootr, rootflux, & + rstfacsun_out,rstfacsha_out,gssun_out, gssha_out, & + assimsun_out, etrsun_out, assimsha_out, etrsha_out, & + h2osoi, wat, rss, & + + ! FLUXES + taux, tauy, fsena, fevpa, & + lfevpa, fsenl, fevpl, etr, & + fseng, fevpg, olrg, fgrnd, & + trad, tref, qref, t2m_wmo, & + frcsat, rsur, rsur_se, rsur_ie, & + rsub, & + rnof, qintr, qinfl, qlayer, & + lake_deficit, qdrip, rst, assim, & + respc, sabvsun, sabvsha, sabg, & + sr, solvd, solvi, solnd, & + solni, srvd, srvi, srnd, & + srni, solvdln, solviln, solndln, & + solniln, srvdln, srviln, srndln, & + srniln, qcharge, xerr, zerr, & + + ! TUNABLE model constants + zlnd, zsno, csoilc, dewmx, & + ! 'wtfact' is updated to gridded 'fsatmax' data. + capr, cnfac, ssi, wimp, & + pondmx, smpmax, smpmin, trsmx0, & + tcrit, & + + ! additional variables required by coupling with WRF model + emis, z0m, zol, rib, & + ustar, qstar, tstar, fm, & + fh, fq ) + +!======================================================================= +! +! Main subroutine, advance time information +! +! Initial : Yongjiu Dai, 1999-2014 +! Revised : Hua Yuan, Shupeng Zhang, Nan Wei, Xingjie Lu, Zhongwang Wei, Yongjiu Dai +! 2014-2024 +! +! FLOW DIAGRAM FOR CoLMMAIN +! +! CoLMMAIN ===>netsolar |> all surface +! rain_snow_temp !> all surface +! +! LEAF_interception |] +! newsnow |] patchtype = 0 (soil ground) +! THERMAL |] = 1 (urban & built-up) +! WATER |] = 2 (wetland) +! snowcompaction |] = 3 (land ice) +! snowlayerscombine |] = 4 (lake) +! snowlayersdivide |] +! +! GLACIER_TEMP |] glacier model +! GLACIER_WATER |] +! +! newsnow_lake |] +! laketem |] lake scheme +! snowwater_lake |] +! +! SOCEAN |> ocean and sea ice +! +! orb_coszen |> all surface +! EcoModel (LAI_empirical) |> land - not actived +! snowfraction |> land +! albland |> land +! albocean |> ocean & sea ice +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice + USE MOD_Vars_TimeVariables, only: tlai, tsai, waterstorage +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_RainSnowTemp +#ifdef HYPERSPECTRAL + USE MOD_NetSolar_Hyper +#else + USE MOD_NetSolar +#endif + USE MOD_OrbCoszen + USE MOD_NewSnow + USE MOD_Thermal + USE MOD_SoilSnowHydrology + USE MOD_SnowFraction + USE MOD_SnowLayersCombineDivide + USE MOD_Glacier + USE MOD_Lake + USE MOD_SimpleOcean +#ifdef HYPERSPECTRAL + USE MOD_Albedo_hires + USE MOD_HighRes_Parameters, only: get_loc_params +#else + USE MOD_Albedo +#endif + USE MOD_LAIEmpirical + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VariablySaturatedFlow, & + DEF_USE_PLANTHYDRAULICS, DEF_USE_IRRIGATION + USE MOD_LeafInterception +#if (defined CaMa_Flood) + ! get flood depth [mm], flood fraction[0-1], flood evaporation [mm/s], flood inflow [mm/s] + USE MOD_CaMa_colmCaMa, only: get_fldevp + USE YOS_CMF_INPUT, only: LWINFILT,LWEVAP +#endif +#ifdef CROP + USE MOD_Irrigation, only: CalIrrigationApplicationFluxes +#endif + USE MOD_SPMD_Task + +#ifdef EXTERNAL_LAKE + USE MOD_Lake_Driver, only: external_lake +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: deltim !seconds in a time step [second] + logical, intent(in) :: doalb !true if time for surface albedo calculation + logical, intent(in) :: dolai !true if time for leaf area index calculation + logical, intent(in) :: dosst !true to update sst/ice/snow before calculation + + integer, intent(in) :: & + ipatch ! patch index + + real(r8), intent(in) :: & + patchlonr ,&! longitude in radians + patchlatr ! latitude in radians + + integer, intent(in) :: & + patchclass ,&! land patch class of USGS classification or others + patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + + real(r8), intent(in) :: lakedepth ! lake depth (m) + real(r8), intent(inout) :: dz_lake(nl_lake) ! lake layer thickness (m) + + real(r8), intent(in) :: & + elvstd ,&! standard deviation of elevation (m) + BVIC ,&! vic model parameter b + + ! soil physical parameters and lake info + soil_s_v_alb ,&! albedo of visible of the saturated soil + soil_d_v_alb ,&! albedo of visible of the dry soil + soil_s_n_alb ,&! albedo of near infrared of the saturated soil + soil_d_n_alb ,&! albedo of near infrared of the dry soil + + vf_quartz (nl_soil) ,&! volumetric fraction of quartz within mineral soil + vf_gravels (nl_soil) ,&! volumetric fraction of gravels + vf_om (nl_soil) ,&! volumetric fraction of organic matter + vf_sand (nl_soil) ,&! volumetric fraction of sand + wf_gravels (nl_soil) ,&! gravimetric fraction of gravels + wf_sand (nl_soil) ,&! gravimetric fraction of sand + porsl (nl_soil) ,&! fraction of soil that is voids [-] + psi0 (nl_soil) ,&! minimum soil suction [mm] + bsw (nl_soil) ,&! clapp and hornberger "b" parameter [-] + theta_r (1:nl_soil) ,&! residual water content (cm3/cm3) + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + topoweti ,&! mean topographic wetness index + alp_twi ,&! alpha in three parameter gamma distribution of twi + chi_twi ,&! chi in three parameter gamma distribution of twi + mu_twi ,&! mu in three parameter gamma distribution of twi +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:nl_soil) ,&! parameter corresponding approximately to inverse of air-entry value + n_vgm (1:nl_soil) ,&! a shape parameter + L_vgm (1:nl_soil) ,&! pore-connectivity parameter + sc_vgm (1:nl_soil) ,&! saturation at air entry value in classical vanGenuchten model [-] + fc_vgm (1:nl_soil) ,&! a scaling factor by using air entry value in the Mualem model [-] +#endif + hksati (nl_soil) ,&! hydraulic conductivity at saturation [mm h2o/s] + csol (nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] + k_solids (nl_soil) ,&! thermal conductivity of minerals soil [W/m-K] + dksatu (nl_soil) ,&! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (nl_soil) ,&! thermal conductivity of saturated frozen soil [W/m-K] + dkdry (nl_soil) ,&! thermal conductivity for dry soil [J/(K s m)] + BA_alpha (nl_soil) ,&! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (nl_soil) ,&! beta in Balland and Arp(2005) thermal conductivity scheme + rootfr (nl_soil) ,&! fraction of roots in each soil layer + + ! vegetation static, dynamic, derived parameters + htop ,&! canopy top height [m] + hbot ,&! canopy bottom height [m] + sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] + effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25 ,&! maximum carboxylation rate at 25 C at canopy top + kmax_sun ,&! Plant Hydraulics Parameters + kmax_sha ,&! Plant Hydraulics Parameters + kmax_xyl ,&! Plant Hydraulics Parameters + kmax_root ,&! Plant Hydraulics Parameters + psi50_sun ,&! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha ,&! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl ,&! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root ,&! water potential at 50% loss of root tissue conductance (mmH2O) + ck ,&! shape-fitting parameter for vulnerability curve (-) + slti ,&! slope of low temperature inhibition function [s3] + hlti ,&! 1/2 point of low temperature inhibition function [s4] + shti ,&! slope of high temperature inhibition function [s1] + hhti ,&! 1/2 point of high temperature inhibition function [s2] + trda ,&! temperature coefficient in gs-a model [s5] + trdm ,&! temperature coefficient in gs-a model [s6] + trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model + gradm ,&! conductance-photosynthesis slope parameter + binter ,&! conductance-photosynthesis intercep + extkn ,&! coefficient of leaf nitrogen allocation + chil ,&! leaf angle distribution factor + rho(2,2) ,&! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ,&! leaf transmittance (iw=iband, il=life and dead) +#ifdef HYPERSPECTRAL + ! hyperspectral scheme parameters + clr_frac ( 211, 90, 5 ),& + cld_frac ( 211, 5 ) ,& + reflectance ( 0:15, 211, 2 ),& + transmittance( 0:15, 211, 2 ),& + soil_alb ( 211 ) ,& + kw ( 211 ) ,& + nw ( 211 ) ,& +#endif + + ! tunable parameters + zlnd ,&! roughness length for soil [m] + zsno ,&! roughness length for snow [m] + csoilc ,&! drag coefficient for soil under canopy [-] + dewmx ,&! maximum dew + ! wtfact ,&! (updated to gridded 'fsatmax') fraction of model area with high water table + capr ,&! tuning factor to turn first layer T into surface T + cnfac ,&! Crank Nicholson factor between 0 and 1 + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable if porosity less than wimp + pondmx ,&! ponding depth (mm) + smpmax ,&! wilting point potential in mm + smpmin ,&! restriction for min of soil poten. (mm) + trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] + tcrit ! critical temp. to determine rain or snow + + integer , intent(in) :: & + c3c4 ! 1 for C3, 2 for C4 + +#ifdef HYPERSPECTRAL + ! Urban hyperspectral albedo + REAL(r8), ALLOCATABLE :: urban_albedo( :, :, : ) ! (cluster_id, season wavelength) + REAL(r8), ALLOCATABLE :: mean_albedo ( :, : ) ! (season, wavelength) + REAL(r8), ALLOCATABLE :: lat_north ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lat_south ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lon_east ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lon_west ( : ) ! (cluster_id) + +#endif + +! Forcing +!----------------------------------------------------------------------- + real(r8), intent(in) :: & + forc_pco2m ,&! partial pressure of CO2 at observational height [pa] + forc_po2m ,&! partial pressure of O2 at observational height [pa] + forc_us ,&! wind speed in eastward direction [m/s] + forc_vs ,&! wind speed in northward direction [m/s] + forc_t ,&! temperature at agcm reference height [kelvin] + forc_q ,&! specific humidity at agcm reference height [kg/kg] + forc_prc ,&! convective precipitation [mm/s] + forc_prl ,&! large scale precipitation [mm/s] + forc_psrf ,&! atmosphere pressure at the surface [pa] + forc_pbot ,&! atmosphere pressure at the bottom of the atmos. model level [pa] + forc_sols ,&! atm vis direct beam solar rad onto srf [W/m2] + forc_soll ,&! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd ,&! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ,&! atm nir diffuse solar rad onto srf [W/m2] +#ifdef HYPERSPECTRAL + forc_solarin,&! atm solar rad onto srf [W/m2] +#endif + forc_frl ,&! atmospheric infrared (longwave) radiation [W/m2] + forc_hgt_u ,&! observational height of wind [m] + forc_hgt_t ,&! observational height of temperature [m] + forc_hgt_q ,&! observational height of humidity [m] + forc_rhoair ,&! density air [kg/m3] + forc_hpbl ,&! atmospheric boundary layer height [m] + forc_aerdep(14)!atmospheric aerosol deposition data [kg/m/s] + +#if (defined CaMa_Flood) + real(r8), intent(in) :: fldfrc !inundation fraction + ! --> allow re-evaporation and infiltration![0-1] + real(r8), intent(inout) :: flddepth !inundation depth + ! --> allow re-evaporation and infiltration![mm] + real(r8), intent(out) :: fevpg_fld !effective evaporation from inundation [mm/s] + real(r8), intent(out) :: qinfl_fld !effective re-infiltration from inundation [mm/s] +#endif +! Variables required for restart run +!----------------------------------------------------------------------- + integer, intent(in) :: & + idate(3) ! next time-step /year/julian day/second in a day/ + + real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag + real(r8), intent(inout) :: & + z_sno (maxsnl+1:0) ,&! layer depth (m) + dz_sno (maxsnl+1:0) ,&! layer thickness (m) + t_soisno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + wliq_soisno(maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wice_soisno(maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + hk(1:nl_soil) ,&! hydraulic conductivity [mm h2o/s] + smp(1:nl_soil) ,&! soil matrix potential [mm] + + t_lake(nl_lake) ,&! lake temperature (kelvin) + lake_icefrac(nl_lake) ,&! lake mass fraction of lake layer that is frozen + savedtke1 ,&! top level eddy conductivity (W/m K) + vegwp(nvegwcs) ,&! ground surface temperature [k] + gs0sun ,&! working copy of sunlit stomata conductance + gs0sha ,&! working copy of shalit stomata conductance + !Ozone stress variables + lai_old ,&! lai in last time step + o3uptakesun ,&! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha ,&! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone ,& + o3coefv_sun ,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha ,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun ,&! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ,&! Ozone stress factor for stomata on shaded leaf + !End ozone stress variables + !WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) + !WUE stomata model parameter + t_grnd ,&! ground surface temperature [k] + tleaf ,&! leaf temperature [K] + ldew ,&! depth of water on foliage [kg/m2/s] + ldew_rain ,&! depth of rain on foliage[kg/m2/s] + ldew_snow ,&! depth of snow on foliage[kg/m2/s] + fwet_snow ,&! vegetation canopy snow fractional cover [-] + sag ,&! non dimensional snow age [-] + scv ,&! snow mass (kg/m2) + snowdp ,&! snow depth (m) + zwt ,&! the depth to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ,&! water storage in aquifer [mm] + wetwat ,&! water storage in wetland [mm] + + snw_rds ( maxsnl+1:0 ) ,&! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ,&! mass of dust species 4 in snow (col,lyr) [kg] + ssno_lyr (2,2,maxsnl+1:1) ,&! snow layer absorption [-] + + fveg ,&! fraction of vegetation cover + fsno ,&! fractional snow cover + sigf ,&! fraction of veg cover, excluding snow-covered veg [-] + green ,&! greenness + lai ,&! leaf area index + sai ,&! stem area index +#ifdef HYPERSPECTRAL + alb_hires(211, 2),& ! hyperspectral albedo +#endif + + coszen ,&! cosine of solar zenith angle + alb(2,2) ,&! averaged albedo [-] + ssun(2,2) ,&! sunlit canopy absorption for solar radiation + ssha(2,2) ,&! shaded canopy absorption for solar radiation + ssoi(2,2) ,&! ground soil absorption [-] + ssno(2,2) ,&! ground snow absorption [-] + thermk ,&! canopy gap fraction for tir radiation + extkb ,&! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + +! additional diagnostic variables for output + real(r8), intent(out) :: & + laisun ,&! sunlit leaf area index + laisha ,&! shaded leaf area index + rstfacsun_out ,&! factor of soil water stress + rstfacsha_out ,&! factor of soil water stress + gssun_out ,&! sunlit stomata conductance + gssha_out ,&! shaded stomata conductance + wat ,&! total water storage + rss ,&! soil surface resistance [s/m] + rootr(nl_soil) ,&! water uptake fraction from different layers, all layers add to 1.0 + rootflux(nl_soil),&! water exchange between soil and root in different layers + ! Positive: soil->root[?] +#ifdef HYPERSPECTRAL + reflectance_out (211, 0:15) ,&! high resolution reflectance + transmittance_out(211, 0:15) ,&! high resolution transmittance +#endif + h2osoi(nl_soil) ,&! volumetric soil water in layers [m3/m3] + qlayer(0:nl_soil),&! water flux at between soil layer [mm h2o/s] + lake_deficit ! lake deficit due to evaporation (mm h2o/s) + + real(r8), intent(out) :: & + assimsun_out,& + etrsun_out ,& + assimsha_out,& + etrsha_out +! Fluxes +!----------------------------------------------------------------------- + real(r8), intent(out) :: & + taux ,&! wind stress: E-W [kg/m/s**2] + tauy ,&! wind stress: N-S [kg/m/s**2] + fsena ,&! sensible heat from canopy height to atmosphere [W/m2] + fevpa ,&! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa ,&! latent heat flux from canopy height to atmosphere [W/2] + fsenl ,&! sensible heat from leaves [W/m2] + fevpl ,&! evaporation+transpiration from leaves [mm/s] + etr ,&! transpiration rate [mm/s] + fseng ,&! sensible heat flux from ground [W/m2] + fevpg ,&! evaporation heat flux from ground [mm/s] + olrg ,&! outgoing long-wave radiation from ground+canopy + fgrnd ,&! ground heat flux [W/m2] + xerr ,&! water balance error at current time-step [mm/s] + zerr ,&! energy balance error at current time-step [W/m2] + + tref ,&! 2 m height air temperature [K] + qref ,&! 2 m height air specific humidity + t2m_wmo ,&! 2 m wmo std air temperature [K] + trad ,&! radiative temperature [K] + frcsat ,&! fraction of saturation area + rsur ,&! surface runoff (mm h2o/s) + rsur_se ,&! saturation excess surface runoff (mm h2o/s) + rsur_ie ,&! infiltration excess surface runoff (mm h2o/s) + rsub ,&! subsurface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qintr ,&! interception (mm h2o/s) + qinfl ,&! infiltration (mm h2o/s) + qdrip ,&! throughfall (mm h2o/s) + qcharge ,&! groundwater recharge [mm/s] + + rst ,&! canopy stomatal resistance + assim ,&! canopy assimilation + respc ,&! canopy respiration + + sabvsun ,&! solar absorbed by sunlit vegetation [W/m2] + sabvsha ,&! solar absorbed by shaded vegetation [W/m2] + sabg ,&! solar absorbed by ground [W/m2] + sr ,&! total reflected solar radiation (W/m2) + solvd ,&! incident direct beam vis solar radiation (W/m2) + solvi ,&! incident diffuse beam vis solar radiation (W/m2) + solnd ,&! incident direct beam nir solar radiation (W/m2) + solni ,&! incident diffuse beam nir solar radiation (W/m2) + srvd ,&! reflected direct beam vis solar radiation (W/m2) + srvi ,&! reflected diffuse beam vis solar radiation (W/m2) + srnd ,&! reflected direct beam nir solar radiation (W/m2) + srni ,&! reflected diffuse beam nir solar radiation (W/m2) + solvdln ,&! incident direct beam vis solar radiation at local noon(W/m2) + solviln ,&! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln ,&! incident direct beam nir solar radiation at local noon(W/m2) + solniln ,&! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln ,&! reflected direct beam vis solar radiation at local noon(W/m2) + srviln ,&! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln ,&! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ,&! reflected diffuse beam nir solar radiation at local noon(W/m2) +#ifdef HYPERSPECTRAL + sol_dir_ln_hires(211) ,&! incident direct beam vis solar radiation at local noon(W/m2) + sol_dif_ln_hires(211) ,&! incident diffuse beam vis solar radiation at local noon(W/m2) + sr_dir_ln_hires(211) ,&! reflected direct beam nir solar radiation at local noon(W/m2) + sr_dif_ln_hires(211) ,&! reflected diffuse beam nir solar radiation at local noon(W/m2) +#endif + + forc_rain ,&! rain [mm/s] + forc_snow ,&! snow [mm/s] + + emis ,&! averaged bulk surface emissivity + z0m ,&! effective roughness [m] + zol ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib ,&! bulk Richardson number in surface layer + ustar ,&! u* in similarity theory [m/s] + qstar ,&! q* in similarity theory [kg/kg] + tstar ,&! t* in similarity theory [K] + fm ,&! integral of profile function for momentum + fh ,&! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + logical :: is_dry_lake + + real(r8) :: & + calday ,&! Julian cal day (1.xx to 365.xx) + endwb ,&! water mass at the end of time step + errore ,&! energy balance error (Wm-2) + errorw ,&! water balance error (mm) + fiold(maxsnl+1:nl_soil), &! fraction of ice relative to the total water + w_old ,&! liquid water mass of the column at the previous time step (mm) + + sabg_soil ,&! solar absorbed by soil fraction + sabg_snow ,&! solar absorbed by snow fraction + parsun ,&! PAR by sunlit leaves [W/m2] + parsha ,&! PAR by shaded leaves [W/m2] + qseva ,&! ground surface evaporation rate (mm h2o/s) + qsdew ,&! ground surface dew formation (mm h2o /s) [+] + qsubl ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros ,&! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil ,&! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil ,&! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil ,&! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow ,&! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow ,&! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow ,&! surface dew added to snow pack (mm h2o /s) [+] + scvold ,&! snow cover for previous time step [mm] + sm ,&! rate of snowmelt [kg/(m2 s)] + ssw ,&! water volumetric content of soil surface layer [m3/m3] + tssub(7) ,&! surface/sub-surface temperatures [K] + tssea ,&! sea surface temperature [K] + totwb ,&! water mass at the beginning of time step + wt ,&! fraction of vegetation buried (covered) by snow [-] + z_soisno (maxsnl+1:nl_soil), &! layer depth (m) + dz_soisno(maxsnl+1:nl_soil), &! layer thickness (m) + zi_soisno(maxsnl :nl_soil) ! interface level below a "z" level (m) + + real(r8) :: & + prc_rain ,&! convective rainfall [kg/(m2 s)] + prc_snow ,&! convective snowfall [kg/(m2 s)] + prl_rain ,&! large scale rainfall [kg/(m2 s)] + prl_snow ,&! large scale snowfall [kg/(m2 s)] + t_precip ,&! snowfall/rainfall temperature [kelvin] + bifall ,&! bulk density of newly fallen dry snow [kg/m3] + pg_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + qintr_rain ,&! rainfall interception (mm h2o/s) + qintr_snow ! snowfall interception (mm h2o/s) + +#ifdef HYPERSPECTRAL + real(r8) :: & + dir_frac(211),&! direct beam fraction + dif_frac(211) ! diffuse beam fraction +#endif + + integer snl ,&! number of snow layers + imelt(maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + lb ,lbsn ,&! lower bound of arrays + j ! do looping index + + ! For SNICAR snow model + !---------------------------------------------------------------------- + integer snl_bef !number of snow layers + real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere (grd,aer) [kg m-1 s-1] + real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8) t_soisno_ (maxsnl+1:1) !soil + snow layer temperature [K] + real(r8) dz_soisno_ (maxsnl+1:1) !layer thickness (m) + real(r8) sabg_snow_lyr(maxsnl+1:1) !snow layer absorption [W/m-2] + !---------------------------------------------------------------------- + ! For irrigation + !---------------------------------------------------------------------- + real(r8) :: qflx_irrig_drip ! drip irrigation rate [mm/s] + real(r8) :: qflx_irrig_sprinkler ! sprinkler irrigation rate [mm/s] + real(r8) :: qflx_irrig_flood ! flood irrigation rate [mm/s] + real(r8) :: qflx_irrig_paddy ! paddy irrigation rate [mm/s] + !---------------------------------------------------------------------- + real(r8) :: a, aa, gwat + real(r8) :: wextra, t_rain, t_snow + integer ps, pe, pc + +#if (defined CaMa_Flood) + !add variables for flood evaporation [mm/s] and re-infiltration [mm/s] calculation. + real(r8) :: kk + real(r8) :: taux_fld ! wind stress: E-W [kg/m/s**2] + real(r8) :: tauy_fld ! wind stress: N-S [kg/m/s**2] + real(r8) :: fsena_fld ! sensible heat from agcm reference height to atmosphere [W/m2] + real(r8) :: fevpa_fld ! evaporation from agcm reference height to atmosphere [mm/s] + real(r8) :: fseng_fld ! sensible heat flux from ground [W/m2] + real(r8) :: tref_fld ! 2 m height air temperature [kelvin] + real(r8) :: qref_fld ! 2 m height air humidity + real(r8) :: z0m_fld ! effective roughness [m] + real(r8) :: zol_fld ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8) :: rib_fld ! bulk Richardson number in surface layer + real(r8) :: ustar_fld ! friction velocity [m/s] + real(r8) :: tstar_fld ! temperature scaling parameter + real(r8) :: qstar_fld ! moisture scaling parameter + real(r8) :: fm_fld ! integral of profile function for momentum + real(r8) :: fh_fld ! integral of profile function for heat + real(r8) :: fq_fld ! integral of profile function for moisture +#endif + +!----------------------------------------------------------------------- + + z_soisno (maxsnl+1:0) = z_sno (maxsnl+1:0) + z_soisno (1:nl_soil ) = z_soi (1:nl_soil ) + dz_soisno(maxsnl+1:0) = dz_sno(maxsnl+1:0) + dz_soisno(1:nl_soil ) = dz_soi(1:nl_soil ) + + ! SNICAR initialization + ! --------------------- + + ! snow freezing rate (col,lyr) [kg m-2 s-1] + snofrz(:) = 0. + + ! aerosol deposition value + IF (DEF_Aerosol_Readin) THEN + forc_aer(:) = forc_aerdep ! read from outside forcing file + ELSE + forc_aer(:) = 0. ! manual setting + ENDIF + + +!====================================================================== +! [1] Solar absorbed by vegetation and ground +! and precipitation information (rain/snow fall and precip temperature +!====================================================================== +#ifdef HYPERSPECTRAL + CALL get_loc_params(forc_solarin, idate, coszen, patchlatr, patchlonr, clr_frac, cld_frac, dir_frac, dif_frac) + + CALL netsolar_hyper (ipatch,idate,deltim,patchlonr,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln,& + ! new variables for hyperspectral scheme + dir_frac, dif_frac, alb_hires ,& + sol_dir_ln_hires,sol_dif_ln_hires,& + sr_dir_ln_hires ,sr_dif_ln_hires ) + +#else + CALL netsolar (ipatch,idate,deltim,patchlonr,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) +#endif + + CALL rain_snow_temp (patchtype, & + forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,tcrit,& + prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) + +#ifdef MPAS_EMBEDDED_COLM + ! MPAS already provides hydrometeor phase; keep it while using CoLM for precipitation temperature. + prc_rain = max(0._r8, min(forc_prc, forc_rain)) + prc_snow = max(0._r8, forc_prc - prc_rain) + prl_rain = max(0._r8, forc_rain - prc_rain) + prl_snow = max(0._r8, forc_snow - prc_snow) +#else + forc_rain = prc_rain + prl_rain + forc_snow = prc_snow + prl_snow +#endif + +!====================================================================== + + is_dry_lake = DEF_USE_Dynamic_Lake .and. (patchtype == 4) .and. & + ((wdsrf < 100.) .or. (zwt > 0.)) + + + ! / SOIL GROUND (patchtype = 0) + IF ((patchtype <= 2) .or. is_dry_lake) THEN ! <=== is - URBAN and BUILT-UP (patchtype = 1) + ! \ WETLAND (patchtype = 2) + ! Dry Lake (patchtype = 4) + +! NOTE: PFT and PC are only for soil patches, i.e., patchtype=0. +!====================================================================== + ! initial set + scvold = scv ! snow mass at previous time step + + snl = 0 + DO j=maxsnl+1,0 + IF(wliq_soisno(j)+wice_soisno(j)>0.) snl=snl-1 + ENDDO + + zi_soisno(0)=0. + IF (snl < 0) THEN + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO + ENDIF + DO j = 1,nl_soil + zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) + ENDDO + + totwb = ldew + scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa +#ifdef CROP + if(DEF_USE_IRRIGATION) totwb = totwb + waterstorage(ipatch) +#endif + totwb = totwb + wdsrf + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype == 2) THEN + totwb = totwb + wetwat + ENDIF + ENDIF + + fiold(:) = 0.0 + IF (snl <0 ) THEN + fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) + ENDIF + +!---------------------------------------------------------------------- +! [2] Irrigation +!---------------------------------------------------------------------- + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 +#ifdef CROP + IF (DEF_USE_IRRIGATION) THEN + IF (patchtype == 0) THEN + CALL CalIrrigationApplicationFluxes(ipatch,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy) + ENDIF + ENDIF +#endif +!---------------------------------------------------------------------- +! [3] Canopy interception and precipitation onto ground surface +!---------------------------------------------------------------------- + IF (patchtype == 0) THEN + +#if (defined LULC_USGS || defined LULC_IGBP) + CALL LEAF_interception_wrap (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,forc_t,& + tleaf,prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +#endif + + ELSE + CALL LEAF_interception_wrap (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,forc_t,& + tleaf,prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ENDIF + + qdrip = pg_rain + pg_snow + +!---------------------------------------------------------------------- +! [3] Initialize new snow nodes for snowfall / sleet +!---------------------------------------------------------------------- + + snl_bef = snl + + CALL newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + t_precip,zi_soisno(:0),z_soisno(:0),dz_soisno(:0),t_soisno(:0),& + wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno,wetwat) + +!---------------------------------------------------------------------- +! [4] Energy and Water balance +!---------------------------------------------------------------------- + lb = snl + 1 !lower bound of array + lbsn = min(lb,0) + + CALL THERMAL (ipatch,patchtype,is_dry_lake,lb ,deltim ,& + trsmx0 ,zlnd ,zsno ,csoilc ,& + dewmx ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,lai ,laisun ,& + laisha ,sai ,htop ,hbot ,& + sqrtdi ,rootfr ,rstfacsun_out ,rstfacsha_out ,& + rss ,gssun_out ,gssha_out ,assimsun_out ,& + etrsun_out ,assimsha_out ,etrsha_out ,& + + effcon ,vmax25,c3c4 ,hksati ,smp ,hk ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& + ck ,vegwp ,gs0sun ,gs0sha ,& + !Ozone stress variables + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& + !End ozone stress variables + !WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) + !WUE stomata model parameter + slti ,hlti ,shti ,hhti ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_pco2m ,forc_hpbl ,forc_po2m ,& + coszen ,parsun ,parsha ,sabvsun ,& + sabvsha ,sabg ,sabg_soil ,sabg_snow ,& + forc_frl ,extkb ,extkd ,thermk ,& + fsno ,sigf ,dz_soisno(lb:) ,z_soisno(lb:) ,& + zi_soisno(lb-1:) ,tleaf ,t_soisno(lb:) ,wice_soisno(lb:) ,& + wliq_soisno(lb:) ,ldew ,ldew_rain ,ldew_snow ,& + fwet_snow ,scv ,snowdp ,imelt(lb:) ,& + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + rootr ,rootflux ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,& + qsubl_soil ,qfros_soil ,qseva_snow ,qsdew_snow ,& + qsubl_snow ,qfros_snow ,sm ,tref ,& + qref ,trad ,rst ,assim ,& + respc ,errore ,emis ,z0m ,& + zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,& + pg_rain ,pg_snow ,t_precip ,qintr_rain ,& + qintr_snow ,snofrz(lbsn:0) ,sabg_snow_lyr(lb:1) ) + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + + CALL WATER_2014 (ipatch,patchtype ,lb ,nl_soil ,& + deltim ,z_soisno(lb:) ,dz_soisno(lb:) ,zi_soisno(lb-1:) ,& + bsw ,porsl ,psi0 ,hksati ,& + theta_r ,fsatmax ,fsatdcf ,elvstd ,& + BVIC ,rootr ,rootflux ,t_soisno(lb:) ,& + wliq_soisno(lb:) ,wice_soisno(lb:) ,smp ,hk ,& + pg_rain ,sm ,etr ,qseva ,& + qsdew ,qsubl ,qfros ,qseva_soil ,& + qsdew_soil ,qsubl_soil ,qfros_soil ,qseva_snow ,& + qsdew_snow ,qsubl_snow ,qfros_snow ,fsno ,& + rsur ,rnof ,qinfl ,pondmx ,& + ssi ,wimp ,smpmin ,zwt ,& + wdsrf ,wa ,qcharge ,& + +#if (defined CaMa_Flood) + !add variables for flood depth [mm], flood fraction [0-1] + !and re-infiltration [mm/s] calculation. + flddepth ,fldfrc ,qinfl_fld ,& +#endif +! SNICAR model variables + forc_aer ,& + mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& + mss_dst1(lbsn:0) ,mss_dst2(lbsn:0) ,mss_dst3(lbsn:0) ,mss_dst4(lbsn:0) ,& +! irrigation variables + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy) + rsub = rnof - rsur + ELSE + + CALL WATER_VSF (ipatch ,patchtype,is_dry_lake, lb ,nl_soil ,& + deltim ,z_soisno(lb:) ,dz_soisno(lb:) ,zi_soisno(lb-1:) ,& + bsw ,theta_r ,fsatmax ,fsatdcf ,& + topoweti ,alp_twi ,chi_twi ,mu_twi ,& + elvstd ,BVIC ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm ,n_vgm ,L_vgm ,sc_vgm ,& + fc_vgm ,& +#endif + porsl ,psi0 ,hksati ,rootr ,& + rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,& + smp ,hk ,pg_rain ,sm ,& + etr ,qseva ,qsdew ,qsubl ,& + qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,& + qfros_soil ,qseva_snow ,qsdew_snow ,qsubl_snow ,& + qfros_snow ,fsno ,frcsat ,rsur ,& + rsur_se ,rsur_ie ,rsub ,rnof ,& + qinfl ,& + qlayer ,ssi ,pondmx ,wimp ,& + zwt ,wdsrf ,wa ,wetwat ,& +#if (defined CaMa_Flood) + !add variables for flood depth [mm], flood fraction [0-1] + !and re-infiltration [mm/s] calculation. + flddepth ,fldfrc ,qinfl_fld ,& +#endif +! SNICAR model variables + forc_aer ,& + mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& + mss_dst1(lbsn:0) ,mss_dst2(lbsn:0) ,mss_dst3(lbsn:0) ,mss_dst4(lbsn:0) ,& +! irrigation variables + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy) + ENDIF + + IF (snl < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lb = snl + 1 !lower bound of array + CALL snowcompaction (lb,deltim,& + imelt(lb:0),fiold(lb:0),t_soisno(lb:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),forc_us,forc_vs,dz_soisno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + + IF (DEF_USE_SNICAR) THEN + CALL snowlayerscombine_snicar (lb,snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:1),& + wliq_soisno(lb:1),wice_soisno(lb:1),t_soisno(lb:1),scv,snowdp,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ELSE + CALL snowlayerscombine (lb,snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:1),& + wliq_soisno(lb:1),wice_soisno(lb:1),t_soisno(lb:1),scv,snowdp) + ENDIF + + ! Divide thick snow elements + IF(snl<0) THEN + IF (DEF_USE_SNICAR) THEN + CALL snowlayersdivide_snicar (lb,snl,& + z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0),& + mss_bcpho(lb:0),mss_bcphi(lb:0),mss_ocpho(lb:0),mss_ocphi(lb:0),& + mss_dst1(lb:0),mss_dst2(lb:0),mss_dst3(lb:0),mss_dst4(lb:0) ) + ELSE + CALL snowlayersdivide (lb,snl,& + z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0)) + ENDIF + ENDIF + ENDIF + + ! Set zero to the empty node + IF (snl > maxsnl) THEN + wice_soisno(maxsnl+1:snl) = 0. + wliq_soisno(maxsnl+1:snl) = 0. + t_soisno (maxsnl+1:snl) = 0. + z_soisno (maxsnl+1:snl) = 0. + dz_soisno (maxsnl+1:snl) = 0. + ENDIF + + lb = snl + 1 + t_grnd = t_soisno(lb) + + IF (is_dry_lake) THEN + dz_lake = wdsrf*1.e-3/nl_lake + t_lake = t_soisno(1) + IF (t_soisno(1) >= tfrz) THEN + lake_icefrac = 0. + ELSE + lake_icefrac = 1. + ENDIF + + IF (wdsrf >= 100.) THEN + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + ENDIF + ENDIF + + ! ---------------------------------------- + ! energy balance + ! ---------------------------------------- + zerr=errore +#if (defined CoLMDEBUG) + IF (abs(errore) > .5) THEN + write(6,*) 'Warning: energy balance violation ',errore,patchclass + ENDIF +#endif + + ! ---------------------------------------- + ! water balance + ! ---------------------------------------- + endwb=sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa +#ifdef CROP + IF (DEF_USE_IRRIGATION) endwb = endwb + waterstorage(ipatch) +#endif + + endwb = endwb + wdsrf + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype == 2) THEN + endwb = endwb + wetwat + ENDIF + ENDIF +#if (defined CaMa_Flood) + IF (LWINFILT) THEN + IF (patchtype == 0) THEN + endwb=endwb - qinfl_fld*deltim + ENDIF + ENDIF +#endif + +#ifndef CatchLateralFlow + errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa-rnof)*deltim +#else + ! for lateral flow, "rsur" is considered in HYDRO/MOD_Hydro_SurfaceFlow.F90 + errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa)*deltim +#endif + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype==2) errorw=0. !wetland + ENDIF + + xerr=errorw/deltim + +#if (defined CoLMDEBUG) + IF (abs(errorw) > 1.e-3) THEN + IF (patchtype == 0) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (soil) ', errorw + ELSEIF (patchtype == 1) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (urban) ', errorw + ELSEIF (patchtype == 2) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (wetland) ', errorw + ELSEIF (patchtype == 4) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (dry lake) ', errorw + ENDIF + CALL CoLM_stop () + ENDIF +#endif + +!====================================================================== + + ELSEIF (patchtype == 3) THEN ! <=== is LAND ICE (glacier/ice sheet) (patchtype = 3) + +!====================================================================== + ! initial set + scvold = scv ! snow mass at previous time step + + snl = 0 + DO j=maxsnl+1,0 + IF(wliq_soisno(j)+wice_soisno(j)>0.) snl=snl-1 + ENDDO + + zi_soisno(0)=0. + IF (snl < 0) THEN + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO + ENDIF + DO j = 1,nl_soil + zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) + ENDDO + + totwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + IF (DEF_USE_VariablySaturatedFlow) THEN + totwb = wdsrf + totwb + ENDIF + + fiold(:) = 0.0 + IF (snl <0 ) THEN + fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) + ENDIF + + pg_rain = prc_rain + prl_rain + pg_snow = prc_snow + prl_snow + + t_rain = t_precip + IF (wliq_soisno(1) > dz_soisno(1)*denh2o) THEN + wextra = (wliq_soisno(1) - dz_soisno(1)*denh2o) / deltim + t_rain = (pg_rain*t_precip + wextra*t_soisno(1)) / (pg_rain + wextra) + pg_rain = pg_rain + wextra + wliq_soisno(1) = dz_soisno(1)*denh2o + totwb = totwb - wextra*deltim + ENDIF + + t_snow = t_precip + IF (wice_soisno(1) > dz_soisno(1)*denice) THEN + wextra = (wice_soisno(1) - dz_soisno(1)*denice) / deltim + t_snow = (pg_snow*t_precip + wextra*t_soisno(1)) / (pg_snow + wextra) + pg_snow = pg_snow + wextra + wice_soisno(1) = dz_soisno(1)*denice + totwb = totwb - wextra*deltim + ENDIF + + IF (pg_rain+pg_snow > 0) THEN + t_precip = (pg_rain*cpliq*t_rain + pg_snow*cpice*t_snow)/(pg_rain*cpliq+pg_snow*cpice) + ENDIF + + !---------------------------------------------------------------- + ! Initialize new snow nodes for snowfall / sleet + !---------------------------------------------------------------- + + snl_bef = snl + + CALL newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + t_precip,zi_soisno(:0),z_soisno(:0),dz_soisno(:0),t_soisno(:0),& + wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno) + + !---------------------------------------------------------------- + ! Energy and Water balance + !---------------------------------------------------------------- + lb = snl + 1 !lower bound of array + lbsn = min(lb,0) + + CALL GLACIER_TEMP (patchtype,lb ,nl_soil ,deltim ,& + zlnd ,zsno ,capr ,cnfac ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_hpbl ,& + forc_rhoair ,forc_psrf ,coszen ,sabg ,& + forc_frl ,fsno ,dz_soisno(lb:) ,& + z_soisno(lb:),zi_soisno(lb-1:) ,& + t_soisno(lb:),wice_soisno(lb:),wliq_soisno(lb:) ,& + scv ,snowdp ,imelt(lb:) ,taux ,& + tauy ,fsena ,fevpa ,lfevpa ,& + fseng ,fevpg ,olrg ,fgrnd ,& + qseva ,qsdew ,qsubl ,qfros ,& + sm ,tref ,qref ,trad ,& + errore ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,pg_rain ,& + pg_snow ,t_precip ,& + snofrz(lbsn:0), sabg_snow_lyr(lb:1) ) + + + IF (DEF_USE_SNICAR) THEN + CALL GLACIER_WATER_snicar (nl_soil ,maxsnl ,deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& + wliq_soisno ,wice_soisno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat ,ssi ,& + wimp ,forc_us ,forc_vs ,& + ! SNICAR + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + ELSE + CALL GLACIER_WATER ( nl_soil ,maxsnl ,deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& + wliq_soisno ,wice_soisno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat ,ssi ,& + wimp ,forc_us ,forc_vs ) + ENDIF + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + rsur = max(0.0,gwat) + rsub = 0. + rnof = rsur + ELSE + a = wdsrf + wliq_soisno(1) + gwat * deltim + IF (a > dz_soisno(1)*denh2o) THEN + wliq_soisno(1) = dz_soisno(1)*denh2o + wdsrf = a - wliq_soisno(1) + ELSE + wdsrf = 0. + wliq_soisno(1) = max(a, 1.e-8) + ENDIF +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rsub = 0. + rnof = rsur + rsur_se = rsur + rsur_ie = 0. +#endif + ENDIF + + lb = snl + 1 + t_grnd = t_soisno(lb) + + ! ---------------------------------------- + ! energy and water balance check + ! ---------------------------------------- + zerr=errore + + endwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + IF (DEF_USE_VariablySaturatedFlow) THEN + endwb = wdsrf + endwb + ENDIF + +#ifndef CatchLateralFlow + errorw=(endwb-totwb)-(pg_rain+pg_snow-fevpa-rnof)*deltim +#else + errorw=(endwb-totwb)-(pg_rain+pg_snow-fevpa)*deltim +#endif + +#if (defined CoLMDEBUG) + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (abs(errorw) > 1.e-3) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (land ice) ', errorw + CALL CoLM_stop () + ENDIF + ENDIF +#endif + + IF (DEF_USE_VariablySaturatedFlow) THEN + xerr=errorw/deltim + ELSE + xerr = 0. + ENDIF + +!====================================================================== + + ELSEIF (patchtype == 4) THEN ! <=== is LAND WATER BODIES + ! (lake, reservoir and river) (patchtype = 4) + +!====================================================================== + + totwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa + IF (DEF_USE_Dynamic_Lake) THEN + totwb = totwb + wdsrf + ENDIF + + snl = 0 + DO j = maxsnl+1, 0 + IF (wliq_soisno(j)+wice_soisno(j) > 0.) THEN + snl=snl-1 + ENDIF + ENDDO + + zi_soisno(0) = 0. + IF (snl < 0) THEN + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO + ENDIF + + DO j = 1,nl_soil + zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) + ENDDO + + scvold = scv !snow mass at previous time step + fiold(:) = 0.0 + IF (snl < 0) THEN + fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) + ENDIF + + w_old = sum(wliq_soisno(1:)) + sum(wice_soisno(1:)) + + pg_rain = prc_rain + prl_rain + pg_snow = prc_snow + prl_snow + +#ifndef EXTERNAL_LAKE + CALL newsnow_lake ( DEF_USE_Dynamic_Lake, & + ! "in" arguments + ! --------------- + maxsnl ,nl_lake ,deltim ,dz_lake ,& + pg_rain ,pg_snow ,t_precip ,bifall ,& + + ! "inout" arguments + ! ------------------ + t_lake ,zi_soisno(:0),z_soisno(:0) ,& + dz_soisno(:0),t_soisno(:0) ,wliq_soisno(:0) ,wice_soisno(:0) ,& + fiold(:0) ,snl ,sag ,scv ,& + snowdp ,lake_icefrac ) + + CALL laketem ( & + ! "in" laketem arguments + ! --------------------------- + patchtype ,maxsnl ,nl_soil ,nl_lake ,& + patchlatr ,deltim ,forc_hgt_u ,forc_hgt_t ,& + forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + forc_q ,forc_rhoair ,forc_psrf ,forc_sols ,& + forc_soll ,forc_solsd ,forc_solld ,sabg ,& + forc_frl ,dz_soisno ,z_soisno ,zi_soisno ,& + dz_lake ,lakedepth ,vf_quartz ,vf_gravels ,& + vf_om ,vf_sand ,wf_gravels ,wf_sand ,& + porsl ,csol ,k_solids ,& + dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,forc_hpbl ,& + + ! "inout" laketem arguments + ! --------------------------- + t_grnd ,scv ,snowdp ,t_soisno ,& + wliq_soisno ,wice_soisno ,imelt ,t_lake ,& + lake_icefrac ,savedtke1 ,& + +! SNICAR model variables + snofrz ,sabg_snow_lyr,& +! END SNICAR model variables + + ! "out" laketem arguments + ! --------------------------- + taux ,tauy ,fsena ,& + fevpa ,lfevpa ,fseng ,fevpg ,& + qseva ,qsubl ,qsdew ,qfros ,& + olrg ,fgrnd ,tref ,qref ,& + trad ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,sm ) + + CALL snowwater_lake ( DEF_USE_Dynamic_Lake, & + ! "in" snowater_lake arguments + ! --------------------------- + maxsnl ,nl_soil ,nl_lake ,deltim ,& + ssi ,wimp ,porsl ,pg_rain ,& + pg_snow ,dz_lake ,imelt(:0) ,fiold(:0) ,& + qseva ,qsubl ,qsdew ,qfros ,& + + ! "inout" snowater_lake arguments + ! --------------------------- + z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& + wice_soisno ,wliq_soisno ,t_lake ,lake_icefrac ,& + gwat ,& + fseng ,fgrnd ,snl ,scv ,& + snowdp ,sm ,forc_us ,forc_vs ,& + + ! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + +#else + CALL external_lake( & + ! "in" arguments + ! ------------------- + deltim ,patchlatr ,patchlonr ,bifall ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_frl ,sabg ,forc_hpbl ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + prc_rain ,prl_rain ,prc_snow ,prl_snow ,& + t_precip ,ipatch ,& + ! "inout" arguments + ! ------------------- + t_grnd ,t_lake ,t_soisno ,snl ,& + z_soisno ,zi_soisno ,dz_soisno ,scv ,& + savedtke1 ,sag ,snowdp ,lake_icefrac ,& + wliq_soisno ,wice_soisno ,gwat ,& +! SNICAR model variables + forc_aer ,sabg_snow_lyr ,snofrz ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! END SNICAR model variables + ! "out" arguments + ! ------------------- + fsena ,fevpa ,lfevpa ,fseng ,& + fevpg ,olrg ,fgrnd ,trad ,& + qseva ,qsubl ,qsdew ,qfros ,& + taux ,tauy ,ustar ,qstar ,& + tstar ,emis ,sm ,zol ,& + tref ,qref ,fm ,fq ,& + rib ,fh ,z0m ) +#endif + + IF (.not. DEF_USE_Dynamic_Lake) THEN + ! We assume the land water bodies have zero extra liquid water capacity + ! (i.e.,constant capacity), all excess liquid water are put into the runoff, + ! this unreasonable assumption should be updated in the future version + a = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+scv-w_old-scvold)/deltim + aa = qseva+qsubl-qsdew-qfros + rsur = max(0., pg_rain + pg_snow - aa - a) + rsub = 0. + rnof = rsur + rsur_se = rsur + rsur_ie = 0. + lake_deficit = - min(0., pg_rain + pg_snow - aa - a) + ELSE + + wdsrf = sum(dz_lake) * 1.e3 + +#ifndef CatchLateralFlow + IF (wdsrf > lakedepth*1.e3) THEN + rsur = (wdsrf - lakedepth*1.e3) / deltim + wdsrf = lakedepth*1.e3 + dz_lake = dz_lake * lakedepth/sum(dz_lake) + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + ELSE + rsur = 0. + ENDIF + rsub = 0. + rnof = rsur + rsur_se = rsur + rsur_ie = 0. +#endif + ENDIF + + endwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa + IF (DEF_USE_Dynamic_Lake) THEN + endwb = endwb + wdsrf + ELSE + endwb = endwb - lake_deficit * deltim + ENDIF + + errorw = (endwb-totwb) - (forc_prc+forc_prl-fevpa) * deltim +#ifndef CatchLateralFlow + errorw = errorw + rnof * deltim +#endif + +#if (defined CoLMDEBUG) + IF (abs(errorw) > 1.e-3) THEN + write(*,*) 'Warning: water balance violation in CoLMMAIN (lake) ', errorw + CALL CoLM_stop () + ENDIF +#endif + + IF (DEF_USE_Dynamic_Lake) THEN + xerr = errorw / deltim + ELSE + xerr = 0. + ENDIF + + ! Set zero to the empty node + IF (snl > maxsnl) THEN + wice_soisno(maxsnl+1:snl) = 0. + wliq_soisno(maxsnl+1:snl) = 0. + t_soisno (maxsnl+1:snl) = 0. + z_soisno (maxsnl+1:snl) = 0. + dz_soisno (maxsnl+1:snl) = 0. + ENDIF + +!====================================================================== + + ELSE ! <=== is OCEAN (patchtype >= 99) + +!====================================================================== +! simple ocean-sea ice model + + tssea = t_grnd + tssub (1:7) = t_soisno (1:7) + CALL SOCEAN (dosst,deltim,oro,forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_t,forc_rhoair,forc_psrf,& + sabg,forc_frl,tssea,tssub(1:7),scv,& + taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,emis,olrg) + + ! null data for sea component + z_soisno (:) = 0.0 + dz_soisno (maxsnl+1:0) = 0. + t_soisno (:) = 0.0 + t_soisno (1:7) = tssub(1:7) + wliq_soisno(:) = 0.0 + wice_soisno(:) = 0.0 + t_grnd = tssea + snowdp = scv/1000.*20. + + trad = tssea + fgrnd = 0.0 + rsur = 0.0 + rsur_se = 0.0 + rsur_ie = 0.0 + rsub = 0.0 + rnof = 0.0 + xerr = 0.0 + +!====================================================================== + ENDIF + +#if (defined CaMa_Flood) + IF (LWEVAP) THEN + IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05).and.patchtype == 0)THEN + CALL get_fldevp (forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf,t_grnd,& + forc_hpbl, & + taux_fld,tauy_fld,fseng_fld,fevpg_fld,tref_fld,qref_fld,& + z0m_fld,zol_fld,rib_fld,ustar_fld,qstar_fld,tstar_fld,fm_fld,fh_fld,fq_fld) + + IF (fevpg_fld<0.0) fevpg_fld=0.0d0 + + IF ((flddepth-deltim*fevpg_fld .gt. 0.0) .and. (fevpg_fld.gt.0.0)) THEN + flddepth=flddepth-deltim*fevpg_fld + fseng= fseng_fld*fldfrc+(1.0-fldfrc)*fseng + fevpg= fevpg_fld*fldfrc+(1.0-fldfrc)*fevpg + fevpg_fld=fevpg_fld*fldfrc + ELSE + fevpg_fld=0.0d0 + ENDIF + + ELSE + fevpg_fld=0.0d0 + ENDIF + + ELSE + fevpg_fld=0.0d0 + ENDIF +#endif + + +!====================================================================== +! Preparation for the next time step +! 1) time-varying parameters for vegetation +! 2) fraction of snow cover +! 3) solar zenith angle and +! 4) albedos +!====================================================================== + + ! cosine of solar zenith angle + calday = calendarday(idate) + coszen = orb_coszen(calday,patchlonr,patchlatr) + + IF (patchtype <= 5) THEN !LAND +#if (defined DYN_PHENOLOGY) + ! need to update lai and sai, fveg, green, they are done once in a day only + IF (dolai) THEN + CALL LAI_empirical(patchclass,nl_soil,rootfr,t_soisno(1:),lai,sai,fveg,green) + ENDIF +#endif + +! only for soil patches +!NOTE: lai from remote sensing has already considered snow coverage + +!NOTE: IF account for snow on vegetation: +! 1) should use snow-free LAI data and 2) update LAI and SAI according to snowdp + + IF (patchtype == 0) THEN + +#if (defined LULC_USGS || defined LULC_IGBP) + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + !NOTE: use snow-free LAI by defining namelist DEF_VEG_SNOW + IF ( DEF_VEG_SNOW ) THEN + lai = tlai(ipatch) * sigf + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + IF(DEF_USE_LAIFEEDBACK)THEN + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ELSE + lai_p(ps:pe) = tlai_p(ps:pe) + lai = tlai(ipatch) + + !NOTE: use snow-free LAI by defining namelist DEF_VEG_SNOW + IF ( DEF_VEG_SNOW ) THEN + lai_p(ps:pe) = tlai_p(ps:pe)*sigf_p(ps:pe) + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ENDIF + ENDIF + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) +#endif + + ELSE + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + !NOTE: use snow-free LAI by defining namelist DEF_VEG_SNOW + IF ( DEF_VEG_SNOW ) THEN + lai = tlai(ipatch) * sigf + ENDIF + ENDIF + + ! water volumetric content of soil surface layer [m3/m3] + ssw = min(1.,1.e-3*wliq_soisno(1)/dz_soisno(1)) + IF (patchtype >= 3) ssw = 1.0 + +! ============================================================================ +! Snow aging routine based on Flanner and Zender (2006), Linking snowpack +! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of +! wet-snow metamorphism in respect of liquid-water content, Ann. Glacial. + + dz_soisno_(:1) = dz_soisno(:1) + t_soisno_ (:1) = t_soisno (:1) + + IF ((patchtype == 4) .and. (.not. is_dry_lake)) THEN + dz_soisno_(1) = dz_lake(1) + t_soisno_ (1) = t_lake (1) + ENDIF + +! ============================================================================ + ! albedos + ! we supposed CALL it every time-step, because + ! other vegetation related parameters are needed to create + IF (doalb) THEN +#ifdef HYPERSPECTRAL + CALL albland_HiRes (ipatch, patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd,& + + ! new parameters for hyperspectral scheme + alb_hires ,& + dir_frac , dif_frac ,& + reflectance , transmittance ,& + soil_alb, kw, nw, porsl(1) ,& + reflectance_out, transmittance_out,& + idate(2), patchlatr, patchlonr ,& + urban_albedo, mean_albedo, lat_north, lat_south, lon_west, lon_east ) + +#else + CALL albland (ipatch,patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) +#endif + ENDIF + + ELSE !OCEAN + sag = 0.0 + IF(doalb)THEN + CALL albocean (oro,scv,coszen,alb) + ENDIF + ENDIF + + ! zero-filling set for glacier/ice-sheet/land water bodies/ocean components + IF ((patchtype > 2) .and. (.not. is_dry_lake)) THEN + lai = 0.0 + sai = 0.0 + laisun = 0.0 + laisha = 0.0 + green = 0.0 + fveg = 0.0 + sigf = 0.0 + + ssun(:,:) = 0.0 + ssha(:,:) = 0.0 + thermk = 0.0 + extkb = 0.0 + extkd = 0.0 + + tleaf = forc_t + ldew_rain = 0.0 + ldew_snow = 0.0 + fwet_snow = 0.0 + ldew = 0.0 + fsenl = 0.0 + fevpl = 0.0 + etr = 0.0 + assim = 0.0 + respc = 0.0 + + zerr = 0. + + qinfl = 0. + qlayer = 0. + qdrip = forc_rain + forc_snow + qintr = 0. + frcsat = 1. + h2osoi = 0. + rstfacsun_out = 0. + rstfacsha_out = 0. + gssun_out = 0. + gssha_out = 0. + assimsun_out = 0. + etrsun_out = 0. + assimsha_out = 0. + etrsha_out = 0. + rootr = 0. + rootflux = 0. + zwt = 0. + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = 4800. + ENDIF + + qcharge = 0. + IF (DEF_USE_PLANTHYDRAULICS)THEN + vegwp = -2.5e4 + ENDIF + ENDIF + + h2osoi = wliq_soisno(1:)/(dz_soisno(1:)*denh2o) + wice_soisno(1:)/(dz_soisno(1:)*denice) + + IF (DEF_USE_VariablySaturatedFlow) THEN + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv+wetwat + ELSE + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa + ENDIF + + z_sno (maxsnl+1:0) = z_soisno (maxsnl+1:0) + dz_sno(maxsnl+1:0) = dz_soisno(maxsnl+1:0) + +END SUBROUTINE CoLMMAIN +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 new file mode 100644 index 0000000000..f4280b27fe --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 @@ -0,0 +1,143 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_Const +!----------------------------------------------------------------------- +! DESCRIPTION: +! 1. Define constants (do not rely on satellite parameters) used in RTM. +! 2. Define parameters (IGBP) used in RTM. +! +! REFERENCES: +! [1] L-band Microwave Emission of the Biosphere (L-MEB) Model: Description +! and calibration against experimental data sets over crop fields. +! +! [2] Wigneron, J. P., Jackson, T. J., O'neill, P., De Lannoy, G., de Rosnay, P., Walker, +! J. P., ... & Kerr, Y. (2017). Modelling the passive microwave signature from land surfaces: +! A review of recent results and application to the L-band SMOS & SMAP soil moisture retrieval algorithms. +! Remote Sensing of Environment, 192, 238-262. +! +! AUTHOR: +! Lu Li, 12/2024: Initial version +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global, only: pi, N_land_classification + + IMPLICIT NONE + SAVE + + ! Constant variables + real(r8), parameter :: C = 2.998e8 ! speed of light (m/s) + real(r8), parameter :: mu0 = 4.*pi*1e-7 ! vacuum permeability (H/m) + real(r8), parameter :: eps0 = 8.854e-12 ! vacuum permittivity (Klein and Swift 1977) [Farads/meter] + real(r8), parameter :: z0 = sqrt(mu0/eps0) ! impendace of free space (Ohm) + real(r8), parameter :: eps_w_inf = 4.9 ! dielectric constant at infinite frequency (Stogryn 1971), + real(r8), parameter :: eps_0 = 8.854e-12 ! dielectric constant of free space (Klein and Swift 1977) [Farads/meter] + real(r8), parameter :: rho_soil = 2.66 ! soil specific density (g/cm3) + real(r8), parameter :: f0w = 9. ! relaxation frequency of liquid water (GHz) + real(r8), parameter :: rgh_surf = 2.2 ! soil surface roughness (cm) + complex(r8), parameter :: jj = (0., 1.) ! imaginary unit for complex number + + +#ifdef LULC_IGBP + + ! MODIS IGBP Land Use/Land Cover System Legend + !--------------------------- + ! 0 Ocean ! 海洋 + ! 1 Evergreen Needleleaf Forests ! 常绿针叶林 + ! 2 Evergreen Broadleaf Forests ! 常绿阔叶林 + ! 3 Deciduous Needleleaf Forests ! 落叶针叶林 + ! 4 Deciduous Broadleaf Forests ! 落叶阔叶林 + ! 5 Mixed Forests ! 混交林 + ! 6 Closed Shrublands ! 密闭灌丛 + ! 7 Open Shrublands ! 稀疏灌丛 + ! 8 Woody Savannas ! 木本稀树草原 + ! 9 Savannas ! 稀树草原 + !10 Grasslands ! 草地 + !11 Permanent Wetlands ! 永久性湿地 + !12 Croplands ! 农田 + !13 Urban and Built-up Lands ! 城市与建成区 + !14 Cropland/Natural Vegetation Mosaics ! 农田-自然植被镶嵌区 + !15 Permanent Snow and Ice ! 永久冰雪 + !16 Barren ! 裸地 + !17 Water Bodies ! 水体 + + ! empirical parameters to account for the dependence of optical depth on incidence angle [1] + real(r8), parameter, dimension(N_land_classification) :: tth & + = (/0.80, 1.00, 0.80, 0.49, 0.49, & + 1.00, 1.00, 1.00, 1.00, 1.00, & + 1.00, 1.00, 1.00, 1.00, 1.00, & + 1.00, 2.00/) + real(r8), parameter, dimension(N_land_classification) :: ttv & + = (/0.80, 1.00, 0.80, 0.46, 0.46, & + 1.00, 1.00, 1.00, 1.00, 1.00, & + 1.00, 2.00, 1.00, 2.00, 1.00, & + 1.00, 1.00/) + + ! empirical roughness parameters (Table 2 in [2]) + real(r8), parameter, dimension(N_land_classification) :: hr_SMAP & + = (/0.160, 0.160, 0.160, 0.160, 0.160, & + 0.110, 0.110, 0.125, 0.156, 0.156, & + 0.100, 0.108, 0.000, 0.130, 0.000, & + 0.150, 0.000/) + + real(r8), parameter, dimension(N_land_classification) :: hr_SMOS & + = (/0.300, 0.300, 0.300, 0.300, 0.300, & + 0.100, 0.100, 0.100, 0.100, 0.100, & + 0.100, 0.100, 0.100, 0.100, 0.000, & + 0.100, 0.000/) + + real(r8), parameter, dimension(N_land_classification) :: hr_P16 & + = (/0.350, 0.460, 0.430, 0.450, 0.410, & + 0.260, 0.170, 0.350, 0.230, 0.130, & + 0.020, 0.170, 0.190, 0.220, 0.000, & + 0.020, 0.000/) + + ! b parameters for Wigneron vegetation model (ref?) + real(r8), parameter, dimension(N_land_classification) :: b1 & + = (/0.2600, 0.2260, 0.2600, 0.2260, 0.2260, & + 0.0375, 0.0375, 0.0375, 0.0375, 0.0375, & + 0.0000, 0.0500, 0.0000, 0.0500, 0.0000, & + 0.0000, 0.0500/) + + real(r8), parameter, dimension(N_land_classification) :: b2 & + = (/0.0060, 0.0010, 0.0060, 0.0010, 0.0010, & + 0.0500, 0.0500, 0.0500, 0.0500, 0.0500, & + 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & + 0.0000, 0.0000/) + + real(r8), parameter, dimension(N_land_classification) :: b3 & + = (/0.6900, 0.7000, 0.6900, 0.7000, 0.7000, & + 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & + 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & + 0.0000, 0.0000/) + + ! effective diffusion albedo (Table 3 in [2]) + real(r8), parameter, dimension(N_land_classification) :: w_SMAPL2 & + = (/0.050, 0.050, 0.050, 0.050, 0.050, & + 0.050, 0.050, 0.050, 0.080, 0.050, & + 0.050, 0.000, 0.065, 0.000, 0.000, & + 0.000, 0.000/) + + real(r8), parameter, dimension(N_land_classification) :: w_CMEM & + = (/0.080, 0.095, 0.080, 0.070, 0.070, & + 0.050, 0.050, 0.050, 0.050, 0.050, & + 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000/) + + real(r8), parameter, dimension(N_land_classification) :: w_K16 & + = (/0.050, 0.050, 0.060, 0.030, 0.050, & + 0.030, 0.050, 0.040, 0.020, 0.030, & + 0.000, 0.040, 0.000, 0.020, 0.000, & + 0.000, 0.000/) + + real(r8), parameter, dimension(N_land_classification) :: w_SMAPL4 & + = (/0.120, 0.080, 0.120, 0.100, 0.120, & + 0.140, 0.110, 0.130, 0.120, 0.070, & + 0.000, 0.120, 0.000, 0.150, 0.000, & + 0.000, 0.000/) +#endif + +END MODULE MOD_DA_Const +!----------------------------------------------------------------------------- +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 new file mode 100644 index 0000000000..1ec32f06e1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 @@ -0,0 +1,137 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_EnKF +!----------------------------------------------------------------------------- +! DESCRIPTION: +! ensemble Kalman filter (EnKF) types +! +! AUTHOR: +! Lu Li, 12/2024: Initial version +! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes +!----------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_SPMD_Task + IMPLICIT NONE + SAVE + +! public functions + PUBLIC :: letkf + + +!----------------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE letkf (& + num_ens, num_obs, & + HA, y, R, infl, & + trans) + +!----------------------------------------------------------------------------- +! Description: +! local transform ensemble Kalman filter +! +! Original author : +! Lu Li, 12/2024 +!----------------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + +!------------------------ Dummy Arguments ------------------------------------ + integer, intent(in) :: num_ens ! ensemble size + integer, intent(in) :: num_obs ! number of observations + real(r8), intent(in) :: HA(num_obs, num_ens) ! ensemble predicted observation matrix + real(r8), intent(in) :: y(num_obs) ! observation vector + real(r8), intent(in) :: R(num_obs) ! observation error variance + real(r8), intent(in) :: infl ! inflation factor + real(r8), intent(out) :: trans(num_ens, num_ens) ! transform matrix (k x k) + +!------------------------ Local Variables ------------------------------------ + real(r8) :: HA_mean(num_obs) ! mean of ensemble predicted observation (l) + real(r8) :: dHA(num_obs, num_ens) ! HA - mean(HA) (l x k) + real(r8) :: dHA_t(num_ens, num_obs) ! transpose of dHA (k x l) + real(r8) :: C(num_ens, num_obs) ! C = (dHA)^T * (R)^-1 (k x l) + real(r8) :: M1(num_ens, num_ens) ! C * dHA (k x k) + real(r8) :: pa_inv(num_ens, num_ens) ! inverse of background error covariance matrix (k x k) + real(r8) :: eigval(num_ens) ! eigenvalues of pa_inv (k) + real(r8) :: eigvec(num_ens, num_ens) ! eigenvectors of pa_inv (k x k) + integer :: lwork + real(r8), allocatable :: work(:) + integer :: err + real(r8) :: M2(num_ens, num_ens) ! M2 = eigvec * eigval^-1 (k x k) + real(r8) :: pa(num_ens, num_ens) ! background error covariance matrix (k x k) + real(r8) :: M3(num_ens, num_obs) ! M3 = pa * C (k x l) + real(r8) :: delta(num_obs) ! increment of observation (l) + real(r8) :: w_avg(num_ens) ! weight (k) + real(r8) :: M4(num_ens, num_ens) ! M4 = eigvec * sqrt((k-1)/eigval) (k x k) + real(r8) :: trans_pert(num_ens, num_ens) ! perturbation transform matrix (k x k) + real(r8) :: I0(num_ens, num_ens) ! identity matrix (k x k) + real(r8) :: one_div_ens(num_ens) ! 1/num_ens + integer :: i, j + +!----------------------------------------------------------------------------- + + ! calculate observation space perturbation + HA_mean = sum(HA, dim=2) / size(HA, dim=2) !(lx1) + DO j = 1, num_ens + dHA(:,j) = HA(:,j) - HA_mean !(lxk) + ENDDO + + ! calculate C, intermediate matrix in localized observation + dHA_t = transpose(dHA) !(kxl) + DO j = 1, num_obs + C(:,j) = dHA_t(:,j) / (R(j)) !(kxl) + ENDDO + + ! calculate C*dHA, intermediate matrix in background error M1 + CALL dgemm('N', 'N', num_ens, num_ens, num_obs, 1.0_8, C, num_ens, dHA, num_obs, 0.0_8, M1, num_ens) + + ! calculate inverse of background error + pa_inv = M1 + do i=1, num_ens + pa_inv(i,i) = M1(i,i) + (num_ens-1)*1.0d0/infl + end do + + ! eigenvalues and eigenvectors of inverse of background error + lwork = 4 * num_ens + allocate( work(lwork) ) + CALL dsyev('V', 'U', num_ens, pa_inv, num_ens, eigval, work, lwork, err) + eigvec = pa_inv !(kxk) + + ! calculate background error covariance matrix pa = eigvec (eigval)^-1 eigvec^T + DO i = 1, num_ens + M2(:,i) = eigvec(:,i) / eigval(i) !(kxk) + ENDDO + CALL dgemm('N', 'T', num_ens, num_ens, num_ens, 1.0_8, M2, num_ens, eigvec, num_ens, 0.0_8, pa, num_ens) !(kxk) + + ! caculate pa * C, intermediate matrix in Kalman gain M3 + CALL dgemm('N', 'N', num_ens, num_obs, num_ens, 1.0_8, pa, num_ens, C, num_ens, 0.0_8, M3, num_ens) !(kxl) + + ! calculate weight + delta = y - HA_mean + CALL dgemm('N', 'N', num_ens, 1, num_obs, 1.0_8, M3, num_ens, delta, num_obs, 0.0_8, w_avg, num_ens) !(kx1) + + ! calculate pertubation transform matrix + DO j = 1, num_ens + M4(:,j) = eigvec(:,j) * sqrt((num_ens-1) / eigval(j)) !(kxk) + ENDDO + CALL dgemm('N', 'T', num_ens, num_ens, num_ens, 1.0_8, M4, num_ens, eigvec, num_ens, 0.0_8, trans_pert, num_ens) !(kxk) + + ! calculate transform matrix + one_div_ens(:) = 1./num_ens + I0 = -1.0 / num_ens + DO i = 1, num_ens + I0(i, i) = 1.0 - 1./num_ens + ENDDO + DO j = 1, num_ens + trans(:, j) = matmul(trans_pert(:, j) + w_avg(:), I0) + one_div_ens(:) + ENDDO + + END SUBROUTINE letkf + +!----------------------------------------------------------------------------- +END MODULE MOD_DA_EnKF +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 new file mode 100644 index 0000000000..8eea429ae2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 @@ -0,0 +1,267 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_Ensemble +!----------------------------------------------------------------------- +! DESCRIPTION: +! Provide functions to generate ensemble samples for data assimilation +! +! REFERENCES: +! [1] Algorithm Theoretical Basis Document Level 4 Surface and Root +! Zone Soil Moisture (L4_SM) Data Product +! +! AUTHOR: +! Lu Li, 12/2024: Initial version +! Lu Li, 10/2025: Consider correlation & AR(1) process +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + USE MOD_Vars_TimeVariables + USE MOD_DA_Vars_TimeVariables + USE MOD_Vars_1DForcing + USE MOD_LandPatch + IMPLICIT NONE + SAVE + + ! public functions + PUBLIC :: ensemble + + ! local parameters + ! forcing [parameters used here is consistent with SMAP L4 (Table 4 in [1])] + integer, parameter :: nvar = 4 ! number of pertutated forcing variables + real(r8), parameter :: tau_ar = 24.0 ! correlation time scale in hours + + real(r8) :: dt ! time step in hours + real(r8) :: phi ! AR(1) autocorrelation coefficient consider time scale + real(r8) :: sigma_eps ! standard deviation of noise in AR(1) process + real(r8), dimension(nvar) :: sigma = (/0.5, 0.3, 20.0, 1.0/) ! standard deviation of perturbed forcing variables (prcp, sw, lw, t) + real(r8), dimension(nvar, nvar) :: C = reshape([ & + 1.0, -0.8, 0.5, 0.0, & + -0.8, 1.0, -0.5, 0.4, & + 0.5, -0.5, 1.0, 0.4, & + 0.0, 0.4, 0.4, 1.0], shape=[nvar, nvar]) ! cross-correlation matrix between perturbed forcing variables + real(r8), allocatable :: r_prev(:,:,:) ! previous perturbation (numpatch, nvar, DEF_DA_ENS_NUM) + real(r8), allocatable :: r_curr(:,:,:) ! current perturbation (numpatch, nvar, DEF_DA_ENS_NUM) + logical :: initialized = .false. ! flag to indicate if is initialized + + ! soil moisture [default set 0.002 m3/m3 disterbulance] + integer, parameter :: nvar_sm = 2 ! number of pertutated soil moisture layers + real(r8), parameter :: tau_sm = 3.0 ! correlation time scale in hours + real(r8) :: phi_sm ! AR(1) autocorrelation coefficient consider time scale + real(r8) :: sigma_eps_sm ! standard deviation of noise in AR(1) process + real(r8), dimension(nvar_sm) :: sigma_sm = (/0.035, 0.0552/) ! standard deviation of perturbed soil moisture (equal to 0.002 m3/m3) + real(r8), allocatable :: r_prev_sm(:,:,:) ! previous perturbation (numpatch, nvar_sm, DEF_DA_ENS_NUM) + real(r8), allocatable :: r_curr_sm(:,:,:) ! current perturbation (numpatch, nvar_sm, DEF_DA_ENS_NUM) + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE ensemble(deltim) + +!----------------------------------------------------------------------- + IMPLICIT NONE + + real(r8), intent(in) :: deltim + +!------------------------ Local Variables ------------------------------ + integer :: np, i, j + + real(r8) :: cov_matrix(nvar, nvar) ! covariance matrix between perturbed forcing variables + real(r8) :: L(nvar, nvar) ! Cholesky decomposition of correlation matrix + integer :: info ! info flag for Cholesky decomposition + real(r8) :: u1(DEF_DA_ENS_NUM/2), u2(DEF_DA_ENS_NUM/2) ! uniform random variables + real(r8) :: z(nvar, DEF_DA_ENS_NUM) ! standard normal random variables + real(r8) :: mean_z(nvar) ! mean of perturbation (nvar) + real(r8) :: std_z(nvar) ! std of perturbation (nvar) + real(r8) :: zxL(nvar, DEF_DA_ENS_NUM) ! correlated random variables (nvar, DEF_DA_ENS_NUM) + + real(r8) :: z_sm(DEF_DA_ENS_NUM) ! standard normal random variables + real(r8) :: mean_z_sm ! mean of perturbation + real(r8) :: std_z_sm ! std of perturbation + real(r8) :: mean_r_sm(nvar_sm) ! mean of perturbation for soil moisture (nvar_sm) + real(r8) :: std_r_sm(nvar_sm) ! std of perturbation for soil moisture (nvar_sm) + real(r8) :: a1(DEF_DA_ENS_NUM) ! temporary disturbed variable for soil moisture layer 1 + real(r8) :: a2(DEF_DA_ENS_NUM) ! temporary disturbed variable for soil moisture layer 2 + +!----------------------------------------------------------------------- + + ! initialize persistent variables + IF (.not. initialized) THEN + allocate(r_prev(numpatch, nvar, DEF_DA_ENS_NUM)) + allocate(r_curr(numpatch, nvar, DEF_DA_ENS_NUM)) + allocate(r_prev_sm(numpatch, nvar_sm, DEF_DA_ENS_NUM)) + allocate(r_curr_sm(numpatch, nvar_sm, DEF_DA_ENS_NUM)) + r_prev = 0.0_r8 + r_curr = 0.0_r8 + r_prev_sm = 0.0_r8 + r_curr_sm = 0.0_r8 + initialized = .true. + ENDIF + + ! calculate AR(1) parameters + dt = deltim/3600 + phi = exp(-dt/tau_ar) + sigma_eps = sqrt(1.0 - phi**2) + phi_sm = exp(-dt/tau_sm) + sigma_eps_sm = sqrt(1.0 - phi_sm**2) + + ! calculate covariance matrix by cross-correlation matrix and standard deviation + cov_matrix = 0.0_r8 + DO i = 1, nvar + DO j = 1, nvar + cov_matrix(i,j) = C(i,j) * sigma(i) * sigma(j) + ENDDO + ENDDO + + ! perform Cholesky decomposition of covariance matrix + L = cov_matrix + CALL dpotrf('L', nvar, L, nvar, info) + DO i = 1, nvar + DO j = i+1, nvar + L(i,j) = 0.0_r8 + ENDDO + ENDDO + IF (info /= 0) THEN + print *, 'Error: Cholesky decomposition failed' + stop + ENDIF + + ! Generate ensemble samples for forcing variables + DO np = 1, numpatch + ! generate disturbance ensemble samples ~ N(0, I) + CALL random_seed() + CALL random_number(u1) + CALL random_number(u2) + DO i = 1, DEF_DA_ENS_NUM/2 + u1(i) = max(u1(i), 1e-10) ! ensure u1 is not zero + z(1,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) + z(1,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) + ENDDO + CALL random_seed() + CALL random_number(u1) + CALL random_number(u2) + DO i = 1, DEF_DA_ENS_NUM/2 + u1(i) = max(u1(i), 1e-10) + z(2,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) + z(2,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) + ENDDO + CALL random_seed() + CALL random_number(u1) + CALL random_number(u2) + DO i = 1, DEF_DA_ENS_NUM/2 + u1(i) = max(u1(i), 1e-10) + z(3,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) + z(3,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) + ENDDO + CALL random_seed() + CALL random_number(u1) + CALL random_number(u2) + DO i = 1, DEF_DA_ENS_NUM/2 + u1(i) = max(u1(i), 1e-10) + z(4,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) + z(4,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) + ENDDO + + ! normalize z to mean 0 and std 1 + DO i = 1, nvar + mean_z(i) = sum(z(i, :))/DEF_DA_ENS_NUM + std_z(i) = sqrt(sum((z(i, :) - mean_z(i))**2)/(DEF_DA_ENS_NUM - 1)) + ENDDO + DO i = 1, nvar + z(i,:) = (z(i,:)-mean_z(i))/std_z(i) + ENDDO + + ! multiply by Cholesky factor to introduce correlation (z*L) + CALL dgemm('N', 'N', nvar, DEF_DA_ENS_NUM, nvar, 1.0_r8, L, nvar, z, nvar, 0.0_r8, zxL, nvar) + + ! introduce correlation using AR(1) process + DO i = 1, nvar + DO j = 1, DEF_DA_ENS_NUM + r_curr(np,i,j) = phi * r_prev(np,i,j) + sigma_eps * zxL(i,j) + ENDDO + ENDDO + ! no AR(1) process, directly use correlated random variables + ! r_curr(np,:,:) = zxL + + ! normalize the disturbance ensemble samples to mean 0 + mean_z = sum(r_curr(np,:,:), dim=2)/DEF_DA_ENS_NUM + DO i = 1, nvar + DO j = 1, DEF_DA_ENS_NUM + r_curr(np,i,j) = r_curr(np,i,j) - mean_z(i) + ENDDO + ENDDO + + ! save current perturbation as previous perturbation for next time step + r_prev = r_curr + + ! generate ensemble samples according different types + DO j = 1, DEF_DA_ENS_NUM + forc_prc_ens(j,np) = forc_prc(np) * exp(r_curr(np,1,j) - 0.5 * sigma(1)**2) + forc_prl_ens(j,np) = forc_prl(np) * exp(r_curr(np,1,j) - 0.5 * sigma(1)**2) + forc_sols_ens(j,np) = forc_sols(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) + forc_soll_ens(j,np) = forc_soll(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) + forc_solsd_ens(j,np) = forc_solsd(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) + forc_solld_ens(j,np) = forc_solld(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) + forc_frl_ens(j,np) = forc_frl(np) + r_curr(np,3,j) + forc_t_ens(j,np) = forc_t(np) + r_curr(np,4,j) + ENDDO + + IF (DEF_DA_ENS_SM) THEN + ! generate ensemble samples (0, I) for soil moisture + CALL random_seed() + CALL random_number(u1) + CALL random_number(u2) + DO i = 1, DEF_DA_ENS_NUM/2 + u1(i) = max(u1(i), 1e-10) + z_sm(i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) + z_sm(i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) + ENDDO + mean_z_sm = sum(z_sm)/DEF_DA_ENS_NUM + std_z_sm = sqrt(sum((z_sm - mean_z_sm)**2)/(DEF_DA_ENS_NUM - 1)) + z_sm = (z_sm - mean_z_sm)/std_z_sm + + ! introduce correlation using AR(1) process + DO i = 1, nvar_sm + DO j = 1, DEF_DA_ENS_NUM + r_curr_sm(np,i,j) = phi_sm * r_prev_sm(np,i,j) + sigma_eps_sm * sigma_sm(i) * z_sm(j) + ENDDO + ENDDO + + ! normalize the disturbance ensemble samples to mean 0 + mean_r_sm = sum(r_curr_sm(np,:,:), dim=2)/DEF_DA_ENS_NUM + DO i = 1, nvar_sm + DO j = 1, DEF_DA_ENS_NUM + r_curr_sm(np,i,j) = r_curr_sm(np,i,j) - mean_r_sm(i) + ENDDO + ENDDO + + ! save current perturbation as previous perturbation for next time step + r_prev_sm = r_curr_sm + + ! generate ensemble samples according different types + DO j = 1, DEF_DA_ENS_NUM + a1(j) = wliq_soisno_ens(1,j,np) + r_curr_sm(np,1,j) + a2(j) = wliq_soisno_ens(2,j,np) + r_curr_sm(np,2,j) + ENDDO + DO j = 1, DEF_DA_ENS_NUM + a1(j) = max(1e-10, a1(j)) + a2(j) = max(1e-10, a2(j)) + ENDDO + + ! move residual water to water table + DO j = 1, DEF_DA_ENS_NUM + wa_ens(j, np) = wa_ens(j, np) - (sum(wliq_soisno_ens(1:2, j, np)) - a1(j) - a2(j)) + wliq_soisno_ens(1, j, np) = a1(j) + wliq_soisno_ens(2, j, np) = a2(j) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE ensemble + +!----------------------------------------------------------------------- +END MODULE MOD_DA_Ensemble +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 new file mode 100644 index 0000000000..eaa662796f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 @@ -0,0 +1,396 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_Main +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Main procedures for data assimilation +! +! AUTHOR: +! Lu Li, 12/2024 +! Zhilong Fan, Lu Li, 03/2024 +!----------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Spmd_task + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_LandPatch + USE MOD_DA_TWS + USE MOD_DA_SM + USE MOD_DA_Ensemble + USE MOD_Vars_1DFluxes + USE MOD_Vars_TimeVariables + USE MOD_Vars_1DForcing + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE init_DA () + +!----------------------------------------------------------------------------- + IMPLICIT NONE + +!----------------------------------------------------------------------------- + +!############################################################################# +! Init data assimilation for different products +!############################################################################# + IF (DEF_DA_TWS) THEN + IF (DEF_DA_TWS_GRACE) THEN + CALL init_DA_GRACE () + ENDIF + ENDIF + + IF (DEF_DA_SM) THEN + IF (p_is_master) THEN + print *, '[CoLM-DA] initialize surface soil moisture & temperature data assimilation.' + ENDIF + CALL init_DA_SM () + ENDIF + + END SUBROUTINE init_DA + +!----------------------------------------------------------------------------- + + SUBROUTINE run_DA (idate, deltim, dolai, doalb, dosst, oro) + +!----------------------------------------------------------------------------- + IMPLICIT NONE + +!------------------------ Dummy Arguments ------------------------------------ + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: dolai ! true if time for time-varying vegetation parameter + logical, intent(in) :: doalb ! true if time for surface albedo calculation + logical, intent(in) :: dosst ! true if time for update sst/ice/snow + + real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag + +!------------------------ Local Variables ------------------------------------ + integer :: np, i, maxday + integer :: sdate(3) ! backward date from the end to the begin of the time step + +!----------------------------------------------------------------------------- + + ! use OI for terrestrial water storage + IF (DEF_DA_TWS) THEN + IF (DEF_DA_TWS_GRACE) THEN + CALL run_DA_GRACE (idate, deltim) + ENDIF + ENDIF + + ! use ensemble DA for soil moisture + IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN +!############################################################################# +! Generate ensemble members +!############################################################################# + IF (p_is_worker) THEN + + ! store the non-DA trajectory + z_sno_noda = z_sno + dz_sno_noda = dz_sno + t_soisno_noda = t_soisno + wliq_soisno_noda = wliq_soisno + wice_soisno_noda = wice_soisno + smp_noda = smp + hk_noda = hk + t_grnd_noda = t_grnd + tleaf_noda = tleaf + ldew_noda = ldew + ldew_rain_noda = ldew_rain + ldew_snow_noda = ldew_snow + fwet_snow_noda = fwet_snow + sag_noda = sag + scv_noda = scv + snowdp_noda = snowdp + fveg_noda = fveg + fsno_noda = fsno + sigf_noda = sigf + green_noda = green + tlai_noda = tlai + lai_noda = lai + tsai_noda = tsai + sai_noda = sai + alb_noda = alb + ssun_noda = ssun + ssha_noda = ssha + ssoi_noda = ssoi + ssno_noda = ssno + thermk_noda = thermk + extkb_noda = extkb + extkd_noda = extkd + zwt_noda = zwt + wdsrf_noda = wdsrf + wa_noda = wa + wetwat_noda = wetwat + t_lake_noda = t_lake + lake_icefrac_noda = lake_icefrac + savedtke1_noda = savedtke1 + + tref_noda = tref + h2osoi_noda = h2osoi + + ! Generate ensemble members + CALL ensemble (deltim) + + ! loop over ensemble members + DO i = 1, DEF_DA_ENS_NUM + ! set ensemble forcing variables + forc_t = forc_t_ens(i,:) + forc_prc = forc_prc_ens(i,:) + forc_prl = forc_prl_ens(i,:) + forc_sols = forc_sols_ens(i,:) + forc_soll = forc_soll_ens(i,:) + forc_solsd = forc_solsd_ens(i,:) + forc_solld = forc_solld_ens(i,:) + forc_frl = forc_frl_ens(i,:) + + ! give the i-th trajectory state value to state variables + z_sno = z_sno_ens ( :,i,:) + dz_sno = dz_sno_ens ( :,i,:) + t_soisno = t_soisno_ens ( :,i,:) + wliq_soisno = wliq_soisno_ens ( :,i,:) + wice_soisno = wice_soisno_ens ( :,i,:) + smp = smp_ens ( :,i,:) + hk = hk_ens ( :,i,:) + t_grnd = t_grnd_ens ( i,:) + tleaf = tleaf_ens ( i,:) + ldew = ldew_ens ( i,:) + ldew_rain = ldew_rain_ens ( i,:) + ldew_snow = ldew_snow_ens ( i,:) + fwet_snow = fwet_snow_ens ( i,:) + sag = sag_ens ( i,:) + scv = scv_ens ( i,:) + snowdp = snowdp_ens ( i,:) + fveg = fveg_ens ( i,:) + fsno = fsno_ens ( i,:) + sigf = sigf_ens ( i,:) + green = green_ens ( i,:) + tlai = tlai_ens ( i,:) + lai = lai_ens ( i,:) + tsai = tsai_ens ( i,:) + sai = sai_ens ( i,:) + alb = alb_ens (:,:,i,:) + ssun = ssun_ens (:,:,i,:) + ssha = ssha_ens (:,:,i,:) + ssoi = ssoi_ens (:,:,i,:) + ssno = ssno_ens (:,:,i,:) + thermk = thermk_ens ( i,:) + extkb = extkb_ens ( i,:) + extkd = extkd_ens ( i,:) + zwt = zwt_ens ( i,:) + wdsrf = wdsrf_ens ( i,:) + wa = wa_ens ( i,:) + wetwat = wetwat_ens ( i,:) + t_lake = t_lake_ens ( :,i,:) + lake_icefrac = lake_icefrac_ens( :,i,:) + savedtke1 = savedtke1_ens ( i,:) + + ! run colm + CALL CoLMDRIVER (idate, deltim, dolai, doalb, dosst, oro) + + ! output ensemble members + z_sno_ens ( :,i,:) = z_sno + dz_sno_ens ( :,i,:) = dz_sno + t_soisno_ens ( :,i,:) = t_soisno + wliq_soisno_ens ( :,i,:) = wliq_soisno + wice_soisno_ens ( :,i,:) = wice_soisno + smp_ens ( :,i,:) = smp + hk_ens ( :,i,:) = hk + t_grnd_ens ( i,:) = t_grnd + tleaf_ens ( i,:) = tleaf + ldew_ens ( i,:) = ldew + ldew_rain_ens ( i,:) = ldew_rain + ldew_snow_ens ( i,:) = ldew_snow + fwet_snow_ens ( i,:) = fwet_snow + sag_ens ( i,:) = sag + scv_ens ( i,:) = scv + snowdp_ens ( i,:) = snowdp + fveg_ens ( i,:) = fveg + fsno_ens ( i,:) = fsno + sigf_ens ( i,:) = sigf + green_ens ( i,:) = green + tlai_ens ( i,:) = tlai + lai_ens ( i,:) = lai + tsai_ens ( i,:) = tsai + sai_ens ( i,:) = sai + alb_ens (:,:,i,:) = alb + ssun_ens (:,:,i,:) = ssun + ssha_ens (:,:,i,:) = ssha + ssoi_ens (:,:,i,:) = ssoi + ssno_ens (:,:,i,:) = ssno + thermk_ens ( i,:) = thermk + extkb_ens ( i,:) = extkb + extkd_ens ( i,:) = extkd + zwt_ens ( i,:) = zwt + wdsrf_ens ( i,:) = wdsrf + wa_ens ( i,:) = wa + wetwat_ens ( i,:) = wetwat + t_lake_ens ( :,i,:) = t_lake + lake_icefrac_ens( :,i,:) = lake_icefrac + savedtke1_ens ( i,:) = savedtke1 + + h2osoi_ens(:,i,:) = h2osoi + trad_ens (i,:) = trad + tref_ens (i,:) = tref + qref_ens (i,:) = qref + ustar_ens (i,:) = ustar + qstar_ens (i,:) = qstar + tstar_ens (i,:) = tstar + fm_ens (i,:) = fm + fh_ens (i,:) = fh + fq_ens (i,:) = fq + + fsena_ens (i,:) = fsena + lfevpa_ens(i,:) = lfevpa + fevpa_ens (i,:) = fevpa + rsur_ens (i,:) = rsur + ENDDO + + ! recover the no-DA trajectory + z_sno = z_sno_noda + dz_sno = dz_sno_noda + t_soisno = t_soisno_noda + wliq_soisno = wliq_soisno_noda + wice_soisno = wice_soisno_noda + smp = smp_noda + hk = hk_noda + t_grnd = t_grnd_noda + tleaf = tleaf_noda + ldew = ldew_noda + ldew_rain = ldew_rain_noda + ldew_snow = ldew_snow_noda + fwet_snow = fwet_snow_noda + sag = sag_noda + scv = scv_noda + snowdp = snowdp_noda + fveg = fveg_noda + fsno = fsno_noda + sigf = sigf_noda + green = green_noda + tlai = tlai_noda + lai = lai_noda + tsai = tsai_noda + sai = sai_noda + alb = alb_noda + ssun = ssun_noda + ssha = ssha_noda + ssoi = ssoi_noda + ssno = ssno_noda + thermk = thermk_noda + extkb = extkb_noda + extkd = extkd_noda + zwt = zwt_noda + wdsrf = wdsrf_noda + wa = wa_noda + wetwat = wetwat_noda + t_lake = t_lake_noda + lake_icefrac = lake_icefrac_noda + savedtke1 = savedtke1_noda + + tref = tref_noda + h2osoi = h2osoi_noda + + ENDIF + ENDIF + +!############################################################################# +! Perform data assimilation for different satellite products +!############################################################################# + IF (DEF_DA_SM) THEN + ! backward date from the end to the begin of the time step + sdate = idate + sdate(3) = sdate(3) - nint(deltim) + IF (sdate(3) < 0) THEN + sdate(2) = sdate(2) - 1 + sdate(3) = sdate(3) + 86400 + + IF (sdate(2) < 1) THEN + sdate(1) = sdate(1) - 1 + IF (isleapyear(sdate(1))) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + sdate(2) = maxday + ENDIF + ENDIF + + ! data assimilation + IF (DEF_DA_SM) THEN + IF (p_is_master) THEN + print *, '[CoLM-DA] Start surface soil moisture & temperature data assimilation.' + ENDIF + CALL mpi_barrier (p_comm_glb, p_err) + CALL run_DA_SM (sdate, deltim) + ENDIF + ENDIF + +!############################################################################# +! Use ensemble mean for important outputs +!############################################################################# + IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO np = 1, numpatch + ! important state variables + t_soisno_a(:,np) = sum(t_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM + wliq_soisno_a(:,np) = sum(wliq_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM + wice_soisno_a(:,np) = sum(wice_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM + t_grnd_a(np) = sum(t_grnd_ens(:,np), dim=1) / DEF_DA_ENS_NUM + tleaf_a(np) = sum(tleaf_ens(:,np), dim=1) / DEF_DA_ENS_NUM + snowdp_a(np) = sum(snowdp_ens(:,np), dim=1) / DEF_DA_ENS_NUM + + ! diagnostic variables + h2osoi_a(:,np) = sum(h2osoi_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM + t_brt_smap_a(:,np) = sum(t_brt_smap_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM + t_brt_fy3d_a(:,np) = sum(t_brt_fy3d_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM + trad_a(np) = sum(trad_ens(:,np), dim=1) / DEF_DA_ENS_NUM + tref_a(np) = sum(tref_ens(:,np), dim=1) / DEF_DA_ENS_NUM + qref_a(np) = sum(qref_ens(:,np), dim=1) / DEF_DA_ENS_NUM + ustar_a(np) = sum(ustar_ens(:,np), dim=1) / DEF_DA_ENS_NUM + qstar_a(np) = sum(qstar_ens(:,np), dim=1) / DEF_DA_ENS_NUM + tstar_a(np) = sum(tstar_ens(:,np), dim=1) / DEF_DA_ENS_NUM + fm_a(np) = sum(fm_ens(:,np), dim=1) / DEF_DA_ENS_NUM + fh_a(np) = sum(fh_ens(:,np), dim=1) / DEF_DA_ENS_NUM + fq_a(np) = sum(fq_ens(:,np), dim=1) / DEF_DA_ENS_NUM + fsena_a(np) = sum(fsena_ens(:,np), dim=1) / DEF_DA_ENS_NUM + fevpa_a(np) = sum(fevpa_ens(:,np), dim=1) / DEF_DA_ENS_NUM + lfevpa_a(np) = sum(lfevpa_ens(:,np), dim=1) / DEF_DA_ENS_NUM + rsur_a(np) = sum(rsur_ens(:,np), dim=1) / DEF_DA_ENS_NUM + ENDDO + ENDIF + ENDIF + ENDIF + + END SUBROUTINE run_DA + +!----------------------------------------------------------------------------- + + SUBROUTINE end_DA () + +!----------------------------------------------------------------------------- + IMPLICIT NONE + +!----------------------------------------------------------------------------- + + IF (DEF_DA_TWS) THEN + IF (DEF_DA_TWS_GRACE) THEN + CALL end_DA_GRACE () + ENDIF + ENDIF + + IF (DEF_DA_SM) THEN + CALL end_DA_SM () + ENDIF + + END SUBROUTINE end_DA + +!----------------------------------------------------------------------------- +END MODULE MOD_DA_Main +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 new file mode 100644 index 0000000000..ef234e5cba --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 @@ -0,0 +1,1431 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_RTM +!----------------------------------------------------------------------- +! DESCRIPTION: +! Forward modeling of brightness temperature observations +! +! AUTHOR: +! Lu Li, 12/2024: Initial version +! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes +! Lu Li, 10/2025: Debug and clean codes +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + USE MOD_Vars_1DForcing + USE MOD_DA_Const + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: nl_soil, nl_lake, N_land_classification + USE MOD_Namelist + IMPLICIT NONE + SAVE + +! public functions + PUBLIC :: forward + +! local variables (parameters depends on frequency and incidence angle of satellite) + real(r8) :: fghz ! frequency of satellite (GHz) + real(r8) :: theta ! incidence angle of satellite (rad) + real(r8) :: f ! frequency (Hz) + real(r8) :: omega ! radian frequency + real(r8) :: lam ! wavelength (m) + real(r8) :: k ! wave number (rad/m) + real(r8) :: kcm ! wave number (rad/cm) + real(r8) :: kr ! size parameter used in calcuate single-particle albedo + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE forward( & + patchtype, patchclass, dz_sno, & + forc_topo, htop, & + tref, t_soisno, tleaf, & + wliq_soisno, wice_soisno, h2osoi, & + snowdp, lai, sai, & + wf_clay, wf_sand, wf_silt, BD_all, porsl, & + sat_theta, sat_fghz, & + tb_toa_h, tb_toa_v) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Forward modeling of brightness temperature observations +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + USE MOD_Vars_Global, only: nl_soil, nl_lake, maxsnl, spval, dz_soi + USE MOD_DA_Const + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + integer, intent(in) :: patchtype ! land cover type + integer, intent(in) :: patchclass ! land cover class + real(r8), intent(in) :: dz_sno(maxsnl + 1:0) ! layer thickness (m) + real(r8), intent(in) :: forc_topo ! topography [m] + real(r8), intent(in) :: htop ! upper height of vegetation [m] + real(r8), intent(in) :: tref ! 2 m height air temperature [kelvin] + real(r8), intent(in) :: tleaf ! leaf temperature [K] + real(r8), intent(in) :: t_soisno(maxsnl + 1:nl_soil) ! soil temperature [K] + real(r8), intent(in) :: wliq_soisno(maxsnl + 1:nl_soil) ! liquid water in layers [kg/m2] + real(r8), intent(in) :: wice_soisno(maxsnl + 1:nl_soil) ! ice lens in layers [kg/m2] + real(r8), intent(in) :: h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3] + real(r8), intent(in) :: snowdp ! snow depth [meter] + real(r8), intent(in) :: lai ! leaf area index + real(r8), intent(in) :: sai ! stem area index + real(r8), intent(in) :: wf_clay(nl_soil) ! gravimetric fraction of clay + real(r8), intent(in) :: wf_sand(nl_soil) ! gravimetric fraction of sand + real(r8), intent(in) :: wf_silt(nl_soil) ! gravimetric fraction of silt + real(r8), intent(in) :: BD_all(nl_soil) ! bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3) + real(r8), intent(in) :: porsl(nl_soil) ! fraction of soil that is voids [-] + real(r8), intent(in) :: sat_theta ! incidence angle of satellite (rad) + real(r8), intent(in) :: sat_fghz ! frequency of satellite (GHz) + real(r8), intent(out) :: tb_toa_h ! brightness temperature of top-of-atmosphere for H- polarization + real(r8), intent(out) :: tb_toa_v ! brightness temperature of top-of-atmosphere for V- polarization + +!----------------------- Local Variables ------------------------------- + logical :: is_low_veg ! flag for low vegetation + real(r8) :: dz_soisno(maxsnl+1:nl_soil) ! liquid water in layers [kg/m2] + integer :: lb ! lower bound of arrays + real(r8) :: tau_atm ! atmospheric optical depth + real(r8) :: r_r(2) ! rough surface reflectivity for H and V polarizations + real(r8) :: r_sn(2) ! reflectivity between the snow and ground for H and V polarizations + real(r8) :: r_snow(2) ! reflectivity of the snow for H and V polarizations + real(r8) :: tb_soil(2) ! brightness temperature of soil for H and V polarizations + real(r8) :: tb_tos(2) ! brightness temperature of snow-covered ground for H and V polarizations + real(r8) :: tb_tov(2) ! brightness temperature of vegetation (consider snow) for H and V polarizations + real(r8) :: tb_tov_noad(2) ! brightness temperature of vegetation (no downwelling radiation) for H and V polarizations + real(r8) :: tb_au(2) ! upwelling radiation (brightness temperature) of atmosphere + real(r8) :: tb_ad(2) ! downwelling radiation (brightness temperature) of atmosphere + real(r8) :: rho_snow ! snow density (g/cm3) + real(r8) :: liq_snow ! snow liquid water content (cm3/cm3) + real(r8) :: gamma_p(2) ! vegetation opacity for H- and V- polarization + real(r8) :: tb_veg(2) ! brightness temperature of vegetation for H- and V- polarization + real(r8) :: tb_2(2) ! the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer + real(r8) :: tb_3(2) ! upwelling soil emission attenuated by the canopy + real(r8) :: tb_4(2) ! the downwelling cosmic ray reflected by the soil and attenuated by the canopy layer + real(r8) :: tb_toa(2) ! brightness temperature of top-of-atmosphere for H- and V- polarization + real(r8) :: wf_total(nl_soil) ! total gravimetric + real(r8) :: BD_all_surf ! bulk density of soil (g/m3) at surface + real(r8) :: porsl_surf ! soil porosity at surface + real(r8) :: t_surf ! soil temperature at surface (C) + real(r8) :: t_deep ! soil temperature at deep layer (C) + real(r8) :: liq_surf ! liquid volumetric water content at surface (m3/m3) + real(r8) :: ice_surf ! ice volumetric water content at surface (m3/m3) + real(r8) :: wf_clay_surf ! gravimetric clay percent fraction(%) at surface + real(r8) :: wf_sand_surf ! gravimetric sand percent fraction(%) at surface + integer :: i + +!----------------------------------------------------------------------- + +!############################################################################# +! Prepare parameters & states used in the operator +!############################################################################# + ! get depth of soil and snow layers + dz_soisno(maxsnl+1:0) = dz_sno(maxsnl+1:0) + dz_soisno(1:nl_soil) = dz_soi(1:nl_soil) + + ! calculate weighted parameters + wf_total = wf_clay + wf_sand + wf_silt + wf_clay_surf = (wf_clay(1)/wf_total(1)*0.0175 + wf_clay(2)/wf_total(2)*0.0276)/0.0451*100 + wf_sand_surf = (wf_sand(1)/wf_total(1)*0.0175 + wf_sand(2)/wf_total(2)*0.0276)/0.0451*100 + BD_all_surf = (BD_all(1)*0.0175 + BD_all(2)*0.0276)/0.0451/1000 + porsl_surf = (porsl(1)*0.0175 + porsl(2)*0.0276)/0.0451 + + ! caculate temperature (C) at surface and deep soil layers + t_surf = ((t_soisno(1)*(0.0175) + t_soisno(2)*(0.0451 - 0.0175))/0.0451) - tfrz + t_deep = ((t_soisno(7)*(0.8289-0.5) + t_soisno(8)*(1.0 - 0.8289))/0.5) - tfrz + + ! caculate liquid/ice volumetric water (first two layers) + liq_surf = (wliq_soisno(1) + wliq_soisno(2))/(0.0451*denh2o) + ice_surf = (wice_soisno(1) + wice_soisno(2))/(0.0451*denice) + + ! calculate lower bound of snow + lb = 0 + DO i = 0, maxsnl + IF (wliq_soisno(i) < 0.0) THEN + lb = i+1 + EXIT + ENDIF + ENDDO + +!############################################################################# +! Run the forward operator +!############################################################################# + ! check the patch type + IF (patchtype >= 3) THEN ! ocean, lake, ice + tb_toa = spval + ELSE + ! calculate parameters used in operator varied with satellite + CALL calc_parameters(sat_theta, sat_fghz) + +!############################################################################# +! atmosphere module +!############################################################################# + CALL atm(forc_topo, tref, tau_atm, tb_au, tb_ad) + +!############################################################################# +! soil module +!############################################################################# + CALL soil(& + patchclass, & + t_surf, t_deep, & + liq_surf, ice_surf, & + wf_sand_surf, wf_clay_surf, BD_all_surf, porsl_surf, & + r_r, tb_soil) + +!############################################################################# +! vegetation and snow module +! We categorized four different cases for the calculations: +! 1) no vegetation and no snow +! 2) no vegetation with snow +! 3) vegetation without snow +! 4) vegetation with snow +!############################################################################# + ! roughly judge low or high vegetation (only for IGBP) + is_low_veg = .true. + IF (patchclass >= 1 .and. patchclass <= 5) THEN + is_low_veg = .false. + END IF + + ! ensure snow density to <= 1 g/cm3 + IF (snowdp > 0.01) THEN + rho_snow = (wliq_soisno(lb) + wice_soisno(lb))/(dz_soisno(lb)*1e3) + liq_snow = wliq_soisno(lb)*rho_snow/(dz_soisno(lb)*1e3) + + IF (liq_snow > 1.0 .or. rho_snow > 1.0) then + rho_snow = 1.0 + liq_snow = wliq_soisno(lb)*rho_snow/(dz_soisno(lb)*1e3) + END IF + END IF + + ! main procedures + ! -------------------------------------------------------------------- + ! 1) no veg and no snow + ! two components: + ! (1) brightness temperature of soil + ! (2) the downwelling radiation reflected by the soil + ! -------------------------------------------------------------------- + IF ((lai + sai < 1e-6) .and. (snowdp < 0.01)) THEN + tb_tov = tb_soil + tb_ad*r_r + tb_tov_noad = tb_soil + + ! -------------------------------------------------------------------- + ! 2) no veg and has snow + ! two components: + ! (1) brightness temperature of snow + ! (2) the downwelling radiation reflected by the snow + ! -------------------------------------------------------------------- + ELSE IF ((lai + sai < 1e-6) .and. (snowdp > 0.01)) THEN + ! calculate brightness temperature of snow-covered ground + CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_r, r_snow, tb_tos) + + tb_tov = tb_tos + tb_ad*r_snow + tb_tov_noad = tb_tos + + ! -------------------------------------------------------------------- + ! 3) has veg and no snow + ! four components: + ! (1) the direct upwelling vegetation emission, + ! (2) the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer + ! (3) upwelling soil emission attenuated by the canopy + ! (4) the downwelling reflected by the soil and attenuated by the canopy layer + ! -------------------------------------------------------------------- + ELSE IF ((lai + sai > 1e-6) .and. (snowdp < 0.01)) THEN + ! calculate brightness temperature of vegetation + CALL veg(patchclass, lai, htop, 0.0, tleaf, tb_veg, gamma_p) + + DO i = 1, 2 + tb_2(i) = tb_veg(i)*gamma_p(i)*r_r(i) + tb_3(i) = tb_soil(i)*gamma_p(i) + tb_4(i) = tb_ad(i)*r_r(i)*(gamma_p(i)**2) + tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i) + tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i) + END DO + + ! -------------------------------------------------------------------- + ! 4) has veg and has snow + ! We need to determine the positional relationship between vegetation and snow. + ! + ! If vegetation is higher than snow, + ! we first calculate brightness temperature of snow (soil boundary), then calculate + ! four components to derive brightness temperature of top of vegetation: + ! (1) the direct upwelling vegetation emission, + ! (2) the downwelling vegetation emission reflected by the snow and attenuated by the canopy layer + ! (3) upwelling snow emission attenuated by the canopy + ! (4) the downwelling reflected by the snow and attenuated by the canopy layer + ! + ! If vegetation is lower than snow + ! we first calculate brightness temperature of top of vegetation (soil boundary), then calculate + ! four components to derive brightness temperature of top of snow: + ! (1) the direct upwelling vegetation emission, + ! (2) the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer + ! (3) upwelling soil emission attenuated by the canopy + ! (4) the downwelling reflected by the soil and attenuated by the canopy layer + ! -------------------------------------------------------------------- + ELSE IF ((lai + sai > 1e-6) .and. (snowdp > 0.01)) THEN + IF (htop < snowdp) THEN + ! calculate brightness temperature of low vegetation + CALL veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p) + + ! calculate brightness temperature of top of vegetation + DO i = 1, 2 + tb_2(i) = tb_veg(i)*gamma_p(i)*r_r(i) + tb_3(i) = tb_soil(i)*gamma_p(i) + tb_4(i) = tb_ad(i)*r_r(i)*(gamma_p(i)**2) + tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i) + tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i) + END DO + + ! calculate reflectivity between the snow and low veg (adopted from CMEM) + r_sn(:) = 1.0 - tb_tov_noad(:)/t_soisno(1) + + ! calculate brightness temperature of snow-covered ground + CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_sn, r_snow, tb_tos) + + ! calculate brightness temperature of top of snow + tb_tov = tb_tos + tb_ad*r_snow + tb_tov_noad = tb_tos + + ELSE + ! calculate brightness temperature of snow-covered ground + CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_r, r_snow, tb_tos) + + ! calculate brightness temperature of high vegetation + CALL veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p) + + ! calculate brightness temperature of top of vegetation + DO i = 1, 2 + tb_2(i) = tb_veg(i)*gamma_p(i)*r_snow(i) + tb_3(i) = tb_tos(i)*gamma_p(i) + tb_4(i) = tb_ad(i)*r_snow(i)*(gamma_p(i)**2) + tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i) + tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i) + END DO + END IF + END IF + +!############################################################################# +! Caculate brightness temperature of top-of-atmosphere +!############################################################################# + tb_toa = tb_tov*exp(-tau_atm) + tb_au + + END IF + + tb_toa_h = tb_toa(1) + tb_toa_v = tb_toa(2) + + END SUBROUTINE forward + + +!----------------------------------------------------------------------- + + SUBROUTINE calc_parameters (sat_theta, sat_fghz) + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_DA_Const + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------- + real(r8), intent(in) :: sat_theta, sat_fghz + +!----------------------- Local Variables ------------------------------- + + theta = sat_theta ! incidence angle of satellite (rad) + fghz = sat_fghz ! frequency of satellite (GHz) + f = fghz*1e9 ! frequency (Hz) + omega = 2.0*pi*f ! radian frequency (rad/s) + lam = C/f ! wavelength (m) + k = 2*pi/lam ! wave number (rad/m) + kcm = k/100.0 ! wave number (rad/cm) + kr = k*(0.5*1e-3) ! size parameter used in calcuate single-particle albedo + + END SUBROUTINE calc_parameters + +!----------------------------------------------------------------------- + + SUBROUTINE atm(z, tref, tau_atm, tb_au, tb_ad) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the atmospheric opacity and up and downwelling brightness temperature +! +! REFERENCES: +! [1] Pellarin, T., et al. (2003), Two-year global simulation of L-band brightness +! temperature over land, IEEE Trans. Geosci. Remote Sens., 41, 2135–2139. +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: z ! altitude (m) + real(r8), intent(in) :: tref ! 2m air temperature (K) + real(r8), intent(out) :: tau_atm ! atmospheric optical depth + real(r8), intent(out) :: tb_au(2) ! upwelling radiation (brightness temperature) of atmosphere + real(r8), intent(out) :: tb_ad(2) ! downwelling radiation (brightness temperature) of atmosphere + +!----------------------- Local Variables ------------------------------- + real(r8) :: t_sky = 2.7 ! cosmic ray radiation (K) + real(r8) :: t_eq ! equivalent layer temperature + real(r8) :: gossat + +!----------------------------------------------------------------------- + + ! calculate optical depth of atmosphere [1] eq(A1) + tau_atm = exp(-3.9262 - 0.2211*z/1000 - 0.00369*tref)/cos(theta) + gossat = exp(-tau_atm) + + ! calculate equivalent layer temperature + t_eq = exp(4.9274 + 0.002195*tref) + + ! upwelling radiation (brightness temperature) of atmosphere + tb_au(:) = t_eq*(1.-gossat) + + ! downwelling radiation (brightness temperature) of atmosphere [1] eq(A2) + tb_ad(:) = t_eq*(1.-gossat) + t_sky*gossat + + END SUBROUTINE atm + +!----------------------------------------------------------------------- + + SUBROUTINE soil( & + patchclass, & + t_surf, t_deep, & + liq_surf, ice_surf, & + wf_sand_surf, wf_clay_surf, BD_all_surf, porsl_surf, & + r_r, tb_soil) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate brightness temperature of soil surface +! +! REFERENCES: +! [1] Wigneron et al., 2007, "L-band Microwave Emission of the Biosphere (L-MEB) Model: +! Description and calibration against experimental +! data sets over crop fields" Remote Sensing of Environment. Vol. 107, pp. 639-655k +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + integer, intent(in) :: patchclass ! land cover class + real(r8), intent(in) :: t_surf ! soil temperature at surface (C) + real(r8), intent(in) :: t_deep ! soil temperature at deep layer (C) + real(r8), intent(in) :: liq_surf ! liquid volumetric water content at surface (m3/m3) + real(r8), intent(in) :: ice_surf ! ice volumetric water content at surface (m3/m3) + real(r8), intent(in) :: wf_sand_surf ! gravimetric sand percent fraction(%) at surface + real(r8), intent(in) :: wf_clay_surf ! gravimetric clay percent fraction(%) at surface + real(r8), intent(in) :: BD_all_surf ! bulk density of soil (g/m3) at surface + real(r8), intent(in) :: porsl_surf ! soil porosity at surface + real(r8), intent(out) :: r_r(2) ! rough surface reflectivity for H and V polarizations + real(r8), intent(out) :: tb_soil(2) ! brightness temperature of soil + +!----------------------- Local Variables ------------------------------- + real(r8) :: t_eff(2) ! effective temperature for H and V polarizations, [K] + complex(r8) :: eps_soil ! dielectric constant of soil for H and V polarizations + real(r8) :: r_s(2) ! smooth surface reflectivity for H and V polarizations + complex(r8) :: ew ! dielectric constant of water + logical :: is_desert ! flag for desert soil + real(r8) :: ffrz ! fraction of frozen soil + complex(r8) :: eps_f = (5.0, 0.5) ! dielectric constant of frozen soil + real(r8) :: sal_soil = 0.0 ! soil salinity (psu) + +!----------------------------------------------------------------------- + + ! whether this patch is desert + is_desert = .false. + IF (liq_surf < 0.02 .and. wf_sand_surf > 90) THEN + is_desert = .true. + END IF + + ! calculate ratio of freezed soil + IF (liq_surf + ice_surf <= 0.0d0) THEN + ffrz = 0.0d0 + ELSE + ffrz = ice_surf / (liq_surf + ice_surf) + ENDIF + + ! caculate effective temperature + CALL eff_soil_temp(liq_surf, t_surf, t_deep, t_eff) + + ! caculate dielectric constant of soil (mixture medium) + IF (is_desert) THEN + ! Microwave 1-10GHz permittivity of dry sand (matzler '98, eq.1) + eps_soil = 2.53 + (2.79 - 2.53)/(1 - jj*(fghz/0.27)) + jj*0.002 + ELSE + ! define bulk density and porosity (CMEM) + ! BD_all_surf = (wf_sand_surf*1.60d0 + wf_clay_surf*1.10d0 + (100.0d0 - wf_sand_surf - wf_clay_surf)*1.20d0)/100.0d0 + ! porsl_surf = 1.0d0 - BD_all_surf/2.660d0 + + ! caculate ice or water dielectric constant + IF (ffrz > 0.95) THEN + CALL diel_ice(t_surf, ew) + ELSE + CALL diel_water(-1, liq_surf, t_surf, wf_sand_surf, wf_clay_surf, BD_all_surf, sal_soil, ew) + END IF + + ! caculate dielectric constant in mixed soil + IF (DEF_DA_RTM_diel == 0) THEN + CALL diel_soil_W80 (ew, t_surf, liq_surf, wf_sand_surf, wf_clay_surf, porsl_surf, eps_soil) + ELSE IF (DEF_DA_RTM_diel == 1) THEN + CALL diel_soil_D85 (ew, liq_surf, wf_sand_surf, wf_clay_surf, BD_all_surf, eps_soil) + ELSE IF (DEF_DA_RTM_diel == 2) THEN + CALL diel_soil_M04 (liq_surf, wf_clay_surf, eps_soil) + ELSE IF (DEF_DA_RTM_diel == 3) THEN + CALL diel_soil_M09 (liq_surf, t_surf, wf_clay_surf, eps_soil) + ENDIF + END IF + + ! mix dielectric constant of frozen and non-frozen soil + eps_soil = eps_soil*(1.-ffrz) + eps_f*ffrz + + ! caculate smooth surface reflectivity + CALL smooth_reflectivity(eps_soil, r_s) + + ! caculate rough surface reflectivity + CALL rough_reflectivity(is_desert, patchclass, r_s, r_r) + + ! calculate brightness temperature + IF (is_desert) THEN + CALL desert(t_eff, r_r, eps_soil, tb_soil) + ELSE + tb_soil = t_eff * (1 - r_r) + END IF + + END SUBROUTINE soil + +!----------------------------------------------------------------------- + + SUBROUTINE eff_soil_temp(wc_surf, t_surf, t_deep, t_eff) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the effective temperature of soil +! +! REFERENCES: +! [1] An improved two-layer algorithm for estimating effective soil +! temperature in microwave radiometry using in situ temperature +! and soil moisture measurements +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + +! ------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: wc_surf ! soil moisture at surface (m3/m3) + real(r8), intent(in) :: t_surf ! soil temperature (C) at surface + real(r8), intent(in) :: t_deep ! soil temperature (C) at deep layer + real(r8), intent(out) :: t_eff(2) ! effective temperature for H and V polarizations, [K] + +!----------------------- Local Variables ------------------------------- + real(r8) :: C ! parameter depending mainly on frequency + ! and soil moisture to describe the impact of + ! surface temperature on the effective temperature; + ! soil moisture increase, C large, teff close to tsurf + ! soil moisture decrease, C small, tdeep impact teff more + real(r8) :: w0 = 0.30 ! parameter + real(r8) :: bw = 0.30 ! parameter +!----------------------------------------------------------------------- + + IF (wc_surf < 0.0) THEN + C = 0.001 + ELSE + C = max(0.001, (wc_surf/w0)**bw) + ENDIF + t_eff(:) = t_deep + (t_surf - t_deep)*C + tfrz + + END SUBROUTINE eff_soil_temp + +!----------------------------------------------------------------------- + + SUBROUTINE diel_ice(t, eps_i) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate dielectric constant of pure ice +! +! REFERENCES: +! [1] Matzler, C. (2006). Thermal Microwave Radiation: Applications +! for Remote Sensing p456-461 +!----------------------------------------------------------------------- + USE MOD_Const_Physical + USE MOD_Precision + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: t ! temperature (C) + complex(r8), intent(out) :: eps_i ! dielectric constant of ice water + +!----------------------- Local Variables ------------------------------- + real(r8) :: betam ! beta parameter by Mishima et al. (1983) + real(r8) :: dbeta ! corrected delta beta parameter + real(r8) :: beta ! beta parameter + real(r8) :: t_inv ! modified inverse temperature + real(r8) :: tk ! temperature (K) + real(r8) :: alpha ! alpha parameter + real(r8) :: eps_i_r ! real part of pure ice dielectric constant + real(r8) :: eps_i_i ! imaginary part of pure ice dielectric constant + +!----------------------------------------------------------------------- + + ! C to K + tk = t + tfrz + + ! eq.(5.33): calculate beta parameter by Mishima et al. (1983) + betam = (0.0207/tk)*(exp(335./tk)/((exp(335./tk) - 1.)**2.)) + 1.16e-11*(fghz**2.) ! [1](5.33) + + ! eq.(5.35): calculate delta beta parameter + dbeta = exp(-10.02 + 0.0364*t) ! [1](5.35) + + ! eq.(5.34): calculate beta parameter + beta = betam + dbeta ! [1](5.34) + + ! eq.(5.32): calculate alpha parameter + t_inv = 300./tk - 1 ! [1](p.457) + alpha = (0.00504 + 0.0062*t_inv)*exp(-22.1*t_inv) !(GHz) ! [1](5.32) + + ! eq.(5.30): calculate real part of pure ice dielectric constant + eps_i_r = 3.1884 + 9.1e-4*t ! [1](5.30) + + ! eq.(5.31): calculate imaginary part of pure ice dielectric constant + eps_i_i = alpha/fghz + beta*fghz ! [1](5.31) + + ! calculate dielectric constant of pure ice + eps_i = eps_i_r - jj*eps_i_i ! [1](5.31) + + END SUBROUTINE diel_ice + +!----------------------------------------------------------------------- + + SUBROUTINE diel_water(type, swc, t, wf_sand, wf_clay, BD_all, sal, eps_w) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate dielectric constant of water in water (saline water) +! +! REFERENCES: +! [1] Ulaby FT, R. K. Moore, and A. K. Fung, Microwave Remote Sensing: +! Active and Passive. Vol. III. From theory to applications. Artech House, +! Norwood, MA., 1986 +! [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. +!----------------------------------------------------------------------- + USE MOD_Const_Physical + USE MOD_Precision + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + integer, intent(in) :: type ! type of water, 0: pure water, 1: sea water, 2: soil water + real(r8), intent(in) :: swc ! soil water content (m3/m3) + real(r8), intent(in) :: t ! soil temperature (C) + real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%) + real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) + real(r8), intent(in) :: BD_all ! bulk density(g/cm3) + real(r8), intent(in) :: sal ! water salinity (psu) + complex(r8), intent(out) :: eps_w ! dielectric constant of soil water + +!----------------------- Local Variables ------------------------------- + real(r8) :: sigma ! ionic conductivity (S/m) + real(r8) :: a, b ! parameters + real(r8) :: tau_w ! relaxation time of pure water + real(r8) :: eps_w0 ! static dielectric constant of pure water + real(r8) :: wc + +!----------------------------------------------------------------------- + + ! [3] eq.16: tau(T, sal) = tau_w(T) * b(sal, T) + ! calculate relaxation time of pure water (Stogryn) + tau_w = 1.768e-11 - 6.068e-13*t + 1.104e-14*t**2 - 8.111e-17*t**3 ! [2](17) + b = 1.000 + 2.282e-5*sal*t - 7.638e-4*sal - 7.760e-6*sal**2 + 1.105e-8*sal**3 ! [2](18) + tau_w = tau_w*b ! [2](16) + + ! [3] eq.13: eps_w0(sal, T) = eps_w0(T) * a(sal, T) + ! static dielectric constant of pure water (Klein and Swift) + eps_w0 = 87.134 - 1.949e-1*t - 1.276e-2*t**2 + 2.491e-4*t**3 ! [2](14) + a = 1.000 + 1.613e-5*sal*t - 3.656e-3*sal + 3.210e-5*sal**2 - 4.232e-7*sal**3 ! [2](15) + eps_w0 = eps_w0*a ! [2](13) + + IF (type == 0) THEN ! pure water + ! [1] eq.19 + eps_w0 = 88.045 - 0.4147*t + 6.295e-4*t**2 + 1.075e-5*t**3 + eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) + + ELSEIF (type == 1) THEN ! sea water + ! calculate ionic conductivity [1] eq.27, eq.28 + sigma = sal*(0.182521 - 1.46192e-3*sal + 2.09324e-5*sal**2 - 1.28205e-7*sal**3) & + *exp(-1.*(25 - t)* & + (2.033e-2 + 1.266e-4*(25 - t) + 2.464e-6*(25 - t)**2 & + - sal*(1.849e-5 - 2.551e-7*(25 - t) + 2.551e-8*(25 - t)**2))) + + ! diel constant of sea water [1] eq.21 + eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) + jj*sigma/(omega*eps_0) + ELSE + ! calculate soil conductivity + sigma = -1.645 + 1.939*BD_all - 0.02256*wf_sand + 0.01594*wf_clay + IF (sigma < 0.) THEN + sigma = 0. ! negative for very sandy soils with low bulk density + END IF + + ! calculate dielectric constant of soil-water by modified Debye expression + wc = max(0.001, swc) + eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) & + + jj*sigma/(omega*eps_0)*(rho_soil - BD_all)/(rho_soil*wc) + END IF + + END SUBROUTINE diel_water + +!----------------------------------------------------------------------- + + SUBROUTINE diel_soil_W80(ew, t, wc, wf_sand, wf_clay, porsl, eps) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the dielectric constant of a wet soil +! +! REFERENCES: +! [1] Matzler, C. (1998). Microwave permittivity of dry sand. +! IEEE Transactions on Geoscience and Remote Sensing, 36(1), 317-319. +! +! [2] 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. +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +! ------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: t ! soil temperature (C) + real(r8), intent(in) :: wc ! volumetric soil moisture (m3/m3) + real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%) + real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) + real(r8), intent(in) :: porsl ! soil porosity at surface + complex(r8), intent(in) :: ew ! dielectric constant of water + complex(r8), intent(out) :: eps + +!----------------------- Local Variables ------------------------------- + real(r8) :: wp ! wilting point + real(r8) :: wt ! transition moisture point (cm3/cm3) + real(r8) :: gamma ! fitting parameter + real(r8) :: ecl ! conductivity loss + real(r8) :: alpha ! conductivity loss parameter + real(r8) :: sal_sea = 32.5 ! sea water salinity (psu) + real(r8) :: sal_soil = 0.0 ! soil salinity (psu) + complex(r8) :: eps_x ! dielectric constant of the initially absorbed water + complex(r8) :: eps_a = (1.0, 0.0) ! dielectric constant of air, [2]IV + complex(r8) :: eps_r = (5.5, 0.2) ! dielectric constant of rock, [2]IV + complex(r8) :: eps_i = (3.2, 0.1) ! dielectric constant of ice, [2]IV + complex(r8) :: eps_f = (5.0, 0.5) ! dielectric constant of frozen soil + +!----------------------------------------------------------------------- + + ! calculate wilting point at the soil layer + wp = 0.06774 - 0.00064*wf_sand + 0.00478*wf_clay ! [2](1) + + ! calculate fitting parameters + gamma = -0.57*wp + 0.481 ! [2](8) + + ! calculate transition moisture point + wt = 0.49*wp + 0.165 ! [2](9) + + ! calculate dielectric constant of wet soil (when all soil freeze, eps_x = eps_i) + IF (wc <= wt) THEN + eps_x = eps_i + (ew - eps_i)*(wc/wt)*gamma ! [2](3) + eps = wc*eps_x + (porsl - wc)*eps_a + (1.-porsl)*eps_r ! [2](2) + ELSE + eps_x = eps_i + (ew - eps_i)*gamma ! [2](5) + eps = wt*eps_x + (wc - wt)*ew + (porsl - wc)*eps_a + (1.-porsl)*eps_r ! [2](4) + END IF + + ! add conductivity loss for imaginary part + alpha = min(100.*wp, 26.) + ecl = alpha*wc**2 ! [2](6) + eps = eps + jj*ecl ! [2](6) + + END SUBROUTINE diel_soil_W80 + +!----------------------------------------------------------------------- + + SUBROUTINE diel_soil_M04(wc, wf_clay, eps) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the dielectric constant of a wet soil Developed and +! validated from 1 to 10 GHz, adapted for a large range of soil moisture +! +! REFERENCES: +! [1] Mironov et al, Generalized Refractive Mixing Dielectric Model for +! moist soil. IEEE Trans. Geosc. Rem. Sens., vol 42 (4), 773-785. 2004. +! +! [2] Mironov et al, Physically and Mineralogically Based Spectroscopic +! Dielectric Model for Moist Soils. IEEE Trans. Geosc. Rem. Sens., +! vol 47 (7), 2059-2070. 2009. +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +! ------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: wc ! soil moisture (m3/m3) + real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) + complex(r8), intent(out) :: eps + +!----------------------- Local Variables ------------------------------- + real(r8) :: znd, zkd, zxmvt, zep0b, ztaub, zsigmab, zep0u, ztauu + real(r8) :: zsigmau, zcxb, zepwbx, zepwby, zcxu, zepwux, zepwuy + real(r8) :: znb, zkb, znu, zku, zxmvt2, znm, zkm, zepmx, zepmy + integer :: zflag + +!----------------------------------------------------------------------- +!------------------------------------------------------------------------ +! Initializing the GRMDM spectroscopic parameters with clay (fraction) +!------------------------------------------------------------------------ + ! RI & NAC of dry soils + znd = 1.634 - 0.539 * (wf_clay/100) + 0.2748 * (wf_clay/100) ** 2 + zkd = 0.03952 - 0.04038 * (wf_clay / 100) ! [2](18) + + ! Maximum bound water fraction + zxmvt = 0.02863 + 0.30673 * wf_clay / 100 ! [2](19) + + ! Bound water parameters + zep0b = 79.8 - 85.4 * (wf_clay / 100) + 32.7 * (wf_clay / 100)*(wf_clay / 100) ! [2](20) + ztaub = 1.062e-11 + 3.450e-12 * (wf_clay / 100) ! [2](21) + zsigmab = 0.3112 + 0.467 * (wf_clay / 100) ! [2](22) + + ! Unbound (free) water parameters + zep0u = 100 ! [2](24) + ztauu = 8.5e-12 ! [2](25) + zsigmau = 0.3631 + 1.217 * (wf_clay / 100) + + ! Computation of epsilon water (bound & unbound) + zcxb = (zep0b - eps_w_inf) / (1. + (2.*pi*f*ztaub)**2) ! [2](16) + zepwbx = eps_w_inf + zcxb ! [2](16) + zepwby = zcxb * (2.*pi*f*ztaub) + zsigmab / (2.*pi*eps_0*f) ! [2](16) + zcxu = (zep0u - eps_w_inf) / (1 + (2*pi*f*ztauu)**2) ! [2](16) + zepwux = eps_w_inf + zcxu ! [2](16) + zepwuy = zcxu * (2.*pi*f*ztauu) + zsigmau/(2.*pi*eps_0*f) + + ! Computation of refractive index of water (bound & unbound) + znb = sqrt( sqrt( zepwbx**2 + zepwby**2) + zepwbx ) / sqrt(2.0) ! [2](14) + zkb = sqrt( sqrt( zepwbx**2 + zepwby**2) - zepwbx ) / sqrt(2.0) ! [2](15) + znu = sqrt( sqrt( zepwux**2 + zepwuy**2) + zepwux ) / sqrt(2.0) ! [2](14) + zku = sqrt( sqrt( zepwux**2 + zepwuy**2) - zepwux ) / sqrt(2.0) ! [2](15) + + ! Computation of soil refractive index (nm & km): xmv can be a vector + zxmvt2 = min (wc, zxmvt) + zflag = 0 + IF ( wc >= zxmvt ) zflag = 1 + znm = znd + (znb - 1) * zxmvt2 + (znu - 1) * (wc-zxmvt) * zflag ! [2](12) + zkm = zkd + zkb * zxmvt2 + zku * (wc-zxmvt) * zflag ! [2](13) + + ! computation of soil dielectric constant: + zepmx = znm ** 2 - zkm ** 2 ! [2](11) + zepmy = znm * zkm * 2 ! [2](11) + eps = cmplx(zepmx, zepmy, kind=r8) + + END SUBROUTINE diel_soil_M04 + +!----------------------------------------------------------------------- + + SUBROUTINE diel_soil_M09(wc, t, wf_clay, eps) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the dielectric constant of a wet soil Developed and +! validated from 1 to 10 GHz, adapted for a large range of soil moisture +! +! REFERENCES: +! [1] V. L. Mironov, S. V. Fomin, +! "Temperature and mineralogy dependable model for microwave dielectric +! spectra of moist soils", PIERS Online, vol. 5, no. 5, pp. 411-415, 2009. +! +! [2] Mironov et al, Physically and Mineralogically Based Spectroscopic Dielectric +! Model for Moist Soils. IEEE Trans. Geosc. Rem. Sens., vol 47 (7), 2059-2070. 2009. +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +! ------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: t ! soil temperature + real(r8), intent(in) :: wc ! soil moisture (m3/m3) + real(r8), intent(in) :: wf_clay ! weighted fraction (%) + complex(r8), intent(out) :: eps + +!----------------------- Local Variables ------------------------------- + real(r8) :: nd, kd, mvt, ts, e0b, Bb, Bsgb, Fb, eb0 + real(r8) :: dSbR, taub, sigmabt, sigmab, e0u, Bu, Bsgu, Fu, eu0, dHuR, dSuR, tauu, dHbR + real(r8) :: sigmau, sigmaut, cxb, eb_r, eb_i, cxu, eu_r, eu_i, nb, kb, nu, ku, nm, km, eps_r, eps_i + +!----------------------------------------------------------------------- +!------------------------------------------------------------------------ +! Initializing the GRMDM spectroscopic parameters with clay (fraction) +!------------------------------------------------------------------------ + ! RI & NAC of dry soils + nd = 1.634 - 0.539 * (wf_clay/100) + 0.2748 * (wf_clay/100) ** 2 ! [1](11) + kd = 0.03952 - 0.04038 * (wf_clay/100) ! [1](12) + + ! maximum bound water fraction + mvt = 0.02863 + 0.30673 * (wf_clay/100) ! [1](13) + + ! starting temperature for parameters' fit ([1] p.413) + ts = 20. + + ! eb0 computation + e0b = 79.8 - 85.4 * wf_clay + 32.7 * (wf_clay/100) **2 ! [1](14) + Bb = 8.67e-19 - 0.00126 * (wf_clay/100) + 0.00184 * (wf_clay/100) ** 2 - 9.77e-10*(wf_clay**3) - 1.39e-15 *(wf_clay**4) ! [1](15) + Bsgb = 0.0028 + 0.02094e-2*wf_clay - 0.01229e-4*(wf_clay**2) - 5.03e-22*(wf_clay**3) + 4.163e-24*(wf_clay**4) ! [1](23) + Fb = log((e0b - 1)/(e0b + 2)) ! [1](8)(ep0->e0p) + eb0 = (1 + 2*exp(Fb-Bb*(t-ts))) / (1 - exp(Fb-Bb*(t-ts))) ! [1](7)(e0p->ep0) + + ! taub computation + dHbR = 1467 + 2697e-2*wf_clay - 980e-4 *(wf_clay**2) + 1.368e-10*(wf_clay**3) - 8.61e-13 *(wf_clay**4) ! [1](18) + dSbR = 0.888 + 9.7e-2 *wf_clay - 4.262e-4*(wf_clay**2) + 6.79e-21 *(wf_clay**3) + 4.263e-22*(wf_clay**4) ! [1](19) + taub = 48e-12 * exp(dHbR/(t+tfrz)-dSbR)/(t+tfrz) ! [1](9) + + ! sigmab computation + sigmabt = 0.3112 + 0.467e-2*wf_clay ! [1](22) + sigmab = sigmabt + Bsgb*(t-ts) ! [1](10) + + ! unbound (free) water parameters + !------------------- + ! eu0 computation + !------------------- + e0u = 100. ! [1](16) + Bu = 1.11e-4 - 1.603e-7 *wf_clay + 1.239e-9 *(wf_clay**2) + 8.33e-13 *(wf_clay**3) - 1.007e-14*(wf_clay**4) ! [1](17) + Bsgu = 0.00108 + 0.1413e-2*wf_clay - 0.2555e-4*(wf_clay**2) + 0.2147e-6*(wf_clay**3) - 0.0711e-8*(wf_clay**4) ! [1](25) + Fu = log((e0u - 1)/(e0u + 2)) ! [1](8)(ep0->e0p) + eu0 = (1 + 2*exp(Fu-Bu*(t-ts))) / (1-exp(Fu-Bu*(t-ts))) ! [1](7))e0p->ep0) + + !-------------------- + ! tauu computation + !-------------------- + dHuR = 2231 - 143.1e-2 *wf_clay + 223.2e-4*(wf_clay**2) - 142.1e-6*(wf_clay**3) + 27.14e-8 *(wf_clay**4) ! [1](20) + dSuR = 3.649 - 0.4894e-2*wf_clay + 0.763e-4*(wf_clay**2) - 0.4859e-6*(wf_clay**3) + 0.0928e-8*(wf_clay**4) ! [1](21) + tauu = 48e-12 * exp(dHuR/(t+tfrz)-dSuR)/(t+tfrz) ! [1](9) + + !---------------------- + ! sigmau computation + !---------------------- + sigmaut = 0.05_r8 + 1.4_r8*(1.0_r8 - (1.0_r8 - wf_clay*1.e-2_r8)**4.664_r8) ! [1](24) + sigmau = sigmaut + Bsgu*(t-ts) ! [1](10) + + !-------------------------------------------------- + ! computation of epsilon water (bound & unbound) + !-------------------------------------------------- + cxb = (eb0-eps_w_inf) / (1+(2*pi*f*taub)**2) ! [1](6), [2](16) + eb_r = eps_w_inf + cxb ! [1](6), [2](16) + eb_i = cxb*(2*pi*f*taub) + sigmab/(2*pi*eps_0*f) ! [1](6), [2](16) + cxu = (eu0-eps_w_inf) / (1+(2*pi*f*tauu)**2) ! [1](6), [2](16) + eu_r = eps_w_inf + cxu ! [1](6), [2](16) + eu_i = cxu*(2*pi*f*tauu) + sigmau/(2*pi*eps_0*f) ! [1](6), [2](16) + + !-------------------------------------------------------------- + ! computation of refractive index of water (bound & unbound) + !-------------------------------------------------------------- + nb = sqrt(sqrt(eb_r**2+eb_i**2)+eb_r) / sqrt(2.0) ! [1](5) + kb = sqrt(sqrt(eb_r**2+eb_i**2)-eb_r) / sqrt(2.0) ! [1](5) + nu = sqrt(sqrt(eu_r**2+eu_i**2)+eu_r) / sqrt(2.0) ! [1](5) + ku = sqrt(sqrt(eu_r**2+eu_i**2)-eu_r) / sqrt(2.0) ! [1](5) + + !-------------------------------------------------- + ! computation of soil refractive index (nm & km) + !-------------------------------------------------- + IF (wc <= mvt) THEN + nm = nd + (nb-1)*wc ! [2](12) + km = kd + kb*wc ! [2](13) + ELSE + nm = nd + (nb-1)*mvt + (nu-1)*(wc-mvt) ! [2](12) + km = kd + kb*mvt + ku*(wc-mvt) ! [2](13) + ENDIF + + !------------------------------------------- + ! computation of soil dielectric constant + !------------------------------------------- + eps_r = nm**2 - km**2 ! [1](4) + eps_i = 2* nm * km ! [1](4) + eps = cmplx(eps_r, eps_i, kind=r8) + + END SUBROUTINE diel_soil_M09 + +!----------------------------------------------------------------------- + + SUBROUTINE diel_soil_D85(ew, swc, wf_sand, wf_clay, BD_all, eps) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the dielectric constant of a wet soil Developed and validated for 1.4 and 18 GHz. + +! REFERENCES: +! [1] Dobson et al., 1985: Microwave Dielectric behavior of +! wet soil - part II: Dielectric mixing models, +! IEEE Trans. Geosc. Rem. Sens., GE-23, No. 1, 35-46. + +! [2] N. R. Peplinski, F. T. Ulaby, and M. C. Dobson, +! Dielectric Properties of Soils in the 0.3-1.3-GHz Range, +! IEEE Trans. Geosc. Rem. Sens., vol. 33, pp. 803-807, May 1995 + +! [3] N. R. Peplinski, F. T. Ulaby, and M. C. Dobson, +! Corrections to “Dielectric Properties of Soils in the 0.3-1.3-GHz Range", +! IEEE Trans. Geosc. Rem. Sens., vol. 33, p. 1340, November 1995 + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +! ------------------------ Dummy Argument ------------------------------ + complex(r8), intent(in) :: ew ! dielectric constant of water + real(r8), intent(in) :: swc ! soil moisture + real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%) + real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) + real(r8), intent(in) :: BD_all ! soil bulk density (g/cm3) + complex(r8), intent(out) :: eps + +!----------------------- Local Variables ------------------------------- + real(r8) :: alphas = 0.65_r8 + real(r8) :: beta, eaa, eps_s, epsi, epsr, wc + +!----------------------------------------------------------------------- + + wc = max(swc, 0.001_r8) + eps_s = (1.01_r8 + 0.44_r8 * rho_soil)**2.0_r8 - 0.062_r8 ! [1](22) + beta = (127.48_r8 - 0.519_r8 * wf_sand - 0.152_r8 * wf_clay) / 100.0_r8 ! [1](30) + eaa = 1.0_r8 + (BD_all / rho_soil) * (eps_s ** alphas - 1.0_r8) & + & + (wc ** beta) * (real(ew) ** alphas) - wc ! [1](28) + epsr = eaa ** (1.0_r8/alphas) ! [2](2),[3] + beta = (133.797_r8 - 0.603_r8 * wf_sand - 0.166_r8 * wf_clay) / 100.0_r8 ! [1](31) 1.33797 -> 133.797, [2](5) + eaa = (wc ** beta) * (abs(aimag(ew)) ** alphas) ! [2](3) + epsi = eaa ** (1.0_r8/alphas) ! [2](3) + eps = cmplx(epsr, epsi, kind=r8) + + END SUBROUTINE diel_soil_D85 + +!----------------------------------------------------------------------- + + SUBROUTINE smooth_reflectivity(eps, r_s) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the smooth surface reflectivity by Fresnel Law +! +! REFERENCES: +! [1] Njoku and Kong, 1977: Theory for passive microwave remote sensing +! of near-surface soil moisture. Journal of Geophysical Research, +! Vol. 82, No. 20, 3108-3118. +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + complex(r8), intent(in) :: eps ! dielectric constant of the surface + real(r8), intent(out) :: r_s(2) ! reflectivities of flat surfaces for H and V polarizations + +!----------------------- Local Variables ------------------------------- + complex(r8) :: g ! parameter in Fresnel Law + +!----------------------------------------------------------------------- + + g = sqrt(eps - sin(theta)**2) + r_s(1) = abs((cos(theta) - g)/(cos(theta) + g))**2. + r_s(2) = abs((cos(theta)*eps - g)/(cos(theta)*eps + g))**2. + + END SUBROUTINE smooth_reflectivity + +!----------------------------------------------------------------------- + + SUBROUTINE rough_reflectivity(is_desert, patchclass, r_s, r_r) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the rough surface reflectivity +! +! REFERENCES: +! [1] Kerr and Njokui, 1990: A Semiempirical Model For Interpreting Microwave +! Emission From Semiarid Land Surfaces as Seen From Space +! IEEE Trans. Geosci. Rem. Sens., Vol.28, No.3, 384-393. +! +! [2] Wigneron, J. P., Jackson, T. J., O'neill, P., De Lannoy, G., de Rosnay, P., Walker, +! J. P., ... & Kerr, Y. (2017). Modelling the passive microwave signature from land surfaces: +! A review of recent results and application to the L-band SMOS & SMAP soil moisture retrieval algorithms. +! Remote Sensing of Environment, 192, 238-262. +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_DA_Const + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + logical, intent(in) :: is_desert ! flag for desert soil + integer, intent(in) :: patchclass ! patch class + real(r8), intent(in) :: r_s(2) ! reflectivities of flat surfaces for H and V polarizations + real(r8), intent(out) :: r_r(2) ! reflectivities of rough surfaces for H and V polarizations + +!----------------------- Local Variables ------------------------------- + real(r8) :: Q ! parameter for polarization mixing + real(r8) :: hr(N_land_classification) ! roughness parameter + real(r8) :: nrh(N_land_classification) ! parameter for H polarization + real(r8) :: nrv(N_land_classification) ! parameter for V polarization + +!----------------------------------------------------------------------- + + IF (is_desert) THEN + r_r = r_s + ELSE + ! calculate parameter for polarization mixing due to surface roughness + IF (fghz < 2.) THEN + Q = 0. ! Q is assumed zero at low frequency + ELSE + Q = 0.35*(1.0 - exp(-0.6*rgh_surf**2*fghz)) ! [1](16) + END IF + + ! calculate rough surface reflectivity (default settings used in [2]) + IF (DEF_DA_RTM_rough == 0) THEN + hr(:) = (2.0*kcm*rgh_surf)**2.0 + nrh(:) = 0.0 + nrv(:) = 0.0 + ELSE IF (DEF_DA_RTM_rough == 1) THEN + hr(:) = hr_SMOS + nrh(:) = 2.0 + nrv(:) = 0.0 + ELSE IF (DEF_DA_RTM_rough == 2) THEN + hr(:) = hr_SMAP + nrh(:) = 2.0 + nrv(:) = 2.0 + ELSE IF (DEF_DA_RTM_rough == 3) THEN + hr(:) = hr_P16 + nrh(:) = -1.0 + nrv(:) = -1.0 + END IF + + ! rough surface reflectivity for H and V polarizations + r_r(1) = (Q*r_s(2) + (1.-Q)*r_s(1))*exp(-hr(patchclass)*cos(theta)**nrh(patchclass)) + r_r(2) = (Q*r_s(1) + (1.-Q)*r_s(2))*exp(-hr(patchclass)*cos(theta)**nrv(patchclass)) + END IF + + END SUBROUTINE rough_reflectivity + +!----------------------------------------------------------------------- + + SUBROUTINE desert(t_soil, r_r, eps, tb_desert) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate desert emissivity using Grody and Weng, 2008 +! +! REFERENCES: +! [1] Grody, N. C., & Weng, F. (2008). Microwave emission and scattering from deserts: +! Theory compared with satellite measurements. +! IEEE Transactions on Geoscience and Remote Sensing, 46, 361–375. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: t_soil(2) ! desert surface temperature (K) (h-pol and v-pol) + real(r8), intent(in) :: r_r(2) ! reflectivity of rough surface (h-pol and v-pol) + complex(r8), intent(in) :: eps ! diel. const of desert + real(r8), intent(out) :: tb_desert(2) ! brightness temperature of soil for H- and V- polarization + +!----------------------- Local Variables ------------------------------- + real(r8) :: f0 = 0.7 ! the fractional volume of spherical particles + ! (f = (4/3)*pi*r^3*n0), + ! r : the particle radius = 0.5 (mm) + ! n0 : the number of particles per unit volume. + real(r8) :: w ! single-particle albedo + real(r8) :: g ! asymmetry parameter + real(r8) :: a ! similarity parameter + real(r8) :: em(2) ! desert soil emissivity + real(r8) :: y_r ! real part of y-parameters + real(r8) :: y_i ! imaginary part of y-parameters + +!----------------------------------------------------------------------- + ! calculate y-parameters (eq.A15) + y_r = (real(eps) - 1)/(real(eps) + 2) ! [1](A15) + y_i = 3*aimag(eps)/(real(eps) + 2)**2 ! [1](A15) + + ! calculate single-particle albedo (eq.A16) + w = (1 - f0)**4*kr**3*y_r**2/ & + ((1 - f0)**4*kr**3*y_r**2 + 1.5*(1 + 2*f0)**2*y_i) ! [1](A16) + + ! calculate asymmetry parameter (p.374) + g = 0.23*kr**2 ! [1]p.374 + + ! calculate similarity parameter (eq.3b) + a = sqrt((1 - w)/(1 - w*g)) ! [1](3b) + + ! calculate desert soil emissivity (eq.A13) + em = (1 - r_r)*(2*a/((1 + a) - (1 - a)*r_r)) ! [1](13) + + ! calculate brightness temperature of desert + tb_desert = t_soil*em + + END SUBROUTINE desert + +!----------------------------------------------------------------------- + + SUBROUTINE veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the brightness temperature on the top of vegetation +! +! REFERENCES: +! [1] Wigneron et al., 2007, "L-band Microwave Emission of the Biosphere (L-MEB) Model: +! Description and calibration against experimental +! data sets over crop fields" Remote Sensing of Environment. Vol. 107, pp. 639-655k +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + integer, intent(in) :: patchclass ! land cover class + real(r8), intent(in) :: lai ! leaf area index + real(r8), intent(in) :: tleaf ! leaf temperature (K) + real(r8), intent(out) :: tb_veg(2) ! brightness temperature of vegetation for H- and V- polarization + real(r8), intent(out) :: gamma_p(2) ! vegetation opacity for H- and V- polarization + real(r8), intent(in) :: htop, snowdp + +!----------------------- Local Variables ------------------------------- + real(r8) :: tau_nadir ! vegetation opacity at nadir + real(r8) :: tau_veg(2) ! vegetation opacity for H- and V- polarization + integer :: i + +!----------------------------------------------------------------------- + + ! caculate vegetation opacity (optical depth) at nadir b*VWC + IF (htop < snowdp) THEN + tau_nadir = b1(patchclass)*lai + b2(patchclass) ! low veg ! [1](22) + ELSE + tau_nadir = b3(patchclass) ! high veg + END IF + + ! calculate vegetation optical depth at H- and V- polarizations + tau_veg(1) = tau_nadir*(cos(theta)**2 + tth(patchclass)*sin(theta)**2) ! [1](23) + tau_veg(2) = tau_nadir*(cos(theta)**2 + ttv(patchclass)*sin(theta)**2) ! [1](24) + + ! calculate brightness temperature of vegetation + DO i = 1, 2 + gamma_p(i) = exp(-tau_veg(i)/cos(theta)) ! [1](15) + tb_veg(i) = (1.-w_CMEM(patchclass))*(1.-gamma_p(i))*tleaf + END DO + + END SUBROUTINE veg + +!----------------------------------------------------------------------- + + SUBROUTINE snow(t_snow, t, snowdp, rho_snow, liq_snow, r_sn, r_snow, tb_tos) + +!----------------------------------------------------------------------- +! DESCRIPTION: +! Calculate the brightness temperature of snow-covered ground +! +! REFERENCES: +! [1] Christian Mätzler (1987) Applications of the interaction of +! microwaves with the natural snow cover, Remote Sensing Reviews, 2:2, 259-387, DOI: +! 10.1080/02757258709532086 +! +! [2] Anderson, E. A., 1976: A point energy and mass balance model of a snow cover. +! NOAA Tech. Rep. NWS 19, 150 pp. U.S. Dept. of Commer., Washington, D.C.(eq.5.1) +! +! [3] Hallikainen, M. T., F. Ulaby, and T. Deventer. 1987. Extinction behavior of dry snow in the +! 18- to 90-GHz range. IEEE Trans. Geosci. Remote Sens., GE-25, 737–745. +! +! [4] Microwave remote sensing : active and passive +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical + IMPLICIT NONE + +!------------------------ Dummy Argument ------------------------------ + real(r8), intent(in) :: t_snow ! average snow temperature (K) + real(r8), intent(in) :: t ! temperature at bottom of snow (K), i.e., soil or leaf + real(r8), intent(in) :: snowdp ! snow depth (m) + real(r8), intent(in) :: rho_snow ! snow density (g/cm3) + real(r8), intent(in) :: liq_snow ! snow liquid water content (cm3/cm3) + real(r8), intent(in) :: r_sn(2) ! reflectivity between the snow and ground at (1, H-POL. 2, V.) + real(r8), intent(out) :: r_snow(2) ! reflectivity between the snow and air for H- and V- polarization + real(r8), intent(out) :: tb_tos(2) ! brightness temperature of snow-cover ground for H- and V- polarization + +!----------------------- Local Variables ------------------------------- + real(r8) :: sal_snow = 0.0 ! snow salinity (pmm) + real(r8) :: eps_i_r ! real part of dielectric constant of ice + real(r8) :: eps_i_i ! imaginary part of dielectric constant of ice + real(r8) :: eps_i_is ! imaginary part of dielectric constant of impure ice -5(C) + real(r8) :: eps_i_ip ! imaginary part of dielectric constant of pure ice -5(C) + real(r8) :: eps_ds_r ! real part of dielectric constant of dry snow + real(r8) :: eps_ds_i ! imaginary part of dielectric constant of dry snow + real(r8) :: eps_ws_i ! imaginary part of dielectric constant of wet snow + real(r8) :: eps_ws_r ! real part of dielectric constant of wet snow + real(r8) :: eps_w_s = 88. ! dielectric constant of static water + real(r8) :: eps_a_inf, eps_b_inf, eps_c_inf ! infinite frequency dielectric constant of three parts + real(r8) :: eps_a_s, eps_b_s, eps_c_s ! static dielectric constant of three parts + complex(r8) :: eps_i ! dielectric constant of ice + complex(r8) :: eps_a + complex(r8) :: eps_b + complex(r8) :: eps_c ! dielectric constant of three parts + complex(r8) :: eps ! dielectric constant of wet snow + real(r8) :: rho_ds ! density of dry snow (g/cm3) + real(r8) :: rho_i = 0.916 ! density of ice (g/cm3) + real(r8) :: aa = 0.005 + real(r8) :: bb = 0.4975 + real(r8) :: cc = 0.4975 ! fitting parameters + real(r8) :: fa, fb, fc ! relaxation frequency of wet snow + real(r8) :: d ! snow grain size (mm) + real(r8) :: alpha, beta, pp, qq ! parameter used to calculate propogation angle in snow + real(r8) :: theta_s ! propogation angle in snow + complex(r8) :: z_s ! wave impedance in snow + real(r8) :: r_sa ! reflectivity between the snow and air for H- and V- polarization + real(r8) :: tb_2 ! the net apparent temperature contributions due to emission by layers 2 (snow) + real(r8) :: tb_3 ! the net apparent temperature contributions due to emission by layers 3 (soil) + real(r8) :: l2_apu ! extinction coefficient of snow (Beer's Law) + real(r8) :: q = 0.96 ! parameter + real(r8) :: ka_ws ! absorption coefficient of wet snow + real(r8) :: ka_ds ! absorption coefficient of dry snow + real(r8) :: ke ! extinction coefficient of wet snow + real(r8) :: ke_ds ! extinction coefficient of dry snow + real(r8) :: ks ! scattering coefficient of snow + real(r8) :: b_ds, b_ws + real(r8) :: wk_h ! [m], equal to cmem cmem_snow_set_var.F90:476 + integer :: i + +!----------------------------------------------------------------------- + IF (snowdp > 0.01) THEN ! > 1cm + ! calculate dielectric constant of ice + CALL diel_ice(t_snow - tfrz, eps_i) + eps_i_r = real(eps_i) + eps_i_i = aimag(eps_i) + + ! consider the effect of salinity on the dielectric constant of ice + eps_i_is = 0.0026/fghz + 0.00023*(fghz**0.87) ! impure ice -5(C) + eps_i_ip = 6.e-4/fghz + 6.5e-5*(fghz**1.07) ! pure ice -5(C) + eps_i_i = eps_i_i + (eps_i_is - eps_i_ip)*sal_snow/13.0d0 ! corrected imaginary part of diel cons of ice + + ! calculate dielectric constant of dry snow (mixed by air and ice) (Polder–van Santen mixing model) + rho_ds = (rho_snow - liq_snow)/(1.0 - liq_snow) ! caculate density of dry snow, + eps_ds_r = 1.0 + 1.58*rho_ds/(1.0 - 0.365*rho_ds) + eps_ds_i = 3.0*(rho_ds/rho_i)*eps_i_i*(eps_ds_r**2)*(2*eps_ds_r + 1)/ & + ((eps_i_r + 2*eps_ds_r)*(eps_i_r + 2*eps_ds_r**2)) ! negative imaginary part of diel cons of dry snow + + ! calculate dielectric constant of wet snow (Matzler 1987) + IF (liq_snow > 0.) THEN ! wet snow + ! caculate relaxation frequency of three parts (eq.2.26) + fa = f0w*(1 + (aa*(eps_w_s - eps_w_inf)/(eps_ds_r + (aa*(eps_w_inf - eps_ds_r))))) + fb = f0w*(1 + (bb*(eps_w_s - eps_w_inf)/(eps_ds_r + (bb*(eps_w_inf - eps_ds_r))))) + fc = f0w*(1 + (cc*(eps_w_s - eps_w_inf)/(eps_ds_r + (cc*(eps_w_inf - eps_ds_r))))) + + ! caculate infinite frequency dielectric constant of three parts + eps_a_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ & + (1.+aa*((eps_w_inf/eps_ds_r) - 1.)) + eps_b_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ & + (1.+bb*((eps_w_inf/eps_ds_r) - 1.)) + eps_c_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ & + (1.+cc*((eps_w_inf/eps_ds_r) - 1.)) + + ! caculate static dielectric constant of three parts + eps_a_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ & + (1.+aa*((eps_w_s/eps_ds_r) - 1.)) + eps_b_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ & + (1.+bb*((eps_w_s/eps_ds_r) - 1.)) + eps_c_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ & + (1.+cc*((eps_w_s/eps_ds_r) - 1.)) + + ! Debye equations + eps_a = eps_a_inf + (eps_a_s - eps_a_inf)/(1 + jj*fghz/fa) + eps_b = eps_b_inf + (eps_b_s - eps_b_inf)/(1 + jj*fghz/fb) + eps_c = eps_c_inf + (eps_c_s - eps_c_inf)/(1 + jj*fghz/fc) + + ! calculate dielectric constant of wet snow + eps = eps_a + eps_b + eps_c + (eps_ds_r - jj*eps_ds_i) + eps_ws_r = real(eps) + eps_ws_i = -1.*aimag(eps) + ELSE + eps_ws_r = eps_ds_r + eps_ws_i = eps_ds_i + END IF + + ! caculate propogation angle in snow (change medium from air to snow) + alpha = k*abs(aimag(sqrt(eps_ws_r - jj*eps_ws_i))) + beta = k*real(sqrt(eps_ws_r - jj*eps_ws_i)) + pp = 2.*alpha*beta + qq = beta**2 - alpha**2 - (k*k)*(sin(theta)**2) + theta_s = atan(k*sin(theta)/((1./sqrt(2.)) & + *sqrt(sqrt(pp**2.+qq**2.) + qq))) + + ! caclulate wave impedance in snow + z_s = z0/sqrt(eps_ws_r - jj*eps_ws_i) + + ! calculate brightness temperature above snow for H- V- polarization + DO i = 1, 2 + ! Fresnel reflection coefficient between snow and air + IF (i == 1) THEN + r_sa = abs((z_s*cos(theta) - z0*cos(theta_s))/ & + (z_s*cos(theta) + z0*cos(theta_s)))**2 + ELSE + r_sa = abs((z0*cos(theta) - z_s*cos(theta_s))/ & + (z0*cos(theta) + z_s*cos(theta_s)))**2 + END IF + + ! calculate snow grain size (mm) (Anderson 1976, eq.5.1) TODO + d = min(1000*(1.6e-4 + 1.1e-13*((rho_snow*1000.0)**4)), 3.0) + + ! extinction coefficient of dry snow + !//TODO: the paper is not focus on L-band, thus the formula is not suitable + ke_ds = 0.0018*(fghz**2.8)*(d**2)/4.3429 ! [3](14) + + ! absorption coefficient of dry snow + b_ds = (eps_ds_i/eps_ds_r)**2 + ka_ds = 2.*omega*sqrt(mu0*eps_0*eps_ds_r)* & + sqrt(b_ds/(2.*(sqrt(1.+b_ds) + 1.))) + + IF (ke_ds < ka_ds) ke_ds = ka_ds + + ! absorption coefficient of wet snow + b_ws = (eps_ws_i/eps_ws_r)**2 + ka_ws = 2.*omega*sqrt(mu0*eps_0*eps_ws_r)* & + sqrt(b_ws/(2.*(sqrt(1.+b_ws) + 1))) + + ! total extinction (assuming scattering is the same for dry and wet snow) + ke = (ke_ds - ka_ds) + ka_ws + + ! scattering coefficient of dry and wet snow + ks = ke_ds - ka_ds + + wk_h = snowdp/rho_snow + IF (((ke - q*ks)*(1./cos(theta_s))*wk_h) > (log(HUGE(1.)) - 1.)) THEN + l2_apu = sqrt(HUGE(1.)) + ELSE + l2_apu = min(sqrt(HUGE(1.)), exp((ke - q*ks)*(1./cos(theta_s))*wk_h)) + END IF + + ! brightness temperature through snow-air layer ([4] pp.243, eq.4.161) + tb_2 = (1.+r_sn(i)/l2_apu)*(1.-r_sa)*t_snow* & + (ka_ws/(ke - q*ks))*(1.-1./l2_apu)/ & + (1.-r_sn(i)*r_sa/l2_apu**2.) + + ! brightness temperature through soil-snow layer ([4] pp.243, eq.4.162) + tb_3 = ((1.-r_sn(i))*(1.-r_sa)*t)/ & + (l2_apu*(1.-r_sn(i)*r_sa/l2_apu**2.)) + + ! brightness temperature of snow-cover ground + tb_tos(i) = tb_2 + tb_3 + + ! emission by layers 2 (snow) and 3 (soil) + ! reflectivity by layers 2 (snow) and 3 (soil) + r_snow(i) = 1 - (tb_2/t_snow + tb_3/t) + END DO + END IF + + END SUBROUTINE snow +!----------------------------------------------------------------------- +END MODULE MOD_DA_RTM +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 new file mode 100644 index 0000000000..676449c40d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 @@ -0,0 +1,1787 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_SM +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Data assimilation of surface soil moisture and temperature +! +! AUTHOR: +! Lu Li, 12/2024: Initial version, based on SMAP L1C TB data +! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes +! Lu Li, 07/2025: reframe codes +! Lu Li, 10/2025: support SMAP/FY3D/SYNOP data +!----------------------------------------------------------------------------- + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_DA_RTM + USE MOD_DA_EnKF + USE MOD_DA_Vars_TimeVariables + USE MOD_Vars_Global, only: pi, nl_soil, maxsnl + USE MOD_LandPatch + USE MOD_Block + USE MOD_Namelist + USE MOD_DA_Vars_TimeVariables + USE MOD_Pixelset + USE MOD_Pixel + USE MOD_Mesh + IMPLICIT NONE + SAVE + +! public functions + PUBLIC :: init_DA_SM + PUBLIC :: run_DA_SM + PUBLIC :: end_DA_SM + + PRIVATE + +! local variables +!############################################################################# +! Universal variables +!############################################################################# + ! time (UTC) at current step + integer :: month, mday, hour ! month, day, hour of current step + character(len=256) :: yearstr, monthstr, daystr, hourstr ! string of year, month, day, hour + integer :: idate_b, idate_e ! begin & end seconds since begin of current day (UTC) + + integer :: num_obs_p + ! mask water + logical, allocatable :: filter(:) ! to mask the water + + ! logical + logical, allocatable :: has_DA ! whether has data assimilation + + ! setting of SMAP satellite + real(r8), parameter :: smap_theta = 40.0*pi/180 ! incidence angle (rad) + real(r8), parameter :: smap_fghz = 1.4 ! frequency (GHz), L-band + + ! setting of FY satellite + real(r8), parameter :: fy3d_theta = 40.0*pi/180 ! incidence angle (rad) + real(r8), parameter :: fy3d_fghz = 1.4 ! frequency (GHz), L-band + + ! parameters of LETKF + real(r8), allocatable :: obs_err(:) ! observation error + real(r8), parameter :: dres = 0.4 ! search localization radius (deg) + real(r8), parameter :: loc_r = 40.0 ! localization radius (km) + real(r8), parameter :: infl = 1.2 ! inflation factor + + ! data assimilation outputs + real(r8), allocatable :: trans(:,:) ! transformation matrix on each patch + real(r8), allocatable :: wliq_soi_ens(:,:) ! soil liquid water content + real(r8), allocatable :: wliq_soi_ens_da(:,:) ! soil liquid water content after data assimilation + real(r8), allocatable :: t_soi_ens(:,:) ! soil temperature + real(r8), allocatable :: t_soi_ens_da(:,:) ! soil temperature after data assimilation + real(r8) :: eff_porsl ! effective porosity of each soil layer + integer :: end_idx(3) + + real(r8), allocatable :: pred_obs_p_ens(:,:) ! predicted observations on each patch + real(r8), allocatable :: obs_p(:) ! observations on each patch + real(r8), allocatable :: obs_err_p(:) ! observation errors on each patch + + real(r8), allocatable :: smap_err(:) ! observation errors for SMAP TB + real(r8), allocatable :: fy3d_err(:) ! observation errors for FY3D TB + real(r8), allocatable :: synop_tref_err(:) ! observation errors for SYNOP 2m temperature + real(r8), allocatable :: synop_qref_err(:) ! observation errors for SYNOP 2m humidity + +!############################################################################# +! For SMAP L1C brightness temperature +!############################################################################# + ! file path + character(len=256) :: file_smap ! SMAP observation file path + character(len=256) :: file_grid_smap ! SMAP world grid file path + + ! grid + type(grid_type) :: grid_smap ! SMAP world grid + type(spatial_mapping_type) :: mg2p_smap ! mapping between SMAP world grid to patch + + ! time variables used to determine whether has obs + real(r8), allocatable :: smap_time(:) ! seconds of all obs since begin of current day (UTC) + real(r8), allocatable :: dt_b_smap(:) ! delta time between SMAP and begin seconds of current day + real(r8), allocatable :: dt_e_smap(:) ! delta time between SMAP and end seconds of current day + + ! logical variables + logical :: has_smap_file ! whether has file of SMAP at target hour + logical :: has_smap_obs ! whether has SMAP obs at current step + + ! observations (dimensions changes with time) + integer :: num_smap_obs ! number of all obs in current file + integer :: num_smap_obs_domain ! number of all obs in simulation domain at current file + real(r8), allocatable :: smap_lat(:) ! latitude of all obs + real(r8), allocatable :: smap_lon(:) ! longitude of all obs + real(r8), allocatable :: smap_tb_h(:) ! H- polarized brightness temperature of all obs ([K]) + real(r8), allocatable :: smap_tb_v(:) ! V- polarized brightness temperature of all obs ([K]) + integer, allocatable :: smap_ii(:) ! i-th lat grid in world map of all obs + integer, allocatable :: smap_jj(:) ! j-th lon grid in world map of all obs + + ! history mean value of smap and colm + real(r8), allocatable :: pred_smap_tb_h_mean(:) ! history mean value of predicted H- polarized temp + real(r8), allocatable :: pred_smap_tb_v_mean(:) ! history mean value of predicted V- polarized temp + real(r8), allocatable :: smap_tb_h_mean(:) ! history mean value of SMAP H- polarized temp + real(r8), allocatable :: smap_tb_v_mean(:) ! history mean value of SMAP V- polarized temp + + ! ensemble predicted observations (at patch) + real(r8), allocatable :: pred_smap_tb_h_pset_ens(:, :) ! predicted H- polarized temp on patch + real(r8), allocatable :: pred_smap_tb_v_pset_ens(:, :) ! predicted V- polarized temp on patch + real(r8), allocatable :: area_pset(:) ! area of each patch across world grid + + ! ensemble predicted observations (at world grid) + type(block_data_real8_3d) :: pred_smap_tb_h_wgrid_ens ! predicted H- polarized temp on world grid + type(block_data_real8_3d) :: pred_smap_tb_v_wgrid_ens ! predicted V- polarized temp on world grid + type(block_data_real8_2d) :: area_smap_wgrid ! area of each patch across world grid + + ! ensemble predicted observations (at obs grid) + real(r8), allocatable :: pred_smap_tb_h_ogrid_ens(:, :) ! predicted H- polarized temp on obs grid + real(r8), allocatable :: pred_smap_tb_v_ogrid_ens(:, :) ! predicted V- polarized temp on obs grid + real(r8) :: area_smap_wgrid_obs ! area of each patch across world grid for each obs + + ! observations around patch (dimensions changes with patch) + integer :: num_smap_p + logical, allocatable :: index_smap_p(:) ! index of obs around each patch + real(r8), allocatable :: smap_lat_p(:) ! latitude of obs around each patch + real(r8), allocatable :: smap_lon_p(:) ! longitude of obs around each patch + real(r8), allocatable :: smap_tb_h_p(:) ! H- polarized brightness temperature of obs around each patch ([K]) + real(r8), allocatable :: smap_tb_v_p(:) ! V- polarized brightness temperature of obs around each patch ([K]) + real(r8), allocatable :: pred_smap_tb_h_p_ens(:, :) ! predicted H- polarized temp around patch + real(r8), allocatable :: pred_smap_tb_v_p_ens(:, :) ! predicted V- polarized temp around patch + + ! history mean value of brightness temperature around patch + real(r8), allocatable :: pred_smap_tb_h_mean_p(:) ! history mean value of predicted H- polarized temp around patch + real(r8), allocatable :: pred_smap_tb_v_mean_p(:) ! history mean value of predicted V- polarized temp around patch + real(r8), allocatable :: smap_tb_h_mean_p(:) ! history mean value of SMAP H- polarized temp around patch + real(r8), allocatable :: smap_tb_v_mean_p(:) ! history mean value of SMAP V- polarized temp around patch + + ! parameters for distance calculation + real(r8), allocatable :: d_smap_p(:) ! distance between obs and patch center + real(r8), parameter :: static_smap_err = 0.1 ! static observation error + +!############################################################################# +! For FY3D L1 brightness temperature +!############################################################################# + ! file path + character(len=256) :: file_fy3d ! FY3D observation file path + character(len=256) :: file_grid_fy3d ! FY3D world grid file path + + ! grid + type(grid_type) :: grid_fy3d ! FY3D world grid + type(spatial_mapping_type) :: mg2p_fy3d ! mapping between FY3D world grid to patch + + ! time variables used to determine whether has obs + real(r8), allocatable :: fy3d_time(:) ! seconds of all obs since begin of current day (UTC) + real(r8), allocatable :: dt_b_fy3d(:) ! delta time between FY3D and begin seconds of current day + real(r8), allocatable :: dt_e_fy3d(:) ! delta time between FY3D and end seconds of current day + + ! logical variables + logical :: has_fy3d_file ! whether has file of FY3D at target hour + logical :: has_fy3d_obs ! whether has FY3D obs at current step + + ! observations (dimensions changes with time) + integer :: num_fy3d_obs ! number of all obs in current file + integer :: num_fy3d_obs_domain ! number of all obs in simulation domain at current file + real(r8), allocatable :: fy3d_lat(:) ! latitude of all obs + real(r8), allocatable :: fy3d_lon(:) ! longitude of all obs + real(r8), allocatable :: fy3d_tb_h(:) ! H- polarized brightness temperature of all obs ([K]) + real(r8), allocatable :: fy3d_tb_v(:) ! V- polarized brightness temperature of all obs ([K]) + integer, allocatable :: fy3d_ii(:) ! i-th lat grid in world map of all obs + integer, allocatable :: fy3d_jj(:) ! j-th lon grid in world map of all obs + + ! history mean value of fy3d and colm + real(r8), allocatable :: pred_fy3d_tb_h_mean(:) ! history mean value of predicted H- polarized temp + real(r8), allocatable :: pred_fy3d_tb_v_mean(:) ! history mean value of predicted V- polarized temp + real(r8), allocatable :: fy3d_tb_h_mean(:) ! history mean value of FY3D H- polarized temp + real(r8), allocatable :: fy3d_tb_v_mean(:) ! history mean value of FY3D V- polarized temp + + ! ensemble predicted observations (at patch) + real(r8), allocatable :: pred_fy3d_tb_h_pset_ens(:, :) ! predicted H- polarized temp on patch + real(r8), allocatable :: pred_fy3d_tb_v_pset_ens(:, :) ! predicted V- polarized temp on patch + + ! ensemble predicted observations (at world grid) + type(block_data_real8_3d) :: pred_fy3d_tb_h_wgrid_ens ! predicted H- polarized temp on world grid + type(block_data_real8_3d) :: pred_fy3d_tb_v_wgrid_ens ! predicted V- polarized temp on world grid + type(block_data_real8_2d) :: area_fy3d_wgrid ! area of each patch across world grid + + ! ensemble predicted observations (at obs grid) + real(r8), allocatable :: pred_fy3d_tb_h_ogrid_ens(:, :) ! predicted H- polarized temp on obs grid + real(r8), allocatable :: pred_fy3d_tb_v_ogrid_ens(:, :) ! predicted V- polarized temp on obs grid + real(r8) :: area_fy3d_wgrid_obs ! area of each patch across world grid for each obs + + ! observations around patch (dimensions changes with patch) + integer :: num_fy3d_p + logical, allocatable :: index_fy3d_p(:) ! index of obs around each patch + real(r8), allocatable :: fy3d_lat_p(:) ! latitude of obs around each patch + real(r8), allocatable :: fy3d_lon_p(:) ! longitude of obs around each patch + real(r8), allocatable :: fy3d_tb_h_p(:) ! H- polarized brightness temperature of obs around each patch ([K]) + real(r8), allocatable :: fy3d_tb_v_p(:) ! V- polarized brightness temperature of obs around each patch ([K]) + real(r8), allocatable :: pred_fy3d_tb_h_p_ens(:, :) ! predicted H- polarized temp around patch + real(r8), allocatable :: pred_fy3d_tb_v_p_ens(:, :) ! predicted V- polarized temp around patch + + ! history mean value of brightness temperature around patch + real(r8), allocatable :: pred_fy3d_tb_h_mean_p(:) ! history mean value of predicted H- polarized temp around patch + real(r8), allocatable :: pred_fy3d_tb_v_mean_p(:) ! history mean value of predicted V- polarized temp around patch + real(r8), allocatable :: fy3d_tb_h_mean_p(:) ! history mean value of FY3D H- polarized temp around patch + real(r8), allocatable :: fy3d_tb_v_mean_p(:) ! history mean value of FY3D V- polarized temp around patch + + ! parameters for distance calculation + real(r8), allocatable :: d_fy3d_p(:) ! distance between obs and patch center + real(r8), parameter :: static_fy3d_err = 10.0 ! static observation error + +!############################################################################# +! For SYNOP 2m temperature and humidity observations +!############################################################################# + ! derived types of pixel index in each worker + ! firstly sorted by pixel latitude index (nlat) and record + ! corresponding longitude index and patch id for each pixel + type :: idx_type + integer, allocatable :: ilon (:) + integer, allocatable :: ipatch (:) + END type idx_type + type(idx_type), allocatable :: idx (:) ! derived types of pixel index at each worker + integer, allocatable :: counter (:) ! counter of pixel longitude index of each latitude index at each worker + + ! file path + character(len=256) :: file_synop ! SYNOP file path + + ! info of all SYNOP sites + character(len=256) :: file_site ! file of location of all SYNOP sites + real(r8), allocatable :: synop_lat_all(:) + real(r8), allocatable :: synop_lon_all(:) ! latitude and longitude of all SYNOP sites + integer :: nsite ! number of all SYNOP sites + integer, allocatable :: iloc_synop (:,:) ! global lat/lon index of pixel cover each site in all SYNOP sites + integer :: counter_worker_nsite ! number of all SYNOP sites located at each worker + integer, allocatable :: ip_worker (:,:) ! patch id of all SYNOP sites located at each worker + integer, allocatable :: idx_lat(:), idx_lon(:), pos(:) ! temporary array save global lat/lon index of each site + integer, allocatable :: synop_lut (:,:) ! look-up-table of all SYNOP sites + + ! time variables used to determine whether has obs + real(r8), allocatable :: synop_time(:) ! seconds of all obs since begin of current day (UTC) + real(r8), allocatable :: dt_b_synop(:) ! delta time between SYNOP and begin seconds of current day + real(r8), allocatable :: dt_e_synop(:) ! delta time between SYNOP and end seconds of current day + + ! logical variables + logical :: has_synop_file ! whether has file of SYNOP at target day + logical :: has_synop_obs ! whether has SYNOP obs at current step + + ! info of SYNOP sites at each step + integer, allocatable :: synop_idx (:,:) ! index of SYNOP sites (worker/patch id) at each step + integer, allocatable :: site_id_worker (:) ! site id of SYNOP sites at each step at each worker + real(r8), allocatable :: tref_ens_worker (:,:) ! predicted 2m temperature of SYNOP sites at each step at each worker + real(r8), allocatable :: qref_ens_worker (:,:) ! predicted 2m humidity of SYNOP sites at each step at each worker + real(r8), allocatable :: qref_ens_o (:,:) ! predicted 2m temperature of SYNOP sites at each step + real(r8), allocatable :: tref_ens_o (:,:) ! predicted 2m humidity of SYNOP sites at each step + + ! observations (dimensions changes with time) + integer :: num_synop_obs ! number of all obs in current file + integer :: num_synop_obs_domain ! number of all obs in simulation domain at current file + real(r8), allocatable :: synop_lat(:) ! latitude of all obs + real(r8), allocatable :: synop_lon(:) ! longitude of all obs + integer, allocatable :: synop_id(:) ! global id of all obs + real(r8), allocatable :: synop_tref(:) ! 2m temperature of all obs ([K]) + integer, allocatable :: synop_qref(:) ! 2m humidity of all obs ([K]) + + ! observations around patch (dimensions changes with patch) + integer :: num_synop_p + logical, allocatable :: index_synop_p(:) ! index of obs around each patch + real(r8), allocatable :: synop_lat_p(:) ! latitude of obs around each patch + real(r8), allocatable :: synop_lon_p(:) ! longitude of obs around each patch + real(r8), allocatable :: synop_qref_p(:) ! 2m temperature of obs around each patch ([K]) + real(r8), allocatable :: synop_tref_p(:) ! 2m humidity of obs around each patch ([K]) + real(r8), allocatable :: synop_p(:) ! concatenate 2m temperature and humidity of obs around each patch + real(r8), allocatable :: qref_ens_p(:,:) ! predicted 2m temperature around patch + real(r8), allocatable :: tref_ens_p(:,:) ! predicted 2m humidity around patch + real(r8), allocatable :: pred_synop_ens_p(:,:) ! predicted 2m temperature and humidity around patch + + ! parameters for distance calculation + real(r8), allocatable :: d_synop_p(:) ! distance between obs and patch center + real(r8), parameter :: static_synop_tref_err = 1.0 ! static observation error (2m temperature) + real(r8), parameter :: static_synop_qref_err = 0.04 ! static observation error (2m humidity) + +!----------------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE init_DA_SM() + +!----------------------------------------------------------------------------- + USE MOD_Spmd_Task + USE MOD_Namelist, only: DEF_DA_obsdir + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + USE MOD_Pixelset + USE MOD_RangeCheck + IMPLICIT NONE + + integer :: np, ie, ipxstt, ipxend, ipxl, i, ilat, isite, ilon, iwork, mesg(2), isrc, ndata, numpxl_lat, numpxl_lon, numpxl + integer, allocatable :: temp (:,:) ! temporary array for receiving data from workers + +!----------------------------------------------------------------------------- + +#ifndef SinglePoint + IF (DEF_DA_SM_SMAP) THEN + ! grid file path of EASE v2.0, 36km world grid + file_grid_smap = trim(DEF_DA_obsdir)//'/grid/'//'/SMAP_L1C_36km.nc' + CALL grid_smap%define_from_file(file_grid_smap, 'latitude', 'longitude') + + ! map SMAP grid to patch + CALL mg2p_smap%build_arealweighted(grid_smap, landpatch) + ENDIF + + IF (DEF_DA_SM_FY) THEN + ! grid file path of FY3D, 0.25 degree world grid + file_grid_fy3d = trim(DEF_DA_obsdir)//'/grid/'//'/FY3D_L1_0p25.nc' + + CALL grid_fy3d%define_from_file(file_grid_fy3d, 'latitude', 'longitude') + + ! map FY3D grid to patch + CALL mg2p_fy3d%build_arealweighted(grid_fy3d, landpatch) + ENDIF + + IF (DEF_DA_SM_SYNOP) THEN +!############################################################################# +! Makeup derived types of pixel index for fast access at each worker +!############################################################################# + IF (p_is_worker) THEN + allocate (counter (pixel%nlat)) + counter(:) = 0 + + ! count the number of pixel lon index for each pixel lat index + DO np = 1, numpatch + ie = landpatch%ielm(np) + + ipxstt = landpatch%ipxstt(np) + ipxend = landpatch%ipxend(np) + + DO ipxl = ipxstt, ipxend + counter(mesh(ie)%ilat(ipxl)) = counter(mesh(ie)%ilat(ipxl)) + 1 + ENDDO + ENDDO + + ! allocate derived types of index + allocate (idx (pixel%nlat)) + DO i = 1, pixel%nlat + IF (counter(i) > 0) THEN + allocate (idx(i)%ilon(counter(i))) + allocate (idx(i)%ipatch(counter(i))) + + idx(i)%ilon(:) = 0 + idx(i)%ipatch(:) = 0 + ENDIF + ENDDO + + ! fill the index + counter(:) = 0 + DO np = 1, numpatch + ie = landpatch%ielm(np) + + ipxstt = landpatch%ipxstt(np) + ipxend = landpatch%ipxend(np) + + DO ipxl = ipxstt, ipxend + ilat = mesh(ie)%ilat(ipxl) + counter(mesh(ie)%ilat(ipxl)) = counter(mesh(ie)%ilat(ipxl)) + 1 + idx(ilat)%ilon(counter(mesh(ie)%ilat(ipxl))) = mesh(ie)%ilon(ipxl) + idx(ilat)%ipatch(counter(mesh(ie)%ilat(ipxl))) = np + ENDDO + ENDDO + ENDIF + + +!############################################################################# +! Read the location of SYNOP sites and find the located pixel of each site +!############################################################################# + ! file of SYNOP sites + file_site = trim(DEF_DA_obsdir)//'/grid/'//'/SYNOP.nc' + + ! read latitude and longitude of sites + IF (ncio_var_exist(file_site, 'latitude')) THEN + CALL ncio_read_bcast_serial(file_site, 'latitude', synop_lat_all) + CALL ncio_read_bcast_serial(file_site, 'longitude', synop_lon_all) + ENDIF + nsite = size(synop_lat_all) + + ! find the located pixel of each site & broadcast workers + allocate (iloc_synop (2, nsite)) + iloc_synop(:,:) = -1 + IF (p_is_master) THEN + DO i = 1, nsite + numpxl_lat = count(pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i)) + numpxl_lon = count(pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i)) + + IF (numpxl_lat ==1 .and. numpxl_lon ==1) THEN + IF (allocated (idx_lat)) deallocate (idx_lat) + IF (allocated (idx_lon)) deallocate (idx_lon) + allocate (idx_lat(numpxl_lat)) + allocate (idx_lon(numpxl_lon)) + + idx_lat = pack([(isite, isite=1, pixel%nlat)], pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i)) + idx_lon = pack([(isite, isite=1, pixel%nlon)], pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i)) + + iloc_synop(1,i) = idx_lat(1) + iloc_synop(2,i) = idx_lon(1) + ELSE + iloc_synop(1,i) = -1 + iloc_synop(2,i) = -1 + ENDIF + ENDDO + ENDIF + CALL mpi_bcast(iloc_synop, 2*nsite, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +!############################################################################# +! Assess the patch id of pixel that cover each observation at each worker +!############################################################################# + IF (p_is_worker) THEN + ! count the number of site that located in pixels of each worker + counter_worker_nsite = 0 + DO i = 1, nsite + IF (iloc_synop(1, i) > 0) THEN + IF (counter(iloc_synop(1, i)) > 0) THEN + IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN + counter_worker_nsite = counter_worker_nsite + 1 + ENDIF + ENDIF + ENDIF + ENDDO + + ! assess patch/site id of sites located at each worker + IF (counter_worker_nsite > 0) THEN + allocate (ip_worker (2, counter_worker_nsite)) + counter_worker_nsite = 0 + ip_worker(:,:) = -1 + + DO i = 1, nsite + IF (iloc_synop(1, i) > 0) THEN + IF (counter(iloc_synop(1, i)) > 0) THEN + IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN + numpxl = count(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i)) + IF (allocated (pos)) deallocate (pos) + allocate (pos(numpxl)) + + pos = pack([(ilon, ilon=1, counter(iloc_synop(1, i)))], (idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) + counter_worker_nsite = counter_worker_nsite + 1 + ip_worker(1, counter_worker_nsite) = i + ip_worker(2, counter_worker_nsite) = idx(iloc_synop(1, i))%ipatch(pos(1)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + + ! send the number of site and their patch id to master +#ifdef USEMPI + mesg = (/p_iam_glb, counter_worker_nsite/) + CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (counter_worker_nsite > 0) THEN + CALL mpi_send(ip_worker, 2*counter_worker_nsite, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#endif + + ! deallocate + IF (allocated (counter)) deallocate (counter) + DO i = 1, pixel%nlat + IF (allocated(idx(i)%ilon)) deallocate (idx(i)%ilon) + IF (allocated(idx(i)%ipatch)) deallocate (idx(i)%ipatch) + ENDDO + IF (allocated (idx)) deallocate (idx) + IF (allocated (iloc_synop)) deallocate (iloc_synop) + IF (allocated (ip_worker)) deallocate (ip_worker) + ENDIF + +!############################################################################# +! Generate look-up-table (contains the worker/patch id of each site) at master +!############################################################################# + IF (p_is_master) THEN + allocate (synop_lut (2, nsite)) + synop_lut(:,:) = -1 + +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + ndata = mesg(2) + + IF (ndata > 0) THEN + allocate (temp(2, ndata)) + CALL mpi_recv(temp, 2*ndata, MPI_INTEGER, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + DO i = 1, ndata + synop_lut(1, temp(1,i)) = isrc + synop_lut(2, temp(1,i)) = temp(2,i) + ENDDO + + deallocate(temp) + ENDIF + ENDDO +#endif + ENDIF + ENDIF +#endif + + END SUBROUTINE init_DA_SM + +!----------------------------------------------------------------------------- + + SUBROUTINE run_DA_SM(idate, deltim) + +!----------------------------------------------------------------------------- + USE MOD_Spmd_task + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_Vars_Global + USE MOD_Vars_1DFluxes + USE MOD_Vars_1DForcing + USE MOD_Vars_TimeVariables + USE MOD_Vars_TimeInvariants + USE MOD_DA_Vars_TimeVariables + USE MOD_RangeCheck + USE MOD_UserDefFun + USE MOD_DA_EnKF + USE MOD_Const_Physical, only: denice, denh2o + IMPLICIT NONE + +!------------------------ Dummy Arguments ------------------------------------ + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + +!------------------------ Local Variables ------------------------------------ + real(r8) :: lat_p_n, lat_p_s, lon_p_w, lon_p_e + real(r8) :: lat_p, lon_p + real(r8) :: es, e + integer :: ib, jb, il, jl, ip, iens, iobs, np, i, n, ndata, isrc, j + integer :: sdate(3), smesg(2), rmesg(2) + integer, allocatable :: iloc(:) + integer, allocatable :: itemp(:) + real(r8), allocatable :: dtemp(:,:) + integer :: iwork, mesg(2) + +!----------------------------------------------------------------------------- + +!############################################################################# +! Identify if there are observations at this time step +!############################################################################# + ! Do not perform DA, only calcuate predict BRT for diagnostic + IF (DEF_DA_ENS_NUM == 1) THEN + has_smap_file = .false. + has_fy3d_file = .false. + has_synop_file = .false. + ELSE + ! covert local time to UTC for single point + sdate = idate + CALL adj2begin(sdate) +#ifdef SinglePoint + IF (.not. DEF_simulation_time%greenwich) THEN + CALL localtime2gmt(sdate) + ENDIF +#endif + ! calculate year/month/day/hour of current step + CALL julian2monthday(sdate(1), sdate(2), month, mday) + hour = int(sdate(3)/3600) + + ! whether has file at target day + write (yearstr, '(I4.4)') sdate(1) + write (monthstr, '(I2.2)') month + write (daystr, '(I2.2)') mday + write (hourstr, '(I2.2)') hour + + ! check SMAP brightness temperature observations + IF (DEF_DA_SM_SMAP) THEN + ! file path of SMAP + file_smap = trim(DEF_DA_obsdir)//'/SMAP_L1C_D/'//'/SMAP_L1C_TB_'// & + trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc' + inquire (file=trim(file_smap), exist=has_smap_file) + + ! whether have obs at this time interval + has_smap_obs = .false. + IF (has_smap_file) THEN + CALL ncio_read_bcast_serial(file_smap, 'time', smap_time) + num_smap_obs = size(smap_time) + idate_b = sdate(3) + idate_e = sdate(3) + deltim + allocate (dt_b_smap(num_smap_obs)) + allocate (dt_e_smap(num_smap_obs)) + dt_b_smap = smap_time - idate_b + dt_e_smap = smap_time - idate_e + IF (any(dt_b_smap >= 0 .and. dt_e_smap <= 0)) has_smap_obs = .true. + deallocate (dt_b_smap) + deallocate (dt_e_smap) + ELSE + has_smap_obs = .false. + ENDIF + + ! check if there are obs in simulation domain + IF (has_smap_obs) THEN + CALL ncio_read_bcast_serial(file_smap, 'lat', smap_lat) + CALL ncio_read_bcast_serial(file_smap, 'lon', smap_lon) + + num_smap_obs_domain = count(smap_lat(:) < DEF_domain%edgen .and. smap_lat(:) > DEF_domain%edges .and. & + smap_lon(:) > DEF_domain%edgew .and. smap_lon(:) < DEF_domain%edgee) + IF (num_smap_obs_domain == 0) has_smap_obs = .false. + ENDIF + ELSE + has_smap_file = .false. + has_smap_obs = .false. + ENDIF + + ! check FY brightness temperature observations + IF (DEF_DA_SM_FY) THEN + ! file path of FY3D + file_fy3d = trim(DEF_DA_obsdir)//'/FY3D_L1/'//'/FY3D_L1_TB_'// & + trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc' + inquire (file=trim(file_fy3d), exist=has_fy3d_file) + + ! whether have obs at this time interval + has_fy3d_obs = .false. + IF (has_fy3d_file) THEN + CALL ncio_read_bcast_serial(file_fy3d, 'time', fy3d_time) + num_fy3d_obs = size(fy3d_time) + idate_b = sdate(3) + idate_e = sdate(3) + deltim + allocate (dt_b_fy3d(num_fy3d_obs)) + allocate (dt_e_fy3d(num_fy3d_obs)) + dt_b_fy3d = fy3d_time - idate_b + dt_e_fy3d = fy3d_time - idate_e + IF (any(dt_b_fy3d >= 0 .and. dt_e_fy3d <= 0)) has_fy3d_obs = .true. + deallocate (dt_b_fy3d) + deallocate (dt_e_fy3d) + ELSE + has_fy3d_obs = .false. + ENDIF + + ! check if there are obs in simulation domain + IF (has_fy3d_obs) THEN + CALL ncio_read_bcast_serial(file_fy3d, 'lat', fy3d_lat) + CALL ncio_read_bcast_serial(file_fy3d, 'lon', fy3d_lon) + + num_fy3d_obs_domain = count(fy3d_lat(:) < DEF_domain%edgen .and. fy3d_lat(:) > DEF_domain%edges .and. & + fy3d_lon(:) > DEF_domain%edgew .and. fy3d_lon(:) < DEF_domain%edgee) + IF (num_fy3d_obs_domain == 0) has_fy3d_obs = .false. + ENDIF + ELSE + has_fy3d_file = .false. + has_fy3d_obs = .false. + ENDIF + + ! check SYNOP 2m observations + IF (DEF_DA_SM_SYNOP) THEN + file_synop = trim(DEF_DA_obsdir)//'/SYNOP/'//'/SYNOP_'// & + trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc' + inquire (file=trim(file_synop), exist=has_synop_file) + + ! whether have obs at this time interval + has_synop_obs = .false. + IF (has_synop_file) THEN + CALL ncio_read_bcast_serial(file_synop, 'time', synop_time) + num_synop_obs = size(synop_time) + idate_b = sdate(3) + idate_e = sdate(3) + deltim + allocate (dt_b_synop(num_synop_obs)) + allocate (dt_e_synop(num_synop_obs)) + dt_b_synop = synop_time - idate_b + dt_e_synop = synop_time - idate_e + IF (any(dt_b_synop >= 0 .and. dt_e_synop <= 0)) has_synop_obs = .true. + deallocate (dt_b_synop) + deallocate (dt_e_synop) + ELSE + has_synop_obs = .false. + ENDIF + + ! check if there are obs in simulation domain + IF (has_synop_obs) THEN + CALL ncio_read_bcast_serial(file_synop, 'lat', synop_lat) + CALL ncio_read_bcast_serial(file_synop, 'lon', synop_lon) + + num_synop_obs_domain = count(synop_lat(:) < DEF_domain%edgen .and. synop_lat(:) > DEF_domain%edges .and. & + synop_lon(:) > DEF_domain%edgew .and. synop_lon(:) < DEF_domain%edgee) + IF (num_synop_obs_domain == 0) has_synop_obs = .false. + ENDIF + ELSE + has_synop_file = .false. + has_synop_obs = .false. + ENDIF + ENDIF + + ! print info of observations + IF (p_is_master) THEN + IF (has_smap_obs) THEN + print *, '[CoLM-DA] Have SMAP observations:', trim(file_smap) + ELSE + print *, '[CoLM-DA] No SMAP observations.' + ENDIF + IF (has_fy3d_obs) THEN + print *, '[CoLM-DA] Have FY3D observations:', trim(file_fy3d) + ELSE + print *, '[CoLM-DA] No FY3D observations.' + ENDIF + IF (has_synop_obs) THEN + print *, '[CoLM-DA] Have SYNOP observations:', trim(file_synop) + ELSE + print *, '[CoLM-DA] No SYNOP observations.' + ENDIF + ENDIF + +!############################################################################# +! Allocate memory for variables +!############################################################################# + IF (DEF_DA_SM_SMAP) THEN + ! allocate memory for ensemble predicted observations at patch (for DA or no DA) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + IF (allocated(pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) + IF (allocated(pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) + allocate (pred_smap_tb_h_pset_ens(DEF_DA_ENS_NUM, numpatch)) + allocate (pred_smap_tb_v_pset_ens(DEF_DA_ENS_NUM, numpatch)) + ENDIF + ENDIF + + ! allocate memory for ensemble predicted observations in vectors (only for DA) +#ifndef SinglePoint + IF (has_smap_obs) THEN + IF (allocated(pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens) + IF (allocated(pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens) + allocate (pred_smap_tb_h_ogrid_ens(num_smap_obs, DEF_DA_ENS_NUM)) + allocate (pred_smap_tb_v_ogrid_ens(num_smap_obs, DEF_DA_ENS_NUM)) + ENDIF +#endif + ENDIF + + IF (DEF_DA_SM_FY) THEN + ! allocate memory for ensemble predicted observations at patch (for DA or no DA) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + IF (allocated(pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) + IF (allocated(pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) + allocate (pred_fy3d_tb_h_pset_ens(DEF_DA_ENS_NUM, numpatch)) + allocate (pred_fy3d_tb_v_pset_ens(DEF_DA_ENS_NUM, numpatch)) + ENDIF + ENDIF + + ! allocate memory for ensemble predicted observations in vectors (only for DA) +#ifndef SinglePoint + IF (has_fy3d_obs) THEN + IF (allocated(pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens) + IF (allocated(pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens) + allocate (pred_fy3d_tb_h_ogrid_ens(num_fy3d_obs, DEF_DA_ENS_NUM)) + allocate (pred_fy3d_tb_v_ogrid_ens(num_fy3d_obs, DEF_DA_ENS_NUM)) + ENDIF +#endif + ENDIF + + IF (DEF_DA_SM_SYNOP) THEN + ! allocate memory + IF (has_synop_obs) THEN + IF (allocated(synop_idx)) deallocate (synop_idx) + IF (allocated(qref_ens_o)) deallocate (qref_ens_o) + IF (allocated(tref_ens_o)) deallocate (tref_ens_o) + allocate (synop_idx (2, num_synop_obs)) + allocate (qref_ens_o (num_synop_obs, DEF_DA_ENS_NUM)) + allocate (tref_ens_o (num_synop_obs, DEF_DA_ENS_NUM)) + ENDIF + ENDIF + +!############################################################################# +! Calculate predicted observations using observation operator +!############################################################################# + ! forward model (for no DA) + IF (p_is_worker) THEN + ! SMAP forward model + DO np = 1, numpatch + lat_p = patchlatr(np)*180/pi + lon_p = patchlonr(np)*180/pi + CALL forward(& + patchtype(np), patchclass(np), dz_sno(:,np), & + forc_topo(np), htop(np), & + tref(np), t_soisno(:,np), tleaf(np), & + wliq_soisno(:,np), wice_soisno(:,np), h2osoi(:,np), & + snowdp(np), lai(np), sai(np), & + wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & + smap_theta, smap_fghz, & + t_brt_smap(1,np), t_brt_smap(2,np)) + ENDDO + + ! FY3D forward model + DO np = 1, numpatch + CALL forward(& + patchtype(np), patchclass(np), dz_sno(:,np), & + forc_topo(np), htop(np), & + tref(np), t_soisno(:,np), tleaf(np), & + wliq_soisno(:,np), wice_soisno(:,np), h2osoi(:,np), & + snowdp(np), lai(np), sai(np), & + wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & + fy3d_theta, fy3d_fghz, & + t_brt_fy3d(1,np), t_brt_fy3d(2,np)) + ENDDO + ENDIF + + ! forward model for ensemble DA + IF (p_is_worker) THEN + IF (DEF_DA_SM_SMAP) THEN + IF (DEF_DA_ENS_NUM > 1) THEN + DO iens = 1, DEF_DA_ENS_NUM + DO np = 1, numpatch + CALL forward(& + patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & + forc_topo(np), htop(np), & + tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & + wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & + snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & + wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & + smap_theta, smap_fghz, & + pred_smap_tb_h_pset_ens(iens, np), pred_smap_tb_v_pset_ens(iens, np)) + ENDDO + ENDDO + t_brt_smap_ens(1,:,:) = pred_smap_tb_h_pset_ens + t_brt_smap_ens(2,:,:) = pred_smap_tb_v_pset_ens + ENDIF + ENDIF + + IF (DEF_DA_SM_FY) THEN + IF (DEF_DA_ENS_NUM > 1) THEN + DO iens = 1, DEF_DA_ENS_NUM + DO np = 1, numpatch + CALL forward(& + patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & + forc_topo(np), htop(np), & + tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & + wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & + snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & + wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & + fy3d_theta, fy3d_fghz, & + pred_fy3d_tb_h_pset_ens(iens, np), pred_fy3d_tb_v_pset_ens(iens, np)) + ENDDO + ENDDO + t_brt_fy3d_ens(1,:,:) = pred_fy3d_tb_h_pset_ens + t_brt_fy3d_ens(2,:,:) = pred_fy3d_tb_v_pset_ens + ENDIF + ENDIF + + IF (DEF_DA_SM_SYNOP) THEN + IF (DEF_DA_ENS_NUM > 1) THEN + ! calculate relative humidity from specific humidity + DO ip = 1, numpatch + DO iens = 1, DEF_DA_ENS_NUM + es = 6.112 * exp((17.67 * (tref_ens(iens, ip) - 273.15))/ (tref_ens(iens, ip) - 273.15 + 243.5)) + e = (qref_ens(iens, ip) * forc_psrf(ip) / 100) / (0.378 * qref_ens(iens, ip) + 0.622) + rhref_ens(iens, ip) = max(min(1.0d0, e / es), 0.0d0) + ENDDO + ENDDO + ENDIF + ENDIF + ENDIF + +!############################################################################# +! Reading observations data +!############################################################################# + ! read observations data (only for DA) + IF (has_smap_obs) THEN + CALL ncio_read_bcast_serial(file_smap, 'ii' , smap_ii ) + CALL ncio_read_bcast_serial(file_smap, 'jj' , smap_jj ) + CALL ncio_read_bcast_serial(file_smap, 'tb_h', smap_tb_h) + CALL ncio_read_bcast_serial(file_smap, 'tb_v', smap_tb_v) + CALL ncio_read_bcast_serial(file_smap, 'tb_h_colm_mean', pred_smap_tb_h_mean) + CALL ncio_read_bcast_serial(file_smap, 'tb_v_colm_mean', pred_smap_tb_v_mean) + CALL ncio_read_bcast_serial(file_smap, 'tb_h_obs_mean', smap_tb_h_mean) + CALL ncio_read_bcast_serial(file_smap, 'tb_v_obs_mean', smap_tb_v_mean) + ENDIF + IF (has_fy3d_obs) THEN + CALL ncio_read_bcast_serial(file_fy3d, 'ii' , fy3d_ii ) + CALL ncio_read_bcast_serial(file_fy3d, 'jj' , fy3d_jj ) + CALL ncio_read_bcast_serial(file_fy3d, 'tb_h', fy3d_tb_h) + CALL ncio_read_bcast_serial(file_fy3d, 'tb_v', fy3d_tb_v) + CALL ncio_read_bcast_serial(file_fy3d, 'tb_h_colm_mean', pred_fy3d_tb_h_mean) + CALL ncio_read_bcast_serial(file_fy3d, 'tb_v_colm_mean', pred_fy3d_tb_v_mean) + CALL ncio_read_bcast_serial(file_fy3d, 'tb_h_obs_mean', fy3d_tb_h_mean) + CALL ncio_read_bcast_serial(file_fy3d, 'tb_v_obs_mean', fy3d_tb_v_mean) + ENDIF + IF (has_synop_obs) THEN + CALL ncio_read_bcast_serial(file_synop, 'lat', synop_lat ) + CALL ncio_read_bcast_serial(file_synop, 'lon', synop_lon ) + CALL ncio_read_bcast_serial(file_synop, 'id', synop_id ) + CALL ncio_read_bcast_serial(file_synop, 'tref', synop_tref) + CALL ncio_read_bcast_serial(file_synop, 'qref', synop_qref) + ENDIF + +!############################################################################# +! Cropping predicted observations at observations space +!############################################################################# +#ifndef SinglePoint + IF (DEF_DA_SM_SMAP) THEN + IF (has_smap_obs) THEN + ! prepare filter for land patches + allocate (filter(numpatch)) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + filter(:) = patchtype <= 2 + ENDIF + ENDIF + + ! calculate area of each patch across world grid + IF (p_is_io) CALL allocate_block_data(grid_smap, area_smap_wgrid) + CALL mg2p_smap%get_sumarea(area_smap_wgrid, filter) + + ! mapping predicted observations from patch to world grid + IF (p_is_io) THEN + CALL allocate_block_data(grid_smap, pred_smap_tb_h_wgrid_ens, DEF_DA_ENS_NUM) + CALL allocate_block_data(grid_smap, pred_smap_tb_v_wgrid_ens, DEF_DA_ENS_NUM) + ENDIF + CALL mg2p_smap%pset2grid(pred_smap_tb_h_pset_ens, pred_smap_tb_h_wgrid_ens, spv=spval, msk=filter) + CALL mg2p_smap%pset2grid(pred_smap_tb_v_pset_ens, pred_smap_tb_v_wgrid_ens, spv=spval, msk=filter) + deallocate (filter) + + ! crop the predicted observations + IF (p_is_io) THEN + allocate (iloc(num_smap_obs)) + pred_smap_tb_h_ogrid_ens = -9999.0 + pred_smap_tb_v_ogrid_ens = -9999.0 + + ! crop obs from world grid to all obs grids + ndata = 0 + DO i = 1, num_smap_obs + ib = grid_smap%xblk(smap_jj(i)) + jb = grid_smap%yblk(smap_ii(i)) + il = grid_smap%xloc(smap_jj(i)) + jl = grid_smap%yloc(smap_ii(i)) + IF (ib /= 0 .and. jb /= 0) THEN + IF (gblock%pio(ib, jb) == p_iam_glb) THEN + area_smap_wgrid_obs = area_smap_wgrid%blk(ib, jb)%val(il, jl) + IF (area_smap_wgrid_obs /= 0) THEN +#ifdef USEMPI + ndata = ndata + 1 + iloc(ndata) = i + pred_smap_tb_h_ogrid_ens(ndata, :) = (pred_smap_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs + pred_smap_tb_v_ogrid_ens(ndata, :) = (pred_smap_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs +#else + pred_smap_tb_h_ogrid_ens(i, :) = (pred_smap_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs + pred_smap_tb_v_ogrid_ens(i, :) = (pred_smap_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs +#endif + ENDIF + ENDIF + ENDIF + ENDDO + + ! send data from io to masters +#ifdef USEMPI + smesg = (/p_iam_glb, ndata/) + CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (ndata > 0) THEN + CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + + allocate (dtemp(ndata, DEF_DA_ENS_NUM)) + dtemp = pred_smap_tb_h_ogrid_ens(1:ndata, :) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + dtemp = pred_smap_tb_v_ogrid_ens(1:ndata, :) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data + 1, p_comm_glb, p_err) + deallocate (dtemp) + ENDIF +#endif + deallocate (iloc) + deallocate (pred_smap_tb_h_wgrid_ens%blk, pred_smap_tb_v_wgrid_ens%blk) + ENDIF + + ! broadcast from master to all workers +#ifdef USEMPI + IF (p_is_master) THEN + pred_smap_tb_h_ogrid_ens = -9999.0 + pred_smap_tb_v_ogrid_ens = -9999.0 + DO ip = 0, p_np_io - 1 + CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + ndata = rmesg(2) + IF (ndata > 0) THEN + allocate (itemp(ndata)) + allocate (dtemp(ndata, DEF_DA_ENS_NUM)) + + isrc = rmesg(1) + CALL mpi_recv(itemp, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + pred_smap_tb_h_ogrid_ens(itemp, :) = dtemp + CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data + 1, p_comm_glb, p_stat, p_err) + pred_smap_tb_v_ogrid_ens(itemp, :) = dtemp + + deallocate (itemp) + deallocate (dtemp) + ENDIF + ENDDO + ENDIF + CALL mpi_bcast(pred_smap_tb_h_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(pred_smap_tb_v_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (DEF_DA_SM_FY) THEN + IF (has_fy3d_obs) THEN + ! prepare filter for land patches + allocate (filter(numpatch)) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + filter(:) = patchtype <= 2 + ENDIF + ENDIF + + ! calculate area of each patch across world grid + IF (p_is_io) CALL allocate_block_data(grid_fy3d, area_fy3d_wgrid) + CALL mg2p_fy3d%get_sumarea(area_fy3d_wgrid, filter) + + ! mapping predicted observations from patch to world grid + IF (p_is_io) THEN + CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_h_wgrid_ens, DEF_DA_ENS_NUM) + CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_v_wgrid_ens, DEF_DA_ENS_NUM) + ENDIF + CALL mg2p_fy3d%pset2grid(pred_fy3d_tb_h_pset_ens, pred_fy3d_tb_h_wgrid_ens, spv=spval, msk=filter) + CALL mg2p_fy3d%pset2grid(pred_fy3d_tb_v_pset_ens, pred_fy3d_tb_v_wgrid_ens, spv=spval, msk=filter) + deallocate (filter) + + ! crop the predicted observations + IF (p_is_io) THEN + allocate (iloc(num_fy3d_obs)) + pred_fy3d_tb_h_ogrid_ens = -9999.0 + pred_fy3d_tb_v_ogrid_ens = -9999.0 + + ! crop obs from world grid to all obs grids + ndata = 0 + DO i = 1, num_fy3d_obs + ib = grid_fy3d%xblk(fy3d_jj(i)) + jb = grid_fy3d%yblk(fy3d_ii(i)) + il = grid_fy3d%xloc(fy3d_jj(i)) + jl = grid_fy3d%yloc(fy3d_ii(i)) + IF (ib /= 0 .and. jb /= 0) THEN + IF (gblock%pio(ib, jb) == p_iam_glb) THEN + area_fy3d_wgrid_obs = area_fy3d_wgrid%blk(ib, jb)%val(il, jl) + IF (area_fy3d_wgrid_obs /= 0) THEN +#ifdef USEMPI + ndata = ndata + 1 + iloc(ndata) = i + pred_fy3d_tb_h_ogrid_ens(ndata, :) = (pred_fy3d_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs + pred_fy3d_tb_v_ogrid_ens(ndata, :) = (pred_fy3d_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs +#else + pred_fy3d_tb_h_ogrid_ens(i, :) = (pred_fy3d_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs + pred_fy3d_tb_v_ogrid_ens(i, :) = (pred_fy3d_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs +#endif + ENDIF + ENDIF + ENDIF + ENDDO + + ! send data from io to masters +#ifdef USEMPI + smesg = (/p_iam_glb, ndata/) + CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (ndata > 0) THEN + CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + + allocate (dtemp(ndata, DEF_DA_ENS_NUM)) + dtemp = pred_fy3d_tb_h_ogrid_ens(1:ndata, :) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + dtemp = pred_fy3d_tb_v_ogrid_ens(1:ndata, :) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data + 1, p_comm_glb, p_err) + deallocate (dtemp) + ENDIF +#endif + deallocate (iloc) + deallocate (pred_fy3d_tb_h_wgrid_ens%blk, pred_fy3d_tb_v_wgrid_ens%blk) + ENDIF + + ! broadcast from master to all workers +#ifdef USEMPI + IF (p_is_master) THEN + pred_fy3d_tb_h_ogrid_ens = -9999.0 + pred_fy3d_tb_v_ogrid_ens = -9999.0 + DO ip = 0, p_np_io - 1 + CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + ndata = rmesg(2) + IF (ndata > 0) THEN + allocate (itemp(ndata)) + allocate (dtemp(ndata, DEF_DA_ENS_NUM)) + + isrc = rmesg(1) + CALL mpi_recv(itemp, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + pred_fy3d_tb_h_ogrid_ens(itemp, :) = dtemp + CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data + 1, p_comm_glb, p_stat, p_err) + pred_fy3d_tb_v_ogrid_ens(itemp, :) = dtemp + + deallocate (itemp) + deallocate (dtemp) + ENDIF + ENDDO + ENDIF + CALL mpi_bcast(pred_fy3d_tb_h_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(pred_fy3d_tb_v_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (DEF_DA_SM_SYNOP) THEN + ! crop corresponding index (worker id and patch id) of each observation + IF (has_synop_obs) THEN + synop_idx(:,:) = -1 + IF (p_is_master) THEN + synop_idx = synop_lut(:, synop_id) + ENDIF + CALL mpi_bcast(synop_idx, 2*num_synop_obs, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + ENDIF + + ! recount the number of observations at each worker + IF (has_synop_obs) THEN + IF (p_is_worker) THEN + counter_worker_nsite = 0 + DO i = 1, num_synop_obs + IF (synop_idx(1, i) == p_iam_glb) THEN + counter_worker_nsite = counter_worker_nsite + 1 + ENDIF + ENDDO + ENDIF + ENDIF + + ! allocate memory for worker + IF (has_synop_obs) THEN + IF (p_is_worker) THEN + IF (counter_worker_nsite > 0) THEN + IF (allocated(tref_ens_worker)) deallocate (tref_ens_worker) + IF (allocated(qref_ens_worker)) deallocate (qref_ens_worker) + IF (allocated(site_id_worker)) deallocate (site_id_worker) + allocate (tref_ens_worker (counter_worker_nsite, DEF_DA_ENS_NUM)) + allocate (qref_ens_worker (counter_worker_nsite, DEF_DA_ENS_NUM)) + allocate (site_id_worker (counter_worker_nsite)) + ENDIF + ENDIF + ENDIF + + ! crop observations at each worker according index & send to master + IF (has_synop_obs) THEN + IF (p_is_worker) THEN + counter_worker_nsite = 0 + DO i = 1, num_synop_obs + IF (synop_idx(1, i) == p_iam_glb) THEN + counter_worker_nsite = counter_worker_nsite + 1 + tref_ens_worker(counter_worker_nsite,:) = tref_ens(:, synop_idx(2, i)) + qref_ens_worker(counter_worker_nsite,:) = rhref_ens(:, synop_idx(2, i)) + site_id_worker (counter_worker_nsite) = i + ENDIF + ENDDO + +#ifdef USEMPI + ! send the number of site and their patch id to master + mesg = (/p_iam_glb, counter_worker_nsite/) + CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (counter_worker_nsite > 0) THEN + CALL mpi_send(tref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(qref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(site_id_worker, counter_worker_nsite, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#endif + + IF (allocated(tref_ens_worker)) deallocate (tref_ens_worker) + IF (allocated(qref_ens_worker)) deallocate (qref_ens_worker) + IF (allocated(site_id_worker)) deallocate (site_id_worker) + ENDIF + ENDIF + + ! concatenate all predicted observations at master & broadcast to all workers + IF (has_synop_obs) THEN + qref_ens_o = spval + tref_ens_o = spval + IF (p_is_master) THEN +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + ndata = mesg(2) + + IF (ndata > 0) THEN + allocate(tref_ens_worker(ndata, DEF_DA_ENS_NUM)) + allocate(qref_ens_worker(ndata, DEF_DA_ENS_NUM)) + allocate(site_id_worker (ndata)) + + CALL mpi_recv(tref_ens_worker, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(qref_ens_worker, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(site_id_worker, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + qref_ens_o(site_id_worker,:) = qref_ens_worker + tref_ens_o(site_id_worker,:) = tref_ens_worker + ENDIF + + IF (allocated(tref_ens_worker)) deallocate(tref_ens_worker) + IF (allocated(qref_ens_worker)) deallocate(qref_ens_worker) + IF (allocated(site_id_worker)) deallocate(site_id_worker) + ENDDO +#endif + ENDIF + CALL mpi_bcast(qref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(tref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_master, p_comm_glb, p_err) + ENDIF + ENDIF +#endif + +!############################################################################# +! Run data assimilation (for only DA) +!############################################################################# + has_DA = .false. + IF (has_smap_obs .or. has_fy3d_obs .or. has_synop_obs) THEN + ! for grid data assimilation + IF (p_is_worker) THEN + DO np = 1, numpatch + +!############################################################################# +! 1. Find observations around each patch +!############################################################################# + ! regions info around target patch + lat_p_n = patchlatr(np)*180/pi + dres + lat_p_s = patchlatr(np)*180/pi - dres + lon_p_w = patchlonr(np)*180/pi - dres + lon_p_e = patchlonr(np)*180/pi + dres + + ! find observations around each patch + num_obs_p = 0 + num_smap_p = 0 + num_fy3d_p = 0 + num_synop_p = 0 + IF (DEF_DA_SM_SMAP) THEN + IF (has_smap_obs) THEN + num_smap_p = count(smap_lat(:) < lat_p_n .and. smap_lat(:) > lat_p_s .and. & + smap_lon(:) > lon_p_w .and. smap_lon(:) < lon_p_e .and. & + smap_time(:) - idate_b >= 0 .and. smap_time(:) - idate_e <= 0 .and. & + smap_tb_h_mean(:) > 0 .and. pred_smap_tb_h_mean(:) > 0) + ENDIF + ENDIF + IF (DEF_DA_SM_FY) THEN + IF (has_fy3d_obs) THEN + num_fy3d_p = count(fy3d_lat(:) < lat_p_n .and. fy3d_lat(:) > lat_p_s .and. & + fy3d_lon(:) > lon_p_w .and. fy3d_lon(:) < lon_p_e .and. & + fy3d_time(:) - idate_b >= 0 .and. fy3d_time(:) - idate_e <= 0 .and. & + fy3d_tb_h_mean(:) > 0 .and. pred_fy3d_tb_h_mean(:) > 0) + ENDIF + ENDIF + IF (DEF_DA_SM_SYNOP) THEN + IF (has_synop_obs) THEN + num_synop_p = count( & + synop_lat(:) < lat_p_n .and. synop_lat(:) > lat_p_s .and. & + synop_lon(:) > lon_p_w .and. synop_lon(:) < lon_p_e .and. & + synop_time(:) - idate_b >= 0 .and. synop_time(:) - idate_e <= 0 .and. & + tref_ens_o(:,1) > 0) + ENDIF + ENDIF + num_obs_p = num_smap_p + num_fy3d_p + 2*num_synop_p + +!############################################################################# +! 2. Perform data assimilation +!############################################################################# + IF (num_obs_p > 0) THEN + ! allocate memory for data assimilation + allocate (obs_err (num_obs_p )) + allocate (trans (DEF_DA_ENS_NUM,DEF_DA_ENS_NUM)) + allocate (wliq_soi_ens (nl_soil, DEF_DA_ENS_NUM )) + allocate (wliq_soi_ens_da(nl_soil, DEF_DA_ENS_NUM )) + allocate (t_soi_ens (nl_soil, DEF_DA_ENS_NUM )) + allocate (t_soi_ens_da (nl_soil, DEF_DA_ENS_NUM )) + allocate (pred_obs_p_ens (num_obs_p, DEF_DA_ENS_NUM )) + allocate (obs_p (num_obs_p )) + + +!############################################################################# +! 2.1. Prepare observations around target patch for each observation dataset +!############################################################################# + IF (num_smap_p > 0) THEN + ! allocate memory + allocate (index_smap_p (num_smap_p )) + allocate (smap_lat_p (num_smap_p )) + allocate (smap_lon_p (num_smap_p )) + allocate (smap_tb_h_p (num_smap_p )) + allocate (smap_tb_v_p (num_smap_p )) + allocate (pred_smap_tb_h_p_ens (num_smap_p, DEF_DA_ENS_NUM)) + allocate (pred_smap_tb_v_p_ens (num_smap_p, DEF_DA_ENS_NUM)) + allocate (smap_tb_h_mean_p (num_smap_p )) + allocate (smap_tb_v_mean_p (num_smap_p )) + allocate (pred_smap_tb_h_mean_p(num_smap_p )) + allocate (pred_smap_tb_v_mean_p(num_smap_p )) + allocate (smap_err (num_smap_p )) + allocate (d_smap_p (num_smap_p )) + + ! index of observations around target patch + index_smap_p = (smap_lat(:) < lat_p_n .and. smap_lat(:) > lat_p_s .and. & + smap_lon(:) > lon_p_w .and. smap_lon(:) < lon_p_e .and. & + smap_time(:) - idate_b >= 0 .and. smap_time(:) - idate_e <= 0 .and. & + smap_tb_h_mean(:) > 0 .and. pred_smap_tb_h_mean(:) > 0) + + ! crop observations around target patch + smap_lat_p = pack(smap_lat , index_smap_p) + smap_lon_p = pack(smap_lon , index_smap_p) + smap_tb_h_p = pack(smap_tb_h, index_smap_p) + smap_tb_v_p = pack(smap_tb_v, index_smap_p) + + ! crop ensemble predicted observations around target patch + DO i = 1, DEF_DA_ENS_NUM + pred_smap_tb_h_p_ens(:, i) = pack(pred_smap_tb_h_ogrid_ens(:, i), index_smap_p) + pred_smap_tb_v_p_ens(:, i) = pack(pred_smap_tb_v_ogrid_ens(:, i), index_smap_p) + ENDDO + + ! crop mean values around target patch + smap_tb_h_mean_p = pack(smap_tb_h_mean, index_smap_p) + smap_tb_v_mean_p = pack(smap_tb_v_mean, index_smap_p) + pred_smap_tb_h_mean_p = pack(pred_smap_tb_h_mean, index_smap_p) + pred_smap_tb_v_mean_p = pack(pred_smap_tb_v_mean, index_smap_p) + + ! scaling + smap_tb_h_p = smap_tb_h_p - smap_tb_h_mean_p + smap_tb_v_p = smap_tb_v_p - smap_tb_v_mean_p + DO i = 1, DEF_DA_ENS_NUM + pred_smap_tb_h_p_ens(:, i) = pred_smap_tb_h_p_ens(:, i) - pred_smap_tb_h_mean_p + pred_smap_tb_v_p_ens(:, i) = pred_smap_tb_v_p_ens(:, i) - pred_smap_tb_v_mean_p + ENDDO + + ! calculate distance between observation and patch center + d_smap_p = 2*6.3781e3*asin(sqrt(sin((smap_lat_p*pi/180 - patchlatr(np))/2.0)**2 + & + cos(smap_lat_p*pi/180)*cos(patchlatr(np))*sin((smap_lon_p*pi/180 - patchlonr(np))/2.0)**2)) + + ! calculate weighted observation error + smap_err = static_smap_err/(exp((-d_smap_p**2)/(2*loc_r**2))) + ENDIF + + IF (num_fy3d_p > 0) THEN + ! allocate memory + allocate (index_fy3d_p (num_fy3d_p )) + allocate (fy3d_lat_p (num_fy3d_p )) + allocate (fy3d_lon_p (num_fy3d_p )) + allocate (fy3d_tb_h_p (num_fy3d_p )) + allocate (fy3d_tb_v_p (num_fy3d_p )) + allocate (pred_fy3d_tb_h_p_ens (num_fy3d_p, DEF_DA_ENS_NUM)) + allocate (pred_fy3d_tb_v_p_ens (num_fy3d_p, DEF_DA_ENS_NUM)) + allocate (fy3d_tb_h_mean_p (num_fy3d_p )) + allocate (fy3d_tb_v_mean_p (num_fy3d_p )) + allocate (pred_fy3d_tb_h_mean_p(num_fy3d_p )) + allocate (pred_fy3d_tb_v_mean_p(num_fy3d_p )) + allocate (fy3d_err (num_fy3d_p )) + allocate (d_fy3d_p (num_fy3d_p )) + + ! index of observations around target patch + index_fy3d_p = (fy3d_lat(:) < lat_p_n .and. fy3d_lat(:) > lat_p_s .and. & + fy3d_lon(:) > lon_p_w .and. fy3d_lon(:) < lon_p_e .and. & + fy3d_time(:) - idate_b >= 0 .and. fy3d_time(:) - idate_e <= 0 .and. & + fy3d_tb_h_mean(:) > 0 .and. pred_fy3d_tb_h_mean(:) > 0) + + ! crop observations around target patch + fy3d_lat_p = pack(fy3d_lat , index_fy3d_p) + fy3d_lon_p = pack(fy3d_lon , index_fy3d_p) + fy3d_tb_h_p = pack(fy3d_tb_h, index_fy3d_p) + fy3d_tb_v_p = pack(fy3d_tb_v, index_fy3d_p) + + ! crop ensemble predicted observations around target patch + DO i = 1, DEF_DA_ENS_NUM + pred_fy3d_tb_h_p_ens(:, i) = pack(pred_fy3d_tb_h_ogrid_ens(:, i), index_fy3d_p) + pred_fy3d_tb_v_p_ens(:, i) = pack(pred_fy3d_tb_v_ogrid_ens(:, i), index_fy3d_p) + ENDDO + + ! crop mean values around target patch + fy3d_tb_h_mean_p = pack(fy3d_tb_h_mean, index_fy3d_p) + fy3d_tb_v_mean_p = pack(fy3d_tb_v_mean, index_fy3d_p) + pred_fy3d_tb_h_mean_p = pack(pred_fy3d_tb_h_mean, index_fy3d_p) + pred_fy3d_tb_v_mean_p = pack(pred_fy3d_tb_v_mean, index_fy3d_p) + + ! scaling + fy3d_tb_h_p = fy3d_tb_h_p - fy3d_tb_h_mean_p + fy3d_tb_v_p = fy3d_tb_v_p - fy3d_tb_v_mean_p + DO i = 1, DEF_DA_ENS_NUM + pred_fy3d_tb_h_p_ens(:, i) = pred_fy3d_tb_h_p_ens(:, i) - pred_fy3d_tb_h_mean_p + pred_fy3d_tb_v_p_ens(:, i) = pred_fy3d_tb_v_p_ens(:, i) - pred_fy3d_tb_v_mean_p + ENDDO + + ! calculate distance between observation and patch center + d_fy3d_p = 2*6.3781e3*asin(sqrt(sin((fy3d_lat_p*pi/180 - patchlatr(np))/2.0)**2 + & + cos(fy3d_lat_p*pi/180)*cos(patchlatr(np))*sin((fy3d_lon_p*pi/180 - patchlonr(np))/2.0)**2)) + + ! calculate weighted observation error + fy3d_err = static_fy3d_err/(exp((-d_fy3d_p**2)/(2*loc_r**2))) + ENDIF + + IF (num_synop_p > 0) THEN + ! allocate memory + allocate (index_synop_p (num_synop_p )) + allocate (synop_lat_p (num_synop_p )) + allocate (synop_lon_p (num_synop_p )) + allocate (synop_qref_p (num_synop_p )) + allocate (synop_tref_p (num_synop_p )) + allocate (qref_ens_p (num_synop_p, DEF_DA_ENS_NUM )) + allocate (tref_ens_p (num_synop_p, DEF_DA_ENS_NUM )) + allocate (synop_tref_err (num_synop_p )) + allocate (synop_qref_err (num_synop_p )) + allocate (d_synop_p (num_synop_p )) + + ! index of observations around target patch + index_synop_p = ( & + synop_lat(:) < lat_p_n .and. synop_lat(:) > lat_p_s .and. & + synop_lon(:) > lon_p_w .and. synop_lon(:) < lon_p_e .and. & + synop_time(:) - idate_b >= 0 .and. synop_time(:) - idate_e <= 0 .and. & + tref_ens_o(:,1) > 0) + + ! crop observations around target patch + synop_lat_p = pack(synop_lat, index_synop_p) + synop_lon_p = pack(synop_lon, index_synop_p) + synop_qref_p = pack(synop_qref, index_synop_p) + synop_tref_p = pack(synop_tref, index_synop_p) + + ! crop ensemble predicted observations around target patch + DO i = 1, DEF_DA_ENS_NUM + qref_ens_p(:, i) = pack(qref_ens_o(:, i), index_synop_p) + tref_ens_p(:, i) = pack(tref_ens_o(:, i), index_synop_p) + ENDDO + + ! calculate distance between observation and patch center + d_synop_p = 2*6.3781e3*asin(sqrt(sin((synop_lat_p*pi/180 - patchlatr(np))/2.0)**2 + & + cos(synop_lat_p*pi/180)*cos(patchlatr(np))*sin((synop_lon_p*pi/180 - patchlonr(np))/2.0)**2)) + + ! calculate weighted observation error + synop_tref_err = static_synop_tref_err/(exp((-d_synop_p**2)/(2*loc_r**2))) + synop_qref_err = static_synop_qref_err/(exp((-d_synop_p**2)/(2*loc_r**2))) + ENDIF + +!############################################################################# +! 2.2. Concat observations & ensemble predictions around target patch +!############################################################################# + ! index of end of each observation dataset + end_idx(1) = num_smap_p + end_idx(2) = num_smap_p + num_fy3d_p + end_idx(3) = num_smap_p + num_fy3d_p + num_synop_p + + ! concatenate ensemble predictions + IF (num_smap_p > 0) THEN + pred_obs_p_ens(1:end_idx(1),:) = pred_smap_tb_h_p_ens + obs_p(1:end_idx(1)) = smap_tb_h_p + obs_err(1:end_idx(1)) = smap_err + ENDIF + IF (num_fy3d_p > 0) THEN + pred_obs_p_ens(end_idx(1)+1:end_idx(2),:) = pred_fy3d_tb_h_p_ens + obs_p(end_idx(1)+1:end_idx(2)) = fy3d_tb_h_p + obs_err(end_idx(1)+1:end_idx(2)) = fy3d_err + ENDIF + IF (num_synop_p > 0) THEN + pred_obs_p_ens(end_idx(2)+1:end_idx(3),:) = tref_ens_p + pred_obs_p_ens(end_idx(3)+1:,:) = qref_ens_p + obs_p(end_idx(2)+1:end_idx(3)) = synop_tref_p + obs_p(end_idx(3)+1:) = synop_qref_p + obs_err(end_idx(2)+1:end_idx(3)) = synop_tref_err + obs_err(end_idx(3)+1:) = synop_qref_err + ENDIF + !index_nearest = minloc(d_p, dim=1) + +!############################################################################# +! Perform LETKF and postprocess analysis results +!############################################################################# + ! calculate transformation matrix + CALL letkf(DEF_DA_ENS_NUM, num_obs_p, & + pred_obs_p_ens, obs_p, obs_err, infl, & + trans) + + ! calculate analysis value + IF (patchtype(np) < 3) THEN ! ocean, lake, ice + has_DA = .true. + + ! soil layer + DO iens = 1, DEF_DA_ENS_NUM + wliq_soi_ens(:, iens) = wliq_soisno_ens(1:, iens, np) + t_soi_ens(:, iens) = t_soisno_ens(1:, iens, np) + ENDDO + + ! analysis + CALL dgemm('N', 'N', nl_soil, DEF_DA_ENS_NUM, DEF_DA_ENS_NUM, 1.0_8, wliq_soi_ens, & + nl_soil, trans, DEF_DA_ENS_NUM, 0.0_8, wliq_soi_ens_da, nl_soil) + CALL dgemm('N', 'N', nl_soil, DEF_DA_ENS_NUM, DEF_DA_ENS_NUM, 1.0_8, t_soi_ens, & + nl_soil, trans, DEF_DA_ENS_NUM, 0.0_8, t_soi_ens_da, nl_soil) + + ! save analysis results + wliq_soi_ens_da = max(0.0, wliq_soi_ens_da) + DO iens = 1, DEF_DA_ENS_NUM + wliq_soisno_ens(1:2, iens, np) = wliq_soi_ens_da(1:2, iens) + ! limit the change of t_soisno in range of [-20.0, 20.0] + WHERE (t_soi_ens_da(1:2,iens) > t_soisno_ens(1:2,iens,np)) + t_soisno_ens(1:2,iens,np) = t_soisno_ens(1:2,iens,np) + min(20.0, t_soi_ens_da(1:2,iens)-t_soisno_ens(1:2,iens,np)) + ELSEWHERE + t_soisno_ens(1:2,iens,np) = t_soisno_ens(1:2,iens,np) + max(-20.0, t_soi_ens_da(1:2,iens)-t_soisno_ens(1:2,iens,np)) + ENDWHERE + ENDDO + + ! limit the soil liquid and ice water in a reasonable range + DO i = 1, nl_soil + DO iens = 1, DEF_DA_ENS_NUM + ! lower bound + wliq_soisno_ens(i, iens, np) = max(0.0d0, wliq_soisno_ens(i, iens, np)) + wice_soisno_ens(i, iens, np) = max(0.0d0, wice_soisno_ens(i, iens, np)) + IF (wliq_soisno_ens(i, iens, np) == 0.0 .and. wice_soisno_ens(i, iens, np) == 0.0) THEN + IF (t_soisno_ens(i, iens, np)-tfrz < -5.0) THEN + wice_soisno_ens(i, iens, np) = 1e-10 + ELSE + wliq_soisno_ens(i, iens, np) = 1e-10 + ENDIF + ENDIF + + ! upper bound + wliq_soisno_ens(i, iens, np) = min(porsl(i, np)*(dz_soi(i)*denh2o), wliq_soisno_ens(i, iens, np)) + eff_porsl = max(0.0d0, porsl(i, np) - wliq_soisno_ens(i, iens, np)/(dz_soi(i)*denh2o)) + wice_soisno_ens(i, iens, np) = min(eff_porsl*(dz_soi(i)*denice), wice_soisno_ens(i, iens, np)) + ENDDO + ENDDO + + ! move residual water to water table + wa_ens(:, np) = wa_ens(:, np) - sum(wliq_soisno_ens(1:, :, np) - wliq_soi_ens, dim=1) + + ! update volumetric water content for diagnostic + DO iens = 1, DEF_DA_ENS_NUM + h2osoi_ens(:, iens, np) = wliq_soisno_ens(1:, iens, np)/(dz_soi(:)*denh2o) + wice_soisno_ens(1:, iens, np)/(dz_soi(:)*denice) + h2osoi_ens(:, iens, np) = min(1.0d0, h2osoi_ens(:, iens, np)) + h2osoi_ens(:, iens, np) = max(0.0d0, h2osoi_ens(:, iens, np)) + ENDDO + ENDIF + ENDIF + + +!############################################################################# +! deallocate memory changes with patch +!############################################################################# + IF (allocated(trans )) deallocate (trans ) + IF (allocated(smap_err )) deallocate (smap_err ) + IF (allocated(d_smap_p )) deallocate (d_smap_p ) + IF (allocated(fy3d_err )) deallocate (fy3d_err ) + IF (allocated(d_fy3d_p )) deallocate (d_fy3d_p ) + IF (allocated(synop_tref_err )) deallocate (synop_tref_err ) + IF (allocated(synop_qref_err )) deallocate (synop_qref_err ) + IF (allocated(d_synop_p )) deallocate (d_synop_p ) + IF (allocated(pred_obs_p_ens )) deallocate (pred_obs_p_ens ) + IF (allocated(obs_p )) deallocate (obs_p ) + IF (allocated(obs_err )) deallocate (obs_err ) + IF (allocated(wliq_soi_ens )) deallocate (wliq_soi_ens ) + IF (allocated(wliq_soi_ens_da )) deallocate (wliq_soi_ens_da ) + IF (allocated(t_soi_ens )) deallocate (t_soi_ens ) + IF (allocated(t_soi_ens_da )) deallocate (t_soi_ens_da ) + + IF (allocated(index_smap_p )) deallocate (index_smap_p ) + IF (allocated(smap_lat_p )) deallocate (smap_lat_p ) + IF (allocated(smap_lon_p )) deallocate (smap_lon_p ) + IF (allocated(smap_tb_h_p )) deallocate (smap_tb_h_p ) + IF (allocated(smap_tb_v_p )) deallocate (smap_tb_v_p ) + IF (allocated(pred_smap_tb_h_p_ens )) deallocate (pred_smap_tb_h_p_ens ) + IF (allocated(pred_smap_tb_v_p_ens )) deallocate (pred_smap_tb_v_p_ens ) + IF (allocated(smap_tb_h_mean_p )) deallocate (smap_tb_h_mean_p ) + IF (allocated(pred_smap_tb_h_mean_p)) deallocate (pred_smap_tb_h_mean_p) + IF (allocated(smap_tb_v_mean_p )) deallocate (smap_tb_v_mean_p ) + IF (allocated(pred_smap_tb_v_mean_p)) deallocate (pred_smap_tb_v_mean_p) + + IF (allocated(index_fy3d_p )) deallocate (index_fy3d_p ) + IF (allocated(fy3d_lat_p )) deallocate (fy3d_lat_p ) + IF (allocated(fy3d_lon_p )) deallocate (fy3d_lon_p ) + IF (allocated(fy3d_tb_h_p )) deallocate (fy3d_tb_h_p ) + IF (allocated(fy3d_tb_v_p )) deallocate (fy3d_tb_v_p ) + IF (allocated(pred_fy3d_tb_h_p_ens )) deallocate (pred_fy3d_tb_h_p_ens ) + IF (allocated(pred_fy3d_tb_v_p_ens )) deallocate (pred_fy3d_tb_v_p_ens ) + IF (allocated(fy3d_tb_h_mean_p )) deallocate (fy3d_tb_h_mean_p ) + IF (allocated(pred_fy3d_tb_h_mean_p)) deallocate (pred_fy3d_tb_h_mean_p) + IF (allocated(fy3d_tb_v_mean_p )) deallocate (fy3d_tb_v_mean_p ) + IF (allocated(pred_fy3d_tb_v_mean_p)) deallocate (pred_fy3d_tb_v_mean_p) + + IF (allocated(index_synop_p )) deallocate (index_synop_p ) + IF (allocated(synop_lat_p )) deallocate (synop_lat_p ) + IF (allocated(synop_lon_p )) deallocate (synop_lon_p ) + IF (allocated(synop_qref_p )) deallocate (synop_qref_p ) + IF (allocated(synop_tref_p )) deallocate (synop_tref_p ) + IF (allocated(qref_ens_p )) deallocate (qref_ens_p ) + IF (allocated(tref_ens_p )) deallocate (tref_ens_p ) + ENDDO + ENDIF + ENDIF + + +!############################################################################# +! Calculate ensemble brightness temperature after DA for diagnostic +!############################################################################# + IF (has_DA) THEN + IF (p_is_worker) THEN + IF (DEF_DA_SM_SMAP) THEN + IF (DEF_DA_ENS_NUM > 1) THEN + DO iens = 1, DEF_DA_ENS_NUM + DO np = 1, numpatch + CALL forward(& + patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & + forc_topo(np), htop(np), & + tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & + wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & + snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & + wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & + smap_theta, smap_fghz, & + t_brt_smap_ens(1,iens,np), t_brt_smap_ens(2,iens,np)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF (DEF_DA_SM_FY) THEN + IF (DEF_DA_ENS_NUM > 1) THEN + DO iens = 1, DEF_DA_ENS_NUM + DO np = 1, numpatch + CALL forward(& + patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & + forc_topo(np), htop(np), & + tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & + wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & + snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & + wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & + fy3d_theta, fy3d_fghz, & + t_brt_fy3d_ens(1,iens,np), t_brt_fy3d_ens(2,iens,np)) + ENDDO + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF + +!############################################################################# +! Deallocate all memory +!############################################################################# + IF (allocated (trans)) deallocate (trans) + IF (allocated (obs_err)) deallocate (obs_err) + IF (allocated (filter )) deallocate (filter ) + IF (allocated (wliq_soi_ens)) deallocate (wliq_soi_ens) + IF (allocated (wliq_soi_ens_da)) deallocate (wliq_soi_ens_da) + IF (allocated (t_soi_ens)) deallocate (t_soi_ens) + IF (allocated (t_soi_ens_da)) deallocate (t_soi_ens_da) + + IF (allocated (smap_time)) deallocate (smap_time) + IF (allocated (dt_b_smap)) deallocate (dt_b_smap) + IF (allocated (dt_e_smap)) deallocate (dt_e_smap) + IF (allocated (smap_lat)) deallocate (smap_lat) + IF (allocated (smap_lon)) deallocate (smap_lon) + IF (allocated (smap_tb_h)) deallocate (smap_tb_h) + IF (allocated (smap_tb_v)) deallocate (smap_tb_v) + IF (allocated (smap_ii)) deallocate (smap_ii) + IF (allocated (smap_jj)) deallocate (smap_jj) + IF (allocated (smap_tb_h_mean)) deallocate (smap_tb_h_mean) + IF (allocated (smap_tb_v_mean)) deallocate (smap_tb_v_mean) + IF (allocated (pred_smap_tb_h_mean)) deallocate (pred_smap_tb_h_mean) + IF (allocated (pred_smap_tb_v_mean)) deallocate (pred_smap_tb_v_mean) + IF (allocated (pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) + IF (allocated (pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) + IF (allocated (pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens) + IF (allocated (pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens) + + IF (allocated (fy3d_time)) deallocate (fy3d_time) + IF (allocated (dt_b_fy3d)) deallocate (dt_b_fy3d) + IF (allocated (dt_e_fy3d)) deallocate (dt_e_fy3d) + IF (allocated (fy3d_lat)) deallocate (fy3d_lat) + IF (allocated (fy3d_lon)) deallocate (fy3d_lon) + IF (allocated (fy3d_tb_h)) deallocate (fy3d_tb_h) + IF (allocated (fy3d_tb_v)) deallocate (fy3d_tb_v) + IF (allocated (fy3d_ii)) deallocate (fy3d_ii) + IF (allocated (fy3d_jj)) deallocate (fy3d_jj) + IF (allocated (fy3d_tb_h_mean)) deallocate (fy3d_tb_h_mean) + IF (allocated (fy3d_tb_v_mean)) deallocate (fy3d_tb_v_mean) + IF (allocated (pred_fy3d_tb_h_mean)) deallocate (pred_fy3d_tb_h_mean) + IF (allocated (pred_fy3d_tb_v_mean)) deallocate (pred_fy3d_tb_v_mean) + IF (allocated (pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) + IF (allocated (pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) + IF (allocated (pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens) + IF (allocated (pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens) + + IF (allocated (synop_time)) deallocate (synop_time) + IF (allocated (synop_lat)) deallocate (synop_lat) + IF (allocated (synop_lon)) deallocate (synop_lon) + IF (allocated (synop_qref)) deallocate (synop_qref) + IF (allocated (synop_tref)) deallocate (synop_tref) + IF (allocated (tref_ens_o)) deallocate (tref_ens_o) + IF (allocated (qref_ens_o)) deallocate (qref_ens_o) + + IF (allocated (synop_idx)) deallocate (synop_idx) + IF (allocated (site_id_worker)) deallocate (site_id_worker) + IF (allocated (tref_ens_worker)) deallocate (tref_ens_worker) + IF (allocated (qref_ens_worker)) deallocate (qref_ens_worker) + IF (allocated (qref_ens_o)) deallocate (qref_ens_o) + IF (allocated (tref_ens_o)) deallocate (tref_ens_o) + + + + END SUBROUTINE run_DA_SM + +!----------------------------------------------------------------------------- + + SUBROUTINE end_DA_SM() + +!----------------------------------------------------------------------------- + IMPLICIT NONE + +!----------------------------------------------------------------------------- + IF (allocated (trans)) deallocate (trans) + IF (allocated (obs_err)) deallocate (obs_err) + IF (allocated (filter )) deallocate (filter ) + IF (allocated (wliq_soi_ens)) deallocate (wliq_soi_ens) + IF (allocated (wliq_soi_ens_da)) deallocate (wliq_soi_ens_da) + IF (allocated (t_soi_ens)) deallocate (t_soi_ens) + IF (allocated (t_soi_ens_da)) deallocate (t_soi_ens_da) + + IF (allocated (smap_time)) deallocate (smap_time) + IF (allocated (dt_b_smap)) deallocate (dt_b_smap) + IF (allocated (dt_e_smap)) deallocate (dt_e_smap) + IF (allocated (smap_lat)) deallocate (smap_lat) + IF (allocated (smap_lon)) deallocate (smap_lon) + IF (allocated (smap_tb_h)) deallocate (smap_tb_h) + IF (allocated (smap_tb_v)) deallocate (smap_tb_v) + IF (allocated (smap_ii)) deallocate (smap_ii) + IF (allocated (smap_jj)) deallocate (smap_jj) + IF (allocated (smap_tb_h_mean)) deallocate (smap_tb_h_mean) + IF (allocated (smap_tb_v_mean)) deallocate (smap_tb_v_mean) + IF (allocated (pred_smap_tb_h_mean)) deallocate (pred_smap_tb_h_mean) + IF (allocated (pred_smap_tb_v_mean)) deallocate (pred_smap_tb_v_mean) + IF (allocated (pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) + IF (allocated (pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) + IF (allocated (pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens) + IF (allocated (pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens) + + IF (allocated (fy3d_time)) deallocate (fy3d_time) + IF (allocated (dt_b_fy3d)) deallocate (dt_b_fy3d) + IF (allocated (dt_e_fy3d)) deallocate (dt_e_fy3d) + IF (allocated (fy3d_lat)) deallocate (fy3d_lat) + IF (allocated (fy3d_lon)) deallocate (fy3d_lon) + IF (allocated (fy3d_tb_h)) deallocate (fy3d_tb_h) + IF (allocated (fy3d_tb_v)) deallocate (fy3d_tb_v) + IF (allocated (fy3d_ii)) deallocate (fy3d_ii) + IF (allocated (fy3d_jj)) deallocate (fy3d_jj) + IF (allocated (fy3d_tb_h_mean)) deallocate (fy3d_tb_h_mean) + IF (allocated (fy3d_tb_v_mean)) deallocate (fy3d_tb_v_mean) + IF (allocated (pred_fy3d_tb_h_mean)) deallocate (pred_fy3d_tb_h_mean) + IF (allocated (pred_fy3d_tb_v_mean)) deallocate (pred_fy3d_tb_v_mean) + IF (allocated (pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) + IF (allocated (pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) + IF (allocated (pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens) + IF (allocated (pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens) + + IF (allocated (synop_time)) deallocate (synop_time) + IF (allocated (synop_lat)) deallocate (synop_lat) + IF (allocated (synop_lon)) deallocate (synop_lon) + IF (allocated (synop_qref)) deallocate (synop_qref) + IF (allocated (synop_tref)) deallocate (synop_tref) + IF (allocated (tref_ens_o)) deallocate (tref_ens_o) + IF (allocated (qref_ens_o)) deallocate (qref_ens_o) + + IF (allocated (synop_idx)) deallocate (synop_idx) + IF (allocated (site_id_worker)) deallocate (site_id_worker) + IF (allocated (tref_ens_worker)) deallocate (tref_ens_worker) + IF (allocated (qref_ens_worker)) deallocate (qref_ens_worker) + IF (allocated (qref_ens_o)) deallocate (qref_ens_o) + IF (allocated (tref_ens_o)) deallocate (tref_ens_o) + + + END SUBROUTINE end_DA_SM + +!----------------------------------------------------------------------------- +END MODULE MOD_DA_SM +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 new file mode 100644 index 0000000000..78c7ada569 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 @@ -0,0 +1,440 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_TWS +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Data assimilation of terrestrial water storge from GRACE satellite +! +! AUTHOR: +! Shupeng Zhang: Initial version +!----------------------------------------------------------------------------- + USE MOD_DataType + USE MOD_SpatialMapping + + IMPLICIT NONE + + PUBLIC :: init_DA_GRACE + PUBLIC :: run_DA_GRACE + PUBLIC :: end_DA_GRACE + + real(r8), allocatable, PUBLIC :: fslp_k_mon (:,:) ! slope factor of runoff + real(r8), allocatable, PUBLIC :: fslp_k (:) ! slope factor of runoff + + PRIVATE + + character(len=256) :: file_grace + type(grid_type) :: grid_grace + + real(r8), allocatable :: longrace(:) + real(r8), allocatable :: latgrace(:) + + integer :: nobstime + integer, allocatable :: obsyear (:) + integer, allocatable :: obsmonth (:) + + type (spatial_mapping_type) :: mg2p_grace + + real(r8), allocatable :: lwe_obs_this (:) + real(r8), allocatable :: err_obs_this (:) + + real(r8), allocatable :: lwe_obs_prev (:) + real(r8), allocatable :: err_obs_prev (:) + + real(r8), allocatable :: wat_prev_m (:) + real(r8), allocatable :: wat_this_m (:) + + real(r8), allocatable :: rnof_acc_prev_m (:) + real(r8), allocatable :: rnof_acc_this_m (:) + real(r8), allocatable :: zwt_acc_prev_m (:) + real(r8), allocatable :: zwt_acc_this_m (:) + + real(r8), allocatable :: rnof_prev_m0 (:) + real(r8), allocatable :: rnof_prev_m1 (:) + real(r8), allocatable :: rnof_this_m (:) + + logical, allocatable :: rnofmask (:) + + logical :: has_prev_grace_obs + integer :: nac_grace_this, nac_grace_prev + + integer :: year_prev, month_prev + +CONTAINS + + ! ---------- + SUBROUTINE init_DA_GRACE () + + USE MOD_Spmd_Task + USE MOD_Namelist, only : DEF_DA_obsdir + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_Mesh, only : numelm + USE MOD_LandElm, only : landelm + USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif + USE MOD_Pixelset + USE MOD_Vars_TimeInvariants, only : patchtype + USE MOD_Forcing, only : forcmask_pch + USE MOD_RangeCheck + IMPLICIT NONE + + ! Local Variables + + real(r8), allocatable :: time_real8(:) + integer :: itime + + file_grace = trim(DEF_DA_obsdir) & + // '/GRACE_JPL/GRCTellus.JPL.200204_202207.GLO.RL06M.MSCNv02CRI.nc' + + CALL ncio_read_bcast_serial (file_grace, 'time', time_real8) + + nobstime = size(time_real8) + allocate (obsyear (nobstime)) + allocate (obsmonth(nobstime)) + + DO itime = 1, nobstime + CALL retrieve_yymm_from_days (time_real8(itime), obsyear(itime), obsmonth(itime)) + ENDDO + + IF (p_is_master) THEN + write(*,*) 'Assimilate GRACE data at' + DO itime = 1, nobstime + write(*,*) obsyear(itime), obsmonth(itime) + ENDDO + ENDIF + + CALL ncio_read_bcast_serial (file_grace, 'lon', longrace) + CALL ncio_read_bcast_serial (file_grace, 'lat', latgrace) + + CALL grid_grace%define_by_center (latgrace,longrace) + + CALL mg2p_grace%build_arealweighted (grid_grace, landelm) + + IF (p_is_worker) THEN + IF (numelm > 0) THEN + allocate (lwe_obs_this (numelm)) + allocate (err_obs_this (numelm)) + allocate (lwe_obs_prev (numelm)) + allocate (err_obs_prev (numelm)) + ENDIF + + IF (numpatch > 0) THEN + allocate (wat_prev_m (numpatch)) + allocate (wat_this_m (numpatch)) + allocate (rnof_acc_prev_m (numpatch)) + allocate (rnof_acc_this_m (numpatch)) + allocate (zwt_acc_prev_m (numpatch)) + allocate (zwt_acc_this_m (numpatch)) + allocate (rnof_prev_m0 (numpatch)) + allocate (rnof_prev_m1 (numpatch)) + allocate (rnof_this_m (numpatch)) + allocate (rnofmask (numpatch)) + + allocate (fslp_k_mon (12,numpatch)) + allocate (fslp_k (numpatch)) + ENDIF + ENDIF + + IF (p_is_worker) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + rnofmask = patchtype == 0 + IF (DEF_forcing%has_missing_value) THEN + rnofmask = rnofmask .and. forcmask_pch + ENDIF + ENDIF + ENDIF + + + has_prev_grace_obs = .false. + + nac_grace_this = 0 + nac_grace_prev = 0 + + IF (p_is_worker) THEN + wat_this_m (:) = 0. + rnof_acc_this_m(:) = 0. + rnof_this_m (:) = 0. + zwt_acc_this_m (:) = 0. + fslp_k_mon (:,:) = 1.0 + fslp_k (:) = 1.0 + ENDIF + + deallocate (time_real8) + + END SUBROUTINE init_DA_GRACE + + ! ---------- + SUBROUTINE run_DA_GRACE (idate, deltim) + + USE MOD_Spmd_task + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_Vars_1DFluxes, only : rnof, rsur + USE MOD_Vars_TimeVariables, only : wat, wa, wdsrf, zwt + USE MOD_RangeCheck + USE MOD_UserDefFun + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + + ! Local Variables + logical :: is_obs_time + integer :: month, mday, itime, ielm, istt, iend, nextmonth + + real(r8) :: sumpct + real(r8) :: w1, w0, r1, r0, var_o, var_m, dw_f, dw_o, dw_a, rr, zwt_ave + real(r8) :: fscal, fprev, fthis + + type(block_data_real8_2d) :: f_grace_lwe ! unit: cm + type(block_data_real8_2d) :: f_grace_err ! unit: cm + + character(len=256) :: sid, logfile + + CALL julian2monthday (idate(1), idate(2), month, mday) + + is_obs_time = any((obsyear == idate(1)) .and. (obsmonth == month)) + + IF (p_is_master) THEN + IF (is_obs_time) THEN + write(*,*) 'GRACE at this time.' + ENDIF + ENDIF + + IF (p_is_worker) THEN + + IF (has_prev_grace_obs) THEN + + nac_grace_prev = nac_grace_prev + 1 + + rnof_acc_prev_m = rnof_acc_prev_m + rnof * deltim + IF (is_obs_time) THEN + rnof_prev_m1 = rnof_prev_m1 + rnof_acc_prev_m + ENDIF + + zwt_acc_prev_m = zwt_acc_prev_m + zwt + ENDIF + + IF (is_obs_time) THEN + + nac_grace_this = nac_grace_this + 1 + + wat_this_m = wat_this_m + wat + wa + wdsrf + + rnof_acc_this_m = rnof_acc_this_m + rnof * deltim + rnof_this_m = rnof_this_m + rnof_acc_this_m + + zwt_acc_this_m = zwt_acc_this_m + zwt + ENDIF + + ENDIF + + IF (is_obs_time .and. (isendofmonth(idate, deltim))) THEN + + itime = findloc_ud((obsyear == idate(1)) .and. (obsmonth == month)) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_grace, f_grace_lwe) + CALL allocate_block_data (grid_grace, f_grace_err) + CALL ncio_read_block_time (file_grace, 'lwe_thickness', grid_grace, itime, f_grace_lwe) + CALL ncio_read_block_time (file_grace, 'uncertainty' , grid_grace, itime, f_grace_err) + ENDIF + + CALL mg2p_grace%grid2pset (f_grace_lwe, lwe_obs_this) + CALL mg2p_grace%grid2pset (f_grace_err, err_obs_this) + + IF (p_is_worker) THEN + + lwe_obs_this = lwe_obs_this * 10.0 ! from cm to mm + err_obs_this = err_obs_this * 10.0 ! from cm to mm + + wat_this_m = wat_this_m / nac_grace_this + + zwt_acc_prev_m = zwt_acc_prev_m / nac_grace_prev + + IF (has_prev_grace_obs) THEN + rnof_prev_m1 = rnof_prev_m1 / nac_grace_this + ENDIF + + IF (has_prev_grace_obs .and. & + (((idate(1) == year_prev) .and. (month_prev == month-1)) & + .or. ((idate(1) == year_prev+1) .and. (month_prev == 12) .and. (month == 1)))) & + THEN + + ! write(sid,'(I0)') p_iam_worker + ! logfile = 'log/grace_log_' // trim(sid) // '.txt' + ! open(12, file = trim(logfile), position = 'append') + + DO ielm = 1, numelm + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + + sumpct = sum(elm_patch%subfrc(istt:iend), mask = rnofmask(istt:iend)) + + IF (sumpct <= 0) THEN + CYCLE + ENDIF + + w1 = sum(wat_this_m (istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + w0 = sum(wat_prev_m (istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + r1 = sum(rnof_prev_m1(istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + r0 = sum(rnof_prev_m0(istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + + zwt_ave = sum(zwt_acc_prev_m(istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + + + var_o = err_obs_this(ielm)**2 + err_obs_prev(ielm)**2 + + dw_f = w1 - w0 + dw_o = lwe_obs_this(ielm) - lwe_obs_prev(ielm) + var_m = (dw_f-dw_o)**2 - var_o + + IF (var_m > 0) THEN + + dw_a = (var_o * dw_f + var_m * dw_o) / (var_m+var_o) + + rr = r1 - r0 + + IF (rr > 0) THEN + + fscal = (1-(dw_a-dw_f)/rr) + + ! (2) method 2: one parameters adjusted + fprev = fslp_k_mon(month,istt) + fthis = fprev * fscal + fthis = min(max(fthis, fprev*0.5), fprev*2.0) + fslp_k_mon(month,istt:iend) = fthis + + fprev = fslp_k_mon(month_prev,istt) + fthis = fprev * fscal + fthis = min(max(fthis, fprev*0.5), fprev*2.0) + fslp_k_mon(month_prev,istt:iend) = fthis + + ! write(12,'(I4,I3,I8,8ES11.2)') idate(1), month, landelm%eindex(ielm), & + ! dw_o, sqrt(var_o), dw_f, sqrt(var_m), dw_a, & + ! rr, zwt_ave, fscal + + ENDIF + + ENDIF + + ENDDO + + ! close(12) + ENDIF + + lwe_obs_prev = lwe_obs_this + err_obs_prev = err_obs_this + + wat_prev_m = wat_this_m + wat_this_m = 0. + + rnof_acc_prev_m = rnof_acc_this_m + rnof_acc_this_m = 0. + + zwt_acc_prev_m = zwt_acc_this_m + zwt_acc_this_m = 0. + + rnof_prev_m0 = rnof_this_m / nac_grace_this + rnof_prev_m1 = 0. + rnof_this_m = 0. + + nac_grace_prev = nac_grace_this + nac_grace_this = 0 + + ENDIF + + has_prev_grace_obs = .true. + year_prev = idate(1) + month_prev = month + + ENDIF + + IF (isendofmonth(idate, deltim)) THEN + IF (p_is_worker .and. (numpatch > 0)) THEN + nextmonth = mod(month+1,12)+1 + fslp_k = fslp_k_mon(nextmonth,:) + ENDIF + ENDIF + + + END SUBROUTINE run_DA_GRACE + + ! --------- + SUBROUTINE end_DA_GRACE () + + IMPLICIT NONE + + IF (allocated(lwe_obs_this)) deallocate(lwe_obs_this) + IF (allocated(err_obs_this)) deallocate(err_obs_this) + IF (allocated(lwe_obs_prev)) deallocate(lwe_obs_prev) + IF (allocated(err_obs_prev)) deallocate(err_obs_prev) + IF (allocated(wat_prev_m )) deallocate(wat_prev_m ) + IF (allocated(wat_this_m )) deallocate(wat_this_m ) + IF (allocated(rnof_acc_prev_m)) deallocate(rnof_acc_prev_m) + IF (allocated(rnof_acc_this_m)) deallocate(rnof_acc_this_m) + IF (allocated(rnof_prev_m0 )) deallocate(rnof_prev_m0 ) + IF (allocated(rnof_prev_m1 )) deallocate(rnof_prev_m1 ) + IF (allocated(rnof_this_m )) deallocate(rnof_this_m ) + IF (allocated(rnofmask )) deallocate(rnofmask ) + + IF (allocated(fslp_k_mon)) deallocate(fslp_k_mon) + IF (allocated(fslp_k)) deallocate(fslp_k) + + IF (allocated(longrace)) deallocate(longrace) + IF (allocated(latgrace)) deallocate(latgrace) + + END SUBROUTINE end_DA_GRACE + + ! --------- + SUBROUTINE retrieve_yymm_from_days (days, yy, mm) + + IMPLICIT NONE + real(r8), intent(in) :: days + integer, intent(out) :: yy, mm + + ! Local Variables + real(r8) :: resday + integer :: mdays(12) + + yy = 2002 + mm = 1 + mdays = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) + + resday = days + DO WHILE (resday > mdays(mm)) + + resday = resday - mdays(mm) + + mm = mm + 1 + IF (mm > 12) THEN + yy = yy + 1 + mm = 1 + IF( (mod(yy,4)==0 .and. mod(yy,100)/=0) .or. mod(yy,400)==0 ) THEN + mdays(2) = 29 + ELSE + mdays(2) = 28 + ENDIF + ENDIF + + ENDDO + + END SUBROUTINE retrieve_yymm_from_days + +END MODULE MOD_DA_TWS +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..26854ea42b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 @@ -0,0 +1,92 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_Vars_1DFluxes +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Process fluxes variables for diagnostic for data assimilation +! +! AUTHOR: +! Lu Li, 07/2025: Initial version +!----------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_DA_ENS_NUM + IMPLICIT NONE + SAVE + + ! public functions + PUBLIC :: allocate_1D_DAFluxes + PUBLIC :: deallocate_1D_DAFluxes + + ! define variables + real(r8), allocatable :: fsena_ens (:,:) ! sensible heat from canopy height to atmosphere [W/m2] + real(r8), allocatable :: lfevpa_ens (:,:) ! latent heat flux from canopy height to atmosphere [W/m2] + real(r8), allocatable :: fevpa_ens (:,:) ! evapotranspiration from canopy to atmosphere [mm/s] + real(r8), allocatable :: rsur_ens (:,:) ! surface runoff (mm h2o/s) + + ! save for analysis increment + real(r8), allocatable :: fsena_a (:) ! + real(r8), allocatable :: fevpa_a (:) ! + real(r8), allocatable :: lfevpa_a (:) ! + real(r8), allocatable :: rsur_a (:) ! + +!----------------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE allocate_1D_DAFluxes () + +!----------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch + IMPLICIT NONE + +!----------------------------------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate ( fsena_ens (DEF_DA_ENS_NUM, numpatch) ) ; fsena_ens (:,:) = spval + allocate ( lfevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; lfevpa_ens (:,:) = spval + allocate ( fevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; fevpa_ens (:,:) = spval + allocate ( rsur_ens (DEF_DA_ENS_NUM, numpatch) ) ; rsur_ens (:,:) = spval + + allocate ( fsena_a (numpatch) ) ; fsena_a (:) = spval + allocate ( fevpa_a (numpatch) ) ; fevpa_a (:) = spval + allocate ( lfevpa_a (numpatch) ) ; lfevpa_a (:) = spval + allocate ( rsur_a (numpatch) ) ; rsur_a (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_1D_DAFluxes + +!----------------------------------------------------------------------------- + + SUBROUTINE deallocate_1D_DAFluxes() + +!----------------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPatch + +!----------------------------------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + deallocate ( fsena_ens ) + deallocate ( lfevpa_ens ) + deallocate ( fevpa_ens ) + deallocate ( rsur_ens ) + + deallocate ( fsena_a ) + deallocate ( fevpa_a ) + deallocate ( lfevpa_a ) + deallocate ( rsur_a ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_1D_DAFluxes + +!----------------------------------------------------------------------------- +END MODULE MOD_DA_Vars_1DFluxes +#endif \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..5ae2abecc7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 @@ -0,0 +1,716 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_Vars_TimeVariables +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Process time-varying state variables for data assimilation +! +! AUTHOR: +! Lu Li, 12/2024: Initial version +! Lu Li, 07/2025: Remove unused variables and clean codes +!----------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_DA_ENS_NUM + IMPLICIT NONE + SAVE + + ! public functions + PUBLIC :: allocate_DATimeVariables + PUBLIC :: deallocate_DATimeVariables + PUBLIC :: READ_DATimeVariables + PUBLIC :: WRITE_DATimeVariables +#ifdef RangeCheck + PUBLIC :: check_DATimeVariables +#endif + + ! define variables + ! Time-varying state variables which required by restart run, used to store tha noda trajectory state variable + real(r8), allocatable :: z_sno_noda (:,:) ! node depth [m] + real(r8), allocatable :: dz_sno_noda (:,:) ! interface depth [m] + real(r8), allocatable :: t_soisno_noda (:,:) ! soil temperature [K] + real(r8), allocatable :: wliq_soisno_noda (:,:) ! liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno_noda (:,:) ! ice lens in layers [kg/m2] + real(r8), allocatable :: smp_noda (:,:) ! soil matrix potential [mm] + real(r8), allocatable :: hk_noda (:,:) ! hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: t_grnd_noda (:) ! ground surface temperature [K] + real(r8), allocatable :: tleaf_noda (:) ! leaf temperature [K] + real(r8), allocatable :: ldew_noda (:) ! depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_noda (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_noda (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: fwet_snow_noda (:) ! vegetation snow fractional cover [-] + real(r8), allocatable :: sag_noda (:) ! non dimensional snow age [-] + real(r8), allocatable :: scv_noda (:) ! snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp_noda (:) ! snow depth [meter] + real(r8), allocatable :: fveg_noda (:) ! fraction of vegetation cover + real(r8), allocatable :: fsno_noda (:) ! fraction of snow cover on ground + real(r8), allocatable :: sigf_noda (:) ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: green_noda (:) ! leaf greenness + real(r8), allocatable :: tlai_noda (:) ! leaf area index + real(r8), allocatable :: lai_noda (:) ! leaf area index + real(r8), allocatable :: tsai_noda (:) ! stem area index + real(r8), allocatable :: sai_noda (:) ! stem area index + real(r8), allocatable :: alb_noda (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: ssun_noda (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_noda (:,:,:) ! shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssoi_noda (:,:,:) ! soil absorption for solar radiation (0-1) + real(r8), allocatable :: ssno_noda (:,:,:) ! snow absorption for solar radiation (0-1) + real(r8), allocatable :: thermk_noda (:) ! canopy gap fraction for tir radiation + real(r8), allocatable :: extkb_noda (:) ! (k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd_noda (:) ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), allocatable :: zwt_noda (:) ! the depth to water table [m] + real(r8), allocatable :: wdsrf_noda (:) ! depth of surface water [mm] + real(r8), allocatable :: wa_noda (:) ! water storage in aquifer [mm] + real(r8), allocatable :: wetwat_noda (:) ! water storage in wetland [mm] + real(r8), allocatable :: t_lake_noda (:,:) ! lake layer teperature [K] + real(r8), allocatable :: lake_icefrac_noda(:,:) ! lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1_noda (:) ! top level eddy conductivity (W/m K) + + ! diagnostic variables for RTM forward operator + real(r8), allocatable :: tref_noda (:) ! 2 m height air temperature [kelvin] + real(r8), allocatable :: h2osoi_noda (:,:) ! volumetric soil water in layers [m3/m3] + + ! Time-varying state variables which required by restart run + real(r8), allocatable :: z_sno_ens (:,:,:) ! node depth [m] + real(r8), allocatable :: dz_sno_ens (:,:,:) ! interface depth [m] + real(r8), allocatable :: t_soisno_ens (:,:,:) ! soil temperature [K] + real(r8), allocatable :: wliq_soisno_ens (:,:,:) ! liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno_ens (:,:,:) ! ice lens in layers [kg/m2] + real(r8), allocatable :: smp_ens (:,:,:) ! soil matrix potential [mm] + real(r8), allocatable :: hk_ens (:,:,:) ! hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: t_grnd_ens (:,:) ! ground surface temperature [K] + real(r8), allocatable :: tleaf_ens (:,:) ! leaf temperature [K] + real(r8), allocatable :: ldew_ens (:,:) ! depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_ens (:,:) ! depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_ens (:,:) ! depth of rain on foliage [mm] + real(r8), allocatable :: fwet_snow_ens (:,:) ! vegetation snow fractional cover [-] + real(r8), allocatable :: sag_ens (:,:) ! non dimensional snow age [-] + real(r8), allocatable :: scv_ens (:,:) ! snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp_ens (:,:) ! snow depth [meter] + real(r8), allocatable :: fveg_ens (:,:) ! fraction of vegetation cover + real(r8), allocatable :: fsno_ens (:,:) ! fraction of snow cover on ground + real(r8), allocatable :: sigf_ens (:,:) ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: green_ens (:,:) ! leaf greenness + real(r8), allocatable :: tlai_ens (:,:) ! leaf area index + real(r8), allocatable :: lai_ens (:,:) ! leaf area index + real(r8), allocatable :: tsai_ens (:,:) ! stem area index + real(r8), allocatable :: sai_ens (:,:) ! stem area index + real(r8), allocatable :: alb_ens (:,:,:,:) ! averaged albedo [-] + real(r8), allocatable :: ssun_ens (:,:,:,:) ! sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_ens (:,:,:,:) ! shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssoi_ens (:,:,:,:) ! soil absorption for solar radiation (0-1) + real(r8), allocatable :: ssno_ens (:,:,:,:) ! snow absorption for solar radiation (0-1) + real(r8), allocatable :: thermk_ens (:,:) ! canopy gap fraction for tir radiation + real(r8), allocatable :: extkb_ens (:,:) ! (k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd_ens (:,:) ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), allocatable :: zwt_ens (:,:) ! the depth to water table [m] + real(r8), allocatable :: wdsrf_ens (:,:) ! depth of surface water [mm] + real(r8), allocatable :: wa_ens (:,:) ! water storage in aquifer [mm] + real(r8), allocatable :: wetwat_ens (:,:) ! water storage in wetland [mm] + real(r8), allocatable :: t_lake_ens (:,:,:) ! lake layer teperature [K] + real(r8), allocatable :: lake_icefrac_ens(:,:,:) ! lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1_ens (:,:) ! top level eddy conductivity (W/m K) + + ! diagnostic variables for DA + real(r8), allocatable :: h2osoi_ens (:,:,:) ! volumetric soil water in layers [m3/m3] + real(r8), allocatable :: t_brt_smap_ens (:,:,:) ! brightness temperature for radiance calculation [K] + real(r8), allocatable :: t_brt_fy3d_ens (:,:,:) ! brightness temperature for radiance calculation [K] + real(r8), allocatable :: t_brt_smap (:,:) ! brightness temperature for radiance calculation [K] + real(r8), allocatable :: t_brt_fy3d (:,:) ! brightness temperature for radiance calculation [K] + real(r8), allocatable :: trad_ens (:,:) ! radiative temperature of surface [K] + real(r8), allocatable :: tref_ens (:,:) ! 2 m height air temperature [kelvin] + real(r8), allocatable :: qref_ens (:,:) ! 2 m height air specific humidity + real(r8), allocatable :: rhref_ens (:,:) ! 2 m height air relative humidity + real(r8), allocatable :: ustar_ens (:,:) ! u* in similarity theory [m/s] + real(r8), allocatable :: qstar_ens (:,:) ! q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar_ens (:,:) ! t* in similarity theory [K] + real(r8), allocatable :: fm_ens (:,:) ! integral of profile FUNCTION for momentum + real(r8), allocatable :: fh_ens (:,:) ! integral of profile FUNCTION for heat + real(r8), allocatable :: fq_ens (:,:) ! integral of profile FUNCTION for moisture + + ! ensemble forcing variables used for ensemble DA + real(r8), allocatable :: forc_t_ens (:,:) ! temperature [K] + real(r8), allocatable :: forc_frl_ens (:,:) ! atmospheric infrared (longwave) radiation [W/m2] + real(r8), allocatable :: forc_prc_ens (:,:) ! convective precipitation [mm/s] + real(r8), allocatable :: forc_prl_ens (:,:) ! large scale precipitation [mm/s] + real(r8), allocatable :: forc_sols_ens (:,:) ! atm vis direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_soll_ens (:,:) ! atm nir direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solsd_ens (:,:) ! atm vis diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solld_ens (:,:) ! atm nir diffuse solar rad onto srf [W/m2] + + ! save for analysis increment + real(r8), allocatable :: t_soisno_a (:,:) ! + real(r8), allocatable :: wliq_soisno_a (:,:) ! + real(r8), allocatable :: wice_soisno_a (:,:) ! + real(r8), allocatable :: t_grnd_a (:) ! + real(r8), allocatable :: tleaf_a (:) ! + real(r8), allocatable :: snowdp_a (:) ! + real(r8), allocatable :: h2osoi_a (:,:) ! + real(r8), allocatable :: t_brt_smap_a (:,:) ! + real(r8), allocatable :: t_brt_fy3d_a (:,:) ! + real(r8), allocatable :: trad_a (:) ! + real(r8), allocatable :: tref_a (:) ! + real(r8), allocatable :: qref_a (:) ! + real(r8), allocatable :: ustar_a (:) ! + real(r8), allocatable :: qstar_a (:) ! + real(r8), allocatable :: tstar_a (:) ! + real(r8), allocatable :: fm_a (:) ! + real(r8), allocatable :: fh_a (:) ! + real(r8), allocatable :: fq_a (:) ! + +!----------------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE allocate_DATimeVariables() + +!----------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + +!----------------------------------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (z_sno_noda (maxsnl+1:0, numpatch)); z_sno_noda (:,:) = spval + allocate (dz_sno_noda (maxsnl+1:0, numpatch)); dz_sno_noda (:,:) = spval + allocate (t_soisno_noda (maxsnl+1:nl_soil,numpatch)); t_soisno_noda (:,:) = spval + allocate (wliq_soisno_noda(maxsnl+1:nl_soil,numpatch)); wliq_soisno_noda (:,:) = spval + allocate (wice_soisno_noda(maxsnl+1:nl_soil,numpatch)); wice_soisno_noda (:,:) = spval + allocate (smp_noda (1:nl_soil,numpatch)); smp_noda (:,:) = spval + allocate (hk_noda (1:nl_soil,numpatch)); hk_noda (:,:) = spval + allocate (t_grnd_noda (numpatch)); t_grnd_noda (:) = spval + allocate (tleaf_noda (numpatch)); tleaf_noda (:) = spval + allocate (ldew_noda (numpatch)); ldew_noda (:) = spval + allocate (ldew_rain_noda (numpatch)); ldew_rain_noda (:) = spval + allocate (ldew_snow_noda (numpatch)); ldew_snow_noda (:) = spval + allocate (fwet_snow_noda (numpatch)); fwet_snow_noda (:) = spval + allocate (sag_noda (numpatch)); sag_noda (:) = spval + allocate (scv_noda (numpatch)); scv_noda (:) = spval + allocate (snowdp_noda (numpatch)); snowdp_noda (:) = spval + allocate (fveg_noda (numpatch)); fveg_noda (:) = spval + allocate (fsno_noda (numpatch)); fsno_noda (:) = spval + allocate (sigf_noda (numpatch)); sigf_noda (:) = spval + allocate (green_noda (numpatch)); green_noda (:) = spval + allocate (tlai_noda (numpatch)); tlai_noda (:) = spval + allocate (lai_noda (numpatch)); lai_noda (:) = spval + allocate (tsai_noda (numpatch)); tsai_noda (:) = spval + allocate (sai_noda (numpatch)); sai_noda (:) = spval + allocate (alb_noda (2,2,numpatch)); alb_noda (:,:,:) = spval + allocate (ssun_noda (2,2,numpatch)); ssun_noda (:,:,:) = spval + allocate (ssha_noda (2,2,numpatch)); ssha_noda (:,:,:) = spval + allocate (ssoi_noda (2,2,numpatch)); ssoi_noda (:,:,:) = spval + allocate (ssno_noda (2,2,numpatch)); ssno_noda (:,:,:) = spval + allocate (thermk_noda (numpatch)); thermk_noda (:) = spval + allocate (extkb_noda (numpatch)); extkb_noda (:) = spval + allocate (extkd_noda (numpatch)); extkd_noda (:) = spval + allocate (zwt_noda (numpatch)); zwt_noda (:) = spval + allocate (wdsrf_noda (numpatch)); wdsrf_noda (:) = spval + allocate (wa_noda (numpatch)); wa_noda (:) = spval + allocate (wetwat_noda (numpatch)); wetwat_noda (:) = spval + allocate (t_lake_noda (nl_lake,numpatch)); t_lake_noda (:,:) = spval + allocate (lake_icefrac_noda (nl_lake,numpatch)); lake_icefrac_noda(:,:) = spval + allocate (savedtke1_noda (numpatch)); savedtke1_noda (:) = spval + + ! diagnostic variables for DA + allocate (h2osoi_noda (1:nl_soil,numpatch)); h2osoi_noda (:,:) = spval + allocate (tref_noda (numpatch)); tref_noda (:) = spval + + ! allocate all time-varying state variables + allocate (z_sno_ens (maxsnl+1:0, DEF_DA_ENS_NUM,numpatch)); z_sno_ens (:,:,:) = spval + allocate (dz_sno_ens (maxsnl+1:0, DEF_DA_ENS_NUM,numpatch)); dz_sno_ens (:,:,:) = spval + allocate (t_soisno_ens (maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); t_soisno_ens (:,:,:) = spval + allocate (wliq_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); wliq_soisno_ens (:,:,:) = spval + allocate (wice_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); wice_soisno_ens (:,:,:) = spval + allocate (smp_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); smp_ens (:,:,:) = spval + allocate (hk_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); hk_ens (:,:,:) = spval + allocate (t_grnd_ens (DEF_DA_ENS_NUM,numpatch)); t_grnd_ens (:,:) = spval + allocate (tleaf_ens (DEF_DA_ENS_NUM,numpatch)); tleaf_ens (:,:) = spval + allocate (ldew_ens (DEF_DA_ENS_NUM,numpatch)); ldew_ens (:,:) = spval + allocate (ldew_rain_ens (DEF_DA_ENS_NUM,numpatch)); ldew_rain_ens (:,:) = spval + allocate (ldew_snow_ens (DEF_DA_ENS_NUM,numpatch)); ldew_snow_ens (:,:) = spval + allocate (fwet_snow_ens (DEF_DA_ENS_NUM,numpatch)); fwet_snow_ens (:,:) = spval + allocate (sag_ens (DEF_DA_ENS_NUM,numpatch)); sag_ens (:,:) = spval + allocate (scv_ens (DEF_DA_ENS_NUM,numpatch)); scv_ens (:,:) = spval + allocate (snowdp_ens (DEF_DA_ENS_NUM,numpatch)); snowdp_ens (:,:) = spval + allocate (fveg_ens (DEF_DA_ENS_NUM,numpatch)); fveg_ens (:,:) = spval + allocate (fsno_ens (DEF_DA_ENS_NUM,numpatch)); fsno_ens (:,:) = spval + allocate (sigf_ens (DEF_DA_ENS_NUM,numpatch)); sigf_ens (:,:) = spval + allocate (green_ens (DEF_DA_ENS_NUM,numpatch)); green_ens (:,:) = spval + allocate (tlai_ens (DEF_DA_ENS_NUM,numpatch)); tlai_ens (:,:) = spval + allocate (lai_ens (DEF_DA_ENS_NUM,numpatch)); lai_ens (:,:) = spval + allocate (tsai_ens (DEF_DA_ENS_NUM,numpatch)); tsai_ens (:,:) = spval + allocate (sai_ens (DEF_DA_ENS_NUM,numpatch)); sai_ens (:,:) = spval + allocate (alb_ens (2,2,DEF_DA_ENS_NUM,numpatch)); alb_ens (:,:,:,:) = spval + allocate (ssun_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssun_ens (:,:,:,:) = spval + allocate (ssha_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssha_ens (:,:,:,:) = spval + allocate (ssoi_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssoi_ens (:,:,:,:) = spval + allocate (ssno_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssno_ens (:,:,:,:) = spval + allocate (thermk_ens (DEF_DA_ENS_NUM,numpatch)); thermk_ens (:,:) = spval + allocate (extkb_ens (DEF_DA_ENS_NUM,numpatch)); extkb_ens (:,:) = spval + allocate (extkd_ens (DEF_DA_ENS_NUM,numpatch)); extkd_ens (:,:) = spval + allocate (zwt_ens (DEF_DA_ENS_NUM,numpatch)); zwt_ens (:,:) = spval + allocate (wdsrf_ens (DEF_DA_ENS_NUM,numpatch)); wdsrf_ens (:,:) = spval + allocate (wa_ens (DEF_DA_ENS_NUM,numpatch)); wa_ens (:,:) = spval + allocate (wetwat_ens (DEF_DA_ENS_NUM,numpatch)); wetwat_ens (:,:) = spval + allocate (t_lake_ens (nl_lake,DEF_DA_ENS_NUM,numpatch)); t_lake_ens (:,:,:) = spval + allocate (lake_icefrac_ens (nl_lake,DEF_DA_ENS_NUM,numpatch)); lake_icefrac_ens(:,:,:) = spval + allocate (savedtke1_ens (DEF_DA_ENS_NUM,numpatch)); savedtke1_ens (:,:) = spval + + ! diagnostic variables for DA + allocate (h2osoi_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); h2osoi_ens (:,:,:) = spval + allocate (t_brt_smap_ens (2,DEF_DA_ENS_NUM,numpatch)); t_brt_smap_ens (:,:,:) = spval + allocate (t_brt_fy3d_ens (2,DEF_DA_ENS_NUM,numpatch)); t_brt_fy3d_ens (:,:,:) = spval + allocate (t_brt_smap (2,numpatch)); t_brt_smap (:,:) = spval + allocate (t_brt_fy3d (2,numpatch)); t_brt_fy3d (:,:) = spval + allocate (trad_ens (DEF_DA_ENS_NUM,numpatch)); trad_ens (:,:) = spval + allocate (tref_ens (DEF_DA_ENS_NUM,numpatch)); tref_ens (:,:) = spval + allocate (qref_ens (DEF_DA_ENS_NUM,numpatch)); qref_ens (:,:) = spval + allocate (rhref_ens (DEF_DA_ENS_NUM,numpatch)); rhref_ens (:,:) = spval + allocate (ustar_ens (DEF_DA_ENS_NUM,numpatch)); ustar_ens (:,:) = spval + allocate (qstar_ens (DEF_DA_ENS_NUM,numpatch)); qstar_ens (:,:) = spval + allocate (tstar_ens (DEF_DA_ENS_NUM,numpatch)); tstar_ens (:,:) = spval + allocate (fm_ens (DEF_DA_ENS_NUM,numpatch)); fm_ens (:,:) = spval + allocate (fh_ens (DEF_DA_ENS_NUM,numpatch)); fh_ens (:,:) = spval + allocate (fq_ens (DEF_DA_ENS_NUM,numpatch)); fq_ens (:,:) = spval + + ! ensemble forcing variables used for ensemble DA + allocate (forc_t_ens (DEF_DA_ENS_NUM,numpatch)); forc_t_ens (:,:) = spval + allocate (forc_frl_ens (DEF_DA_ENS_NUM,numpatch)); forc_frl_ens (:,:) = spval + allocate (forc_prc_ens (DEF_DA_ENS_NUM,numpatch)); forc_prc_ens (:,:) = spval + allocate (forc_prl_ens (DEF_DA_ENS_NUM,numpatch)); forc_prl_ens (:,:) = spval + allocate (forc_sols_ens (DEF_DA_ENS_NUM,numpatch)); forc_sols_ens (:,:) = spval + allocate (forc_soll_ens (DEF_DA_ENS_NUM,numpatch)); forc_soll_ens (:,:) = spval + allocate (forc_solsd_ens (DEF_DA_ENS_NUM,numpatch)); forc_solsd_ens (:,:) = spval + allocate (forc_solld_ens (DEF_DA_ENS_NUM,numpatch)); forc_solld_ens (:,:) = spval + + ! allocate variables for analysis increment + allocate (t_soisno_a (maxsnl+1:nl_soil,numpatch)); t_soisno_a (:,:) = spval + allocate (wliq_soisno_a (maxsnl+1:nl_soil,numpatch)); wliq_soisno_a (:,:) = spval + allocate (wice_soisno_a (maxsnl+1:nl_soil,numpatch)); wice_soisno_a (:,:) = spval + allocate (t_grnd_a (numpatch)); t_grnd_a (:) = spval + allocate (tleaf_a (numpatch)); tleaf_a (:) = spval + allocate (snowdp_a (numpatch)); snowdp_a (:) = spval + allocate (h2osoi_a (1:nl_soil,numpatch)); h2osoi_a (:,:) = spval + allocate (t_brt_smap_a (2,numpatch)); t_brt_smap_a (:,:) = spval + allocate (t_brt_fy3d_a (2,numpatch)); t_brt_fy3d_a (:,:) = spval + + allocate (trad_a (numpatch)); trad_a (:) = spval + allocate (tref_a (numpatch)); tref_a (:) = spval + allocate (qref_a (numpatch)); qref_a (:) = spval + allocate (ustar_a (numpatch)); ustar_a (:) = spval + allocate (qstar_a (numpatch)); qstar_a (:) = spval + allocate (tstar_a (numpatch)); tstar_a (:) = spval + allocate (fm_a (numpatch)); fm_a (:) = spval + allocate (fh_a (numpatch)); fh_a (:) = spval + allocate (fq_a (numpatch)); fq_a (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_DATimeVariables + +!----------------------------------------------------------------------------- + + SUBROUTINE deallocate_DATimeVariables() + +!----------------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + +!----------------------------------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + deallocate (z_sno_noda ) + deallocate (dz_sno_noda ) + deallocate (t_soisno_noda ) + deallocate (wliq_soisno_noda ) + deallocate (wice_soisno_noda ) + deallocate (smp_noda ) + deallocate (hk_noda ) + deallocate (t_grnd_noda ) + deallocate (tleaf_noda ) + deallocate (ldew_noda ) + deallocate (ldew_rain_noda ) + deallocate (ldew_snow_noda ) + deallocate (fwet_snow_noda ) + deallocate (sag_noda ) + deallocate (scv_noda ) + deallocate (snowdp_noda ) + deallocate (fveg_noda ) + deallocate (fsno_noda ) + deallocate (sigf_noda ) + deallocate (green_noda ) + deallocate (tlai_noda ) + deallocate (lai_noda ) + deallocate (tsai_noda ) + deallocate (sai_noda ) + deallocate (alb_noda ) + deallocate (ssun_noda ) + deallocate (ssha_noda ) + deallocate (ssoi_noda ) + deallocate (ssno_noda ) + deallocate (thermk_noda ) + deallocate (extkb_noda ) + deallocate (extkd_noda ) + deallocate (zwt_noda ) + deallocate (wdsrf_noda ) + deallocate (wa_noda ) + deallocate (wetwat_noda ) + deallocate (t_lake_noda ) + deallocate (lake_icefrac_noda ) + deallocate (savedtke1_noda ) + + deallocate (tref_noda ) + deallocate (h2osoi_noda ) + + deallocate (z_sno_ens ) + deallocate (dz_sno_ens ) + deallocate (t_soisno_ens ) + deallocate (wliq_soisno_ens ) + deallocate (wice_soisno_ens ) + deallocate (smp_ens ) + deallocate (hk_ens ) + deallocate (t_grnd_ens ) + deallocate (tleaf_ens ) + deallocate (ldew_ens ) + deallocate (ldew_rain_ens ) + deallocate (ldew_snow_ens ) + deallocate (fwet_snow_ens ) + deallocate (sag_ens ) + deallocate (scv_ens ) + deallocate (snowdp_ens ) + deallocate (fveg_ens ) + deallocate (fsno_ens ) + deallocate (sigf_ens ) + deallocate (green_ens ) + deallocate (tlai_ens ) + deallocate (lai_ens ) + deallocate (tsai_ens ) + deallocate (sai_ens ) + deallocate (alb_ens ) + deallocate (ssun_ens ) + deallocate (ssha_ens ) + deallocate (ssoi_ens ) + deallocate (ssno_ens ) + deallocate (thermk_ens ) + deallocate (extkb_ens ) + deallocate (extkd_ens ) + deallocate (zwt_ens ) + deallocate (wdsrf_ens ) + deallocate (wa_ens ) + deallocate (wetwat_ens ) + deallocate (t_lake_ens ) + deallocate (lake_icefrac_ens ) + deallocate (savedtke1_ens ) + + deallocate (h2osoi_ens ) + deallocate (t_brt_smap_ens ) + deallocate (t_brt_fy3d_ens ) + deallocate (t_brt_smap ) + deallocate (t_brt_fy3d ) + deallocate (trad_ens ) + deallocate (tref_ens ) + deallocate (qref_ens ) + deallocate (rhref_ens ) + deallocate (ustar_ens ) + deallocate (qstar_ens ) + deallocate (tstar_ens ) + deallocate (fm_ens ) + deallocate (fh_ens ) + deallocate (fq_ens ) + + deallocate (forc_t_ens ) + deallocate (forc_frl_ens ) + deallocate (forc_prc_ens ) + deallocate (forc_prl_ens ) + deallocate (forc_sols_ens ) + deallocate (forc_soll_ens ) + deallocate (forc_solsd_ens ) + deallocate (forc_solld_ens ) + + deallocate (t_soisno_a ) + deallocate (wliq_soisno_a ) + deallocate (wice_soisno_a ) + deallocate (t_grnd_a ) + deallocate (tleaf_a ) + deallocate (snowdp_a ) + deallocate (h2osoi_a ) + deallocate (t_brt_smap_a ) + deallocate (t_brt_fy3d_a ) + deallocate (trad_a ) + deallocate (tref_a ) + deallocate (qref_a ) + deallocate (ustar_a ) + deallocate (qstar_a ) + deallocate (tstar_a ) + deallocate (fm_a ) + deallocate (fh_a ) + deallocate (fq_a ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_DATimeVariables + +!----------------------------------------------------------------------------- + + SUBROUTINE WRITE_DATimeVariables (idate, lc_year, site, dir_restart) + +!----------------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_Namelist, only : DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION, DEF_USE_Dynamic_Lake + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + +!------------------------ Dummy Arguments ------------------------------------ + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year ! year of land cover type data + character(len=*), intent(in) :: site + character(len=*), intent(in) :: dir_restart + +!------------------------ Local Variables ------------------------------------ + character(len=256) :: file_restart + character(len=14) :: cdate + character(len=256) :: cyear ! character for lc_year + integer :: compress + integer :: i + +!----------------------------------------------------------------------------- + compress = DEF_REST_CompressLevel + + ! land cover type year + write(cyear,'(i4.4)') lc_year + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_DA_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + + CALL ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'ens', DEF_DA_ENS_NUM) + + ! Time-varying state variables which reaquired by restart run + CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, z_sno_ens, compress) ! node depth [m] + CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, dz_sno_ens, compress) ! interface depth [m] + CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_soisno_ens, compress) ! soil temperature [K] + CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wliq_soisno_ens, compress) ! liquid water in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wice_soisno_ens, compress) ! ice lens in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, smp_ens, compress) ! soil matrix potential [mm] + CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, hk_ens, compress) ! hydraulic conductivity [mm h2o/s] + CALL ncio_write_vector (file_restart, 't_grnd', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_grnd_ens, compress) ! ground surface temperature [K] + CALL ncio_write_vector (file_restart, 'tleaf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tleaf_ens, compress) ! leaf temperature [K] + CALL ncio_write_vector (file_restart, 'ldew', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_ens, compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_rain', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_rain_ens, compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_snow', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_snow_ens, compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'fwet_snow', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fwet_snow_ens, compress) ! vegetation snow fractional cover [-] + CALL ncio_write_vector (file_restart, 'sag', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sag_ens, compress) ! non dimensional snow age [-] + CALL ncio_write_vector (file_restart, 'scv', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, scv_ens, compress) ! snow cover, water equivalent [mm] + CALL ncio_write_vector (file_restart, 'snowdp', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, snowdp_ens, compress) ! snow depth [meter] + CALL ncio_write_vector (file_restart, 'fveg', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fveg_ens, compress) ! fraction of vegetation cover + CALL ncio_write_vector (file_restart, 'fsno', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fsno_ens, compress) ! fraction of snow cover on ground + CALL ncio_write_vector (file_restart, 'sigf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sigf_ens, compress) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_write_vector (file_restart, 'green', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, green_ens, compress) ! leaf greenness + CALL ncio_write_vector (file_restart, 'tlai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tlai_ens, compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'lai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, lai_ens, compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'tsai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tsai_ens, compress) ! stem area index + CALL ncio_write_vector (file_restart, 'sai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sai_ens, compress) ! stem area index + CALL ncio_write_vector (file_restart, 'alb', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, alb_ens, compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'ssun', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssun_ens, compress) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssha', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssha_ens, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssoi', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssoi_ens, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssno', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssno_ens, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'thermk', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, thermk_ens, compress) ! canopy gap fraction for tir radiation + CALL ncio_write_vector (file_restart, 'extkb', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, extkb_ens, compress) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_write_vector (file_restart, 'extkd', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, extkd_ens, compress) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_write_vector (file_restart, 'zwt', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, zwt_ens, compress) ! the depth to water table [m] + CALL ncio_write_vector (file_restart, 'wdsrf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wdsrf_ens, compress) ! depth of surface water [mm] + CALL ncio_write_vector (file_restart, 'wa', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wa_ens, compress) ! water storage in aquifer [mm] + CALL ncio_write_vector (file_restart, 'wetwat', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wetwat_ens, compress) ! water storage in wetland [mm] + CALL ncio_write_vector (file_restart, 't_lake', 'lake', nl_lake, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_lake_ens, compress) + CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, lake_icefrac_ens, compress) + CALL ncio_write_vector (file_restart, 'savedtke1', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, savedtke1_ens, compress) + + END SUBROUTINE WRITE_DATimeVariables + +!----------------------------------------------------------------------------- + + SUBROUTINE READ_DATimeVariables (idate, lc_year, site, dir_restart) + +!----------------------------------------------------------------------------- + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + IMPLICIT NONE + +!------------------------ Dummy Arguments ------------------------------------ + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(len=*), intent(in) :: site + character(len=*), intent(in) :: dir_restart + +!------------------------ Local Variables ------------------------------------ + character(len=256) :: file_restart + character(len=14) :: cdate, cyear + +!----------------------------------------------------------------------------- +#ifdef USEMPI + CALL mpi_barrier(p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write (*, *) 'Loading DA Time Variables ...' + END IF + + ! land cover type year + write (cyear, '(i4.4)') lc_year + + write (cdate, '(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + file_restart = trim(dir_restart)//'/'//trim(cdate)//'/'//trim(site)//'_restart_DA_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + + ! Time-varying state variables which reaquired by restart run + CALL ncio_read_vector(file_restart, 'z_sno ', -maxsnl, DEF_DA_ENS_NUM, landpatch, z_sno_ens) ! node depth [m] + CALL ncio_read_vector(file_restart, 'dz_sno ', -maxsnl, DEF_DA_ENS_NUM, landpatch, dz_sno_ens) ! interface depth [m] + CALL ncio_read_vector(file_restart, 't_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, t_soisno_ens) ! soil temperature [K] + CALL ncio_read_vector(file_restart, 'wliq_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, wliq_soisno_ens)! liquid water in layers [kg/m2] + CALL ncio_read_vector(file_restart, 'wice_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, wice_soisno_ens)! ice lens in layers [kg/m2] + CALL ncio_read_vector(file_restart, 'smp', nl_soil, DEF_DA_ENS_NUM, landpatch, smp_ens) ! soil matrix potential [mm] + CALL ncio_read_vector(file_restart, 'hk', nl_soil, DEF_DA_ENS_NUM, landpatch, hk_ens) ! hydraulic conductivity [mm h2o/s] + CALL ncio_read_vector(file_restart, 't_grnd ', DEF_DA_ENS_NUM, landpatch, t_grnd_ens) ! ground surface temperature [K] + CALL ncio_read_vector(file_restart, 'tleaf ', DEF_DA_ENS_NUM, landpatch, tleaf_ens) ! leaf temperature [K] + CALL ncio_read_vector(file_restart, 'ldew ', DEF_DA_ENS_NUM, landpatch, ldew_ens) ! depth of water on foliage [mm] + CALL ncio_read_vector(file_restart, 'ldew_rain', DEF_DA_ENS_NUM, landpatch, ldew_rain_ens) ! depth of water on foliage [mm] + CALL ncio_read_vector(file_restart, 'ldew_snow', DEF_DA_ENS_NUM, landpatch, ldew_snow_ens) ! depth of water on foliage [mm] + CALL ncio_read_vector(file_restart, 'fwet_snow', DEF_DA_ENS_NUM, landpatch, fwet_snow_ens) ! vegetation snow fractional cover [-] + CALL ncio_read_vector(file_restart, 'sag ', DEF_DA_ENS_NUM, landpatch, sag_ens) ! non dimensional snow age [-] + CALL ncio_read_vector(file_restart, 'scv ', DEF_DA_ENS_NUM, landpatch, scv_ens) ! snow cover, water equivalent [mm] + CALL ncio_read_vector(file_restart, 'snowdp ', DEF_DA_ENS_NUM, landpatch, snowdp_ens) ! snow depth [meter] + CALL ncio_read_vector(file_restart, 'fveg ', DEF_DA_ENS_NUM, landpatch, fveg_ens) ! fraction of vegetation cover + CALL ncio_read_vector(file_restart, 'fsno ', DEF_DA_ENS_NUM, landpatch, fsno_ens) ! fraction of snow cover on ground + CALL ncio_read_vector(file_restart, 'sigf ', DEF_DA_ENS_NUM, landpatch, sigf_ens) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_read_vector(file_restart, 'green ', DEF_DA_ENS_NUM, landpatch, green_ens) ! leaf greenness + CALL ncio_read_vector(file_restart, 'lai ', DEF_DA_ENS_NUM, landpatch, lai_ens) ! leaf area index + CALL ncio_read_vector(file_restart, 'tlai ', DEF_DA_ENS_NUM, landpatch, tlai_ens) ! leaf area index + CALL ncio_read_vector(file_restart, 'sai ', DEF_DA_ENS_NUM, landpatch, sai_ens) ! stem area index + CALL ncio_read_vector(file_restart, 'tsai ', DEF_DA_ENS_NUM, landpatch, tsai_ens) ! stem area index + CALL ncio_read_vector(file_restart, 'alb ', 2, 2, DEF_DA_ENS_NUM, landpatch, alb_ens) ! averaged albedo [-] + CALL ncio_read_vector(file_restart, 'ssun ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssun_ens) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_read_vector(file_restart, 'ssha ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssha_ens) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_read_vector(file_restart, 'ssoi ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssoi_ens) ! soil absorption for solar radiation (0-1) + CALL ncio_read_vector(file_restart, 'ssno ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssno_ens) ! snow absorption for solar radiation (0-1) + CALL ncio_read_vector(file_restart, 'thermk ', DEF_DA_ENS_NUM, landpatch, thermk_ens) ! canopy gap fraction for tir radiation + CALL ncio_read_vector(file_restart, 'extkb ', DEF_DA_ENS_NUM, landpatch, extkb_ens) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_read_vector(file_restart, 'extkd ', DEF_DA_ENS_NUM, landpatch, extkd_ens) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_read_vector(file_restart, 'zwt ', DEF_DA_ENS_NUM, landpatch, zwt_ens) ! the depth to water table [m] + CALL ncio_read_vector(file_restart, 'wdsrf ', DEF_DA_ENS_NUM, landpatch, wdsrf_ens) ! depth of surface water [mm] + CALL ncio_read_vector(file_restart, 'wa ', DEF_DA_ENS_NUM, landpatch, wa_ens) ! water storage in aquifer [mm] + CALL ncio_read_vector(file_restart, 'wetwat ', DEF_DA_ENS_NUM, landpatch, wetwat_ens) ! water storage in wetland [mm] + CALL ncio_read_vector(file_restart, 't_lake ', nl_lake, DEF_DA_ENS_NUM, landpatch, t_lake_ens) ! lake temperature [K] + CALL ncio_read_vector(file_restart, 'lake_icefrc', nl_lake, DEF_DA_ENS_NUM, landpatch, lake_icefrac_ens) ! lake ice fraction [-] + CALL ncio_read_vector(file_restart, 'savedtke1 ', DEF_DA_ENS_NUM, landpatch, savedtke1_ens) ! saved tke1 [m2/s2] + +#ifdef RangeCheck + CALL check_DATimeVariables +#endif + + IF (p_is_master) THEN + write (*, *) 'Loading DA Time Variables done.' + END IF + + END SUBROUTINE READ_DATimeVariables + +#ifdef RangeCheck +!----------------------------------------------------------------------- + + SUBROUTINE check_DATimeVariables () + +!----------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & + DEF_USE_SNICAR, DEF_USE_Dynamic_Lake + IMPLICIT NONE + +#ifdef USEMPI + CALL mpi_barrier(p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write (*, *) 'Checking DA Time Variables ...' + END IF + + CALL check_vector_data ('z_sno [m] ', z_sno_ens ) ! node depth [m] + CALL check_vector_data ('dz_sno [m] ', dz_sno_ens ) ! interface depth [m] + CALL check_vector_data ('t_soisno [K] ', t_soisno_ens ) ! soil temperature [K] + CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno_ens ) ! liquid water in layers [kg/m2] + CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno_ens ) ! ice lens in layers [kg/m2] + CALL check_vector_data ('smp [mm] ', smp_ens ) ! soil matrix potential [mm] + CALL check_vector_data ('hk [mm/s] ', hk_ens ) ! hydraulic conductivity [mm h2o/s] + CALL check_vector_data ('t_grnd [K] ', t_grnd_ens ) ! ground surface temperature [K] + CALL check_vector_data ('tleaf [K] ', tleaf_ens ) ! leaf temperature [K] + CALL check_vector_data ('ldew [mm] ', ldew_ens ) ! depth of water on foliage [mm] + CALL check_vector_data ('ldew_rain [mm] ', ldew_rain_ens ) ! depth of rain on foliage [mm] + CALL check_vector_data ('ldew_snow [mm] ', ldew_snow_ens ) ! depth of snow on foliage [mm] + CALL check_vector_data ('fwet_snow [mm] ', fwet_snow_ens ) ! vegetation snow fractional cover [-] + CALL check_vector_data ('sag [-] ', sag_ens ) ! non dimensional snow age [-] + CALL check_vector_data ('scv [mm] ', scv_ens ) ! snow cover, water equivalent [mm] + CALL check_vector_data ('snowdp [m] ', snowdp_ens ) ! snow depth [meter] + CALL check_vector_data ('fveg [-] ', fveg_ens ) ! fraction of vegetation cover + CALL check_vector_data ('fsno [-] ', fsno_ens ) ! fraction of snow cover on ground + CALL check_vector_data ('sigf [-] ', sigf_ens ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL check_vector_data ('green [-] ', green_ens ) ! leaf greenness + CALL check_vector_data ('lai [-] ', lai_ens ) ! leaf area index + CALL check_vector_data ('tlai [-] ', tlai_ens ) ! leaf area index + CALL check_vector_data ('sai [-] ', sai_ens ) ! stem area index + CALL check_vector_data ('tsai [-] ', tsai_ens ) ! stem area index + CALL check_vector_data ('alb [-] ', alb_ens ) ! averaged albedo [-] + CALL check_vector_data ('ssun [-] ', ssun_ens ) ! sunlit canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssha [-] ', ssha_ens ) ! shaded canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssoi [-] ', ssoi_ens ) ! soil absorption for solar radiation (0-1) + CALL check_vector_data ('ssno [-] ', ssno_ens ) ! snow absorption for solar radiation (0-1) + CALL check_vector_data ('thermk [-] ', thermk_ens ) ! canopy gap fraction for tir radiation + CALL check_vector_data ('extkb [-] ', extkb_ens ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL check_vector_data ('extkd [-] ', extkd_ens ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL check_vector_data ('zwt [m] ', zwt_ens ) ! the depth to water table [m] + CALL check_vector_data ('wdsrf [mm] ', wdsrf_ens ) ! depth of surface water [mm] + CALL check_vector_data ('wa [mm] ', wa_ens ) ! water storage in aquifer [mm] + CALL check_vector_data ('wetwat [mm] ', wetwat_ens ) ! water storage in wetland [mm] + CALL check_vector_data ('t_lake [K] ', t_lake_ens ) ! lake temperature [K] + CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac_ens) ! lake ice fraction [-] + CALL check_vector_data ('savedtke1 [W/m K]', savedtke1_ens ) ! saved tke1 [m2/s2] + +#ifdef USEMPI + CALL mpi_barrier(p_comm_glb, p_err) +#endif + + END SUBROUTINE check_DATimeVariables +!----------------------------------------------------------------------------- +#endif + +END MODULE MOD_DA_Vars_TimeVariables +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 new file mode 100644 index 0000000000..28942ac5f0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 @@ -0,0 +1,494 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_BasinNetwork +!-------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Created by Shupeng Zhang, Feb 2025 +!-------------------------------------------------------------------------------- + + USE MOD_Pixelset + USE MOD_WorkerPushData + IMPLICIT NONE + + ! -- instances -- + integer :: numbasin + integer, allocatable :: basinindex(:) + + integer :: numbsnhru + type(subset_type) :: basin_hru + + integer :: numrivmth + integer, allocatable :: rivermouth(:) + + integer :: numlake, numresv + integer, allocatable :: lake_id (:) + integer, allocatable :: lake_type(:) ! lake type: + ! 0: not lake; 1: natural lake; + ! 2: reservoir; 3: controlled lake. + integer, allocatable :: bsn2lake (:) + integer, allocatable :: bsn2resv (:) + + type(worker_pushdata_type) :: push_elm2bsn + type(worker_pushdata_type) :: push_bsn2elm + + type(worker_pushdata_type) :: push_elmhru2bsnhru + type(worker_pushdata_type) :: push_bsnhru2elmhru + +CONTAINS + + ! ---------- + SUBROUTINE build_basin_network () + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Utils + USE MOD_NetCDFSerial + USE MOD_Mesh, only: numelm + USE MOD_LandElm, only: landelm + USE MOD_LandHRU, only: elm_hru + IMPLICIT NONE + + ! Local Variables + character(len=256) :: basin_file + integer, allocatable :: basindown(:) + + integer, allocatable :: nups_nst(:), iups_nst(:), nups_all(:), b_up2down(:), orderbsn(:) + + integer , allocatable :: nb_rs(:), iwrk_rs(:), nwrk_rs(:), nave_rs(:), nb_wrk(:) + real(r8), allocatable :: wtbsn(:), wt_rs (:), wt_wrk (:) + + integer :: totalnumbasin, ibasin, nbasin, iriv + integer :: iworker, iwrkdsp, mesg(2), isrc, nrecv + integer :: iloc, i, j, ithis + real(r8) :: sumwt + + integer, allocatable :: bindex(:), addrbasin(:), elmindex(:) + + ! lake and reservoir + character(len=256) :: lake_info_file + integer, allocatable :: all_lake_id (:), all_lake_type (:), order(:), icache(:) + integer, allocatable :: lake_id_resv(:), lake_type_resv(:) + integer :: ilake, iresv + + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + basin_file = DEF_CatchmentMesh_data + + ! read in parameters from file. + IF (p_is_master) THEN + CALL ncio_read_serial (basin_file, 'basin_downstream', basindown) + totalnumbasin = size(basindown) + ENDIF + +#ifdef USEMPI + ! divide basins into groups and assign to workers + IF (p_is_master) THEN + + IF (ncio_var_exist(basin_file, 'weightbasin')) THEN + CALL ncio_read_serial (basin_file, 'weightbasin', wtbsn) + ELSE + allocate (wtbsn (totalnumbasin)); wtbsn(:) = 1. + ENDIF + + ! sort basins from up to down, recorded by "b_up2down" + + allocate (nups_nst (totalnumbasin)); nups_nst(:) = 0 + allocate (iups_nst (totalnumbasin)); iups_nst(:) = 0 + allocate (b_up2down(totalnumbasin)) + + DO i = 1, totalnumbasin + j = basindown(i) + IF (j > 0) THEN + nups_nst(j) = nups_nst(j) + 1 + ENDIF + ENDDO + + ithis = 0 + DO i = 1, totalnumbasin + IF (iups_nst(i) == nups_nst(i)) THEN + + ithis = ithis + 1 + b_up2down(ithis) = i + iups_nst(i) = -1 + + j = basindown(i) + DO WHILE (j > 0) + + iups_nst(j) = iups_nst(j) + 1 + + IF (iups_nst(j) == nups_nst(j)) THEN + ithis = ithis + 1 + b_up2down(ithis) = j + iups_nst(j) = -1 + + j = basindown(j) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ENDDO + + deallocate (nups_nst) + deallocate (iups_nst) + + allocate (rivermouth (totalnumbasin)) + numrivmth = 0 + DO i = totalnumbasin, 1, -1 + j = basindown(b_up2down(i)) + IF (j <= 0) THEN + numrivmth = numrivmth + 1 + rivermouth(b_up2down(i)) = numrivmth + ELSE + rivermouth(b_up2down(i)) = rivermouth(j) + ENDIF + ENDDO + + allocate (nb_rs (numrivmth)); nb_rs(:) = 0 + allocate (wt_rs (numrivmth)); wt_rs(:) = 0 + DO i = 1, totalnumbasin + nb_rs(rivermouth(i)) = nb_rs(rivermouth(i)) + 1 + wt_rs(rivermouth(i)) = wt_rs(rivermouth(i)) + wtbsn(i) + ENDDO + + sumwt = sum(wt_rs) + + allocate (iwrk_rs (numrivmth)) + allocate (nwrk_rs (numrivmth)) + allocate (nave_rs (numrivmth)) + + iwrkdsp = -1 + DO i = 1, numrivmth + nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_worker) + IF (nwrk_rs(i) > 1) THEN + + nave_rs(i) = nb_rs(i) / nwrk_rs(i) + IF (mod(nb_rs(i), nwrk_rs(i)) /= 0) THEN + nave_rs(i) = nave_rs(i) + 1 + ENDIF + + iwrk_rs(i) = iwrkdsp + 1 + iwrkdsp = iwrkdsp + nwrk_rs(i) + ENDIF + ENDDO + + allocate (nups_all (totalnumbasin)); nups_all(:) = 1 + + DO i = 1, totalnumbasin + j = basindown(b_up2down(i)) + IF (j > 0) THEN + nups_all(j) = nups_all(j) + nups_all(b_up2down(i)) + ENDIF + ENDDO + + allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 + + allocate (wt_wrk (0:p_np_worker-1)); wt_wrk(:) = 0 + allocate (nb_wrk (0:p_np_worker-1)); nb_wrk(:) = 0 + + allocate (orderbsn(totalnumbasin)) + orderbsn(b_up2down) = (/(i, i = 1, totalnumbasin)/) + + ithis = totalnumbasin + DO WHILE (ithis > 0) + + i = b_up2down(ithis) + + IF (addrbasin(i) >= 0) THEN + ithis = ithis - 1 + CYCLE + ENDIF + + j = basindown(i) + IF (j > 0) THEN + IF (addrbasin(j) >= 0) THEN + addrbasin(i) = addrbasin(j) + ithis = ithis - 1 + CYCLE + ENDIF + ENDIF + + iriv = rivermouth(i) + IF (nwrk_rs(iriv) > 1) THEN + iworker = iwrk_rs(iriv) + IF (nups_all(i) <= nave_rs(iriv)-nb_wrk(iworker)) THEN + + addrbasin(i) = p_address_worker(iworker) + + nb_wrk(iworker) = nb_wrk(iworker) + nups_all(i) + IF (nb_wrk(iworker) == nave_rs(iriv)) THEN + iwrk_rs(iriv) = iwrk_rs(iriv) + 1 + ENDIF + + j = basindown(i) + IF (j > 0) THEN + DO WHILE (j > 0) + nups_all(j) = nups_all(j) - nups_all(i) + ithis = orderbsn(j) + j = basindown(j) + ENDDO + ELSE + ithis = ithis - 1 + ENDIF + ELSE + ithis = ithis - 1 + ENDIF + ELSE + iworker = minloc(wt_wrk(iwrkdsp+1:p_np_worker-1), dim=1) + iwrkdsp + + addrbasin(i) = p_address_worker(iworker) + + wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv) + ithis = ithis - 1 + ENDIF + + ENDDO + + deallocate (basindown) + deallocate (wtbsn ) + deallocate (b_up2down) + deallocate (nups_all ) + deallocate (orderbsn ) + deallocate (nb_rs ) + deallocate (wt_rs ) + deallocate (iwrk_rs ) + deallocate (nwrk_rs ) + deallocate (nave_rs ) + deallocate (wt_wrk ) + deallocate (nb_wrk ) + + ENDIF + + + ! send basin index to workers + IF (p_is_master) THEN + + allocate(basinindex (totalnumbasin)) + basinindex = (/(i, i = 1, totalnumbasin)/) + + DO iworker = 0, p_np_worker-1 + + nbasin = count(addrbasin == p_address_worker(iworker)) + CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_worker(iworker), mpi_tag_mesg, p_comm_glb, p_err) + + IF (nbasin > 0) THEN + allocate (bindex (nbasin)) + + bindex = pack(basinindex, mask = (addrbasin == p_address_worker(iworker))) + CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + + deallocate (bindex) + ENDIF + + ENDDO + + deallocate (basinindex) + + ELSEIF (p_is_worker) THEN + + CALL mpi_recv (numbasin, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + IF (numbasin > 0) THEN + + allocate (basinindex (numbasin)) + CALL mpi_recv (basinindex, numbasin, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + numbasin = totalnumbasin + allocate(basinindex (totalnumbasin)) + basinindex = (/(i, i = 1, totalnumbasin)/) +#endif + + + IF (p_is_worker) THEN + IF (numelm > 0) THEN + allocate (elmindex (numelm)) + elmindex = landelm%eindex + ENDIF + ENDIF + + CALL build_worker_pushdata (numelm, elmindex, numbasin, basinindex, push_elm2bsn) + CALL build_worker_pushdata (numbasin, basinindex, numelm, elmindex, push_bsn2elm) + + CALL build_worker_pushdata_subset ( & + numelm, numbasin, push_elm2bsn, elm_hru, push_elmhru2bsnhru, basin_hru, numbsnhru) + + CALL build_worker_pushdata_subset ( & + numbasin, numelm, push_bsn2elm, basin_hru, push_bsnhru2elmhru) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (allocated(addrbasin)) deallocate(addrbasin) + IF (allocated(elmindex )) deallocate(elmindex ) + + + IF (p_is_master) THEN + + lake_info_file = DEF_CatchmentMesh_data + CALL ncio_read_serial (lake_info_file, 'lake_id', all_lake_id) + + lake_info_file = trim(DEF_dir_runtime)//'/HydroLAKES_Reservoir.nc' + CALL ncio_read_serial (lake_info_file, 'hylak_id', lake_id_resv ) + CALL ncio_read_serial (lake_info_file, 'lake_type', lake_type_resv) + + allocate (order (size(lake_id_resv))) + order = (/(iresv, iresv=1,size(lake_id_resv))/) + + CALL quicksort (size(lake_id_resv), lake_id_resv, order) + + lake_type_resv = lake_type_resv(order) + + allocate (all_lake_type (size(all_lake_id))) + all_lake_type(:) = 0 + + DO ibasin = 1, size(all_lake_id) + IF (all_lake_id(ibasin) > 0) THEN + all_lake_type(ibasin) = 1 + iresv = find_in_sorted_list1 (all_lake_id(ibasin), size(lake_id_resv), lake_id_resv) + IF (iresv > 0) THEN + all_lake_type(ibasin) = lake_type_resv(iresv) + ENDIF + ENDIF + ENDDO + + deallocate (lake_id_resv ) + deallocate (lake_type_resv) + deallocate (order) + + ENDIF + + IF (p_is_worker) THEN + IF (numbasin > 0) THEN + allocate (lake_id (numbasin)); lake_id (:) = 0 + allocate (lake_type (numbasin)); lake_type(:) = 0 + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_worker) THEN + mesg = (/p_iam_glb, numbasin/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) + + IF (numbasin > 0) THEN + CALL mpi_send (basinindex, numbasin, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + + CALL mpi_recv (lake_id, numbasin, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + CALL mpi_recv (lake_type, numbasin, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF + + IF (p_is_master) THEN + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + nbasin = mesg(2) + IF (nbasin > 0) THEN + + allocate(bindex (nbasin)) + CALL mpi_recv (bindex, nbasin, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate(icache (nbasin)) + + icache = all_lake_id (bindex) + CALL mpi_send (icache, nbasin, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_err) + + icache = all_lake_type(bindex) + CALL mpi_send (icache, nbasin, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_err) + + deallocate (bindex) + deallocate (icache) + ENDIF + + ENDDO + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + lake_id = all_lake_id (basinindex) + lake_type = all_lake_type(basinindex) +#endif + + IF (p_is_worker) THEN + IF (numbasin > 0) THEN + numlake = count(lake_type /= 0) + numresv = count(lake_type >= 2) + ELSE + numlake = 0 + numresv = 0 + ENDIF + + IF (numlake > 0) THEN + allocate (bsn2lake (numbasin)) + ilake = 0 + DO ibasin = 1, numbasin + IF (lake_type(ibasin) /= 0) THEN + ilake = ilake + 1 + bsn2lake(ibasin) = ilake + ENDIF + ENDDO + ENDIF + + IF (numresv > 0) THEN + allocate (bsn2resv (numbasin)) + iresv = 0 + DO ibasin = 1, numbasin + IF (lake_type(ibasin) >= 2) THEN + iresv = iresv + 1 + bsn2resv(ibasin) = iresv + ENDIF + ENDDO + ENDIF + ENDIF + + IF (allocated(all_lake_id )) deallocate(all_lake_id ) + IF (allocated(all_lake_type)) deallocate(all_lake_type) + + + END SUBROUTINE build_basin_network + + ! --------- + SUBROUTINE basin_network_final () + + IMPLICIT NONE + + IF (allocated(basinindex)) deallocate(basinindex) + IF (allocated(rivermouth)) deallocate(rivermouth) + + IF (allocated(lake_id )) deallocate(lake_id ) + IF (allocated(lake_type )) deallocate(lake_type ) + + IF (allocated(bsn2lake )) deallocate(bsn2lake ) + IF (allocated(bsn2resv )) deallocate(bsn2resv ) + + END SUBROUTINE basin_network_final + +END MODULE MOD_Catch_BasinNetwork +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 new file mode 100644 index 0000000000..b300f8bbec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 @@ -0,0 +1,310 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_HillslopeFlow +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Shallow water equation solver over hillslopes. +! +! References +! [1] Toro EF. Shock-capturing methods for free-surface shallow flows. +! Chichester: John Wiley & Sons; 2001. +! [2] Liang, Q., Borthwick, A. G. L. (2009). Adaptive quadtree simulation of shallow +! flows with wet-dry fronts over complex topography. +! Computers and Fluids, 38(2), 221-234. +! [3] Audusse, E., Bouchut, F., Bristeau, M.-O., Klein, R., Perthame, B. (2004). +! A Fast and Stable Well-Balanced Scheme with Hydrostatic Reconstruction for +! Shallow Water Flows. SIAM Journal on Scientific Computing, 25(6), 2050-2065. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + ! -- Parameters -- + real(r8), parameter :: PONDMIN = 1.e-4 + real(r8), parameter :: nmanning_hslp = 0.3 + +CONTAINS + + ! ---------- + SUBROUTINE hillslope_flow (dt) + + USE MOD_SPMD_Task + USE MOD_Catch_BasinNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_RiverLakeNetwork + USE MOD_Catch_Vars_TimeVariables + USE MOD_Catch_Vars_1DFluxes + USE MOD_Const_Physical, only: grav + + IMPLICIT NONE + + real(r8), intent(in) :: dt + + ! Local Variables + integer :: nhru, hs, he, ibasin, i, j + + type(hillslope_network_type), pointer :: hillslope + + real(r8), allocatable :: wdsrf_h (:) ! [m] + real(r8), allocatable :: momen_h (:) ! [m^2/s] + real(r8), allocatable :: veloc_h (:) ! [m/s] + + real(r8), allocatable :: sum_hflux_h (:) + real(r8), allocatable :: sum_mflux_h (:) + real(r8), allocatable :: sum_zgrad_h (:) + + real(r8) :: hand_fc, wdsrf_fc, veloc_fc, hflux_fc, mflux_fc + real(r8) :: wdsrf_up, wdsrf_dn, vwave_up, vwave_dn + real(r8) :: hflux_up, hflux_dn, mflux_up, mflux_dn + + real(r8), allocatable :: xsurf_h (:) ! [m/s] + + real(r8) :: friction + real(r8) :: dt_res, dt_this + + logical, allocatable :: mask(:) + real(r8) :: srfbsn, dvol, nextl, nexta, nextv, ddep + + IF (p_is_worker) THEN + + DO ibasin = 1, numbasin + + hs = basin_hru%substt(ibasin) + he = basin_hru%subend(ibasin) + + IF (lake_id(ibasin) > 0) THEN + veloc_bsnhru(hs:he) = 0 + momen_bsnhru(hs:he) = 0 + CYCLE ! skip lakes + ELSE + DO i = hs, he + ! momentum is less or equal than the momentum at last time step. + momen_bsnhru(i) = min(wdsrf_bsnhru_prev(i), wdsrf_bsnhru(i)) * veloc_bsnhru(i) + ENDDO + ENDIF + + hillslope => hillslope_basin(ibasin) + + nhru = hillslope%nhru + + allocate (wdsrf_h (nhru)) + allocate (veloc_h (nhru)) + allocate (momen_h (nhru)) + + allocate (sum_hflux_h (nhru)) + allocate (sum_mflux_h (nhru)) + allocate (sum_zgrad_h (nhru)) + + allocate (xsurf_h (nhru)) + + DO i = 1, nhru + wdsrf_h(i) = wdsrf_bsnhru(hillslope%ihru(i)) + momen_h(i) = momen_bsnhru(hillslope%ihru(i)) + IF (wdsrf_h(i) > 0.) THEN + veloc_h(i) = momen_h(i) / wdsrf_h(i) + ELSE + veloc_h(i) = 0. + ENDIF + ENDDO + + dt_res = dt + DO WHILE (dt_res > 0.) + + DO i = 1, nhru + sum_hflux_h(i) = 0. + sum_mflux_h(i) = 0. + sum_zgrad_h(i) = 0. + ENDDO + + dt_this = dt_res + + DO i = 1, nhru + + j = hillslope%inext(i) + + IF (j <= 0) CYCLE ! lowest HRUs + + ! dry HRU + IF ((wdsrf_h(i) < PONDMIN) .and. (wdsrf_h(j) < PONDMIN)) THEN + CYCLE + ENDIF + + ! reconstruction of height of water near interface + hand_fc = max(hillslope%hand(i), hillslope%hand(j)) + wdsrf_up = max(0., hillslope%hand(i)+wdsrf_h(i) - hand_fc) + wdsrf_dn = max(0., hillslope%hand(j)+wdsrf_h(j) - hand_fc) + + ! velocity at hydrounit downstream face + veloc_fc = 0.5 * (veloc_h(i) + veloc_h(j)) & + + sqrt(grav * wdsrf_up) - sqrt(grav * wdsrf_dn) + + ! depth of water at downstream face + wdsrf_fc = 1/grav * (0.5*(sqrt(grav*wdsrf_up) + sqrt(grav*wdsrf_dn)) & + + 0.25 * (veloc_h(i) - veloc_h(j)))**2.0 + + IF (wdsrf_up > 0) THEN + vwave_up = min(veloc_h(i)-sqrt(grav*wdsrf_up), veloc_fc-sqrt(grav*wdsrf_fc)) + ELSE + vwave_up = veloc_h(j) - 2.0 * sqrt(grav*wdsrf_dn) + ENDIF + + IF (wdsrf_dn > 0) THEN + vwave_dn = max(veloc_h(j)+sqrt(grav*wdsrf_dn), veloc_fc+sqrt(grav*wdsrf_fc)) + ELSE + vwave_dn = veloc_h(i) + 2.0 * sqrt(grav*wdsrf_up) + ENDIF + + hflux_up = veloc_h(i) * wdsrf_up + hflux_dn = veloc_h(j) * wdsrf_dn + mflux_up = veloc_h(i)**2 * wdsrf_up + 0.5*grav * wdsrf_up**2 + mflux_dn = veloc_h(j)**2 * wdsrf_dn + 0.5*grav * wdsrf_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc = hillslope%flen(i) * hflux_up + mflux_fc = hillslope%flen(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc = hillslope%flen(i) * hflux_dn + mflux_fc = hillslope%flen(i) * mflux_dn + ELSE + hflux_fc = hillslope%flen(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(wdsrf_dn-wdsrf_up)) / (vwave_dn-vwave_up) + mflux_fc = hillslope%flen(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_hflux_h(i) = sum_hflux_h(i) + hflux_fc + sum_hflux_h(j) = sum_hflux_h(j) - hflux_fc + + sum_mflux_h(i) = sum_mflux_h(i) + mflux_fc + sum_mflux_h(j) = sum_mflux_h(j) - mflux_fc + + sum_zgrad_h(i) = sum_zgrad_h(i) + hillslope%flen(i) * 0.5*grav * wdsrf_up**2 + sum_zgrad_h(j) = sum_zgrad_h(j) - hillslope%flen(i) * 0.5*grav * wdsrf_dn**2 + + ENDDO + + DO i = 1, nhru + ! constraint 1: CFL condition + IF (hillslope%inext(i) > 0) THEN + IF ((veloc_h(i) /= 0.) .or. (wdsrf_h(i) > 0.)) THEN + dt_this = min(dt_this, hillslope%plen(i)/(abs(veloc_h(i)) + sqrt(grav*wdsrf_h(i)))*0.8) + ENDIF + ENDIF + + ! constraint 2: Avoid negative values of water + xsurf_h(i) = sum_hflux_h(i) / hillslope%area(i) + IF (xsurf_h(i) > 0) THEN + dt_this = min(dt_this, wdsrf_h(i) / xsurf_h(i)) + ENDIF + + ! constraint 3: Avoid change of flow direction + IF ((abs(veloc_h(i)) > 0.1) & + .and. (veloc_h(i) * (sum_mflux_h(i) - sum_zgrad_h(i)) > 0)) THEN + dt_this = min(dt_this, & + abs(momen_h(i) * hillslope%area(i) / (sum_mflux_h(i) - sum_zgrad_h(i)))) + ENDIF + ENDDO + + DO i = 1, nhru + + wdsrf_h(i) = max(0., wdsrf_h(i) - xsurf_h(i) * dt_this) + + IF (wdsrf_h(i) < PONDMIN) THEN + momen_h(i) = 0 + ELSE + friction = grav * nmanning_hslp**2 * abs(momen_h(i)) / wdsrf_h(i)**(7.0/3.0) + momen_h(i) = (momen_h(i) - & + (sum_mflux_h(i) - sum_zgrad_h(i)) / hillslope%area(i) * dt_this) & + / (1 + friction * dt_this) + + IF (hillslope%inext(i) <= 0) THEN + momen_h(i) = min(momen_h(i), 0.) + ENDIF + + IF (all(hillslope%inext /= i)) THEN + momen_h(i) = max(momen_h(i), 0.) + ENDIF + ENDIF + + ENDDO + + IF (hillslope%indx(1) == 0) THEN + srfbsn = minval(hillslope%hand + wdsrf_h) + IF (srfbsn < wdsrf_h(1)) THEN + allocate (mask (hillslope%nhru)) + dvol = (wdsrf_h(1) - srfbsn) * hillslope%area(1) + momen_h(1) = srfbsn/wdsrf_h(1) * momen_h(1) + wdsrf_h(1) = srfbsn + DO WHILE (dvol > 0) + mask = hillslope%hand + wdsrf_h > srfbsn + nexta = sum(hillslope%area, mask = (.not. mask)) + IF (any(mask)) THEN + nextl = minval(hillslope%hand + wdsrf_h, mask = mask) + nextv = nexta*(nextl-srfbsn) + IF (dvol > nextv) THEN + ddep = nextl - srfbsn + dvol = dvol - nextv + ELSE + ddep = dvol/nexta + dvol = 0. + ENDIF + ELSE + ddep = dvol/nexta + dvol = 0. + ENDIF + + srfbsn = srfbsn + ddep + + WHERE (.not. mask) + wdsrf_h = wdsrf_h + ddep + END WHERE + ENDDO + deallocate(mask) + ENDIF + ENDIF + + DO i = 1, nhru + IF (wdsrf_h(i) < PONDMIN) THEN + veloc_h(i) = 0 + ELSE + veloc_h(i) = momen_h(i) / wdsrf_h(i) + ENDIF + + wdsrf_bsnhru_ta(hillslope%ihru(i)) = wdsrf_bsnhru_ta(hillslope%ihru(i)) + wdsrf_h(i) * dt_this + momen_bsnhru_ta(hillslope%ihru(i)) = momen_bsnhru_ta(hillslope%ihru(i)) + momen_h(i) * dt_this + ENDDO + + dt_res = dt_res - dt_this + + ENDDO + + ! SAVE depth of surface water + DO i = 1, nhru + wdsrf_bsnhru(hillslope%ihru(i)) = wdsrf_h(i) + veloc_bsnhru(hillslope%ihru(i)) = veloc_h(i) + ENDDO + + deallocate (wdsrf_h) + deallocate (veloc_h) + deallocate (momen_h) + + deallocate (sum_hflux_h) + deallocate (sum_mflux_h) + deallocate (sum_zgrad_h) + + deallocate (xsurf_h) + + ENDDO + + IF (numbsnhru > 0) wdsrf_bsnhru_prev(:) = wdsrf_bsnhru(:) + + ENDIF + + END SUBROUTINE hillslope_flow + +END MODULE MOD_Catch_HillslopeFlow +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 new file mode 100644 index 0000000000..bded7bd9d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 @@ -0,0 +1,381 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_HillslopeNetwork +!-------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Surface networks (hillslope bands): data and communication subroutines. +! +! Created by Shupeng Zhang, May 2023 +!-------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + ! -- data type -- + type :: hillslope_network_type + integer :: nhru + integer , pointer :: ihru (:) ! location of HRU in global vector "landhru" + integer , pointer :: indx (:) ! index of HRU + real(r8), pointer :: area (:) ! area of HRU [m^2] + real(r8), pointer :: agwt (:) ! water area only including (patchtype <= 2) [m^2] + real(r8), pointer :: hand (:) ! height above nearest drainage [m] + real(r8), pointer :: elva (:) ! elevation [m] + real(r8), pointer :: plen (:) ! average drainage path length to downstream HRU [m] + real(r8), pointer :: flen (:) ! interface length between this and downstream HRU [m] + integer , pointer :: inext(:) ! location of next HRU in this basin + real(r8), pointer :: fldprof (:,:) ! flood area profile + CONTAINS + final :: hillslope_network_free_mem + END type hillslope_network_type + + integer :: nfldstep + +CONTAINS + + ! ---------- + SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_UserDefFun + IMPLICIT NONE + + integer, intent(in) :: ne + integer, intent(in) :: elmindex (:) + type(hillslope_network_type), pointer :: hillslope_network(:) + + ! Local Variables + character(len=256) :: hillslope_network_file + + integer :: maxnumhru, ie, nhru, hs, i, j + integer :: iworker, mesg(2), nrecv, irecv, isrc, idest + + integer , allocatable :: eid (:) + + integer , allocatable :: nhru_all(:), nhru_in_bsn(:) + + integer , allocatable :: indxhru (:,:) + real(r8), allocatable :: handhru (:,:) + real(r8), allocatable :: elvahru (:,:) + real(r8), allocatable :: plenhru (:,:) + real(r8), allocatable :: lfachru (:,:) + integer , allocatable :: nexthru (:,:) + real(r8), allocatable :: fldstep (:,:,:) + + integer , allocatable :: icache (:,:) + real(r8), allocatable :: rcache (:,:), rcache2(:,:,:) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + hillslope_network_file = DEF_CatchmentMesh_data + + IF (p_is_master) THEN + + CALL ncio_read_serial (hillslope_network_file, 'basin_numhru', nhru_all) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_index', indxhru) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_hand', handhru) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_elva', elvahru) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_pathlen', plenhru) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_facelen', lfachru) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_downstream', nexthru) + CALL ncio_read_serial (hillslope_network_file, 'hydrounit_flood_step', fldstep) + + ENDIF + + IF (p_is_master) maxnumhru = size(indxhru,1) + IF (p_is_master) nfldstep = size(fldstep,1) +#ifdef USEMPI + CALL mpi_bcast (maxnumhru, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (nfldstep, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#endif + + hillslope_network => null() + + IF (p_is_master) THEN +#ifdef USEMPI + DO iworker = 1, p_np_worker + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + nrecv = mesg(2) + isrc = mesg(1) + + IF (nrecv > 0) THEN + + allocate (eid (nrecv)) + allocate (nhru_in_bsn (nrecv)) + allocate (icache (maxnumhru,nrecv)) + allocate (rcache (maxnumhru,nrecv)) + + CALL mpi_recv (eid, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + idest = isrc + + nhru_in_bsn = nhru_all(eid) + CALL mpi_send (nhru_in_bsn, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + icache(:,irecv) = indxhru(:,eid(irecv)) + ENDDO + CALL mpi_send (icache, maxnumhru*nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + rcache(:,irecv) = handhru(:,eid(irecv)) + ENDDO + CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + rcache(:,irecv) = elvahru(:,eid(irecv)) + ENDDO + CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + rcache(:,irecv) = plenhru(:,eid(irecv)) + ENDDO + CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + rcache(:,irecv) = lfachru(:,eid(irecv)) + ENDDO + CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + icache(:,irecv) = nexthru(:,eid(irecv)) + ENDDO + CALL mpi_send (icache, maxnumhru*nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + allocate (rcache2 (nfldstep,maxnumhru,nrecv)) + + DO irecv = 1, nrecv + rcache2(:,:,irecv) = fldstep(:,:,eid(irecv)) + ENDDO + CALL mpi_send (rcache2, nfldstep*maxnumhru*nrecv, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (eid) + deallocate (nhru_in_bsn) + deallocate (icache) + deallocate (rcache) + deallocate (rcache2) + ENDIF + ENDDO +#else + IF (ne > 0) THEN + + allocate (nhru_in_bsn (ne)) + allocate (icache (maxnumhru,ne)) + allocate (rcache (maxnumhru,ne)) + + nhru_in_bsn = nhru_all(elmindex) + + DO ie = 1, ne + icache(:,ie) = indxhru(:,elmindex(ie)) + ENDDO + indxhru = icache + + DO ie = 1, ne + rcache(:,ie) = handhru(:,elmindex(ie)) + ENDDO + handhru = rcache + + DO ie = 1, ne + rcache(:,ie) = elvahru(:,elmindex(ie)) + ENDDO + elvahru = rcache + + DO ie = 1, ne + rcache(:,ie) = plenhru(:,elmindex(ie)) + ENDDO + plenhru = rcache + + DO ie = 1, ne + rcache(:,ie) = lfachru(:,elmindex(ie)) + ENDDO + lfachru = rcache + + DO ie = 1, ne + icache(:,ie) = nexthru(:,elmindex(ie)) + ENDDO + nexthru = icache + + deallocate (icache) + deallocate (rcache) + + allocate (rcache2 (nfldstep,maxnumhru,ne)) + + DO ie = 1, ne + rcache2(:,:,ie) = fldstep(:,:,elmindex(ie)) + ENDDO + fldstep = rcache2 + + deallocate (rcache2) + + ENDIF +#endif + ENDIF + + IF (p_is_worker) THEN + +#ifdef USEMPI + mesg(1:2) = (/p_iam_glb, ne/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (ne > 0) THEN + + CALL mpi_send (elmindex, ne, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + + allocate (nhru_in_bsn (ne)) + CALL mpi_recv (nhru_in_bsn, ne, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (indxhru (maxnumhru,ne)) + CALL mpi_recv (indxhru, maxnumhru*ne, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (handhru (maxnumhru,ne)) + CALL mpi_recv (handhru, maxnumhru*ne, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (elvahru (maxnumhru,ne)) + CALL mpi_recv (elvahru, maxnumhru*ne, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (plenhru (maxnumhru,ne)) + CALL mpi_recv (plenhru, maxnumhru*ne, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (lfachru (maxnumhru,ne)) + CALL mpi_recv (lfachru, maxnumhru*ne, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (nexthru (maxnumhru,ne)) + CALL mpi_recv (nexthru, maxnumhru*ne, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (fldstep (nfldstep,maxnumhru,ne)) + CALL mpi_recv (fldstep, nfldstep*maxnumhru*ne, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF +#endif + + IF (ne > 0) THEN + allocate( hillslope_network (ne)) + ENDIF + + hs = 0 + + DO ie = 1, ne + + nhru = count(indxhru(:,ie) >= 0) + + IF (nhru > 0) THEN + + IF (nhru /= nhru_in_bsn(ie)) THEN + write(*,*) 'Warning : numbers of hydro units from file mismatch!' + ENDIF + + allocate (hillslope_network(ie)%ihru (nhru)) + allocate (hillslope_network(ie)%indx (nhru)) + allocate (hillslope_network(ie)%area (nhru)) + allocate (hillslope_network(ie)%agwt (nhru)) + allocate (hillslope_network(ie)%hand (nhru)) + allocate (hillslope_network(ie)%elva (nhru)) + allocate (hillslope_network(ie)%plen (nhru)) + allocate (hillslope_network(ie)%flen (nhru)) + allocate (hillslope_network(ie)%inext (nhru)) + + hillslope_network(ie)%indx = indxhru(1:nhru,ie) + hillslope_network(ie)%hand = handhru(1:nhru,ie) ! m + hillslope_network(ie)%elva = elvahru(1:nhru,ie) ! m + hillslope_network(ie)%plen = plenhru(1:nhru,ie) * 1.0e3 ! km to m + hillslope_network(ie)%flen = lfachru(1:nhru,ie) * 1.0e3 ! km to m + + hillslope_network(ie)%ihru = (/ (i, i = hs+1, hs+nhru) /) + + allocate (hillslope_network(ie)%fldprof (nfldstep,nhru)) + + DO i = 1, nhru + DO j = 1, nfldstep + IF (j == 1) THEN + hillslope_network(ie)%fldprof(j,i) = max(fldstep(j,i,ie) * (j-0.5)/nfldstep, 1.e-3) + ELSE + hillslope_network(ie)%fldprof(j,i) = hillslope_network(ie)%fldprof(j-1,i) & + + (fldstep(j,i,ie) - fldstep(j-1,i,ie)) * (j-0.5)/nfldstep + ENDIF + ENDDO + ENDDO + + DO i = 1, nhru + IF (nexthru(i,ie) >= 0) THEN + j = findloc_ud(indxhru(1:nhru,ie) == nexthru(i,ie)) + hillslope_network(ie)%inext(i) = j + ELSE + hillslope_network(ie)%inext(i) = -1 + ENDIF + ENDDO + + ELSE + ! for lake + hillslope_network(ie)%ihru => null() + hillslope_network(ie)%indx => null() + hillslope_network(ie)%area => null() + hillslope_network(ie)%agwt => null() + hillslope_network(ie)%hand => null() + hillslope_network(ie)%elva => null() + hillslope_network(ie)%plen => null() + hillslope_network(ie)%flen => null() + hillslope_network(ie)%inext => null() + ENDIF + + hillslope_network(ie)%nhru = nhru_in_bsn(ie) + hs = hs + nhru_in_bsn(ie) + + ENDDO + + ENDIF + + IF (allocated(nhru_all )) deallocate(nhru_all ) + IF (allocated(nhru_in_bsn)) deallocate(nhru_in_bsn) + + IF (allocated(indxhru)) deallocate(indxhru) + IF (allocated(handhru)) deallocate(handhru) + IF (allocated(elvahru)) deallocate(elvahru) + IF (allocated(plenhru)) deallocate(plenhru) + IF (allocated(lfachru)) deallocate(lfachru) + IF (allocated(nexthru)) deallocate(nexthru) + IF (allocated(fldstep)) deallocate(fldstep) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + IF (p_is_master) write(*,'(A)') 'Read hillslope network information done.' + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE hillslope_network_init + + ! --------- + SUBROUTINE hillslope_network_free_mem (this) + + IMPLICIT NONE + type(hillslope_network_type) :: this + + IF (associated(this%ihru )) deallocate(this%ihru ) + IF (associated(this%indx )) deallocate(this%indx ) + IF (associated(this%area )) deallocate(this%area ) + IF (associated(this%agwt )) deallocate(this%agwt ) + IF (associated(this%hand )) deallocate(this%hand ) + IF (associated(this%elva )) deallocate(this%elva ) + IF (associated(this%plen )) deallocate(this%plen ) + IF (associated(this%flen )) deallocate(this%flen ) + IF (associated(this%inext )) deallocate(this%inext ) + IF (associated(this%fldprof)) deallocate(this%fldprof) + + END SUBROUTINE hillslope_network_free_mem + +END MODULE MOD_Catch_HillslopeNetwork +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 new file mode 100644 index 0000000000..84454ec069 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 @@ -0,0 +1,490 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_Hist +!-------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Write out model results in lateral hydrological processes to history files. +! +! Created by Shupeng Zhang, May 2023 +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Vars_Global, only: spval + + USE MOD_Mesh, only: numelm + USE MOD_LandHRU, only: numhru + USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru + USE MOD_Catch_Reservoir + USE MOD_Catch_Vars_1DFluxes + USE MOD_Vector_ReadWrite + + ! -- ACC Fluxes -- + integer :: nac_basin + + real(r8), allocatable :: a_wdsrf_bsnhru (:) + real(r8), allocatable :: a_veloc_bsnhru (:) + + real(r8), allocatable :: a_wdsrf_hru (:) + real(r8), allocatable :: a_veloc_hru (:) + + real(r8), allocatable :: a_wdsrf_bsn (:) + real(r8), allocatable :: a_veloc_riv (:) + real(r8), allocatable :: a_discharge (:) + + real(r8), allocatable :: a_wdsrf_elm (:) + real(r8), allocatable :: a_veloc_elm (:) + real(r8), allocatable :: a_dschg_elm (:) + + real(r8), allocatable :: a_xsubs_elm (:) + real(r8), allocatable :: a_xsubs_hru (:) + + real(r8), allocatable :: a_volresv (:) + real(r8), allocatable :: a_qresv_in (:) + real(r8), allocatable :: a_qresv_out (:) + + real(r8), allocatable :: ntacc_elm (:) + + ! -- PUBLIC SUBROUTINEs -- + PUBLIC :: hist_basin_init + PUBLIC :: hist_basin_out + PUBLIC :: hist_basin_final + +!-------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE hist_basin_init + + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numbsnhru > 0) THEN + allocate (a_wdsrf_bsnhru (numbsnhru)) + allocate (a_veloc_bsnhru (numbsnhru)) + ENDIF + + IF (numbasin > 0) THEN + allocate (a_wdsrf_bsn (numbasin)) + allocate (a_veloc_riv (numbasin)) + allocate (a_discharge (numbasin)) + ENDIF + + IF (numelm > 0) allocate (a_xsubs_elm (numelm)) + IF (numhru > 0) allocate (a_xsubs_hru (numhru)) + + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv > 0) allocate (a_volresv (numresv)) + IF (numresv > 0) allocate (a_qresv_in (numresv)) + IF (numresv > 0) allocate (a_qresv_out (numresv)) + ENDIF + ENDIF + + CALL FLUSH_acc_fluxes_basin () + + END SUBROUTINE hist_basin_init + + !-------------------------------------- + SUBROUTINE hist_basin_final () + + IMPLICIT NONE + + IF (allocated(a_wdsrf_bsnhru)) deallocate(a_wdsrf_bsnhru) + IF (allocated(a_veloc_bsnhru)) deallocate(a_veloc_bsnhru) + + IF (allocated(a_wdsrf_bsn)) deallocate(a_wdsrf_bsn) + IF (allocated(a_veloc_riv)) deallocate(a_veloc_riv) + IF (allocated(a_discharge)) deallocate(a_discharge) + + IF (allocated(a_xsubs_elm)) deallocate(a_xsubs_elm) + IF (allocated(a_xsubs_hru)) deallocate(a_xsubs_hru) + + IF (allocated(a_volresv )) deallocate(a_volresv ) + IF (allocated(a_qresv_in )) deallocate(a_qresv_in ) + IF (allocated(a_qresv_out)) deallocate(a_qresv_out) + + END SUBROUTINE hist_basin_final + + !--------------------------------------- + SUBROUTINE hist_basin_out (file_hist, idate) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_ElmVector + USE MOD_HRUVector + USE MOD_LandHRU + USE MOD_Catch_BasinNetwork + IMPLICIT NONE + + character(len=*), intent(in) :: file_hist + integer, intent(in) :: idate(3) + + ! Local variables + character(len=256) :: file_hist_basin + logical :: fexists + integer :: itime_in_file + logical, allocatable :: filter (:) + real(r8), allocatable :: varhist(:) + integer :: i + + IF (p_is_master) THEN + + i = len_trim (file_hist) + DO WHILE (file_hist(i:i) /= '_') + i = i - 1 + ENDDO + file_hist_basin = file_hist(1:i) // 'basin_' // file_hist(i+1:) + + inquire (file=file_hist_basin, exist=fexists) + IF (.not. fexists) THEN + CALL ncio_create_file (trim(file_hist_basin)) + CALL ncio_define_dimension(file_hist_basin, 'time', 0) + CALL ncio_define_dimension(file_hist_basin, 'basin', totalnumelm) + CALL ncio_define_dimension(file_hist_basin, 'hydrounit', totalnumhru) + + CALL ncio_write_serial (file_hist_basin, 'basin', eindex_glb, 'basin') + CALL ncio_put_attr (file_hist_basin, 'basin', 'long_name', 'basin index') + + CALL ncio_write_serial (file_hist_basin, 'basin_hru', eindx_hru, 'hydrounit') + CALL ncio_put_attr (file_hist_basin, 'basin_hru', 'long_name', & + 'basin index of hydrological units') + + CALL ncio_write_serial (file_hist_basin, 'hru_type' , htype_hru, 'hydrounit') + CALL ncio_put_attr (file_hist_basin, 'hru_type' , 'long_name', & + 'index of hydrological units inside basin') + + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv_uniq > 0) THEN + CALL ncio_define_dimension(file_hist_basin, 'reservoir', numresv_uniq) + CALL ncio_write_serial (file_hist_basin, 'resv_hylak_id' , resv_hylak_id, 'reservoir') + CALL ncio_put_attr (file_hist_basin, 'resv_hylak_id' , 'long_name', & + 'HydroLAKE ID of reservoirs') + ENDIF + ENDIF + ENDIF + + CALL ncio_write_time (file_hist_basin, 'time', idate, itime_in_file, DEF_HIST_FREQ) + + ENDIF + + + IF (p_is_worker) THEN + IF (numhru > 0) THEN + allocate (a_wdsrf_hru (numhru)) + allocate (a_veloc_hru (numhru)) + ENDIF + + IF (numelm > 0) THEN + allocate (a_wdsrf_elm (numelm)) + allocate (a_veloc_elm (numelm)) + allocate (a_dschg_elm (numelm)) + allocate (ntacc_elm (numelm)) + ENDIF + ENDIF + + ! ----- water depth in basin ----- + IF (DEF_hist_vars%riv_height) THEN + IF ((p_is_worker) .and. allocated(a_wdsrf_bsn)) THEN + WHERE(a_wdsrf_bsn /= spval) + a_wdsrf_bsn = a_wdsrf_bsn / nac_basin + END WHERE + ENDIF + + CALL worker_push_data (push_bsn2elm, a_wdsrf_bsn, a_wdsrf_elm, spval) + + CALL vector_gather_and_write (& + a_wdsrf_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_wdsrf_bsn', 'basin', & + itime_in_file, 'River Height', 'm') + ENDIF + + ! ----- water velocity in river ----- + IF (DEF_hist_vars%riv_veloct) THEN + IF ((p_is_worker) .and. allocated(a_veloc_riv)) THEN + WHERE(a_veloc_riv /= spval) + a_veloc_riv = a_veloc_riv / nac_basin + END WHERE + ENDIF + + CALL worker_push_data (push_bsn2elm, a_veloc_riv, a_veloc_elm, spval) + + CALL vector_gather_and_write (& + a_veloc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_veloc_riv', 'basin', & + itime_in_file, 'River Velocity', 'm/s') + ENDIF + + ! ----- discharge in river ----- + IF (DEF_hist_vars%discharge) THEN + IF ((p_is_worker) .and. allocated(a_discharge)) THEN + WHERE(a_discharge /= spval) + a_discharge = a_discharge / nac_basin + END WHERE + ENDIF + + CALL worker_push_data (push_bsn2elm, a_discharge, a_dschg_elm, spval) + + CALL vector_gather_and_write (& + a_dschg_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_discharge', 'basin', & + itime_in_file, 'River Discharge', 'm^3/s') + ENDIF + + ! ----- number of time steps for each basin ----- + CALL worker_push_data (push_bsn2elm, ntacc_bsn, ntacc_elm, spval) + + CALL vector_gather_and_write (& + ntacc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'timesteps', 'basin', & + itime_in_file, 'Number of accumulated timesteps for each basin', '-') + + IF (p_is_worker .and. (numbasin > 0)) ntacc_bsn(:) = 0. + + ! ----- water depth in hydro unit ----- + IF (DEF_hist_vars%wdsrf_hru) THEN + IF ((p_is_worker) .and. allocated(a_wdsrf_bsnhru)) THEN + WHERE(a_wdsrf_bsnhru /= spval) + a_wdsrf_bsnhru = a_wdsrf_bsnhru / nac_basin + END WHERE + ENDIF + + CALL worker_push_data (push_bsnhru2elmhru, a_wdsrf_bsnhru, a_wdsrf_hru, spval) + + CALL vector_gather_and_write (& + a_wdsrf_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_wdsrf_hru', 'hydrounit', & + itime_in_file, 'Depth of Surface Water in Hydro unit', 'm') + ENDIF + + ! ----- water velocity in hydro unit ----- + IF (DEF_hist_vars%veloc_hru) THEN + IF ((p_is_worker) .and. allocated(a_veloc_bsnhru)) THEN + WHERE(a_veloc_bsnhru /= spval) + a_veloc_bsnhru = a_veloc_bsnhru / nac_basin + END WHERE + ENDIF + + CALL worker_push_data (push_bsnhru2elmhru, a_veloc_bsnhru, a_veloc_hru, spval) + + CALL vector_gather_and_write (& + a_veloc_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_veloc_hru', 'hydrounit', & + itime_in_file, 'Surface Flow Velocity in Hydro unit', 'm/s') + ENDIF + + ! ----- subsurface water flow between elements ----- + IF (DEF_hist_vars%xsubs_bsn) THEN + IF (p_is_worker) THEN + WHERE(a_xsubs_elm /= spval) + a_xsubs_elm = a_xsubs_elm / nac_basin + END WHERE + ENDIF + + CALL vector_gather_and_write (& + a_xsubs_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_xsubs_bsn', 'basin', & + itime_in_file, 'Subsurface lateral flow between basins', 'm/s') + ENDIF + + ! ----- subsurface water flow between hydro units ----- + IF (DEF_hist_vars%xsubs_hru) THEN + IF (p_is_worker) THEN + WHERE(a_xsubs_hru /= spval) + a_xsubs_hru = a_xsubs_hru / nac_basin + END WHERE + ENDIF + + CALL vector_gather_and_write (& + a_xsubs_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_xsubs_hru', 'hydrounit', & + itime_in_file, 'SubSurface lateral flow between HRUs', 'm/s') + ENDIF + + ! ----- reservoir variables ----- + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv_uniq > 0) THEN + + allocate (varhist (numresv_uniq)) + + IF (DEF_hist_vars%volresv) THEN + + IF (p_is_worker) THEN + IF (numresv > 0) THEN + WHERE (a_volresv /= spval) + a_volresv = a_volresv / nac_basin + END WHERE + ENDIF + ENDIF + + CALL reservoir_gather_var (a_volresv, varhist) + + IF (p_is_master) THEN + CALL ncio_write_serial_time (file_hist_basin, 'volresv', & + itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (file_hist_basin, 'volresv', 'long_name', 'reservoir water volume') + CALL ncio_put_attr (file_hist_basin, 'volresv', 'units', 'm^3') + CALL ncio_put_attr (file_hist_basin, 'volresv', 'missing_value', spval) + ENDIF + ENDIF + ENDIF + + IF (DEF_hist_vars%qresv_in) THEN + + IF (p_is_worker) THEN + IF (numresv > 0) THEN + WHERE (a_qresv_in /= spval) + a_qresv_in = a_qresv_in / nac_basin + END WHERE + ENDIF + ENDIF + + CALL reservoir_gather_var (a_qresv_in, varhist) + + IF (p_is_master) THEN + CALL ncio_write_serial_time (file_hist_basin, 'qresv_in', & + itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'long_name', 'reservoir inflow') + CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'units', 'm^3/s') + CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'missing_value', spval) + ENDIF + ENDIF + ENDIF + + IF (DEF_hist_vars%qresv_out) THEN + + IF (p_is_worker) THEN + IF (numresv > 0) THEN + WHERE (a_qresv_out /= spval) + a_qresv_out = a_qresv_out / nac_basin + END WHERE + ENDIF + ENDIF + + CALL reservoir_gather_var (a_qresv_out, varhist) + + IF (p_is_master) THEN + CALL ncio_write_serial_time (file_hist_basin, 'qresv_out', & + itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'long_name', 'reservoir outflow') + CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'units', 'm^3/s') + CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'missing_value', spval) + ENDIF + ENDIF + ENDIF + + deallocate (varhist) + + ENDIF + ENDIF + + + CALL FLUSH_acc_fluxes_basin () + + IF (allocated(a_wdsrf_hru)) deallocate(a_wdsrf_hru) + IF (allocated(a_veloc_hru)) deallocate(a_veloc_hru) + + IF (allocated(a_wdsrf_elm)) deallocate(a_wdsrf_elm) + IF (allocated(a_veloc_elm)) deallocate(a_veloc_elm) + IF (allocated(a_dschg_elm)) deallocate(a_dschg_elm) + IF (allocated(ntacc_elm )) deallocate(ntacc_elm ) + + + END SUBROUTINE hist_basin_out + + !----------------------- + SUBROUTINE FLUSH_acc_fluxes_basin () + + USE MOD_SPMD_Task + USE MOD_Mesh, only: numelm + USE MOD_LandHRU, only: numhru + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + IF (p_is_worker) THEN + + nac_basin = 0 + + IF (numbasin > 0) THEN + a_wdsrf_bsn(:) = spval + a_veloc_riv(:) = spval + a_discharge(:) = spval + ENDIF + + IF (numelm > 0) a_xsubs_elm (:) = spval + + IF (numbsnhru > 0) THEN + a_wdsrf_bsnhru(:) = spval + a_veloc_bsnhru(:) = spval + ENDIF + + IF (numhru > 0) a_xsubs_hru(:) = spval + + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv > 0) a_volresv (:) = spval + IF (numresv > 0) a_qresv_in (:) = spval + IF (numresv > 0) a_qresv_out(:) = spval + ENDIF + + ENDIF + + END SUBROUTINE FLUSH_acc_fluxes_basin + + ! ------- + SUBROUTINE accumulate_fluxes_basin + + IMPLICIT NONE + + IF (p_is_worker) THEN + + nac_basin = nac_basin + 1 + + IF (numbasin > 0) THEN + CALL acc1d_basin (wdsrf_bsn_ta, a_wdsrf_bsn) + CALL acc1d_basin (veloc_riv_ta, a_veloc_riv) + CALL acc1d_basin (discharge_ta, a_discharge ) + ENDIF + + IF (numelm > 0) CALL acc1d_basin (xsubs_elm, a_xsubs_elm) + + IF (numbsnhru > 0) THEN + CALL acc1d_basin (wdsrf_bsnhru_ta, a_wdsrf_bsnhru) + CALL acc1d_basin (veloc_bsnhru_ta, a_veloc_bsnhru) + ENDIF + + IF (numhru > 0) CALL acc1d_basin (xsubs_hru, a_xsubs_hru) + + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv > 0) CALL acc1d_basin (volresv_ta, a_volresv ) + IF (numresv > 0) CALL acc1d_basin (qresv_in_ta, a_qresv_in ) + IF (numresv > 0) CALL acc1d_basin (qresv_out_ta, a_qresv_out) + ENDIF + + ENDIF + + END SUBROUTINE accumulate_fluxes_basin + + ! ------- + SUBROUTINE acc1d_basin (var, s) + + USE MOD_Precision + USE MOD_Vars_Global, only: spval + + IMPLICIT NONE + + real(r8), intent(in) :: var(:) + real(r8), intent(inout) :: s (:) + ! Local variables + integer :: i + + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i) + ELSE + s(i) = var(i) + ENDIF + ENDIF + ENDDO + + END SUBROUTINE acc1d_basin + +END MODULE MOD_Catch_Hist +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 new file mode 100644 index 0000000000..fa250d80ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 @@ -0,0 +1,496 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_LateralFlow +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Lateral flow. +! +! Lateral flows in CoLM include +! 1. Surface flow over hillslopes; +! 2. Routing flow in rivers; +! 3. Groundwater (subsurface) lateral flow. +! +! Water exchanges between +! 1. surface flow and rivers; +! 2. subsurface flow and rivers. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Catch_Vars_TimeVariables + USE MOD_ElementNeighbour + USE MOD_Catch_BasinNetwork + USE MOD_Catch_RiverLakeNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_HillslopeFlow + USE MOD_Catch_SubsurfaceFlow + USE MOD_Catch_RiverLakeFlow + USE MOD_Catch_Reservoir + USE MOD_Vars_TimeVariables + USE MOD_Vars_Global, only: dz_soi + USE MOD_Const_Physical, only: denice, denh2o + IMPLICIT NONE + + integer, parameter :: nsubstep = 20 + real(r8) :: dt_average + + real(r8) :: landarea + real(r8), allocatable :: patcharea (:) ! m^2 + +CONTAINS + + ! ---------- + SUBROUTINE lateral_flow_init (lc_year) + +#ifdef CoLMDEBUG + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_Pixel + USE MOD_LandPatch + USE MOD_Utils +#endif + USE MOD_Catch_WriteParameters + IMPLICIT NONE + + integer, intent(in) :: lc_year ! which year of land cover data used + + integer :: ip, ie, ipxl + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + allocate (patcharea (numpatch)) + patcharea(:) = 0. + DO ip = 1, numpatch + ie = landpatch%ielm(ip) + DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) + patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + IF (landpatch%has_shared) THEN + patcharea(ip) = patcharea(ip) * landpatch%pctshared(ip) + ENDIF + ENDDO + ENDIF + + landarea = 0. + IF (numpatch > 0) landarea = sum(patcharea) +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, landarea, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#endif + ENDIF + + CALL element_neighbour_init (patcharea, lc_year) + CALL river_lake_network_init (patcharea) + CALL subsurface_network_init (patcharea) + CALL reservoir_init () + + CALL write_catch_parameters () + + + END SUBROUTINE lateral_flow_init + + ! ---------- + SUBROUTINE lateral_flow (year, deltime) + + USE MOD_Namelist, only: DEF_Reservoir_Method, DEF_USE_Dynamic_Lake + USE MOD_Mesh, only: numelm + USE MOD_LandHRU, only: landhru, numhru, elm_hru + USE MOD_LandPatch, only: numpatch, elm_patch, hru_patch + + USE MOD_Vars_Global, only: nl_lake + USE MOD_Const_Physical, only: tfrz + USE MOD_Vars_TimeVariables, only: wdsrf, t_lake, lake_icefrac, t_soisno + USE MOD_Vars_TimeInvariants, only: lakedepth, dz_lake + USE MOD_Vars_1DFluxes, only: rsur, rsub, rnof + USE MOD_Catch_Vars_1DFluxes + USE MOD_Catch_Vars_TimeVariables + USE MOD_Catch_RiverLakeNetwork + + USE MOD_Lake, only: adjust_lake_layer + + USE MOD_UserDefFun, only : findloc_ud + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: year + real(r8), intent(in) :: deltime + + ! Local Variables + integer :: i, j, j0, h, ps, pe, istep, s + real(r8) :: rnofsrf, sumarea + real(r8), allocatable :: wdsrf_p (:), wdsrf_hru_p (:) +#ifdef CoLMDEBUG + real(r8) :: dtolw, tolwat, toldis, maxdvol, maxdvol_g, sumdvol + integer :: hs, he, imax, bidmax + real(r8), allocatable :: wdsrf_bsnhru_p(:), delvol(:) +#endif + + IF (p_is_worker) THEN + + ! a) The smallest unit in surface lateral flow (including hillslope flow and river-lake flow) + ! is HRU and the main prognostic variable is "wdsrf_bsnhru" (surface water depth). + ! b) "wdsrf_bsnhru" is updated by aggregating water depths in patches. + ! c) Water surface in a basin ("wdsrf_bsn", defined as the lowest surface water in the basin) + ! is derived from "wdsrf_bsnhru". + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + wdsrf_hru(i) = sum(wdsrf(ps:pe) * hru_patch%subfrc(ps:pe)) + wdsrf_hru(i) = wdsrf_hru(i) / 1.0e3 ! mm to m + ENDDO + + IF (numhru > 0) THEN + allocate (wdsrf_hru_p (numhru)) + wdsrf_hru_p = wdsrf_hru + ENDIF + + IF (numpatch > 0) THEN + allocate (wdsrf_p (numpatch)) + wdsrf_p = wdsrf + ENDIF + + dt_average = 0. + + IF (numbasin > 0) wdsrf_bsn_ta (:) = 0. + IF (numbasin > 0) momen_riv_ta (:) = 0. + IF (numbasin > 0) discharge_ta (:) = 0. + IF (numbsnhru > 0) wdsrf_bsnhru_ta (:) = 0. + IF (numbsnhru > 0) momen_bsnhru_ta (:) = 0. + + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv > 0) volresv_ta (:) = 0. + IF (numresv > 0) qresv_in_ta (:) = 0. + IF (numresv > 0) qresv_out_ta(:) = 0. + ENDIF + + CALL worker_push_data (push_elmhru2bsnhru, wdsrf_hru, wdsrf_bsnhru, spval) + +#ifdef CoLMDEBUG + IF (numbsnhru > 0) THEN + allocate (wdsrf_bsnhru_p (numbsnhru)) + wdsrf_bsnhru_p = wdsrf_bsnhru + ENDIF +#endif + + DO istep = 1, nsubstep + + ! (1) ------------------- Surface flow over hillslopes. ------------------- + CALL hillslope_flow (deltime/nsubstep) + + ! (2) ----------------------- River and Lake flow. ------------------------ + CALL river_lake_flow (year, deltime/nsubstep) + + dt_average = dt_average + deltime/nsubstep/ntimestep_riverlake + + ENDDO + + IF (numbasin > 0) THEN + wdsrf_bsn_ta(:) = wdsrf_bsn_ta(:) / deltime + momen_riv_ta(:) = momen_riv_ta(:) / deltime + + WHERE (wdsrf_bsn_ta > 0) + veloc_riv_ta = momen_riv_ta / wdsrf_bsn_ta + ELSE WHERE + veloc_riv_ta = 0 + END WHERE + + discharge_ta = discharge_ta / deltime + ENDIF + + IF (numbsnhru > 0) THEN + wdsrf_bsnhru_ta(:) = wdsrf_bsnhru_ta(:) / deltime + momen_bsnhru_ta(:) = momen_bsnhru_ta(:) / deltime + + WHERE (wdsrf_bsnhru_ta > 0) + veloc_bsnhru_ta = momen_bsnhru_ta / wdsrf_bsnhru_ta + ELSE WHERE + veloc_bsnhru_ta = 0. + END WHERE + ENDIF + + IF (DEF_Reservoir_Method > 0) THEN + DO i = 1, numresv + IF (year >= dam_build_year(i)) THEN + volresv_ta (i) = volresv_ta (i) / deltime + qresv_in_ta (i) = qresv_in_ta (i) / deltime + qresv_out_ta(i) = qresv_out_ta(i) / deltime + ELSE + volresv_ta (i) = spval + qresv_in_ta (i) = spval + qresv_out_ta(i) = spval + ENDIF + ENDDO + ENDIF + + ! update surface water depth on patches + CALL worker_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval) + DO i = 1, numhru + wdsrf_hru(i) = max(0., wdsrf_hru(i)) + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + wdsrf(ps:pe) = wdsrf_hru(i) * 1.0e3 ! m to mm + ENDDO + + IF (numpatch > 0) THEN + xwsur(:) = (wdsrf_p(:) - wdsrf(:)) / deltime + ENDIF + + ! update surface runoff from hillslope to river + IF (numpatch > 0) rsur(:) = 0. + DO i = 1, numelm + IF (lake_id_elm(i) <= 0) THEN + + rnofsrf = 0. + sumarea = 0. + + IF (lake_id_elm(i) == 0) THEN + j0 = 2 ! regular catchment with river + ELSE + j0 = 1 ! catchment directly to lake + ENDIF + + DO j = j0, hillslope_element(i)%nhru + h = hillslope_element(i)%ihru(j) + rnofsrf = rnofsrf + (wdsrf_hru_p(h) - wdsrf_hru(h)) * hillslope_element(i)%area(j) + sumarea = sumarea + hillslope_element(i)%area(j) + ENDDO + + IF (sumarea > 0.) THEN + rnofsrf = rnofsrf / sumarea * 1.e3 / deltime ! unit: mm/s + DO j = j0, hillslope_element(i)%nhru + h = hillslope_element(i)%ihru(j) + ps = hru_patch%substt(h) + pe = hru_patch%subend(h) + rsur(ps:pe) = rnofsrf + ENDDO + ENDIF + ENDIF + ENDDO + + ! update fraction of flooded area + DO i = 1, numelm + IF (lake_id_elm(i) <= 0) THEN + DO j = 1, hillslope_element(i)%nhru + h = hillslope_element(i)%ihru(j) + ps = hru_patch%substt(h) + pe = hru_patch%subend(h) + + IF (hillslope_element(i)%indx(j) == 0) THEN + fldarea(ps:pe) = 1.0 ! river + ELSE + s = findloc_ud(hillslope_element(i)%fldprof(:,j) <= wdsrf_hru(h), back = .true.) + IF (s == nfldstep) THEN + fldarea(ps:pe) = 1.0 + ELSEIF (s == 0) THEN + fldarea(ps:pe) = sqrt(wdsrf_hru(h)/hillslope_element(i)%fldprof(1,j) * 1./nfldstep**2) + ELSE + fldarea(ps:pe) = sqrt( (wdsrf_hru(h)-hillslope_element(i)%fldprof(s,j)) & + / (hillslope_element(i)%fldprof(s+1,j)-hillslope_element(i)%fldprof(s,j)) & + * real(2*s+1) / nfldstep**2 + real(s**2)/nfldstep**2 ) + ENDIF + ENDIF + ENDDO + ELSE + ps = elm_patch%substt(i) + pe = elm_patch%subend(i) + fldarea(ps:pe) = 1.0 ! lake + ENDIF + ENDDO + +#ifdef CoLMDEBUG + IF (numbasin > 0) THEN + + allocate (delvol (numbasin)) + + delvol(:) = 0 + DO i = numbasin, 1, -1 + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + + IF (lake_id(i) <= 0) THEN + delvol(i) = delvol(i) & + + sum((wdsrf_bsnhru_p(hs:he) - wdsrf_bsnhru(hs:he))* hillslope_basin(i)%area) + ELSE + delvol(i) = delvol(i) & + + sum((wdsrf_bsnhru_p(hs:he) - wdsrf_bsnhru(hs:he))* lakeinfo(i)%area0) + ENDIF + + IF ((riverdown(i) == 0) .or. (riverdown(i) == -3)) THEN + delvol(i) = delvol(i) - discharge_ta(i) * deltime + ENDIF + + IF (riversystem == -1) THEN + j0 = i; j = ilocdown(i) + DO WHILE (j > 0) + + delvol(j) = delvol(j) + delvol(j0) + delvol(j0) = 0 + + IF ((j > i) .and. (ilocdown(j) > 0)) THEN + j0 = j; j = ilocdown(j) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ENDDO + + sumdvol = sum(delvol) + + IF (riversystem /= -1) THEN + maxdvol = sum(delvol) +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, maxdvol, 1, MPI_REAL8, MPI_SUM, p_comm_rivsys, p_err) + maxdvol = abs(maxdvol) + imax = findloc_ud(riverdown <= 0) + IF (imax > 0) THEN + bidmax = basinindex(imax) + ELSE + bidmax = 0 + ENDIF + CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_rivsys, p_err) +#endif + ELSE + imax = maxloc(abs(delvol),dim=1) + maxdvol = abs(delvol(imax)) + bidmax = basinindex(imax) + ENDIF + + ELSE + maxdvol = 0. + bidmax = 0 + sumdvol = 0. + ENDIF + +#ifdef USEMPI + CALL mpi_allreduce (maxdvol, maxdvol_g, 1, MPI_REAL8, MPI_MAX, p_comm_worker, p_err) + IF (maxdvol < maxdvol_g) THEN + bidmax = 0 + ENDIF + CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, sumdvol, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#else + maxdvol_g = maxdvol +#endif + + IF (allocated(wdsrf_bsnhru_p)) deallocate(wdsrf_bsnhru_p) + IF (allocated(delvol )) deallocate(delvol ) +#endif + + ! (3) ------------------- Subsurface lateral flow ------------------- + CALL subsurface_flow (deltime) + + DO i = 1, numpatch + h2osoi(:,i) = wliq_soisno(1:,i)/(dz_soi(1:)*denh2o) + wice_soisno(1:,i)/(dz_soi(1:)*denice) + wat(i) = sum(wice_soisno(1:,i)+wliq_soisno(1:,i)) + ldew(i) + scv(i) + wetwat(i) + ENDDO + + IF (numpatch > 0) rnof = rsur + rsub + + ! (4) ---------------- vertical layers adjustment --------------------- + IF (DEF_USE_Dynamic_Lake) THEN + DO i = 1, numpatch + IF (wdsrf_p(i) >= 100.) THEN + ! wet previously + dz_lake(:,i) = dz_lake(:,i) * wdsrf(i)*1.e-3/sum(dz_lake(:,i)) + ELSE + ! dry previously + dz_lake(:,i) = wdsrf(i)*1.e-3/nl_lake + t_lake (:,i) = t_soisno(1,i) + IF (t_soisno(1,i) >= tfrz) THEN + lake_icefrac(:,i) = 0. + ELSE + lake_icefrac(:,i) = 1. + ENDIF + ENDIF + + IF (wdsrf(i) >= 100.) THEN + CALL adjust_lake_layer (nl_lake, dz_lake(:,i), t_lake(:,i), lake_icefrac(:,i)) + ENDIF + ENDDO + ENDIF + + ENDIF + +#ifdef RangeCheck + IF (p_is_worker .and. (p_iam_worker == 0)) THEN + write(*,'(/,A)') 'Checking Lateral Flow Variables ...' + write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', & + dt_average/nsubstep, ' seconds' + ENDIF + + CALL check_vector_data ('Basin Water Depth [m] ', wdsrf_bsn) + CALL check_vector_data ('River Velocity [m/s]', veloc_riv) + CALL check_vector_data ('HRU Water Depth [m] ', wdsrf_bsnhru) + CALL check_vector_data ('HRU Water Velocity [m/s]', veloc_bsnhru) + CALL check_vector_data ('Subsurface bt basin [m/s]', xsubs_elm) + CALL check_vector_data ('Subsurface bt HRU [m/s]', xsubs_hru) + CALL check_vector_data ('Subsurface bt patch [m/s]', xsubs_pch) + +#ifdef CoLMDEBUG + IF (p_is_worker) THEN + + dtolw = 0 + toldis = 0 + + IF (numpatch > 0) THEN + dtolw = sum(patcharea * xwsur ) / 1.e3 * deltime + tolwat = sum(patcharea * wdsrf_p) / 1.e3 + ENDIF + IF (numbasin > 0) THEN + toldis = sum(discharge_ta*deltime, mask = (riverdown == 0) .or. (riverdown == -3)) + dtolw = dtolw - toldis + ENDIF + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, tolwat, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, toldis, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#endif + IF (p_iam_worker == 0) THEN + write(*,'(A,E9.2,A,I0,A,E9.2,A)') 'River system error: max ', maxdvol_g, & + ' m^3 in river mouth ', bidmax, ', total ', sumdvol, ' m^3' + write(*,'(A,F12.2,A,ES8.1,A,ES10.3,A)') 'Total surface water error: ', dtolw, & + ' m^3 of total ', tolwat, ' m^3, discharge ', toldis, ' m^3' + ENDIF + + dtolw = 0 + IF (numpatch > 0) dtolw = sum(patcharea * xwsub) / 1.e3 * deltime +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#endif + IF (p_iam_worker == 0) THEN + write(*,'(A,F12.2,A,ES8.1,A)') 'Total ground water error: ', dtolw, & + ' m^3 in area ', landarea, ' m^2' + ENDIF + ENDIF +#endif +#endif + + IF (allocated(wdsrf_p )) deallocate(wdsrf_p ) + IF (allocated(wdsrf_hru_p)) deallocate(wdsrf_hru_p) + + END SUBROUTINE lateral_flow + + ! ---------- + SUBROUTINE lateral_flow_final () + + IMPLICIT NONE + + CALL river_lake_network_final () + CALL subsurface_network_final () + CALL basin_network_final () + CALL reservoir_final () + + IF (allocated(patcharea)) deallocate(patcharea) + + END SUBROUTINE lateral_flow_final + +END MODULE MOD_Catch_LateralFlow +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 new file mode 100644 index 0000000000..bfed81b8bb --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 @@ -0,0 +1,497 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_Reservoir +!----------------------------------------------------------------------- +! DESCRIPTION: +! +! Reservoir module in catchment mesh. +! +! Created by Shupeng Zhang, July 2025 +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Catch_BasinNetwork, only : numbasin, basinindex, numresv, bsn2resv, lake_id, lake_type + + real(r8), allocatable :: dam_elv (:) ! dam elevation [m] + + ! parameters + real(r8), allocatable :: volresv_total (:) ! total reservoir volume [m^3] + real(r8), allocatable :: volresv_emerg (:) ! emergency reservoir volume [m^3] + real(r8), allocatable :: volresv_adjust(:) ! adjustment reservoir volume [m^3] + real(r8), allocatable :: volresv_normal(:) ! normal reservoir volume [m^3] + + real(r8), allocatable :: qresv_mean (:) ! mean natural reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_flood (:) ! flood reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_adjust (:) ! adjustment reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_normal (:) ! normal reservoir outflow [m^3/s] + + integer, allocatable :: dam_build_year(:) ! year in which the dam/barrier was built + + ! time variables + real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3] + real(r8), allocatable :: qresv_in (:) ! reservoir inflow [m^3/s] + real(r8), allocatable :: qresv_out (:) ! reservoir outflow [m^3/s] + + ! time average variables for output + real(r8), allocatable :: volresv_ta (:) ! reservoir water volume [m^3] + real(r8), allocatable :: qresv_in_ta (:) ! inflow to reservoir [m^3/s] + real(r8), allocatable :: qresv_out_ta (:) ! outflow from reservoir [m^3/s] + + integer :: numresv_uniq + integer, allocatable :: resv_hylak_id (:) ! HydroLAKE ID of reservoir + integer, allocatable :: resv_loc2glb (:) ! global index of reservoir + + ! -- PUBLIC SUBROUTINEs -- + PUBLIC :: reservoir_init + PUBLIC :: reservoir_operation + PUBLIC :: reservoir_gather_var + PUBLIC :: reservoir_final + +CONTAINS + + ! ------- + SUBROUTINE reservoir_init ( ) + + USE MOD_Vars_Global, only: spval + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_Utils + USE MOD_Catch_RiverLakeNetwork, only : wtsrfelv, bedelv, lakeinfo + + IMPLICIT NONE + + ! Local variables + character(len=256) :: basin_info_file, resv_info_file + integer :: maxlakeid, mesg(2), isrc, idest, iworker + + integer, allocatable :: lake_id_basin (:), ilat_outlet_basin(:), ilon_outlet_basin(:) + integer, allocatable :: lake_id_resv (:), ilat_outlet_resv (:), ilon_outlet_resv (:) + integer, allocatable :: lake_type_resv(:), lake_id2typ (:) + integer, allocatable :: resv_bsn_id (:), idlist (:) + integer, allocatable :: all_year_basin(:), all_year_resv (:) + + real(r8), allocatable :: all_vol_basin (:), all_qmean_basin (:), all_qflood_basin (:) + real(r8), allocatable :: all_vol_resv (:), all_qmean_resv (:), all_qflood_resv (:) + real(r8), allocatable :: all_dhgt_basin(:), all_dhgt_resv (:), dam_height (:) + + real(r8), allocatable :: rcache(:) + integer, allocatable :: icache(:) + integer :: nbasin, ibasin, irsv, nrecv, nrsv, iloc + + + IF (p_is_worker) THEN + + IF (numresv > 0) THEN + + allocate (dam_elv (numresv)) + + allocate (volresv_total (numresv)) + allocate (volresv_emerg (numresv)) + allocate (volresv_adjust(numresv)) + allocate (volresv_normal(numresv)) + + allocate (qresv_mean (numresv)) + allocate (qresv_flood (numresv)) + allocate (qresv_adjust (numresv)) + allocate (qresv_normal (numresv)) + + allocate (volresv (numresv)) + allocate (qresv_in (numresv)) + allocate (qresv_out (numresv)) + + allocate (volresv_ta (numresv)) + allocate (qresv_in_ta (numresv)) + allocate (qresv_out_ta (numresv)) + + allocate (dam_build_year(numresv)) + + allocate (dam_height (numresv)) + + ENDIF + ENDIF + + ! read in parameters from file. + IF (p_is_master) THEN + + basin_info_file = DEF_CatchmentMesh_data + CALL ncio_read_serial (basin_info_file, 'lake_id', lake_id_basin ) + CALL ncio_read_serial (basin_info_file, 'ilat_outlet', ilat_outlet_basin) + CALL ncio_read_serial (basin_info_file, 'ilon_outlet', ilon_outlet_basin) + + maxlakeid = maxval(lake_id_basin) + IF (maxlakeid > 0) THEN + + resv_info_file = trim(DEF_dir_runtime)//'/HydroLAKES_Reservoir.nc' + CALL ncio_read_serial (resv_info_file, 'hylak_id', lake_id_resv ) + CALL ncio_read_serial (resv_info_file, 'lake_type', lake_type_resv ) + CALL ncio_read_serial (resv_info_file, 'ilat_outlet', ilat_outlet_resv) + CALL ncio_read_serial (resv_info_file, 'ilon_outlet', ilon_outlet_resv) + CALL ncio_read_serial (resv_info_file, 'volresv', all_vol_resv ) + CALL ncio_read_serial (resv_info_file, 'qmean', all_qmean_resv ) + CALL ncio_read_serial (resv_info_file, 'qflood', all_qflood_resv) + + CALL ncio_read_serial (resv_info_file, 'build_year', all_year_resv) + CALL ncio_read_serial (resv_info_file, 'dam_height', all_dhgt_resv) + + allocate (lake_id2typ (-1:maxlakeid)) + lake_id2typ(:) = 0 + + DO irsv = 1, size(lake_id_resv) + IF (lake_id_resv(irsv) <= maxlakeid) THEN + lake_id2typ(lake_id_resv(irsv)) = lake_type_resv(irsv) + ENDIF + ENDDO + + + nbasin = size(lake_id_basin) + + allocate(all_vol_basin (nbasin)); all_vol_basin (:) = spval + allocate(all_qmean_basin (nbasin)); all_qmean_basin (:) = spval + allocate(all_qflood_basin (nbasin)); all_qflood_basin(:) = spval + allocate(all_year_basin (nbasin)); all_year_basin (:) = -99 + allocate(all_dhgt_basin (nbasin)); all_dhgt_basin (:) = spval + + DO ibasin = 1, nbasin + IF (lake_id2typ(lake_id_basin(ibasin)) >= 2) THEN + DO irsv = 1, size(lake_id_resv) + IF (lake_id_basin(ibasin) == lake_id_resv(irsv)) THEN + IF (ilat_outlet_basin(ibasin) == ilat_outlet_resv(irsv)) THEN + IF (ilon_outlet_basin(ibasin) == ilon_outlet_resv(irsv)) THEN + all_vol_basin (ibasin) = all_vol_resv (irsv) + all_qmean_basin (ibasin) = all_qmean_resv (irsv) + all_qflood_basin(ibasin) = all_qflood_resv(irsv) + all_year_basin (ibasin) = all_year_resv (irsv) + all_dhgt_basin (ibasin) = all_dhgt_resv (irsv) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + ENDIF + + ENDIF + + IF (p_is_worker) THEN + IF (numresv > 0) THEN + allocate (resv_bsn_id (numresv)) + resv_bsn_id = pack(basinindex, lake_type >= 2) + ENDIF + ENDIF + +#ifdef USEMPI + IF (p_is_master) THEN + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + + allocate (resv_bsn_id (nrecv)) + allocate (rcache (nrecv)) + allocate (icache (nrecv)) + + CALL mpi_recv (resv_bsn_id, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + idest = isrc + + rcache = all_vol_basin(resv_bsn_id) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = all_qmean_basin(resv_bsn_id) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = all_qflood_basin(resv_bsn_id) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + icache = all_year_basin(resv_bsn_id) + CALL mpi_send (icache, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = all_dhgt_basin(resv_bsn_id) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (resv_bsn_id) + deallocate (rcache) + deallocate (icache) + + ENDIF + ENDDO + ENDIF + + IF (p_is_worker) THEN + + mesg(1:2) = (/p_iam_glb, numresv/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numresv > 0) THEN + CALL mpi_send (resv_bsn_id, numresv, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + + CALL mpi_recv (volresv_total, numresv, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + CALL mpi_recv (qresv_mean, numresv, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + CALL mpi_recv (qresv_flood, numresv, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + CALL mpi_recv (dam_build_year, numresv, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + CALL mpi_recv (dam_height, numresv, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF +#else + IF (numresv > 0) THEN + volresv_total = all_vol_basin (resv_bsn_id) + qresv_mean = all_qmean_basin (resv_bsn_id) + qresv_flood = all_qflood_basin(resv_bsn_id) + dam_build_year = all_year_basin (resv_bsn_id) + dam_height = all_dhgt_basin (resv_bsn_id) + ENDIF +#endif + + IF (p_is_worker) THEN + DO ibasin = 1, numbasin + IF (lake_type(ibasin) >= 2) THEN + + irsv = bsn2resv(ibasin) + + dam_height(irsv) = max(dam_height(irsv), wtsrfelv(ibasin)-bedelv(ibasin)) + dam_height(irsv) = max(dam_height(irsv), lakeinfo(ibasin)%surface(volresv_total(irsv))) + dam_height(irsv) = min(dam_height(irsv), 335.) + + dam_elv (irsv) = bedelv(ibasin) + dam_height(irsv) + volresv_total (irsv) = lakeinfo(ibasin)%volume( dam_height(irsv) ) + + volresv_emerg (irsv) = volresv_total(irsv) * 0.94 + volresv_adjust(irsv) = volresv_total(irsv) * 0.77 + volresv_normal(irsv) = volresv_total(irsv) * 0.7 + + qresv_normal (irsv) = volresv_normal(irsv)*0.7/(180*86400) + qresv_mean(irsv)*0.25 + qresv_adjust (irsv) = (qresv_normal(irsv) + qresv_flood(irsv)) * 0.5 + ENDIF + ENDDO + ENDIF + + + IF (p_is_master) THEN + + nrsv = count(lake_id2typ(lake_id_basin) >= 2) + + IF (nrsv > 0) THEN + + allocate (idlist (nrsv)) + + numresv_uniq = 0 + DO ibasin = 1, size(lake_id_basin) + IF (lake_id2typ(lake_id_basin(ibasin)) >= 2) THEN + CALL insert_into_sorted_list1 ( & + lake_id_basin(ibasin), numresv_uniq, idlist, iloc) + ENDIF + ENDDO + + allocate (resv_hylak_id (numresv_uniq)) + resv_hylak_id = idlist(1:numresv_uniq) + + deallocate (idlist) + + ELSE + numresv_uniq = 0 + ENDIF + + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (numresv_uniq, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + + IF (numresv_uniq > 0) THEN + IF (.not. p_is_master) allocate (resv_hylak_id (numresv_uniq)) + CALL mpi_bcast (resv_hylak_id, numresv_uniq, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + ENDIF +#endif + + IF (p_is_worker) THEN + IF (numresv > 0) THEN + allocate (resv_loc2glb (numresv)) + DO ibasin = 1, numbasin + IF (lake_type(ibasin) >= 2) THEN + resv_loc2glb(bsn2resv(ibasin)) = & + find_in_sorted_list1 (lake_id(ibasin), numresv_uniq, resv_hylak_id) + ENDIF + ENDDO + ENDIF + ENDIF + + + IF (allocated(lake_id2typ )) deallocate (lake_id2typ ) + IF (allocated(lake_id_basin )) deallocate (lake_id_basin ) + IF (allocated(ilat_outlet_basin)) deallocate (ilat_outlet_basin) + IF (allocated(ilon_outlet_basin)) deallocate (ilon_outlet_basin) + IF (allocated(lake_id_resv )) deallocate (lake_id_resv ) + IF (allocated(lake_type_resv )) deallocate (lake_type_resv ) + IF (allocated(ilat_outlet_resv )) deallocate (ilat_outlet_resv ) + IF (allocated(ilon_outlet_resv )) deallocate (ilon_outlet_resv ) + IF (allocated(all_qmean_basin )) deallocate (all_qmean_basin ) + IF (allocated(all_qflood_basin )) deallocate (all_qflood_basin ) + IF (allocated(all_qmean_resv )) deallocate (all_qmean_resv ) + IF (allocated(all_qflood_resv )) deallocate (all_qflood_resv ) + IF (allocated(all_year_basin )) deallocate (all_year_basin ) + IF (allocated(all_year_resv )) deallocate (all_year_resv ) + IF (allocated(all_dhgt_basin )) deallocate (all_dhgt_basin ) + IF (allocated(all_dhgt_resv )) deallocate (all_dhgt_resv ) + IF (allocated(dam_height )) deallocate (dam_height ) + IF (allocated(resv_bsn_id )) deallocate (resv_bsn_id ) + + + END SUBROUTINE reservoir_init + + + SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) + + IMPLICIT NONE + integer, intent(in) :: method + integer, intent(in) :: irsv + real(r8), intent(in) :: qin, vol + real(r8), intent(out) :: qout + + ! local variables + real(r8) :: q1 + + IF (method == 1) THEN + ! *** Reference *** + ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. + ! Development of an Improved Reservoir Operation Scheme for Global Flood Modeling (CaMa-Flood v4.20). + ! ESS Open Archive . October 24, 2024. + + IF (vol > volresv_emerg(irsv)) THEN + qout = max(qin, qresv_flood(irsv)) + ELSEIF (vol > volresv_adjust(irsv)) THEN + qout = qresv_adjust(irsv) + (qresv_flood(irsv)-qresv_adjust(irsv)) & + * ((vol-volresv_adjust(irsv))/(volresv_emerg(irsv)-volresv_adjust(irsv)))**0.1 + IF (qin > qresv_flood(irsv)) THEN + q1 = qresv_normal(irsv) + (qin-qresv_normal(irsv)) & + * (vol-volresv_normal(irsv))/(volresv_emerg(irsv)-volresv_normal(irsv)) + qout = max(q1, qout) + ENDIF + ELSEIF (vol > volresv_normal(irsv)) THEN + qout = qresv_normal(irsv) + (qresv_adjust(irsv)-qresv_normal(irsv)) & + * ((vol-volresv_normal(irsv))/(volresv_adjust(irsv)-volresv_normal(irsv)))**3. + ELSE + qout = (vol/volresv_normal(irsv))**0.5 * qresv_normal(irsv) + ENDIF + + ENDIF + + END SUBROUTINE reservoir_operation + + + SUBROUTINE reservoir_gather_var (varin, varout) + + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(in) :: varin (:) + real(r8), intent(out) :: varout (:) + + ! local variables + integer :: irsv, iworker + real(r8), allocatable :: varall (:,:) + + IF (numresv_uniq == 0) RETURN + + IF (p_is_worker) THEN + varout(:) = spval + DO irsv = 1, numresv + IF (varin(irsv) /= spval) THEN + IF (varout(resv_loc2glb(irsv)) /= spval) THEN + varout(resv_loc2glb(irsv)) = varout(resv_loc2glb(irsv)) + varin(irsv) + ELSE + varout(resv_loc2glb(irsv)) = varin(irsv) + ENDIF + ENDIF + ENDDO +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (varall (numresv_uniq,0:p_np_worker-1)) + ENDIF + + CALL mpi_gather (varout, numresv_uniq, MPI_REAL8, & + varall, numresv_uniq, MPI_REAL8, p_root, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + + DO irsv = 1, numresv_uniq + DO iworker = 0, p_np_worker-1 + IF (iworker /= p_root) THEN + IF (varall(irsv,iworker) /= spval) THEN + IF (varout(irsv) /= spval) THEN + varout(irsv) = varout(irsv) + varall(irsv,iworker) + ELSE + varout(irsv) = varall(irsv,iworker) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + + deallocate (varall) + ENDIF +#endif + ENDIF + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + CALL mpi_send (varout, numresv_uniq, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + IF (p_is_master) THEN + CALL mpi_recv (varout, numresv_uniq, MPI_REAL8, p_address_worker(p_root), & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF +#endif + + END SUBROUTINE reservoir_gather_var + + + SUBROUTINE reservoir_final () + + IMPLICIT NONE + + IF (allocated(dam_elv )) deallocate (dam_elv ) + + IF (allocated(resv_hylak_id )) deallocate (resv_hylak_id ) + IF (allocated(resv_loc2glb )) deallocate (resv_loc2glb ) + + IF (allocated(volresv_total )) deallocate (volresv_total ) + IF (allocated(volresv_emerg )) deallocate (volresv_emerg ) + IF (allocated(volresv_adjust)) deallocate (volresv_adjust) + IF (allocated(volresv_normal)) deallocate (volresv_normal) + + IF (allocated(qresv_mean )) deallocate (qresv_mean ) + IF (allocated(qresv_flood )) deallocate (qresv_flood ) + IF (allocated(qresv_adjust )) deallocate (qresv_adjust ) + IF (allocated(qresv_normal )) deallocate (qresv_normal ) + + IF (allocated(dam_build_year)) deallocate (dam_build_year) + + IF (allocated(volresv )) deallocate (volresv ) + IF (allocated(qresv_in )) deallocate (qresv_in ) + IF (allocated(qresv_out )) deallocate (qresv_out ) + + IF (allocated(volresv_ta )) deallocate (volresv_ta ) + IF (allocated(qresv_in_ta )) deallocate (qresv_in_ta ) + IF (allocated(qresv_out_ta )) deallocate (qresv_out_ta ) + + END SUBROUTINE reservoir_final + +END MODULE MOD_Catch_Reservoir +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 new file mode 100644 index 0000000000..3a88650e29 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 @@ -0,0 +1,596 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_RiverLakeFlow +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Shallow water equation solver in rivers. +! +! References +! [1] Toro EF. Shock-capturing methods for free-surface shallow flows. +! Chichester: John Wiley & Sons; 2001. +! [2] Liang, Q., Borthwick, A. G. L. (2009). Adaptive quadtree simulation of shallow +! flows with wet-dry fronts over complex topography. +! Computers and Fluids, 38(2), 221-234. +! [3] Audusse, E., Bouchut, F., Bristeau, M.-O., Klein, R., Perthame, B. (2004). +! A Fast and Stable Well-Balanced Scheme with Hydrostatic Reconstruction for +! Shallow Water Flows. SIAM Journal on Scientific Computing, 25(6), 2050-2065. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + real(r8), parameter :: nmanning_riv = 0.03 + + real(r8), parameter :: RIVERMIN = 1.e-5_r8 + real(r8), parameter :: VOLUMEMIN = 1.e-5_r8 + + integer :: ntimestep_riverlake + +CONTAINS + + ! --------- + SUBROUTINE river_lake_flow (year, dt) + + USE MOD_SPMD_Task + USE MOD_Namelist, only : DEF_Reservoir_Method + USE MOD_Utils + USE MOD_Catch_BasinNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_RiverLakeNetwork + USE MOD_Catch_Reservoir + USE MOD_Catch_Vars_TimeVariables + USE MOD_Catch_Vars_1DFluxes + USE MOD_Const_Physical, only: grav + IMPLICIT NONE + + integer, intent(in) :: year + real(r8), intent(in) :: dt + + ! Local Variables + integer :: hs, he, i, j, irsv + real(r8) :: dt_this + + real(r8), allocatable :: wdsrf_bsn_ds(:) + real(r8), allocatable :: veloc_riv_ds(:) + real(r8), allocatable :: momen_riv_ds(:) + + real(r16), allocatable :: hflux_fc(:) + real(r16), allocatable :: mflux_fc(:) + real(r16), allocatable :: zgrad_dn(:) + + real(r16), allocatable :: hflux_resv(:) + real(r16), allocatable :: mflux_resv(:) + + real(r16), allocatable :: sum_hflux_riv(:) + real(r16), allocatable :: sum_mflux_riv(:) + real(r16), allocatable :: sum_zgrad_riv(:) + + real(r8) :: veloct_fc, height_fc, momen_fc, zsurf_fc + real(r8) :: bedelv_fc, height_up, height_dn + real(r8) :: vwave_up, vwave_dn, hflux_up, hflux_dn, mflux_up, mflux_dn + real(r8) :: totalvolume, friction, dvol, nextl, nexta, nextv, ddep + real(r8), allocatable :: dt_res(:), dt_all(:), dt_tmp(:) + logical, allocatable :: hmask(:), bsnfilter(:) + + + IF (p_is_worker) THEN + + ! update water depth in basin by aggregating water depths in patches + DO i = 1, numbasin + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + + IF (lake_id(i) <= 0) THEN + ! river or lake catchment + ! Water surface in a basin is defined as the lowest surface water in the basin + wdsrf_bsn(i) = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he)) - handmin(i) + + ELSEIF (lake_id(i) > 0) THEN + ! lake + totalvolume = sum(wdsrf_bsnhru(hs:he) * lakeinfo(i)%area0) + wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume) + ENDIF + + + IF (lake_id(i) == 0) THEN + ! river momentum is less or equal than the momentum at last time step. + IF (wdsrf_bsn_prev(i) < wdsrf_bsn(i)) THEN + momen_riv(i) = wdsrf_bsn_prev(i) * veloc_riv(i) + veloc_riv(i) = momen_riv(i) / wdsrf_bsn(i) + ELSE + momen_riv(i) = wdsrf_bsn(i) * veloc_riv(i) + ENDIF + ELSE + ! water in lake or lake catchment is assumued to be stationary. + ! TODO: lake dynamics + momen_riv(i) = 0 + veloc_riv(i) = 0 + ENDIF + + ENDDO + + IF (numbasin > 0) THEN + + allocate (wdsrf_bsn_ds (numbasin)) + allocate (veloc_riv_ds (numbasin)) + allocate (momen_riv_ds (numbasin)) + allocate (hflux_fc (numbasin)) + allocate (mflux_fc (numbasin)) + allocate (zgrad_dn (numbasin)) + allocate (sum_hflux_riv (numbasin)) + allocate (sum_mflux_riv (numbasin)) + allocate (sum_zgrad_riv (numbasin)) + allocate (bsnfilter (numbasin)) + + IF (DEF_Reservoir_Method > 0) THEN + allocate (hflux_resv (numbasin)) + allocate (mflux_resv (numbasin)) + ENDIF + + ENDIF + + allocate (dt_res (numrivsys)) + allocate (dt_all (numrivsys)) + + ntimestep_riverlake = 0 + + dt_res(:) = dt + + DO WHILE (any(dt_res > 0)) + + ntimestep_riverlake = ntimestep_riverlake + 1 + + DO i = 1, numbasin + bsnfilter(i) = dt_res(irivsys(i)) > 0 + IF (bsnfilter(i)) THEN + sum_hflux_riv(i) = 0. + sum_mflux_riv(i) = 0. + sum_zgrad_riv(i) = 0. + ENDIF + ENDDO + + WHERE (bsnfilter) ntacc_bsn = ntacc_bsn + 1 + + CALL pull_from_downstream (wdsrf_bsn, wdsrf_bsn_ds, bsnfilter) + CALL pull_from_downstream (veloc_riv, veloc_riv_ds, bsnfilter) + CALL pull_from_downstream (momen_riv, momen_riv_ds, bsnfilter) + + ! velocity in ocean or inland depression is assumed to be 0. + IF (numbasin > 0) THEN + WHERE (riverdown <= 0) + veloc_riv_ds = 0. + END WHERE + ENDIF + + dt_all(:) = dt_res(:) + + DO i = 1, numbasin + + IF (.not. bsnfilter(i)) CYCLE + + IF (riverdown(i) >= 0) THEN + + IF (riverdown(i) > 0) THEN + ! both elements are dry. + IF ((wdsrf_bsn(i) < RIVERMIN) .and. (wdsrf_bsn_ds(i) < RIVERMIN)) THEN + hflux_fc(i) = 0 + mflux_fc(i) = 0 + zgrad_dn(i) = 0 + CYCLE + ENDIF + ENDIF + + ! reconstruction of height of water near interface + IF (riverdown(i) > 0) THEN + bedelv_fc = max(bedelv(i), bedelv_ds(i)) + IF ((lake_type(i) == 2) .or. (lake_type(i) == 3)) THEN + ! for reservoir (type=2) or controlled lake (type=3) + IF ((DEF_Reservoir_Method > 0) & + .and. (year >= dam_build_year(bsn2resv(i)))) THEN + bedelv_fc = max(bedelv_fc, dam_elv(bsn2resv(i))) + ENDIF + ENDIF + height_up = max(0., wdsrf_bsn(i) +bedelv(i) -bedelv_fc) + height_dn = max(0., wdsrf_bsn_ds(i)+bedelv_ds(i)-bedelv_fc) + ELSEIF (riverdown(i) == 0) THEN ! for river mouth + bedelv_fc = bedelv(i) + height_up = wdsrf_bsn(i) + ! sea level is assumed to be 0. and sea bed is assumed to be negative infinity. + height_dn = max(0., - bedelv_fc) + ENDIF + + ! velocity at river downstream face (middle region in Riemann problem) + veloct_fc = 0.5 * (veloc_riv(i) + veloc_riv_ds(i)) & + + sqrt(grav * height_up) - sqrt(grav * height_dn) + + ! height of water at downstream face (middle region in Riemann problem) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn)) & + + 0.25 * (veloc_riv(i) - veloc_riv_ds(i))) ** 2 + + IF (height_up > 0) THEN + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + ELSE + vwave_up = veloc_riv_ds(i) - 2.0 * sqrt(grav*height_dn) + ENDIF + + IF (height_dn > 0) THEN + vwave_dn = max(veloc_riv_ds(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + ELSE + vwave_dn = veloc_riv(i) + 2.0 * sqrt(grav*height_up) + ENDIF + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_riv_ds(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_riv_ds(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + zgrad_dn(i) = outletwth(i) * 0.5*grav * height_dn**2 + + ELSEIF (riverdown(i) == -3) THEN + ! downstream is not in model region. + ! assume: 1. downstream river bed is equal to this river bed. + ! 2. downstream water surface is equal to this river depth. + ! 3. downstream water velocity is equal to this velocity. + + veloc_riv(i) = max(veloc_riv(i), 0.) + + IF (wdsrf_bsn(i) > riverdpth(i)) THEN + + ! reconstruction of height of water near interface + height_up = wdsrf_bsn(i) + height_dn = riverdpth(i) + + veloct_fc = veloc_riv(i) + sqrt(grav * height_up) - sqrt(grav * height_dn) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn))) ** 2 + + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + vwave_dn = max(veloc_riv(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_riv(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_riv(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + ELSE + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + ELSEIF (riverdown(i) == -1) THEN ! inland depression + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + IF ((lake_id(i) < 0) .and. (hflux_fc(i) < 0)) THEN + dt_this = dt_all(irivsys(i)) + hflux_fc(i) = & + max(hflux_fc(i), (height_up-height_dn) / dt_this * sum(hillslope_basin(i)%area, & + mask = hillslope_basin(i)%hand <= wdsrf_bsn(i) + handmin(i))) + ENDIF + + ! reservoir operation. + IF (DEF_Reservoir_Method > 0) THEN + IF (lake_type(i) == 2) THEN + IF (year >= dam_build_year(bsn2resv(i))) THEN + hflux_fc(i) = 0. + mflux_fc(i) = 0. + zgrad_dn(i) = 0. + ENDIF + ENDIF + ENDIF + + sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) + sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) + + ENDDO + + IF (numbasin > 0) THEN + hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn + ENDIF + + CALL push_to_downstream (hflux_fc, sum_hflux_riv, bsnfilter) + CALL push_to_downstream (mflux_fc, sum_mflux_riv, bsnfilter) + CALL push_to_downstream (zgrad_dn, sum_zgrad_riv, bsnfilter) + + IF (numbasin > 0) THEN + hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn + ENDIF + + ! reservoir operation. + IF (DEF_Reservoir_Method > 0) THEN + + DO i = 1, numbasin + + hflux_resv(i) = 0. + mflux_resv(i) = 0. + + IF (bsnfilter(i)) THEN + IF ((lake_type(i) == 2) .and. (riverdown(i) /= -1)) THEN + IF (year >= dam_build_year(bsn2resv(i))) THEN + + irsv = bsn2resv(i) + qresv_in(irsv) = - sum_hflux_riv(i) + volresv (irsv) = lakeinfo(i)%volume( wdsrf_bsn(i) ) + + IF (volresv(irsv) > 1.e-4 * volresv_total(irsv)) THEN + CALL reservoir_operation (DEF_Reservoir_Method, & + irsv, qresv_in(irsv), volresv(irsv), qresv_out(irsv)) + ELSE + qresv_out (irsv) = 0. + ENDIF + + hflux_fc(i) = qresv_out(irsv) + mflux_fc(i) = qresv_out(irsv) * sqrt(2*grav*wdsrf_bsn(i)) + + sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) + sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) + + hflux_resv(i) = - hflux_fc(i) + mflux_resv(i) = - mflux_fc(i) + + ENDIF + ENDIF + ENDIF + ENDDO + + CALL push_to_downstream (hflux_resv, sum_hflux_riv, bsnfilter) + CALL push_to_downstream (mflux_resv, sum_mflux_riv, bsnfilter) + + ENDIF + + DO i = 1, numbasin + + IF (.not. bsnfilter(i)) CYCLE + + dt_this = dt_all(irivsys(i)) + + ! constraint 1: CFL condition (only for rivers) + IF ((lake_id(i) == 0) .and. (riverdown(i) /= -1)) THEN + IF ((veloc_riv(i) /= 0.) .or. (wdsrf_bsn(i) > 0.)) THEN + dt_this = min(dt_this, riverlen(i)/(abs(veloc_riv(i))+sqrt(grav*wdsrf_bsn(i)))*0.8) + ENDIF + ENDIF + + ! constraint 2: Avoid negative values of water + IF (sum_hflux_riv(i) > 0) THEN + IF (lake_id(i) <= 0) THEN + ! for river or lake catchment + totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand) & + * hillslope_basin(i)%area, & + mask = wdsrf_bsn(i) + handmin(i) >= hillslope_basin(i)%hand) + ELSEIF (lake_id(i) > 0) THEN + ! for lake + totalvolume = lakeinfo(i)%volume(wdsrf_bsn(i)) + ENDIF + + dt_this = min(dt_this, totalvolume / sum_hflux_riv(i)) + + ENDIF + + ! constraint 3: Avoid change of flow direction (only for rivers) + IF (lake_id(i) == 0) THEN + IF ((abs(veloc_riv(i)) > 0.1) & + .and. (veloc_riv(i) * (sum_mflux_riv(i)-sum_zgrad_riv(i)) > 0)) THEN + dt_this = min(dt_this, & + abs(momen_riv(i) * riverarea(i) / (sum_mflux_riv(i)-sum_zgrad_riv(i)))) + ENDIF + ENDIF + + dt_all(irivsys(i)) = min(dt_this, dt_all(irivsys(i))) + + ENDDO + +#ifdef USEMPI + IF (riversystem /= -1) THEN + CALL mpi_allreduce (MPI_IN_PLACE, dt_all, 1, MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err) + ENDIF +#endif + + DO i = 1, numbasin + + IF (.not. bsnfilter(i)) CYCLE + + IF (lake_id(i) <= 0) THEN + ! rivers or lake catchments + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + allocate (hmask (hillslope_basin(i)%nhru)) + + totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand) & + * hillslope_basin(i)%area, & + mask = wdsrf_bsn(i) + handmin(i) >= hillslope_basin(i)%hand) + + totalvolume = totalvolume - sum_hflux_riv(i) * dt_all(irivsys(i)) + + IF (totalvolume < VOLUMEMIN) THEN + DO j = 1, hillslope_basin(i)%nhru + IF (hillslope_basin(i)%hand(j) <= wdsrf_bsn(i) + handmin(i)) THEN + wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) & + - (wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand(j)) + ENDIF + ENDDO + wdsrf_bsn(i) = 0 + ELSE + + dvol = sum_hflux_riv(i) * dt_all(irivsys(i)) + IF (dvol > VOLUMEMIN) THEN + DO WHILE (dvol > VOLUMEMIN) + hmask = hillslope_basin(i)%hand < wdsrf_bsn(i) + handmin(i) + nextl = maxval(hillslope_basin(i)%hand, mask = hmask) + nexta = sum (hillslope_basin(i)%area, mask = hmask) + nextv = nexta * (wdsrf_bsn(i)+handmin(i)-nextl) + IF (nextv > dvol) THEN + ddep = dvol/nexta + dvol = 0. + ELSE + ddep = wdsrf_bsn(i)+handmin(i) - nextl + dvol = dvol - nextv + ENDIF + + wdsrf_bsn(i) = wdsrf_bsn(i) - ddep + + DO j = 1, hillslope_basin(i)%nhru + IF (hmask(j)) THEN + wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) - ddep + ENDIF + ENDDO + ENDDO + ELSEIF (dvol < -VOLUMEMIN) THEN + hmask = .true. + nexta = 0. + DO WHILE (dvol < -VOLUMEMIN) + IF (any(hmask)) THEN + j = minloc(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he), 1, mask = hmask) + nexta = nexta + hillslope_basin(i)%area(j) + hmask(j) = .false. + ENDIF + IF (any(hmask)) THEN + nextl = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he), mask = hmask) + nextv = nexta*(nextl-(wdsrf_bsn(i)+handmin(i))) + IF ((-dvol) > nextv) THEN + ddep = nextl - (wdsrf_bsn(i)+handmin(i)) + dvol = dvol + nextv + ELSE + ddep = (-dvol)/nexta + dvol = 0. + ENDIF + ELSE + ddep = (-dvol)/nexta + dvol = 0. + ENDIF + + wdsrf_bsn(i) = wdsrf_bsn(i) + ddep + + DO j = 1, hillslope_basin(i)%nhru + IF (.not. hmask(j)) THEN + wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) + ddep + ENDIF + ENDDO + ENDDO + ENDIF + + ENDIF + deallocate(hmask) + + ELSE + totalvolume = lakeinfo(i)%volume(wdsrf_bsn(i)) + totalvolume = totalvolume - sum_hflux_riv(i) * dt_all(irivsys(i)) + wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume) + ENDIF + + IF ((lake_id(i) /= 0) .or. (wdsrf_bsn(i) < RIVERMIN)) THEN + momen_riv(i) = 0 + veloc_riv(i) = 0 + ELSE + friction = grav * nmanning_riv**2 / wdsrf_bsn(i)**(7.0/3.0) * abs(momen_riv(i)) + momen_riv(i) = (momen_riv(i) & + - (sum_mflux_riv(i) - sum_zgrad_riv(i)) / riverarea(i) * dt_all(irivsys(i))) & + / (1 + friction * dt_all(irivsys(i))) + veloc_riv(i) = momen_riv(i) / wdsrf_bsn(i) + ENDIF + + ! inland depression river + IF ((lake_id(i) == 0) .and. (riverdown(i) == -1)) THEN + momen_riv(i) = min(0., momen_riv(i)) + veloc_riv(i) = min(0., veloc_riv(i)) + ENDIF + + veloc_riv(i) = min(veloc_riv(i), 20.) + veloc_riv(i) = max(veloc_riv(i), -20.) + + ENDDO + + DO i = 1, numbasin + IF (bsnfilter(i)) THEN + + wdsrf_bsn_ta (i) = wdsrf_bsn_ta (i) + wdsrf_bsn(i) * dt_all(irivsys(i)) + momen_riv_ta (i) = momen_riv_ta (i) + momen_riv(i) * dt_all(irivsys(i)) + discharge_ta (i) = discharge_ta (i) + hflux_fc (i) * dt_all(irivsys(i)) + + IF (lake_id(i) > 0) THEN ! for lakes + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + DO j = hs, he + wdsrf_bsnhru(j) = & + max(wdsrf_bsn(i) - (lakeinfo(i)%depth(1) - lakeinfo(i)%depth0(j-hs+1)), 0.) + wdsrf_bsnhru_ta(j) = wdsrf_bsnhru_ta(j) + wdsrf_bsnhru(j) * dt_all(irivsys(i)) + ENDDO + ENDIF + + IF (DEF_Reservoir_Method > 0) THEN + IF (lake_type(i) == 2) THEN + IF (year >= dam_build_year(bsn2resv(i))) THEN + irsv = bsn2resv(i) + volresv_ta (irsv) = volresv_ta (irsv) + volresv (irsv) * dt_all(irivsys(i)) + qresv_in_ta (irsv) = qresv_in_ta (irsv) + qresv_in (irsv) * dt_all(irivsys(i)) + qresv_out_ta(irsv) = qresv_out_ta(irsv) + qresv_out(irsv) * dt_all(irivsys(i)) + ENDIF + ENDIF + ENDIF + + ENDIF + ENDDO + + dt_res = dt_res - dt_all + + ENDDO + + IF (numbasin > 0) wdsrf_bsn_prev(:) = wdsrf_bsn(:) + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, ntimestep_riverlake, 1, MPI_INTEGER, MPI_MAX, p_comm_worker, p_err) +#endif + + IF (allocated(wdsrf_bsn_ds )) deallocate(wdsrf_bsn_ds ) + IF (allocated(veloc_riv_ds )) deallocate(veloc_riv_ds ) + IF (allocated(momen_riv_ds )) deallocate(momen_riv_ds ) + IF (allocated(hflux_fc )) deallocate(hflux_fc ) + IF (allocated(mflux_fc )) deallocate(mflux_fc ) + IF (allocated(zgrad_dn )) deallocate(zgrad_dn ) + IF (allocated(hflux_resv )) deallocate(hflux_resv ) + IF (allocated(mflux_resv )) deallocate(mflux_resv ) + IF (allocated(sum_hflux_riv)) deallocate(sum_hflux_riv) + IF (allocated(sum_mflux_riv)) deallocate(sum_mflux_riv) + IF (allocated(sum_zgrad_riv)) deallocate(sum_zgrad_riv) + IF (allocated(bsnfilter )) deallocate(bsnfilter ) + + ENDIF + + END SUBROUTINE river_lake_flow + +END MODULE MOD_Catch_RiverLakeFlow +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 new file mode 100644 index 0000000000..a24cc0d483 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 @@ -0,0 +1,1145 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_RiverLakeNetwork +!-------------------------------------------------------------------------------- +! DESCRIPTION: +! +! River networks: data and communication subroutines. +! +! Created by Shupeng Zhang, May 2023 +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global, only: spval + USE MOD_Pixelset + USE MOD_Catch_BasinNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_Vars_TimeVariables + IMPLICIT NONE + + ! -- river parameters -- + real(r8), allocatable :: riverlen (:) + real(r8), allocatable :: riverelv (:) + real(r8), allocatable :: riverwth (:) + real(r8), allocatable :: riverarea (:) + real(r8), allocatable :: riverdpth (:) + + real(r8), allocatable :: basinelv (:) + real(r8), allocatable :: bedelv (:) + real(r8), allocatable :: handmin (:) + + real(r8), allocatable :: wtsrfelv (:) + + ! index of downstream river + ! > 0 : other catchment; 0 : river mouth; -1 : inland depression + integer, allocatable :: riverdown (:) + integer, allocatable :: ilocdown (:) + logical, allocatable :: to_lake (:) + + real(r8), allocatable :: riverlen_ds (:) + real(r8), allocatable :: wtsrfelv_ds (:) + real(r8), allocatable :: riverwth_ds (:) + real(r8), allocatable :: bedelv_ds (:) + + real(r8), allocatable :: outletwth (:) + + integer :: riversystem + + integer :: numrivsys + integer, allocatable :: irivsys (:) + +#ifdef USEMPI + integer :: p_comm_rivsys + + integer :: numbsnlink + integer, allocatable :: linkbindex (:) + + integer :: nlink_me + integer, allocatable :: linkpush (:) + integer, allocatable :: linkpull (:) +#endif + + ! -- lake data type -- + type :: lake_info_type + integer :: nsub + real(r8), allocatable :: area0 (:) ! area data in HRU order + real(r8), allocatable :: area (:) ! area data in the order from deepest to shallowest HRU + real(r8), allocatable :: depth0 (:) ! depth data in HRU order + real(r8), allocatable :: depth (:) ! depth data in the order from deepest to shallowest HRU + ! a curve describing the relationship between depth of water from lake bottom and total water volume + ! the i-th value corresponds to the volume when water depth is at i-th depth + real(r8), allocatable :: dep_vol_curve (:) + CONTAINS + procedure, PUBLIC :: surface => retrieve_lake_surface_from_volume + procedure, PUBLIC :: volume => retrieve_lake_volume_from_surface + final :: lake_info_free_mem + END type lake_info_type + + ! -- lake information -- + type(lake_info_type), allocatable :: lakeinfo (:) + + ! -- information of HRU in basin -- + type(hillslope_network_type), pointer :: hillslope_basin (:) + + + ! ----- subroutines and functions ----- + PUBLIC :: river_lake_network_init + PUBLIC :: pull_from_downstream + PUBLIC :: push_to_downstream + PUBLIC :: calc_riverdepth_from_runoff + PUBLIC :: retrieve_lake_surface_from_volume + PUBLIC :: river_lake_network_final + +CONTAINS + + ! ---------- + SUBROUTINE river_lake_network_init (patcharea) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_Mesh + USE MOD_Pixel + USE MOD_LandElm + USE MOD_LandHRU + USE MOD_LandPatch + USE MOD_ElementNeighbour + USE MOD_DataType + USE MOD_Utils + USE MOD_UserDefFun + USE MOD_Vars_TimeInvariants, only: lakedepth + IMPLICIT NONE + + real(r8), intent(in) :: patcharea (:) + + ! Local Variables + character(len=256) :: river_file, rivdpt_file + logical :: use_calc_rivdpt + + integer :: totalnumbasin, ibasin, jbasin, inb, iloc, ielm, i, j, ilink + integer :: iworker, mesg(2), isrc, idest, nrecv + +#ifdef USEMPI + integer :: nblink_all + integer, allocatable :: linkbindex_all (:) + integer, allocatable :: linkrivmth_all (:) +#endif + + logical , allocatable :: is_link (:) + logical , allocatable :: link_on_me (:) + + integer :: nnode + integer, allocatable :: route(:) + + integer , allocatable :: icache (:) + real(r8), allocatable :: rcache (:) + logical , allocatable :: lcache (:) + + integer, allocatable :: bindex(:), addrbasin(:), addrdown(:) + integer, allocatable :: basin_sorted(:), basin_order(:), order (:) + + logical, allocatable :: bsnfilter(:) + + ! for lakes + integer :: ps, pe, nsublake, hs, he, ihru + integer, allocatable :: all_lake_id (:), lake_id_elm (:) + integer , allocatable :: lakedown_id_elm(:), lakedown_id_bsn (:) + real(r8), allocatable :: lakedepth_hru (:), lakedepth_bsnhru(:) + real(r8), allocatable :: lakeoutlet_elm (:), lakeoutlet_bsn (:) + real(r8), allocatable :: unitarea_hru (:), unitarea_bsnhru (:) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + use_calc_rivdpt = DEF_USE_EstimatedRiverDepth + river_file = DEF_CatchmentMesh_data + + ! step 1: read in parameters from file. + IF (p_is_master) THEN + + CALL ncio_read_serial (river_file, 'lake_id', all_lake_id) + + CALL ncio_read_serial (river_file, 'basin_downstream', riverdown) + CALL ncio_read_serial (river_file, 'river_length' , riverlen ) + CALL ncio_read_serial (river_file, 'river_elevation' , riverelv ) + CALL ncio_read_serial (river_file, 'basin_elevation' , basinelv ) + + IF (.not. use_calc_rivdpt) THEN + CALL ncio_read_serial (river_file, 'river_depth' , riverdpth) + ENDIF + + riverlen = riverlen * 1.e3 ! km to m + + totalnumbasin = size(riverdown) + allocate (to_lake (totalnumbasin)) + to_lake = .false. + DO i = 1, totalnumbasin + IF (riverdown(i) > 0) THEN + to_lake(i) = all_lake_id(riverdown(i)) > 0 + ENDIF + ENDDO + + ENDIF + + ! step 2: Estimate river depth by using runoff data. + IF (use_calc_rivdpt) THEN + CALL calc_riverdepth_from_runoff (patcharea) + ENDIF + +#ifdef USEMPI + IF (p_is_master) THEN + + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + + allocate (bindex (nrecv)) + allocate (icache (nrecv)) + allocate (rcache (nrecv)) + allocate (lcache (nrecv)) + + CALL mpi_recv (bindex, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + idest = isrc + + icache = riverdown(bindex) + CALL mpi_send (icache, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + lcache = to_lake(bindex) + CALL mpi_send (lcache, nrecv, MPI_LOGICAL, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = riverlen(bindex) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = riverelv(bindex) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = riverdpth(bindex) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + rcache = basinelv(bindex) + CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (bindex) + deallocate (icache) + deallocate (rcache) + deallocate (lcache) + + ENDIF + ENDDO + + deallocate (all_lake_id) + + ENDIF + + IF (p_is_worker) THEN + + mesg(1:2) = (/p_iam_glb, numbasin/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numbasin > 0) THEN + CALL mpi_send (basinindex, numbasin, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + + allocate (riverdown (numbasin)) + CALL mpi_recv (riverdown, numbasin, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (to_lake (numbasin)) + CALL mpi_recv (to_lake, numbasin, MPI_LOGICAL, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (riverlen (numbasin)) + CALL mpi_recv (riverlen, numbasin, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (riverelv (numbasin)) + CALL mpi_recv (riverelv, numbasin, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (riverdpth (numbasin)) + CALL mpi_recv (riverdpth, numbasin, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (basinelv (numbasin)) + CALL mpi_recv (basinelv, numbasin, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + IF (numbasin > 0) THEN + + riverdown = riverdown(basinindex) + to_lake = to_lake (basinindex) + riverlen = riverlen (basinindex) + riverelv = riverelv (basinindex) + riverdpth = riverdpth(basinindex) + basinelv = basinelv (basinindex) + + ENDIF +#endif + +#ifdef USEMPI + ! get address of basins + IF (p_is_master) THEN + + allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 + + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + allocate (bindex (nrecv)) + + CALL mpi_recv (bindex, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + addrbasin(bindex) = isrc + + deallocate(bindex) + ENDIF + + ENDDO + + ELSEIF (p_is_worker) THEN + + mesg(1:2) = (/p_iam_glb, numbasin/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numbasin > 0) THEN + CALL mpi_send (basinindex, numbasin, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + ENDIF + + + IF (p_is_master) THEN + + allocate (addrdown (totalnumbasin)) + allocate (is_link (totalnumbasin)); is_link = .false. + + DO ibasin = 1, totalnumbasin + IF (riverdown(ibasin) >= 1) THEN + addrdown(ibasin) = addrbasin(riverdown(ibasin)) + IF (addrdown(ibasin) /= addrbasin(ibasin)) THEN + is_link(riverdown(ibasin)) = .true. + ENDIF + ELSE + addrdown(ibasin) = addrbasin(ibasin) + ENDIF + ENDDO + + nblink_all = count(is_link) + + IF (nblink_all > 0) THEN + allocate (linkbindex_all (nblink_all)) + allocate (linkrivmth_all (nblink_all)) + linkbindex_all = pack((/(ibasin, ibasin = 1, totalnumbasin)/), mask = is_link) + linkrivmth_all = pack(rivermouth, mask = is_link) + ENDIF + + deallocate (addrdown) + deallocate (is_link ) + + write(*,'(/,A,I5,A,/)') 'There are ', nblink_all, ' links between processors.' + + ENDIF + + CALL mpi_bcast (nblink_all, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (nblink_all > 0) THEN + IF (.not. allocated(linkbindex_all)) allocate (linkbindex_all (nblink_all)) + IF (.not. allocated(linkrivmth_all)) allocate (linkrivmth_all (nblink_all)) + CALL mpi_bcast (linkbindex_all, nblink_all, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (linkrivmth_all, nblink_all, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + ENDIF +#endif + + IF (p_is_worker) THEN + + IF (numbasin > 0) THEN + allocate (basin_sorted (numbasin)) + allocate (basin_order (numbasin)) + basin_sorted = basinindex + basin_order = (/(ibasin, ibasin = 1, numbasin)/) + + CALL quicksort (numbasin, basin_sorted, basin_order) + ENDIF + + riversystem = -1 + +#ifdef USEMPI + IF (nblink_all > 0) THEN + DO ibasin = 1, numbasin + + iloc = find_in_sorted_list1 (riverdown(ibasin), nblink_all, linkbindex_all) + IF (iloc <= 0) THEN + iloc = find_in_sorted_list1 (basinindex(ibasin), nblink_all, linkbindex_all) + ENDIF + + IF (iloc > 0) THEN + IF (riversystem == -1) THEN + riversystem = linkrivmth_all(iloc) + ELSEIF (riversystem /= linkrivmth_all(iloc)) THEN + write(*,*) 'Warning: river system allocation error!' + ENDIF + ENDIF + ENDDO + ENDIF + + IF (riversystem /= -1) THEN + numbsnlink = count(linkrivmth_all == riversystem) + allocate (linkbindex (numbsnlink)) + linkbindex = pack(linkbindex_all, linkrivmth_all == riversystem) + + allocate (link_on_me (numbsnlink)); link_on_me = .false. + + DO ibasin = 1, numbsnlink + iloc = find_in_sorted_list1 (linkbindex(ibasin), numbasin, basin_sorted) + IF (iloc > 0) THEN + link_on_me(ibasin) = .true. + ENDIF + ENDDO + + nlink_me = count(link_on_me) + + IF (nlink_me > 0) THEN + allocate (linkpush (nlink_me)) + allocate (linkpull (nlink_me)) + ilink = 0 + DO ibasin = 1, numbsnlink + IF (link_on_me(ibasin)) THEN + ilink = ilink + 1 + iloc = find_in_sorted_list1 (linkbindex(ibasin), numbasin, basin_sorted) + linkpush(ilink) = basin_order(iloc) + linkpull(ilink) = ibasin + ENDIF + ENDDO + ENDIF + + deallocate (link_on_me) + ENDIF + + IF (riversystem /= -1) THEN + CALL mpi_comm_split (p_comm_worker, riversystem, p_iam_worker, p_comm_rivsys, p_err) + ELSE + CALL mpi_comm_split (p_comm_worker, MPI_UNDEFINED, p_iam_worker, p_comm_rivsys, p_err) + ENDIF +#endif + + + IF (numbasin > 0) THEN + + allocate (ilocdown (numbasin)); ilocdown(:) = 0 + + DO ibasin = 1, numbasin + IF (riverdown(ibasin) > 0) THEN + iloc = find_in_sorted_list1 (riverdown(ibasin), numbasin, basin_sorted) + IF (iloc > 0) THEN + ilocdown(ibasin) = basin_order(iloc) +#ifdef USEMPI + ELSE + iloc = find_in_sorted_list1 (riverdown(ibasin), numbsnlink, linkbindex) + ilocdown(ibasin) = - iloc +#endif + ENDIF + ENDIF + ENDDO + ENDIF + + + IF (numbasin > 0) allocate (irivsys (numbasin)) + IF (numbasin > 0) allocate (route (numbasin)) + + IF (riversystem == -1) THEN + irivsys(:) = -1 + numrivsys = 0 + DO ibasin = 1, numbasin + IF (irivsys(ibasin) == -1) THEN + + jbasin = ibasin + nnode = 1 + route(nnode) = jbasin + DO WHILE ((riverdown(jbasin) > 0) .and. (irivsys(jbasin) == -1)) + nnode = nnode + 1 + route(nnode) = jbasin + jbasin = ilocdown(jbasin) + ENDDO + + IF (irivsys(jbasin) == -1) THEN + numrivsys = numrivsys + 1 + irivsys(jbasin) = numrivsys + ENDIF + + irivsys(route(1:nnode)) = irivsys(jbasin) + + ENDIF + ENDDO + ELSE + numrivsys = 1 + irivsys(:) = 1 + ENDIF + + IF (numbasin > 0) deallocate (route) + + ENDIF + +#ifdef USEMPI + IF (allocated (linkbindex_all)) deallocate (linkbindex_all) + IF (allocated (linkrivmth_all)) deallocate (linkrivmth_all) +#endif + + + CALL hillslope_network_init (numbasin, basinindex, hillslope_basin) + + IF (p_is_worker) THEN + + IF (numelm > 0) allocate (lake_id_elm (numelm)) + IF (numhru > 0) allocate (lakedepth_hru (numhru)) + IF (numbsnhru > 0) allocate (lakedepth_bsnhru(numbsnhru)) + IF (numelm > 0) allocate (lakedown_id_elm (numelm)) + IF (numbasin > 0) allocate (lakedown_id_bsn (numbasin)) + IF (numelm > 0) allocate (lakeoutlet_elm (numelm)) + IF (numbasin > 0) allocate (lakeoutlet_bsn (numbasin)) + IF (numhru > 0) allocate (unitarea_hru (numhru)) + IF (numbsnhru > 0) allocate (unitarea_bsnhru (numbsnhru)) + + DO ibasin = 1, numbasin + + lakedown_id_bsn(ibasin) = 0 + + IF ((lake_id(ibasin) /= 0) .and. (to_lake(ibasin))) THEN + ! lake to lake .or. lake catchment to lake + lakedown_id_bsn(ibasin) = riverdown(ibasin) + ENDIF + IF ((lake_id(ibasin) > 0) .and. (riverdown(ibasin) == 0)) THEN + ! lake to ocean + lakedown_id_bsn(ibasin) = -9 ! -9 is ocean + ENDIF + ENDDO + + ENDIF + + CALL worker_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) + CALL worker_push_data (push_bsn2elm, lakedown_id_bsn, lakedown_id_elm, -9999) + + IF (p_is_worker) THEN + + unitarea_hru = 0. + lakedepth_hru = 0. + lakeoutlet_elm = 0. + + DO ielm = 1, numelm + hs = elm_hru%substt(ielm) + he = elm_hru%subend(ielm) + DO ihru = hs, he + ps = hru_patch%substt(ihru) + pe = hru_patch%subend(ihru) + + unitarea_hru(ihru) = sum(patcharea(ps:pe)) + + IF (lake_id_elm(ielm) > 0) THEN + lakedepth_hru(ihru) = maxval(lakedepth(ps:pe)) + ENDIF + ENDDO + + IF (lakedown_id_elm(ielm) /= 0) THEN + inb = findloc_ud(elementneighbour(ielm)%glbindex == lakedown_id_elm(ielm)) + IF (inb > 0) lakeoutlet_elm(ielm) = elementneighbour(ielm)%lenbdr(inb) + ENDIF + ENDDO + ENDIF + + CALL worker_push_data (push_elm2bsn, lakeoutlet_elm, lakeoutlet_bsn, spval) + + CALL worker_push_data (push_elmhru2bsnhru, unitarea_hru, unitarea_bsnhru, spval) + CALL worker_push_data (push_elmhru2bsnhru, lakedepth_hru, lakedepth_bsnhru, spval) + + IF (allocated (lake_id_elm )) deallocate (lake_id_elm ) + IF (allocated (lakedepth_hru )) deallocate (lakedepth_hru ) + IF (allocated (lakedown_id_elm)) deallocate (lakedown_id_elm) + IF (allocated (lakedown_id_bsn)) deallocate (lakedown_id_bsn) + IF (allocated (lakeoutlet_elm )) deallocate (lakeoutlet_elm ) + IF (allocated (unitarea_hru )) deallocate (unitarea_hru ) + + IF (p_is_worker) THEN + + IF (numbasin > 0) THEN + + allocate (lakeinfo (numbasin)) + allocate (riverarea (numbasin)) + allocate (riverwth (numbasin)) + allocate (bedelv (numbasin)) + allocate (handmin (numbasin)) + allocate (wtsrfelv (numbasin)) + allocate (riverlen_ds (numbasin)) + allocate (wtsrfelv_ds (numbasin)) + allocate (riverwth_ds (numbasin)) + allocate (bedelv_ds (numbasin)) + allocate (outletwth (numbasin)) + + DO ibasin = 1, numbasin + + hs = basin_hru%substt(ibasin) + he = basin_hru%subend(ibasin) + + IF (lake_id(ibasin) == 0) THEN + + hillslope_basin(ibasin)%area = unitarea_bsnhru(hs:he) + + riverarea(ibasin) = hillslope_basin(ibasin)%area(1) + riverwth (ibasin) = riverarea(ibasin) / riverlen(ibasin) + + ! modify height above nearest drainage data to consider river depth + IF (hillslope_basin(ibasin)%nhru > 1) THEN + hillslope_basin(ibasin)%hand(2:) = & + hillslope_basin(ibasin)%hand(2:) + riverdpth(ibasin) + ENDIF + + wtsrfelv(ibasin) = riverelv(ibasin) + bedelv (ibasin) = riverelv(ibasin) - riverdpth(ibasin) + + handmin(ibasin) = minval(hillslope_basin(ibasin)%hand) + + ELSEIF (lake_id(ibasin) > 0) THEN + + wtsrfelv(ibasin) = basinelv(ibasin) + + bedelv(ibasin) = basinelv(ibasin) - maxval(lakedepth_bsnhru(hs:he)) + + nsublake = he - hs + 1 + lakeinfo(ibasin)%nsub = nsublake + + allocate (lakeinfo(ibasin)%area0 (nsublake)) + allocate (lakeinfo(ibasin)%area (nsublake)) + allocate (lakeinfo(ibasin)%depth0 (nsublake)) + allocate (lakeinfo(ibasin)%depth (nsublake)) + + lakeinfo(ibasin)%area = unitarea_bsnhru (hs:he) + lakeinfo(ibasin)%depth = lakedepth_bsnhru(hs:he) + + ! area data in HRU order + lakeinfo(ibasin)%area0 = lakeinfo(ibasin)%area + + ! depth data in HRU order + lakeinfo(ibasin)%depth0 = lakeinfo(ibasin)%depth + + allocate (order (1:nsublake)) + order = (/(i, i = 1, nsublake)/) + + CALL quicksort (nsublake, lakeinfo(ibasin)%depth, order) + + ! area data in depth order + lakeinfo(ibasin)%area = lakeinfo(ibasin)%area(order) + + ! adjust to be from deepest to shallowest + lakeinfo(ibasin)%depth = lakeinfo(ibasin)%depth(nsublake:1:-1) + lakeinfo(ibasin)%area = lakeinfo(ibasin)%area (nsublake:1:-1) + + allocate (lakeinfo(ibasin)%dep_vol_curve (nsublake)) + + lakeinfo(ibasin)%dep_vol_curve(1) = 0 + DO i = 2, nsublake + lakeinfo(ibasin)%dep_vol_curve(i) = & + lakeinfo(ibasin)%dep_vol_curve(i-1) & + + sum(lakeinfo(ibasin)%area(1:i-1)) & + * (lakeinfo(ibasin)%depth(i-1)-lakeinfo(ibasin)%depth(i)) + ENDDO + + riverlen(ibasin) = 0. + + deallocate (order) + + ELSEIF (lake_id(ibasin) < 0) THEN + + hillslope_basin(ibasin)%area = unitarea_bsnhru(hs:he) + handmin(ibasin) = minval(hillslope_basin(ibasin)%hand) + + ENDIF + + ENDDO + ENDIF + + IF (numbasin > 0) THEN + allocate(bsnfilter (numbasin)) + bsnfilter(:) = .true. + ENDIF + + CALL pull_from_downstream (riverlen, riverlen_ds, bsnfilter) + CALL pull_from_downstream (wtsrfelv, wtsrfelv_ds, bsnfilter) + CALL pull_from_downstream (riverwth, riverwth_ds, bsnfilter) + CALL pull_from_downstream (bedelv , bedelv_ds , bsnfilter) + + IF (allocated(bsnfilter)) deallocate(bsnfilter) + + DO ibasin = 1, numbasin + IF (lake_id(ibasin) < 0) THEN + bedelv(ibasin) = wtsrfelv_ds(ibasin) + minval(hillslope_basin(ibasin)%hand) + ENDIF + ENDDO + + DO ibasin = 1, numbasin + IF (lake_id(ibasin) == 0) THEN + IF ((to_lake(ibasin)) .or. (riverdown(ibasin) <= 0)) THEN + ! river to lake, ocean, inland depression or out of region + outletwth(ibasin) = riverwth(ibasin) + ELSE + ! river to river + outletwth(ibasin) = (riverwth(ibasin) + riverwth_ds(ibasin)) * 0.5 + ENDIF + ELSEIF (lake_id(ibasin) /= 0) THEN + IF ((.not. to_lake(ibasin)) .and. (riverdown(ibasin) /= 0)) THEN + IF (riverdown(ibasin) > 0) THEN + ! lake to river + outletwth(ibasin) = riverwth_ds(ibasin) + ELSEIF (riverdown(ibasin) == -1) THEN + ! lake is inland depression + outletwth(ibasin) = 0 + ENDIF + ELSEIF (to_lake(ibasin)) THEN + ! lake to lake .or. lake catchment to lake + outletwth(ibasin) = lakeoutlet_bsn(ibasin) + ELSEIF (riverdown(ibasin) == 0) THEN + ! lake to ocean + outletwth(ibasin) = lakeoutlet_bsn(ibasin) + ENDIF + ENDIF + ENDDO + + ENDIF + + IF (allocated (lakedepth_bsnhru)) deallocate (lakedepth_bsnhru) + IF (allocated (lakeoutlet_bsn )) deallocate (lakeoutlet_bsn ) + IF (allocated (unitarea_bsnhru )) deallocate (unitarea_bsnhru ) + + IF (allocated(basin_sorted )) deallocate(basin_sorted ) + IF (allocated(basin_order )) deallocate(basin_order ) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + IF (p_is_master) write(*,'(A)') 'Building river network information done.' + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE river_lake_network_init + + ! ----- pull data from downstream basin ----- + SUBROUTINE pull_from_downstream (datain, dataout, bsnfilter) + + USE MOD_SPMD_Task + + IMPLICIT NONE + + real(r8), intent(in) :: datain (:) + real(r8), intent(inout) :: dataout (:) + logical, intent(in) :: bsnfilter(:) + + ! local variables + integer :: i, ibasin + real(r8), allocatable :: datalink(:) + + IF (p_is_worker) THEN + +#ifdef USEMPI + IF (riversystem /= -1) THEN + allocate (datalink (numbsnlink)); datalink(:) = 0. + DO i = 1, nlink_me + datalink(linkpull(i)) = datain(linkpush(i)) + ENDDO + CALL mpi_allreduce (MPI_IN_PLACE, datalink, numbsnlink, MPI_REAL8, MPI_SUM, p_comm_rivsys, p_err) + ENDIF +#endif + + DO ibasin = 1, numbasin + IF (bsnfilter(ibasin)) THEN + IF (riverdown(ibasin) > 0) THEN + IF (ilocdown(ibasin) > 0) THEN + dataout(ibasin) = datain(ilocdown(ibasin)) +#ifdef USEMPI + ELSEIF (ilocdown(ibasin) < 0) THEN + dataout(ibasin) = datalink(-ilocdown(ibasin)) +#endif + ENDIF + ENDIF + ENDIF + ENDDO + +#ifdef USEMPI + IF (allocated(datalink)) deallocate (datalink) +#endif + ENDIF + + END SUBROUTINE pull_from_downstream + + ! ----- push data to downstream basin ----- + SUBROUTINE push_to_downstream (datain, dataout, bsnfilter) + + USE MOD_SPMD_Task + + IMPLICIT NONE + + real(r16), intent(in) :: datain (:) + real(r16), intent(inout) :: dataout (:) + logical, intent(in) :: bsnfilter(:) + + ! local variables + integer :: i, ibasin + real(r16), allocatable :: datalink(:) + + + IF (p_is_worker) THEN + +#ifdef USEMPI + IF (numbsnlink > 0) THEN + allocate (datalink (numbsnlink)); datalink(:) = 0. + ENDIF +#endif + + DO ibasin = 1, numbasin + IF (bsnfilter(ibasin)) THEN + IF (riverdown(ibasin) > 0) THEN + IF (ilocdown(ibasin) > 0) THEN + dataout(ilocdown(ibasin)) = dataout(ilocdown(ibasin)) + datain(ibasin) +#ifdef USEMPI + ELSEIF (ilocdown(ibasin) < 0) THEN + datalink(-ilocdown(ibasin)) = datalink(-ilocdown(ibasin)) + datain(ibasin) +#endif + ENDIF + ENDIF + ENDIF + ENDDO + +#ifdef USEMPI + IF (riversystem /= -1) THEN + + CALL mpi_allreduce (MPI_IN_PLACE, datalink, numbsnlink, MPI_REAL16, MPI_SUM, p_comm_rivsys, p_err) + + DO i = 1, nlink_me + dataout(linkpush(i)) = dataout(linkpush(i)) + datalink(linkpull(i)) + ENDDO + + deallocate (datalink) + ENDIF +#endif + ENDIF + + END SUBROUTINE push_to_downstream + + ! ----- retrieve river depth from runoff ----- + SUBROUTINE calc_riverdepth_from_runoff (patcharea) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Utils + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_Pixel + USE MOD_Block + USE MOD_Mesh + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_ElmVector + IMPLICIT NONE + + real(r8), intent(in) :: patcharea (:) + + ! Local Variables + character(len=256) :: file_rnof, file_rivdpt + type(grid_type) :: grid_rnof + type(block_data_real8_2d) :: f_rnof + type(spatial_mapping_type) :: mg2p_rnof + + real(r8), allocatable :: bsnrnof(:) , bsndis(:) + integer, allocatable :: nups_riv(:), iups_riv(:), b_up2down(:) + + integer :: i, j, ithis, ib, jb, iblkme, ps, pe + integer :: iwork, mesg(2), isrc, ndata + real(r8), allocatable :: rcache(:) + real(r8) :: myarea + + real(r8), parameter :: cH_rivdpt = 0.1 + real(r8), parameter :: pH_rivdpt = 0.5 + real(r8), parameter :: B0_rivdpt = 0.0 + real(r8), parameter :: Bmin_rivdpt = 1.0 + + + file_rnof = trim(DEF_dir_runtime) // '/runoff_clim.nc' + + CALL grid_rnof%define_from_file (file_rnof, 'lat', 'lon') + + CALL mg2p_rnof%build_arealweighted (grid_rnof, landelm) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_rnof, f_rnof) + CALL ncio_read_block (file_rnof, 'ro', grid_rnof, f_rnof) + + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + DO j = 1, grid_rnof%ycnt(jb) + DO i = 1, grid_rnof%xcnt(ib) + f_rnof%blk(ib,jb)%val(i,j) = max(f_rnof%blk(ib,jb)%val(i,j), 0.) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (numelm > 0) allocate (bsnrnof (numelm)) + ENDIF + + CALL mg2p_rnof%grid2pset (f_rnof, bsnrnof) + + IF (p_is_worker) THEN + IF (numelm > 0) THEN + bsnrnof = bsnrnof /24.0/3600.0 ! from m/day to m/s + DO i = 1, numelm + ps = elm_patch%substt(i) + pe = elm_patch%subend(i) + myarea = sum(patcharea(ps:pe)) + ! total runoff in basin, from m/s to m3/s + bsnrnof(i) = bsnrnof(i) * myarea + ENDDO + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_worker) THEN + mesg = (/p_iam_glb, numelm/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numelm > 0) THEN + CALL mpi_send (bsnrnof, numelm, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDIF + + IF (p_is_master) THEN + + allocate (bsnrnof (totalnumelm)) + + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate(rcache (ndata)) + + CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + bsnrnof(elm_data_address(p_itis_worker(isrc))%val) = rcache + + deallocate (rcache) + ENDIF + ENDDO + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + bsnrnof(elm_data_address(0)%val) = bsnrnof +#endif + + + IF (p_is_master) THEN + + allocate (nups_riv (totalnumelm)) + allocate (iups_riv (totalnumelm)) + allocate (b_up2down(totalnumelm)) + + allocate (bsndis (totalnumelm)) + + nups_riv(:) = 0 + DO i = 1, totalnumelm + j = riverdown(i) + IF (j > 0) THEN + nups_riv(j) = nups_riv(j) + 1 + ENDIF + ENDDO + + iups_riv(:) = 0 + ithis = 0 + DO i = 1, totalnumelm + IF (iups_riv(i) == nups_riv(i)) THEN + + ithis = ithis + 1 + b_up2down(ithis) = i + + j = riverdown(i) + DO WHILE (j > 0) + + iups_riv(j) = iups_riv(j) + 1 + + IF (iups_riv(j) == nups_riv(j)) THEN + ithis = ithis + 1 + b_up2down(ithis) = j + j = riverdown(j) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ENDDO + + bsndis(:) = 0. + DO i = 1, totalnumelm + j = b_up2down(i) + bsndis(j) = bsndis(j) + bsnrnof(j) + IF (riverdown(j) > 0) THEN + bsndis(riverdown(j)) = bsndis(riverdown(j)) + bsndis(j) + ENDIF + ENDDO + + allocate (riverdpth (totalnumelm)) + DO i = 1, totalnumelm + riverdpth(i) = max(cH_rivdpt * (bsndis(i)**pH_rivdpt) + B0_rivdpt, Bmin_rivdpt) + ENDDO + + ENDIF + + IF (allocated (bsnrnof )) deallocate(bsnrnof ) + IF (allocated (bsndis )) deallocate(bsndis ) + IF (allocated (nups_riv )) deallocate(nups_riv ) + IF (allocated (iups_riv )) deallocate(iups_riv ) + IF (allocated (b_up2down)) deallocate(b_up2down) + + END SUBROUTINE calc_riverdepth_from_runoff + + ! + FUNCTION retrieve_lake_surface_from_volume (this, volume) result(surface) + + IMPLICIT NONE + + class(lake_info_type) :: this + real(r8), intent(in) :: volume + real(r8) :: surface + + ! Local Variables + integer :: i + + IF (volume <= 0) THEN + surface = 0 + RETURN + ENDIF + + IF (this%nsub == 1) THEN + surface = volume / this%area(1) + ELSE + i = 1 + DO WHILE (i < this%nsub) + IF (volume >= this%dep_vol_curve(i+1)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + surface = this%depth(1) - this%depth(i) + & + (volume - this%dep_vol_curve(i)) / sum(this%area(1:i)) + ENDIF + + END FUNCTION retrieve_lake_surface_from_volume + + ! + FUNCTION retrieve_lake_volume_from_surface (this, surface) result(volume) + + IMPLICIT NONE + + class(lake_info_type) :: this + real(r8), intent(in) :: surface + real(r8) :: volume + + ! Local Variables + integer :: i + + IF (surface <= 0) THEN + volume = 0 + RETURN + ENDIF + + IF (this%nsub == 1) THEN + volume = this%area(1) * surface + ELSE + i = 1 + DO WHILE (i < this%nsub) + IF (surface >= this%depth(1)-this%depth(i+1)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + volume = this%dep_vol_curve(i) & + + (surface - (this%depth(1) - this%depth(i))) * sum(this%area(1:i)) + ENDIF + + END FUNCTION retrieve_lake_volume_from_surface + + ! ---------- + SUBROUTINE river_lake_network_final () + + IMPLICIT NONE + + ! Local Variables + integer :: ilake + + IF (allocated (riverlen )) deallocate(riverlen ) + IF (allocated (riverelv )) deallocate(riverelv ) + IF (allocated (riverwth )) deallocate(riverwth ) + IF (allocated (riverarea )) deallocate(riverarea ) + IF (allocated (riverdpth )) deallocate(riverdpth ) + IF (allocated (basinelv )) deallocate(basinelv ) + IF (allocated (bedelv )) deallocate(bedelv ) + IF (allocated (handmin )) deallocate(handmin ) + IF (allocated (wtsrfelv )) deallocate(wtsrfelv ) + IF (allocated (riverdown )) deallocate(riverdown ) + IF (allocated (ilocdown )) deallocate(ilocdown ) + IF (allocated (to_lake )) deallocate(to_lake ) + IF (allocated (riverlen_ds )) deallocate(riverlen_ds ) + IF (allocated (wtsrfelv_ds )) deallocate(wtsrfelv_ds ) + IF (allocated (riverwth_ds )) deallocate(riverwth_ds ) + IF (allocated (bedelv_ds )) deallocate(bedelv_ds ) + IF (allocated (outletwth )) deallocate(outletwth ) + IF (allocated (irivsys )) deallocate(irivsys ) +#ifdef USEMPI + IF (allocated (linkbindex )) deallocate(linkbindex ) + IF (allocated (linkpush )) deallocate(linkpush ) + IF (allocated (linkpull )) deallocate(linkpull ) +#endif + IF (allocated (lakeinfo )) deallocate(lakeinfo ) + IF (associated(hillslope_basin)) deallocate(hillslope_basin) + + END SUBROUTINE river_lake_network_final + + ! --------- + SUBROUTINE lake_info_free_mem (this) + + IMPLICIT NONE + type(lake_info_type) :: this + + IF (allocated(this%area0 )) deallocate (this%area0 ) + IF (allocated(this%area )) deallocate (this%area ) + IF (allocated(this%depth0)) deallocate (this%depth0) + IF (allocated(this%depth )) deallocate (this%depth ) + IF (allocated(this%dep_vol_curve)) deallocate (this%dep_vol_curve) + + END SUBROUTINE lake_info_free_mem + +END MODULE MOD_Catch_RiverLakeNetwork +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 new file mode 100644 index 0000000000..8876b6392d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 @@ -0,0 +1,823 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_SubsurfaceFlow +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Ground water lateral flow. +! +! Ground water fluxes are calculated +! 1. between elements +! 2. between hydrological response units +! 3. between patches inside one HRU +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_DataType + USE MOD_Catch_HillslopeNetwork + IMPLICIT NONE + + ! --- information of HRU on hillslope --- + type(hillslope_network_type), pointer :: hillslope_element (:) + + integer, allocatable :: lake_id_elm (:) + real(r8), allocatable :: lakedepth_elm(:) + real(r8), allocatable :: riverdpth_elm(:) + real(r8), allocatable :: wdsrf_elm (:) + + real(r8), parameter :: e_ice = 6.0 ! soil ice impedance factor + + ! anisotropy ratio of lateral/vertical hydraulic conductivity (unitless) + ! for USDA soil texture class: + ! 0: undefined + ! 1: clay; 2: silty clay; 3: sandy clay; 4: clay loam; 5: silty clay loam; 6: sandy clay loam; & + ! 7: loam; 8: silty loam; 9: sandy loam; 10: silt; 11: loamy sand; 12: sand + real(r8), parameter :: raniso(0:12) = (/ 1., & + 48., 40., 28., 24., 20., 14., 12., 10., 4., 2., 3., 2. /) + + ! -- neighbour variables -- + type(pointer_real8_1d), allocatable :: agwt_nb (:) ! ground water area (for patchtype <= 2) of neighbours [m^2] + type(pointer_real8_1d), allocatable :: theta_a_nb (:) ! saturated volume content [-] + type(pointer_real8_1d), allocatable :: zwt_nb (:) ! water table depth [m] + type(pointer_real8_1d), allocatable :: Kl_nb (:) ! lateral hydraulic conductivity [m/s] + type(pointer_real8_1d), allocatable :: wdsrf_nb (:) ! depth of surface water [m] + type(pointer_logic_1d), allocatable :: islake_nb (:) ! whether a neighbour is water body + type(pointer_real8_1d), allocatable :: lakedp_nb (:) ! lake depth of neighbour [m] + +CONTAINS + + ! ---------- + SUBROUTINE subsurface_network_init (patcharea) + + USE MOD_SPMD_Task + USE MOD_Utils + USE MOD_Mesh + USE MOD_Pixel + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_ElementNeighbour + USE MOD_WorkerPushData, only: worker_push_data + USE MOD_Catch_BasinNetwork, only: push_bsn2elm + USE MOD_Catch_RiverLakeNetwork, only: lake_id, riverdpth + USE MOD_Vars_TimeInvariants, only: patchtype, lakedepth + IMPLICIT NONE + + real(r8), intent(in) :: patcharea (:) + + integer :: ielm, inb, i, ihru, ps, pe, ipatch + + real(r8), allocatable :: agwt_b(:) + real(r8), allocatable :: islake(:) + type(pointer_real8_1d), allocatable :: iswat_nb (:) + + integer, allocatable :: eindex(:) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + IF (numelm > 0) THEN + allocate (eindex (numelm)) + eindex = landelm%eindex + ENDIF + ENDIF + + CALL hillslope_network_init (numelm, eindex, hillslope_element) + + IF (allocated(eindex)) deallocate (eindex) + + IF (p_is_worker) THEN + + IF (numelm > 0) allocate (lake_id_elm (numelm)) + IF (numelm > 0) allocate (riverdpth_elm(numelm)) + IF (numelm > 0) allocate (lakedepth_elm(numelm)) + IF (numelm > 0) allocate (wdsrf_elm (numelm)) + + CALL worker_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) + CALL worker_push_data (push_bsn2elm, riverdpth, riverdpth_elm, spval) + + DO ielm = 1, numelm + IF (lake_id_elm(ielm) <= 0) THEN + DO i = 1, hillslope_element(ielm)%nhru + + hillslope_element(ielm)%agwt(i) = 0 + hillslope_element(ielm)%area(i) = 0 + + ihru = hillslope_element(ielm)%ihru(i) + ps = hru_patch%substt(ihru) + pe = hru_patch%subend(ihru) + DO ipatch = ps, pe + hillslope_element(ielm)%area(i) = hillslope_element(ielm)%area(i) + patcharea(ipatch) + IF (patchtype(ipatch) <= 2) THEN + hillslope_element(ielm)%agwt(i) = hillslope_element(ielm)%agwt(i) + patcharea(ipatch) + ENDIF + ENDDO + + ENDDO + ENDIF + ENDDO + + lakedepth_elm(:) = 0. + DO ielm = 1, numelm + IF (lake_id_elm(ielm) > 0) THEN + ps = elm_patch%substt(ielm) + pe = elm_patch%subend(ielm) + lakedepth_elm(ielm) = sum(lakedepth(ps:pe) * elm_patch%subfrc(ps:pe)) + ENDIF + ENDDO + + CALL allocate_neighbour_data (agwt_nb ) + CALL allocate_neighbour_data (theta_a_nb) + CALL allocate_neighbour_data (zwt_nb ) + CALL allocate_neighbour_data (Kl_nb ) + CALL allocate_neighbour_data (wdsrf_nb ) + CALL allocate_neighbour_data (islake_nb ) + CALL allocate_neighbour_data (lakedp_nb ) + CALL allocate_neighbour_data (iswat_nb ) + + IF (numelm > 0) THEN + allocate (agwt_b(numelm)) + allocate (islake(numelm)) + DO ielm = 1, numelm + IF (lake_id_elm(ielm) <= 0) THEN + agwt_b(ielm) = sum(hillslope_element(ielm)%agwt) + islake(ielm) = 0. + ELSE + agwt_b(ielm) = 0. + islake(ielm) = 1. + ENDIF + ENDDO + ENDIF + + CALL retrieve_neighbour_data (lakedepth_elm, lakedp_nb) + + CALL retrieve_neighbour_data (agwt_b, agwt_nb ) + CALL retrieve_neighbour_data (islake, iswat_nb) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour + islake_nb(ielm)%val(inb) = (iswat_nb(ielm)%val(inb) > 0) + ENDIF + ENDDO + ENDDO + + IF (allocated(agwt_b )) deallocate(agwt_b ) + IF (allocated(islake )) deallocate(islake ) + IF (allocated(iswat_nb)) deallocate(iswat_nb) + + ENDIF + + END SUBROUTINE subsurface_network_init + + ! --------- + SUBROUTINE subsurface_flow (deltime) + + USE MOD_SPMD_Task + USE MOD_UserDefFun + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandHRU + USE MOD_LandPatch + USE MOD_Vars_TimeVariables + USE MOD_Vars_TimeInvariants + USE MOD_Vars_1DFluxes + USE MOD_Catch_HillslopeNetwork + USE MOD_ElementNeighbour + USE MOD_Const_Physical, only: denice, denh2o + USE MOD_Vars_Global, only: pi, nl_soil, zi_soi + USE MOD_Hydro_SoilWater, only: soilwater_aquifer_exchange + + IMPLICIT NONE + + real(r8), intent(in) :: deltime + + ! Local Variables + integer :: nhru, ielm, i, i0, j, ihru, ipatch, ps, pe, hs, he, ilev + + type(hillslope_network_type), pointer :: hrus + + real(r8), allocatable :: theta_a_h (:) + real(r8), allocatable :: zwt_h (:) + real(r8), allocatable :: Kl_h (:) ! [m/s] + real(r8), allocatable :: xsubs_h (:) ! [m/s] + real(r8), allocatable :: xsubs_fc (:) ! [m/s] + + logical :: j_is_river + real(r8) :: theta_s_h, air_h, icefrac, imped, delp + real(r8) :: sumwt, sumarea, zwt_mean + real(r8) :: zsubs_h_up, zsubs_h_dn + real(r8) :: slope, bdamp, Kl_fc, Kl_in + real(r8) :: ca, cb + real(r8) :: alp + + real(r8), allocatable :: theta_a_elm (:) + real(r8), allocatable :: zwt_elm (:) + real(r8), allocatable :: Kl_elm (:) ! [m/s] + + integer :: jnb + real(r8) :: zsubs_up, zwt_up, Kl_up, theta_a_up, area_up + real(r8) :: zsubs_dn, zwt_dn, Kl_dn, theta_a_dn, area_dn + real(r8) :: lenbdr, xsubs_nb + logical :: iam_lake, nb_is_lake, has_river + + ! for water exchange + logical :: is_dry_lake + integer :: izwt + real(r8) :: exwater + real(r8) :: sp_zi(0:nl_soil), sp_dz(1:nl_soil), zwtmm ! [mm] + real(r8) :: vl_r (1:nl_soil) +#ifdef Campbell_SOIL_MODEL + integer, parameter :: nprms = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: nprms = 5 +#endif + real(r8) :: prms (nprms,1:nl_soil) + real(r8) :: vol_ice (1:nl_soil) + real(r8) :: vol_liq (1:nl_soil) + real(r8) :: eff_porosity(1:nl_soil) + logical :: is_permeable(1:nl_soil) + real(r8) :: wresi (1:nl_soil) + real(r8) :: w_sum_before, w_sum_after, errblc + + + IF (p_is_worker) THEN + + xsubs_elm(:) = 0. ! subsurface lateral flow between element basins + xsubs_hru(:) = 0. ! subsurface lateral flow between hydrological response units + xsubs_pch(:) = 0. ! subsurface lateral flow between patches inside one HRU + + xwsub(:) = 0. ! total recharge/discharge from subsurface lateral flow + + IF (numpatch > 0) rsub(:) = 0. + + IF (numelm > 0) THEN + allocate (theta_a_elm (numelm)); theta_a_elm = 0. + allocate (zwt_elm (numelm)); zwt_elm = 0. + allocate (Kl_elm (numelm)); Kl_elm = 0. + ENDIF + + DO ielm = 1, numelm + + hrus => hillslope_element(ielm) + + nhru = hrus%nhru + + IF (lake_id_elm(ielm) > 0) CYCLE ! lake + IF (sum(hrus%agwt) <= 0) CYCLE ! no area of soil, urban or wetland + + allocate (theta_a_h (nhru)); theta_a_h = 0. + allocate (zwt_h (nhru)); zwt_h = 0. + allocate (Kl_h (nhru)); Kl_h = 0. + + DO i = 1, nhru + + IF (hrus%indx(i) == 0) CYCLE ! river + IF (hrus%agwt(i) == 0) CYCLE ! no area of soil, urban or wetland + + ps = hru_patch%substt(hrus%ihru(i)) + pe = hru_patch%subend(hrus%ihru(i)) + + theta_s_h = 0 + sumwt = 0 + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + theta_s_h = theta_s_h + hru_patch%subfrc(ipatch) & + * sum(porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) & + - wice_soisno(1:nl_soil,ipatch)/denice) / sum(dz_soi(1:nl_soil)) + sumwt = sumwt + hru_patch%subfrc(ipatch) + ENDIF + ENDDO + IF (sumwt > 0) theta_s_h = theta_s_h / sumwt + + IF (theta_s_h > 0.) THEN + + air_h = 0. + zwt_h(i) = 0. + sumwt = 0. + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + air_h = air_h + hru_patch%subfrc(ipatch) & + * (sum( porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) & + - wliq_soisno(1:nl_soil,ipatch)/denh2o & + - wice_soisno(1:nl_soil,ipatch)/denice ) - wa(ipatch)/1.0e3) + air_h = max(0., air_h) + + zwt_h(i) = zwt_h(i) + zwt(ipatch) * hru_patch%subfrc(ipatch) + + sumwt = sumwt + hru_patch%subfrc(ipatch) + ENDIF + ENDDO + IF (sumwt > 0) air_h = air_h / sumwt + IF (sumwt > 0) zwt_h(i) = zwt_h(i) / sumwt + + IF ((air_h <= 0.) .or. (zwt_h(i) <= 0.)) THEN + theta_a_h(i) = theta_s_h + zwt_h(i) = 0. + ELSE + theta_a_h(i) = air_h / zwt_h(i) + IF (theta_a_h(i) > theta_s_h) THEN + theta_a_h(i) = theta_s_h + zwt_h(i) = air_h / theta_a_h(i) + ENDIF + ENDIF + + Kl_h(i) = 0. + sumwt = 0. + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + DO ilev = 1, nl_soil + icefrac = min(1., wice_soisno(ilev,ipatch)/denice/dz_soi(ilev)/porsl(ilev,ipatch)) + imped = 10.**(-e_ice*icefrac) + Kl_h(i) = Kl_h(i) + hru_patch%subfrc(ipatch) * raniso(soiltext(ipatch)) & + * hksati(ilev,ipatch)/1.0e3 * imped * dz_soi(ilev)/zi_soi(nl_soil) + ENDDO + sumwt = sumwt + hru_patch%subfrc(ipatch) + ENDIF + ENDDO + IF (sumwt > 0) Kl_h(i) = Kl_h(i) / sumwt + ELSE + ! Frozen soil. + Kl_h(i) = 0. + ENDIF + + ENDDO + + allocate (xsubs_h (nhru)) + allocate (xsubs_fc (nhru)) + + xsubs_h (:) = 0. + xsubs_fc(:) = 0. + + DO i = 1, nhru + + j = hrus%inext(i) + + IF (j <= 0) CYCLE ! downstream is out of catchment + IF (Kl_h(i) == 0.) CYCLE ! this HRU is frozen + + j_is_river = (hrus%indx(j) == 0) + + IF ((.not. j_is_river) .and. (Kl_h(j) == 0.)) CYCLE ! non-river downstream HRU is frozen + + zsubs_h_up = hrus%elva(i) - zwt_h(i) + + IF (.not. j_is_river) THEN + zsubs_h_dn = hrus%elva(j) - zwt_h(j) + ELSE + zsubs_h_dn = hrus%elva(1) - riverdpth_elm(ielm) + wdsrf_hru(hrus%ihru(1)) + ENDIF + + IF (.not. j_is_river) THEN + delp = hrus%plen(i) + hrus%plen(j) + ELSE + delp = hrus%plen(i) + ENDIF + + slope = abs(hrus%elva(i)-hrus%elva(j))/delp + ! from Fan et al., JGR 112(D10125) + IF (slope > 0.16) THEN + bdamp = 4.8 + ELSE + bdamp = 120./(1+150.*slope) + ENDIF + + ! Upstream scheme for hydraulic conductivity + IF ((zsubs_h_up > zsubs_h_dn) .or. j_is_river) THEN + IF (zwt_h(i) > 1.5) THEN + ! from Fan et al., JGR 112(D10125) + Kl_fc = Kl_h(i) * bdamp * exp(-(zwt_h(i)-1.5)/bdamp) + ELSE + Kl_fc = Kl_h(i) * ((1.5-zwt_h(i)) + bdamp) + ENDIF + ELSE + IF (zwt_h(j) > 1.5) THEN + Kl_fc = Kl_h(j) * bdamp * exp(-(zwt_h(j)-1.5)/bdamp) + ELSE + Kl_fc = Kl_h(j) * ((1.5-zwt_h(j)) + bdamp) + ENDIF + ENDIF + + ca = hrus%flen(i) * Kl_fc / theta_a_h(i) / delp / hrus%agwt(i) * deltime + + IF (.not. j_is_river) THEN + cb = hrus%flen(i) * Kl_fc / theta_a_h(j) / delp / hrus%agwt(j) * deltime + ELSE + cb = hrus%flen(i) * Kl_fc / delp / hrus%area(j) * deltime + ENDIF + + xsubs_fc(i) = (zsubs_h_up - zsubs_h_dn) * hrus%flen(i) * Kl_fc / (1+ca+cb) / delp + + xsubs_h(i) = xsubs_h(i) + xsubs_fc(i) / hrus%agwt(i) + + IF (j_is_river) THEN + xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%area(j) + ELSE + xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%agwt(j) + ENDIF + + ENDDO + + IF (hrus%indx(1) == 0) THEN + ! xsubs_h(1) is positive = out of soil column + IF (xsubs_h(1)*deltime > wdsrf_hru(hrus%ihru(1))) THEN + alp = wdsrf_hru(hrus%ihru(1)) / (xsubs_h(1)*deltime) + xsubs_h(1) = xsubs_h(1) * alp + DO i = 2, nhru + IF ((hrus%inext(i) == 1) .and. (hrus%agwt(i) > 0.)) THEN + xsubs_h(i) = xsubs_h(i) - (1.0-alp)*xsubs_fc(i)/hrus%agwt(i) + ENDIF + ENDDO + ENDIF + ENDIF + + ! Update total subsurface lateral flow (1): Between hydrological units + ! for soil, urban, wetland or river patches + DO i = 1, nhru + xsubs_hru(hrus%ihru(i)) = xsubs_h(i) + + ps = hru_patch%substt(hrus%ihru(i)) + pe = hru_patch%subend(hrus%ihru(i)) + DO ipatch = ps, pe + IF ((patchtype(ipatch) <= 2) .or. (hrus%indx(i) == 0)) THEN + xwsub(ipatch) = xwsub(ipatch) + xsubs_h(i) * 1.e3 ! (positive = out of soil column) + ENDIF + ENDDO + + IF (hrus%indx(1) == 0) THEN + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + rsub(ipatch) = - xsubs_h(1) * hrus%area(1) / sum(hrus%agwt) * 1.0e3 ! m/s to mm/s + ENDIF + ENDDO + ENDIF + ENDDO + + DO i = 1, nhru + ! Inside hydrological units + IF (hrus%agwt(i) > 0) THEN + + bdamp = 4.8 + + IF (zwt_h(i) > 1.5) THEN + ! from Fan et al., JGR 112(D10125) + Kl_in = Kl_h(i) * bdamp * exp(-(zwt_h(i)-1.5)/bdamp) + ELSE + Kl_in = Kl_h(i) * ((1.5-zwt_h(i)) + bdamp) + ENDIF + + ps = hru_patch%substt(hrus%ihru(i)) + pe = hru_patch%subend(hrus%ihru(i)) + sumwt = sum(hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) + IF (sumwt > 0) THEN + zwt_mean = sum(zwt(ps:pe)*hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) / sumwt + + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + xsubs_pch(ipatch) = - Kl_in * (zwt(ipatch) - zwt_mean) *6.0*pi/hrus%agwt(i) + ! Update total subsurface lateral flow (2): Between patches + xwsub(ipatch) = xwsub(ipatch) + xsubs_pch(ipatch) * 1.e3 ! m/s to mm/s + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + + sumarea = sum(hrus%agwt) + IF (sumarea > 0) THEN + theta_a_elm (ielm) = sum(theta_a_h * hrus%agwt) / sumarea + zwt_elm (ielm) = sum(zwt_h * hrus%agwt) / sumarea + Kl_elm (ielm) = sum(Kl_h * hrus%agwt) / sumarea + ENDIF + + deallocate (theta_a_h) + deallocate (zwt_h ) + deallocate (Kl_h ) + deallocate (xsubs_h ) + deallocate (xsubs_fc ) + + ENDDO + + DO ielm = 1, numelm + hs = elm_hru%substt(ielm) + he = elm_hru%subend(ielm) + wdsrf_elm(ielm) = sum(wdsrf_hru(hs:he) * elm_hru%subfrc(hs:he)) + ENDDO + + CALL retrieve_neighbour_data (theta_a_elm, theta_a_nb) + CALL retrieve_neighbour_data (zwt_elm , zwt_nb ) + CALL retrieve_neighbour_data (Kl_elm , Kl_nb ) + CALL retrieve_neighbour_data (wdsrf_elm , wdsrf_nb ) + + DO ielm = 1, numelm + + hrus => hillslope_element(ielm) + + iam_lake = (lake_id_elm(ielm) > 0) + + DO jnb = 1, elementneighbour(ielm)%nnb + + IF (elementneighbour(ielm)%glbindex(jnb) == -9) CYCLE ! skip ocean neighbour + + nb_is_lake = islake_nb(ielm)%val(jnb) + + IF (iam_lake .and. nb_is_lake) THEN + CYCLE + ENDIF + + IF (.not. iam_lake) THEN + Kl_up = Kl_elm (ielm) + zwt_up = zwt_elm (ielm) + theta_a_up = theta_a_elm(ielm) + zsubs_up = elementneighbour(ielm)%myelva - zwt_up + area_up = sum(hrus%agwt) + ELSE + theta_a_up = 1. + zsubs_up = elementneighbour(ielm)%myelva - lakedepth_elm(ielm) + wdsrf_elm(ielm) + area_up = elementneighbour(ielm)%myarea + ENDIF + + IF (.not. nb_is_lake) THEN + Kl_dn = Kl_nb(ielm)%val(jnb) + zwt_dn = zwt_nb(ielm)%val(jnb) + theta_a_dn = theta_a_nb(ielm)%val(jnb) + zsubs_dn = elementneighbour(ielm)%elva(jnb) - zwt_dn + area_dn = agwt_nb(ielm)%val(jnb) + ELSE + theta_a_dn = 1. + zsubs_dn = elementneighbour(ielm)%elva(jnb) - lakedp_nb(ielm)%val(jnb) + wdsrf_nb(ielm)%val(jnb) + area_dn = elementneighbour(ielm)%area(jnb) + ENDIF + + IF ((.not. iam_lake) .and. (area_up <= 0)) CYCLE + IF ((.not. nb_is_lake) .and. (area_dn <= 0)) CYCLE + IF ((.not. iam_lake) .and. (Kl_up == 0. )) CYCLE + IF ((.not. nb_is_lake) .and. (Kl_dn == 0. )) CYCLE + + ! water body is dry. + IF (iam_lake .and. (zsubs_up > zsubs_dn) .and. (wdsrf_elm(ielm) == 0.)) THEN + CYCLE + ENDIF + IF (nb_is_lake .and. (zsubs_up < zsubs_dn) .and. (wdsrf_nb(ielm)%val(jnb) == 0.)) THEN + CYCLE + ENDIF + + lenbdr = elementneighbour(ielm)%lenbdr(jnb) + + delp = elementneighbour(ielm)%dist(jnb) + IF (iam_lake) THEN + delp = elementneighbour(ielm)%area(jnb) / lenbdr * 0.5 + ENDIF + IF (nb_is_lake) THEN + delp = elementneighbour(ielm)%myarea / lenbdr * 0.5 + ENDIF + + ! from Fan et al., JGR 112(D10125) + slope = abs(elementneighbour(ielm)%slope(jnb)) + IF (slope > 0.16) THEN + bdamp = 4.8 + ELSE + bdamp = 120./(1+150.*slope) + ENDIF + + ! Upstream scheme for hydraulic conductivity + IF (nb_is_lake .or. ((.not. iam_lake) .and. (zsubs_up > zsubs_dn))) THEN + IF (zwt_up > 1.5) THEN + ! from Fan et al., JGR 112(D10125) + Kl_fc = Kl_up * bdamp * exp(-(zwt_up-1.5)/bdamp) + ELSE + Kl_fc = Kl_up * ((1.5-zwt_up) + bdamp) + ENDIF + ELSE + IF (zwt_dn > 1.5) THEN + Kl_fc = Kl_dn * bdamp * exp(-(zwt_dn-1.5)/bdamp) + ELSE + Kl_fc = Kl_dn * ((1.5-zwt_dn) + bdamp) + ENDIF + ENDIF + + ca = lenbdr * Kl_fc / theta_a_up / delp / area_up * deltime + cb = lenbdr * Kl_fc / theta_a_dn / delp / area_dn * deltime + + xsubs_nb = (zsubs_up - zsubs_dn) * lenbdr * Kl_fc / (1+ca+cb) / delp + + IF (.not. iam_lake) THEN + xsubs_nb = xsubs_nb / sum(hrus%agwt) + ELSE + xsubs_nb = xsubs_nb / elementneighbour(ielm)%myarea + ENDIF + + xsubs_elm(ielm) = xsubs_elm(ielm) + xsubs_nb + + IF (nb_is_lake) THEN + ps = elm_patch%substt(ielm) + pe = elm_patch%subend(ielm) + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + rsub(ipatch) = rsub(ipatch) + xsubs_nb * 1.e3 + ENDIF + ENDDO + ENDIF + + ENDDO + + ! Update total subsurface lateral flow (3): Between basins + ps = elm_patch%substt(ielm) + pe = elm_patch%subend(ielm) + DO ipatch = ps, pe + IF (iam_lake .or. (patchtype(ipatch) <= 2)) THEN + xwsub(ipatch) = xwsub(ipatch) + xsubs_elm(ielm) * 1.e3 ! m/s to mm/s + ENDIF + ENDDO + + ENDDO + + IF (allocated(theta_a_elm)) deallocate(theta_a_elm) + IF (allocated(zwt_elm )) deallocate(zwt_elm ) + IF (allocated(Kl_elm )) deallocate(Kl_elm ) + + ENDIF + + ! Exchange between soil water and aquifer. + IF (p_is_worker) THEN + + sp_zi(0) = 0. + sp_zi(1:nl_soil) = zi_soi(1:nl_soil) * 1000.0 ! from meter to mm + sp_dz(1:nl_soil) = sp_zi(1:nl_soil) - sp_zi(0:nl_soil-1) + + DO ipatch = 1, numpatch + +#if (defined CoLMDEBUG) + ! For water balance check, the sum of water in soil column before the calcultion + w_sum_before = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & + + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch) +#endif + + IF (DEF_USE_Dynamic_Lake) THEN + is_dry_lake = (patchtype(ipatch) == 4) .and. (zwt(ipatch) > 0.) + ELSE + is_dry_lake = .false. + ENDIF + + IF ((patchtype(ipatch) <= 1) .or. is_dry_lake) THEN + + exwater = xwsub(ipatch) * deltime + +#ifdef Campbell_SOIL_MODEL + vl_r(1:nl_soil) = 0._r8 + prms(1,:) = bsw(1:nl_soil,ipatch) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + vl_r (1:nl_soil) = theta_r (1:nl_soil,ipatch) + prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,ipatch) + prms(2,1:nl_soil) = n_vgm (1:nl_soil,ipatch) + prms(3,1:nl_soil) = L_vgm (1:nl_soil,ipatch) + prms(4,1:nl_soil) = sc_vgm (1:nl_soil,ipatch) + prms(5,1:nl_soil) = fc_vgm (1:nl_soil,ipatch) +#endif + + DO ilev = 1, nl_soil + vol_ice(ilev) = wice_soisno(ilev,ipatch)/denice*1000. / sp_dz(ilev) + vol_ice(ilev) = min(vol_ice(ilev), porsl(ilev,ipatch)) + + eff_porosity(ilev) = max(wimp, porsl(ilev,ipatch)-vol_ice(ilev)) + is_permeable(ilev) = eff_porosity(ilev) > max(wimp, vl_r(ilev)) + IF (is_permeable(ilev)) THEN + vol_liq(ilev) = wliq_soisno(ilev,ipatch)/denh2o*1000. / sp_dz(ilev) + vol_liq(ilev) = min(eff_porosity(ilev), max(0., vol_liq(ilev))) + wresi(ilev) = wliq_soisno(ilev,ipatch) - sp_dz(ilev)*vol_liq(ilev)/1000. * denh2o + ELSE + vol_liq(ilev) = eff_porosity(ilev) + wresi(ilev) = 0. + ENDIF + ENDDO + + zwtmm = zwt(ipatch) * 1000. ! m -> mm + + ! check consistancy between water table location and liquid water content + DO ilev = 1, nl_soil + IF ((vol_liq(ilev) < eff_porosity(ilev)-1.e-8) .and. (zwtmm <= sp_zi(ilev-1))) THEN + zwtmm = sp_zi(ilev) + ENDIF + ENDDO + + izwt = findloc_ud(zwtmm >= sp_zi, back=.true.) + + IF (izwt <= nl_soil) THEN + IF (is_permeable(izwt) .and. (zwtmm > sp_zi(izwt-1))) THEN + vol_liq(izwt) = (wliq_soisno(izwt,ipatch)/denh2o*1000.0 & + - eff_porosity(izwt)*(sp_zi(izwt)-zwtmm)) / (zwtmm - sp_zi(izwt-1)) + + IF (vol_liq(izwt) < 0.) THEN + zwtmm = sp_zi(izwt) + vol_liq(izwt) = wliq_soisno(izwt,ipatch)/denh2o*1000.0 / (sp_zi(izwt)-sp_zi(izwt-1)) + ENDIF + + vol_liq(izwt) = max(0., min(eff_porosity(izwt), vol_liq(izwt))) + wresi(izwt) = wliq_soisno(izwt,ipatch) - (eff_porosity(izwt)*(sp_zi(izwt)-zwtmm) & + + vol_liq(izwt)*(zwtmm-sp_zi(izwt-1))) /1000. * denh2o + ENDIF + ENDIF + + CALL soilwater_aquifer_exchange ( & + nl_soil, exwater, sp_zi, is_permeable, eff_porosity, vl_r, psi0(:,ipatch), & + hksati(:,ipatch), nprms, prms, porsl(nl_soil,ipatch), wdsrf(ipatch), & + vol_liq, zwtmm, wa(ipatch), izwt) + + ! update the mass of liquid water + DO ilev = nl_soil, 1, -1 + IF (is_permeable(ilev)) THEN + IF (zwtmm < sp_zi(ilev)) THEN + IF (zwtmm >= sp_zi(ilev-1)) THEN + wliq_soisno(ilev,ipatch) = ((eff_porosity(ilev)*(sp_zi(ilev)-zwtmm)) & + + vol_liq(ilev)*(zwtmm-sp_zi(ilev-1)))/1000.0 * denh2o + ELSE + wliq_soisno(ilev,ipatch) = denh2o * eff_porosity(ilev)*sp_dz(ilev)/1000.0 + ENDIF + ELSE + wliq_soisno(ilev,ipatch) = denh2o * vol_liq(ilev)*sp_dz(ilev)/1000.0 + ENDIF + + wliq_soisno(ilev,ipatch) = wliq_soisno(ilev,ipatch) + wresi(ilev) + ENDIF + ENDDO + + zwt(ipatch) = zwtmm/1000.0 + + ELSEIF (patchtype(ipatch) == 2) THEN ! wetland + + wetwat(ipatch) = wdsrf(ipatch) + wa(ipatch) + wetwat(ipatch) - xwsub(ipatch)*deltime + + IF (wetwat(ipatch) > wetwatmax) THEN + wdsrf (ipatch) = wetwat(ipatch) - wetwatmax + wetwat(ipatch) = wetwatmax + wa (ipatch) = 0. + ELSEIF (wetwat(ipatch) < 0) THEN + wa (ipatch) = wetwat(ipatch) + wdsrf (ipatch) = 0. + wetwat(ipatch) = 0. + ELSE + wdsrf(ipatch) = 0. + wa (ipatch) = 0. + ENDIF + + ELSEIF (patchtype(ipatch) == 4) THEN ! land water bodies + + wdsrf(ipatch) = wa(ipatch) + wdsrf(ipatch) - xwsub(ipatch)*deltime + + IF (wdsrf(ipatch) < 0) THEN + wa (ipatch) = wdsrf(ipatch) + wdsrf(ipatch) = 0 + ELSE + wa(ipatch) = 0 + ENDIF + + ENDIF + +#if (defined CoLMDEBUG) + ! For water balance check, the sum of water in soil column after the calcultion + w_sum_after = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & + + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch) + errblc = w_sum_after - w_sum_before + xwsub(ipatch)*deltime + + IF(abs(errblc) > 1.e-3)THEN + write(6,'(A,I0,4E20.5)') 'Warning (Subsurface Runoff): water balance violation ', & + ipatch, errblc, xwsub(ipatch), zwtmm + write(*,*) patchtype(ipatch) + CALL CoLM_stop () + ENDIF +#endif + ENDDO + ENDIF + + END SUBROUTINE subsurface_flow + + ! ---------- + SUBROUTINE subsurface_network_final () + + IMPLICIT NONE + + IF (allocated(lake_id_elm )) deallocate(lake_id_elm ) + IF (allocated(riverdpth_elm)) deallocate(riverdpth_elm) + IF (allocated(lakedepth_elm)) deallocate(lakedepth_elm) + IF (allocated(wdsrf_elm )) deallocate(wdsrf_elm ) + + IF (allocated(theta_a_nb)) deallocate(theta_a_nb) + IF (allocated(zwt_nb )) deallocate(zwt_nb ) + IF (allocated(Kl_nb )) deallocate(Kl_nb ) + IF (allocated(wdsrf_nb )) deallocate(wdsrf_nb ) + IF (allocated(agwt_nb )) deallocate(agwt_nb ) + IF (allocated(islake_nb )) deallocate(islake_nb ) + IF (allocated(lakedp_nb )) deallocate(lakedp_nb ) + + IF (associated(hillslope_element)) deallocate(hillslope_element) + + END SUBROUTINE subsurface_network_final + +END MODULE MOD_Catch_SubsurfaceFlow +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..b75974f46f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 @@ -0,0 +1,115 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_Vars_1DFluxes +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! 1D fluxes in lateral hydrological processes. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + ! -- fluxes -- + real(r8), allocatable :: xsubs_elm (:) ! subsurface lateral flow between basins [m/s] + real(r8), allocatable :: xsubs_hru (:) ! subsurface lateral flow between hydrological response units [m/s] + real(r8), allocatable :: xsubs_pch (:) ! subsurface lateral flow between patches inside one HRU [m/s] + + real(r8), allocatable :: wdsrf_bsn_ta (:) ! time step average of river height [m] + real(r8), allocatable :: momen_riv_ta (:) ! time step average of river momentum [m^2/s] + real(r8), allocatable :: veloc_riv_ta (:) ! time step average of river velocity [m/s] + real(r8), allocatable :: discharge_ta (:) ! river discharge [m^3/s] + + real(r8), allocatable :: wdsrf_bsnhru_ta (:) ! time step average of surface water depth [m] + real(r8), allocatable :: momen_bsnhru_ta (:) ! time step average of surface water momentum [m^2/s] + real(r8), allocatable :: veloc_bsnhru_ta (:) ! time step average of surface water veloctiy [m/s] + + real(r8), allocatable :: xwsur (:) ! surface water exchange [mm h2o/s] + real(r8), allocatable :: xwsub (:) ! subsurface water exchange [mm h2o/s] + real(r8), allocatable :: fldarea (:) ! fraction of flooded area [-] + + real(r8), allocatable :: ntacc_bsn (:) + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_CatchFluxes + PUBLIC :: deallocate_1D_CatchFluxes + +CONTAINS + + SUBROUTINE allocate_1D_CatchFluxes + + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + USE MOD_Mesh, only: numelm + USE MOD_LandHRU, only: numhru + USE MOD_LandPatch, only: numpatch + USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + allocate (xsubs_pch (numpatch)) ; xsubs_pch (:) = spval + allocate (xwsur (numpatch)) ; xwsur (:) = spval + allocate (xwsub (numpatch)) ; xwsub (:) = spval + allocate (fldarea (numpatch)) ; fldarea (:) = spval + ENDIF + + IF (numelm > 0) THEN + allocate (xsubs_elm (numelm)) ; xsubs_elm(:) = spval + ENDIF + + IF (numbasin > 0) THEN + allocate (wdsrf_bsn_ta (numbasin)) ; wdsrf_bsn_ta (:) = spval + allocate (momen_riv_ta (numbasin)) ; momen_riv_ta (:) = spval + allocate (veloc_riv_ta (numbasin)) ; veloc_riv_ta (:) = spval + allocate (discharge_ta (numbasin)) ; discharge_ta (:) = spval + ENDIF + + IF (numhru > 0) THEN + allocate (xsubs_hru (numhru)); xsubs_hru(:) = spval + ENDIF + + IF (numbsnhru > 0) THEN + allocate (wdsrf_bsnhru_ta (numbsnhru)) ; wdsrf_bsnhru_ta (:) = spval + allocate (momen_bsnhru_ta (numbsnhru)) ; momen_bsnhru_ta (:) = spval + allocate (veloc_bsnhru_ta (numbsnhru)) ; veloc_bsnhru_ta (:) = spval + ENDIF + + IF (numbasin > 0) allocate (ntacc_bsn (numbasin)) + IF (numbasin > 0) ntacc_bsn(:) = 0. + + ENDIF + + END SUBROUTINE allocate_1D_CatchFluxes + + SUBROUTINE deallocate_1D_CatchFluxes + + IMPLICIT NONE + + IF (allocated(xsubs_elm)) deallocate(xsubs_elm) + IF (allocated(xsubs_hru)) deallocate(xsubs_hru) + IF (allocated(xsubs_pch)) deallocate(xsubs_pch) + + IF (allocated(wdsrf_bsn_ta)) deallocate(wdsrf_bsn_ta) + IF (allocated(momen_riv_ta)) deallocate(momen_riv_ta) + IF (allocated(veloc_riv_ta)) deallocate(veloc_riv_ta) + IF (allocated(discharge_ta)) deallocate(discharge_ta) + + IF (allocated(wdsrf_bsnhru_ta)) deallocate(wdsrf_bsnhru_ta) + IF (allocated(momen_bsnhru_ta)) deallocate(momen_bsnhru_ta) + IF (allocated(veloc_bsnhru_ta)) deallocate(veloc_bsnhru_ta) + + IF (allocated(xwsur )) deallocate(xwsur ) + IF (allocated(xwsub )) deallocate(xwsub ) + IF (allocated(fldarea)) deallocate(fldarea) + + IF (allocated(ntacc_bsn)) deallocate(ntacc_bsn) + + END SUBROUTINE deallocate_1D_CatchFluxes + +END MODULE MOD_Catch_Vars_1DFluxes +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..a65744277d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 @@ -0,0 +1,178 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_Vars_TimeVariables +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Time Variables in lateral hydrological processes. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Catch_BasinNetwork + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + ! -- state variables (1): necessary for restart -- + real(r8), allocatable :: veloc_elm (:) ! river velocity [m/s] + real(r8), allocatable :: veloc_hru (:) ! surface water velocity [m/s] + real(r8), allocatable :: wdsrf_hru (:) ! surface water depth [m] + + real(r8), allocatable :: wdsrf_elm_prev (:) ! river or lake water depth at previous time step [m] + real(r8), allocatable :: wdsrf_hru_prev (:) ! surface water depth at previous time step [m] + + ! -- state variables (2): only in model -- + real(r8), allocatable :: wdsrf_bsn (:) ! river or lake water depth [m] + real(r8), allocatable :: veloc_riv (:) ! river velocity [m/s] + real(r8), allocatable :: momen_riv (:) ! unit river momentum [m^2/s] + real(r8), allocatable :: wdsrf_bsnhru (:) ! surface water depth [m] + real(r8), allocatable :: veloc_bsnhru (:) ! surface water velocity [m/s] + real(r8), allocatable :: momen_bsnhru (:) ! unit surface water momentum [m^2/s] + + real(r8), allocatable :: wdsrf_bsn_prev (:) ! river or lake water depth at previous time step [m] + real(r8), allocatable :: wdsrf_bsnhru_prev (:) ! surface water depth at previous time step [m] + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_CatchTimeVariables + PUBLIC :: deallocate_CatchTimeVariables + + PUBLIC :: read_CatchTimeVariables + PUBLIC :: write_CatchTimeVariables + +CONTAINS + + SUBROUTINE allocate_CatchTimeVariables + + USE MOD_SPMD_Task + USE MOD_Mesh, only: numelm + USE MOD_LandHRU, only: numhru + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numelm > 0) THEN + allocate (veloc_elm (numelm)) + allocate (wdsrf_elm_prev (numelm)) + ENDIF + + IF (numhru > 0) THEN + allocate (veloc_hru (numhru)) + allocate (wdsrf_hru (numhru)) + allocate (wdsrf_hru_prev (numhru)) + ENDIF + + IF (numbasin > 0) allocate (wdsrf_bsn (numbasin)) + IF (numbasin > 0) allocate (veloc_riv (numbasin)) + IF (numbasin > 0) allocate (momen_riv (numbasin)) + IF (numbasin > 0) allocate (wdsrf_bsn_prev(numbasin)) + + IF (numbsnhru > 0) allocate (wdsrf_bsnhru (numbsnhru)) + IF (numbsnhru > 0) allocate (veloc_bsnhru (numbsnhru)) + IF (numbsnhru > 0) allocate (momen_bsnhru (numbsnhru)) + IF (numbsnhru > 0) allocate (wdsrf_bsnhru_prev (numbsnhru)) + + ENDIF + + END SUBROUTINE allocate_CatchTimeVariables + + SUBROUTINE READ_CatchTimeVariables (file_restart) + + USE MOD_Mesh + USE MOD_LandHRU + USE MOD_Vector_ReadWrite + USE MOD_ElmVector + USE MOD_HRUVector + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + CALL vector_read_and_scatter (file_restart, veloc_elm, numelm, 'veloc_riv', elm_data_address) + CALL worker_push_data (push_elm2bsn, veloc_elm, veloc_riv, spval) + + CALL vector_read_and_scatter (file_restart, wdsrf_elm_prev, numelm, 'wdsrf_bsn_prev', elm_data_address) + CALL worker_push_data (push_elm2bsn, wdsrf_elm_prev, wdsrf_bsn_prev, spval) + + CALL vector_read_and_scatter (file_restart, veloc_hru, numhru, 'veloc_hru', hru_data_address) + CALL worker_push_data (push_elmhru2bsnhru, veloc_hru, veloc_bsnhru, spval) + + CALL vector_read_and_scatter (file_restart, wdsrf_hru_prev, numhru, 'wdsrf_hru_prev', hru_data_address) + CALL worker_push_data (push_elmhru2bsnhru, wdsrf_hru_prev, wdsrf_bsnhru_prev, spval) + + END SUBROUTINE READ_CatchTimeVariables + + SUBROUTINE WRITE_CatchTimeVariables (file_restart) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Mesh + USE MOD_LandHRU + USE MOD_Vector_ReadWrite + USE MOD_ElmVector + USE MOD_HRUVector + IMPLICIT NONE + + integer :: iwork + character(len=*), intent(in) :: file_restart + + IF (p_is_master) THEN + CALL ncio_create_file (trim(file_restart)) + CALL ncio_define_dimension(file_restart, 'basin', totalnumelm) + CALL ncio_define_dimension(file_restart, 'hydrounit', totalnumhru) + + CALL ncio_write_serial (file_restart, 'basin', eindex_glb, 'basin') + CALL ncio_put_attr (file_restart, 'basin', 'long_name', 'basin index') + + CALL ncio_write_serial (file_restart, 'bsn_hru', eindx_hru, 'hydrounit') + CALL ncio_put_attr (file_restart, 'bsn_hru', & + 'long_name', 'basin index of hydrological units') + + CALL ncio_write_serial (file_restart, 'hru_type' , htype_hru, 'hydrounit') + CALL ncio_put_attr (file_restart, 'hru_type' , & + 'long_name', 'index of hydrological units inside basin') + ENDIF + + CALL worker_push_data (push_bsn2elm, veloc_riv, veloc_elm, spval) + CALL vector_gather_and_write (& + veloc_elm, numelm, totalnumelm, elm_data_address, file_restart, 'veloc_riv', 'basin') + + CALL worker_push_data (push_bsn2elm, wdsrf_bsn_prev, wdsrf_elm_prev, spval) + CALL vector_gather_and_write (& + wdsrf_elm_prev, numelm, totalnumelm, elm_data_address, file_restart, 'wdsrf_bsn_prev', 'basin') + + CALL worker_push_data (push_bsnhru2elmhru, veloc_bsnhru, veloc_hru, spval) + CALL vector_gather_and_write (& + veloc_hru, numhru, totalnumhru, hru_data_address, file_restart, 'veloc_hru', 'hydrounit') + + CALL worker_push_data (push_bsnhru2elmhru, wdsrf_bsnhru_prev, wdsrf_hru_prev, spval) + CALL vector_gather_and_write (& + wdsrf_hru_prev, numhru, totalnumhru, hru_data_address, file_restart, 'wdsrf_hru_prev', 'hydrounit') + + END SUBROUTINE WRITE_CatchTimeVariables + + SUBROUTINE deallocate_CatchTimeVariables + + IMPLICIT NONE + + IF (allocated(veloc_elm)) deallocate(veloc_elm) + IF (allocated(veloc_hru)) deallocate(veloc_hru) + IF (allocated(wdsrf_hru)) deallocate(wdsrf_hru) + + IF (allocated(wdsrf_elm_prev)) deallocate(wdsrf_elm_prev) + IF (allocated(wdsrf_hru_prev)) deallocate(wdsrf_hru_prev) + + IF (allocated (wdsrf_bsn )) deallocate (wdsrf_bsn ) + IF (allocated (veloc_riv )) deallocate (veloc_riv ) + IF (allocated (momen_riv )) deallocate (momen_riv ) + IF (allocated (wdsrf_bsn_prev)) deallocate (wdsrf_bsn_prev) + + IF (allocated (wdsrf_bsnhru )) deallocate (wdsrf_bsnhru ) + IF (allocated (veloc_bsnhru )) deallocate (veloc_bsnhru ) + IF (allocated (momen_bsnhru )) deallocate (momen_bsnhru ) + IF (allocated (wdsrf_bsnhru_prev)) deallocate (wdsrf_bsnhru_prev) + + END SUBROUTINE deallocate_CatchTimeVariables + +END MODULE MOD_Catch_Vars_TimeVariables +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 new file mode 100644 index 0000000000..6cb7781616 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 @@ -0,0 +1,230 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_WriteParameters + +CONTAINS + + SUBROUTINE write_catch_parameters + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_Vector_ReadWrite + USE MOD_ElmVector + USE MOD_Catch_Reservoir + USE MOD_Vars_TimeInvariants, only : wf_sand, wf_clay, wf_om, wf_gravels, patchclass + USE MOD_Catch_SubsurfaceFlow, only : hillslope_element, lake_id_elm + USE MOD_HRUVector, only : totalnumhru, hru_data_address, eindx_hru, htype_hru + USE MOD_Mesh, only : numelm + USE MOD_LandHRU, only : numhru + USE MOD_LandPatch, only : hru_patch + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + character(len=256) :: file_parameters + character(len=1) :: slev + real(r8), allocatable :: hrupara(:), varpara(:) + integer :: ilev, i, ps, pe, ielm, ihru, j + + file_parameters = trim(DEF_dir_output) // '/' // trim(DEF_CASE_NAME) // '/catch_parameters.nc' + + IF (p_is_master) THEN + CALL ncio_create_file (trim(file_parameters)) + CALL ncio_define_dimension(file_parameters, 'hydrounit', totalnumhru) + + CALL ncio_write_serial (file_parameters, 'bsn_hru', eindx_hru, 'hydrounit') + CALL ncio_put_attr (file_parameters, 'bsn_hru', & + 'long_name', 'basin index of hydrological units') + + CALL ncio_write_serial (file_parameters, 'hru_type' , htype_hru, 'hydrounit') + CALL ncio_put_attr (file_parameters, 'hru_type' , & + 'long_name', 'index of hydrological units inside basin') + ENDIF + + IF (p_is_worker) THEN + IF (numhru > 0) allocate (hrupara (numhru)) + ENDIF + + DO ilev = 1, 5 + + write(slev,'(i1.1)') ilev + + ! sand + IF (p_is_worker) THEN + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + hrupara(i) = sum(wf_sand(ilev,ps:pe) * hru_patch%subfrc(ps:pe)) + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_sand_l'//slev, 'hydrounit') + + ! clay + IF (p_is_worker) THEN + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + hrupara(i) = sum(wf_clay(ilev,ps:pe) * hru_patch%subfrc(ps:pe)) + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_clay_l'//slev, 'hydrounit') + + ! organic matter + IF (p_is_worker) THEN + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + hrupara(i) = sum(wf_om(ilev,ps:pe) * hru_patch%subfrc(ps:pe)) + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_om_l'//slev, 'hydrounit') + + ! silt + IF (p_is_worker) THEN + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + hrupara(i) = sum((1-wf_sand(ilev,ps:pe)-wf_gravels(ilev,ps:pe)-wf_om(ilev,ps:pe)-wf_clay(ilev,ps:pe)) * hru_patch%subfrc(ps:pe)) + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_silt_l'//slev, 'hydrounit') + ENDDO + + + + IF (p_is_worker) THEN + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + hrupara(i) = patchclass(ps) + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'lulc_igbp', 'hydrounit') + + IF (p_is_worker) THEN + IF (numhru > 0) hrupara(:) = spval + DO ielm = 1, numelm + IF (lake_id_elm(ielm) <= 0) THEN + DO i = 1, hillslope_element(ielm)%nhru + IF (hillslope_element(ielm)%indx(i) /= 0) THEN + ihru = hillslope_element(ielm)%ihru(i) + hrupara(ihru) = hillslope_element(ielm)%plen(i) * 2. + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_length', 'hydrounit') + + IF (p_is_master) THEN + CALL ncio_put_attr (file_parameters, 'slope_length', 'units', 'm') + CALL ncio_put_attr (file_parameters, 'slope_length', 'missing_value', spval) + ENDIF + + IF (p_is_worker) THEN + IF (numhru > 0) hrupara(:) = spval + DO ielm = 1, numelm + IF (lake_id_elm(ielm) <= 0) THEN + DO i = 1, hillslope_element(ielm)%nhru + IF (hillslope_element(ielm)%indx(i) /= 0) THEN + ihru = hillslope_element(ielm)%ihru(i) + hrupara(ihru) = hillslope_element(ielm)%elva(i) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'elevation', 'hydrounit') + + IF (p_is_master) THEN + CALL ncio_put_attr (file_parameters, 'elevation', 'units', 'm') + CALL ncio_put_attr (file_parameters, 'elevation', 'missing_value', spval) + ENDIF + + IF (p_is_worker) THEN + IF (numhru > 0) hrupara(:) = spval + DO ielm = 1, numelm + IF (lake_id_elm(ielm) <= 0) THEN + DO i = 1, hillslope_element(ielm)%nhru + IF (hillslope_element(ielm)%indx(i) /= 0) THEN + ihru = hillslope_element(ielm)%ihru(i) + j = hillslope_element(ielm)%inext(i) + IF (j > 0) THEN + hrupara(ihru) = (hillslope_element(ielm)%hand(i) - hillslope_element(ielm)%hand(j)) & + / (hillslope_element(ielm)%plen(i) + hillslope_element(ielm)%plen(j)) + ELSE + hrupara(ihru) = hillslope_element(ielm)%hand(i) / hillslope_element(ielm)%plen(i) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + + CALL vector_gather_and_write (& + hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_ratio', 'hydrounit') + + IF (p_is_master) THEN + CALL ncio_put_attr (file_parameters, 'slope_ratio', 'units', '-') + CALL ncio_put_attr (file_parameters, 'slope_ratio', 'missing_value', spval) + ENDIF + + IF (allocated(hrupara)) deallocate(hrupara) + + + ! ----- reservoirs ----- + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv_uniq > 0) THEN + + IF (p_is_master) THEN + CALL ncio_define_dimension (file_parameters, 'reservoir', numresv_uniq) + CALL ncio_write_serial (file_parameters, 'resv_hylak_id' , resv_hylak_id, 'reservoir') + CALL ncio_put_attr (file_parameters, 'resv_hylak_id' , 'long_name', & + 'HydroLAKE ID of reservoirs') + ENDIF + + allocate (varpara (numresv_uniq)) + + CALL reservoir_gather_var (volresv_total, varpara) + IF (p_is_master) THEN + CALL ncio_write_serial (file_parameters, 'volresv_total', varpara, 'reservoir', 1) + CALL ncio_put_attr (file_parameters, 'volresv_total', 'units', 'm^3') + ENDIF + + CALL reservoir_gather_var (qresv_mean, varpara) + IF (p_is_master) THEN + CALL ncio_write_serial (file_parameters, 'qresv_mean', varpara, 'reservoir', 1) + CALL ncio_put_attr (file_parameters, 'qresv_mean', 'units', 'm^3/s') + ENDIF + + CALL reservoir_gather_var (qresv_flood, varpara) + IF (p_is_master) THEN + CALL ncio_write_serial (file_parameters, 'qresv_flood', varpara, 'reservoir', 1) + CALL ncio_put_attr (file_parameters, 'qresv_flood', 'units', 'm^3/s') + ENDIF + + deallocate (varpara) + + ENDIF + ENDIF + + END SUBROUTINE write_catch_parameters + +END MODULE MOD_Catch_WriteParameters +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 new file mode 100644 index 0000000000..42cd6c7dcf --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 @@ -0,0 +1,711 @@ +#include + +MODULE MOD_ElementNeighbour +!--------------------------------------------------------------------------------! +! DESCRIPTION: ! +! ! +! Element Neighbours : data and communication subroutines. ! +! ! +! Created by Shupeng Zhang, May 2023 ! +!--------------------------------------------------------------------------------! + + USE MOD_Precision + USE MOD_DataType + IMPLICIT NONE + + ! -- neighbour parameters -- + type element_neighbour_type + + integer :: nnb ! number of neighbours + real(r8) :: myarea ! area of this element [m^2] + real(r8) :: myelva ! elevation of this element [m] + + integer*8, allocatable :: glbindex (:) ! neighbour global index + + ! data address: (1,:) refers to process, (2,:) refers to location + integer , allocatable :: addr (:,:) + + real(r8), allocatable :: dist (:) ! distance between element centers [m] + real(r8), allocatable :: lenbdr (:) ! length of boundary line [m] + real(r8), allocatable :: area (:) ! area of neighbours [m^2] + real(r8), allocatable :: elva (:) ! elevation of neighbours [m] + real(r8), allocatable :: slope (:) ! slope (positive) [-] + + END type element_neighbour_type + + type(element_neighbour_type), allocatable :: elementneighbour (:) + + ! -- neighbour communication -- + type neighbour_sendrecv_type + integer :: ndata + integer*8, allocatable :: glbindex (:) + integer, allocatable :: ielement (:) + END type neighbour_sendrecv_type + + type(neighbour_sendrecv_type), allocatable :: recvaddr(:) + type(neighbour_sendrecv_type), allocatable :: sendaddr(:) + + INTERFACE allocate_neighbour_data + MODULE procedure allocate_neighbour_data_real8 + MODULE procedure allocate_neighbour_data_logic + END INTERFACE allocate_neighbour_data + +CONTAINS + + ! ---------- + SUBROUTINE element_neighbour_init (patcharea, lc_year) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_Mesh + USE MOD_Pixel + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_Utils + IMPLICIT NONE + + integer, intent(in) :: lc_year ! which year of land cover data used + real(r8), intent(in) :: patcharea (:) + + ! Local Variables + character(len=256) :: neighbour_file + + integer :: ielm + integer :: iwork, mesg(2), isrc, idest + integer :: nrecv, irecv + integer :: iloc, iloc1, iloc2 + integer :: nnb, nnbinq, inb, ndata + + integer :: maxnnb + integer , allocatable :: nnball (:) + integer , allocatable :: idxnball (:,:) + real(r8), allocatable :: lenbdall (:,:) + + integer , allocatable :: addrelement(:) + + integer*8, allocatable :: eindex (:) + integer, allocatable :: icache1 (:) + integer, allocatable :: icache2 (:,:) + real(r8), allocatable :: rcache2 (:,:) + + integer*8, allocatable :: elm_sorted (:) + integer, allocatable :: order (:) + integer*8, allocatable :: idxinq (:) + integer, allocatable :: addrinq (:) + + logical, allocatable :: mask(:) + + real(r8), allocatable :: rlon_b(:), rlat_b(:) + type(pointer_real8_1d), allocatable :: rlon_nb(:), rlat_nb(:) + + real(r8), allocatable :: area_b(:) + real(r8), allocatable :: elva_b(:) + + character(len=256) :: lndname, cyear + real(r8), allocatable :: elv_patches(:) + + type(pointer_real8_1d), allocatable :: area_nb (:) ! m^2 + type(pointer_real8_1d), allocatable :: elva_nb (:) ! m + + integer :: istt, iend + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + neighbour_file = DEF_ElementNeighbour_file + + IF (p_is_master) THEN + CALL ncio_read_serial (neighbour_file, 'num_neighbour', nnball ) + CALL ncio_read_serial (neighbour_file, 'idx_neighbour', idxnball) + CALL ncio_read_serial (neighbour_file, 'len_border' , lenbdall) + + maxnnb = size(idxnball,1) + + lenbdall = lenbdall * 1.e3 ! km to m + ENDIF + +#ifdef USEMPI + + CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + + IF (p_is_master) THEN + + allocate (addrelement (size(nnball))) + addrelement(:) = -1 + + DO iwork = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + + allocate (eindex (nrecv)) + allocate (icache1 (nrecv)) + allocate (icache2 (maxnnb,nrecv)) + allocate (rcache2 (maxnnb,nrecv)) + + CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + addrelement(eindex) = isrc + + idest = isrc + + icache1 = nnball(eindex) + CALL mpi_send (icache1, nrecv, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + icache2(:,irecv) = idxnball(:,eindex(irecv)) + ENDDO + CALL mpi_send (icache2, maxnnb*nrecv, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + rcache2(:,irecv) = lenbdall(:,eindex(irecv)) + ENDDO + CALL mpi_send (rcache2, maxnnb*nrecv, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (eindex ) + deallocate (icache1) + deallocate (icache2) + deallocate (rcache2) + + ENDIF + ENDDO + ENDIF +#endif + + IF (p_is_worker) THEN + + IF (numelm > 0) THEN + allocate (eindex (numelm)) + eindex = landelm%eindex + ENDIF + +#ifdef USEMPI + mesg(1:2) = (/p_iam_glb, numelm/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numelm > 0) THEN + CALL mpi_send (eindex, numelm, MPI_INTEGER8, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + + allocate (nnball (numelm)) + CALL mpi_recv (nnball, numelm, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (idxnball (maxnnb,numelm)) + CALL mpi_recv (idxnball, maxnnb*numelm, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (lenbdall (maxnnb,numelm)) + CALL mpi_recv (lenbdall, maxnnb*numelm, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF +#else + allocate (icache1 (numelm)) + allocate (icache2 (maxnnb,numelm)) + allocate (rcache2 (maxnnb,numelm)) + + icache1 = nnball + icache2 = idxnball + rcache2 = lenbdall + + DO ielm = 1, numelm + nnball (ielm) = icache1 (eindex(ielm)) + idxnball (:,ielm) = icache2 (:,eindex(ielm)) + lenbdall (:,ielm) = rcache2 (:,eindex(ielm)) + ENDDO + + deallocate (icache1, icache2, rcache2) +#endif + + IF (numelm > 0) THEN + + allocate (elementneighbour (numelm)) + + DO ielm = 1, numelm + nnb = nnball(ielm) + elementneighbour(ielm)%nnb = nnb + + IF (nnb > 0) THEN + allocate (elementneighbour(ielm)%glbindex (nnb)) + allocate (elementneighbour(ielm)%lenbdr (nnb)) + allocate (elementneighbour(ielm)%addr (2,nnb)) + + elementneighbour(ielm)%glbindex = idxnball(1:nnb,ielm) + elementneighbour(ielm)%lenbdr = lenbdall(1:nnb,ielm) + elementneighbour(ielm)%addr(1,:) = -9999 + ENDIF + ENDDO + ENDIF + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_master) THEN + DO iwork = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + allocate (eindex (nrecv)) + allocate (icache1 (nrecv)) + + CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + icache1 = addrelement(eindex) + + idest = isrc + CALL mpi_send (icache1, nrecv, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate(eindex, icache1) + ENDIF + ENDDO + ENDIF +#endif + + IF (p_is_worker) THEN + + IF (numelm > 0) THEN + allocate (elm_sorted (numelm)) + allocate (order (numelm)) + + elm_sorted = eindex + order = (/(ielm, ielm = 1, numelm)/) + + CALL quicksort (numelm, elm_sorted, order) + +#ifdef USEMPI + allocate(idxinq (numelm*maxnnb)) +#endif + + nnbinq = 0 + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + + IF (elementneighbour(ielm)%glbindex(inb) <= 0) CYCLE ! skip ocean neighbour + + iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), numelm, elm_sorted) + IF (iloc > 0) THEN + elementneighbour(ielm)%addr(1,inb) = -1 + elementneighbour(ielm)%addr(2,inb) = order(iloc) +#ifdef USEMPI + ELSE + CALL insert_into_sorted_list1 (elementneighbour(ielm)%glbindex(inb), nnbinq, idxinq, iloc) +#endif + ENDIF + ENDDO + ENDDO + ELSE + nnbinq = 0 + ENDIF + +#ifdef USEMPI + mesg(1:2) = (/p_iam_glb, nnbinq/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (nnbinq > 0) THEN + + CALL mpi_send (idxinq(1:nnbinq), nnbinq, MPI_INTEGER8, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + + allocate (addrinq (nnbinq)) + CALL mpi_recv (addrinq, nnbinq, MPI_INTEGER, & + p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + + ENDIF + + IF (nnbinq > 0) allocate(mask (nnbinq)) + + allocate (recvaddr (0:p_np_worker-1)) + DO iwork = 0, p_np_worker-1 + IF (nnbinq > 0) THEN + mask = (addrinq == p_address_worker(iwork)) + ndata = count(mask) + ELSE + ndata = 0 + ENDIF + + recvaddr(iwork)%ndata = ndata + IF (ndata > 0) THEN + allocate (recvaddr(iwork)%glbindex (ndata)) + recvaddr(iwork)%glbindex = pack(idxinq(1:nnbinq), mask) + ENDIF + ENDDO + + IF (nnbinq > 0) deallocate(mask) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF ((elementneighbour(ielm)%addr(1,inb) == -9999) & + .and. (elementneighbour(ielm)%glbindex(inb) > 0)) THEN ! skip ocean neighbour + + iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & + nnbinq, idxinq(1:nnbinq)) + + iwork = p_itis_worker(addrinq(iloc)) + iloc1 = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & + recvaddr(iwork)%ndata, recvaddr(iwork)%glbindex) + + elementneighbour(ielm)%addr(1,inb) = iwork + elementneighbour(ielm)%addr(2,inb) = iloc1 + ENDIF + ENDDO + ENDDO + + allocate (sendaddr (0:p_np_worker-1)) + DO iwork = 0, p_np_worker-1 + sendaddr(iwork)%ndata = 0 + ENDDO + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN + iwork = elementneighbour(ielm)%addr(1,inb) + sendaddr(iwork)%ndata = sendaddr(iwork)%ndata + 1 + ENDIF + ENDDO + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) + sendaddr(iwork)%ndata = 0 + ENDIF + ENDDO + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN + iwork = elementneighbour(ielm)%addr(1,inb) + CALL insert_into_sorted_list1 (eindex(ielm), & + sendaddr(iwork)%ndata, sendaddr(iwork)%glbindex, iloc) + ENDIF + ENDDO + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + IF (sendaddr(iwork)%ndata < size(sendaddr(iwork)%glbindex)) THEN + allocate (icache1 (sendaddr(iwork)%ndata)) + icache1 = sendaddr(iwork)%glbindex(1:sendaddr(iwork)%ndata) + + deallocate (sendaddr(iwork)%glbindex) + allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) + sendaddr(iwork)%glbindex = icache1 + + deallocate (icache1) + ENDIF + ENDIF + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + allocate (sendaddr(iwork)%ielement (sendaddr(iwork)%ndata)) + + DO inb = 1, sendaddr(iwork)%ndata + iloc = find_in_sorted_list1 (sendaddr(iwork)%glbindex(inb), numelm, elm_sorted) + sendaddr(iwork)%ielement(inb) = order(iloc) + ENDDO + ENDIF + ENDDO +#endif + ENDIF + + IF (allocated(addrelement)) deallocate(addrelement) + IF (allocated(elm_sorted )) deallocate(elm_sorted ) + IF (allocated(nnball )) deallocate(nnball ) + IF (allocated(idxnball )) deallocate(idxnball ) + IF (allocated(lenbdall )) deallocate(lenbdall ) + IF (allocated(eindex )) deallocate(eindex ) + IF (allocated(icache1 )) deallocate(icache1 ) + IF (allocated(icache2 )) deallocate(icache2 ) + IF (allocated(rcache2 )) deallocate(rcache2 ) + IF (allocated(order )) deallocate(order ) + IF (allocated(idxinq )) deallocate(idxinq ) + IF (allocated(addrinq )) deallocate(addrinq ) + IF (allocated(mask )) deallocate(mask ) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + write(cyear,'(i4.4)') lc_year + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/elevation_patches.nc' + CALL ncio_read_vector (lndname, 'elevation_patches', landpatch, elv_patches) + + IF (p_is_worker) THEN + + DO ielm = 1, numelm + nnb = elementneighbour(ielm)%nnb + IF (nnb > 0) THEN + allocate (elementneighbour(ielm)%dist (nnb)) + allocate (elementneighbour(ielm)%area (nnb)) + allocate (elementneighbour(ielm)%elva (nnb)) + allocate (elementneighbour(ielm)%slope (nnb)) + ENDIF + ENDDO + + IF (numelm > 0) THEN + allocate (rlon_b(numelm)) + allocate (rlat_b(numelm)) + CALL landelm%get_lonlat_radian (rlon_b, rlat_b) + ENDIF + + CALL allocate_neighbour_data (rlon_nb) + CALL allocate_neighbour_data (rlat_nb) + + CALL retrieve_neighbour_data (rlon_b, rlon_nb) + CALL retrieve_neighbour_data (rlat_b, rlat_nb) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour + elementneighbour(ielm)%dist(inb) = 1.0e3 * arclen ( & + rlat_b (ielm), rlon_b (ielm), & + rlat_nb(ielm)%val(inb), rlon_nb(ielm)%val(inb)) + elementneighbour(ielm)%dist(inb) = max(elementneighbour(ielm)%dist(inb), 90.) + ENDIF + ENDDO + ENDDO + + IF (numelm > 0) THEN + allocate (area_b(numelm)) + allocate (elva_b(numelm)) + DO ielm = 1, numelm + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + area_b(ielm) = sum(patcharea(istt:iend)) + elva_b(ielm) = sum(elv_patches(istt:iend) * elm_patch%subfrc(istt:iend)) + + elementneighbour(ielm)%myarea = area_b(ielm) + elementneighbour(ielm)%myelva = elva_b(ielm) + ENDDO + ENDIF + + CALL allocate_neighbour_data (area_nb) + CALL retrieve_neighbour_data (area_b, area_nb) + + CALL allocate_neighbour_data (elva_nb) + CALL retrieve_neighbour_data (elva_b, elva_nb) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour + elementneighbour(ielm)%area (inb) = area_nb(ielm)%val(inb) + elementneighbour(ielm)%elva (inb) = elva_nb(ielm)%val(inb) + elementneighbour(ielm)%slope(inb) = & + abs(elva_nb(ielm)%val(inb) - elva_b(ielm)) / elementneighbour(ielm)%dist(inb) + ENDIF + ENDDO + ENDDO + + IF (allocated(rlon_b )) deallocate(rlon_b ) + IF (allocated(rlat_b )) deallocate(rlat_b ) + IF (allocated(elva_b )) deallocate(elva_b ) + IF (allocated(area_b )) deallocate(area_b ) + IF (allocated(rlon_nb)) deallocate(rlon_nb) + IF (allocated(rlat_nb)) deallocate(rlat_nb) + IF (allocated(area_nb)) deallocate(area_nb) + IF (allocated(elva_nb)) deallocate(elva_nb) + + ENDIF + + END SUBROUTINE element_neighbour_init + + ! ---------- + SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Mesh, only: numelm + IMPLICIT NONE + + real(r8), intent(inout) :: vec_in (:) + type(pointer_real8_1d) :: nbdata (:) + + ! Local Variables + logical, allocatable :: smask(:), rmask(:) + integer, allocatable :: req_send(:), req_recv(:) + type(pointer_real8_1d), allocatable :: sbuff(:), rbuff(:) + integer :: iwork, ielm, inb, iloc + + IF (p_is_worker) THEN + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb)== -1) THEN + iloc = elementneighbour(ielm)%addr(2,inb) + nbdata(ielm)%val(inb) = vec_in(iloc) + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + CALL mpi_barrier (p_comm_worker, p_err) + + allocate (smask (0:p_np_worker-1)) + allocate (req_send (0:p_np_worker-1)) + allocate (sbuff (0:p_np_worker-1)) + smask(:) = .false. + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + smask(iwork) = .true. + + allocate (sbuff(iwork)%val (sendaddr(iwork)%ndata)) + sbuff(iwork)%val = vec_in(sendaddr(iwork)%ielement) + + CALL mpi_isend(sbuff(iwork)%val, sendaddr(iwork)%ndata, MPI_REAL8, & + p_address_worker(iwork), 101, p_comm_glb, req_send(iwork), p_err) + ENDIF + ENDDO + + allocate (rmask (0:p_np_worker-1)) + allocate (req_recv (0:p_np_worker-1)) + allocate (rbuff (0:p_np_worker-1)) + rmask(:) = .false. + + DO iwork = 0, p_np_worker-1 + IF (recvaddr(iwork)%ndata > 0) THEN + rmask(iwork) = .true. + + allocate (rbuff(iwork)%val (recvaddr(iwork)%ndata)) + + CALL mpi_irecv(rbuff(iwork)%val, recvaddr(iwork)%ndata, MPI_REAL8, & + p_address_worker(iwork), 101, p_comm_glb, req_recv(iwork), p_err) + ENDIF + ENDDO + + IF (any(rmask)) THEN + + CALL mpi_waitall(count(rmask), pack(req_recv,rmask), MPI_STATUSES_IGNORE, p_err) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN + iwork = elementneighbour(ielm)%addr(1,inb) + iloc = elementneighbour(ielm)%addr(2,inb) + nbdata(ielm)%val(inb) = rbuff(iwork)%val(iloc) + ENDIF + ENDDO + ENDDO + ENDIF + + IF (any(smask)) THEN + CALL mpi_waitall(count(smask), pack(req_send,smask), MPI_STATUSES_IGNORE, p_err) + ENDIF + + IF (allocated(smask)) deallocate(smask) + IF (allocated(rmask)) deallocate(rmask) + + IF (allocated(req_send)) deallocate(req_send) + IF (allocated(req_recv)) deallocate(req_recv) + + IF (allocated(sbuff)) deallocate(sbuff) + IF (allocated(rbuff)) deallocate(rbuff) + + CALL mpi_barrier (p_comm_worker, p_err) +#endif + + ENDIF + + END SUBROUTINE retrieve_neighbour_data + + ! --- + SUBROUTINE allocate_neighbour_data_real8 (nbdata) + + USE MOD_Mesh, only: numelm + IMPLICIT NONE + + type(pointer_real8_1d), allocatable :: nbdata(:) + integer :: ielm + + IF (numelm > 0) THEN + allocate (nbdata(numelm)) + DO ielm = 1, numelm + IF (elementneighbour(ielm)%nnb > 0) THEN + allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb)) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE allocate_neighbour_data_real8 + + ! --- + SUBROUTINE allocate_neighbour_data_logic (nbdata) + + USE MOD_Mesh, only: numelm + IMPLICIT NONE + + type(pointer_logic_1d), allocatable :: nbdata(:) + integer :: ielm + + IF (numelm > 0) THEN + allocate (nbdata(numelm)) + DO ielm = 1, numelm + IF (elementneighbour(ielm)%nnb > 0) THEN + allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb)) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE allocate_neighbour_data_logic + + ! ---------- + SUBROUTINE element_neighbour_final () + + IMPLICIT NONE + integer :: i + + IF (allocated(elementneighbour)) THEN + DO i = 1, size(elementneighbour) + IF (allocated(elementneighbour(i)%glbindex)) deallocate(elementneighbour(i)%glbindex) + IF (allocated(elementneighbour(i)%addr )) deallocate(elementneighbour(i)%addr ) + IF (allocated(elementneighbour(i)%dist )) deallocate(elementneighbour(i)%dist ) + IF (allocated(elementneighbour(i)%lenbdr)) deallocate(elementneighbour(i)%lenbdr) + IF (allocated(elementneighbour(i)%area )) deallocate(elementneighbour(i)%area ) + IF (allocated(elementneighbour(i)%elva )) deallocate(elementneighbour(i)%elva ) + IF (allocated(elementneighbour(i)%slope )) deallocate(elementneighbour(i)%slope ) + ENDDO + deallocate(elementneighbour) + ENDIF + + IF (allocated(recvaddr)) THEN + DO i = lbound(recvaddr,1), ubound(recvaddr,1) + IF (allocated(recvaddr(i)%glbindex)) deallocate(recvaddr(i)%glbindex) + IF (allocated(recvaddr(i)%ielement)) deallocate(recvaddr(i)%ielement) + ENDDO + ENDIF + + IF (allocated(sendaddr)) THEN + DO i = lbound(sendaddr,1), ubound(sendaddr,1) + IF (allocated(sendaddr(i)%glbindex)) deallocate(sendaddr(i)%glbindex) + IF (allocated(sendaddr(i)%ielement)) deallocate(sendaddr(i)%ielement) + ENDDO + ENDIF + + IF (allocated(recvaddr)) deallocate(recvaddr) + IF (allocated(sendaddr)) deallocate(sendaddr) + + END SUBROUTINE element_neighbour_final + +END MODULE MOD_ElementNeighbour diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 new file mode 100644 index 0000000000..0eae2905a6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -0,0 +1,341 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_Reservoir +!----------------------------------------------------------------------- +! DESCRIPTION: +! +! Reservoir module in gridded mesh. +! +! Created by Shupeng Zhang, Oct 2025 +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_DataType + + integer :: totalnumresv + integer :: numresv + integer, allocatable :: ucat2resv (:) + integer, allocatable :: resv_global_index(:) + type(pointer_int32_1d), allocatable :: resv_data_address (:) + + + ! parameters + integer, allocatable :: dam_GRAND_ID (:) ! GRAND dam ID + + integer, allocatable :: dam_build_year(:) ! year in which the dam/barrier was built + + real(r8), allocatable :: volresv_total (:) ! total reservoir volume [m^3] + real(r8), allocatable :: volresv_emerg (:) ! emergency reservoir volume [m^3] + real(r8), allocatable :: volresv_adjust(:) ! adjustment reservoir volume [m^3] + real(r8), allocatable :: volresv_normal(:) ! normal reservoir volume [m^3] + + real(r8), allocatable :: qresv_flood (:) ! flood reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_adjust (:) ! adjustment reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_normal (:) ! normal reservoir outflow [m^3/s] + + ! fluxes + real(r8), allocatable :: qresv_in (:) ! reservoir inflow [m^3/s] + real(r8), allocatable :: qresv_out (:) ! reservoir outflow [m^3/s] + + ! -- PUBLIC SUBROUTINEs -- + PUBLIC :: reservoir_init + PUBLIC :: reservoir_operation + PUBLIC :: reservoir_final + +CONTAINS + + ! ------- + SUBROUTINE reservoir_init ( ) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Utils + USE MOD_Namelist, only: DEF_ReservoirPara_file + USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid, lake_type + + IMPLICIT NONE + + ! Local variables + character(len=256) :: parafile + + integer, allocatable :: dam_seq(:), order(:), local_ucid(:) + real(r8), allocatable :: rcache (:) + integer, allocatable :: icache (:) + + integer, parameter :: dam_seq_chunk_size = 1048576 + integer :: i, iloc, irsv, nresv, iworker + integer :: istart, iend, local_index + + + parafile = DEF_ReservoirPara_file + +#ifndef MPAS_EMBEDDED_COLM + IF (p_is_master) THEN + CALL ncio_read_serial (parafile, 'dam_GRAND_ID', dam_GRAND_ID) + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_seq', dam_seq) + + totalnumresv = size(dam_seq) +#else + CALL ncio_inquire_length (parafile, 'dam_seq', totalnumresv) +#endif + + IF (p_is_worker) THEN + + allocate (ucat2resv (numucat)) + ucat2resv = 0 + allocate (resv_global_index(numucat)) + + numresv = 0 + +#ifdef MPAS_EMBEDDED_COLM + IF (numucat > 0 .and. totalnumresv > 0) THEN + allocate (order (numucat)) + allocate (local_ucid (numucat)) + + order = (/(i, i = 1, numucat)/) + local_ucid = ucat_ucid + CALL quicksort (numucat, local_ucid, order) + + istart = 1 + DO WHILE (istart <= totalnumresv) + iend = min(istart + dam_seq_chunk_size - 1, totalnumresv) + CALL ncio_read_part_serial (parafile, 'dam_seq', istart, iend, dam_seq) + + DO i = lbound(dam_seq,1), ubound(dam_seq,1) + iloc = find_in_sorted_list1 (dam_seq(i), numucat, local_ucid) + IF (iloc > 0) THEN + local_index = order(iloc) + IF (ucat2resv(local_index) == 0) THEN + numresv = numresv + 1 + lake_type(local_index) = 2 + ucat2resv(local_index) = numresv + resv_global_index(numresv) = i + ENDIF + ENDIF + ENDDO + + deallocate (dam_seq) + istart = iend + 1 + ENDDO + ENDIF +#else + allocate (order (totalnumresv)) + order = (/(i, i = 1, totalnumresv)/) + + CALL quicksort (totalnumresv, dam_seq, order) + + DO i = 1, numucat + iloc = find_in_sorted_list1 (ucat_ucid(i), totalnumresv, dam_seq) + IF (iloc > 0) THEN + numresv = numresv + 1 + lake_type(i) = 2 + ucat2resv(i) = numresv + resv_global_index(numresv) = order(iloc) + ENDIF + ENDDO +#endif + + ENDIF + +#ifdef MPAS_EMBEDDED_COLM + ! MPAS embedded mode writes reservoir restart state from each owning rank + ! with resv_global_index, so no master-side global address table is needed. +#else +#ifdef COLM_PARALLEL + IF (p_is_master) THEN + + allocate (resv_data_address (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + + IF (p_address_worker(iworker) == p_iam_glb) THEN + nresv = numresv + ELSE + CALL mpi_recv (nresv, 1, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + ENDIF + + IF (nresv > 0) THEN + allocate (resv_data_address(iworker)%val (nresv)) + IF (p_address_worker(iworker) == p_iam_glb) THEN + resv_data_address(iworker)%val = resv_global_index(1:nresv) + ELSE + CALL mpi_recv (resv_data_address(iworker)%val, nresv, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + + CALL mpi_send (numresv, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numresv > 0) THEN + CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + ENDIF +#else + IF (numresv > 0) THEN + allocate (resv_data_address (0:0)) + allocate (resv_data_address(0)%val (numresv)) + resv_data_address(0)%val = resv_global_index(1:numresv) + ENDIF +#endif +#endif + + IF (p_is_worker) THEN + + IF (numresv > 0) THEN + + allocate (dam_build_year (numresv)) + + allocate (volresv_total (numresv)) + allocate (volresv_emerg (numresv)) + allocate (volresv_adjust (numresv)) + allocate (volresv_normal (numresv)) + + allocate (qresv_flood (numresv)) + allocate (qresv_adjust (numresv)) + allocate (qresv_normal (numresv)) + + allocate (qresv_in (numresv)) + allocate (qresv_out (numresv)) + + ENDIF + + ENDIF + +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_worker .and. (numresv > 0)) THEN + CALL ncio_read_indexed_serial (parafile, 'dam_year', resv_global_index(1:numresv), icache) + dam_build_year = icache + + CALL ncio_read_indexed_serial (parafile, 'dam_TotalVol_mcm', resv_global_index(1:numresv), rcache) + volresv_total = rcache*1.e6 + + CALL ncio_read_indexed_serial (parafile, 'dam_ConVol_mcm', resv_global_index(1:numresv), rcache) + volresv_normal = rcache*1.e6 + + CALL ncio_read_indexed_serial (parafile, 'dam_Qn', resv_global_index(1:numresv), rcache) + qresv_normal = rcache + + CALL ncio_read_indexed_serial (parafile, 'dam_Qf', resv_global_index(1:numresv), rcache) + qresv_flood = rcache + ENDIF +#else + CALL ncio_read_bcast_serial (parafile, 'dam_year', icache) + IF (p_is_worker .and. (numresv > 0)) THEN + dam_build_year = icache(resv_global_index(1:numresv)) + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_TotalVol_mcm', rcache) + IF (p_is_worker .and. (numresv > 0)) THEN + volresv_total = rcache(resv_global_index(1:numresv))*1.e6 + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_ConVol_mcm', rcache) + IF (p_is_worker .and. (numresv > 0)) THEN + volresv_normal = rcache(resv_global_index(1:numresv))*1.e6 + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_Qn', rcache) + IF (p_is_worker .and. (numresv > 0)) THEN + qresv_normal = rcache(resv_global_index(1:numresv)) + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_Qf', rcache) + IF (p_is_worker .and. (numresv > 0)) THEN + qresv_flood = rcache(resv_global_index(1:numresv)) + ENDIF +#endif + + + IF (p_is_worker) THEN + DO irsv = 1, numresv + volresv_emerg (irsv) = volresv_total(irsv) * 0.94 + volresv_adjust(irsv) = volresv_total(irsv) * 0.77 + volresv_normal(irsv) = min(volresv_total(irsv)*0.7, volresv_normal(irsv)) + qresv_adjust (irsv) = (qresv_normal(irsv) + qresv_flood(irsv)) * 0.5 + ENDDO + ENDIF + + IF (allocated(dam_seq)) deallocate(dam_seq) + IF (allocated(order )) deallocate(order ) + IF (allocated(rcache )) deallocate(rcache ) + IF (allocated(icache )) deallocate(icache ) + + END SUBROUTINE reservoir_init + + + SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) + + IMPLICIT NONE + integer, intent(in) :: method + integer, intent(in) :: irsv + real(r8), intent(in) :: qin, vol + real(r8), intent(out) :: qout + + ! local variables + real(r8) :: q1 + + IF (method == 1) THEN + ! *** Reference *** + ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. + ! Development of an Improved Reservoir Operation Scheme for Global Flood Modeling (CaMa-Flood v4.20). + ! ESS Open Archive . October 24, 2024. + + IF (vol > volresv_emerg(irsv)) THEN + qout = max(qin, qresv_flood(irsv)) + ELSEIF (vol > volresv_adjust(irsv)) THEN + qout = qresv_adjust(irsv) + (qresv_flood(irsv)-qresv_adjust(irsv)) & + * ((vol-volresv_adjust(irsv))/(volresv_emerg(irsv)-volresv_adjust(irsv)))**0.1 + IF (qin > qresv_flood(irsv)) THEN + q1 = qresv_normal(irsv) + (qin-qresv_normal(irsv)) & + * (vol-volresv_normal(irsv))/(volresv_emerg(irsv)-volresv_normal(irsv)) + qout = max(q1, qout) + ENDIF + ELSEIF (vol > volresv_normal(irsv)) THEN + qout = qresv_normal(irsv) + (qresv_adjust(irsv)-qresv_normal(irsv)) & + * ((vol-volresv_normal(irsv))/(volresv_adjust(irsv)-volresv_normal(irsv)))**3. + ELSE + qout = (vol/volresv_normal(irsv))**0.5 * qresv_normal(irsv) + ENDIF + + ENDIF + + END SUBROUTINE reservoir_operation + + + SUBROUTINE reservoir_final () + + IMPLICIT NONE + + IF (allocated(ucat2resv )) deallocate (ucat2resv ) + IF (allocated(resv_global_index)) deallocate (resv_global_index) + IF (allocated(resv_data_address)) deallocate (resv_data_address) + + IF (allocated(dam_GRAND_ID )) deallocate (dam_GRAND_ID ) + IF (allocated(dam_build_year )) deallocate (dam_build_year ) + + IF (allocated(volresv_total )) deallocate (volresv_total ) + IF (allocated(volresv_emerg )) deallocate (volresv_emerg ) + IF (allocated(volresv_adjust )) deallocate (volresv_adjust ) + IF (allocated(volresv_normal )) deallocate (volresv_normal ) + + IF (allocated(qresv_flood )) deallocate (qresv_flood ) + IF (allocated(qresv_adjust )) deallocate (qresv_adjust ) + IF (allocated(qresv_normal )) deallocate (qresv_normal ) + + IF (allocated(qresv_in )) deallocate (qresv_in ) + IF (allocated(qresv_out )) deallocate (qresv_out ) + + END SUBROUTINE reservoir_final + +END MODULE MOD_Grid_Reservoir +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 new file mode 100644 index 0000000000..f82bd0f75d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -0,0 +1,764 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeFlow +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! River Lake flow. +! +!------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Grid_RiverLakeNetwork + USE MOD_Grid_RiverLakeTimeVars + USE MOD_Grid_Reservoir + USE MOD_Grid_RiverLakeHist +#ifdef GridRiverLakeSediment + USE MOD_Grid_RiverLakeSediment, only: grid_sediment_init, grid_sediment_calc, & + grid_sediment_final, sediment_diag_accumulate, sediment_forcing_put, & + read_sediment_restart +#endif + IMPLICIT NONE + + real(r8), parameter :: RIVERMIN = 1.e-5_r8 + + real(r8), save :: acctime_rnof_max + + real(r8) :: acctime_rnof + real(r8), allocatable :: acc_rnof_uc (:) + logical, allocatable :: filter_rnof (:) + +CONTAINS + + ! --------- + SUBROUTINE grid_riverlake_flow_init () + + USE MOD_LandPatch, only: numpatch + USE MOD_Forcing, only: forcmask_pch + USE MOD_Vars_TimeInvariants, only: patchtype, patchmask + IMPLICIT NONE + + acctime_rnof_max = DEF_GRIDBASED_ROUTING_MAX_DT + acctime_rnof = 0. + + IF (p_is_worker) THEN + ! Allocate on all workers (zero-length if numucat/numpatch=0) + ! to avoid passing unallocated arrays to assumed-shape MPI wrappers. + allocate (acc_rnof_uc (numucat)) + acc_rnof_uc = 0. + ENDIF + + ! excluding (patchtype >= 99), virtual patches and those forcing missed + IF (p_is_worker) THEN + allocate (filter_rnof (numpatch)) + IF (numpatch > 0) THEN + filter_rnof = patchtype < 99 + filter_rnof = filter_rnof .and. patchmask + IF (DEF_forcing%has_missing_value) THEN + filter_rnof = filter_rnof .and. forcmask_pch + ENDIF + ENDIF + ENDIF + +#ifdef GridRiverLakeSediment + CALL grid_sediment_init() + IF (len_trim(gridriver_restart_file) > 0) THEN + CALL read_sediment_restart(gridriver_restart_file) + ENDIF +#endif + + END SUBROUTINE grid_riverlake_flow_init + + ! --------- + SUBROUTINE grid_riverlake_flow (year, deltime) + + USE MOD_Utils + USE MOD_Namelist, only: DEF_Reservoir_Method, DEF_USE_SEDIMENT + USE MOD_Vars_1DFluxes, only: rnof + USE MOD_Mesh, only: numelm + USE MOD_LandPatch, only: elm_patch, numpatch + USE MOD_Const_Physical, only: grav + USE MOD_Vars_Global, only: spval +#ifdef GridRiverLakeSediment + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl +#endif + IMPLICIT NONE + + integer, intent(in) :: year + real(r8), intent(in) :: deltime + + ! Local Variables + integer :: i, j, irsv, ntimestep + real(r8) :: dt_this + integer :: sed_clock_start, sed_clock_end, sed_clock_rate + real(r8) :: sed_elapsed + + real(r8), allocatable :: rnof_gd(:) + real(r8), allocatable :: rnof_uc(:) + +#ifdef GridRiverLakeSediment + real(r8), allocatable :: prcp_gd(:) + real(r8), allocatable :: prcp_uc(:) + real(r8), allocatable :: prcp_pch(:) + real(r8), allocatable :: floodarea_sed(:) +#endif + + logical, allocatable :: is_built_resv(:) + + real(r8), allocatable :: wdsrf_next(:) + real(r8), allocatable :: veloc_next(:) + + real(r8), allocatable :: hflux_fc(:) + real(r8), allocatable :: mflux_fc(:) + real(r8), allocatable :: zgrad_dn(:) + + real(r8), allocatable :: hflux_resv(:) + real(r8), allocatable :: mflux_resv(:) + + real(r8), allocatable :: hflux_sumups(:) + real(r8), allocatable :: mflux_sumups(:) + real(r8), allocatable :: zgrad_sumups(:) + + real(r8), allocatable :: sum_hflux_riv(:) + real(r8), allocatable :: sum_mflux_riv(:) + real(r8), allocatable :: sum_zgrad_riv(:) + + real(r8) :: veloct_fc, height_fc, momen_fc, zsurf_fc + real(r8) :: bedelv_fc, height_up, height_dn + real(r8) :: vwave_up, vwave_dn, hflux_up, hflux_dn, mflux_up, mflux_dn + real(r8) :: volwater, friction, floodarea + real(r8), allocatable :: dt_res(:), dt_all(:) + logical, allocatable :: ucatfilter(:) +#ifdef CoLMDEBUG + real(r8) :: totalvol_bef, totalvol_aft, totalrnof, totaldis +#endif + + + IF (p_is_worker) THEN + + allocate (rnof_gd (numinpm)) + allocate (rnof_uc (numucat)) + + CALL worker_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & + fillvalue = 0., filter = filter_rnof) + + IF (numinpm > 0) THEN + WHERE (push_ucat2inpm%sum_area > 0) + rnof_gd = rnof_gd / push_ucat2inpm%sum_area + END WHERE + ENDIF + + CALL worker_push_data (push_inpm2ucat, rnof_gd, rnof_uc, & + fillvalue = 0., mode = 'sum') + + IF (numucat > 0) THEN + acc_rnof_uc = acc_rnof_uc + rnof_uc*1.e-3*deltime + ENDIF + + deallocate(rnof_gd) + deallocate(rnof_uc) + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT) THEN + ! Allocate zero-length arrays on empty workers to avoid passing unallocated + ! arrays to assumed-shape dummy arguments in MPI communication routines. + IF (numpatch > 0) THEN + allocate (prcp_pch (numpatch)) + prcp_pch = forc_prc + forc_prl + ELSE + allocate (prcp_pch (0)) + ENDIF + IF (numinpm > 0) THEN + allocate (prcp_gd (numinpm)) + ELSE + allocate (prcp_gd (0)) + ENDIF + IF (numucat > 0) THEN + allocate (prcp_uc (numucat)) + ELSE + allocate (prcp_uc (0)) + ENDIF + + CALL worker_remap_data_pset2grid (remap_patch2inpm, prcp_pch, prcp_gd, & + fillvalue = 0., filter = filter_rnof) + + IF (numinpm > 0) THEN + WHERE (push_ucat2inpm%sum_area > 0) + prcp_gd = prcp_gd / push_ucat2inpm%sum_area + END WHERE + ENDIF + + CALL worker_push_data (push_inpm2ucat, prcp_gd, prcp_uc, & + fillvalue = 0., mode = 'sum') + + ! Convert from area-integrated [mm/s * m²] back to flux density [mm/s]. + ! push_data(mode='sum') produces area-integrated values (like rnof_uc), + ! but the sediment yield formula expects a rate and multiplies by area internally. + IF (numucat > 0) THEN + WHERE (topo_area > 0._r8) + prcp_uc = prcp_uc / topo_area + END WHERE + ENDIF + + CALL sediment_forcing_put(prcp_uc, deltime) + + deallocate(prcp_pch) + deallocate(prcp_gd) + deallocate(prcp_uc) + ENDIF +#endif + + ENDIF + + + acctime_rnof = acctime_rnof + deltime + + IF (acctime_rnof+0.01 < acctime_rnof_max) THEN + RETURN + ENDIF + + IF (p_is_worker) THEN + + IF (numucat > 0) THEN + + allocate (is_built_resv (numucat)) + allocate (wdsrf_next (numucat)) + allocate (veloc_next (numucat)) + allocate (hflux_fc (numucat)) + allocate (mflux_fc (numucat)) + allocate (zgrad_dn (numucat)) + allocate (sum_hflux_riv (numucat)) + allocate (sum_mflux_riv (numucat)) + allocate (sum_zgrad_riv (numucat)) + allocate (ucatfilter (numucat)) + + allocate (hflux_sumups (numucat)) + allocate (mflux_sumups (numucat)) + allocate (zgrad_sumups (numucat)) + + IF (DEF_Reservoir_Method > 0) THEN + allocate (hflux_resv (numucat)) + allocate (mflux_resv (numucat)) + ENDIF + + allocate (dt_res (numrivsys)) + allocate (dt_all (numrivsys)) + + ENDIF + +#ifdef CoLMDEBUG + totalrnof = sum(acc_rnof_uc) + totalvol_bef = 0. +#endif + + DO i = 1, numucat + + is_built_resv(i) = .false. + IF (lake_type(i) == 2) THEN + irsv = ucat2resv(i) + IF (year >= dam_build_year(irsv)) THEN + is_built_resv(i) = .true. + IF (volresv(irsv) == spval) THEN + volresv(irsv) = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + wdsrf_ucat(i) = floodplain_curve(i)%depth (volresv(irsv)) + ENDIF + ENDIF + ENDIF + + IF (.not. is_built_resv(i)) THEN + momen_riv(i) = wdsrf_ucat(i) * veloc_riv(i) + volwater = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + ! water in reservoirs is assumued to be stationary. + momen_riv(i) = 0 + veloc_riv(i) = 0 + volwater = volresv(ucat2resv(i)) + ENDIF + +#ifdef CoLMDEBUG + totalvol_bef = totalvol_bef + volwater +#endif + + volwater = volwater + acc_rnof_uc(i) + + IF (.not. is_built_resv(i)) THEN + wdsrf_ucat(i) = floodplain_curve(i)%depth (volwater) + IF (wdsrf_ucat(i) > RIVERMIN) THEN + veloc_riv(i) = momen_riv(i) / wdsrf_ucat(i) + ELSE + veloc_riv(i) = 0. + ENDIF + ELSE + volresv(ucat2resv(i)) = volwater + ENDIF + + ENDDO + + + ntimestep = 0 +#ifdef CoLMDEBUG + totaldis = 0. +#endif + + dt_res(:) = acctime_rnof + + DO WHILE (any(dt_res > 0)) + + ntimestep = ntimestep + 1 + + CALL worker_push_data (push_next2ucat, wdsrf_ucat, wdsrf_next, fillvalue = spval) + ! velocity in ocean or inland depression is assumed to be 0. + CALL worker_push_data (push_next2ucat, veloc_riv, veloc_next, fillvalue = 0.) + + dt_all(:) = min(dt_res(:), 60.) + + DO i = 1, numucat + + ucatfilter(i) = dt_all(irivsys(i)) > 0 + + IF (.not. ucatfilter(i)) CYCLE + + sum_hflux_riv(i) = 0. + sum_mflux_riv(i) = 0. + sum_zgrad_riv(i) = 0. + + ! reservoir + IF (is_built_resv(i)) THEN + hflux_fc(i) = 0. + mflux_fc(i) = 0. + zgrad_dn(i) = 0. + CYCLE + ENDIF + + IF ((ucat_next(i) > 0) .or. (ucat_next(i) == -9)) THEN + + IF (ucat_next(i) > 0) THEN + ! both rivers are dry. + IF ((wdsrf_ucat(i) < RIVERMIN) .and. (wdsrf_next(i) < RIVERMIN)) THEN + hflux_fc(i) = 0 + mflux_fc(i) = 0 + zgrad_dn(i) = 0 + CYCLE + ENDIF + ENDIF + + ! reconstruction of height of water near interface + IF (ucat_next(i) > 0) THEN + bedelv_fc = max(topo_rivelv(i), bedelv_next(i)) + height_up = max(0., wdsrf_ucat(i)+topo_rivelv(i)-bedelv_fc) + height_dn = max(0., wdsrf_next(i)+bedelv_next(i)-bedelv_fc) + ELSEIF (ucat_next(i) == -9) THEN ! for river mouth + bedelv_fc = topo_rivelv(i) + height_up = wdsrf_ucat (i) + ! sea level is assumed to be 0. and sea bed is assumed to be negative infinity. + height_dn = max(0., - bedelv_fc) + ENDIF + + ! velocity at river downstream face (middle region in Riemann problem) + veloct_fc = 0.5 * (veloc_riv(i) + veloc_next(i)) & + + sqrt(grav * height_up) - sqrt(grav * height_dn) + + ! height of water at downstream face (middle region in Riemann problem) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn)) & + + 0.25 * (veloc_riv(i) - veloc_next(i))) ** 2 + + IF (height_up > 0) THEN + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + ELSE + vwave_up = veloc_next(i) - 2.0 * sqrt(grav*height_dn) + ENDIF + + IF (height_dn > 0) THEN + vwave_dn = max(veloc_next(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + ELSE + vwave_dn = veloc_riv(i) + 2.0 * sqrt(grav*height_up) + ENDIF + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_next(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_next(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + zgrad_dn(i) = outletwth(i) * 0.5*grav * height_dn**2 + + ELSEIF (ucat_next(i) == -99) THEN + ! downstream is not in model region. + ! assume: 1. downstream river bed is equal to this river bed. + ! 2. downstream water surface is equal to this river depth. + ! 3. downstream water velocity is equal to this velocity. + + veloc_riv(i) = max(veloc_riv(i), 0.) + + IF (wdsrf_ucat(i) > topo_rivhgt(i)) THEN + + ! reconstruction of height of water near interface + height_up = wdsrf_ucat (i) + height_dn = topo_rivhgt(i) + + veloct_fc = veloc_riv(i) + sqrt(grav * height_up) - sqrt(grav * height_dn) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn))) ** 2 + + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + vwave_dn = max(veloc_riv(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_riv(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_riv(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + ELSE + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + ELSEIF (ucat_next(i) == -10) THEN ! inland depression + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) + sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) + + ENDDO + + CALL worker_push_data (push_ups2ucat, hflux_fc, hflux_sumups, fillvalue = 0., mode = 'sum') + CALL worker_push_data (push_ups2ucat, mflux_fc, mflux_sumups, fillvalue = 0., mode = 'sum') + CALL worker_push_data (push_ups2ucat, zgrad_dn, zgrad_sumups, fillvalue = 0., mode = 'sum') + + IF (numucat > 0) THEN + WHERE (ucatfilter) + sum_hflux_riv = sum_hflux_riv - hflux_sumups + sum_mflux_riv = sum_mflux_riv - mflux_sumups + sum_zgrad_riv = sum_zgrad_riv - zgrad_sumups + END WHERE + ENDIF + + ! reservoir operation. + IF (DEF_Reservoir_Method > 0) THEN + + DO i = 1, numucat + + IF ((.not. ucatfilter(i)) .or. (ucat_next(i) == -10)) CYCLE + + hflux_resv(i) = 0. + mflux_resv(i) = 0. + + IF (is_built_resv(i)) THEN + + irsv = ucat2resv(i) + qresv_in(irsv) = - sum_hflux_riv(i) + + IF (volresv(irsv) > 1.e-4 * volresv_total(irsv)) THEN + CALL reservoir_operation (DEF_Reservoir_Method, & + irsv, qresv_in(irsv), volresv(irsv), qresv_out(irsv)) + ELSE + qresv_out (irsv) = 0. + ENDIF + + hflux_fc(i) = qresv_out(irsv) + mflux_fc(i) = qresv_out(irsv) * sqrt(2*grav*wdsrf_ucat(i)) + + sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) + sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) + + hflux_resv(i) = hflux_fc(i) + mflux_resv(i) = mflux_fc(i) + ENDIF + + ENDDO + + CALL worker_push_data (push_ups2ucat, hflux_resv, hflux_sumups, fillvalue = 0., mode = 'sum') + CALL worker_push_data (push_ups2ucat, mflux_resv, mflux_sumups, fillvalue = 0., mode = 'sum') + + IF (numucat > 0) THEN + WHERE (ucatfilter) + sum_hflux_riv = sum_hflux_riv - hflux_sumups + sum_mflux_riv = sum_mflux_riv - mflux_sumups + END WHERE + ENDIF + + ENDIF + + DO i = 1, numucat + + IF (.not. ucatfilter(i)) CYCLE + + dt_this = dt_all(irivsys(i)) + + ! constraint 1: CFL condition (only for rivers) + IF (.not. is_built_resv(i)) THEN + IF ((veloc_riv(i) /= 0.) .or. (wdsrf_ucat(i) > 0.)) THEN + dt_this = min(dt_this, topo_rivlen(i)/(abs(veloc_riv(i))+sqrt(grav*wdsrf_ucat(i)))*0.8) + ENDIF + ENDIF + + ! constraint 2: Avoid negative values of water + IF (sum_hflux_riv(i) > 0) THEN + IF (.not. is_built_resv(i)) THEN + ! for river or lake catchment + volwater = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + ! for reservoir + volwater = volresv(ucat2resv(i)) + ENDIF + + dt_this = min(dt_this, volwater / sum_hflux_riv(i)) + + ENDIF + + ! constraint 3: Avoid change of flow direction (only for rivers) + ! IF (.not. is_built_resv(i)) THEN + ! IF ((abs(veloc_riv(i)) > 0.1) & + ! .and. (veloc_riv(i) * (sum_mflux_riv(i)-sum_zgrad_riv(i)) > 0)) THEN + ! dt_this = min(dt_this, & + ! abs(momen_riv(i) * topo_rivare(i) / (sum_mflux_riv(i)-sum_zgrad_riv(i)))) + ! ENDIF + ! ENDIF + + dt_all(irivsys(i)) = min(dt_this, dt_all(irivsys(i))) + + ENDDO + +#ifdef COLM_PARALLEL + IF (rivsys_by_multiple_procs) THEN + CALL mpi_allreduce (MPI_IN_PLACE, dt_all, 1, MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err) + ENDIF +#endif + + DO i = 1, numucat + + IF (.not. ucatfilter(i)) CYCLE + + IF (.not. is_built_resv(i)) THEN + volwater = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + volwater = volresv(ucat2resv(i)) + ENDIF + + volwater = volwater - sum_hflux_riv(i) * dt_all(irivsys(i)) + volwater = max(volwater, 0.) + + ! for inland depression, remove excess water (to be optimized) + IF (ucat_next(i) == -10) THEN + IF (volwater > topo_rivstomax(i)) THEN + hflux_fc(i) = (volwater - topo_rivstomax(i)) / dt_all(irivsys(i)) + volwater = topo_rivstomax(i) + ENDIF + ENDIF + + wdsrf_ucat(i) = floodplain_curve(i)%depth (volwater) + + IF (is_built_resv(i)) THEN + volresv(ucat2resv(i)) = volwater + ENDIF + + IF ((.not. is_built_resv(i)) .and. (wdsrf_ucat(i) >= RIVERMIN)) THEN + friction = grav * topo_rivman(i)**2 / wdsrf_ucat(i)**(7.0/3.0) * abs(momen_riv(i)) + momen_riv(i) = (momen_riv(i) & + - (sum_mflux_riv(i) - sum_zgrad_riv(i)) / topo_rivare(i) * dt_all(irivsys(i))) & + / (1 + friction * dt_all(irivsys(i))) + veloc_riv(i) = momen_riv(i) / wdsrf_ucat(i) + ELSE + momen_riv(i) = 0 + veloc_riv(i) = 0 + ENDIF + + ! inland depression river + IF ((.not. is_built_resv(i)) .and. (ucat_next(i) == -10)) THEN + momen_riv(i) = min(0., momen_riv(i)) + veloc_riv(i) = min(0., veloc_riv(i)) + ENDIF + + veloc_riv(i) = min(veloc_riv(i), 20.) + veloc_riv(i) = max(veloc_riv(i), -20.) + + ENDDO + + DO i = 1, numucat + IF (ucatfilter(i)) THEN + +#ifdef CoLMDEBUG + IF (ucat_next(i) <= 0) THEN + totaldis = totaldis + hflux_fc(i)*dt_all(irivsys(i)) + ENDIF +#endif + + IF (allocated(acctime_ucat) .and. allocated(a_wdsrf_ucat) .and. & + allocated(a_veloc_riv) .and. allocated(a_discharge) .and. & + allocated(a_floodarea)) THEN + acctime_ucat(i) = acctime_ucat(i) + dt_all(irivsys(i)) + + a_wdsrf_ucat(i) = a_wdsrf_ucat(i) + wdsrf_ucat(i) * dt_all(irivsys(i)) + a_veloc_riv (i) = a_veloc_riv (i) + veloc_riv (i) * dt_all(irivsys(i)) + a_discharge (i) = a_discharge (i) + hflux_fc (i) * dt_all(irivsys(i)) + + floodarea = floodplain_curve(i)%floodarea (wdsrf_ucat(i)) + a_floodarea (i) = a_floodarea (i) + floodarea * dt_all(irivsys(i)) + + IF (is_built_resv(i) .and. allocated(acctime_resv) .and. & + allocated(a_volresv) .and. allocated(a_qresv_in) .and. & + allocated(a_qresv_out)) THEN + irsv = ucat2resv(i) + acctime_resv(irsv) = acctime_resv(irsv) + dt_all(irivsys(i)) + a_volresv (irsv) = a_volresv (irsv) + volresv (irsv) * dt_all(irivsys(i)) + a_qresv_in (irsv) = a_qresv_in (irsv) + qresv_in (irsv) * dt_all(irivsys(i)) + a_qresv_out (irsv) = a_qresv_out(irsv) + qresv_out(irsv) * dt_all(irivsys(i)) + ENDIF + ENDIF + + ENDIF + ENDDO + + dt_res = dt_res - dt_all + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT) THEN + IF (numucat > 0) THEN + allocate(floodarea_sed(numucat)) + DO i = 1, numucat + IF (ucatfilter(i)) THEN + floodarea_sed(i) = floodplain_curve(i)%floodarea(wdsrf_ucat(i)) + ELSE + floodarea_sed(i) = 0._r8 + ENDIF + ENDDO + ELSE + allocate(floodarea_sed(0)) + ENDIF + CALL sediment_diag_accumulate(dt_all, irivsys, ucatfilter, & + veloc_riv, wdsrf_ucat, hflux_fc, floodarea_sed) + deallocate(floodarea_sed) + ENDIF +#endif + + ENDDO + +#ifdef CoLMDEBUG + totalvol_aft = 0. + DO i = 1, numucat + IF (.not. is_built_resv(i)) THEN + totalvol_aft = totalvol_aft + floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + totalvol_aft = totalvol_aft + volresv(ucat2resv(i)) + ENDIF + ENDDO +#endif + ENDIF + +#ifdef CoLMDEBUG +#ifdef COLM_PARALLEL + IF (.not. p_is_worker) ntimestep = 0 + CALL mpi_allreduce (MPI_IN_PLACE, ntimestep, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err) + + IF (.not. p_is_worker) totalvol_bef = 0. + IF (.not. p_is_worker) totalvol_aft = 0. + IF (.not. p_is_worker) totalrnof = 0. + IF (.not. p_is_worker) totaldis = 0. + + CALL mpi_allreduce (MPI_IN_PLACE, totalvol_bef, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, totalvol_aft, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, totalrnof, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, totaldis, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/,A)') 'Checking River Routing Flow ...' + write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', acctime_rnof/ntimestep, ' seconds' + write(*,'(A,ES8.1,A)') 'Total water before : ', totalvol_bef, ' m^3' + write(*,'(A,ES8.1,A)') 'Total runoff : ', totalrnof, ' m^3' + write(*,'(A,ES8.1,A)') 'Total discharge : ', totaldis, ' m^3' + write(*,'(A,ES8.1,A)') 'Total water change : ', totalvol_aft-totalvol_bef, ' m^3' + write(*,'(A,ES8.1,A)') 'Total water balance : ', totalvol_aft-totalvol_bef-totalrnof+totaldis, ' m^3' + ENDIF +#endif + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT .and. p_is_worker) THEN + ! All workers must participate (MPI point-to-point inside push_data). + ! fldfrc is now computed inside grid_sediment_calc from per-routing-period + ! accumulators (sed_acc_floodarea), not from history-period averages. + CALL grid_sediment_calc(acctime_rnof) + ENDIF +#endif + + acctime_rnof = 0. + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + acc_rnof_uc = 0. + ENDIF + ENDIF + + IF (allocated(is_built_resv)) deallocate(is_built_resv) + IF (allocated(wdsrf_next )) deallocate(wdsrf_next ) + IF (allocated(veloc_next )) deallocate(veloc_next ) + IF (allocated(hflux_fc )) deallocate(hflux_fc ) + IF (allocated(mflux_fc )) deallocate(mflux_fc ) + IF (allocated(zgrad_dn )) deallocate(zgrad_dn ) + IF (allocated(hflux_resv )) deallocate(hflux_resv ) + IF (allocated(mflux_resv )) deallocate(mflux_resv ) + IF (allocated(hflux_sumups )) deallocate(hflux_sumups ) + IF (allocated(mflux_sumups )) deallocate(mflux_sumups ) + IF (allocated(zgrad_sumups )) deallocate(zgrad_sumups ) + IF (allocated(sum_hflux_riv)) deallocate(sum_hflux_riv) + IF (allocated(sum_mflux_riv)) deallocate(sum_mflux_riv) + IF (allocated(sum_zgrad_riv)) deallocate(sum_zgrad_riv) + IF (allocated(ucatfilter )) deallocate(ucatfilter ) + IF (allocated(dt_res )) deallocate(dt_res ) + IF (allocated(dt_all )) deallocate(dt_all ) + + END SUBROUTINE grid_riverlake_flow + + ! --------- + SUBROUTINE grid_riverlake_flow_final () + + CALL riverlake_network_final () + + IF (DEF_Reservoir_Method > 0) THEN + CALL reservoir_final () + ENDIF + +#ifdef GridRiverLakeSediment + CALL grid_sediment_final() +#endif + + IF (allocated(acc_rnof_uc)) deallocate(acc_rnof_uc) + IF (allocated(filter_rnof)) deallocate(filter_rnof) + + END SUBROUTINE grid_riverlake_flow_final + +END MODULE MOD_Grid_RiverLakeFlow +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 new file mode 100644 index 0000000000..23953f875a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 @@ -0,0 +1,756 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeHist +!-------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Write out model results in lateral hydrological processes to history files. +! +! Created by Shupeng Zhang, May 2023 +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_DataType +#ifdef GridRiverLakeSediment + USE MOD_Grid_RiverLakeSediment, only: nsed, sed_hist_acctime, & + a_sedcon, a_sedout, a_bedout, a_sedinp, a_netflw, a_layer, a_shearvel +#endif + + ! -- ACC Fluxes -- + real(r8), allocatable :: acctime_ucat (:) + + real(r8), allocatable :: a_wdsrf_ucat (:) + real(r8), allocatable :: a_veloc_riv (:) + real(r8), allocatable :: a_discharge (:) + real(r8), allocatable :: a_floodarea (:) ! flooded area [m^2] + + real(r8), allocatable :: a_wdsrf_ucat_pch (:) + real(r8), allocatable :: a_veloc_riv_pch (:) + real(r8), allocatable :: a_discharge_pch (:) + real(r8), allocatable :: a_dis_rmth_pch (:) + real(r8), allocatable :: a_floodfrc_pch (:) ! flooded area [m^2] + + ! for reservoirs + real(r8), allocatable :: acctime_resv (:) + + real(r8), allocatable :: a_volresv (:) ! reservoir water volume [m^3] + real(r8), allocatable :: a_qresv_in (:) ! inflow to reservoir [m^3/s] + real(r8), allocatable :: a_qresv_out (:) ! outflow from reservoir [m^3/s] + + ! grid information + real(r8), allocatable :: lon_ucat (:) + real(r8), allocatable :: lat_ucat (:) + + ! auxiliary data + type(block_data_real8_2d) :: sumarea_ucat ! 1) area covered by unit catchments + logical, allocatable :: filter_ucat (:) + real(r8), allocatable :: sum_grid_area (:) ! sum area of patches inside one grid + + logical, allocatable :: filter_rivmth (:) ! 2) area covered by river mouths + real(r8), allocatable :: sum_rmth_area (:) + + logical, allocatable :: filter_inpm (:) ! 3) area covered by input matrix + type(block_data_real8_2d) :: sumarea_inpm + + type(block_data_real8_2d) :: allups_mask_grid ! 4) mask of unit catchments with all + real(r8), allocatable :: allups_mask_pch (:) ! upstreams in simulation region + + ! -- PUBLIC SUBROUTINEs -- + PUBLIC :: hist_grid_riverlake_init + PUBLIC :: hist_grid_riverlake_out + PUBLIC :: hist_grid_riverlake_final + +!-------------------------------------------------------------------------- +CONTAINS + + !--------------------------------------- + SUBROUTINE hist_grid_riverlake_init (histform) + + USE MOD_Block + USE MOD_WorkerPushData + USE MOD_HistGridded + USE MOD_Grid_RiverLakeNetwork + USE MOD_Grid_Reservoir, only: numresv + USE MOD_LandPatch, only: numpatch + USE MOD_Forcing, only: forcmask_pch + USE MOD_Vars_TimeInvariants, only: patchtype, patchmask + + IMPLICIT NONE + + character(len=*), intent(in) :: histform + + ! Local Variables + logical, allocatable :: filter_basic(:) + real(r8), allocatable :: vec_ucat(:), vec_grid(:), vec_inpm(:), vec_patch(:) + integer :: ilon, iblkme, iblk, jblk + + + ! ----- allocate memory for accumulative variables ----- + IF (p_is_worker) THEN + + allocate (acctime_ucat (numucat)) + allocate (a_wdsrf_ucat (numucat)) + allocate (a_veloc_riv (numucat)) + allocate (a_discharge (numucat)) + allocate (a_floodarea (numucat)) + + allocate (a_wdsrf_ucat_pch (numpatch)) + allocate (a_veloc_riv_pch (numpatch)) + allocate (a_discharge_pch (numpatch)) + allocate (a_dis_rmth_pch (numpatch)) + allocate (a_floodfrc_pch (numpatch)) + + allocate (acctime_resv (numresv)) + allocate (a_volresv (numresv)) + allocate (a_qresv_in (numresv)) + allocate (a_qresv_out (numresv)) + + ENDIF + + CALL flush_acc_fluxes_riverlake () + + ! ----- get longitude and latitude ----- + IF (p_is_master) THEN + allocate (lon_ucat (griducat%nlon)) + allocate (lat_ucat (griducat%nlat)) + + lat_ucat = (griducat%lat_s + griducat%lat_n) * 0.5 + + DO ilon = 1, griducat%nlon + IF (griducat%lon_w(ilon) > griducat%lon_e(ilon)) THEN + lon_ucat(ilon) = (griducat%lon_w(ilon) + griducat%lon_e(ilon)+360.) * 0.5 + CALL normalize_longitude (lon_ucat(ilon)) + ELSE + lon_ucat(ilon) = (griducat%lon_w(ilon) + griducat%lon_e(ilon)) * 0.5 + ENDIF + ENDDO + ENDIF + + ! ----- for auxiliary data ----- + IF (p_is_worker) THEN + allocate (vec_ucat (numucat )) + allocate (vec_grid (numinpm )) + allocate (vec_inpm (numinpm )) + allocate (vec_patch (numpatch)) + + ! Patches excluding (type >= 99), virtual patches and thos forcing missed + allocate (filter_basic (numpatch)) + IF (numpatch > 0) THEN + filter_basic = patchtype < 99 + filter_basic = filter_basic .and. patchmask + IF (DEF_forcing%has_missing_value) THEN + filter_basic = filter_basic .and. forcmask_pch + ENDIF + ENDIF + ENDIF + + ! ----- 1) area and filter covered by unit catchments ----- + IF (p_is_worker) THEN + + IF (numucat > 0) vec_ucat = 1. + + CALL worker_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) + CALL worker_remap_data_grid2pset ( & + remap_patch2inpm, vec_grid, vec_patch, fillvalue = spval, mode = 'average') + + allocate (filter_ucat (numpatch)) + IF (numpatch > 0) THEN + filter_ucat = filter_basic .and. (vec_patch /= spval) + + WHERE (filter_ucat) + vec_patch = 1 + ELSE WHERE + vec_patch = spval + END WHERE + ENDIF + + allocate (sum_grid_area (numinpm)) + CALL worker_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & + fillvalue = spval, filter = filter_ucat) + CALL worker_push_data (allreduce_inpm, vec_grid, sum_grid_area, fillvalue = spval) + ENDIF + +#ifndef MPAS_EMBEDDED_COLM + IF (trim(histform) == 'Gridded') THEN + IF (p_is_io) CALL allocate_block_data (ghist, sumarea_ucat) + CALL mp2g_hist%get_sumarea (sumarea_ucat, filter_ucat) + ENDIF +#endif + + ! ----- 2) area and filter covered by river mouth ----- + IF (p_is_worker) THEN + IF (numucat > 0) THEN + WHERE (ucat_next == -9) + vec_ucat = 1. + ELSE WHERE + vec_ucat = spval + END WHERE + ENDIF + + CALL worker_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) + CALL worker_remap_data_grid2pset (remap_patch2inpm, vec_grid, vec_patch, & + fillvalue = spval, mode = 'average') + + allocate (filter_rivmth (numpatch)) + IF (numpatch > 0) THEN + filter_rivmth = filter_ucat .and. (vec_patch /= spval) + + WHERE (filter_rivmth) + vec_patch = 1 + ELSE WHERE + vec_patch = spval + END WHERE + ENDIF + + allocate (sum_rmth_area (numinpm)) + + CALL worker_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & + fillvalue = spval, filter = filter_rivmth) + CALL worker_push_data (allreduce_inpm, vec_grid, sum_rmth_area, fillvalue = spval) + ENDIF + + ! ----- 3) area covered by input matrix ----- + IF (p_is_worker) THEN + IF (numucat > 0) vec_ucat = 1. + CALL worker_push_data (push_ucat2inpm, vec_ucat, vec_inpm, & + fillvalue = spval, mode = 'average') + CALL worker_remap_data_grid2pset (remap_patch2inpm, vec_inpm, vec_patch, & + fillvalue = spval, mode = 'average') + + allocate (filter_inpm (numpatch)) + IF (numpatch > 0) THEN + filter_inpm = filter_basic .and. (vec_patch /= spval) + ENDIF + ENDIF + +#ifndef MPAS_EMBEDDED_COLM + IF (trim(histform) == 'Gridded') THEN + IF (p_is_io) CALL allocate_block_data (ghist, sumarea_inpm) + CALL mp2g_hist%get_sumarea (sumarea_inpm, filter_inpm) + ENDIF +#endif + + ! ----- 4) mask of unit catchments with all upstreams in simulation region ----- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (allups_mask_pch (numpatch)) + ENDIF + ENDIF + + IF (p_is_worker) THEN + CALL worker_push_data (push_ucat2grid, allups_mask_ucat, vec_grid, fillvalue = spval) + CALL worker_remap_data_grid2pset ( & + remap_patch2inpm, vec_grid, allups_mask_pch, fillvalue = spval, mode = 'average') + ENDIF + +#ifndef MPAS_EMBEDDED_COLM + IF (trim(histform) == 'Gridded') THEN + + IF (p_is_io) CALL allocate_block_data (ghist, allups_mask_grid) + + CALL mp2g_hist%pset2grid (allups_mask_pch, allups_mask_grid, spv = spval, msk = filter_ucat) + + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE (sumarea_ucat%blk(iblk,jblk)%val > 0.) + allups_mask_grid%blk(iblk,jblk)%val = & + allups_mask_grid%blk(iblk,jblk)%val / sumarea_ucat%blk(iblk,jblk)%val + ELSE WHERE + allups_mask_grid%blk(iblk,jblk)%val = spval + END WHERE + ENDDO + ENDIF + + ENDIF +#endif + + IF (allocated (vec_ucat )) deallocate (vec_ucat ) + IF (allocated (vec_grid )) deallocate (vec_grid ) + IF (allocated (vec_inpm )) deallocate (vec_inpm ) + IF (allocated (vec_patch )) deallocate (vec_patch ) + IF (allocated (filter_basic)) deallocate (filter_basic) + + END SUBROUTINE hist_grid_riverlake_init + + !--------------------------------------- + SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, is_first_in_file) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_WorkerPushData + USE MOD_Grid_RiverLakeNetwork + USE MOD_Grid_Reservoir + USE MOD_Vector_ReadWrite + USE MOD_HistGridded +#ifdef UNSTRUCTURED + USE MOD_HistVector +#endif + USE MOD_LandPatch, only: numpatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: histform + integer, intent(in) :: idate(3) + integer, intent(in) :: itime_in_file + logical, intent(in) :: is_first_in_file + + ! Local variables + character(len=256) :: file_hist_ucat + logical :: fexists + integer :: itime_in_file_ucat, i + + real(r8), allocatable :: acc_vec_grid (:) + real(r8), allocatable :: a_floodfrc_ucat (:) ! flooded area fraction + real(r8), allocatable :: a_floodfrc_inpm (:) ! flooded area fraction + + + IF (p_is_master) THEN + i = len_trim (file_hist) + DO WHILE (file_hist(i:i) /= '_') + i = i - 1 + ENDDO + file_hist_ucat = file_hist(1:i) // 'unitcat_' // file_hist(i+1:) + + inquire (file=file_hist_ucat, exist=fexists) + IF (.not. fexists) THEN + + CALL ncio_create_file (trim(file_hist_ucat)) + + CALL ncio_define_dimension (file_hist_ucat, 'time', 0) + CALL ncio_define_dimension (file_hist_ucat, 'lat_ucat', griducat%nlat) + CALL ncio_define_dimension (file_hist_ucat, 'lon_ucat', griducat%nlon) + + CALL ncio_write_serial (file_hist_ucat, 'lat_ucat', lat_ucat, 'lat_ucat') + CALL ncio_write_serial (file_hist_ucat, 'lon_ucat', lon_ucat, 'lon_ucat') + ENDIF + + CALL ncio_write_time (file_hist_ucat, 'time', idate, itime_in_file_ucat, DEF_HIST_FREQ) + + ENDIF + + IF (is_first_in_file) THEN + IF (trim(histform) == 'Gridded') THEN + CALL hist_write_var_real8_2d ( & + file_hist, 'mask_complete_upstream_regird', ghist, -1, allups_mask_grid, compress = 1, & + longname = 'Mask of grids with all upstream located in simulation region', units = '100%') +#ifdef UNSTRUCTURED + ELSE + CALL aggregate_to_vector_and_write_2d ( & + allups_mask_pch, file_hist, 'mask_complete_upstream_regird', -1, filter_ucat, & + longname = 'Mask of grids with all upstream located in simulation region', units = '100%') +#endif + ENDIF + + CALL vector_gather_map2grid_and_write ( & + allups_mask_ucat, numucat, totalnumucat, ucat_data_address, griducat%nlon, x_ucat, & + griducat%nlat, y_ucat, file_hist_ucat, 'mask_complete_upstream', 'lon_ucat', 'lat_ucat', & + longname = 'Mask of grids with all upstream located in simulation region', units = '100%') + ENDIF + + IF (p_is_worker) THEN + allocate (acc_vec_grid (numinpm )) + ENDIF + + IF (DEF_hist_vars%riv_height) THEN + IF (p_is_worker) THEN + IF (numucat > 0) a_wdsrf_ucat = a_wdsrf_ucat / acctime_ucat + CALL worker_push_data (push_ucat2grid, a_wdsrf_ucat, acc_vec_grid, fillvalue = spval) + CALL worker_remap_data_grid2pset ( remap_patch2inpm, acc_vec_grid, a_wdsrf_ucat_pch, & + fillvalue = spval, mode = 'average') + ENDIF + + CALL vector_gather_map2grid_and_write ( a_wdsrf_ucat, numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_wdpth_ucat', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'deepest water depth in river and flood plain', 'm') + ENDIF + + IF (DEF_hist_vars%riv_veloct) THEN + IF (p_is_worker) THEN + IF (numucat > 0) a_veloc_riv = a_veloc_riv / acctime_ucat + CALL worker_push_data (push_ucat2grid, a_veloc_riv, acc_vec_grid, fillvalue = spval) + CALL worker_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_veloc_riv_pch, & + fillvalue = spval, mode = 'average') + ENDIF + + CALL vector_gather_map2grid_and_write ( a_veloc_riv, numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_veloc_riv', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'water velocity in river', 'm/s') + ENDIF + + IF (DEF_hist_vars%discharge) THEN + IF (p_is_worker) THEN + IF (numucat > 0) a_discharge = a_discharge / acctime_ucat + CALL worker_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) + + IF (numinpm > 0) THEN + WHERE ((sum_grid_area /= spval) .and. (acc_vec_grid /= spval)) + acc_vec_grid = acc_vec_grid / sum_grid_area + ELSE WHERE + acc_vec_grid = spval + END WHERE + ENDIF + + CALL worker_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_discharge_pch, & + fillvalue = spval, mode = 'sum') + ENDIF + + CALL vector_gather_map2grid_and_write ( a_discharge, numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_discharge', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'discharge in river and flood plain', 'm^3/s') + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + WHERE (ucat_next /= -9) a_discharge = spval + ENDIF + CALL worker_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) + + IF (numinpm > 0) THEN + WHERE ((sum_rmth_area /= spval) .and. (acc_vec_grid /= spval)) + acc_vec_grid = acc_vec_grid / sum_rmth_area + ELSE WHERE + acc_vec_grid = spval + END WHERE + ENDIF + + CALL worker_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_dis_rmth_pch, & + fillvalue = spval, mode = 'sum') + ENDIF + + CALL vector_gather_map2grid_and_write ( a_discharge, numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_discharge_rivermouth', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'river mouth discharge into ocean', 'm^3/s') + ENDIF + + IF (DEF_hist_vars%floodfrc) THEN + + IF (p_is_worker) THEN + + IF (numucat > 0) a_floodarea = a_floodarea / acctime_ucat + + allocate (a_floodfrc_ucat (numucat)) + IF (numucat > 0) THEN + WHERE (topo_area > 0) + a_floodfrc_ucat = a_floodarea / topo_area + ELSE WHERE + a_floodfrc_ucat = spval + END WHERE + ENDIF + + allocate (a_floodfrc_inpm (numinpm)) + + CALL worker_push_data (push_ucat2inpm, a_floodfrc_ucat, a_floodfrc_inpm, & + fillvalue = spval, mode = 'average') + + CALL worker_remap_data_grid2pset (remap_patch2inpm, a_floodfrc_inpm, a_floodfrc_pch, & + fillvalue = spval, mode = 'average') + ENDIF + + ENDIF + + + IF (allocated (a_floodfrc_ucat)) deallocate (a_floodfrc_ucat) + IF (allocated (a_floodfrc_inpm)) deallocate (a_floodfrc_inpm) + IF (allocated (acc_vec_grid )) deallocate (acc_vec_grid ) + +#ifdef GridRiverLakeSediment + CALL write_sediment_history (file_hist_ucat, itime_in_file_ucat) +#endif + + ! ----- reservoir variables ----- + IF (DEF_Reservoir_Method > 0) THEN + IF (totalnumresv > 0) THEN + + IF (p_is_master) THEN + IF (.not. fexists) THEN + CALL ncio_define_dimension(file_hist_ucat, 'reservoir', totalnumresv) + CALL ncio_write_serial (file_hist_ucat, 'resv_GRAND_ID' , dam_GRAND_ID, 'reservoir') + CALL ncio_put_attr (file_hist_ucat, 'resv_GRAND_ID', 'long_name', 'reservoir GRAND ID') + ENDIF + ENDIF + + IF (DEF_hist_vars%volresv) THEN + IF (p_is_worker) THEN + IF (numresv > 0) THEN + WHERE (acctime_resv > 0) + a_volresv = a_volresv / acctime_resv + ELSEWHERE + a_volresv = spval + END WHERE + ENDIF + ENDIF + + CALL vector_gather_and_write ( a_volresv, numresv, totalnumresv, resv_data_address, & + file_hist_ucat, 'volresv', 'reservoir', itime_in_file_ucat, 'reservoir water volume', 'm^3') + ENDIF + + IF (DEF_hist_vars%qresv_in) THEN + IF (p_is_worker) THEN + IF (numresv > 0) THEN + WHERE (acctime_resv > 0) + a_qresv_in = a_qresv_in / acctime_resv + ELSEWHERE + a_qresv_in = spval + END WHERE + ENDIF + ENDIF + + CALL vector_gather_and_write ( a_qresv_in, numresv, totalnumresv, resv_data_address, & + file_hist_ucat, 'qresv_in', 'reservoir', itime_in_file_ucat, 'reservoir inflow', 'm^3/s') + ENDIF + + IF (DEF_hist_vars%qresv_out) THEN + IF (p_is_worker) THEN + IF (numresv > 0) THEN + WHERE (acctime_resv > 0) + a_qresv_out = a_qresv_out / acctime_resv + ELSEWHERE + a_qresv_out = spval + END WHERE + ENDIF + ENDIF + + CALL vector_gather_and_write ( a_qresv_out, numresv, totalnumresv, resv_data_address, & + file_hist_ucat, 'qresv_out', 'reservoir', itime_in_file_ucat, 'reservoir outflow', 'm^3/s') + ENDIF + + ENDIF + ENDIF + + CALL flush_acc_fluxes_riverlake () + + END SUBROUTINE hist_grid_riverlake_out + + !----------------------- + SUBROUTINE flush_acc_fluxes_riverlake () + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Grid_RiverLakeNetwork, only: numucat + USE MOD_Grid_Reservoir, only: numresv + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numucat > 0) THEN + acctime_ucat (:) = 0. + a_wdsrf_ucat (:) = 0. + a_veloc_riv (:) = 0. + a_discharge (:) = 0. + a_floodarea (:) = 0. + ENDIF + + IF (numresv > 0) THEN + acctime_resv (:) = 0. + a_volresv (:) = 0. + a_qresv_in (:) = 0. + a_qresv_out (:) = 0. + ENDIF + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT .and. allocated(a_sedcon)) THEN + a_sedcon = 0. + a_sedout = 0. + a_bedout = 0. + a_sedinp = 0. + a_netflw = 0. + a_layer = 0. + a_shearvel = 0. + sed_hist_acctime = 0. + ENDIF +#endif + + ENDIF + + END SUBROUTINE flush_acc_fluxes_riverlake + + !--------------------------------------- + SUBROUTINE hist_grid_riverlake_final () + + IMPLICIT NONE + + IF (allocated(acctime_ucat )) deallocate (acctime_ucat ) + IF (allocated(a_wdsrf_ucat )) deallocate (a_wdsrf_ucat ) + IF (allocated(a_veloc_riv )) deallocate (a_veloc_riv ) + IF (allocated(a_discharge )) deallocate (a_discharge ) + IF (allocated(a_floodarea )) deallocate (a_floodarea ) + + IF (allocated(a_wdsrf_ucat_pch)) deallocate (a_wdsrf_ucat_pch) + IF (allocated(a_veloc_riv_pch )) deallocate (a_veloc_riv_pch ) + IF (allocated(a_discharge_pch )) deallocate (a_discharge_pch ) + IF (allocated(a_dis_rmth_pch )) deallocate (a_dis_rmth_pch ) + IF (allocated(a_floodfrc_pch )) deallocate (a_floodfrc_pch ) + + IF (allocated(acctime_resv )) deallocate (acctime_resv ) + IF (allocated(a_volresv )) deallocate (a_volresv ) + IF (allocated(a_qresv_in )) deallocate (a_qresv_in ) + IF (allocated(a_qresv_out )) deallocate (a_qresv_out ) + + IF (allocated(lon_ucat )) deallocate (lon_ucat ) + IF (allocated(lat_ucat )) deallocate (lat_ucat ) + + IF (allocated(filter_ucat )) deallocate (filter_ucat ) + IF (allocated(sum_grid_area )) deallocate (sum_grid_area ) + IF (allocated(filter_rivmth )) deallocate (filter_rivmth ) + IF (allocated(sum_rmth_area )) deallocate (sum_rmth_area ) + IF (allocated(filter_inpm )) deallocate (filter_inpm ) + + IF (allocated(allups_mask_pch )) deallocate (allups_mask_pch ) + + END SUBROUTINE hist_grid_riverlake_final + +#ifdef GridRiverLakeSediment + !--------------------------------------- + SUBROUTINE write_sediment_history (file_hist_ucat, itime_in_file_ucat) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_data_address, & + x_ucat, y_ucat, griducat + USE MOD_Vector_ReadWrite + IMPLICIT NONE + + character(len=*), intent(in) :: file_hist_ucat + integer, intent(in) :: itime_in_file_ucat + + real(r8), allocatable :: a_sedcon_avg(:,:) + real(r8), allocatable :: a_sedout_avg(:,:) + real(r8), allocatable :: a_bedout_avg(:,:) + real(r8), allocatable :: a_sedinp_avg(:,:) + real(r8), allocatable :: a_netflw_avg(:,:) + real(r8), allocatable :: a_layer_avg(:,:) + real(r8), allocatable :: a_shearvel_avg(:) + integer :: ised + character(len=16) :: cised + + IF (.not. DEF_USE_SEDIMENT) RETURN + + ! Allocate on ALL processes (zero-size on non-workers) to avoid + ! passing unallocated arrays to vector_gather_map2grid_and_write + IF (p_is_worker .and. numucat > 0) THEN + allocate (a_sedcon_avg (nsed, numucat)) + allocate (a_sedout_avg (nsed, numucat)) + allocate (a_bedout_avg (nsed, numucat)) + allocate (a_sedinp_avg (nsed, numucat)) + allocate (a_netflw_avg (nsed, numucat)) + allocate (a_layer_avg (nsed, numucat)) + allocate (a_shearvel_avg(numucat)) + + IF (sed_hist_acctime > 0._r8) THEN + a_shearvel_avg = a_shearvel / sed_hist_acctime + DO ised = 1, nsed + a_sedcon_avg(ised,:) = a_sedcon(ised,:) / sed_hist_acctime + a_sedout_avg(ised,:) = a_sedout(ised,:) / sed_hist_acctime + a_bedout_avg(ised,:) = a_bedout(ised,:) / sed_hist_acctime + a_sedinp_avg(ised,:) = a_sedinp(ised,:) / sed_hist_acctime + a_netflw_avg(ised,:) = a_netflw(ised,:) / sed_hist_acctime + a_layer_avg(ised,:) = a_layer(ised,:) / sed_hist_acctime + ENDDO + ELSE + a_shearvel_avg = 0. + a_sedcon_avg = 0. + a_sedout_avg = 0. + a_bedout_avg = 0. + a_sedinp_avg = 0. + a_netflw_avg = 0. + a_layer_avg = 0. + ENDIF + ELSE + ! Allocate with nsed in first dim so a_xxx_avg(ised,:) is a valid zero-length slice + allocate (a_sedcon_avg (nsed, 0)) + allocate (a_sedout_avg (nsed, 0)) + allocate (a_bedout_avg (nsed, 0)) + allocate (a_sedinp_avg (nsed, 0)) + allocate (a_netflw_avg (nsed, 0)) + allocate (a_layer_avg (nsed, 0)) + allocate (a_shearvel_avg(0)) + ENDIF + + IF (DEF_hist_vars%sedcon) THEN + DO ised = 1, nsed + WRITE(cised, '(I0)') ised + CALL vector_gather_map2grid_and_write ( a_sedcon_avg(ised,:), numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_sedcon_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'suspended sediment concentration, size class ' // trim(cised), 'm^3/m^3') + ENDDO + ENDIF + + IF (DEF_hist_vars%sedout) THEN + DO ised = 1, nsed + WRITE(cised, '(I0)') ised + CALL vector_gather_map2grid_and_write ( a_sedout_avg(ised,:), numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_sedout_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'suspended sediment flux, size class ' // trim(cised), 'm^3/s') + ENDDO + ENDIF + + IF (DEF_hist_vars%bedout) THEN + DO ised = 1, nsed + WRITE(cised, '(I0)') ised + CALL vector_gather_map2grid_and_write ( a_bedout_avg(ised,:), numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_bedout_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'bedload flux, size class ' // trim(cised), 'm^3/s') + ENDDO + ENDIF + + IF (DEF_hist_vars%sedinp) THEN + DO ised = 1, nsed + WRITE(cised, '(I0)') ised + CALL vector_gather_map2grid_and_write ( a_sedinp_avg(ised,:), numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_sedinp_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'sediment erosion input, size class ' // trim(cised), 'm^3/s') + ENDDO + ENDIF + + IF (DEF_hist_vars%netflw) THEN + DO ised = 1, nsed + WRITE(cised, '(I0)') ised + CALL vector_gather_map2grid_and_write ( a_netflw_avg(ised,:), numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_netflw_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'net bed-water exchange flux (incl. shallow deposit), size class ' // trim(cised), 'm^3/s') + ENDDO + ENDIF + + IF (DEF_hist_vars%sedlayer) THEN + DO ised = 1, nsed + WRITE(cised, '(I0)') ised + CALL vector_gather_map2grid_and_write ( a_layer_avg(ised,:), numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_layer_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'active layer storage, size class ' // trim(cised), 'm^3') + ENDDO + ENDIF + + IF (DEF_hist_vars%shearvel) THEN + CALL vector_gather_map2grid_and_write ( a_shearvel_avg, numucat, & + totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & + file_hist_ucat, 'f_shearvel', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & + 'shear velocity', 'm/s') + ENDIF + + IF (allocated(a_sedcon_avg )) deallocate (a_sedcon_avg ) + IF (allocated(a_sedout_avg )) deallocate (a_sedout_avg ) + IF (allocated(a_bedout_avg )) deallocate (a_bedout_avg ) + IF (allocated(a_sedinp_avg )) deallocate (a_sedinp_avg ) + IF (allocated(a_netflw_avg )) deallocate (a_netflw_avg ) + IF (allocated(a_layer_avg )) deallocate (a_layer_avg ) + IF (allocated(a_shearvel_avg)) deallocate (a_shearvel_avg) + + END SUBROUTINE write_sediment_history +#endif + +END MODULE MOD_Grid_RiverLakeHist +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 new file mode 100644 index 0000000000..c70313d794 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -0,0 +1,2105 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeNetwork +!-------------------------------------------------------------------------------- +! DESCRIPTION: +!-------------------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_WorkerPushData + IMPLICIT NONE + + ! ----- River Lake network ----- + + type(grid_type) :: griducat + + integer :: totalnumucat + integer :: numucat + integer, allocatable :: ucat_ucid (:) ! index in unit catchment numbering + integer, allocatable :: x_ucat (:) ! + integer, allocatable :: y_ucat (:) ! + integer, allocatable :: ucat_gdid (:) ! + + integer, allocatable :: numucat_wrk (:) + type(pointer_int32_1d), allocatable :: ucat_data_address (:) + + ! ----- Part 1: between runoff input elements and unit catchments ----- + integer :: numinpm + integer, allocatable :: inpm_gdid (:) + + integer :: inpn + integer, allocatable :: idmap_gd2uc (:,:) + real(r8), allocatable :: area_gd2uc (:,:) + + integer :: nucpart + integer, allocatable :: idmap_uc2gd (:,:) + real(r8), allocatable :: area_uc2gd (:,:) + + type(worker_remapdata_type) :: remap_patch2inpm + type(worker_pushdata_type) :: push_inpm2ucat + type(worker_pushdata_type) :: push_ucat2inpm + type(worker_pushdata_type) :: push_ucat2grid + type(worker_pushdata_type) :: allreduce_inpm + + ! ----- Part 2: between upstream and downstream unit catchments ----- + integer, allocatable :: ucat_next (:) ! next unit catchment + integer :: upnmax + integer, allocatable :: ucat_ups (:,:) ! upstream unit catchments + real(r8), allocatable :: wts_ups (:,:) + + type(worker_pushdata_type) :: push_next2ucat + type(worker_pushdata_type) :: push_ups2ucat + + ! ----- Part 3: river systems ----- + integer :: numrivsys + logical :: rivsys_by_multiple_procs + integer, allocatable :: irivsys (:) +#ifdef COLM_PARALLEL + integer :: p_comm_rivsys +#endif + + + ! ----- Parameters for River and Lake ----- + + integer, allocatable :: lake_type (:) ! 0: river; 2: reservoir. + + real(r8), allocatable :: topo_rivelv (:) ! river bed elevation [m] + real(r8), allocatable :: topo_rivhgt (:) ! river channel depth [m] + real(r8), allocatable :: topo_rivlen (:) ! river channel length [m] + real(r8), allocatable :: topo_rivman (:) ! river manning coefficient [m] + real(r8), allocatable :: topo_rivwth (:) ! river channel width [m] + real(r8), allocatable :: topo_rivare (:) ! river channel area [m^2] + real(r8), allocatable :: topo_rivstomax (:) ! max river channel storage [m^3] + + real(r8), allocatable :: topo_area (:) ! floodplain area [m^2] + real(r8), allocatable :: topo_fldhgt (:,:) ! floodplain height profile [m] + + real(r8), allocatable :: bedelv_next (:) ! downstream river bed elevation [m] + real(r8), allocatable :: outletwth (:) ! river outlet width [m] + + type :: vol_dep_curve_type + integer :: nlfp + real(r8) :: rivhgt + real(r8) :: rivare + real(r8) :: rivstomax + real(r8), allocatable :: flphgt (:) ! floodplain height profile [m] + real(r8), allocatable :: flparea (:) ! flood plain area [m^2] + real(r8), allocatable :: flpaccare (:) ! flood plain accumulated area [m^2] + real(r8), allocatable :: flpstomax (:) ! max flood plain storage [m^3] + CONTAINS + procedure, PUBLIC :: depth => retrieve_depth_from_volume + procedure, PUBLIC :: volume => retrieve_volume_from_depth + procedure, PUBLIC :: floodarea => retrieve_area_from_depth + final :: vol_depth_curve_free_mem + END type vol_dep_curve_type + + type(vol_dep_curve_type), allocatable :: floodplain_curve (:) + + + ! ----- Mask of Grids with all upstream area in the simulation region ----- + real(r8), allocatable :: allups_mask_ucat (:) + +CONTAINS + + ! ---------- + SUBROUTINE build_riverlake_network () + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_Mesh + USE MOD_Utils + USE MOD_LandPatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + ! Local Variables + character(len=256) :: parafile + + integer, allocatable :: idmap_x(:,:), idmap_y(:,:) + integer, allocatable :: varsize(:) + + integer :: numrivmth + integer, allocatable :: rivermouth(:) + + integer, allocatable :: nups_nst (:), iups_nst (:), nups_all(:) + integer, allocatable :: ucat_next_all(:) + integer, allocatable :: uc_up2down(:), order_ucat(:) + integer, allocatable :: addr_ucat (:) + + integer , allocatable :: nuc_rs(:), iwrk_rs(:), nwrk_rs(:), nave_rs(:) + real(r8), allocatable :: wt_uc (:), wt_rs (:), wt_wrk (:), nuc_wrk(:) + + integer, allocatable :: grdindex(:) + + + integer, allocatable :: idata1d(:), idata2d(:,:) + real(r8), allocatable :: rdata1d(:), rdata2d(:,:) + + integer, allocatable :: allgrd_in_inp (:), nucat_g2d(:,:), iucat_g(:) + + integer, allocatable :: idmap_uc2gd_all(:,:) + real(r8), allocatable :: area_uc2gd_all (:,:) + + real(r8), allocatable :: ucat_area_all (:) + + integer :: nlat_ucat, nlon_ucat + integer :: nucat, iriv, ngrdall, igrd, ngrd + integer :: p_np_rivsys, color + integer :: iworker, iwrkdsp, self_worker + integer :: iloc, i, j, ithis + real(r8) :: sumwt + logical :: is_new + + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef MPAS_EMBEDDED_COLM + CALL build_riverlake_network_mpas_embedded() + RETURN +#endif + + ! read in parameters from file. + parafile = DEF_UnitCatchment_file + IF (p_is_master) THEN + +#ifdef MPAS_EMBEDDED_COLM + CALL ncio_inquire_length (parafile, 'seq_next', totalnumucat) +#else + CALL ncio_read_serial (parafile, 'seq_x', x_ucat) + CALL ncio_read_serial (parafile, 'seq_y', y_ucat) + totalnumucat = size(x_ucat) +#endif + + CALL ncio_read_serial (parafile, 'seq_next', ucat_next) + + CALL ncio_inquire_length (parafile, 'lon', nlon_ucat) + CALL ncio_inquire_length (parafile, 'lat', nlat_ucat) + +#ifndef MPAS_EMBEDDED_COLM + CALL ncio_read_serial (parafile, 'inpmat_x', idmap_x) + CALL ncio_read_serial (parafile, 'inpmat_y', idmap_y) + CALL ncio_read_serial (parafile, 'inpmat_area', area_gd2uc) +#endif + + ENDIF + + IF (p_is_master) THEN + + allocate (nups_nst (totalnumucat)) + allocate (iups_nst (totalnumucat)) + + nups_nst(:) = 0 + DO i = 1, totalnumucat + j = ucat_next(i) + IF (j > 0) THEN + nups_nst(j) = nups_nst(j) + 1 + ENDIF + ENDDO + + ! sort unit catchment from upstream to downstream, recorded by "uc_up2down" + allocate (uc_up2down (totalnumucat)) + + ithis = 0 + iups_nst(:) = 0 + DO i = 1, totalnumucat + IF (iups_nst(i) == nups_nst(i)) THEN + + ithis = ithis + 1 + uc_up2down(ithis) = i + iups_nst(i) = -1 + + j = ucat_next(i) + DO WHILE (j > 0) + + iups_nst(j) = iups_nst(j) + 1 + + IF (iups_nst(j) == nups_nst(j)) THEN + ithis = ithis + 1 + uc_up2down(ithis) = j + iups_nst(j) = -1 + + j = ucat_next(j) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ENDDO + + ENDIF + +#ifdef COLM_PARALLEL + ! divide unit catchments into groups and assign to workers + IF (p_is_master) THEN + + allocate (wt_uc (totalnumucat)); wt_uc(:) = 1. + + allocate (rivermouth (totalnumucat)) + numrivmth = 0 + DO i = totalnumucat, 1, -1 + j = ucat_next(uc_up2down(i)) + IF (j <= 0) THEN + numrivmth = numrivmth + 1 + rivermouth(uc_up2down(i)) = numrivmth + ELSE + rivermouth(uc_up2down(i)) = rivermouth(j) + ENDIF + ENDDO + + allocate (nuc_rs (numrivmth)); nuc_rs(:) = 0 + allocate (wt_rs (numrivmth)); wt_rs (:) = 0. + DO i = 1, totalnumucat + nuc_rs(rivermouth(i)) = nuc_rs(rivermouth(i)) + 1 + wt_rs (rivermouth(i)) = wt_rs (rivermouth(i)) + wt_uc(i) + ENDDO + + sumwt = sum(wt_rs) + + allocate (iwrk_rs (numrivmth)) + allocate (nwrk_rs (numrivmth)) + allocate (nave_rs (numrivmth)) + + iwrkdsp = -1 + DO i = 1, numrivmth + nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_worker) + IF (nwrk_rs(i) > 1) THEN + + nave_rs(i) = nuc_rs(i) / nwrk_rs(i) + IF (mod(nuc_rs(i), nwrk_rs(i)) /= 0) THEN + nave_rs(i) = nave_rs(i) + 1 + ENDIF + + iwrk_rs(i) = iwrkdsp + 1 + iwrkdsp = iwrkdsp + nwrk_rs(i) + ENDIF + ENDDO + + allocate (nups_all (totalnumucat)); nups_all(:) = 1 + + DO i = 1, totalnumucat + j = ucat_next(uc_up2down(i)) + IF (j > 0) THEN + nups_all(j) = nups_all(j) + nups_all(uc_up2down(i)) + ENDIF + ENDDO + + allocate (addr_ucat (totalnumucat)); addr_ucat(:) = -1 + + allocate (wt_wrk (0:p_np_worker-1)); wt_wrk (:) = 0 + allocate (nuc_wrk(0:p_np_worker-1)); nuc_wrk(:) = 0 + + allocate (order_ucat (totalnumucat)) + order_ucat(uc_up2down) = (/(i, i = 1, totalnumucat)/) + + ithis = totalnumucat + DO WHILE (ithis > 0) + + i = uc_up2down(ithis) + + IF (addr_ucat(i) >= 0) THEN + ithis = ithis - 1 + CYCLE + ENDIF + + j = ucat_next(i) + IF (j > 0) THEN + IF (addr_ucat(j) >= 0) THEN + addr_ucat(i) = addr_ucat(j) + ithis = ithis - 1 + CYCLE + ENDIF + ENDIF + + iriv = rivermouth(i) + IF (nwrk_rs(iriv) > 1) THEN + iworker = iwrk_rs(iriv) + IF (nups_all(i) <= nave_rs(iriv)-nuc_wrk(iworker)) THEN + + addr_ucat(i) = p_address_worker(iworker) + + nuc_wrk(iworker) = nuc_wrk(iworker) + nups_all(i) + IF (nuc_wrk(iworker) == nave_rs(iriv)) THEN + iwrk_rs(iriv) = iwrk_rs(iriv) + 1 + ENDIF + + j = ucat_next(i) + IF (j > 0) THEN + DO WHILE (j > 0) + nups_all(j) = nups_all(j) - nups_all(i) + ithis = order_ucat(j) + j = ucat_next(j) + ENDDO + ELSE + ithis = ithis - 1 + ENDIF + ELSE + ithis = ithis - 1 + ENDIF + ELSE + iworker = minloc(wt_wrk(iwrkdsp+1:p_np_worker-1), dim=1) + iwrkdsp + + addr_ucat(i) = p_address_worker(iworker) + + wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv) + ithis = ithis - 1 + ENDIF + + ENDDO + + deallocate (order_ucat) + deallocate (nups_all ) + deallocate (nuc_rs ) + deallocate (iwrk_rs ) + deallocate (nwrk_rs ) + deallocate (nave_rs ) + deallocate (wt_uc ) + deallocate (wt_rs ) + deallocate (wt_wrk ) + deallocate (nuc_wrk ) + + ENDIF + + IF (p_is_master) THEN + + allocate(ucat_ucid (totalnumucat)) + ucat_ucid = (/(i, i = 1, totalnumucat)/) + + allocate (numucat_wrk (0:p_np_worker-1)) + allocate (ucat_data_address (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + nucat = count(addr_ucat == p_address_worker(iworker)) + numucat_wrk(iworker) = nucat + IF (nucat > 0) THEN + allocate (ucat_data_address(iworker)%val (nucat)) + ucat_data_address(iworker)%val = & + pack(ucat_ucid, mask = (addr_ucat == p_address_worker(iworker))) + ENDIF + ENDDO + + ENDIF + + CALL mpi_bcast (totalnumucat, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + + ! send unit catchment index to workers + IF (p_is_master) THEN + + self_worker = -1 + + DO iworker = 0, p_np_worker-1 + + nucat = numucat_wrk(iworker) + IF (p_address_worker(iworker) == p_iam_glb) THEN + numucat = nucat + self_worker = iworker + CYCLE + ENDIF + + CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_mesg, p_comm_glb, p_err) + + IF (nucat > 0) THEN + + CALL mpi_send (ucat_data_address(iworker)%val, nucat, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_err) + +#ifndef MPAS_EMBEDDED_COLM + allocate (idata1d (nucat)) + + idata1d = x_ucat (ucat_data_address(iworker)%val) + CALL mpi_send (idata1d, nucat, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_err) + + idata1d = y_ucat (ucat_data_address(iworker)%val) + CALL mpi_send (idata1d, nucat, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_err) + + deallocate (idata1d) +#endif + ENDIF + ENDDO + + IF (self_worker >= 0) THEN + nucat = numucat_wrk(self_worker) + IF (allocated(idata1d)) deallocate(idata1d) + allocate (idata1d (nucat)) + IF (nucat > 0) idata1d = ucat_data_address(self_worker)%val + + IF (allocated(ucat_ucid)) deallocate(ucat_ucid) + allocate (ucat_ucid (nucat)) + IF (nucat > 0) ucat_ucid = idata1d + +#ifndef MPAS_EMBEDDED_COLM + IF (allocated(x_ucat)) THEN + IF (nucat > 0) idata1d = x_ucat(ucat_ucid) + deallocate (x_ucat) + allocate (x_ucat (nucat)) + IF (nucat > 0) x_ucat = idata1d + ENDIF + + IF (allocated(y_ucat)) THEN + IF (nucat > 0) idata1d = y_ucat(ucat_ucid) + deallocate (y_ucat) + allocate (y_ucat (nucat)) + IF (nucat > 0) y_ucat = idata1d + ENDIF +#endif + + deallocate (idata1d) + ENDIF + + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + + CALL mpi_recv (numucat, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + IF (numucat > 0) THEN + allocate (ucat_ucid (numucat)) +#ifndef MPAS_EMBEDDED_COLM + allocate (x_ucat (numucat)) + allocate (y_ucat (numucat)) +#endif + CALL mpi_recv (ucat_ucid, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) +#ifndef MPAS_EMBEDDED_COLM + CALL mpi_recv (x_ucat, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (y_ucat, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) +#endif + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + numucat = totalnumucat + + allocate(ucat_ucid (totalnumucat)) + ucat_ucid = (/(i, i = 1, totalnumucat)/) + + allocate (numucat_wrk (0:0)) + numucat_wrk(0) = numucat + + allocate (ucat_data_address (0:0)) + allocate (ucat_data_address(0)%val (numucat)) + ucat_data_address(0)%val = ucat_ucid +#endif + +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_worker) THEN + IF (numucat > 0) THEN + CALL ncio_read_indexed_serial (parafile, 'seq_x', ucat_ucid, x_ucat) + CALL ncio_read_indexed_serial (parafile, 'seq_y', ucat_ucid, y_ucat) + ELSE + IF (.not. allocated(x_ucat)) allocate (x_ucat (0)) + IF (.not. allocated(y_ucat)) allocate (y_ucat (0)) + ENDIF + ENDIF +#endif + + IF (p_is_worker .and. numucat == 0) THEN + IF (.not. allocated(ucat_ucid)) allocate (ucat_ucid (0)) + IF (.not. allocated(x_ucat )) allocate (x_ucat (0)) + IF (.not. allocated(y_ucat )) allocate (y_ucat (0)) + ENDIF + + IF (allocated(addr_ucat)) deallocate(addr_ucat) + + ! ----- Part 1: between runoff input elements and unit catchments ----- + +#ifdef COLM_PARALLEL + CALL mpi_bcast (nlon_ucat, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (nlat_ucat, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#endif + + CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) + + CALL build_worker_remapdata (landpatch, griducat, remap_patch2inpm) + + IF (p_is_worker) THEN + numinpm = remap_patch2inpm%num_grid + IF (numinpm > 0) THEN + allocate (inpm_gdid (numinpm)) + inpm_gdid = remap_patch2inpm%ids_me + ELSE + allocate (inpm_gdid (0)) + ENDIF + ENDIF + +#ifdef MPAS_EMBEDDED_COLM + CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) + inpn = varsize(1) + deallocate (varsize) + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) + CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) + CALL ncio_read_indexed_serial (parafile, 'inpmat_area', ucat_ucid, area_gd2uc) + + allocate(idmap_gd2uc (inpn,numucat)) + idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x + + WHERE ((area_gd2uc <= 0) .or. (idmap_gd2uc <= 0)) + idmap_gd2uc = 0 + area_gd2uc = 0. + END WHERE + ELSE + allocate(idmap_gd2uc (inpn,0)) + allocate(area_gd2uc (inpn,0)) + ENDIF + + CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & + nucpart, idmap_uc2gd, area_uc2gd) + ENDIF +#else + IF (p_is_master) THEN + + inpn = size(idmap_x,1) + + allocate(idmap_gd2uc (inpn,totalnumucat)) + + idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x + + WHERE ((area_gd2uc <= 0) .or. (idmap_gd2uc <= 0)) + idmap_gd2uc = 0 + area_gd2uc = 0. + END WHERE + + allocate (nucat_g2d (nlon_ucat,nlat_ucat)) + nucat_g2d(:,:) = 0 + + DO i = 1, totalnumucat + DO j = 1, inpn + IF (idmap_gd2uc(j,i) > 0) THEN + nucat_g2d(idmap_x(j,i),idmap_y(j,i)) = nucat_g2d(idmap_x(j,i),idmap_y(j,i)) + 1 + ENDIF + ENDDO + ENDDO + + nucpart = maxval(nucat_g2d) + ngrdall = count(nucat_g2d > 0) + + allocate (allgrd_in_inp (ngrdall)) + + igrd = 0 + DO i = 1, nlat_ucat + DO j = 1, nlon_ucat + IF (nucat_g2d(j,i) > 0) THEN + igrd = igrd + 1 + allgrd_in_inp(igrd) = (i-1)*nlon_ucat + j + ENDIF + ENDDO + ENDDO + + allocate (idmap_uc2gd_all (nucpart, ngrdall)); idmap_uc2gd_all(:,:) = 0 + allocate (area_uc2gd_all (nucpart, ngrdall)); area_uc2gd_all (:,:) = 0. + + allocate (iucat_g (ngrdall)); iucat_g(:) = 0 + + DO i = 1, totalnumucat + DO j = 1, inpn + IF (idmap_gd2uc(j,i) > 0) THEN + iloc = find_in_sorted_list1 (idmap_gd2uc(j,i), ngrdall, allgrd_in_inp(1:ngrdall)) + iucat_g(iloc) = iucat_g(iloc) + 1 + idmap_uc2gd_all(iucat_g(iloc),iloc) = i + area_uc2gd_all (iucat_g(iloc),iloc) = area_gd2uc(j,i) + ENDIF + ENDDO + ENDDO + + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_bcast (inpn, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + + IF (p_is_master) THEN + + self_worker = -1 + DO iworker = 0, p_np_worker-1 + + nucat = numucat_wrk(iworker) + + IF (nucat > 0) THEN + IF (p_address_worker(iworker) == p_iam_glb) THEN + self_worker = iworker + CYCLE + ENDIF + + allocate (idata2d (inpn, nucat)) + DO i = 1, nucat + idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(iworker)%val(i)) + ENDDO + + allocate (rdata2d (inpn, nucat)) + DO i = 1, nucat + rdata2d(:,i) = area_gd2uc(:,ucat_data_address(iworker)%val(i)) + ENDDO + + CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + + deallocate (idata2d) + deallocate (rdata2d) + ENDIF + ENDDO + + IF (self_worker >= 0) THEN + nucat = numucat_wrk(self_worker) + IF (nucat > 0) THEN + allocate (idata2d (inpn, nucat)) + DO i = 1, nucat + idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(self_worker)%val(i)) + ENDDO + + allocate (rdata2d (inpn, nucat)) + DO i = 1, nucat + rdata2d(:,i) = area_gd2uc(:,ucat_data_address(self_worker)%val(i)) + ENDDO + + IF (allocated(idmap_gd2uc)) deallocate(idmap_gd2uc) + IF (allocated(area_gd2uc )) deallocate(area_gd2uc ) + allocate (idmap_gd2uc (inpn, nucat)) + allocate (area_gd2uc (inpn, nucat)) + idmap_gd2uc = idata2d + area_gd2uc = rdata2d + + deallocate (idata2d) + deallocate (rdata2d) + ENDIF + ENDIF + + IF (.not. (p_is_worker .and. numucat > 0)) THEN + IF (allocated(idmap_gd2uc)) deallocate (idmap_gd2uc) + IF (allocated(area_gd2uc )) deallocate (area_gd2uc ) + IF (p_is_worker) THEN + allocate (idmap_gd2uc (inpn,0)) + allocate (area_gd2uc (inpn,0)) + ENDIF + ENDIF + + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + + IF (numucat > 0) THEN + + allocate (idmap_gd2uc (inpn, numucat)) + CALL mpi_recv (idmap_gd2uc, inpn*numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (area_gd2uc (inpn, numucat)) + CALL mpi_recv (area_gd2uc, inpn*numucat, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + ENDIF + + ENDIF + + CALL mpi_bcast (nucpart, 1, mpi_integer, p_address_master, p_comm_glb, p_err) + + IF (p_is_master) THEN + + DO iworker = 0, p_np_worker-1 + + IF (p_address_worker(iworker) == p_iam_glb) THEN + ngrd = numinpm + ELSE + CALL mpi_recv (ngrd, 1, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + ENDIF + + IF (ngrd > 0) THEN + + allocate (grdindex (ngrd)) + allocate (idata2d (nucpart, ngrd)); idata2d(:,:) = 0 + allocate (rdata2d (nucpart, ngrd)); rdata2d(:,:) = 0. + + IF (p_address_worker(iworker) == p_iam_glb) THEN + grdindex = inpm_gdid + ELSE + CALL mpi_recv (grdindex, ngrd, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + DO i = 1, ngrd + iloc = find_in_sorted_list1 (grdindex(i), ngrdall, allgrd_in_inp(1:ngrdall)) + IF (iloc > 0) THEN + idata2d(:,i) = idmap_uc2gd_all(:,iloc) + rdata2d(:,i) = area_uc2gd_all (:,iloc) + ENDIF + ENDDO + + IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (allocated(idmap_uc2gd)) deallocate(idmap_uc2gd) + IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) + allocate (idmap_uc2gd (nucpart, ngrd)) + allocate (area_uc2gd (nucpart, ngrd)) + idmap_uc2gd = idata2d + area_uc2gd = rdata2d + ELSE + CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + deallocate (grdindex) + deallocate (idata2d ) + deallocate (rdata2d ) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + + CALL mpi_send (numinpm, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numinpm > 0) THEN + + CALL mpi_send (inpm_gdid, numinpm, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_err) + + allocate (idmap_uc2gd (nucpart,numinpm)) + CALL mpi_recv (idmap_uc2gd, nucpart*numinpm, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (area_uc2gd (nucpart,numinpm)) + CALL mpi_recv (area_uc2gd, nucpart*numinpm, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + allocate (idmap_uc2gd (nucpart,numinpm)) + allocate (area_uc2gd (nucpart,numinpm)) + idmap_uc2gd = 0 + area_uc2gd = 0. + + DO i = 1, numinpm + iloc = find_in_sorted_list1 (inpm_gdid(i), ngrdall, allgrd_in_inp(1:ngrdall)) + IF (iloc > 0) THEN + idmap_uc2gd(:,i) = idmap_uc2gd_all(:,iloc) + area_uc2gd (:,i) = area_uc2gd_all (:,iloc) + ENDIF + ENDDO +#endif +#endif + + IF (p_is_worker) THEN + IF (.not. allocated(idmap_gd2uc)) allocate (idmap_gd2uc (inpn,0)) + IF (.not. allocated(area_gd2uc )) allocate (area_gd2uc (inpn,0)) + IF (.not. allocated(idmap_uc2gd)) allocate (idmap_uc2gd (nucpart,0)) + IF (.not. allocated(area_uc2gd )) allocate (area_uc2gd (nucpart,0)) + ENDIF + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + allocate (ucat_gdid (numucat)) + ucat_gdid = (y_ucat-1)*nlon_ucat + x_ucat + ELSE + allocate (ucat_gdid (0)) + ENDIF + ENDIF + + CALL build_worker_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) + CALL build_worker_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) + CALL build_worker_pushdata (numucat, ucat_gdid, numinpm, inpm_gdid, push_ucat2grid) + CALL build_worker_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) + + IF (allocated(idmap_x)) deallocate (idmap_x) + IF (allocated(idmap_y)) deallocate (idmap_y) + IF (p_is_master) THEN + IF (allocated(allgrd_in_inp )) deallocate (allgrd_in_inp ) + IF (allocated(nucat_g2d )) deallocate (nucat_g2d ) + IF (allocated(iucat_g )) deallocate (iucat_g ) + IF (allocated(idmap_uc2gd_all)) deallocate (idmap_uc2gd_all) + IF (allocated(area_uc2gd_all )) deallocate (area_uc2gd_all ) + ENDIF + + ! ----- Part 2: between upstream and downstream unit catchments ----- + + IF (p_is_master) THEN + + upnmax = maxval(nups_nst) + allocate (ucat_ups (upnmax,totalnumucat)) + ucat_ups(:,:) = 0 + allocate (ucat_next_all (totalnumucat)) + ucat_next_all = ucat_next + + iups_nst(:) = 0 + DO i = 1, totalnumucat + j = ucat_next(i) + IF (j > 0) THEN + iups_nst(j) = iups_nst(j) + 1 + ucat_ups(iups_nst(j),j) = i + ENDIF + ENDDO + + ENDIF + + +#ifdef COLM_PARALLEL + CALL mpi_bcast (upnmax, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + + IF (p_is_master) THEN + + self_worker = -1 + DO iworker = 0, p_np_worker-1 + + nucat = numucat_wrk(iworker) + + IF (nucat > 0) THEN + IF (p_address_worker(iworker) == p_iam_glb) THEN + self_worker = iworker + CYCLE + ENDIF + + allocate (idata1d (nucat)) + idata1d = ucat_next(ucat_data_address(iworker)%val) + + allocate (idata2d (upnmax,nucat)) + DO i = 1, nucat + idata2d(:,i) = ucat_ups(:,ucat_data_address(iworker)%val(i)) + ENDDO + + CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + + deallocate (idata1d) + deallocate (idata2d) + ENDIF + ENDDO + + IF (self_worker >= 0) THEN + nucat = numucat_wrk(self_worker) + IF (nucat > 0) THEN + allocate (idata1d (nucat)) + idata1d = ucat_next(ucat_data_address(self_worker)%val) + + allocate (idata2d (upnmax,nucat)) + DO i = 1, nucat + idata2d(:,i) = ucat_ups(:,ucat_data_address(self_worker)%val(i)) + ENDDO + + IF (allocated(ucat_next)) deallocate(ucat_next) + IF (allocated(ucat_ups )) deallocate(ucat_ups ) + allocate (ucat_next (nucat)) + allocate (ucat_ups (upnmax,nucat)) + ucat_next = idata1d + ucat_ups = idata2d + + deallocate (idata1d) + deallocate (idata2d) + ELSE + IF (allocated(ucat_next)) deallocate(ucat_next) + IF (allocated(ucat_ups )) deallocate(ucat_ups ) + allocate (ucat_next (0)) + allocate (ucat_ups (upnmax,0)) + ENDIF + ENDIF + + IF (.not. (p_is_worker .and. numucat > 0)) THEN + IF (allocated(ucat_ups)) deallocate (ucat_ups) + ENDIF + + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + + IF (numucat > 0) THEN + + allocate (ucat_next (numucat)) + CALL mpi_recv (ucat_next, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (ucat_ups (upnmax, numucat)) + CALL mpi_recv (ucat_ups, upnmax*numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + IF (.not. allocated(ucat_next)) allocate (ucat_next (0)) + IF (.not. allocated(ucat_ups )) allocate (ucat_ups (upnmax,0)) + allocate (wts_ups (upnmax,numucat)) + IF (numucat > 0) wts_ups(:,:) = 1. + ENDIF + + CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) + CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + +#ifdef CoLMDEBUG + ! IF (p_is_worker) THEN + ! write(*,'(A,I0,A,I0,A,I0,A)') 'worker ', p_iam_worker, ' has ', numucat, & + ! ' unit catchment with ', sum(push_next2ucat%n_from_other), ' downstream to other workers' + ! ENDIF +#endif + + ! ----- Part 3: river systems ----- + +#ifdef COLM_PARALLEL + IF (p_is_master) THEN + self_worker = -1 + DO iworker = 0, p_np_worker-1 + nucat = numucat_wrk(iworker) + IF (nucat > 0) THEN + IF (p_address_worker(iworker) == p_iam_glb) THEN + self_worker = iworker + CYCLE + ENDIF + + allocate (idata1d (nucat)) + idata1d = rivermouth(ucat_data_address(iworker)%val) + CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + deallocate (idata1d) + ENDIF + ENDDO + + IF (self_worker >= 0) THEN + nucat = numucat_wrk(self_worker) + allocate (idata1d (nucat)) + IF (nucat > 0) idata1d = rivermouth(ucat_data_address(self_worker)%val) + IF (allocated(rivermouth)) deallocate(rivermouth) + allocate (rivermouth (nucat)) + IF (nucat > 0) rivermouth = idata1d + deallocate (idata1d) + ENDIF + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (numucat > 0) THEN + allocate (rivermouth (numucat)) + CALL mpi_recv (rivermouth, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + color = maxval(rivermouth) + CALL mpi_comm_split (p_comm_worker, color, p_iam_worker, p_comm_rivsys, p_err) + ELSE + CALL mpi_comm_split (p_comm_worker, MPI_UNDEFINED, p_iam_worker, p_comm_rivsys, p_err) + ENDIF + + rivsys_by_multiple_procs = .false. + IF (p_comm_rivsys /= MPI_COMM_NULL) THEN + CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) + IF (p_np_rivsys > 1) THEN + rivsys_by_multiple_procs = .true. + ENDIF + ENDIF + ENDIF +#else + rivsys_by_multiple_procs = .false. +#endif + + IF (p_is_worker) THEN + + IF (numucat > 0) allocate (irivsys (numucat)) + + IF (.not. rivsys_by_multiple_procs) THEN + IF (numucat > 0) THEN + + allocate (order_ucat (numucat)) + order_ucat = (/(i, i = 1, numucat)/) + + CALL quicksort (numucat, rivermouth, order_ucat) + + numrivsys = 1 + irivsys(order_ucat(1)) = numrivsys + DO i = 2, numucat + IF (rivermouth(i) /= rivermouth(i-1)) THEN + numrivsys = numrivsys + 1 + ENDIF + irivsys(order_ucat(i)) = numrivsys + ENDDO + + ENDIF + ELSE + numrivsys = 1 + irivsys(:) = 1 + ENDIF + + ENDIF + + IF (allocated(rivermouth)) deallocate(rivermouth) + IF (allocated(order_ucat)) deallocate(order_ucat) + + ! ----- Parameters for River and Lake ----- + + CALL readin_riverlake_parameter (parafile, 'topo_rivelv', rdata1d = topo_rivelv ) + CALL readin_riverlake_parameter (parafile, 'topo_rivhgt', rdata1d = topo_rivhgt ) + CALL readin_riverlake_parameter (parafile, 'topo_rivlen', rdata1d = topo_rivlen ) + CALL readin_riverlake_parameter (parafile, 'topo_rivman', rdata1d = topo_rivman ) + CALL readin_riverlake_parameter (parafile, 'topo_rivwth', rdata1d = topo_rivwth ) + CALL readin_riverlake_parameter (parafile, 'topo_rivstomax', rdata1d = topo_rivstomax) + CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) + CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + + allocate (lake_type (numucat)) + lake_type(:) = 0 + + allocate (topo_rivare (numucat)) + topo_rivare = topo_rivstomax / topo_rivhgt + + allocate (floodplain_curve (numucat)) + + DO i = 1, numucat + floodplain_curve(i)%nlfp = size(topo_fldhgt,1) + floodplain_curve(i)%rivhgt = topo_rivhgt(i) + floodplain_curve(i)%rivstomax = topo_rivstomax(i) + floodplain_curve(i)%rivare = topo_rivare(i) + + allocate (floodplain_curve(i)%flphgt (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flparea (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flpaccare (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flpstomax (0:floodplain_curve(i)%nlfp)) + + floodplain_curve(i)%flphgt(0) = 0. + floodplain_curve(i)%flphgt(1:) = topo_fldhgt(:,i) + + floodplain_curve(i)%flparea(0) = 0. + floodplain_curve(i)%flparea(1:) = topo_area(i) / floodplain_curve(i)%nlfp + + floodplain_curve(i)%flpaccare(0) = 0. + DO j = 1, floodplain_curve(i)%nlfp + floodplain_curve(i)%flpaccare(j) = & + floodplain_curve(i)%flpaccare(j-1) + floodplain_curve(i)%flparea(j) + ENDDO + + floodplain_curve(i)%flpstomax(0) = 0. + DO j = 1, floodplain_curve(i)%nlfp + floodplain_curve(i)%flpstomax(j) = floodplain_curve(i)%flpstomax(j-1) & + + 0.5 * (floodplain_curve(i)%flparea(j) + floodplain_curve(i)%flparea(j-1)) & + * (floodplain_curve(i)%flphgt(j) - floodplain_curve(i)%flphgt(j-1)) + ENDDO + ENDDO + + allocate (bedelv_next (numucat)) + allocate (outletwth (numucat)) + + ELSE + allocate (bedelv_next (0)) + allocate (outletwth (0)) + ENDIF + ENDIF + + CALL worker_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) + CALL worker_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + WHERE (ucat_next > 0) + outletwth = (outletwth + topo_rivwth) * 0.5 + ELSEWHERE + outletwth = topo_rivwth + END WHERE + ENDIF + ENDIF + + ! ----- Mask of Grids with all upstream area in the simulation region ----- + + IF (p_is_master) allocate (ucat_area_all (totalnumucat)) + +#ifdef COLM_PARALLEL + IF (p_is_worker .and. (.not. p_is_master)) THEN + + IF (numucat > 0) THEN + CALL mpi_send (push_inpm2ucat%sum_area, numucat, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + ENDIF + + IF (p_is_master) THEN + + DO iworker = 0, p_np_worker-1 + IF (numucat_wrk(iworker) > 0) THEN + + allocate (rdata1d (numucat_wrk(iworker))) + IF (p_address_worker(iworker) == p_iam_glb) THEN + rdata1d = push_inpm2ucat%sum_area + ELSE + CALL mpi_recv (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + ucat_area_all(ucat_data_address(iworker)%val) = rdata1d + + deallocate (rdata1d) + ENDIF + + ENDDO + ENDIF +#else + ucat_area_all = push_inpm2ucat%sum_area +#endif + + IF (p_is_master) THEN + + allocate (allups_mask_ucat (totalnumucat)) + allups_mask_ucat (:) = 0 + + iups_nst(:) = 0 + DO i = 1, totalnumucat + j = uc_up2down(i) + IF (ucat_area_all(j) > 0.) THEN + IF (iups_nst(j) == nups_nst(j)) THEN + + allups_mask_ucat(j) = 1 + + IF (ucat_next_all(j) > 0) THEN + iups_nst(ucat_next_all(j)) = iups_nst(ucat_next_all(j)) + 1 + ENDIF + ENDIF + ENDIF + ENDDO + + ENDIF + +#ifdef COLM_PARALLEL + IF (p_is_master) THEN + self_worker = -1 + DO iworker = 0, p_np_worker-1 + IF (numucat_wrk(iworker) > 0) THEN + IF (p_address_worker(iworker) == p_iam_glb) THEN + self_worker = iworker + CYCLE + ENDIF + + allocate (rdata1d (numucat_wrk(iworker))) + rdata1d = allups_mask_ucat(ucat_data_address(iworker)%val) + + CALL mpi_send (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + + deallocate (rdata1d) + ENDIF + ENDDO + + IF (self_worker >= 0) THEN + allocate (rdata1d (numucat_wrk(self_worker))) + IF (numucat_wrk(self_worker) > 0) & + rdata1d = allups_mask_ucat(ucat_data_address(self_worker)%val) + IF (allocated(allups_mask_ucat)) deallocate(allups_mask_ucat) + allocate (allups_mask_ucat (numucat_wrk(self_worker))) + IF (numucat_wrk(self_worker) > 0) allups_mask_ucat = rdata1d + deallocate (rdata1d) + ENDIF + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (numucat > 0) THEN + allocate (allups_mask_ucat (numucat)) + CALL mpi_recv (allups_mask_ucat, numucat, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF +#endif + + IF (p_is_worker .and. numucat == 0) THEN + IF (.not. allocated(allups_mask_ucat)) allocate (allups_mask_ucat (0)) + ENDIF + + + IF (allocated (uc_up2down )) deallocate (uc_up2down ) + IF (allocated (ucat_next_all)) deallocate (ucat_next_all) + IF (allocated (nups_nst )) deallocate (nups_nst ) + IF (allocated (iups_nst )) deallocate (iups_nst ) + IF (allocated (ucat_area_all)) deallocate (ucat_area_all) + + END SUBROUTINE build_riverlake_network + +#ifdef MPAS_EMBEDDED_COLM + ! --------- + SUBROUTINE build_riverlake_network_mpas_embedded () + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_Mesh + USE MOD_LandPatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=256) :: parafile + integer, allocatable :: varsize(:) + integer, allocatable :: idmap_x(:,:), idmap_y(:,:) + integer :: nlat_ucat, nlon_ucat + integer :: inpn + integer :: p_np_rivsys + integer :: i, j + + parafile = DEF_UnitCatchment_file + + CALL ncio_inquire_length (parafile, 'seq_next', totalnumucat) + CALL ncio_inquire_length (parafile, 'lon', nlon_ucat) + CALL ncio_inquire_length (parafile, 'lat', nlat_ucat) + + CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) + CALL build_worker_remapdata (landpatch, griducat, remap_patch2inpm) + + IF (p_is_worker) THEN + numinpm = remap_patch2inpm%num_grid + IF (numinpm > 0) THEN + allocate (inpm_gdid (numinpm)) + inpm_gdid = remap_patch2inpm%ids_me + ELSE + allocate (inpm_gdid (0)) + ENDIF + ENDIF + + CALL build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) + + CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) + inpn = varsize(1) + deallocate (varsize) + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) + CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) + CALL ncio_read_indexed_serial (parafile, 'inpmat_area', ucat_ucid, area_gd2uc) + + allocate (idmap_gd2uc (inpn,numucat)) + idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x + + WHERE ((area_gd2uc <= 0._r8) .or. (idmap_gd2uc <= 0)) + idmap_gd2uc = 0 + area_gd2uc = 0._r8 + END WHERE + + deallocate (idmap_x) + deallocate (idmap_y) + ELSE + allocate (idmap_gd2uc (inpn,0)) + allocate (area_gd2uc (inpn,0)) + ENDIF + + CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & + nucpart, idmap_uc2gd, area_uc2gd) + ENDIF + + IF (p_is_worker) THEN + CALL build_worker_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) + CALL build_worker_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) + CALL build_worker_pushdata (numucat, ucat_ucid, numinpm, inpm_gdid, push_ucat2grid) + CALL build_worker_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) + ENDIF + + CALL build_mpas_embedded_local_topology (parafile) + + IF (p_is_worker) THEN + allocate (wts_ups (upnmax,numucat)) + IF (numucat > 0) wts_ups(:,:) = 1._r8 + + CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) + CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + ENDIF + +#ifdef COLM_PARALLEL + IF (p_is_worker) THEN + IF (numucat > 0) THEN + p_comm_rivsys = p_comm_worker + CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) + rivsys_by_multiple_procs = p_np_rivsys > 1 + ELSE + p_comm_rivsys = MPI_COMM_NULL + rivsys_by_multiple_procs = .false. + ENDIF + ENDIF +#else + rivsys_by_multiple_procs = .false. +#endif + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + allocate (irivsys (numucat)) + numrivsys = 1 + irivsys(:) = 1 + ELSE + numrivsys = 0 + ENDIF + ENDIF + + CALL readin_riverlake_parameter (parafile, 'topo_rivelv', rdata1d = topo_rivelv ) + CALL readin_riverlake_parameter (parafile, 'topo_rivhgt', rdata1d = topo_rivhgt ) + CALL readin_riverlake_parameter (parafile, 'topo_rivlen', rdata1d = topo_rivlen ) + CALL readin_riverlake_parameter (parafile, 'topo_rivman', rdata1d = topo_rivman ) + CALL readin_riverlake_parameter (parafile, 'topo_rivwth', rdata1d = topo_rivwth ) + CALL readin_riverlake_parameter (parafile, 'topo_rivstomax', rdata1d = topo_rivstomax) + CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) + CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + allocate (lake_type (numucat)) + lake_type(:) = 0 + + allocate (topo_rivare (numucat)) + topo_rivare = topo_rivstomax / topo_rivhgt + + allocate (floodplain_curve (numucat)) + DO i = 1, numucat + floodplain_curve(i)%nlfp = size(topo_fldhgt,1) + floodplain_curve(i)%rivhgt = topo_rivhgt(i) + floodplain_curve(i)%rivstomax = topo_rivstomax(i) + floodplain_curve(i)%rivare = topo_rivare(i) + + allocate (floodplain_curve(i)%flphgt (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flparea (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flpaccare (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flpstomax (0:floodplain_curve(i)%nlfp)) + + floodplain_curve(i)%flphgt(0) = 0._r8 + floodplain_curve(i)%flphgt(1:) = topo_fldhgt(:,i) + + floodplain_curve(i)%flparea(0) = 0._r8 + floodplain_curve(i)%flparea(1:) = topo_area(i) / floodplain_curve(i)%nlfp + + floodplain_curve(i)%flpaccare(0) = 0._r8 + DO j = 1, floodplain_curve(i)%nlfp + floodplain_curve(i)%flpaccare(j) = & + floodplain_curve(i)%flpaccare(j-1) + floodplain_curve(i)%flparea(j) + ENDDO + + floodplain_curve(i)%flpstomax(0) = 0._r8 + DO j = 1, floodplain_curve(i)%nlfp + floodplain_curve(i)%flpstomax(j) = floodplain_curve(i)%flpstomax(j-1) & + + 0.5_r8 * (floodplain_curve(i)%flparea(j) + floodplain_curve(i)%flparea(j-1)) & + * (floodplain_curve(i)%flphgt(j) - floodplain_curve(i)%flphgt(j-1)) + ENDDO + ENDDO + + allocate (bedelv_next (numucat)) + allocate (outletwth (numucat)) + ELSE + allocate (bedelv_next (0)) + allocate (outletwth (0)) + ENDIF + ENDIF + + CALL worker_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) + CALL worker_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) + + IF (p_is_worker) THEN + IF (numucat > 0) THEN + WHERE (ucat_next > 0) + outletwth = (outletwth + topo_rivwth) * 0.5_r8 + ELSEWHERE + outletwth = topo_rivwth + END WHERE + ENDIF + + allocate (allups_mask_ucat (numucat)) + IF (numucat > 0) THEN + allups_mask_ucat(:) = 0._r8 + WHERE (push_inpm2ucat%sum_area > 0._r8) + allups_mask_ucat = 1._r8 + END WHERE + ENDIF + ENDIF + + END SUBROUTINE build_riverlake_network_mpas_embedded + + ! --------- + SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + integer, intent(in) :: nlon_ucat + integer, intent(in) :: numinpm + integer, intent(in) :: inpm_gdid(:) + + integer, parameter :: ucat_chunk_size = 131072 + integer, allocatable :: inpm_sorted(:), inpm_order(:) + integer, allocatable :: seq_x_blk(:), seq_y_blk(:) + integer :: istart, iend, iucat, iloc, grid_id, nfound + + IF (.not. p_is_worker) RETURN + + IF (numinpm > 0) THEN + allocate (inpm_sorted (numinpm)) + allocate (inpm_order (numinpm)) + inpm_sorted = inpm_gdid + inpm_order = (/(iucat, iucat = 1, numinpm)/) + CALL quicksort (numinpm, inpm_sorted, inpm_order) + + nfound = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) + CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + IF (seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) nfound = nfound + 1 + ENDIF + ENDDO + + deallocate (seq_x_blk) + deallocate (seq_y_blk) + istart = iend + 1 + ENDDO + ELSE + nfound = 0 + ENDIF + + numucat = nfound + allocate (ucat_ucid (numucat)) + allocate (x_ucat (numucat)) + allocate (y_ucat (numucat)) + allocate (ucat_gdid (numucat)) + + IF (numinpm > 0 .and. numucat > 0) THEN + nfound = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) + CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + IF (seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) THEN + nfound = nfound + 1 + ucat_ucid(nfound) = iucat + x_ucat(nfound) = seq_x_blk(iucat) + y_ucat(nfound) = seq_y_blk(iucat) + ucat_gdid(nfound) = grid_id + ENDIF + ENDIF + ENDDO + + deallocate (seq_x_blk) + deallocate (seq_y_blk) + istart = iend + 1 + ENDDO + ENDIF + + IF (allocated(inpm_sorted)) deallocate (inpm_sorted) + IF (allocated(inpm_order )) deallocate (inpm_order ) + + END SUBROUTINE build_mpas_embedded_local_ucats + + ! --------- + SUBROUTINE gather_mpas_embedded_ucat_addresses() + + USE MOD_SPMD_Task + IMPLICIT NONE + + integer :: iworker, nrecv + + allocate (numucat_wrk (0:p_np_worker-1)) + allocate (ucat_data_address (0:p_np_worker-1)) + numucat_wrk(:) = 0 + +#ifdef COLM_PARALLEL + IF (p_is_worker .and. (.not. p_is_master)) THEN + CALL mpi_send (numucat, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numucat > 0) THEN + CALL mpi_send (ucat_ucid, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDIF + + IF (p_is_master) THEN + DO iworker = 0, p_np_worker-1 + IF (p_is_worker .and. p_address_worker(iworker) == p_iam_glb) THEN + nrecv = numucat + ELSE + CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + ENDIF + + numucat_wrk(iworker) = nrecv + allocate (ucat_data_address(iworker)%val (nrecv)) + + IF (nrecv > 0) THEN + IF (p_is_worker .and. p_address_worker(iworker) == p_iam_glb) THEN + ucat_data_address(iworker)%val = ucat_ucid + ELSE + CALL mpi_recv (ucat_data_address(iworker)%val, nrecv, MPI_INTEGER, & + p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF + ENDDO + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + numucat_wrk(0) = numucat + allocate (ucat_data_address(0)%val (numucat)) + IF (numucat > 0) ucat_data_address(0)%val = ucat_ucid +#endif + + END SUBROUTINE gather_mpas_embedded_ucat_addresses + + ! --------- + SUBROUTINE build_mpas_embedded_local_topology (parafile) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + + integer, parameter :: ucat_chunk_size = 131072 + integer, allocatable :: ucat_sorted(:), ucat_order(:), ups_count(:), ups_fill(:) + integer, allocatable :: seq_next_blk(:) + integer :: istart, iend, iucat, iloc, idn, local_upnmax + + IF (.not. p_is_worker) RETURN + + IF (numucat > 0) THEN + CALL ncio_read_indexed_serial (parafile, 'seq_next', ucat_ucid, ucat_next) + + allocate (ucat_sorted (numucat)) + allocate (ucat_order (numucat)) + allocate (ups_count (numucat)) + + ucat_sorted = ucat_ucid + ucat_order = (/(iucat, iucat = 1, numucat)/) + CALL quicksort (numucat, ucat_sorted, ucat_order) + + ups_count(:) = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_next', istart, iend, seq_next_blk) + + DO iucat = lbound(seq_next_blk,1), ubound(seq_next_blk,1) + idn = seq_next_blk(iucat) + IF (idn > 0) THEN + iloc = find_in_sorted_list1 (idn, numucat, ucat_sorted) + IF (iloc > 0) ups_count(ucat_order(iloc)) = ups_count(ucat_order(iloc)) + 1 + ENDIF + ENDDO + + deallocate (seq_next_blk) + istart = iend + 1 + ENDDO + + local_upnmax = maxval(ups_count) + ELSE + allocate (ucat_next (0)) + local_upnmax = 0 + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, p_comm_worker, p_err) +#else + upnmax = local_upnmax +#endif + upnmax = max(1, upnmax) + + allocate (ucat_ups (upnmax,numucat)) + ucat_ups(:,:) = 0 + + IF (numucat > 0) THEN + allocate (ups_fill (numucat)) + ups_fill(:) = 0 + + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_next', istart, iend, seq_next_blk) + + DO iucat = lbound(seq_next_blk,1), ubound(seq_next_blk,1) + idn = seq_next_blk(iucat) + IF (idn > 0) THEN + iloc = find_in_sorted_list1 (idn, numucat, ucat_sorted) + IF (iloc > 0) THEN + ups_fill(ucat_order(iloc)) = ups_fill(ucat_order(iloc)) + 1 + ucat_ups(ups_fill(ucat_order(iloc)), ucat_order(iloc)) = iucat + ENDIF + ENDIF + ENDDO + + deallocate (seq_next_blk) + istart = iend + 1 + ENDDO + + deallocate (ups_fill) + deallocate (ups_count) + deallocate (ucat_sorted) + deallocate (ucat_order) + ENDIF + + END SUBROUTINE build_mpas_embedded_local_topology + + ! --------- + SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & + nucpart, idmap_uc2gd, area_uc2gd) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + integer, intent(in) :: nlon_ucat + integer, intent(in) :: inpn + integer, intent(in) :: numinpm + integer, intent(in) :: inpm_gdid(:) + integer, intent(out) :: nucpart + integer, allocatable, intent(out) :: idmap_uc2gd(:,:) + real(r8), allocatable, intent(out) :: area_uc2gd(:,:) + + integer, parameter :: ucat_chunk_size = 131072 + integer, allocatable :: inpm_sorted(:), inpm_order(:), nucat_g(:) + integer, allocatable :: idmap_x_blk(:,:), idmap_y_blk(:,:) + real(r8), allocatable :: area_blk(:,:) + integer :: istart, iend, iucat, imap, iloc, igrd, grid_id + integer :: nucpart_local + + IF (numinpm > 0) THEN + allocate (inpm_sorted (numinpm)) + allocate (inpm_order (numinpm)) + allocate (nucat_g (numinpm)) + + inpm_sorted = inpm_gdid + inpm_order = (/(igrd, igrd = 1, numinpm)/) + CALL quicksort (numinpm, inpm_sorted, inpm_order) + nucat_g = 0 + + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'inpmat_x', (/1,istart/), (/inpn,iend/), idmap_x_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_y', (/1,istart/), (/inpn,iend/), idmap_y_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_area', (/1,istart/), (/inpn,iend/), area_blk) + + DO iucat = lbound(idmap_x_blk,2), ubound(idmap_x_blk,2) + DO imap = 1, inpn + IF (area_blk(imap,iucat) > 0._r8 .and. idmap_x_blk(imap,iucat) > 0 .and. & + idmap_y_blk(imap,iucat) > 0) THEN + grid_id = (idmap_y_blk(imap,iucat)-1) * nlon_ucat + idmap_x_blk(imap,iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) THEN + igrd = inpm_order(iloc) + nucat_g(igrd) = nucat_g(igrd) + 1 + ENDIF + ENDIF + ENDDO + ENDDO + + deallocate (idmap_x_blk) + deallocate (idmap_y_blk) + deallocate (area_blk) + istart = iend + 1 + ENDDO + + nucpart_local = maxval(nucat_g) + ELSE + nucpart_local = 0 + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_allreduce (nucpart_local, nucpart, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err) +#else + nucpart = nucpart_local +#endif + + allocate (idmap_uc2gd (nucpart,numinpm)) + allocate (area_uc2gd (nucpart,numinpm)) + idmap_uc2gd = 0 + area_uc2gd = 0._r8 + + IF (numinpm > 0 .and. nucpart > 0) THEN + nucat_g = 0 + + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'inpmat_x', (/1,istart/), (/inpn,iend/), idmap_x_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_y', (/1,istart/), (/inpn,iend/), idmap_y_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_area', (/1,istart/), (/inpn,iend/), area_blk) + + DO iucat = lbound(idmap_x_blk,2), ubound(idmap_x_blk,2) + DO imap = 1, inpn + IF (area_blk(imap,iucat) > 0._r8 .and. idmap_x_blk(imap,iucat) > 0 .and. & + idmap_y_blk(imap,iucat) > 0) THEN + grid_id = (idmap_y_blk(imap,iucat)-1) * nlon_ucat + idmap_x_blk(imap,iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) THEN + igrd = inpm_order(iloc) + nucat_g(igrd) = nucat_g(igrd) + 1 + idmap_uc2gd(nucat_g(igrd),igrd) = iucat + area_uc2gd (nucat_g(igrd),igrd) = area_blk(imap,iucat) + ENDIF + ENDIF + ENDDO + ENDDO + + deallocate (idmap_x_blk) + deallocate (idmap_y_blk) + deallocate (area_blk) + istart = iend + 1 + ENDDO + ENDIF + + IF (allocated(inpm_sorted)) deallocate (inpm_sorted) + IF (allocated(inpm_order )) deallocate (inpm_order ) + IF (allocated(nucat_g )) deallocate (nucat_g ) + + END SUBROUTINE build_mpas_embedded_uc2gd +#endif + + ! --------- + SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idata1d) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + character(len=*), intent(in) :: varname + + real(r8), allocatable, intent(inout), optional :: rdata1d (:) + real(r8), allocatable, intent(inout), optional :: rdata2d (:,:) + integer, allocatable, intent(inout), optional :: idata1d (:) + + ! Local Variables + integer :: iworker, nucat, ndim1, i + real(r8), allocatable :: rsend1d (:) + real(r8), allocatable :: rsend2d (:,:) + integer, allocatable :: isend1d (:) + +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_worker) THEN + IF (present(rdata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata1d) + IF (present(rdata2d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata2d) + IF (present(idata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, idata1d) + ENDIF +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) +#endif + RETURN +#endif + + IF (p_is_master) THEN + IF (present(rdata1d)) CALL ncio_read_serial (parafile, varname, rdata1d) + IF (present(rdata2d)) CALL ncio_read_serial (parafile, varname, rdata2d) + IF (present(idata1d)) CALL ncio_read_serial (parafile, varname, idata1d) + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) + + IF (present(rdata2d)) THEN + IF (p_is_master) ndim1 = size(rdata2d,1) + CALL mpi_bcast (ndim1, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + ENDIF + + ! send unit catchment index to workers + IF (p_is_master) THEN + + DO iworker = 0, p_np_worker-1 + + nucat = numucat_wrk(iworker) + + IF (nucat > 0) THEN + IF (present(rdata1d)) THEN + allocate (rsend1d (nucat)) + + rsend1d = rdata1d(ucat_data_address(iworker)%val) + IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (allocated(rdata1d)) deallocate(rdata1d) + allocate (rdata1d (nucat)) + rdata1d = rsend1d + ELSE + CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + deallocate (rsend1d) + ENDIF + + IF (present(rdata2d)) THEN + allocate (rsend2d (ndim1,nucat)) + + DO i = 1, nucat + rsend2d(:,i) = rdata2d(:,ucat_data_address(iworker)%val(i)) + ENDDO + IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (allocated(rdata2d)) deallocate(rdata2d) + allocate (rdata2d (ndim1,nucat)) + rdata2d = rsend2d + ELSE + CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + deallocate (rsend2d) + ENDIF + + IF (present(idata1d)) THEN + allocate (isend1d (nucat)) + + isend1d = idata1d(ucat_data_address(iworker)%val) + IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (allocated(idata1d)) deallocate(idata1d) + allocate (idata1d (nucat)) + idata1d = isend1d + ELSE + CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_worker(iworker), & + mpi_tag_data, p_comm_glb, p_err) + ENDIF + + deallocate (isend1d) + ENDIF + ENDIF + ENDDO + + IF (.not. p_is_worker) THEN + IF (present(rdata1d)) deallocate (rdata1d) + IF (present(rdata2d)) deallocate (rdata2d) + IF (present(idata1d)) deallocate (idata1d) + ENDIF + + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + + IF (numucat > 0) THEN + IF (present(rdata1d)) THEN + allocate (rdata1d (numucat)) + CALL mpi_recv (rdata1d, numucat, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + IF (present(rdata2d)) THEN + allocate (rdata2d (ndim1,numucat)) + CALL mpi_recv (rdata2d, ndim1*numucat, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + IF (present(idata1d)) THEN + allocate (idata1d (numucat)) + CALL mpi_recv (idata1d, numucat, MPI_INTEGER, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker .and. numucat == 0) THEN + IF (present(rdata1d)) THEN + IF (.not. allocated(rdata1d)) allocate (rdata1d (0)) + ENDIF + IF (present(rdata2d)) THEN + IF (.not. allocated(rdata2d)) allocate (rdata2d (ndim1,0)) + ENDIF + IF (present(idata1d)) THEN + IF (.not. allocated(idata1d)) allocate (idata1d (0)) + ENDIF + ENDIF + + END SUBROUTINE readin_riverlake_parameter + + ! + FUNCTION retrieve_depth_from_volume (this, volume) result(depth) + + IMPLICIT NONE + + class(vol_dep_curve_type) :: this + real(r8), intent(in) :: volume + real(r8) :: depth + + ! Local Variables + real(r8) :: v0, g + integer :: i + + v0 = volume - this%rivstomax + IF (v0 <= 0) THEN + depth = volume / this%rivare + ELSE + i = 1 + DO WHILE (i <= this%nlfp) + IF (v0 > this%flpstomax(i)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (i == this%nlfp+1) THEN + depth = this%rivhgt + this%flphgt(this%nlfp) & + + (v0-this%flpstomax(this%nlfp)) / this%flpaccare(this%nlfp) + ELSE + g = (this%flphgt(i)-this%flphgt(i-1))/this%flparea(i) + depth = this%rivhgt + this%flphgt(i-1) & + + g * (-this%flpaccare(i-1)+sqrt((this%flpaccare(i-1))**2+2*(v0-this%flpstomax(i-1))/g)) + ENDIF + ENDIF + + END FUNCTION retrieve_depth_from_volume + + ! + FUNCTION retrieve_volume_from_depth (this, depth) result(volume) + + IMPLICIT NONE + + class(vol_dep_curve_type) :: this + real(r8), intent(in) :: depth + real(r8) :: volume + + ! Local Variables + real(r8) :: h, d + integer :: i + + IF (depth <= this%rivhgt) THEN + volume = this%rivare * depth + ELSE + i = 1 + DO WHILE (i <= this%nlfp) + IF (depth > this%rivhgt+this%flphgt(i)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + + d = depth - this%rivhgt - this%flphgt(i-1) + IF (i == this%nlfp+1) THEN + volume = this%rivstomax + this%flpstomax(this%nlfp) + d * this%flpaccare(this%nlfp) + ELSE + h = this%flphgt(i)-this%flphgt(i-1) + volume = this%rivstomax + this%flpstomax(i-1) & + + (d/h*this%flparea(i)+2*this%flpaccare(i-1))*d*0.5 + ENDIF + ENDIF + + END FUNCTION retrieve_volume_from_depth + + ! + FUNCTION retrieve_area_from_depth (this, depth) result(area) + + IMPLICIT NONE + + class(vol_dep_curve_type) :: this + real(r8), intent(in) :: depth + real(r8) :: area + + ! Local Variables + real(r8) :: h, d + integer :: i + + IF (depth <= this%rivhgt) THEN + area = 0. + ELSE + i = 1 + DO WHILE (i <= this%nlfp) + IF (depth > this%rivhgt+this%flphgt(i)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (i == this%nlfp+1) THEN + area = this%flpaccare(this%nlfp) + ELSE + h = this%flphgt(i)-this%flphgt(i-1) + d = depth - this%rivhgt - this%flphgt(i-1) + area = this%flpaccare(i-1) + d/h * this%flparea(i) + ENDIF + ENDIF + + END FUNCTION retrieve_area_from_depth + + ! --- + SUBROUTINE vol_depth_curve_free_mem (this) + + IMPLICIT NONE + type(vol_dep_curve_type) :: this + + IF (allocated(this%flphgt )) deallocate (this%flphgt ) + IF (allocated(this%flparea )) deallocate (this%flparea ) + IF (allocated(this%flpaccare)) deallocate (this%flpaccare) + IF (allocated(this%flpstomax)) deallocate (this%flpstomax) + + END SUBROUTINE vol_depth_curve_free_mem + + ! --------- + SUBROUTINE riverlake_network_final () + + IMPLICIT NONE + + IF (allocated(x_ucat )) deallocate(x_ucat ) + IF (allocated(y_ucat )) deallocate(y_ucat ) + + IF (allocated(ucat_ucid )) deallocate(ucat_ucid ) + IF (allocated(ucat_gdid )) deallocate(ucat_gdid ) + + IF (allocated(numucat_wrk )) deallocate(numucat_wrk ) + IF (allocated(ucat_data_address)) deallocate(ucat_data_address) + + IF (allocated(inpm_gdid )) deallocate(inpm_gdid ) + IF (allocated(idmap_gd2uc )) deallocate(idmap_gd2uc ) + IF (allocated(area_gd2uc )) deallocate(area_gd2uc ) + IF (allocated(idmap_uc2gd )) deallocate(idmap_uc2gd ) + IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) + IF (allocated(ucat_next )) deallocate(ucat_next ) + IF (allocated(ucat_ups )) deallocate(ucat_ups ) + IF (allocated(irivsys )) deallocate(irivsys ) + + IF (allocated(topo_rivelv )) deallocate(topo_rivelv ) + IF (allocated(topo_rivhgt )) deallocate(topo_rivhgt ) + IF (allocated(topo_rivlen )) deallocate(topo_rivlen ) + IF (allocated(topo_rivman )) deallocate(topo_rivman ) + IF (allocated(topo_rivwth )) deallocate(topo_rivwth ) + IF (allocated(topo_rivare )) deallocate(topo_rivare ) + IF (allocated(topo_rivstomax )) deallocate(topo_rivstomax ) + IF (allocated(topo_area )) deallocate(topo_area ) + IF (allocated(topo_fldhgt )) deallocate(topo_fldhgt ) + IF (allocated(bedelv_next )) deallocate(bedelv_next ) + IF (allocated(outletwth )) deallocate(outletwth ) + + IF (allocated(floodplain_curve )) deallocate(floodplain_curve ) + + IF (allocated(allups_mask_ucat )) deallocate(allups_mask_ucat ) + + END SUBROUTINE riverlake_network_final + +END MODULE MOD_Grid_RiverLakeNetwork +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 new file mode 100644 index 0000000000..cc041fb766 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 @@ -0,0 +1,287 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeTimeVars +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Time Variables in gridded hydrological processes. +! +! Created by Shupeng Zhang, Oct 2025 +!------------------------------------------------------------------------------------- + + USE MOD_Precision +#ifdef GridRiverLakeSediment + USE MOD_Grid_RiverLakeSediment, only: write_sediment_restart +#endif + IMPLICIT NONE + + ! -- state variables -- + real(r8), allocatable :: wdsrf_ucat (:) ! river or lake water depth [m] + real(r8), allocatable :: veloc_riv (:) ! river velocity [m/s] + real(r8), allocatable :: momen_riv (:) ! unit river momentum [m^2/s] + real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3] + + ! -- restart file path (saved for deferred sediment restart read) -- + character(len=512) :: gridriver_restart_file = '' + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_GridRiverLakeTimeVars + PUBLIC :: deallocate_GridRiverLakeTimeVars + + PUBLIC :: read_GridRiverLakeTimeVars + PUBLIC :: write_GridRiverLakeTimeVars + +CONTAINS + + SUBROUTINE allocate_GridRiverLakeTimeVars + + USE MOD_SPMD_Task + USE MOD_Grid_RiverLakeNetwork, only: numucat + USE MOD_Grid_Reservoir, only: numresv + IMPLICIT NONE + + IF (p_is_worker) THEN + + allocate (wdsrf_ucat (numucat)) + allocate (veloc_riv (numucat)) + allocate (momen_riv (numucat)) + allocate (volresv (numresv)) + + ENDIF + + END SUBROUTINE allocate_GridRiverLakeTimeVars + + + SUBROUTINE READ_GridRiverLakeTimeVars (file_restart) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Vector_ReadWrite +#ifdef MPAS_EMBEDDED_COLM + USE MOD_NetCDFSerial, only: ncio_read_indexed_serial + USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid + USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index +#else + USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_data_address + USE MOD_Grid_Reservoir, only: numresv, resv_data_address, totalnumresv +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + gridriver_restart_file = trim(file_restart) + +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_worker .and. numucat > 0) THEN + CALL ncio_read_indexed_serial (file_restart, 'wdsrf_ucat', ucat_ucid, wdsrf_ucat) + CALL ncio_read_indexed_serial (file_restart, 'veloc_riv', ucat_ucid, veloc_riv ) + ENDIF +#else + CALL vector_read_and_scatter (file_restart, wdsrf_ucat, numucat, 'wdsrf_ucat', ucat_data_address) + CALL vector_read_and_scatter (file_restart, veloc_riv, numucat, 'veloc_riv', ucat_data_address) +#endif + + IF (DEF_Reservoir_Method > 0) THEN + IF (totalnumresv > 0) THEN +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_worker .and. numresv > 0) THEN + CALL ncio_read_indexed_serial (file_restart, 'volresv', resv_global_index, volresv) + ENDIF +#else + CALL vector_read_and_scatter (file_restart, volresv, numresv, 'volresv', resv_data_address) +#endif + ENDIF + ENDIF + + ! Note: sediment restart is read separately in grid_sediment_read_restart, + ! called from grid_riverlake_flow_init after sediment module is initialized. + + END SUBROUTINE READ_GridRiverLakeTimeVars + + + SUBROUTINE WRITE_GridRiverLakeTimeVars (file_restart) + + USE MOD_SPMD_Task + USE MOD_Namelist +#ifndef MPAS_EMBEDDED_COLM + USE MOD_NetCDFSerial + USE MOD_Vector_ReadWrite + USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_data_address + USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_data_address +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +#ifdef MPAS_EMBEDDED_COLM + CALL write_gridriver_restart_mpas_embedded (file_restart) +#else + IF (p_is_master) THEN + CALL ncio_create_file (trim(file_restart)) + CALL ncio_define_dimension(file_restart, 'ucatch', totalnumucat) + ENDIF + + CALL vector_gather_and_write (& + wdsrf_ucat, numucat, totalnumucat, ucat_data_address, file_restart, 'wdsrf_ucat', 'ucatch') + + CALL vector_gather_and_write (& + veloc_riv, numucat, totalnumucat, ucat_data_address, file_restart, 'veloc_riv', 'ucatch') + + IF (DEF_Reservoir_Method > 0) THEN + IF (totalnumresv > 0) THEN + + IF (p_is_master) CALL ncio_define_dimension(file_restart, 'reservoir', totalnumresv) + + CALL vector_gather_and_write (& + volresv, numresv, totalnumresv, resv_data_address, file_restart, 'volresv', 'reservoir') + ENDIF + ENDIF +#endif + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT) THEN + CALL write_sediment_restart(file_restart) + ENDIF +#endif + + END SUBROUTINE WRITE_GridRiverLakeTimeVars + +#ifdef MPAS_EMBEDDED_COLM + SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) + + USE mpi, only: MPI_INFO_NULL, MPI_OFFSET_KIND + USE pnetcdf + USE MOD_SPMD_Task, only: p_comm_worker + USE MOD_Namelist, only: DEF_Reservoir_Method + USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_ucid + USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + integer :: ierr + integer :: ncid + integer :: dim_ucatch + integer :: dim_reservoir + integer :: var_wdsrf + integer :: var_veloc + integer :: var_volresv + logical :: write_reservoir + + write_reservoir = DEF_Reservoir_Method > 0 .and. totalnumresv > 0 + + ierr = nf90mpi_create(p_comm_worker, trim(file_restart), & + IOR(NF90_CLOBBER, NF90_64BIT_OFFSET), MPI_INFO_NULL, ncid) + CALL pnetcdf_check(ierr, 'create', file_restart) + + ierr = nf90mpi_def_dim(ncid, 'ucatch', int(totalnumucat, MPI_OFFSET_KIND), dim_ucatch) + CALL pnetcdf_check(ierr, 'define ucatch dimension', file_restart) + + ierr = nf90mpi_def_var(ncid, 'wdsrf_ucat', NF90_DOUBLE, (/dim_ucatch/), var_wdsrf) + CALL pnetcdf_check(ierr, 'define wdsrf_ucat', file_restart) + + ierr = nf90mpi_def_var(ncid, 'veloc_riv', NF90_DOUBLE, (/dim_ucatch/), var_veloc) + CALL pnetcdf_check(ierr, 'define veloc_riv', file_restart) + + IF (write_reservoir) THEN + ierr = nf90mpi_def_dim(ncid, 'reservoir', int(totalnumresv, MPI_OFFSET_KIND), dim_reservoir) + CALL pnetcdf_check(ierr, 'define reservoir dimension', file_restart) + + ierr = nf90mpi_def_var(ncid, 'volresv', NF90_DOUBLE, (/dim_reservoir/), var_volresv) + CALL pnetcdf_check(ierr, 'define volresv', file_restart) + ENDIF + + ierr = nf90mpi_enddef(ncid) + CALL pnetcdf_check(ierr, 'end define mode', file_restart) + + ierr = nf90mpi_begin_indep_data(ncid) + CALL pnetcdf_check(ierr, 'begin independent data mode', file_restart) + + CALL pnetcdf_write_real8_points(ncid, var_wdsrf, ucat_ucid, wdsrf_ucat, numucat, & + 'wdsrf_ucat', file_restart) + CALL pnetcdf_write_real8_points(ncid, var_veloc, ucat_ucid, veloc_riv, numucat, & + 'veloc_riv', file_restart) + + IF (write_reservoir) THEN + CALL pnetcdf_write_real8_points(ncid, var_volresv, resv_global_index, volresv, numresv, & + 'volresv', file_restart) + ENDIF + + ierr = nf90mpi_end_indep_data(ncid) + CALL pnetcdf_check(ierr, 'end independent data mode', file_restart) + + ierr = nf90mpi_close(ncid) + CALL pnetcdf_check(ierr, 'close', file_restart) + + END SUBROUTINE write_gridriver_restart_mpas_embedded + + SUBROUTINE pnetcdf_write_real8_points(ncid, varid, index, data, ndata, varname, filename) + + USE mpi, only: MPI_OFFSET_KIND + USE pnetcdf, only: nfmpi_put_var1_double + USE MOD_SPMD_Task, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: ncid + integer, intent(in) :: varid + integer, intent(in) :: index(:) + real(r8), intent(in) :: data(:) + integer, intent(in) :: ndata + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + integer :: ierr + integer :: i + integer(kind=MPI_OFFSET_KIND) :: start(1) + real(r8) :: value + + IF (ndata > size(index) .or. ndata > size(data)) THEN + CALL CoLM_stop('PnetCDF indexed write size mismatch for '//trim(varname)) + ENDIF + + DO i = 1, ndata + IF (index(i) < 1) THEN + CALL CoLM_stop('PnetCDF indexed write invalid index for '//trim(varname)) + ENDIF + + start(1) = int(index(i), MPI_OFFSET_KIND) + value = data(i) + ierr = nfmpi_put_var1_double(ncid, varid, start, value) + CALL pnetcdf_check(ierr, 'write '//trim(varname), filename) + ENDDO + + END SUBROUTINE pnetcdf_write_real8_points + + SUBROUTINE pnetcdf_check(status, action, filename) + + USE pnetcdf, only: NF90_NOERR, nf90mpi_strerror + USE MOD_SPMD_Task, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: status + character(len=*), intent(in) :: action + character(len=*), intent(in) :: filename + + IF (status /= NF90_NOERR) THEN + write(*,'(A)') 'PnetCDF error during '//trim(action)//' for '//trim(filename)//': ' & + //trim(nf90mpi_strerror(status)) + CALL CoLM_stop() + ENDIF + + END SUBROUTINE pnetcdf_check +#endif + + SUBROUTINE deallocate_GridRiverLakeTimeVars + + IMPLICIT NONE + + IF (allocated (wdsrf_ucat)) deallocate (wdsrf_ucat) + IF (allocated (veloc_riv )) deallocate (veloc_riv ) + IF (allocated (momen_riv )) deallocate (momen_riv ) + IF (allocated (volresv )) deallocate (volresv ) + + END SUBROUTINE deallocate_GridRiverLakeTimeVars + +END MODULE MOD_Grid_RiverLakeTimeVars +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 new file mode 100644 index 0000000000..1480a85553 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 @@ -0,0 +1,173 @@ +#include + +MODULE MOD_Hydro_SoilFunction + +!---------------------------------------------------------------------------- +! Description: +! +! Soil function type 1: +! Campbell model +! CAMPBELL, G. S. (1974), Soil Science, 117(6), 311-314. +! +! Soil function type 2: +! Modified van Genuchten & Mualem model by introducing an air-entry value +! Ippisch et al. (2006), Advances in Water Resources, 29(12), 1780-1789. +! +! Created by Shupeng Zhang, 2022. +!---------------------------------------------------------------------------- + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), parameter :: minsmp = -1.e8 + + PUBLIC :: get_derived_parameters_vGM + + PUBLIC :: soil_psi_from_vliq + PUBLIC :: soil_hk_from_psi + PUBLIC :: soil_vliq_from_psi + +CONTAINS + + !------------------------------------- + SUBROUTINE get_derived_parameters_vGM ( & + psi_s, alpha_vgm, n_vgm, sc_vgm, fc_vgm) + + real(r8), intent(in) :: psi_s + real(r8), intent(in) :: alpha_vgm + real(r8), intent(in) :: n_vgm + + real(r8), intent(out) :: sc_vgm + real(r8), intent(out) :: fc_vgm + + ! Local variables + real(r8) :: m_vgm + + m_vgm = 1.0_r8 - 1.0_r8 / n_vgm + sc_vgm = (1.0_r8 + (- alpha_vgm * psi_s)**n_vgm) ** (-m_vgm) + fc_vgm = 1.0_r8 - (1.0_r8 - sc_vgm ** (1.0_r8/m_vgm)) ** m_vgm + + END SUBROUTINE get_derived_parameters_vGM + + !------------------------------------------------------------------ + real(r8) FUNCTION soil_hk_from_psi (psi, & + psi_s, hksat, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: psi + + real(r8), intent(in) :: psi_s + real(r8), intent(in) :: hksat + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + ! Local variables + real(r8) :: m_vgm, esat + + IF (psi >= psi_s) THEN + soil_hk_from_psi = hksat + RETURN + ENDIF + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + soil_hk_from_psi = hksat * (psi / psi_s)**(- 3.0_r8 / prms(1) - 2.0_r8) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! alpha_vgm => prms(1), n_vgm => prms(2), L_vgm => prms(3), sc_vgm => prms(4), fc_vgm => prms(5) + m_vgm = 1.0_r8 - 1.0_r8 / prms(2) + esat = (1.0_r8 + (- prms(1) * psi)**(prms(2)))**(-m_vgm) / prms(4) + soil_hk_from_psi = hksat * esat**prms(3) & + * ((1.0_r8 - (1.0_r8 - (esat*prms(4))**(1.0_r8/m_vgm))**m_vgm) / prms(5))**2.0_r8 +#endif + + END FUNCTION soil_hk_from_psi + + + !----------------------------------------------------------------- + real(r8) FUNCTION soil_psi_from_vliq (vliq, & + porsl, vl_r, psi_s, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: vliq + + real(r8), intent(in) :: porsl + real(r8), intent(in) :: vl_r + real(r8), intent(in) :: psi_s + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + ! Local variables + real(r8) :: esat, m_vgm + + IF (vliq >= porsl) THEN + soil_psi_from_vliq = psi_s + RETURN + ELSEIF (vliq <= max(vl_r,1.0e-8)) THEN + soil_psi_from_vliq = minsmp + RETURN + ENDIF + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + soil_psi_from_vliq = psi_s * (vliq / porsl)**(-prms(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! alpha_vgm => prms(1), n_vgm => prms(2), L_vgm => prms(3), sc_vgm => prms(4), fc_vgm => prms(5) + m_vgm = 1.0_r8 - 1.0_r8 / prms(2) + esat = (vliq - vl_r) / (porsl - vl_r) + soil_psi_from_vliq = - ((esat*prms(4))**(- 1.0_r8/m_vgm) - 1.0_r8)**(1.0_r8/prms(2)) & + / prms(1) +#endif + + soil_psi_from_vliq = max(soil_psi_from_vliq, minsmp) + + + END FUNCTION soil_psi_from_vliq + + !------------------------------------------------------------------ + real(r8) FUNCTION soil_vliq_from_psi (psi, & + porsl, vl_r, psi_s, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: psi + + real(r8), intent(in) :: porsl + real(r8), intent(in) :: vl_r + real(r8), intent(in) :: psi_s + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + ! Local variables + real(r8) :: esat, m_vgm + + IF (psi >= psi_s) THEN + soil_vliq_from_psi = porsl + RETURN + ENDIF + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + soil_vliq_from_psi = porsl * (psi / psi_s)**(-1.0/prms(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! alpha_vgm => prms(1), n_vgm => prms(2), L_vgm => prms(3), sc_vgm => prms(4), fc_vgm => prms(5) + m_vgm = 1.0_r8 - 1.0_r8 / prms(2) + esat = (1.0_r8 + (psi * (-prms(1)))**(prms(2))) ** (-m_vgm) / prms(4) + soil_vliq_from_psi = (porsl - vl_r) * esat + vl_r +#endif + + END FUNCTION soil_vliq_from_psi + + +END MODULE MOD_Hydro_SoilFunction diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 new file mode 100644 index 0000000000..90f83eee1e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 @@ -0,0 +1,3620 @@ +#include + +MODULE MOD_Hydro_SoilWater + +!------------------------------------------------------------------------- +! Description: +! +! Numerical Solver of Richards equation. +! +! Dai, Y., Zhang, S., Yuan, H., & Wei, N. (2019). +! Modeling Variably Saturated Flow in Stratified Soils +! With Explicit Tracking of Wetting Front and Water Table Locations. +! Water Resources Research. doi:10.1029/2019wr025368 +! +! Created by Shupeng Zhang, 2022. +!------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Hydro_SoilFunction + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS + USE MOD_UserDefFun, only: findloc_ud + + IMPLICIT NONE + + ! public subroutines and functions + PUBLIC :: soil_water_vertical_movement + PUBLIC :: get_water_equilibrium_state + PUBLIC :: soilwater_aquifer_exchange + PUBLIC :: get_zwt_from_wa + + + ! boundary condition: + ! 1: fixed pressure head + ! 2: rainfall condition with a ponding layer on top of ground surface + ! and a flux such as rainfall into the ponding layer + ! 3: fixed flux + ! 4: drainage condition with aquifers below soil columns + integer, parameter :: BC_FIX_HEAD = 1 + integer, parameter :: BC_RAINFALL = 2 + integer, parameter :: BC_FIX_FLUX = 3 + integer, parameter :: BC_DRAINAGE = 4 + + ! formula of effective hydraulic conductivity between levels + ! Please refer to Dai et al. (2019) for definitions + integer, parameter :: type_upstream_mean = 1 + integer, parameter :: type_weighted_geometric_mean = 2 + + integer, parameter :: effective_hk_type = type_weighted_geometric_mean + integer, parameter :: max_iters_richards = 10 + real(r8), parameter :: tol_richards = 8.e-8 + +#ifdef CoLMDEBUG + integer(8) :: count_implicit = 0 + integer(8) :: count_explicit = 0 + integer(8) :: count_wet2dry = 0 +#endif + + ! private subroutines and functions + PRIVATE :: Richards_solver + + PRIVATE :: water_balance + PRIVATE :: initialize_sublevel_structure + + PRIVATE :: use_explicit_form + + PRIVATE :: var_perturb_level + PRIVATE :: var_perturb_rainfall + PRIVATE :: var_perturb_drainage + + PRIVATE :: check_and_update_level + + PRIVATE :: flux_all + PRIVATE :: flux_sat_zone_all + PRIVATE :: flux_sat_zone_fixed_bc + PRIVATE :: flux_inside_hm_soil + PRIVATE :: flux_at_unsaturated_interface + PRIVATE :: flux_top_transitive_interface + PRIVATE :: flux_btm_transitive_interface + PRIVATE :: flux_both_transitive_interface + + PRIVATE :: solve_least_squares_problem + PRIVATE :: secant_method_iteration + + PRIVATE :: find_unsat_lev_lower + +CONTAINS + + ! ---- get equilibrium state ---- + SUBROUTINE get_water_equilibrium_state ( & + zwtmm, nlev, wliq, smp, hk, wa, sp_zc, sp_zi, porsl, vl_r, psi_s, hksat, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: zwtmm ! location of water table [mm] + + integer, intent(in) :: nlev ! number of levels + + real(r8), intent(out) :: wliq(1:nlev) ! [mm] or [kg/m2] + real(r8), intent(out) :: smp (1:nlev) ! [mm] + real(r8), intent(out) :: hk (1:nlev) ! [mm/s] + real(r8), intent(out) :: wa ! water in aquifer [mm] + + real(r8), intent(in) :: sp_zc (1:nlev) ! soil parameter : centers of level [mm] + real(r8), intent(in) :: sp_zi (0:nlev) ! soil parameter : interfaces of level [mm] + + real(r8), intent(in) :: porsl (1:nlev) ! soil porosity + real(r8), intent(in) :: vl_r (1:nlev) ! residual soil moisture + real(r8), intent(in) :: psi_s (1:nlev) ! saturated capillary potential [mm, negative] + real(r8), intent(in) :: hksat (1:nlev) ! saturated hydraulic conductivity [mm/s] + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function + + ! Local Variables + integer :: izwt, ilev + real(r8) :: psi_zwt, smp_up, vliq_up, vliq(1:nlev), psi, vl + + ! water table location + izwt = findloc_ud(zwtmm >= sp_zi, back=.true.) + + IF (izwt <= nlev) THEN + psi_zwt = psi_s(izwt) + ELSE + psi_zwt = psi_s(nlev) + ENDIF + + DO ilev = 1, nlev + IF (ilev < izwt) THEN + smp (ilev) = psi_zwt - (zwtmm - sp_zc(ilev)) + vliq(ilev) = soil_vliq_from_psi (smp(ilev), porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + wliq(ilev) = vliq(ilev) * (sp_zi(ilev)-sp_zi(ilev-1)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSEIF (ilev == izwt) THEN + smp_up = psi_zwt & + - (zwtmm-sp_zi(ilev-1)) * (sp_zi(ilev)-sp_zc(ilev))/(sp_zi(ilev)-sp_zi(ilev-1)) + vliq_up = soil_vliq_from_psi (smp_up, porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + wliq(ilev) = vliq_up * (zwtmm-sp_zi(ilev-1)) + porsl(ilev)*(sp_zi(ilev)-zwtmm) + vliq(ilev) = wliq(ilev) / (sp_zi(ilev)-sp_zi(ilev-1)) + smp(ilev) = soil_psi_from_vliq (vliq(ilev), porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + wliq(ilev) = porsl(ilev) * (sp_zi(ilev)-sp_zi(ilev-1)) + smp (ilev) = psi_s(ilev) + hk (ilev) = hksat(ilev) + ENDIF + ENDDO + + IF (izwt == nlev+1) THEN + psi = psi_zwt - (zwtmm - sp_zi(nlev)) * 0.5 + vl = soil_vliq_from_psi (psi, porsl(nlev), vl_r(nlev), psi_s(nlev), nprm, prms(:,nlev)) + wa = -(zwtmm-sp_zi(nlev))*(porsl(nlev)-vl) + ELSE + wa = 0. + ENDIF + + END SUBROUTINE get_water_equilibrium_state + + ! --- soil water movement --- + SUBROUTINE soil_water_vertical_movement ( & + nlev, dt, sp_zc, sp_zi, is_permeable, porsl, & + vl_r, psi_s, hksat, nprm, prms, porsl_wa, & + qgtop, etr, rootr, rootflux, rsubst, qinfl, & + ss_dp, zwt, wa, ss_vliq, smp, hk, & + qlayer, tolerance, wblc) + + !======================================================================= + ! this is the main subroutine to execute the calculation of + ! soil water movement + !======================================================================= + + USE MOD_Const_Physical, only: tfrz + + IMPLICIT NONE + + integer, intent(in) :: nlev ! number of levels + real(r8), intent(in) :: dt ! time step (second) + + real(r8), intent(in) :: sp_zc (1:nlev) ! soil parameter : centers of level (mm) + real(r8), intent(in) :: sp_zi (0:nlev) ! soil parameter : interfaces of level (mm) + + logical, intent(in) :: is_permeable (1:nlev) + + real(r8), intent(in) :: porsl (1:nlev) ! soil porosity (mm^3/mm^3) + real(r8), intent(in) :: vl_r (1:nlev) ! residual soil moisture (mm^3/mm^3) + real(r8), intent(in) :: psi_s (1:nlev) ! saturated capillary potential (mm) + real(r8), intent(in) :: hksat (1:nlev) ! saturated hydraulic conductivity (mm/s) + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function + + real(r8), intent(in) :: porsl_wa ! soil porosity in aquifer (mm^3/mm^3) + + ! ground water including rain, snow melt and dew formation (mm/s) + real(r8), intent(in) :: qgtop + + real(r8), intent(in) :: etr ! transpiration rate (mm/s) + real(r8), intent(in) :: rootr(1:nlev) ! root fractions (percentage) + real(r8), intent(in) :: rootflux(1:nlev) ! root water uptake from different layers (mm/s) + + real(r8), intent(in) :: rsubst ! subsurface runoff (mm/s) + real(r8), intent(out) :: qinfl ! infiltration into soil (mm/s) + + real(r8), intent(inout) :: ss_dp ! soil water state : depth of ponding water (mm) + real(r8), intent(inout) :: zwt ! location of water table (mm) + real(r8), intent(inout) :: wa ! water deficit in aquifer (negative, mm) + real(r8), intent(inout) :: ss_vliq(1:nlev) ! volume content of liquid water (mm^3/mm^3) + + real(r8), intent(out) :: smp(1:nlev) ! soil matrix potential (mm) + real(r8), intent(out) :: hk (1:nlev) ! hydraulic conductivity (mm/s) + + real(r8), intent(out) :: qlayer(0:nlev) ! water flux at interface of soil layers (mm/s) + + real(r8), intent(in) :: tolerance + + real(r8), intent(out) :: wblc + + ! Local variables + integer :: lb, ub, ilev, izwt + real(r8) :: sumroot, deficit, etrdef, wexchange + real(r8) :: dp_m1, psi, vliq, zwtp, air + logical :: is_sat + + real(r8) :: sp_dz (1:nlev) + real(r8) :: etroot (1:nlev) + real(r8) :: ss_wt (1:nlev) + + integer :: ubc_typ_sub + real(r8) :: ubc_val_sub + integer :: lbc_typ_sub + real(r8) :: lbc_val_sub + + real(r8) :: w_sum_before, w_sum_after, vl_before(nlev), wt_before, wa_before, dp_before + + real(r8) :: tol_q, tol_z, tol_v, tol_p + + sp_dz(1:nlev) = sp_zi(1:nlev) - sp_zi(0:nlev-1) + + dp_m1 = ss_dp + + ! tolerances + tol_q = tolerance / real(nlev,r8) / dt /2.0 + tol_z = tol_q * dt + tol_v = tol_z / maxval(sp_dz) + tol_p = 1.0e-14 + + ! water table location + izwt = findloc_ud(zwt >= sp_zi, back=.true.) + + ! total water mass + w_sum_before = ss_dp + DO ilev = 1, nlev + IF (is_permeable(ilev)) THEN + IF (ilev <= izwt-1) THEN + w_sum_before = w_sum_before + ss_vliq(ilev) * sp_dz(ilev) + ELSEIF (ilev == izwt) THEN + w_sum_before = w_sum_before + ss_vliq(izwt) * (zwt - sp_zi(izwt-1)) + w_sum_before = w_sum_before + porsl (izwt) * (sp_zi(izwt) - zwt) + ELSE + w_sum_before = w_sum_before + porsl(ilev) * sp_dz(ilev) + ENDIF + ENDIF + ENDDO + w_sum_before = w_sum_before + wa + + vl_before = ss_vliq + wt_before = zwt + wa_before = wa + dp_before = ss_dp + + ! transpiration + IF(.not. DEF_USE_PLANTHYDRAULICS)THEN + sumroot = sum(rootr, mask = is_permeable .and. (rootr > 0.)) + etroot(:) = 0. + IF (sumroot > 0.) THEN + WHERE (is_permeable) + etroot = etr * max(rootr, 0.) / sumroot + END WHERE + etrdef = 0. + ELSE + etrdef = etr*dt + ENDIF + ELSE + etrdef = 0. + etroot(:) = rootflux + ENDIF + + deficit = etrdef + + DO ilev = 1, izwt-1 + IF (is_permeable(ilev)) THEN + + ss_vliq(ilev) = (ss_vliq(ilev) * sp_dz(ilev) & + - etroot(ilev)*dt - deficit) / sp_dz(ilev) + + IF (ss_vliq(ilev) < 0) THEN + deficit = ( - ss_vliq(ilev)) * sp_dz(ilev) + ss_vliq(ilev) = 0 + ELSEIF (ss_vliq(ilev) > porsl(ilev)) THEN + deficit = - (ss_vliq(ilev) - porsl(ilev)) * sp_dz(ilev) + ss_vliq(ilev) = porsl(ilev) + ELSE + deficit = 0. + ENDIF + ELSE + deficit = deficit + etroot(ilev)*dt + ENDIF + ENDDO + + DO ilev = izwt, nlev + deficit = deficit + etroot(ilev)*dt + ENDDO + + ! Exchange water with aquifer + wexchange = rsubst * dt + deficit + CALL soilwater_aquifer_exchange ( & + nlev, wexchange, sp_zi, is_permeable, porsl, vl_r, psi_s, hksat, & + nprm, prms, porsl_wa, ss_dp, ss_vliq, zwt, wa, izwt) + + ! water table location + ss_wt(:) = 0._r8 + IF ((izwt >= 1) .and. (izwt <= nlev)) THEN + ss_wt(izwt) = sp_zi(izwt) - zwt + ENDIF + DO ilev = izwt+1, nlev + ss_wt(ilev) = sp_dz(ilev) + ENDDO + + ! Impermeable levels cut the soil column into several disconnected parts. + ! The Richards solver is called to calculate water movement part by part. + ub = nlev + soilcolumn : DO WHILE (ub >= 1) + + DO WHILE (.not. is_permeable(ub)) + + qlayer(ub-1:ub) = 0._r8 + + IF (ub > 1) THEN + ub = ub - 1 + ELSE + EXIT soilcolumn + ENDIF + ENDDO + + lb = ub + DO WHILE (lb > 1) + IF (is_permeable(lb-1)) THEN + lb = lb - 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (lb == 1) THEN + ubc_typ_sub = BC_RAINFALL + ubc_val_sub = qgtop + ELSE + ubc_typ_sub = BC_FIX_FLUX + ubc_val_sub = 0 + ENDIF + + IF ((ub == nlev) .and. (izwt > nlev)) THEN + lbc_typ_sub = BC_DRAINAGE + lbc_val_sub = 0. + ELSE + lbc_typ_sub = BC_FIX_FLUX + lbc_val_sub = 0. + ENDIF + + CALL Richards_solver ( & + lb, ub, dt, sp_zc(lb:ub), sp_zi(lb-1:ub), & + porsl(lb:ub), vl_r(lb:ub), psi_s(lb:ub), hksat(lb:ub), nprm, prms(:,lb:ub), & + porsl_wa, & + ubc_typ_sub, ubc_val_sub, lbc_typ_sub, lbc_val_sub, & + ss_dp, wa, ss_vliq(lb:ub), ss_wt(lb:ub), qlayer(lb-1:ub), & + tol_q, tol_z, tol_v, tol_p) + + ub = lb - 1 + + ENDDO soilcolumn + + IF (.not. is_permeable(1)) THEN + ss_dp = max(ss_dp + qgtop * dt, 0._r8) + ENDIF + + IF (wa >= 0) THEN + DO ilev = nlev, 1, -1 + is_sat = (.not. is_permeable(ilev)) & + .or. (ss_vliq(ilev) > porsl(ilev) - tol_v) & + .or. (ss_wt (ilev) > sp_dz(ilev) - tol_z) + IF (.not. is_sat) THEN + zwt = sp_zi(ilev) - ss_wt(ilev) + EXIT + ENDIF + ENDDO + + IF (is_sat) THEN + zwt = 0._r8 + ENDIF + ELSE + CALL get_zwt_from_wa ( & + porsl_wa, vl_r(nlev), psi_s(nlev), hksat(nlev), & + nprm, prms(:,nlev), tol_v, tol_z, & + wa, sp_zi(nlev), zwt) + ENDIF + + izwt = findloc_ud(zwt >= sp_zi, back=.true.) + DO ilev = izwt-1, 1, -1 + IF (is_permeable(ilev)) THEN + ss_vliq(ilev) = (ss_vliq(ilev)*(sp_dz(ilev)-ss_wt(ilev)) & + + porsl(ilev)*ss_wt(ilev)) / sp_dz(ilev) + ENDIF + ENDDO + + qinfl = qgtop - (ss_dp - dp_m1)/dt + + ! total water mass + w_sum_after = ss_dp + DO ilev = 1, nlev + IF (is_permeable(ilev)) THEN + IF (ilev <= izwt-1) THEN + w_sum_after = w_sum_after + ss_vliq(ilev) * sp_dz(ilev) + ELSEIF (ilev == izwt) THEN + w_sum_after = w_sum_after + ss_vliq(izwt) * (zwt - sp_zi(izwt-1)) + w_sum_after = w_sum_after + porsl (izwt) * (sp_zi(izwt) - zwt) + ELSE + w_sum_after = w_sum_after + porsl(ilev) * sp_dz(ilev) + ENDIF + ENDIF + ENDDO + w_sum_after = w_sum_after + wa + + wblc = w_sum_after - (w_sum_before + (qgtop - sum(etroot) - rsubst) * dt - etrdef) + + IF (abs(wblc) > tolerance) THEN + write(*,*) 'soil_water_vertical_movement balance error: ', wblc, ' in mm.' + write(*,*) 'qtop: ', qgtop, 'etr: ', sum(etroot)+etrdef, 'rsubst: ', rsubst + write(*,*) 'permeable (1-10): ', is_permeable + write(*,*) 'ponding depth: ', dp_before, '(before) to ', ss_dp, '(after)' + write(*,*) 'porsl (c1) and liquid volume before (c2) and after (c3) (1-10) : ' + DO ilev = 1, nlev + write(*,*) porsl(ilev), vl_before(ilev), ss_vliq(ilev) + ENDDO + write(*,*) 'water table : ', wt_before, '(before) to ', zwt, '(after)' + write(*,*) 'aquifer : ', wa_before, '(before) to ', wa, '(after)' + ENDIF + + DO ilev = 1, nlev + IF (ilev < izwt) THEN + smp(ilev) = soil_psi_from_vliq (ss_vliq(ilev), porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSEIF (ilev == izwt) THEN + vliq = (ss_vliq(izwt) * (zwt - sp_zi(izwt-1)) + porsl(izwt) * (sp_zi(izwt) - zwt)) & + / (sp_zi(izwt) - sp_zi(izwt-1)) + smp(ilev) = soil_psi_from_vliq (vliq, porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + smp(ilev) = psi_s(ilev) + hk (ilev) = hksat(ilev) + ENDIF + ENDDO + + END SUBROUTINE soil_water_vertical_movement + + ! --- water exchange between soil water and aquifer --- + SUBROUTINE soilwater_aquifer_exchange ( & + nlev, exwater, sp_zi, is_permeable, porsl, vl_r, psi_s, hksat, & + nprm, prms, porsl_wa, ss_dp, ss_vliq, zwt, wa, izwt) + + IMPLICIT NONE + + integer, intent(in) :: nlev + + real(r8), intent(in) :: exwater ! total water exchange [mm] + + real(r8), intent(in) :: sp_zi (0:nlev) ! soil parameter : interfaces of level [mm] + + logical, intent(in) :: is_permeable (1:nlev) + real(r8), intent(in) :: porsl (1:nlev) ! soil porosity [mm^3/mm^3] + real(r8), intent(in) :: vl_r (1:nlev) ! residual soil moisture [mm^3/mm^3] + real(r8), intent(in) :: psi_s (1:nlev) ! saturated capillary potential [mm] + real(r8), intent(in) :: hksat (1:nlev) ! saturated hydraulic conductivity [mm/s] + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function + + real(r8), intent(in) :: porsl_wa ! soil porosity in aquifer [mm^3/mm^3] + + real(r8), intent(inout) :: ss_dp ! depth of ponding water [mm] + real(r8), intent(inout) :: ss_vliq(1:nlev) ! volume content of liquid water [mm^3/mm^3] + real(r8), intent(inout) :: zwt ! location of water table [mm] + real(r8), intent(inout) :: wa ! water in aquifer [mm, negative] + + integer, intent(out) :: izwt + + ! Local variables + real(r8) :: sp_dz(1:nlev) + real(r8) :: reswater, zwtp, psi, vliq, air + real(r8) :: tol_v, tol_z + + sp_dz(1:nlev) = sp_zi(1:nlev) - sp_zi(0:nlev-1) + + ! tolerances + tol_z = tol_richards / sqrt(real(nlev,r8)) * 0.5_r8 * 1800._r8 + tol_v = tol_z / maxval(sp_dz) + + ! water table location + izwt = findloc_ud(zwt >= sp_zi, back=.true.) + + reswater = exwater + + IF (reswater > 0.) THEN + + IF ((zwt <= 0.) .and. (ss_dp > 0.)) THEN + IF (ss_dp > reswater) THEN + ss_dp = ss_dp - reswater + reswater = 0. + ELSE + reswater = reswater - ss_dp + ss_dp = 0. + ENDIF + ENDIF + + ! remove water from aquifer + DO WHILE (reswater > 0.) + IF (izwt <= nlev) THEN + IF (is_permeable(izwt)) THEN + + CALL get_zwt_from_wa ( & + porsl(izwt), vl_r(izwt), psi_s(izwt), hksat(izwt), & + nprm, prms(:,izwt), tol_v, tol_z, -reswater, zwt, zwtp) + + IF (zwtp < sp_zi(izwt)) THEN + ss_vliq(izwt) = (ss_vliq(izwt)*(zwt-sp_zi(izwt-1)) & + + porsl(izwt)*(zwtp-zwt) - reswater) / (zwtp - sp_zi(izwt-1)) + reswater = 0. + zwt = zwtp + ELSE + psi = psi_s(izwt) - (zwtp - 0.5*(sp_zi(izwt) + zwt)) + vliq = soil_vliq_from_psi (psi, & + porsl(izwt), vl_r(izwt), psi_s(izwt), nprm, prms(:,izwt)) + IF (reswater > (porsl(izwt)-vliq) * (sp_zi(izwt)-zwt)) THEN + ss_vliq(izwt) = (ss_vliq(izwt)*(zwt-sp_zi(izwt-1)) & + + vliq * (sp_zi(izwt)-zwt)) / sp_dz(izwt) + reswater = reswater - (porsl(izwt)-vliq) * (sp_zi(izwt)-zwt) + ELSE + ss_vliq(izwt) = (ss_vliq(izwt)*(zwt-sp_zi(izwt-1)) & + + porsl(izwt)*(sp_zi(izwt)-zwt) - reswater) / sp_dz(izwt) + reswater = 0. + ENDIF + + zwt = sp_zi(izwt) + izwt = izwt + 1 + ENDIF + + ELSE + zwt = sp_zi(izwt) + izwt = izwt + 1 + ENDIF + ELSE + CALL get_zwt_from_wa ( & + porsl_wa, vl_r(nlev), psi_s(nlev), hksat(nlev), & + nprm, prms(:,nlev), tol_v, tol_z, wa-reswater, sp_zi(nlev), zwt) + wa = wa - reswater + reswater = 0. + ENDIF + ENDDO + + ELSEIF (reswater < 0.) THEN + + ! increase water in aquifer + DO WHILE (reswater < 0.) + IF (izwt > nlev) THEN + IF (wa <= reswater) THEN + wa = wa - reswater + reswater = 0. + ELSE + reswater = reswater - wa + wa = 0. + izwt = nlev + zwt = sp_zi(nlev) + ENDIF + ELSEIF (izwt >= 1) THEN + IF (is_permeable(izwt)) THEN + air = (porsl(izwt)-ss_vliq(izwt)) * (zwt-sp_zi(izwt-1)) + IF (air > -reswater) THEN + ss_vliq(izwt) = ss_vliq(izwt) - reswater / (zwt-sp_zi(izwt-1)) + reswater = 0. + ELSE + ss_vliq(izwt) = porsl(izwt) + reswater = reswater + air + izwt = izwt - 1 + zwt = sp_zi(izwt) + ENDIF + ELSE + izwt = izwt - 1 + zwt = sp_zi(izwt) + ENDIF + ELSE + ss_dp = ss_dp - reswater + reswater = 0. + izwt = 1 + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE soilwater_aquifer_exchange + + ! ---- Richards equation solver ---- + SUBROUTINE Richards_solver ( & + lb, ub, dt, sp_zc, sp_zi, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + vl_s_wa, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_dp, waquifer, ss_vl, ss_wt, ss_q, & + tol_q, tol_z, tol_v, tol_p) + + IMPLICIT NONE + + integer, intent(in) :: lb, ub ! lower and upper boundary + + real(r8), intent(in) :: dt ! time step (second) + + real(r8), intent(in) :: sp_zc (lb:ub) ! soil parameter : centers of level (mm) + real(r8), intent(in) :: sp_zi (lb-1:ub) ! soil parameter : interfaces of level (mm) + + real(r8), intent(in) :: vl_s (lb:ub) ! soil porosity (mm^3/mm^3) + real(r8), intent(in) :: vl_r (lb:ub) ! residual soil moisture (mm^3/mm^3) + real(r8), intent(in) :: psi_s (lb:ub) ! saturated capillary potential (mm,negative) + real(r8), intent(in) :: hksat (lb:ub) ! saturated hydraulic conductivity (mm/s) + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms(nprm,lb:ub) ! parameters included in soil function + + real(r8), intent(in) :: vl_s_wa ! soil porosity in aquifer (mm^3/mm^3) + + integer, intent(in) :: ubc_typ ! upper boundary condition type + real(r8), intent(in) :: ubc_val ! value of upper boundary condition + integer, intent(in) :: lbc_typ ! lower boundary condition type + real(r8), intent(in) :: lbc_val ! value of lower boundary condition + + real(r8), intent(inout) :: ss_dp ! soil water state : depth of ponding water (mm) + real(r8), intent(inout) :: waquifer ! water deficit in aquifer (mm, negative) + real(r8), intent(inout) :: ss_vl (lb:ub) ! soil water state : volume content of liquid water + real(r8), intent(inout) :: ss_wt (lb:ub) ! soil water state : location of water table (mm) + real(r8), intent(out) :: ss_q (lb-1:ub) ! soil water state : flux between levels (mm/s) + + real(r8), intent(in) :: tol_q ! tolerance for flux + real(r8), intent(in) :: tol_z ! tolerance for locations + real(r8), intent(in) :: tol_v ! tolerance for volumetric water content + real(r8), intent(in) :: tol_p ! tolerance for potential head + + ! Local variables + real(r8) :: zwt ! location of water table (mm) + real(r8) :: sp_dz (lb:ub) ! thickness of level (mm) + real(r8) :: ss_wf (lb:ub) ! soil water state : location of wetting front + + logical :: is_sat (lb:ub) ! whether a level is saturated or not at this time step + logical :: has_wf (lb:ub) ! whether a wetting front is present or not + logical :: has_wt (lb:ub) ! whether a water table is present or not + + real(r8) :: psi (lb:ub) ! water pressure head in unsaturated soil (mm) + real(r8) :: hk (lb:ub) ! hydraulic conductivity in unsaturated soil (mm/s) + + real(r8) :: psi_pb (lb:ub) ! perturbed water pressure head (mm) + real(r8) :: hk_pb (lb:ub) ! perturbed hydraulic conductivity (mm/s) + + real(r8) :: q_this(lb-1:ub) ! water flux between levels (mm/s) + real(r8) :: q_wf (lb:ub) ! water flux at wetting front (mm/s) + real(r8) :: q_wt (lb:ub) ! water flux at water table (mm/s) + + real(r8) :: dp_m1 ! depth of ponding water at previous time step (mm) + real(r8) :: wf_m1 (lb:ub) ! location of wetting front at previous time step (mm) + real(r8) :: vl_m1 (lb:ub) ! volumetric water content at previous time step (mm/mm) + real(r8) :: wt_m1 (lb:ub) ! location of water table at previous time step (mm) + real(r8) :: waquifer_m1 ! water deficit in aquifer at previous time step + + real(r8) :: q_0 (lb-1:ub) ! initial value of water flux between levels (mm/s) + real(r8) :: q_wf_0 (lb:ub) ! initial value of water flux at wetting front (mm/s) + real(r8) :: q_wt_0 (lb:ub) ! initial value of water flux at water table (mm/s) + + real(r8) :: dp_pb ! perturbed depth of ponding water (mm) + real(r8) :: vl_pb (lb:ub) ! perturbed volumetric water content (mm/mm) + real(r8) :: wf_pb (lb:ub) ! perturbed location of wetting front (mm) + real(r8) :: wt_pb (lb:ub) ! perturbed location of water table (mm) + real(r8) :: zwt_pb, waquifer_pb + + real(r8) :: q_pb (lb-1:ub) ! perturbed water flux between levels (mm/s) + real(r8) :: q_wf_pb (lb:ub) ! perturbed water flux at wetting front (mm/s) + real(r8) :: q_wt_pb (lb:ub) ! perturbed water flux at water table (mm/s) + + real(r8) :: blc (lb-1:ub+1) ! mass balance (mm water) + logical :: is_solvable + logical :: lev_update (lb-1:ub+1) ! whether a level is updated or not + real(r8) :: blc_pb (lb-1:ub+1) ! perturbed mass balance (mm water) + logical :: vact (lb-1:ub+1) ! whether a level is active or not + integer :: jsbl (lb:ub) ! which variable of wf,vl,wt inside each level is active + + real(r8) :: dr_dv (lb-1:ub+1,lb-1:ub+1) ! the Jacobian matrix + real(r8) :: dv (lb-1:ub+1) ! searching step of variables + + real(r8) :: f2_norm (max_iters_richards) ! sqrt( f2 ), where f2 = sum_i (r_i ^2) + + real(r8) :: dt_this, dt_done + real(r8) :: dt_explicit ! time step (day) for explicit scheme + + integer :: ilev, iter + real(r8) :: dlt + + logical :: wet2dry + + real(r8) :: wsum_m1, wsum, werr + + ss_wf(lb:ub) = 0 + + DO ilev = lb, ub + sp_dz(ilev) = sp_zi(ilev) - sp_zi(ilev-1) + ENDDO + + dt_explicit = dt / max_iters_richards + + ss_q = 0 + dt_done = 0 + DO WHILE (dt_done < dt) + + dt_this = dt - dt_done + + wf_m1 = ss_wf + vl_m1 = ss_vl + wt_m1 = ss_wt + + wsum_m1 = sum(ss_vl * (sp_dz - ss_wt)) + sum(ss_wt * vl_s) + IF (ubc_typ == BC_RAINFALL) THEN + wsum_m1 = wsum_m1 + ss_dp + ENDIF + IF (lbc_typ == BC_DRAINAGE) THEN + wsum_m1 = wsum_m1 + waquifer + ENDIF + + IF (ubc_typ == BC_RAINFALL) THEN + dp_m1 = max(ss_dp, 0._r8) + ENDIF + + IF (lbc_typ == BC_DRAINAGE) THEN + waquifer_m1 = waquifer + CALL get_zwt_from_wa ( & + vl_s_wa, vl_r(ub), psi_s(ub), hksat(ub), & + nprm, prms(:,ub), tol_v, tol_z, & + waquifer, sp_zi(ub), zwt) + ENDIF + + iter = 0 + DO WHILE (.true.) + + iter = iter + 1 + + CALL initialize_sublevel_structure ( & + lb, ub, sp_dz, sp_zi(ub), & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, ss_dp, psi, hk, & + tol_v, tol_z) + + lev_update (:) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .true., & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, ss_dp, zwt, psi, hk, & + q_this, q_wf, q_wt, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_this, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_wf, ss_vl, ss_wt, ss_dp, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc, is_solvable, tol_richards * dt_this) + + IF (iter == 1) THEN + q_0 = q_this + q_wf_0 = q_wf + q_wt_0 = q_wt + + wet2dry = .false. + IF (ubc_typ == BC_RAINFALL) THEN + IF ((dp_m1 > tol_z) .and. (dp_m1 - (q_0(lb-1)-ubc_val)*dt_this < tol_z)) THEN + wet2dry = .true. + ENDIF + ENDIF + ENDIF + + f2_norm(iter) = sqrt(sum(blc**2)) + + IF ( (f2_norm(iter) < tol_richards * dt_this) & ! converged + .or. (dt_this < dt_explicit) & + .or. (iter >= max_iters_richards) & + .or. (.not. is_solvable) & + .or. wet2dry) THEN + + IF ((dt_this < dt_explicit) & + .or. (iter >= max_iters_richards) & + .or. (.not. is_solvable) & + .or. wet2dry) THEN + + dt_this = min(dt_this, dt_explicit) + q_this = q_0 + + CALL use_explicit_form ( & + lb, ub, dt_this, sp_dz, sp_zc, sp_zi, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + vl_s_wa, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + q_this, q_wf_0, q_wt_0, & + ss_wf, ss_vl, ss_wt, ss_dp, waquifer, zwt, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + tol_q, tol_z, tol_v) + + ENDIF + + dt_done = dt_done + dt_this + +#ifdef CoLMDEBUG + IF (f2_norm(iter) < tol_richards * dt_this) THEN + count_implicit = count_implicit + 1 + ELSEIF (iter >= max_iters_richards) then + count_explicit = count_explicit + 1 + ELSEIF (wet2dry) THEN + count_wet2dry = count_wet2dry + 1 + ENDIF +#endif + + EXIT + + ENDIF + + dr_dv = 0 + vact = .false. + + IF (ubc_typ == BC_RAINFALL) THEN + + CALL var_perturb_rainfall ( & + blc(lb-1), ss_dp, dp_pb, dlt, vact(lb-1)) + + IF (vact(lb-1)) THEN + q_pb = q_this + q_wf_pb = q_wf + q_wt_pb = q_wt + + lev_update(:) = .false. + lev_update(lb-1) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .false., & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, dp_pb, zwt, psi, hk, & + q_pb, q_wf_pb, q_wt_pb, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_pb, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_wf, ss_vl, ss_wt, dp_pb, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc_pb) + + dr_dv(:,lb-1) = (blc_pb - blc) / dlt + + ENDIF + + ENDIF + + DO ilev = lb, ub + IF (.not. is_sat(ilev)) THEN + + wf_pb = ss_wf + vl_pb = ss_vl + wt_pb = ss_wt + psi_pb = psi + hk_pb = hk + + CALL var_perturb_level ( jsbl(ilev), blc(ilev), & + sp_dz(ilev), sp_zc(ilev), sp_zi(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), hksat(ilev), & + nprm, prms(:,ilev), & + is_sat(ilev), has_wf(ilev), has_wt(ilev), & + q_this(ilev-1), q_this(ilev), q_wf(ilev), q_wt(ilev), & + wf_pb(ilev), vl_pb(ilev), wt_pb(ilev), dlt, & + psi_pb(ilev), hk_pb(ilev), vact(ilev), & + tol_v) + + IF (vact(ilev)) THEN + + q_pb = q_this + q_wf_pb = q_wf + q_wt_pb = q_wt + + lev_update(:) = .false. + lev_update(ilev) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .false., & + is_sat, has_wf, has_wt, & + wf_pb, vl_pb, wt_pb, ss_dp, zwt, psi_pb, hk_pb, & + q_pb, q_wf_pb, q_wt_pb, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_pb, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + wf_pb, vl_pb, wt_pb, ss_dp, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc_pb) + + dr_dv(:,ilev) = (blc_pb - blc) / dlt + + ENDIF + ENDIF + ENDDO + + IF (lbc_typ == BC_DRAINAGE) THEN + + CALL var_perturb_drainage (sp_zi(ub), blc(ub+1), zwt, zwt_pb, dlt, vact(ub+1)) + + IF (vact(ub+1)) THEN + q_pb = q_this + q_wf_pb = q_wf + q_wt_pb = q_wt + + waquifer_pb = - (zwt_pb - sp_zi(ub)) * (vl_s_wa & + - soil_vliq_from_psi (psi_s(ub)+(sp_zi(ub)-zwt_pb)*0.5, & + vl_s_wa, vl_r(ub), psi_s(ub), nprm, prms(:,ub))) + + lev_update(:) = .false. + lev_update(ub+1) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .false., & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, ss_dp, zwt_pb, psi, hk, & + q_pb, q_wf_pb, q_wt_pb, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_pb, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_wf, ss_vl, ss_wt, ss_dp, waquifer_pb, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc_pb) + + dr_dv(:,ub+1) = (blc_pb - blc) / dlt + + ENDIF + + ENDIF + + DO ilev = lb-1, ub+1 + vact(ilev) = vact(ilev) .and. (abs(dr_dv(ilev,ilev)) > tol_q) + ENDDO + + CALL solve_least_squares_problem (ub-lb+3, dr_dv, vact, blc, dv) + + IF (vact(lb-1)) THEN + ss_dp = ss_dp - dv(lb-1) + ss_dp = max(ss_dp, 0._r8) + ENDIF + + DO ilev = lb, ub + IF (vact(ilev)) THEN + IF (jsbl(ilev) == 1) THEN + IF ((ss_wf(ilev) == sp_dz(ilev)) .and. (dv(ilev) > 0)) THEN + ss_wf(ilev) = ss_wf(ilev) - min(dv(ilev), sp_dz(ilev)) + + psi(ilev) = psi_s(ilev) + (1 - q_this(ilev)/hksat(ilev)) & + * min(dv(ilev),sp_dz(ilev)) * (sp_zc(ilev)-sp_zi(ilev-1))/sp_dz(ilev) + ss_vl(ilev) = soil_vliq_from_psi (psi(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), nprm, prms(:,ilev)) + hk(ilev) = soil_hk_from_psi (psi(ilev), & + psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + ss_wf(ilev) = ss_wf(ilev) - dv(ilev) + ss_wf(ilev) = max(ss_wf(ilev), 0._r8) + ss_wf(ilev) = min(ss_wf(ilev), sp_dz(ilev)-ss_wt(ilev)) + ENDIF + ENDIF + + IF (jsbl(ilev) == 2) THEN + ss_vl(ilev) = ss_vl(ilev) - dv(ilev) + ss_vl(ilev) = max(ss_vl(ilev), tol_v) + ss_vl(ilev) = min(ss_vl(ilev), vl_s(ilev)) + ENDIF + + IF (jsbl(ilev) == 3) THEN + IF ((ss_wt(ilev) == sp_dz(ilev)) .and. (dv(ilev) > 0)) THEN + ss_wt(ilev) = ss_wt(ilev) - min(dv(ilev), sp_dz(ilev)) + + psi(ilev) = psi_s(ilev) - (1 - q_this(ilev-1)/hksat(ilev)) & + * min(dv(ilev),sp_dz(ilev)) * (sp_zi(ilev)-sp_zc(ilev))/sp_dz(ilev) + ss_vl(ilev) = soil_vliq_from_psi (psi(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), nprm, prms(:,ilev)) + hk(ilev) = soil_hk_from_psi (psi(ilev), & + psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + ss_wt(ilev) = ss_wt(ilev) - dv(ilev) + ss_wt(ilev) = max(ss_wt(ilev), 0._r8) + ss_wt(ilev) = min(ss_wt(ilev), sp_dz(ilev)-ss_wf(ilev)) + ENDIF + ENDIF + ENDIF + + CALL check_and_update_level (sp_dz(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), hksat(ilev), & + nprm, prms(:,ilev), & + is_sat(ilev), has_wf(ilev), has_wt(ilev), & + ss_wf(ilev), ss_vl(ilev), ss_wt(ilev), psi(ilev), hk(ilev), & + jsbl(ilev) == 2, tol_v) + ENDDO + + IF (vact(ub+1)) THEN + zwt = zwt - dv(ub+1) + zwt = max(zwt, sp_zi(ub)) + waquifer = - (zwt - sp_zi(ub)) * (vl_s_wa & + - soil_vliq_from_psi (psi_s(ub)+(sp_zi(ub)-zwt)*0.5, & + vl_s_wa, vl_r(ub), psi_s(ub), nprm, prms(:,ub))) + ENDIF + + ENDDO + + ss_q = ss_q + q_this * dt_this + + wsum = sum(ss_vl * (sp_dz - ss_wt - ss_wf)) + sum((ss_wt + ss_wf) * vl_s) + IF (ubc_typ == BC_RAINFALL) THEN + wsum = wsum + ss_dp + ENDIF + IF (lbc_typ == BC_DRAINAGE) THEN + wsum = wsum + waquifer + ENDIF + + werr = wsum - (wsum_m1 + ubc_val * dt_this - lbc_val * dt_this) + + ENDDO + + ss_q = ss_q / dt + + DO ilev = lb, ub + IF (abs(sp_dz(ilev) - ss_wt(ilev)) > tol_z) THEN + ss_vl(ilev) = (ss_wf(ilev) * vl_s(ilev) & + + (sp_dz(ilev) - ss_wf(ilev) - ss_wt(ilev)) * ss_vl(ilev)) & + / (sp_dz(ilev) - ss_wt(ilev)) + ENDIF + ENDDO + + END SUBROUTINE Richards_solver + + + ! ---- water balance ---- + SUBROUTINE water_balance ( & + lb, ub, dz, dt, is_sat, vl_s, q, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + wf, vl, wt, dp, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc, is_solvable, tol) + + integer, intent(in) :: lb, ub + + real(r8), intent(in) :: dz(lb:ub) + real(r8), intent(in) :: dt + + logical, intent(in) :: is_sat(lb:ub) + real(r8), intent(in) :: vl_s (lb:ub) + + real(r8), intent(in) :: q(lb-1:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + real(r8), intent(in) :: wf(lb:ub) + real(r8), intent(in) :: vl(lb:ub) + real(r8), intent(in) :: wt(lb:ub) + real(r8), intent(in) :: dp + real(r8), intent(in) :: waquifer + + real(r8), intent(in) :: wf_m1(lb:ub) + real(r8), intent(in) :: vl_m1(lb:ub) + real(r8), intent(in) :: wt_m1(lb:ub) + real(r8), intent(in) :: dp_m1 + real(r8), intent(in) :: waquifer_m1 + + real(r8), intent(out) :: blc(lb-1:ub+1) + logical, intent(out), optional :: is_solvable + real(r8), intent(in ), optional :: tol + + ! Local variables + integer :: ilev, jlev + real(r8) :: dmss, qsum + + blc(:) = 0 + + IF (ubc_typ == BC_RAINFALL) THEN + dmss = max(dp, 0._r8) - max(dp_m1, 0._r8) + qsum = ubc_val - q(lb-1) + blc(lb-1) = dmss - qsum * dt + ENDIF + + ilev = lb - 1 + DO jlev = lb, ub + + dmss = (vl_s(jlev) - vl_m1(jlev)) * (wf(jlev) - wf_m1(jlev)) + dmss = (vl_s(jlev) - vl_m1(jlev)) * (wt(jlev) - wt_m1(jlev)) + dmss + dmss = (dz(jlev) - wt(jlev) - wf(jlev)) * (vl(jlev) - vl_m1(jlev)) + dmss + + qsum = q(jlev-1) - q(jlev) + + IF (.not. is_sat(jlev)) THEN + + ilev = jlev + + IF ((ubc_typ /= BC_RAINFALL) .and. (blc(lb-1) /= 0)) THEN + blc(ilev) = blc(ilev) + blc(lb-1) + blc(lb-1) = 0 + ENDIF + ENDIF + + blc(ilev) = blc(ilev) + dmss - qsum * dt + + ENDDO + + IF (lbc_typ == BC_DRAINAGE) THEN + IF ((waquifer == 0) .and. (q(ub) >= 0)) THEN + blc(ilev) = blc(ilev) - waquifer_m1 - q(ub) * dt + ELSE + blc(ub+1) = waquifer - waquifer_m1 - q(ub) * dt + + IF ((ubc_typ /= BC_RAINFALL) .and. (blc(lb-1) /= 0)) THEN + blc(ub+1) = blc(ub+1) + blc(lb-1) + blc(lb-1) = 0 + ENDIF + ENDIF + ENDIF + + IF (present(is_solvable)) THEN + IF (present(tol)) THEN + is_solvable = (ubc_typ == BC_RAINFALL) .or. (blc(lb-1) < tol) + ELSE + is_solvable = (ubc_typ == BC_RAINFALL) .or. (blc(lb-1) == 0) + ENDIF + ENDIF + + END SUBROUTINE water_balance + + ! ---- initialize sublevel structure ---- + SUBROUTINE initialize_sublevel_structure ( & + lb, ub, dz, zbtm, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, & + wf, vl, wt, dp, psi, hk, & + tol_v, tol_z) + + integer, intent(in) :: lb, ub + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: zbtm + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: vl_r (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,lb:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + logical, intent(inout) :: is_sat(lb:ub) + logical, intent(inout) :: has_wf(lb:ub) + logical, intent(inout) :: has_wt(lb:ub) + + real(r8), intent(inout) :: wf(lb:ub) + real(r8), intent(inout) :: vl(lb:ub) + real(r8), intent(inout) :: wt(lb:ub) + real(r8), intent(inout) :: dp + + real(r8), intent(inout) :: psi(lb:ub) + real(r8), intent(inout) :: hk (lb:ub) + + real(r8), intent(in) :: tol_v + real(r8), intent(in) :: tol_z + + ! Local variables + integer :: ilev + + DO ilev = lb, ub + is_sat(ilev) = (abs(vl(ilev) - vl_s(ilev)) < tol_v) & + .or. (abs(wf(ilev) + wt(ilev) - dz(ilev)) < tol_z) + ENDDO + + IF (ubc_typ == BC_FIX_HEAD) THEN + IF (ubc_val < psi_s(lb)) THEN + IF (is_sat(lb)) THEN + is_sat(lb) = .false. + + wf(lb) = 0 + vl(lb) = vl_s(lb) + wt(lb) = 0.9 * dz(lb) + ELSEIF (wf(lb) >= tol_z) THEN + vl(lb) = (wf(lb)*vl_s(lb) + vl(lb)*(dz(lb)-wf(lb)-wt(lb))) / (dz(lb)-wt(lb)) + wf(lb) = 0 + ENDIF + ENDIF + ENDIF + + IF (lbc_typ == BC_FIX_HEAD) THEN + IF (lbc_val < psi_s(ub)) THEN + IF (is_sat(ub)) THEN + is_sat(ub) = .false. + + wf(ub) = 0.9 * dz(ub) + vl(ub) = vl_s(ub) + wt(ub) = 0 + ELSEIF (wt(ub) >= tol_z) THEN + vl(ub) = (wt(ub)*vl_s(ub) + vl(ub)*(dz(ub)-wf(ub)-wt(ub))) / (dz(ub)-wf(ub)) + wt(ub) = 0 + ENDIF + ENDIF + ENDIF + + DO ilev = lb, ub + IF (is_sat(ilev)) THEN + wf(ilev) = 0 + wt(ilev) = dz(ilev) + vl(ilev) = vl_s(ilev) + ELSE + IF (ilev > lb) THEN + IF (is_sat(ilev-1)) THEN + has_wf(ilev) = .true. + ELSE + has_wf(ilev) = (wf(ilev) >= tol_z) .or. (wt(ilev-1) >= tol_z) + ENDIF + + IF (has_wf(ilev)) THEN + IF ((wf(ilev) < tol_z) .and. (psi_s(ilev) < psi_s(ilev-1))) THEN + wf(ilev) = 0.1 * (dz(ilev)-wt(ilev)) + ENDIF + ENDIF + ELSE + SELECTCASE (ubc_typ) + CASE (BC_RAINFALL) + has_wf(lb) = (dp >= tol_z) .or. (wf(lb) >= tol_z) + CASE (BC_FIX_HEAD) + has_wf(lb) = (ubc_val > psi_s(lb)) .or. (wf(lb) >= tol_z) + + IF (has_wf(lb) .and. (wf(lb) < tol_z)) THEN + wf(lb) = 0.01 * (dz(lb)-wt(lb)) + ENDIF + CASE (BC_FIX_FLUX) + has_wf(lb) = wf(lb) >= tol_z + ENDSELECT + ENDIF + + IF (ilev < ub) THEN + IF (is_sat(ilev+1)) THEN + has_wt(ilev) = .true. + ELSE + has_wt(ilev) = (wt(ilev) >= tol_z) .or. (wf(ilev+1) >= tol_z) + ENDIF + + IF (has_wt(ilev)) THEN + IF ((wt(ilev) < tol_z) .and. (psi_s(ilev) < psi_s(ilev+1))) THEN + wt(ilev) = 0.1 * (dz(ilev)-wf(ilev)) + ENDIF + ENDIF + ELSE + SELECTCASE (lbc_typ) + CASE (BC_DRAINAGE) + has_wt(ub) = (wt(ub) >= tol_z) + CASE (BC_FIX_HEAD) + has_wt(ub) = (lbc_val > psi_s(ub)) .or. (wt(ub) >= tol_z) + + IF ((has_wt(ub)) .and. (wt(ub) < tol_z)) THEN + wt(ub) = 0.01 * (dz(ub)-wf(ub)) + ENDIF + CASE (BC_FIX_FLUX) + has_wt(ub) = (wt(ub) >= tol_z) + ENDSELECT + ENDIF + ENDIF + + CALL check_and_update_level ( dz(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), hksat(ilev), & + nprm, prms(:,ilev), & + is_sat(ilev), has_wf(ilev), has_wt(ilev), & + wf(ilev), vl(ilev), wt(ilev), psi(ilev), hk(ilev), & + .true., tol_v) + ENDDO + + END SUBROUTINE initialize_sublevel_structure + + !----------------------------------------------------------------------- + SUBROUTINE use_explicit_form ( & + lb, ub, dt, dz, sp_zc, sp_zi, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + vl_s_wa, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + q, q_wf, q_wt, wf, vl, wt, dp, waquifer, zwt, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + tol_q, tol_z, tol_v) + + integer, intent(in) :: lb, ub + + real(r8), intent(in) :: dt + + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: sp_zc (lb:ub) + real(r8), intent(in) :: sp_zi(lb-1:ub) + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: vl_r (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm,lb:ub) + + real(r8), intent(in) :: vl_s_wa + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + real(r8), intent(inout) :: q (lb-1:ub) + real(r8), intent(in) :: q_wf (lb:ub) + real(r8), intent(in) :: q_wt (lb:ub) + + real(r8), intent(inout) :: wf (lb:ub) + real(r8), intent(inout) :: vl (lb:ub) + real(r8), intent(inout) :: wt (lb:ub) + real(r8), intent(inout) :: dp + real(r8), intent(inout) :: waquifer + real(r8), intent(inout) :: zwt + + real(r8), intent(in) :: wf_m1 (lb:ub) + real(r8), intent(in) :: vl_m1 (lb:ub) + real(r8), intent(in) :: wt_m1 (lb:ub) + real(r8), intent(in) :: dp_m1 + real(r8), intent(in) :: waquifer_m1 + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_v + + ! Local variables + integer :: ilev + real(r8) :: air_m1, wa_m1, dwat, dwat_s + real(r8) :: alp, zwf_this, zwt_this, vl_wa + + real(r8) :: dmss, mblc + + ! depleted : decrease outflux from top down + IF (ubc_typ == BC_RAINFALL) THEN + IF (dp_m1 < - (ubc_val - q(lb-1))*dt) THEN + q(lb-1) = dp_m1/dt + ubc_val + ENDIF + ENDIF + + DO ilev = lb, ub + + dwat = (q(ilev-1) - q(ilev)) * dt + wa_m1 = (wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) + IF (dwat <= - wa_m1) THEN + q(ilev) = q(ilev-1) + wa_m1/dt + ENDIF + + ENDDO + + IF ((lbc_typ == BC_FIX_FLUX) .and. (q(ub) < lbc_val)) THEN + + q(ub) = lbc_val + DO ilev = ub, lb, -1 + dwat = (q(ilev-1) - q(ilev)) * dt + wa_m1 = (wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) + IF (dwat <= - wa_m1) THEN + q(ilev-1) = q(ilev) - wa_m1/dt + ENDIF + ENDDO + + ENDIF + + ! overfilled : increase influx from bottom up + IF (lbc_typ == BC_DRAINAGE) THEN + IF (q(ub)*dt > -waquifer_m1) THEN + q(ub) = - waquifer_m1/dt + ENDIF + ENDIF + + DO ilev = ub, lb, -1 + + dwat = (q(ilev-1) - q(ilev)) * dt + air_m1 = (vl_s(ilev) - vl_m1(ilev)) * (dz(ilev) - wt_m1(ilev) - wf_m1(ilev)) + IF (dwat >= air_m1) THEN + q(ilev-1) = q(ilev) + air_m1/dt + ENDIF + + ENDDO + + IF ((ubc_typ == BC_FIX_FLUX) .and. (q(lb-1) < ubc_val)) THEN + + q(lb-1) = ubc_val + DO ilev = lb, ub + dwat = (q(ilev-1) - q(ilev)) * dt + air_m1 = (vl_s(ilev) - vl_m1(ilev)) * (dz(ilev) - wt_m1(ilev) - wf_m1(ilev)) + IF (dwat >= air_m1) THEN + q(ilev) = q(ilev-1) - air_m1/dt + ENDIF + ENDDO + + ENDIF + + ! update prognostic variables : dp, wf, vl, wt, zwt + IF (ubc_typ == BC_RAINFALL) THEN + dp = max(0., dp_m1 + (ubc_val - q(lb-1))*dt) + ENDIF + + DO ilev = lb, ub + + dwat = (q(ilev-1) - q(ilev)) * dt + + wt(ilev) = 0. + wf(ilev) = 0. + vl(ilev) = ((wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) + dwat) / dz(ilev) + + ENDDO + + IF (lbc_typ == BC_DRAINAGE) THEN + waquifer = waquifer_m1 + q(ub)*dt + CALL get_zwt_from_wa ( & + vl_s_wa, vl_r(ub), psi_s(ub), hksat(ub), nprm, prms(:,ub), tol_v, tol_z, & + waquifer, sp_zi(ub), zwt) + ENDIF + + END SUBROUTINE use_explicit_form + + !---------------------------------------------------------------------- + SUBROUTINE var_perturb_level ( jsbl, blc, & + dz, zc, zi, vl_s, vl_r, psi_s, hksat, nprm, prms, & + is_sat, has_wf, has_wt, qin, qout, q_wf, q_wt, & + wf_p, vl_p, wt_p, delta, psi_p, hk_p, is_act, & + tol_v) + + integer, intent(out) :: jsbl + + real(r8), intent(in) :: blc + + real(r8), intent(in) :: dz, zc, zi + real(r8), intent(in) :: vl_s, vl_r, psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + logical, intent(in) :: is_sat, has_wf, has_wt + real(r8), intent(in) :: qin, qout, q_wf, q_wt + + real(r8), intent(inout) :: wf_p, vl_p, wt_p + real(r8), intent(out) :: delta + real(r8), intent(inout) :: psi_p, hk_p + logical, intent(out) :: is_act + + real(r8), intent(in) :: tol_v + + ! Local variables + real(r8), parameter :: vstep = 1.0e-6_r8 + real(r8), parameter :: wstep = 1.0e-1_r8 + + jsbl = 2 + + IF (has_wt) THEN + + IF ((wt_p == dz) .or. & + ((blc >= 0) .and. (q_wt < qout) .and. (wt_p > 0) .and. (vl_p < vl_s))) THEN + ! reduce water table + + jsbl = 3 + + delta = - min(wstep, wt_p * 0.1_r8) + + IF (wt_p == dz) THEN + psi_p = psi_s - (1 - qin/hksat) * (-delta)*(zi-zc)/dz + vl_p = soil_vliq_from_psi (psi_p, vl_s, vl_r, psi_s, nprm, prms) + hk_p = soil_hk_from_psi (psi_p, psi_s, hksat, nprm, prms) + ENDIF + + wt_p = wt_p + delta + + ELSEIF ((blc < 0) .and. (q_wt > qout) .and. (vl_p < vl_s)) THEN + ! increase water table + + jsbl = 3 + + delta = min(wstep, (dz - wf_p - wt_p) * 0.1_r8) + wt_p = wt_p + delta + + ENDIF + + ENDIF + + IF ((jsbl == 2) .and. has_wf) THEN + + IF ((wf_p == dz) .or. & + ((blc >= 0) .and. (qin < q_wf) .and. (wf_p > 0) .and. (vl_p < vl_s))) THEN + ! reduce wetting front + + jsbl = 1 + + delta = - min(wstep, wf_p * 0.1_r8) + IF (wf_p == dz) THEN + psi_p = psi_s + (1 - qout/hksat) * (-delta)*(dz-(zi-zc))/dz + vl_p = soil_vliq_from_psi (psi_p, vl_s, vl_r, psi_s, nprm, prms) + hk_p = soil_hk_from_psi (psi_p, psi_s, hksat, nprm, prms) + ENDIF + + wf_p = wf_p + delta + + ELSEIF ((blc < 0) .and. (qin > q_wf) .and. (vl_p < vl_s)) THEN + ! increase wetting front + + jsbl = 1 + + delta = min(wstep, (dz - wf_p - wt_p) * 0.1_r8) + wf_p = wf_p + delta + + ENDIF + + ENDIF + + IF (jsbl == 2) THEN + + IF (((blc > 0) .and. (vl_p > vl_r + tol_v)) .or. (vl_p >= vl_s)) THEN + ! reduce water content + delta = - min(vstep, (vl_p - vl_r - tol_v) * 0.5_r8) + ELSEIF (((blc <= 0) .and. (vl_p < vl_s)) .or. (vl_p <= vl_r+tol_v)) THEN + ! increase water content + delta = + min(vstep, (vl_s - vl_p) * 0.5_r8) + ELSE + delta = 0 + ENDIF + + vl_p = vl_p + delta + + ENDIF + + is_act = (delta /= 0) + + IF (is_act) THEN + CALL check_and_update_level (dz, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + is_sat, has_wf, has_wt, wf_p, vl_p, wt_p, psi_p, hk_p, & + jsbl == 2, tol_v) + ENDIF + + END SUBROUTINE var_perturb_level + + !---------------------------------------------------------------- + SUBROUTINE var_perturb_rainfall ( & + blc_srf, dp, dp_p, delta, is_act) + + real(r8), intent(in) :: blc_srf + + real(r8), intent(in) :: dp + real(r8), intent(out) :: dp_p + real(r8), intent(out) :: delta + logical, intent(out) :: is_act + + ! Local variables + real(r8), parameter :: wstep = 1.0e-1_r8 + + delta = 0 + + IF (blc_srf > 0) THEN + IF (dp > 0) THEN + delta = - min(wstep, dp * 0.5_r8) + ENDIF + ELSEIF (blc_srf < 0) THEN + delta = wstep + ENDIF + + dp_p = dp + delta + is_act = (delta /= 0) + + END SUBROUTINE var_perturb_rainfall + + !---------------------------------------------------------------- + SUBROUTINE var_perturb_drainage ( & + zmin, blc_btm, zwt, zwt_p, delta, is_act) + + real(r8), intent(in) :: zmin + + real(r8), intent(in) :: blc_btm + + real(r8), intent(in) :: zwt + real(r8), intent(out) :: zwt_p + real(r8), intent(out) :: delta + logical, intent(out) :: is_act + + ! Local variables + real(r8), parameter :: wstep = 1.0e-1_r8 + + delta = 0 + + IF (blc_btm > 0) THEN + delta = wstep + ELSEIF (blc_btm < 0) THEN + delta = - min(max((zwt-zmin)*0.5_r8,0.0), wstep) + ENDIF + + zwt_p = zwt + delta + is_act = (delta /= 0) + + END SUBROUTINE var_perturb_drainage + + + !---------------------------------------------------------------- + SUBROUTINE check_and_update_level ( dz, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + is_sat, has_wf, has_wt, & + wf, vl, wt, psi, hk, & + is_update_psi_hk, tol_v) + + real(r8), intent(in) :: dz + real(r8), intent(in) :: vl_s, vl_r, psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + logical, intent(in) :: is_sat, has_wf, has_wt + + real(r8), intent(inout) :: wf, vl, wt + real(r8), intent(inout) :: psi, hk + + logical, intent(in) :: is_update_psi_hk + + real(r8), intent(in) :: tol_v + + ! Local variables + real(r8) :: alpha + + IF (.not. is_sat) THEN + + IF (has_wf) THEN + wf = min(max(wf, 0._r8), dz) + ELSE + wf = 0 + ENDIF + + IF (has_wt) THEN + wt = min(max(wt, 0._r8), dz) + ELSE + wt = 0 + ENDIF + + IF (has_wf .and. has_wt) THEN + IF (wf + wt > dz) THEN + alpha = wf / (wf + wt) + wf = dz * alpha + wt = dz * (1.0_r8 - alpha) + ENDIF + ENDIF + + vl = min(vl, vl_s) + vl = max(vl, tol_v) + + IF (is_update_psi_hk) THEN + psi = soil_psi_from_vliq (vl, vl_s, vl_r, psi_s, nprm, prms) + hk = soil_hk_from_psi (psi, psi_s, hksat, nprm, prms) + ENDIF + ELSE + vl = vl_s + psi = psi_s + hk = hksat + ENDIF + + END SUBROUTINE check_and_update_level + + + !---------------------------------------------------------------------- + SUBROUTINE flux_all ( & + lb, ub, dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, is_update_sublevel, & + is_sat, has_wf, has_wt, & + wf, vl, wt, dp, zwt, psi_us, hk_us, & + qq, qq_wf, qq_wt, & + tol_q, tol_z, tol_p) + + integer, intent(in) :: lb, ub + + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: sp_zc (lb:ub) + real(r8), intent(in) :: sp_zi (lb-1:ub) + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,lb:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + logical, intent(in) :: lev_update (lb-1:ub+1) + logical, intent(in) :: is_update_sublevel + + logical, intent(inout) :: is_sat (lb:ub) + logical, intent(inout) :: has_wf (lb:ub) + logical, intent(inout) :: has_wt (lb:ub) + + real(r8), intent(inout) :: wf (lb:ub) + real(r8), intent(inout) :: vl (lb:ub) + real(r8), intent(inout) :: wt (lb:ub) + real(r8), intent(inout) :: dp + real(r8), intent(inout) :: zwt + real(r8), intent(in) :: psi_us (lb:ub) + real(r8), intent(in) :: hk_us (lb:ub) + + real(r8), intent(inout) :: qq (lb-1:ub) + real(r8), intent(inout) :: qq_wf (lb:ub) + real(r8), intent(inout) :: qq_wt (lb:ub) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + ! Local variables + integer :: ilev_u, ilev_l + real(r8) :: hk_top, pbtm, hk_btm + real(r8) :: dz_this, dz_upp, dz_low + logical :: has_sat_zone + real(r8) :: psi_i, hk_i + real(r8) :: qtest + + + ilev_u = lb - 1 + ilev_l = find_unsat_lev_lower (is_sat, lb, ub, ilev_u+1) + + DO WHILE (.true.) + + IF (lev_update(ilev_u) .or. lev_update(ilev_l)) THEN + + IF (ilev_l == lb) THEN + ! CASE 1: water flux on top + + dz_this = (dz(lb)-wt(lb)-wf(lb)) * (sp_zc(lb)-sp_zi(lb-1))/dz(lb) + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + + IF (has_wf(lb)) THEN + qq(lb-1) = - hksat(lb) * ((psi_s(lb) - ubc_val) / wf(lb) - 1) + ELSE + hk_top = soil_hk_from_psi (ubc_val, & + psi_s(lb), hksat(lb), nprm, prms(:,lb)) + qq(lb-1) = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, ubc_val, psi_us(lb), hk_top, hk_us(lb)) + ENDIF + + CASE (BC_RAINFALL) + + IF (has_wf(lb) .and. (wf(lb) >= tol_z)) THEN + + qq(lb-1) = - hksat(lb) * ((psi_s(lb) - dp) / wf(lb) - 1) + + ELSE + + IF (dp > tol_z) THEN + qq(lb-1) = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, dp, psi_us(lb), hksat(lb), hk_us(lb)) + ELSE + qtest = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, psi_s(lb), psi_us(lb), hksat(lb), hk_us(lb)) + + qq(lb-1) = min(ubc_val, qtest) + + IF (is_update_sublevel) THEN + IF (qq(lb-1) > qtest) THEN + has_wf(lb) = .true. + wf(lb) = 0.0 + ENDIF + ENDIF + ENDIF + + ENDIF + + CASE (BC_FIX_FLUX) + + qq(lb-1) = ubc_val + + IF (is_update_sublevel) THEN + IF ((.not. has_wf(lb)) .and. (ubc_val > hksat(lb))) THEN + qtest = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, psi_s(lb), psi_us(lb), hksat(lb), hk_us(lb)) + IF (qq(lb-1) > qtest) THEN + has_wf(lb) = .true. + wf(lb) = 0.0 + ENDIF + ENDIF + ENDIF + + ENDSELECT + + IF ((has_wf(lb)) .and. (dz_this >= tol_z)) THEN + qq_wf(lb) = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, psi_s(lb), psi_us(lb), hksat(lb), hk_us(lb)) + ELSE + IF (has_wf(lb)) THEN + qq_wf(lb) = qq(lb) + ELSE + qq_wf(lb) = qq(lb-1) + ENDIF + ENDIF + + ELSEIF (ilev_u == ub) THEN + ! CASE 2: water flux at bottom + + dz_this = (dz(ub) - wf(ub) - wt(ub)) * (sp_zi(ub) - sp_zc(ub))/ dz(ub) + + SELECTCASE (lbc_typ) + CASE (BC_FIX_HEAD) + + IF (has_wt(ub)) THEN + qq(ub) = - hksat(ub) * ((lbc_val - psi_s(ub))/wt(ub) - 1) + ELSE + hk_btm = soil_hk_from_psi (lbc_val, & + psi_s(ub), hksat(ub), nprm, prms(:,ub)) + qq(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), lbc_val, hk_us(ub), hk_btm) + ENDIF + + CASE (BC_DRAINAGE) + + IF (has_wt(ub)) THEN + IF (zwt > sp_zi(ub)) THEN + qq(ub) = hksat(ub) + ELSE + qq(ub) = 0 + ENDIF + ELSE + IF (zwt > sp_zi(ub)) THEN + pbtm = psi_s(ub) + sp_zi(ub) - zwt + hk_btm = soil_hk_from_psi (pbtm, & + psi_s(ub), hksat(ub), nprm, prms(:,ub)) + qq(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), pbtm, hk_us(ub), hk_btm) + ELSE + qq(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), psi_s(ub), hk_us(ub), hksat(ub)) + + IF (is_update_sublevel) THEN + IF (qq(ub) > 0) THEN + has_wt(ub) = .true. + wt(ub) = 0 + qq(ub) = 0 + ENDIF + ENDIF + ENDIF + ENDIF + + CASE (BC_FIX_FLUX) + + qq(ub) = lbc_val + + IF (is_update_sublevel) THEN + IF ((.not. has_wt(ub)) .and. (lbc_val < hksat(ub))) THEN + qtest = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), psi_s(ub), hk_us(ub), hksat(ub)) + + IF (qtest > lbc_val) THEN + has_wt(ub) = .true. + wt(ub) = 0 + ENDIF + ENDIF + ENDIF + + ENDSELECT + + IF ((has_wt(ub)) .and. (dz_this >= tol_z)) THEN + qq_wt(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), psi_s(ub), hk_us(ub), hksat(ub)) + ELSE + IF (has_wt(ub)) THEN + qq_wt(ub) = qq(ub-1) + ELSE + qq_wt(ub) = qq(ub) + ENDIF + ENDIF + + ELSE + ! CASE 3: inside soil column + + IF ((ilev_u == lb-1) .or. (ilev_l == ub+1)) THEN + has_sat_zone = .true. + ELSEIF (has_wf(ilev_l)) THEN + has_sat_zone = .true. + IF (ilev_l == ilev_u+1) THEN + IF ((wf(ilev_l) < tol_z) .and. (wt(ilev_u) < tol_z)) THEN + has_sat_zone = .false. + ENDIF + ENDIF + ELSE + has_sat_zone = .false. + ENDIF + + IF (has_sat_zone) THEN + ! CASE 3(1): inside soil column, saturated zone + CALL flux_sat_zone_all ( & + lb, ub, max(ilev_u,lb), min(ilev_l,ub), & + dz, sp_zc, sp_zi, vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, is_update_sublevel, & + wf, vl, wt, dp, zwt, psi_us, hk_us, & + qq, qq_wt, qq_wf, tol_q, tol_z, tol_p) + + ELSE + ! CASE 3(2): inside soil column, unsaturated zone + + dz_upp = (dz(ilev_u) - wf(ilev_u)) * (sp_zi(ilev_u)-sp_zc(ilev_u))/dz(ilev_u) + dz_low = (dz(ilev_l) - wt(ilev_l)) * (sp_zc(ilev_l)-sp_zi(ilev_u))/dz(ilev_l) + + IF ((dz_upp >= tol_z) .and. (dz_low >= tol_z)) THEN + + CALL flux_at_unsaturated_interface (nprm, & + psi_s(ilev_u), hksat(ilev_u), prms(:,ilev_u), dz_upp, psi_us(ilev_u), hk_us(ilev_u), & + psi_s(ilev_l), hksat(ilev_l), prms(:,ilev_l), dz_low, psi_us(ilev_l), hk_us(ilev_l), & + qq_wt(ilev_u), qq_wf(ilev_l), tol_q, tol_p) + + IF (abs(qq_wt(ilev_u) - qq_wf(ilev_l)) < tol_q) THEN + + qq(ilev_u) = (qq_wt(ilev_u) + qq_wf(ilev_l)) * 0.5_r8 + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + + IF (is_update_sublevel) THEN + has_wt(ilev_u) = .false. + has_wf(ilev_l) = .false. + ENDIF + + ELSEIF (qq_wt(ilev_u) > qq_wf(ilev_l)) THEN + IF (is_update_sublevel) THEN + has_wt(ilev_u) = .true. + wt(ilev_u) = 0 + + has_wf(ilev_l) = .true. + wf(ilev_l) = 0 + ENDIF + + IF (has_wt(ilev_u) .and. has_wf(ilev_l)) THEN + IF (psi_s(ilev_u) >= psi_s(ilev_l)) THEN + qq(ilev_u) = qq_wt(ilev_u) + ELSE + qq(ilev_u) = qq_wf(ilev_l) + ENDIF + ELSE + qq(ilev_u) = (qq_wt(ilev_u) + qq_wf(ilev_l)) * 0.5_r8 + ENDIF + ENDIF + + ELSEIF ((dz_upp >= tol_z) .and. (dz_low < tol_z)) THEN + + psi_i = min(psi_s(ilev_u), psi_s(ilev_l)) + hk_i = soil_hk_from_psi (psi_i, & + psi_s(ilev_u), hksat(ilev_u), nprm, prms(:,ilev_u)) + qq(ilev_u) = flux_inside_hm_soil ( & + psi_s(ilev_u), hksat(ilev_u), nprm, prms(:,ilev_u), & + dz_upp, psi_us(ilev_u), psi_i, hk_us(ilev_u), hk_i) + + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + qq_wt(ilev_l) = qq(ilev_u) + + ELSEIF ((dz_upp < tol_z) .and. (dz_low >= tol_z)) THEN + + psi_i = min(psi_s(ilev_u), psi_s(ilev_l)) + hk_i = soil_hk_from_psi (psi_i, & + psi_s(ilev_l), hksat(ilev_l), nprm, prms(:,ilev_l)) + qq(ilev_u) = flux_inside_hm_soil ( & + psi_s(ilev_l), hksat(ilev_l), nprm, prms(:,ilev_l), & + dz_low, psi_i, psi_us(ilev_l), hk_i, hk_us(ilev_l)) + + qq_wf(ilev_u) = qq(ilev_u) + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + + ELSEIF ((dz_upp < tol_z) .and. (dz_low < tol_z)) THEN + ! This CASE does not exist in principle. + + qq(ilev_u) = min(hksat(ilev_u), hksat(ilev_l)) + + qq_wf(ilev_u) = qq(ilev_u) + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + qq_wt(ilev_l) = qq(ilev_u) + + ENDIF + ENDIF + + ENDIF + ENDIF + + IF (ilev_l == ub+1) THEN + EXIT + ELSE + ilev_u = ilev_l + ilev_l = find_unsat_lev_lower (is_sat, lb, ub, ilev_u+1) + ENDIF + ENDDO + + END SUBROUTINE flux_all + + + !------------------------------------------------------------------- + SUBROUTINE flux_sat_zone_all ( & + lb, ub, i_stt, i_end, dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, is_update_sublevel, & + wf, vl, wt, wdsrf, zwt, psi_us, hk_us, & + qq, qq_wt, qq_wf, tol_q, tol_z, tol_p) + + integer, intent(in) :: lb, ub + integer, intent(in) :: i_stt, i_end + + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: sp_zc (lb:ub) + real(r8), intent(in) :: sp_zi (lb-1:ub) + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,lb:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + logical, intent(inout) :: is_sat (lb:ub) + logical, intent(inout) :: has_wf (lb:ub) + logical, intent(inout) :: has_wt (lb:ub) + logical, intent(in) :: is_update_sublevel + + real(r8), intent(inout) :: wf (lb:ub) + real(r8), intent(inout) :: vl (lb:ub) + real(r8), intent(inout) :: wt (lb:ub) + real(r8), intent(in) :: wdsrf + real(r8), intent(in) :: zwt + real(r8), intent(in) :: psi_us (lb:ub) + real(r8), intent(in) :: hk_us (lb:ub) + + real(r8), intent(inout) :: qq (lb-1:ub) + real(r8), intent(inout) :: qq_wt (lb:ub) + real(r8), intent(inout) :: qq_wf (lb:ub) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + ! Local variables + logical :: top_at_ground, top_at_interface, top_inside_level + logical :: btm_at_bottom, btm_at_interface, btm_inside_level + + integer :: i_s, i_e, ilev, iface + + integer :: nlev_sat + real(r8), allocatable :: qlc (:) + real(r8), allocatable :: dz_sat (:) + real(r8), allocatable :: psi_sat (:) + real(r8), allocatable :: hk_sat (:) + + real(r8) :: ptop, pbtm, qtop, qupper, qlower + real(r8) :: dz_us_top, dz_us_btm + + logical :: is_trans + + top_at_ground = (i_stt == lb) .and. is_sat(i_stt) + top_at_interface = (.not. top_at_ground) .and. (wt(i_stt) < tol_z) + top_inside_level = .not. (top_at_ground .or. top_at_interface) + + btm_at_bottom = (i_end == ub) .and. is_sat(i_end) + btm_at_interface = (.not. btm_at_bottom) .and. (wf(i_end) < tol_z) + btm_inside_level = .not. (btm_at_bottom .or. btm_at_interface) + + IF (top_at_interface) THEN + i_s = i_stt + 1 + ELSE + i_s = i_stt + ENDIF + + IF (btm_at_interface) THEN + i_e = i_end - 1 + ELSE + i_e = i_end + ENDIF + + nlev_sat = i_e - i_s + 1 + + allocate (dz_sat (i_s:i_e)) + allocate (psi_sat (i_s:i_e)) + allocate (hk_sat (i_s:i_e)) + allocate (qlc (i_s:i_e)) + + DO ilev = i_s, i_e + dz_sat (ilev) = dz (ilev) + psi_sat(ilev) = psi_s(ilev) + hk_sat (ilev) = hksat(ilev) + ENDDO + + IF (top_inside_level) dz_sat(i_s) = wt(i_stt) + IF (btm_inside_level) dz_sat(i_e) = wf(i_end) + + IF (.not. top_at_ground) THEN + dz_us_top = (dz(i_stt) - wt(i_stt) - wf(i_stt)) & + * (sp_zi(i_stt) - sp_zc(i_stt)) / dz(i_stt) + ENDIF + + IF (.not. btm_at_bottom) THEN + dz_us_btm = (dz(i_end) - wt(i_end) - wf(i_end)) & + * (sp_zc(i_end) - sp_zi(i_end-1)) / dz(i_end) + ENDIF + + ! Case 1 + IF (top_at_ground .and. btm_at_bottom) THEN + + ! Case 1-1 + IF ((ubc_typ == BC_FIX_HEAD) .and. (lbc_typ == BC_FIX_HEAD)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, lbc_val, qlc) + ENDIF + + ! Case 1-2 + IF ((ubc_typ == BC_RAINFALL) .and. (lbc_typ == BC_FIX_HEAD)) THEN + + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, lbc_val, qlc) + + ENDIF + + ! Case 1-3 + IF ((ubc_typ == BC_FIX_FLUX) .and. (lbc_typ == BC_FIX_HEAD)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), lbc_val, qlc, & + flux_top = ubc_val) + ENDIF + + ! Case 1-4 + IF ((ubc_typ == BC_FIX_HEAD) .and. (lbc_typ == BC_FIX_FLUX)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, psi_s(ub), qlc, & + flux_btm = lbc_val) + ENDIF + + ! Case 1-5 + IF ((ubc_typ == BC_RAINFALL) .and. (lbc_typ == BC_FIX_FLUX)) THEN + + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, psi_s(ub), qlc, & + flux_btm = lbc_val) + + ENDIF + + ! Case 1-6 + IF ((ubc_typ == BC_FIX_FLUX) .and. (lbc_typ == BC_FIX_FLUX)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), psi_s(ub), qlc, & + flux_top = ubc_val, flux_btm = lbc_val) + ENDIF + + ! Case 1-7 + IF ((ubc_typ == BC_FIX_HEAD) .and. (lbc_typ == BC_DRAINAGE)) THEN + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, psi_s(ub), qlc) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, psi_s(ub), qlc, & + flux_btm = 0.0) + ENDIF + ENDIF + + ! Case 1-8 + IF ((ubc_typ == BC_RAINFALL) .and. (lbc_typ == BC_DRAINAGE)) THEN + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, psi_s(ub), qlc) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, psi_s(ub), qlc, & + flux_btm = 0.0) + ENDIF + + ENDIF + + ! Case 1-9 + IF ((ubc_typ == BC_FIX_FLUX) .and. (lbc_typ == BC_DRAINAGE)) THEN + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), psi_s(ub), qlc, & + flux_top = ubc_val) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), psi_s(ub), qlc, & + flux_top = ubc_val, flux_btm = 0.0) + ENDIF + ENDIF + ENDIF + + ! Case 2 + IF (top_at_ground .and. btm_at_interface) THEN + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, ubc_val, & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p) + + CASE (BC_FIX_FLUX) + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(lb), & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p, & + flux_top = ubc_val) + + CASE (BC_RAINFALL) + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, wdsrf, & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p) + + ENDSELECT + + ENDIF + + ! Case 3 + IF (top_at_ground .and. btm_inside_level) THEN + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, ubc_val, psi_s(i_end), qlc) + + CASE (BC_FIX_FLUX) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, psi_s(lb), psi_s(i_end), qlc, & + flux_top = ubc_val) + + CASE (BC_RAINFALL) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, wdsrf, psi_s(i_end), qlc) + + ENDSELECT + + ENDIF + + ! Case 4 + IF (top_at_interface .and. btm_at_bottom) THEN + + SELECTCASE (lbc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, lbc_val, & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p) + + CASE (BC_FIX_FLUX) + + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(ub), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p, & + flux_btm = lbc_val) + + CASE (BC_DRAINAGE) + + IF (zwt > sp_zi(ub)) THEN + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(ub), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p) + ELSE + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(ub), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p, & + flux_btm = 0.0) + ENDIF + + ENDSELECT + + ENDIF + + ! Case 5 + IF (top_at_interface .and. btm_at_interface) THEN + + CALL flux_both_transitive_interface ( & + i_stt, i_end, dz(i_stt:i_end), & + psi_s(i_stt:i_end), hksat(i_stt:i_end), nprm, prms(:,i_stt:i_end), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + qq_wt(i_stt), qq_wf(i_end), qlc, & + tol_q, tol_z, tol_p) + + ENDIF + + ! Case 6 + IF (top_at_interface .and. btm_inside_level) THEN + + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(i_end), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p) + + ENDIF + + ! Case 7 + IF (top_inside_level .and. btm_at_bottom) THEN + + SELECTCASE (lbc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, psi_s(i_stt), lbc_val, qlc) + + CASE (BC_FIX_FLUX) + + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(i_stt), psi_s(ub), & + qlc, flux_btm = lbc_val) + + CASE (BC_DRAINAGE) + + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, psi_s(i_stt), psi_s(ub), qlc) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(i_stt), psi_s(ub), & + qlc, flux_btm = 0.0) + ENDIF + + ENDSELECT + + ENDIF + + ! Case 8 + IF (top_inside_level .and. btm_at_interface) THEN + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(i_stt), & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p) + + ENDIF + + ! Case 9 + IF (top_inside_level .and. btm_inside_level) THEN + + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_s(i_stt), psi_s(i_end), qlc) + + ENDIF + + IF (top_inside_level) THEN + IF (dz_us_top < tol_z) THEN + qq_wt(i_stt) = qq(i_stt-1) + ELSE + qq_wt(i_stt) = flux_inside_hm_soil ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), psi_s(i_stt), hk_us(i_stt), hksat(i_stt)) + ENDIF + ENDIF + + IF (top_at_interface) THEN + IF (dz_us_top < tol_z) THEN + qq_wf(i_stt) = qq_wt(i_stt) + ENDIF + ENDIF + + IF (top_at_ground) THEN + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + qq(lb-1) = qlc(lb) + is_trans = .false. + CASE (BC_FIX_FLUX) + qq(lb-1) = ubc_val ! min(qlc(lb), ubc_val) + is_trans = (qlc(lb) > ubc_val) + CASE (BC_RAINFALL) + IF (wdsrf < tol_z) THEN + qq(lb-1) = min(ubc_val, qlc(lb)) + is_trans = (qlc(lb) > ubc_val) + ELSE + qq(lb-1) = qlc(lb) + is_trans = .false. + ENDIF + ENDSELECT + + IF (is_update_sublevel) THEN + IF (is_trans .and. is_sat(lb)) THEN + is_sat(lb) = .false. + has_wf(lb) = .false. + has_wt(lb) = .true. + + wt(lb) = 0.9*dz(lb) + vl(lb) = vl_s(lb) + wf(lb) = 0 + + qq_wt(lb) = qq(lb-1) + ENDIF + ENDIF + ENDIF + + DO iface = i_stt, i_end-1 + IF (top_at_interface .and. (iface == i_stt)) THEN + qupper = qq_wt(i_stt) + ELSE + qupper = qlc(iface) + ENDIF + + IF (btm_at_interface .and. (iface == i_end-1)) THEN + qlower = qq_wf(i_end) + ELSE + qlower = qlc(iface+1) + ENDIF + + IF (qlower - qupper >= tol_q) THEN + IF ((psi_s(iface) < psi_s(iface+1)) & + .or. & + ((psi_s(iface) == psi_s(iface+1)) .and. (is_sat(iface+1))) & + .or. & + (top_at_interface .and. (iface == i_stt))) THEN + + qq(iface) = qupper + + IF (is_update_sublevel .and. is_sat(iface+1)) THEN + is_sat(iface+1) = .false. + has_wf(iface+1) = .false. + has_wt(iface+1) = .true. + + wt(iface+1) = dz(iface+1) + vl(iface+1) = vl_s(iface+1) + wf(iface+1) = 0 + + qq_wf(iface+1) = qq(iface) + qq_wt(iface+1) = qq(iface) + + IF (top_at_interface .and. (iface == i_stt)) THEN + has_wt(iface) = .false. + ENDIF + ENDIF + + ELSEIF ((psi_s(iface) > psi_s(iface+1)) & + .or. & + ((psi_s(iface) == psi_s(iface+1)) .and. (.not. is_sat(iface+1))) & + .or. & + (btm_at_interface .and. (iface == i_end-1))) THEN + + qq(iface) = qlower + + IF (is_update_sublevel .and. is_sat(iface)) THEN + is_sat(iface) = .false. + has_wt(iface) = .false. + has_wf(iface) = .true. + + wf(iface) = dz(iface) + vl(iface) = vl_s(iface) + wt(iface) = 0 + + qq_wf(iface) = qq(iface) + qq_wt(iface) = qq(iface) + + IF (btm_at_interface .and. (iface == i_end-1)) THEN + has_wf(iface+1) = .false. + ENDIF + ENDIF + ENDIF + ELSEIF (qupper - qlower >= tol_q) THEN + IF (top_at_interface .and. (iface == i_stt)) THEN + qq(iface) = qlower + ENDIF + + IF (btm_at_interface .and. (iface == i_end-1)) THEN + qq(iface) = qupper + ENDIF + ELSE + qq(iface) = (qupper + qlower) * 0.5_r8 + ENDIF + ENDDO + + IF (btm_at_bottom) THEN + qq(ub) = qlc(ub) + ENDIF + + IF (btm_at_interface) THEN + IF (dz_us_btm < tol_z) THEN + qq_wt(i_end) = qq_wf(i_end) + ENDIF + ENDIF + + IF (btm_inside_level) THEN + IF (dz_us_btm < tol_z) THEN + qq_wf(i_end) = qq(i_end) + ELSE + qq_wf(i_end) = flux_inside_hm_soil ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_s(i_end), psi_us(i_end), hksat(i_end), hk_us(i_end)) + ENDIF + ENDIF + + deallocate (qlc ) + deallocate (dz_sat ) + deallocate (psi_sat) + deallocate (hk_sat ) + + END SUBROUTINE flux_sat_zone_all + + !-------------------------------------------------------------------------- + SUBROUTINE flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_btm, qlc, flux_top, flux_btm) + + IMPLICIT NONE + + integer, intent(in) :: nlev_sat + + real(r8), intent(in) :: dz_sat (nlev_sat) + real(r8), intent(in) :: psi_sat (nlev_sat) + real(r8), intent(in) :: hk_sat (nlev_sat) + + real(r8), intent(in) :: psi_top + real(r8), intent(in) :: psi_btm + + real(r8), intent(inout) :: qlc (nlev_sat) + + real(r8), intent(in), optional :: flux_top + real(r8), intent(in), optional :: flux_btm + + ! Local variables + real(r8) :: psi (0:nlev_sat) + integer :: ilev, ilev_u, ilev_l + integer :: spr(1:nlev_sat) + + IF (present(flux_top) .and. present(flux_btm)) THEN + IF (flux_top >= flux_btm) THEN + qlc(:) = flux_btm + RETURN + ENDIF + ENDIF + + psi(0) = psi_top + psi(nlev_sat) = psi_btm + + DO ilev = 1, nlev_sat + IF (ilev < nlev_sat) THEN + psi(ilev) = max(psi_sat(ilev),psi_sat(ilev+1)) + ENDIF + + qlc(ilev) = - hk_sat(ilev) & + * ((psi(ilev) - psi(ilev-1)) / dz_sat(ilev) - 1) + + spr(ilev) = ilev + ENDDO + + ilev_u = nlev_sat + ilev_l = ilev_u + DO WHILE (.true.) + + IF (ilev_l < nlev_sat) THEN + ilev = findloc_ud(spr == spr(ilev_l+1), BACK=.true.) + DO WHILE (qlc(ilev_u) >= qlc(ilev)) + + ilev_l = ilev + qlc(ilev_u:ilev_l) = - (psi(ilev_l) - psi(ilev_u-1) & + - sum(dz_sat(ilev_u:ilev_l))) & + / sum(dz_sat(ilev_u:ilev_l) / hk_sat(ilev_u:ilev_l)) + + spr(ilev_u:ilev_l) = ilev_u + + IF (ilev_l < nlev_sat) THEN + spr(ilev_l+1:nlev_sat) = spr(ilev_l+1:nlev_sat) - 1 + ilev = findloc_ud(spr == spr(ilev_l+1), BACK=.true.) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + IF ((ilev_l == nlev_sat) .and. (present(flux_btm))) THEN + IF (qlc(ilev_l) > flux_btm) THEN + qlc(ilev_u:ilev_l) = flux_btm + ENDIF + ENDIF + + IF (ilev_u > 1) THEN + ilev_u = ilev_u - 1 + ilev_l = ilev_u + ELSE + IF (present(flux_top)) THEN + DO ilev = 1, nlev_sat + IF (flux_top > qlc(ilev)) THEN + qlc(ilev) = flux_top + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + EXIT + ENDIF + + ENDDO + + END SUBROUTINE flux_sat_zone_fixed_bc + + + !------------------------------------------------------------------------- + real(r8) FUNCTION flux_inside_hm_soil ( & + psi_s, hksat, nprm, prms, & + dz, psi_u, psi_l, hk_u, hk_l) + + IMPLICIT NONE + + real(r8), intent(in) :: psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + real(r8), intent(in) :: dz + real(r8), intent(in) :: psi_u, psi_l + real(r8), intent(in) :: hk_u, hk_l + + ! Local variables + real(r8) :: grad_psi + real(r8) :: hk_m + real(r8) :: r0, rr + + grad_psi = (1.0_r8 - (psi_l - psi_u)/dz) + + SELECTCASE (effective_hk_type) + + CASE (type_upstream_mean) + + IF (grad_psi < 0) THEN + flux_inside_hm_soil = hk_l * grad_psi + ELSE + flux_inside_hm_soil = hk_u * grad_psi + ENDIF + + CASE (type_weighted_geometric_mean) + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + r0 = 1.0_r8 / (3.0_r8 / prms(1) + 2.0_r8) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! n_gm => prms(2), L_gm => prms(3) + r0 = 1.0_r8 / (prms(3) * (prms(2) - 1.0_r8) + prms(2) * 2.0_r8) +#endif + + IF (grad_psi < 0) THEN + rr = r0 + hk_m = soil_hk_from_psi (psi_l-dz, psi_s, hksat, nprm, prms) + flux_inside_hm_soil = hk_u**rr * hk_m**(1.0_r8 - rr) * grad_psi + ELSEIF (grad_psi == 0) THEN + flux_inside_hm_soil = 0 + ELSEIF ((grad_psi > 0) .and. (grad_psi < 1)) THEN + rr = max(1.0_r8+r0*psi_l/dz, 1.0_r8-r0) + flux_inside_hm_soil = hk_u**rr * hk_l**(1.0_r8-rr) * grad_psi + ELSEIF (grad_psi == 1) THEN + flux_inside_hm_soil = hk_u + ELSEIF (grad_psi > 1) THEN + rr = r0 + flux_inside_hm_soil = hk_u + (psi_u - psi_l)/dz * hk_u**(1.0_r8-rr) * hk_l**rr + ENDIF + + ENDSELECT + + END FUNCTION flux_inside_hm_soil + + + !-------------------------------------------------------- + SUBROUTINE flux_at_unsaturated_interface (& + nprm, & + psi_s_u, hksat_u, prms_u, dz_u, psi_u, hk_u, & + psi_s_l, hksat_l, prms_l, dz_l, psi_l, hk_l, & + flux_u, flux_l, tol_q, tol_p) + + IMPLICIT NONE + + integer, intent(in) :: nprm + real(r8), intent(in) :: psi_s_u, hksat_u, prms_u(nprm) + real(r8), intent(in) :: psi_s_l, hksat_l, prms_l(nprm) + + real(r8), intent(in) :: dz_u, psi_u, hk_u + real(r8), intent(in) :: dz_l, psi_l, hk_l + + real(r8), intent(out) :: flux_u + real(r8), intent(out) :: flux_l + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_p + + ! Local variables + real(r8) :: psi_s_min + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i_u, hk_i_l + real(r8) :: fval, fval_k1 + integer :: iter + + + psi_i_r = max(psi_u + dz_u, psi_l - dz_l) + psi_i_l = min(psi_u + dz_u, psi_l - dz_l) + + psi_s_min = min(psi_s_u, psi_s_l) + + IF (psi_i_r > psi_s_min) THEN + hk_i_u = soil_hk_from_psi (psi_s_min, psi_s_u, hksat_u, nprm, prms_u) + hk_i_l = soil_hk_from_psi (psi_s_min, psi_s_l, hksat_l, nprm, prms_l) + + flux_u = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_u, psi_u, psi_s_min, hk_u, hk_i_u) + + flux_l = flux_inside_hm_soil (& + psi_s_l, hksat_l, nprm, prms_l, & + dz_l, psi_s_min, psi_l, hk_i_l, hk_l) + + IF (flux_u >= flux_l) THEN + RETURN + ELSE + psi_i_r = psi_s_min + ENDIF + ENDIF + + psi_i = (dz_l * psi_u + dz_u * psi_l) / (dz_u + dz_l) + IF ((psi_i < psi_i_l) .or. (psi_i > psi_i_r)) THEN + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + ENDIF + + iter = 0 + DO WHILE (iter < 50) + hk_i_u = soil_hk_from_psi (psi_i, psi_s_u, hksat_u, nprm, prms_u) + hk_i_l = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + + flux_u = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_u, psi_u, psi_i, hk_u, hk_i_u) + + flux_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_l, psi_i, psi_l, hk_i_l, hk_l) + + fval = flux_l - flux_u + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + IF (iter == 0) THEN + IF (fval < 0) THEN + psi_i_l = psi_i + ELSE + psi_i_r = psi_i + ENDIF + + psi_i_k1 = psi_i + fval_k1 = fval + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_at_unsaturated_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_at_unsaturated_interface + + !------------------------------------------------------------------- + SUBROUTINE flux_top_transitive_interface ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, hk_us, & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_btm, & + q_us_up, qlc, tol_q, tol_z, tol_p, flux_btm) + + IMPLICIT NONE + + real(r8), intent(in) :: psi_s_u, hksat_u + integer, intent(in) :: nprm + real(r8), intent(in) :: prms_u(nprm) + + real(r8), intent(in) :: dz_us + real(r8), intent(in) :: psi_us + real(r8), intent(in) :: hk_us + + integer, intent(in) :: nlev_sat + real(r8), intent(in) :: dz_sat (nlev_sat) + real(r8), intent(in) :: psi_sat (nlev_sat) + real(r8), intent(in) :: hk_sat (nlev_sat) + + real(r8), intent(in) :: psi_btm + + real(r8), intent(out) :: q_us_up + real(r8), intent(inout) :: qlc (nlev_sat) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + real(r8), intent(in), optional :: flux_btm + + ! Local variables + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i + real(r8) :: fval, fval_k1 + integer :: iter + + + IF (dz_us < tol_z) THEN + + psi_i = max(psi_s_u, psi_sat(1)) + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + q_us_up = qlc(1) + + RETURN + + ENDIF + + IF (psi_s_u <= psi_sat(1)) THEN + ! The case psi_s_u < psi_sat(1) does not exist in principle. + + psi_i = psi_s_u + hk_i = hksat_u + q_us_up = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + psi_i = psi_sat(1) + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + RETURN + + ENDIF + + psi_i = psi_sat(1) + hk_i = soil_hk_from_psi (psi_i, psi_s_u, hksat_u, nprm, prms_u) + q_us_up = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + IF (q_us_up <= qlc(1)) THEN + RETURN + ELSE + psi_i_l = psi_sat(1) + ENDIF + + psi_i = psi_s_u + hk_i = hksat_u + q_us_up = flux_inside_hm_soil (& + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + IF (q_us_up >= qlc(1)) THEN + RETURN + ELSE + psi_i_r = psi_s_u + ENDIF + + psi_i_k1 = psi_i_r + fval_k1 = qlc(1) - q_us_up + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + iter = 0 + DO WHILE (iter < 50) + hk_i = soil_hk_from_psi (psi_i, psi_s_u, hksat_u, nprm, prms_u) + q_us_up = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + fval = qlc(1) - q_us_up + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_top_transitive_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_top_transitive_interface + + !------------------------------------------------------------------------ + SUBROUTINE flux_btm_transitive_interface ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_us, hk_us, & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_top, & + q_us_l, qlc, tol_q, tol_z, tol_p, flux_top) + + IMPLICIT NONE + + real(r8), intent(in) :: psi_s_l, hksat_l + integer, intent(in) :: nprm + real(r8), intent(in) :: prms_l(nprm) + + real(r8), intent(in) :: dz_us + real(r8), intent(in) :: psi_us + real(r8), intent(in) :: hk_us + + integer, intent(in) :: nlev_sat + real(r8), intent(in) :: dz_sat (nlev_sat) + real(r8), intent(in) :: psi_sat (nlev_sat) + real(r8), intent(in) :: hk_sat (nlev_sat) + + real(r8), intent(in) :: psi_top + + real(r8), intent(out) :: q_us_l + real(r8), intent(inout) :: qlc (nlev_sat) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + real(r8), intent(in), optional :: flux_top + + ! Local variables + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i + real(r8) :: fval, fval_k1 + integer :: iter + + + IF (dz_us < tol_z) THEN + + psi_i = max(psi_sat(nlev_sat), psi_s_l) + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + q_us_l = qlc(nlev_sat) + + RETURN + + ENDIF + + IF (psi_sat(nlev_sat) >= psi_s_l) THEN + ! The case psi_sat(nlev_sat) > psi_s_l does not exist in principle. + + psi_i = psi_s_l + hk_i = hksat_l + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + psi_i = psi_sat(nlev_sat) + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + RETURN + + ENDIF + + psi_i = psi_sat(nlev_sat) + + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + hk_i = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + IF (qlc(nlev_sat) <= q_us_l) THEN + RETURN + ELSE + psi_i_l = psi_sat(nlev_sat) + ENDIF + + psi_i = psi_s_l + + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + hk_i = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + IF (qlc(nlev_sat) >= q_us_l) THEN + RETURN + ELSE + psi_i_r = psi_s_l + ENDIF + + psi_i_k1 = psi_i_r + fval_k1 = q_us_l - qlc(nlev_sat) + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + iter = 0 + DO WHILE (iter < 50) + + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + hk_i = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + fval = q_us_l - qlc(nlev_sat) + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_btm_transitive_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_btm_transitive_interface + + + !----------------------------------------------------------------------- + SUBROUTINE flux_both_transitive_interface ( & + ilev_us_u, ilev_us_l, & + dz, psi_s, hksat, nprm, prms, & + dz_us_u, psi_us_u, hk_us_u, & + dz_us_l, psi_us_l, hk_us_l, & + q_us_u, q_us_l, qlc, & + tol_q, tol_z, tol_p) + + IMPLICIT NONE + + integer, intent(in) :: ilev_us_u, ilev_us_l + real(r8), intent(in) :: dz (ilev_us_u:ilev_us_l) + real(r8), intent(in) :: psi_s (ilev_us_u:ilev_us_l) + real(r8), intent(in) :: hksat (ilev_us_u:ilev_us_l) + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,ilev_us_u:ilev_us_l) + + real(r8), intent(in) :: dz_us_u, psi_us_u, hk_us_u + real(r8), intent(in) :: dz_us_l, psi_us_l, hk_us_l + + real(r8), intent(out) :: q_us_u, q_us_l + real(r8), intent(inout) :: qlc (ilev_us_u+1:ilev_us_l-1) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + ! Local variables + integer :: nlev_sat + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i + real(r8) :: fval, fval_k1 + integer :: iter + + nlev_sat = ilev_us_l - ilev_us_u - 1 + + IF ((psi_s(ilev_us_u) <= psi_s(ilev_us_u+1)) & + .or. (dz_us_u < tol_z)) THEN + + psi_i = max(psi_s(ilev_us_u), psi_s(ilev_us_u+1)) + CALL flux_btm_transitive_interface ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_us_l, hk_us_l, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), psi_s(ilev_us_u+1:ilev_us_l-1), & + hksat(ilev_us_u+1:ilev_us_l-1), psi_i, & + q_us_l, qlc, tol_q, tol_z, tol_p) + + IF (dz_us_u < tol_z) THEN + q_us_u = qlc(ilev_us_u+1) + ELSE + q_us_u = flux_inside_hm_soil ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, psi_s(ilev_us_u), hk_us_u, hksat(ilev_us_u)) + ENDIF + + RETURN + ENDIF + + IF ((psi_s(ilev_us_l) <= psi_s(ilev_us_l-1)) & + .or. (dz_us_l < tol_z)) THEN + + psi_i = max(psi_s(ilev_us_l-1), psi_s(ilev_us_l)) + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i, & + q_us_u, qlc, tol_q, tol_z, tol_p) + + IF (dz_us_l < tol_z) THEN + q_us_l = qlc(ilev_us_l-1) + ELSE + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_s(ilev_us_l), psi_us_l, hksat(ilev_us_l), hk_us_l) + ENDIF + + RETURN + ENDIF + + psi_i_l = psi_s(ilev_us_l-1) + + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i_l, & + q_us_u, qlc, tol_q/2.0_r8, tol_z, tol_p) + + hk_i = soil_hk_from_psi (psi_i_l, & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l)) + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_i_l, psi_us_l, hk_i, hk_us_l) + + IF (qlc(ilev_us_l-1) <= q_us_l) THEN + RETURN + ENDIF + + psi_i_r = psi_s(ilev_us_l) + + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i_r, & + q_us_u, qlc, tol_q/2.0_r8, tol_z, tol_p) + + hk_i = soil_hk_from_psi (psi_i_r, & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l)) + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_i_r, psi_us_l, hk_i, hk_us_l) + + IF (qlc(ilev_us_l-1) >= q_us_l ) THEN + RETURN + ENDIF + + psi_i_k1 = psi_i_r + fval_k1 = q_us_l - qlc(ilev_us_l-1) + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + iter = 0 + DO WHILE (iter < 50) + + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i, & + q_us_u, qlc, tol_q/2.0_r8, tol_z, tol_p) + + hk_i = soil_hk_from_psi (psi_i, & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l)) + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_i, psi_us_l, hk_i, hk_us_l) + + fval = q_us_l - qlc(ilev_us_l-1) + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_both_transitive_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_both_transitive_interface + + !----------------------------------------------------------------- + SUBROUTINE get_zwt_from_wa ( & + vl_s, vl_r, psi_s, hksat, nprm, prms, tol_v, tol_z, & + wa, zmin, zwt) + + IMPLICIT NONE + + real(r8), intent(in) :: vl_s, vl_r, psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + real(r8), intent(in) :: tol_v, tol_z + real(r8), intent(in) :: wa, zmin + real(r8), intent(out) :: zwt + + real(r8) :: vl + real(r8) :: zwt_l, zwt_r, zwt_k1 + real(r8) :: fval, fval_k1 + real(r8) :: psi + integer :: iter + + IF (wa >= 0) THEN + zwt = zmin + vl = vl_s + RETURN + ENDIF + + zwt = zmin + (-wa)/vl_s * 2.0 + psi = psi_s - (zwt - zmin) * 0.5 + vl = soil_vliq_from_psi (psi, & + vl_s, vl_r, psi_s, nprm, prms) + DO WHILE (wa <= -(zwt-zmin)*(vl_s-vl)) + zwt = zmin + (zwt-zmin)*2 + 0.1 + psi = psi_s - (zwt - zmin) * 0.5 + vl = soil_vliq_from_psi (psi, & + vl_s, vl_r, psi_s, nprm, prms) + ENDDO + + zwt_r = zwt + zwt_l = zmin + + zwt_k1 = zwt_l + fval_k1 = wa + + zwt = (zwt_l + zwt_r) / 2.0 + iter = 0 + DO WHILE (iter < 50) + + psi = psi_s - (zwt - zmin) * 0.5 + vl = soil_vliq_from_psi (psi, & + vl_s, vl_r, psi_s, nprm, prms) + fval = wa + (zwt-zmin)* (vl_s-vl) + + IF ((abs(fval) < tol_v) .or. (zwt_r - zwt_l < tol_z)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, zwt, zwt_k1, zwt_l, zwt_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : get_zwt_from_wa: not converged.' + ENDIF +#endif + + END SUBROUTINE get_zwt_from_wa + + + !--------------------------------------------------------------------- + SUBROUTINE solve_least_squares_problem (ndim, dr_dv, lact, rhs, dv) + ! By using Givens rotation. + + IMPLICIT NONE + + integer, intent(in) :: ndim + real(r8), intent(in) :: dr_dv (ndim,ndim) + logical, intent(in) :: lact (ndim) + real(r8), intent(in) :: rhs (ndim) + + real(r8), intent(out) :: dv (ndim) + + ! Local variables + real(r8) :: Amatrix (ndim,ndim) + real(r8) :: res (ndim) + integer :: i, j, k + real(r8) :: tau, c, s + real(r8) :: tmp + + Amatrix = dr_dv + res = rhs + dv = 0 + + DO i = 1, ndim + IF (lact(i)) THEN + + DO j = i+1, ndim + IF (Amatrix(j,i) /= 0) THEN + IF (abs(Amatrix(j,i)) > abs(Amatrix(i,i))) THEN + tau = Amatrix(i,i) / Amatrix(j,i) + s = 1 / sqrt(1 + tau**2) + c = s * tau + ELSE + tau = Amatrix(j,i) / Amatrix(i,i) + c = 1 / sqrt(1 + tau**2) + s = c * tau + ENDIF + + Amatrix(i,i) = c * Amatrix(i,i) + s * Amatrix(j,i) + Amatrix(j,i) = 0 + + DO k = i+1, ndim + IF (lact(k)) THEN + tmp = c * Amatrix(i,k) + s * Amatrix(j,k) + Amatrix(j,k) = - s * Amatrix(i,k) + c * Amatrix(j,k) + Amatrix(i,k) = tmp + ENDIF + ENDDO + + tmp = c * res(i) + s * res(j) + res(j) = - s * res(i) + c * res(j) + res(i) = tmp + ENDIF + ENDDO + + ENDIF + ENDDO + + dv = 0 + + DO i = ndim, 1, -1 + IF (lact(i)) THEN + + dv(i) = res(i) + + DO k = i+1, ndim + IF (lact(k)) THEN + dv(i) = dv(i) - Amatrix(i,k) * dv(k) + ENDIF + ENDDO + + dv(i) = dv(i) / Amatrix(i,i) + + ENDIF + ENDDO + + END SUBROUTINE solve_least_squares_problem + + + !--------------------------------------------------------------------------------- + SUBROUTINE secant_method_iteration ( & + fval, fval_k1, x_i, x_k1, x_l, x_r) + + IMPLICIT NONE + + real(r8), intent(in) :: fval + real(r8), intent(inout) :: fval_k1 + + real(r8), intent(inout) :: x_i, x_k1 + real(r8), intent(inout) :: x_l, x_r + + real(r8), parameter :: alp = 0.9_r8 + + ! Local variables + real(r8) :: x_k2, fval_k2 + + IF (fval > 0.0_r8) THEN + x_r = x_i + ELSE + x_l = x_i + ENDIF + + fval_k2 = fval_k1 + fval_k1 = fval + + x_k2 = x_k1 + x_k1 = x_i + + IF (fval_k1 == fval_k2) THEN + x_i = (x_l + x_r) * 0.5_r8 + ELSE + x_i = (fval_k1 * x_k2 - fval_k2 * x_k1) / (fval_k1 - fval_k2) + x_i = max(x_i, x_l * alp + x_r * (1.0_r8 - alp)) + x_i = min(x_i, x_l * (1.0_r8 - alp) + x_r * alp) + ENDIF + + END SUBROUTINE secant_method_iteration + + + !------------------------------------------------------------------------------- + integer FUNCTION find_unsat_lev_lower (is_sat, lb, ub, ilev) + + IMPLICIT NONE + + integer, intent(in) :: lb, ub + logical, intent(in) :: is_sat (lb:ub) + integer, intent(in) :: ilev + + find_unsat_lev_lower = ilev + DO WHILE (find_unsat_lev_lower <= ub) + IF (is_sat(find_unsat_lev_lower)) THEN + find_unsat_lev_lower = find_unsat_lev_lower + 1 + ELSE + EXIT + ENDIF + ENDDO + + END FUNCTION find_unsat_lev_lower + + ! ----- + SUBROUTINE print_VSF_iteration_stat_info () + + USE MOD_SPMD_Task + IMPLICIT NONE + + integer(8), SAVE :: count_implicit_accum = 0 + integer(8), SAVE :: count_explicit_accum = 0 + integer(8), SAVE :: count_wet2dry_accum = 0 + integer :: iwork + +#ifdef CoLMDEBUG + IF (p_is_worker) THEN +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) +#endif + IF (p_iam_worker == p_root) THEN + count_implicit_accum = count_implicit_accum + count_implicit + count_explicit_accum = count_explicit_accum + count_explicit + count_wet2dry_accum = count_wet2dry_accum + count_wet2dry + +#ifdef USEMPI + CALL mpi_send (count_implicit, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_explicit, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_wet2dry, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_implicit_accum, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_explicit_accum, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_wet2dry_accum, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN + +#ifdef USEMPI + iwork = p_address_worker(p_root) + CALL mpi_recv (count_implicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_explicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_wet2dry , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_implicit_accum, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_explicit_accum, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_wet2dry_accum , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + + write(*,"(/,A,I13,A,I13,A,I13,A)") 'VSF scheme this step: ', & + count_implicit, ' (implicit)', count_explicit, ' (explicit)', count_wet2dry, ' (wet2dry)' + write(*,"(A,I13,A,I13,A,I13,A)") 'VSF scheme all steps: ', & + count_implicit_accum, ' (implicit)', count_explicit_accum, ' (explicit)', & + count_wet2dry_accum, ' (wet2dry)' + ENDIF + + count_implicit = 0 + count_explicit = 0 + count_wet2dry = 0 +#endif + END SUBROUTINE print_VSF_iteration_stat_info + +END MODULE MOD_Hydro_SoilWater diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 new file mode 100644 index 0000000000..cbc90062c7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 @@ -0,0 +1,588 @@ +MODULE MOD_Hydro_VIC + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + + PUBLIC :: compute_vic_runoff + + PRIVATE :: compute_runoff_and_asat + PRIVATE :: calc_Q12 + PRIVATE :: compute_zwt + PRIVATE :: wrap_compute_zwt + + CONTAINS + + ! ****************************************************************************** + SUBROUTINE Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno, wliq_soisno, fevpg, rootflux, ppt, & + b_infilt, Dsmax, Ds, Ws, c, & + rsur,rsubst,wliq_soisno_tmp) + + USE MOD_Namelist + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + + !-----------------------Arguments--------------------------------------- + type(soil_con_struct) :: soil_con + type(cell_data_struct) :: cell + + real(r8), intent(in) :: porsl(1:nl_soil), theta_r(1:nl_soil), hksati(1:nl_soil), bsw(1:nl_soil) + real(r8), intent(in) :: wice_soisno(1:nl_soil) + real(r8), intent(in) :: wliq_soisno(1:nl_soil) + real(r8), intent(in) :: fevpg + real(r8), intent(in) :: rootflux(1:nl_soil) + real(r8), intent(in) :: ppt ! /**< amount of liquid water coming to the surface */ + real(r8), intent(in) :: deltim ! int(DEF_simulation_time%timestep) + + real(r8), intent(in) :: b_infilt, Dsmax, Ds, Ws, c + + real(r8), intent(inout) :: rsur, rsubst + real(r8), intent(out) :: wliq_soisno_tmp(1:nl_soil) + + !-----------------------Local Variables--------------------------------- + integer :: ilay + real(r8) :: vic_tmp(Nlayer), vic_tmp_(Nlayer) + !-----------------------Arguments--------------------------------------- + + CALL vic_para(porsl, theta_r, hksati, bsw, wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg, rootflux, & + b_infilt, Dsmax, Ds, Ws, c, & + soil_con, cell) + + CALL compute_vic_runoff(soil_con, ppt*deltim, soil_con%frost_fract, cell) + + DO ilay = 1, Nlayer + vic_tmp(ilay) = cell%layer(ilay)%moist + ENDDO + wliq_soisno_tmp = 0. + CALL VIC2CoLM(wliq_soisno_tmp, vic_tmp) + + DO ilay = 1, Nlayer + vic_tmp_(ilay) = sum(cell%layer(ilay)%ice) + ENDDO + ! CALL VIC2CoLM(wice_soisno(1:nl_soil), vic_tmp_) + + IF (ppt > 0.) rsur = cell%runoff/deltim + rsubst = cell%baseflow/deltim + + END SUBROUTINE Runoff_VIC + + ! /****************************************************************************** + ! * @brief Calculate infiltration and runoff from the surface, gravity driven + ! * drainage between all soil layers, and generates baseflow from the + ! * bottom layer. + ! ******************************************************************************/ + SUBROUTINE compute_vic_runoff(soil_con, ppt, frost_fract, cell) + USE MOD_Hydro_VIC_Variables + USE MOD_Namelist + IMPLICIT NONE + + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + real(r8), intent(in) :: ppt ! /**< amount of liquid water coming to the surface */ + real(r8), intent(in) :: frost_fract(:) ! /**< spatially distributed frost coverage fractions */ + type(cell_data_struct),intent(inout) :: cell + + !-----------------------Local Variables--------------------------------- + integer :: lindex, time_step + integer :: last_index, tmplayer, fidx + real(r8) :: A + real(r8) :: frac + real(r8) :: tmp_runoff + real(r8) :: inflow + real(r8) :: resid_moist(MAX_LAYERS) ! residual moisture (mm) + real(r8) :: org_moist(MAX_LAYERS) ! total soil moisture (liquid and frozen) at beginning of this FUNCTION (mm) + real(r8) :: avail_liq(MAX_LAYERS, MAX_FROST_AREAS) ! liquid soil moisture available for evap/drainage (mm) + real(r8) :: liq(MAX_LAYERS) + real(r8) :: ice(MAX_LAYERS) + real(r8) :: moist(MAX_LAYERS) + real(r8) :: max_moist(MAX_LAYERS) + real(r8) :: Ksat(MAX_LAYERS) + real(r8) :: Q12(MAX_LAYERS - 1) + real(r8) :: Dsmax + real(r8) :: tmp_inflow + real(r8) :: tmp_moist + real(r8) :: tmp_moist_for_runoff(MAX_LAYERS) + real(r8) :: tmp_liq + real(r8) :: dt_inflow + real(r8) :: dt_runoff + real(r8) :: runoff(MAX_FROST_AREAS) + real(r8) :: tmp_dt_runoff(MAX_FROST_AREAS) + real(r8) :: baseflow(MAX_FROST_AREAS) + real(r8) :: dt_baseflow + real(r8) :: rel_moist + real(r8) :: evap(MAX_LAYERS, MAX_FROST_AREAS) + real(r8) :: sum_liq + real(r8) :: evap_fraction + real(r8) :: evap_sum + type(layer_data_struct), dimension(MAX_LAYERS) :: layer + + real(r8) :: dltime !/**< timestep in seconds */ + integer :: runoff_steps_per_day !/**< Number of runoff timesteps per day */ + integer :: model_steps_per_day !/**< Number of model timesteps per day */ + integer :: runoff_steps_per_dt + + !-----------------------End Variable List------------------------------- + + dltime = DEF_simulation_time%timestep + runoff_steps_per_day = 86400/dltime + model_steps_per_day = 86400/dltime + + ! /** Set Temporary Variables **/ + DO lindex = 1, Nlayer + resid_moist(lindex) = soil_con%resid_moist(lindex) + max_moist(lindex) = soil_con%max_moist(lindex) + Ksat(lindex) = soil_con%Ksat(lindex) / runoff_steps_per_day + ENDDO + + ! /** Allocate and Set Values for Soil Sublayers **/ + layer = cell%layer + cell%runoff = 0 + cell%baseflow = 0 + cell%asat = 0 + + runoff_steps_per_dt = runoff_steps_per_day / model_steps_per_day + + ! initialize baseflow + DO fidx = 1, Nfrost + baseflow(fidx) = 0.0 + ENDDO + + DO lindex = 1, Nlayer + evap(lindex, 1) = layer(lindex)%evap / real(runoff_steps_per_dt) + org_moist(lindex) = layer(lindex)%moist + layer(lindex)%moist = 0.0 + + ! if there is positive evaporation + IF (evap(lindex, 1) > 0.0) THEN + sum_liq = 0.0 + ! compute available soil moisture for each frost sub area + DO fidx = 1, Nfrost + avail_liq(lindex, fidx) = org_moist(lindex) - layer(lindex)%ice(fidx) - resid_moist(lindex) + !avail_liq(lindex, fidx) = org_moist(lindex) - resid_moist(lindex) + IF (avail_liq(lindex, fidx) < 0.0) THEN + avail_liq(lindex, fidx) = 0.0 + ENDIF + sum_liq = sum_liq + avail_liq(lindex, fidx) * frost_fract(fidx) + ENDDO + + ! compute fraction of available soil moisture that is evaporated + IF (sum_liq > 0.0) THEN + evap_fraction = evap(lindex, 1) / sum_liq + ELSE + evap_fraction = 1.0 + ENDIF + + ! distribute evaporation between frost sub areas by percentage + evap_sum = evap(lindex, 1) + DO fidx = Nfrost, 1, -1 + evap(lindex, fidx) = avail_liq(lindex, fidx) * evap_fraction + avail_liq(lindex, fidx) = avail_liq(lindex, fidx) - evap(lindex, fidx) + evap_sum = evap_sum - evap(lindex, fidx) * frost_fract(fidx) + ENDDO + ELSE + ! if no evaporation + DO fidx = Nfrost, 2, -1 + evap(lindex, fidx) = evap(lindex, 1) + ENDDO + ENDIF + ENDDO + + + DO fidx = 1, Nfrost + ! ppt = amount of liquid water coming to the surface + inflow = ppt + + ! /************************************************** + ! Initialize Variables + ! **************************************************/ + DO lindex = 1, Nlayer + ! Set Layer Liquid Moisture Content + liq(lindex) = org_moist(lindex) - layer(lindex)%ice(fidx) + + ! Set Layer Frozen Moisture Content + ice(lindex) = layer(lindex)%ice(fidx) + ENDDO + + ! /****************************************************** + ! Runoff Based on Soil Moisture Level of Upper Layers + ! ******************************************************/ + DO lindex = 1, Nlayer + tmp_moist_for_runoff(lindex) = liq(lindex) + ice(lindex) + ENDDO + + CALL compute_runoff_and_asat(soil_con, tmp_moist_for_runoff, inflow, A, runoff(fidx)) + + ! Save dt_runoff based on initial runoff estimate + tmp_dt_runoff(fidx) = runoff(fidx) / real(runoff_steps_per_dt, kind=r8) + + ! /************************************************** + ! Compute Flow Between Soil Layers () + ! **************************************************/ + dt_inflow = inflow / real(runoff_steps_per_dt, kind=r8) + + Dsmax = soil_con%Dsmax / runoff_steps_per_day + + DO time_step = 1, runoff_steps_per_dt + inflow = dt_inflow + + ! /************************************* + ! Compute Drainage between Sublayers + ! *************************************/ + DO lindex = 1, Nlayer - 1 + ! Brooks & Corey relation for hydraulic conductivity + tmp_liq = liq(lindex) - evap(lindex, fidx) ! Assume evap is a 2D array now, adjusted indexing + + IF (tmp_liq < resid_moist(lindex)) THEN + tmp_liq = resid_moist(lindex) + ENDIF + + IF (tmp_liq > resid_moist(lindex)) THEN + CALL calc_Q12(Ksat(lindex), tmp_liq, resid_moist(lindex), max_moist(lindex), soil_con%expt(lindex),Q12(lindex)) + ELSE + Q12(lindex) = 0.0 + ENDIF + ENDDO + + ! /************************************************** + ! Solve for Current Soil Layer Moisture, and + ! Check Versus Maximum and Minimum Moisture Contents. + ! **************************************************/ + last_index = 0 + DO lindex = 1, Nlayer - 1 + IF (lindex == 1) THEN + dt_runoff = tmp_dt_runoff(fidx) + ELSE + dt_runoff = 0.0 + ENDIF + + ! transport moisture for all sublayers + tmp_inflow = 0.0 + + ! Update soil layer moisture content + liq(lindex) = liq(lindex) + (inflow - dt_runoff) - (Q12(lindex) + evap(lindex, fidx)) + + ! Verify that soil layer moisture is less than maximum + IF ((liq(lindex) + ice(lindex)) > max_moist(lindex)) THEN + tmp_inflow = (liq(lindex) + ice(lindex)) - max_moist(lindex) + liq(lindex) = max_moist(lindex) - ice(lindex) + + IF (lindex == 1) THEN + Q12(lindex) = Q12(lindex) + tmp_inflow + tmp_inflow = 0.0 + ELSE + tmplayer = lindex + DO WHILE (tmp_inflow > 0) + tmplayer = tmplayer - 1 + IF (tmplayer < 1) THEN + ! If top layer saturated, add to runoff + runoff(fidx) = runoff(fidx) + tmp_inflow + tmp_inflow = 0.0 + ELSE + ! else add excess soil moisture to next higher layer + liq(tmplayer) = liq(tmplayer) + tmp_inflow + IF ((liq(tmplayer) + ice(tmplayer)) > max_moist(tmplayer)) THEN + tmp_inflow = (liq(tmplayer) + ice(tmplayer)) - max_moist(tmplayer) + liq(tmplayer) = max_moist(tmplayer) - ice(tmplayer) + ELSE + tmp_inflow = 0.0 + ENDIF + ENDIF + ENDDO + ENDIF ! /** END trapped excess moisture **/ + ENDIF ! /** END check if excess moisture in top layer **/ + + ! verify that current layer moisture is greater than minimum + IF (liq(lindex) < 0.0) THEN + ! liquid cannot fall below 0 + Q12(lindex) = Q12(lindex) + liq(lindex) + liq(lindex) = 0.0 + ENDIF + + IF ((liq(lindex) + ice(lindex)) < resid_moist(lindex)) THEN + ! moisture cannot fall below minimum + Q12(lindex) = Q12(lindex) + (liq(lindex) + ice(lindex)) - resid_moist(lindex) + liq(lindex) = resid_moist(lindex) - ice(lindex) + ENDIF + + inflow = Q12(lindex) + tmp_inflow + Q12(lindex) = Q12(lindex) + tmp_inflow + + last_index = last_index + 1 + ENDDO ! /* END loop through soil layers */ + + ! /************************************************** + ! Compute Baseflow + ! **************************************************/ + ! ARNO model for the bottom soil layer (based on bottom + ! soil layer moisture from previous time step) + + lindex = Nlayer + + ! Compute relative moisture + rel_moist = (liq(lindex) - resid_moist(lindex)) / & + (max_moist(lindex) - resid_moist(lindex)) + + ! Compute baseflow as FUNCTION of relative moisture + frac = Dsmax * soil_con%Ds / soil_con%Ws + dt_baseflow = frac * rel_moist + IF (rel_moist > soil_con%Ws) THEN + frac = (rel_moist - soil_con%Ws) / (1 - soil_con%Ws) + dt_baseflow = dt_baseflow + Dsmax * (1 - soil_con%Ds / soil_con%Ws) * & + frac ** soil_con%c + ENDIF + + ! Make sure baseflow isn't negative + IF (dt_baseflow < 0) THEN + dt_baseflow = 0.0 + ENDIF + + ! Extract baseflow from the bottom soil layer + liq(lindex) = liq(lindex) + Q12(lindex - 1) - (evap(lindex, fidx) + dt_baseflow) + + ! Check Lower Sub-Layer Moistures + tmp_moist = 0.0 + + ! /* If soil moisture has gone below minimum, take water out + ! * of baseflow and add back to soil to make up the difference + ! * Note: this may lead to negative baseflow, in which case we will + ! * reduce evap to make up for it */ + IF ((liq(lindex) + ice(lindex)) < resid_moist(lindex)) THEN + dt_baseflow = dt_baseflow + & + (liq(lindex) + ice(lindex)) - resid_moist(lindex) + liq(lindex) = resid_moist(lindex) - ice(lindex) + ENDIF + + IF ((liq(lindex) + ice(lindex)) > max_moist(lindex)) THEN + ! soil moisture above maximum + tmp_moist = (liq(lindex) + ice(lindex)) - max_moist(lindex) + liq(lindex) = max_moist(lindex) - ice(lindex) + tmplayer = lindex + DO WHILE (tmp_moist > 0) + tmplayer = tmplayer - 1 + IF (tmplayer < 1) THEN + ! If top layer saturated, add to runoff + runoff(fidx) = runoff(fidx) + tmp_moist + tmp_moist = 0.0 + ELSE + ! else if sublayer exists, add excess soil moisture + liq(tmplayer) = liq(tmplayer) + tmp_moist + IF ((liq(tmplayer) + ice(tmplayer)) > max_moist(tmplayer)) THEN + tmp_moist = (liq(tmplayer) + ice(tmplayer)) - max_moist(tmplayer) + liq(tmplayer) = max_moist(tmplayer) - ice(tmplayer) + ELSE + tmp_moist = 0.0 + ENDIF + ENDIF + ENDDO + ENDIF + + baseflow(fidx) = baseflow(fidx) + dt_baseflow + ENDDO ! /* END of sub-dt time step loop */ + + ! If negative baseflow, reduce evap accordingly + IF (baseflow(fidx) < 0.0) THEN + ! layer(lindex)%evap = layer(lindex)%evap + baseflow(fidx) !!!! need check + baseflow(fidx) = 0.0 + endif + + ! Recompute Asat based on final moisture level of upper layers + do lindex = 1, Nlayer + tmp_moist_for_runoff(lindex) = (liq(lindex) + ice(lindex)) + enddo + + CALL compute_runoff_and_asat(soil_con, tmp_moist_for_runoff, real(0.0, kind=r8), A, tmp_runoff) + + ! Store tile-wide values + do lindex = 1, Nlayer + layer(lindex)%moist = layer(lindex)%moist + & + ((liq(lindex) + ice(lindex)) * frost_fract(fidx)) + enddo + cell%asat = cell%asat + A * frost_fract(fidx) + cell%runoff = cell%runoff + runoff(fidx) * frost_fract(fidx) + cell%baseflow = cell%baseflow + baseflow(fidx) * frost_fract(fidx) + + ! ! /** Compute water table depth **/ + ! CALL wrap_compute_zwt(soil_con, cell) + + enddo + + END SUBROUTINE compute_vic_runoff + + + ! ****************************************************************************** + ! * @brief Calculate the saturated area and runoff + ! ****************************************************************************** + SUBROUTINE compute_runoff_and_asat(soil_con, moist, inflow, A, runoff) + USE MOD_Hydro_VIC_Variables, only: soil_con_struct, Nlayer + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + real(r8), intent(in) :: moist(Nlayer) + real(r8), intent(in) :: inflow + real(r8), intent(inout) :: A + real(r8), intent(inout) :: runoff + !-----------------------Local Variables--------------------------------- + real(r8) :: top_moist !! total moisture (liquid and frozen) in topmost soil layers (mm) + real(r8) :: top_max_moist !! maximum storable moisture (liquid and frozen) in topmost soil layers (mm) + integer :: lindex + real(r8) :: ex, max_infil, i_0, basis + !-----------------------End Variable List------------------------------- + + top_moist = 0.0 + top_max_moist = 0.0 + do lindex = 1, Nlayer - 1 + top_moist = top_moist + moist(lindex) + top_max_moist = top_max_moist + soil_con%max_moist(lindex) + enddo + if (top_moist > top_max_moist) then + top_moist = top_max_moist + endif + + ! A as in Wood et al. in JGR 97, D3, 1992 equation (1) + ex = soil_con%b_infilt / (1.0 + soil_con%b_infilt) + A = 1.0 - (1.0 - top_moist / top_max_moist)**ex + + max_infil = (1.0 + soil_con%b_infilt) * top_max_moist + i_0 = max_infil * (1.0 - (1.0 - A)**(1.0 / soil_con%b_infilt)) + + ! equation (3a) Wood et al. + if (inflow == 0.0) then + runoff = 0.0 + else if (max_infil == 0.0) then + runoff = inflow + else if ((i_0 + inflow) > max_infil) then + runoff = inflow - top_max_moist + top_moist + ! equation (3b) Wood et al. (wrong in paper) + else + basis = 1.0 - (i_0 + inflow) / max_infil + runoff = (inflow - top_max_moist + top_moist + & + top_max_moist * basis**(1.0 * (1.0 + soil_con%b_infilt))) + endif + if (runoff < 0.0) then + runoff = 0.0 + endif + END SUBROUTINE compute_runoff_and_asat + + + ! ****************************************************************************** + ! * @brief Calculate drainage between two layers + ! ****************************************************************************** + SUBROUTINE calc_Q12(Ksat, init_moist, resid_moist, max_moist, expt, Q12) + IMPLICIT NONE + real(r8), intent(in) :: Ksat, init_moist, resid_moist, max_moist, expt + real(r8), intent(out) :: Q12 + + Q12 = init_moist - ((init_moist - resid_moist)**(1.0d0 - expt) - Ksat / & + (max_moist - resid_moist)**expt * (1.0d0 - expt))**(1.0d0 / (1.0d0 - expt)) - resid_moist + + END SUBROUTINE calc_Q12 + + + ! /****************************************************************************** + ! * @brief Compute spatial average water table position (zwt). Water table + ! * position is measured in cm and is negative below the soil surface. + ! *****************************************************************************/ + SUBROUTINE compute_zwt(soil_con,lindex, moist, zwt) + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + integer, intent(in) :: lindex + real(r8), intent(in) :: moist + real(r8), intent(out) :: zwt + !-----------------------Local Variables--------------------------------- + integer :: i + real(r8) :: MISSING = -99999. !/**< missing value */ + !-----------------------End Variable List------------------------------- + + zwt = MISSING + + ! /** Compute zwt using soil moisture v zwt curve **/ + i = MAX_ZWTVMOIST - 1 + do while (i >= 1 .and. moist > soil_con%zwtvmoist_moist(lindex, i)) + i = i - 1 + enddo + + if (i == MAX_ZWTVMOIST - 1) then + if (moist < soil_con%zwtvmoist_moist(lindex, i)) then + zwt = 999.0 ! 999 indicates water table not present in this layer + else if (moist == soil_con%zwtvmoist_moist(lindex, i)) then + zwt = soil_con%zwtvmoist_zwt(lindex, i) ! Just barely enough water for a water table + endif + else + zwt = soil_con%zwtvmoist_zwt(lindex, i+1) + & + (soil_con%zwtvmoist_zwt(lindex, i) - soil_con%zwtvmoist_zwt(lindex, i+1)) * & + (moist - soil_con%zwtvmoist_moist(lindex, i+1)) / & + (soil_con%zwtvmoist_moist(lindex, i) - soil_con%zwtvmoist_moist(lindex, i+1)) + endif + END SUBROUTINE compute_zwt + + + ! /****************************************************************************** + ! * @brief Function to compute spatial average water table position (zwt) for + ! * individual layers as well as various total-column versions of zwt. + ! * Water table position is measured in cm and is negative below the + ! * soil surface. + ! *****************************************************************************/ + SUBROUTINE wrap_compute_zwt(soil_con, cell) + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + type(cell_data_struct), intent(inout) :: cell + !-----------------------Local Variables--------------------------------- + integer :: lindex + integer :: idx + real(r8) :: total_depth + real(r8) :: tmp_depth + real(r8) :: tmp_moist + integer, parameter :: CM_PER_M = 100 !/**< centimeters per meter */ + real(r8), parameter :: DBL_EPSILON = 2.2204460492503131E-16 + !-----------------------End Variable List------------------------------- + + ! /** Compute total soil column depth **/ + total_depth = 0.0 + do lindex = 1, Nlayer + total_depth = total_depth + soil_con%depth(lindex) + enddo + + ! /** Compute each layer's zwt using soil moisture v zwt curve **/ + do lindex = 1, Nlayer + CALL compute_zwt(soil_con, lindex, cell%layer(lindex)%moist, cell%layer(lindex)%zwt) + enddo + if (cell%layer(Nlayer)%zwt == 999) then + cell%layer(Nlayer)%zwt = -total_depth * CM_PER_M + endif + + ! /** Compute total soil column's zwt; this will be the zwt of the lowest layer that isn't completely saturated **/ + idx = Nlayer + tmp_depth = total_depth + do while (idx >= 1 .and. soil_con%max_moist(idx) - cell%layer(idx)%moist <= DBL_EPSILON) + tmp_depth = tmp_depth - soil_con%depth(idx) + idx = idx - 1 + enddo + if (idx < 1) then + cell%zwt = 0.0 + else if (idx < Nlayer) then + if (cell%layer(idx)%zwt /= 999) then + cell%zwt = cell%layer(idx)%zwt + else + cell%zwt = -tmp_depth * CM_PER_M + endif + else + cell%zwt = cell%layer(idx)%zwt + endif + + ! /** Compute total soil column's zwt_lumped; this will be the zwt of all N layers lumped together. **/ + tmp_moist = 0.0 + do lindex = 1, Nlayer + tmp_moist = tmp_moist + cell%layer(lindex)%moist + enddo + CALL compute_zwt(soil_con, Nlayer + 1, tmp_moist, cell%zwt_lumped) + + if (cell%zwt_lumped == 999) then + cell%zwt_lumped = -total_depth * CM_PER_M ! // in cm; + endif + END SUBROUTINE wrap_compute_zwt +END MODULE MOD_Hydro_VIC diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 new file mode 100644 index 0000000000..4ece3c3d1e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 @@ -0,0 +1,298 @@ +MODULE MOD_Hydro_VIC_Variables + USE MOD_Precision + IMPLICIT NONE + + ! /***** Define the number of layers used in VIC *****/ + integer, parameter :: Nlayer = 3 !/**< Number of soil moisture layers in model */ + integer :: Nfrost = 1 !/**< Number of frost subareas in model */ + + ! /***** Define maximum array sizes for model source code *****/ + integer, parameter :: MAX_LAYERS = 3 !/**< maximum number of soil moisture layers */ + integer, parameter :: MAX_FROST_AREAS = 3 !/**< maximum number of frost sub-areas */ + integer, parameter :: MAX_ZWTVMOIST = 11 !/**< maximum number of points in water table vs moisture curve for each soil layer; should include points at lower and upper boundaries of the layer */ + + ! /***** colm layers to vic layers *****/ + integer, parameter, dimension(:) :: colm2vic_lay(Nlayer) = [3, 6, 10] !/**< colm layers to vic layers */ + + ! /****************************************************************************** + ! * @brief This structure stores all soil variables for each layer in the + ! * soil column. + ! *****************************************************************************/ + type layer_data_struct + real(r8) :: ice(MAX_FROST_AREAS) ! /**< ice content of the frozen sublayer (mm) */ + real(r8) :: moist ! /**< moisture content of the unfrozen sublayer (mm) */ + real(r8) :: evap ! /**< evapotranspiration from soil layer (mm) */ + real(r8) :: zwt ! /**< water table position relative to soil surface within the layer (cm) */ + END type layer_data_struct + + ! /****************************************************************************** + ! * @brief This structure stores soil variables for the complete soil column + ! * for each grid cell. + ! *****************************************************************************/ + type cell_data_struct + real(r8) :: asat ! /**< saturated area fraction */ + real(r8) :: baseflow ! /**< baseflow from current cell (mm/TS) */ + real(r8) :: runoff ! /**< runoff from current cell (mm/TS) */ + type(layer_data_struct) :: layer(MAX_LAYERS) ! /**< structure containing soil variables for each layer (see above) */ + !!! for zwt calcaulation, not used + real(r8) :: zwt ! /**< average water table position [cm] - using lowest unsaturated layer */ + real(r8) :: zwt_lumped ! /**< average water table position [cm] - lumping all layers' moisture together */ + END type cell_data_struct + + ! /****************************************************************************** + ! * @brief This structure stores the soil parameters for a grid cell. + ! *****************************************************************************/ + type soil_con_struct + real(r8) :: frost_fract(MAX_FROST_AREAS) ! /**< spatially distributed frost coverage fractions */ + real(r8) :: max_moist(MAX_LAYERS) ! /**< Maximum moisture content (mm) per layer */ + real(r8) :: resid_moist(MAX_LAYERS) ! /**< Residual moisture content of soil layer (mm) */ + real(r8) :: Ksat(MAX_LAYERS) ! /**< Saturated hydraulic conductivity (mm/day) */ + real(r8) :: expt(MAX_LAYERS) ! /**< Layer-specific exponent n (=3+2/lambda) in Campbell's equation for hydraulic conductivity, HBH 5.6 */ + !!!! to be calibrated + real(r8) :: b_infilt ! /**< Infiltration parameter */ + real(r8) :: Ds ! /**< Fraction of maximum subsurface flow rate */ + real(r8) :: Ws ! /**< Fraction of maximum soil moisture */ + real(r8) :: Dsmax ! /**< Maximum subsurface flow rate (mm/day) */ + real(r8) :: c ! /**< Exponent in ARNO baseflow scheme */ + real(r8) :: depth(MAX_LAYERS) ! /**< Thickness of each soil moisture layer (m) */ + !!! for zwt calculation, not used + ! Bubbling pressure, HBH 5.15 (cm) + real(r8) :: bubble(MAX_LAYERS) + ! Zwt values in the zwt-v-moist curve for each layer. + real(r8) :: zwtvmoist_zwt(MAX_LAYERS + 2, MAX_ZWTVMOIST) + ! Moist values in the zwt-v-moist curve for each layer. + real(r8) :: zwtvmoist_moist(MAX_LAYERS + 2, MAX_ZWTVMOIST) + END type soil_con_struct + +CONTAINS + + + SUBROUTINE vic_para(porsl, theta_r, hksati, bsw, wice_soisno, wliq_soisno, fevpg, rootflux, & + b_infilt, Dsmax, Ds, Ws, c, & + soil_con, cell) + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + + type(soil_con_struct) , intent(inout) :: soil_con + type(cell_data_struct), intent(inout) :: cell + + real(r8), intent(in) :: porsl(1:nl_soil), theta_r(1:nl_soil), hksati(1:nl_soil), bsw(1:nl_soil) + real(r8), intent(in) :: wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil) + real(r8), intent(in) :: fevpg + real(r8), intent(in) :: rootflux(1:nl_soil) + + real(r8), intent(in) :: b_infilt, Dsmax, Ds, Ws, c + real(r8) :: soil_tmp(Nlayer), ice_tmp(Nlayer) + integer :: lb, lp, k, ilay + + real(r8) :: dltime !int(DEF_simulation_time%timestep) + !-----------------------END Variable List------------------------------- + + dltime = DEF_simulation_time%timestep + + CALL CoLM2VIC(dz_soi, soil_tmp) + soil_con%depth = soil_tmp + + CALL CoLM2VIC_weight(porsl, soil_tmp) + ! convert - to mm + soil_con%max_moist = soil_tmp*soil_con%depth*1000 + + CALL CoLM2VIC_weight(theta_r, soil_tmp) + ! convert - to mm + soil_con%resid_moist = soil_tmp*soil_con%depth*1000 + + CALL CoLM2VIC_weight(hksati, soil_tmp) + ! convert mm/s to mm/day + soil_con%Ksat = soil_tmp*86400 + + CALL CoLM2VIC_weight(bsw, soil_tmp) + ! 2*lambda+3 + soil_con%expt = soil_tmp*2+3 + + soil_con%b_infilt = b_infilt + soil_con%Dsmax = Dsmax + soil_con%Ds = Ds + soil_con%Ws = Ws + soil_con%c = c + + soil_con%frost_fract = 1 + IF (sum(wice_soisno)>0) THEN + Nfrost = 3 + DO k = 1, Nfrost + IF (Nfrost == 1) THEN + soil_con%frost_fract(k) = 1.0 + ELSEIF (Nfrost == 2) THEN + soil_con%frost_fract(k) = 0.5 + ELSE + soil_con%frost_fract(k) = 1.0 / real(Nfrost - 1, kind=8) + IF (k == 1 .or. k == Nfrost) THEN + soil_con%frost_fract(k) = soil_con%frost_fract(k) / 2.0 + ENDIF + ENDIF + ENDDO + ENDIF + + CALL CoLM2VIC(wliq_soisno, soil_tmp) + DO ilay = 1, Nlayer + ! mm + cell%layer(ilay)%moist = soil_tmp(ilay) + ENDDO + + DO ilay=1, Nlayer + cell%layer(ilay)%ice(:) = 0 + ENDDO + + IF (sum(wice_soisno)>0) THEN + DO ilay = 1, Nlayer + lp = colm2vic_lay(ilay) + IF (ilay==1) THEN + lb = 1 + ELSE + lb = colm2vic_lay(ilay-1)+1 + ENDIF + CALL VIC_IceLay(lb, lp, wice_soisno(lb:lp), ice_tmp) + cell%layer(ilay)%ice(:) = ice_tmp + ENDDO + ! ELSE + ! DO ilay = 1, Nlayer + ! cell%layer(ilay)%ice(:) = 0 + ! ENDDO + ENDIF + + CALL CoLM2VIC(rootflux, soil_tmp) + ! mm/s*dltime to convert to mm + DO ilay = 1, Nlayer + cell%layer(ilay)%evap = soil_tmp(ilay)*dltime + ENDDO + cell%layer(1)%evap = cell%layer(1)%evap + fevpg*dltime + + END SUBROUTINE vic_para + + + SUBROUTINE VIC_IceLay(lb, lp, colm_ice, vic_ice) + + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + integer , intent(in ) :: lb + integer , intent(in ) :: lp + real(kind=8), intent(in ) :: colm_ice(lb:lp) + real(kind=8), intent(out) :: vic_ice(3) + !-----------------------Local variables--------------------------------- + integer :: idx, colm_lay + real(kind=8) :: totalSum + real(kind=8) :: multiplier + real(kind=8) :: ice_tmp(lp-lb+1) + integer :: vic_lay=3 + !-----------------------END Variable List------------------------------- + + colm_lay = lp - lb + 1 + ice_tmp = colm_ice + totalSum = sum(ice_tmp) + + IF (colm_lay == 1) THEN + vic_ice = totalSum / vic_lay + ELSEIF (colm_lay == 2) THEN + vic_ice(1) = ice_tmp(1) * 2.0 / vic_lay + vic_ice(3) = ice_tmp(2) * 2.0 / vic_lay + ELSEIF (colm_lay == 3) THEN + vic_ice = ice_tmp + ELSE + DO idx = 1, min(int((colm_lay-1)/vic_lay), vic_lay) + multiplier = merge(1.0, 0.0, colm_lay > idx*vic_lay) + vic_ice(1) = vic_ice(1) + ice_tmp(idx) * multiplier + vic_ice(3) = vic_ice(3) + ice_tmp(colm_lay-idx+1) * multiplier + ENDDO + multiplier = merge((colm_lay-idx*vic_lay)/vic_lay, 0, colm_lay <= (idx+1)*vic_lay) + vic_ice(1) = vic_ice(1) + ice_tmp(idx+1) * multiplier + vic_ice(3) = vic_ice(3) + ice_tmp(colm_lay-idx) * multiplier + ENDIF + vic_ice(2) = totalSum - vic_ice(1) - vic_ice(3) + + END SUBROUTINE VIC_Icelay + + + SUBROUTINE CoLM2VIC(colm_water, vic_water) + + USE MOD_Vars_Global + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + real, intent(in ) :: colm_water(1:nl_soil) + real, intent(out) :: vic_water(Nlayer) + !-----------------------Local variables--------------------------------- + integer :: i_colm, i_vic + !-----------------------END Variable List------------------------------- + + DO i_vic = 1, Nlayer + vic_water(i_vic) = 0 + IF (i_vic == 1) THEN + DO i_colm = 1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm) + ENDDO + ELSE + DO i_colm = colm2vic_lay(i_vic-1)+1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE CoLM2VIC + + + SUBROUTINE CoLM2VIC_weight(colm_water, vic_water) + + USE MOD_Vars_Global + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + real, intent(in ) :: colm_water(1:nl_soil) + real, intent(out) :: vic_water(Nlayer) + !-----------------------Local variables--------------------------------- + integer :: i_colm, i_vic + !-----------------------END Variable List------------------------------- + + DO i_vic = 1, Nlayer + vic_water(i_vic) = 0 + IF (i_vic == 1) THEN + DO i_colm = 1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm)*dz_soi(i_colm) + ENDDO + vic_water(i_vic) = vic_water(i_vic)/sum(dz_soi(1:colm2vic_lay(i_vic))) + ELSE + DO i_colm = colm2vic_lay(i_vic-1)+1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm)*dz_soi(i_colm) + ENDDO + vic_water(i_vic) = vic_water(i_vic)/sum(dz_soi(colm2vic_lay(i_vic-1)+1:colm2vic_lay(i_vic))) + ENDIF + ENDDO + + END SUBROUTINE CoLM2VIC_weight + + + SUBROUTINE VIC2CoLM(colm_water, vic_water) + + USE MOD_Vars_Global + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + real, intent(in ) :: vic_water(Nlayer) + real, intent(inout) :: colm_water(1:nl_soil) + !-----------------------Local variables--------------------------------- + integer :: i_colm, i_vic + !-----------------------END Variable List------------------------------- + + DO i_vic = 1, Nlayer + IF (i_vic == 1) THEN + DO i_colm = 1, colm2vic_lay(i_vic) + colm_water(i_colm) = vic_water(i_vic)*(dz_soi(i_colm)/sum(dz_soi(1:colm2vic_lay(i_vic)))) + ENDDO + ELSE + DO i_colm = colm2vic_lay(i_vic-1)+1, colm2vic_lay(i_vic) + colm_water(i_colm) = vic_water(i_vic)*(dz_soi(i_colm)/sum(dz_soi(colm2vic_lay(i_vic-1)+1:colm2vic_lay(i_vic)))) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE VIC2CoLM + + +END MODULE MOD_Hydro_VIC_Variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 new file mode 100644 index 0000000000..bd27bd3051 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 @@ -0,0 +1,291 @@ +#include + +MODULE MOD_Vector_ReadWrite +!----------------------------------------------------------------------- +! DESCRIPTION: +! +! Read/Write data in vector form. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + PUBLIC :: vector_gather_and_write + PUBLIC :: vector_gather_map2grid_and_write + PUBLIC :: vector_read_and_scatter + +CONTAINS + + ! ------- + SUBROUTINE vector_gather_to_master ( & + vector, vlen, totalvlen, data_address, wdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_DataType + IMPLICIT NONE + + real(r8), intent(in) :: vector (:) + integer, intent(in) :: vlen + integer, intent(in) :: totalvlen + + type(pointer_int32_1d), intent(in) :: data_address (0:) + + real(r8), allocatable, intent(inout) :: wdata (:) + + ! Local variables + integer :: iwork, mesg(2), isrc, ndata + real(r8), allocatable :: rcache(:) + + IF (totalvlen <= 0) RETURN + + IF (p_is_master) THEN + allocate (wdata (totalvlen)) + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_worker .and. (.not. p_is_master)) THEN + mesg = (/p_iam_glb, vlen/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (vlen > 0) THEN + CALL mpi_send (vector, vlen, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDIF + + IF (p_is_master) THEN + IF (p_is_worker .and. vlen > 0) THEN + wdata(data_address(p_iam_worker)%val) = vector + ENDIF + + DO iwork = 0, p_np_worker-1 + IF (p_address_worker(iwork) == p_iam_glb) CYCLE + + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate(rcache (ndata)) + + CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + wdata(data_address(p_itis_worker(isrc))%val) = rcache + + deallocate (rcache) + ENDIF + ENDDO + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + wdata(data_address(0)%val) = vector +#endif + + END SUBROUTINE vector_gather_to_master + + ! ------- + SUBROUTINE vector_gather_and_write ( vector, vlen, totalvlen, data_address, & + fileout, varname, dimname, itime_in_file, longname, units) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_NetCDFSerial + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(in) :: vector (:) + integer, intent(in) :: vlen + integer, intent(in) :: totalvlen + + type(pointer_int32_1d), intent(in) :: data_address (0:) + + character(len=*), intent(in) :: fileout + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: dimname + + integer, intent(in), optional :: itime_in_file + character(len=*), intent(in), optional :: longname + character(len=*), intent(in), optional :: units + + ! Local variables + real(r8), allocatable :: wdata(:) + logical :: write_attr + + + CALL vector_gather_to_master (vector, vlen, totalvlen, data_address, wdata) + + IF (p_is_master) THEN + + IF (present(itime_in_file)) THEN + CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata, & + dimname, 'time', DEF_HIST_CompressLevel) + ELSE + CALL ncio_write_serial (fileout, varname, wdata, & + dimname, DEF_REST_CompressLevel) + ENDIF + + IF (present(itime_in_file)) THEN + write_attr = itime_in_file <= 1 + ELSE + write_attr = .true. + ENDIF + + IF (write_attr) THEN + CALL ncio_put_attr (fileout, varname, 'missing_value', spval) + IF (present(longname)) CALL ncio_put_attr (fileout, varname, 'long_name', longname) + IF (present(units )) CALL ncio_put_attr (fileout, varname, 'units', units ) + ENDIF + + deallocate (wdata) + + ENDIF + + END SUBROUTINE vector_gather_and_write + + ! ------- + SUBROUTINE vector_gather_map2grid_and_write ( & + vector, vlen, totalvlen, data_address, nlon, x_vec, nlat, y_vec, & + fileout, varname, lon_name, lat_name, itime_in_file, longname, units) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_NetCDFSerial + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: fileout + real(r8), intent(in) :: vector (:) + integer, intent(in) :: vlen + integer, intent(in) :: totalvlen + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: lon_name, lat_name + + type(pointer_int32_1d), intent(in) :: data_address (0:) + + integer, intent(in) :: nlon, x_vec (:) + integer, intent(in) :: nlat, y_vec (:) + + integer, intent(in), optional :: itime_in_file + character(len=*), intent(in), optional :: longname + character(len=*), intent(in), optional :: units + + ! Local variables + integer :: i + real(r8), allocatable :: wdata(:), wdata2d(:,:) + logical :: write_attr + + CALL vector_gather_to_master (vector, vlen, totalvlen, data_address, wdata) + + IF (p_is_master) THEN + + allocate (wdata2d (nlon,nlat)) + wdata2d(:,:) = spval + + DO i = 1, totalvlen + wdata2d(x_vec(i),y_vec(i)) = wdata(i) + ENDDO + + IF (present(itime_in_file)) THEN + CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata2d, & + lon_name, lat_name, 'time', DEF_HIST_CompressLevel) + ELSE + CALL ncio_write_serial (fileout, varname, wdata2d, & + lon_name, lat_name, DEF_REST_CompressLevel) + ENDIF + + IF (present(itime_in_file)) THEN + write_attr = itime_in_file == 1 + ELSE + write_attr = .true. + ENDIF + + IF (write_attr) THEN + CALL ncio_put_attr (fileout, varname, 'missing_value', spval) + IF (present(longname)) CALL ncio_put_attr (fileout, varname, 'long_name', longname) + IF (present(units )) CALL ncio_put_attr (fileout, varname, 'units', units ) + ENDIF + + deallocate (wdata ) + deallocate (wdata2d) + + ENDIF + + END SUBROUTINE vector_gather_map2grid_and_write + + ! ----- + SUBROUTINE vector_read_and_scatter ( & + filein, vector, vlen, varname, data_address) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_DataType + USE MOD_NetCDFSerial + IMPLICIT NONE + + character(len=*), intent(in) :: filein + real(r8), allocatable, intent(inout) :: vector (:) + integer, intent(in) :: vlen + character(len=*), intent(in) :: varname + type(pointer_int32_1d), intent(in) :: data_address (0:) + + ! Local variables + integer :: iwork, ndata + real(r8), allocatable :: rdata(:), rcache(:) + + IF (p_is_master) THEN + CALL ncio_read_serial (filein, varname, rdata) + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_master) THEN + DO iwork = 0, p_np_worker-1 + IF (allocated(data_address(iwork)%val)) THEN + + ndata = size(data_address(iwork)%val) + allocate(rcache (ndata)) + rcache = rdata(data_address(iwork)%val) + + IF (p_address_worker(iwork) == p_iam_glb) THEN + IF (ndata > 0) THEN + IF (.not. allocated(vector)) allocate(vector(ndata)) + vector = rcache + ENDIF + ELSE + CALL mpi_send (rcache, ndata, MPI_REAL8, & + p_address_worker(iwork), mpi_tag_data, p_comm_glb, p_err) + ENDIF + + deallocate (rcache) + ENDIF + ENDDO + ENDIF + + IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (vlen > 0) THEN + IF (.not. allocated(vector)) allocate(vector(vlen)) + CALL mpi_recv (vector, vlen, MPI_REAL8, p_address_master, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + IF (.not. allocated(vector)) allocate(vector(vlen)) + vector = rdata(data_address(0)%val) +#endif + + IF (p_is_master) deallocate(rdata) + + END SUBROUTINE vector_read_and_scatter + +END MODULE MOD_Vector_ReadWrite diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 new file mode 100644 index 0000000000..729503c858 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 @@ -0,0 +1,162 @@ +#include + +#ifdef LULCC +MODULE MOD_Lulcc_Driver + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LulccDriver + + CONTAINS + + + SUBROUTINE LulccDriver (casename, dir_landdata, dir_restart, & + jdate, greenwich) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! the main subroutine for Land use and land cover change simulation +! +! Created by Hua Yuan, 04/08/2022 +! +! !REVISIONS: +! 07/2023, Wenzong Dong: porting to MPI version. +! 08/2023, Wanyi Lin: add interface for Mass&Energy conserved scheme. +! +!----------------------------------------------------------------------- +! +! ***** For Development ***** +! +! Extra processes when adding a new variable and #define LULCC: +! +! 1. Save a copy of new variable (if called "var", save it to "var_") +! with 2 steps: +! +! 1.1 main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine +! "allocate_LulccTimeVariables": +! allocate (var_(dimension)) +! +! 1.2 main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine +! "SAVE_LulccTimeVariables": +! var_ = var +! +! 2. Reassignment for the next year +! +! 2.1 if used Same Type Assignment (SAT) scheme for variable recovery +! main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine +! "REST_LulccTimeVariables" +! var(np) = var_(np_) +! +! 2.2 if using Mass and Energy conservation (MEC) scheme for variable +! recovery +! +! 2.2.1 main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine +! "REST_LulccTimeVariables": +! var(np) = var_(np_) +! +! 2.2.2 [No need for PFT/PC scheme] Mass and Energy conserve +! adjustment, add after line 519 of MOD_Lulcc_MassEnergyConserve.F90. +! +! o if variable should be mass conserved: +! var(:,np) = var(:,np) + & +! var(:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np +! +! o if variable should be energy conserved, take soil temperature +! "t_soisno" as an example: [May neeed extra calculation] +! t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) + & +! t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k)* & +! lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) +! where cvsoil_ is the heat capacity, wgt is the sum of +! cvsoil_(1:nl_soil,k)*lccpct_np(patchclass_(frnp_(k))), which need to +! be calculated in advance. +! +! 3. Deallocate the copy of new variable in +! MOD_Lulcc_Vars_TimeVariables.F90's subroutine +! "deallocate_LulccTimeVariables": +! deallocate (var_) +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Lulcc_Vars_TimeInvariants + USE MOD_Lulcc_Vars_TimeVariables + USE MOD_Lulcc_Initialize + USE MOD_Vars_TimeVariables + USE MOD_Lulcc_TransferTraceReadin + USE MOD_Lulcc_MassEnergyConserve + USE MOD_Namelist + + IMPLICIT NONE + + character(len=256), intent(in) :: casename !casename name + character(len=256), intent(in) :: dir_landdata !surface data directory + character(len=256), intent(in) :: dir_restart !case restart data directory + + logical, intent(in) :: greenwich !true: greenwich time, false: local time + integer, intent(inout) :: jdate(3) !year, julian day, seconds of the starting time +!----------------------------------------------------------------------- + + ! allocate Lulcc memory + CALL allocate_LulccTimeInvariants + CALL allocate_LulccTimeVariables + + ! SAVE variables + CALL SAVE_LulccTimeInvariants + CALL SAVE_LulccTimeVariables + + ! ============================================================= + ! cold start for Lulcc + ! ============================================================= + + IF (p_is_master) THEN + print *, ">>> LULCC: initializing..." + ENDIF + + CALL LulccInitialize (casename, dir_landdata, dir_restart, & + jdate, greenwich) + + + ! ============================================================= + ! 1. Same Type Assignment (SAT) scheme for variable recovery + ! ============================================================= + + IF (DEF_LULCC_SCHEME == 1) THEN + IF (p_is_master) THEN + print *, ">>> LULCC: Same Type Assignment (SAT) scheme for variable recovery..." + ENDIF + CALL REST_LulccTimeVariables + ENDIF + + + ! ============================================================= + ! 2. Mass and Energy conservation (MEC) scheme for variable recovery + ! ============================================================= + + IF (DEF_LULCC_SCHEME == 2) THEN + IF (p_is_master) THEN + print *, ">>> LULCC: Mass&Energy conserve (MEC) for variable recovery..." + ENDIF + CALL allocate_LulccTransferTrace() + CALL REST_LulccTimeVariables + CALL LulccTransferTraceReadin(jdate(1)) + CALL LulccMassEnergyConserve() + ENDIF + + + ! deallocate Lulcc memory + CALL deallocate_LulccTimeInvariants() + CALL deallocate_LulccTimeVariables() + IF (DEF_LULCC_SCHEME == 2) THEN + CALL deallocate_LulccTransferTrace() + ENDIF + + END SUBROUTINE LulccDriver + +END MODULE MOD_Lulcc_Driver +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 new file mode 100644 index 0000000000..7b260a81ab --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 @@ -0,0 +1,138 @@ +#include +#ifdef LULCC +MODULE MOD_Lulcc_Initialize + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LulccInitialize + +CONTAINS + + SUBROUTINE LulccInitialize (casename, dir_landdata, dir_restart, & + jdate, greenwich) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Initialization routine for Land-use-Land-cover-change (Lulcc) case +! +! Created by Hua Yuan, 04/08/2022 +! +! !REVISIONS: +! 08/2023, Wenzong Dong: Porting to MPI version and share the same code +! with MOD_Initialize:initialize() +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif + USE MOD_LandUrban + USE MOD_Const_LC + USE MOD_Const_PFT + USE MOD_TimeManager + USE MOD_Lulcc_Vars_TimeInvariants + USE MOD_Lulcc_Vars_TimeVariables + USE MOD_SrfdataRestart + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Initialize + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + character(len=*), intent(in) :: casename ! case name + character(len=*), intent(in) :: dir_landdata + character(len=*), intent(in) :: dir_restart + + integer, intent(inout) :: jdate(3) ! year, julian day, seconds of the starting time + logical, intent(in) :: greenwich ! true: greenwich time, false: local time + +!-------------------------- Local Variables ---------------------------- + integer :: year, jday + +!----------------------------------------------------------------------- + + ! initial time of model run and consts + year = jdate(1) + jday = jdate(2) + + CALL Init_GlobalVars + CALL Init_LC_Const + CALL Init_PFT_Const + + ! deallocate pixelset and mesh data of previous year + CALL mesh_free_mem + CALL landelm%forc_free_mem + CALL landpatch%forc_free_mem +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL landpft%forc_free_mem +#endif +#ifdef URBAN_MODEL + CALL landurban%forc_free_mem +#endif + + ! load pixelset and mesh data of next year + ! CALL pixel%load_from_file (dir_landdata) + ! CALL gblock%load_from_file (dir_landdata) + CALL mesh_load_from_file (dir_landdata, year) + CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , year) + + ! load CATCHMENT of next year +#ifdef CATCHMENT + CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , year) +#endif + + ! load landpatch data of next year + CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, year) + + ! load pft data of PFT/PC of next year +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , year) + CALL map_patch_to_pft +#endif + + ! load urban data of next year +#ifdef URBAN_MODEL + CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, year) + CALL map_patch_to_urban +#endif + + ! initialize for data associated with land element +#if (defined UNSTRUCTURED || defined CATCHMENT) + CALL elm_vector_init () +#ifdef CATCHMENT + CALL hru_vector_init () +#endif +#endif + + ! build element subfraction of next year which it's needed in the MOD_Lulcc_TransferTrace + IF (p_is_worker) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + ENDIF + + + ! -------------------------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + CALL deallocate_TimeInvariants + CALL deallocate_TimeVariables + + ! initialize all state variables of next year + CALL initialize (casename, dir_landdata, dir_restart,& + jdate, year, greenwich, lulcc_call=.true.) + + END SUBROUTINE LulccInitialize + +END MODULE MOD_Lulcc_Initialize +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 new file mode 100644 index 0000000000..6909cbcabf --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 @@ -0,0 +1,1165 @@ +#include + +#ifdef LULCC +MODULE MOD_Lulcc_MassEnergyConserve + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LulccMassEnergyConserve + +CONTAINS + + + SUBROUTINE LulccMassEnergyConserve + +!----------------------------------------------------------------------- +! +! !DESCRIPTION +! This is the main subroutine to execute the calculation of the restart +! variables for the begin of next year. There are mainly three ways to +! adjust restart variables: +! +! 1) variable related to mass: area weighted mean of the source +! patches, e.g., ldew, wliq_soisno. variable related to energy: keep +! energy conserve after the change of temperature, e.g., t_soisno. +! +! 2) recalculate according to physical process, e.g., dz_sno, scv, +! fsno. +! +! Created by Wanyi Lin and Hua Yuan, 07/2023 +! +! !REVISIONS: +! +! 10/2023, Wanyi Lin: share the codes with REST_LulccTimeVariables(), +! and simplify the codes in this subroutine. +! +! 01/2024, Wanyi Lin: use "enthalpy conservation" for snow layer +! temperature calculation. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_LandElm + USE MOD_Mesh + USE MOD_SPMD_Task + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Lulcc_Vars_TimeInvariants + USE MOD_Lulcc_Vars_TimeVariables + USE MOD_Lulcc_TransferTraceReadin +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif +#ifdef URBAN_MODEL + USE MOD_LandUrban + USE MOD_Urban_Vars_TimeVariables + USE MOD_Urban_Vars_TimeInvariants +#endif + USE MOD_Const_Physical, only: cpice, cpliq, hfus, tfrz, denh2o, denice + USE MOD_GroundTemperature + USE MOD_SnowFraction + USE MOD_Albedo + USE MOD_Namelist + USE MOD_Hydro_SoilWater + + IMPLICIT NONE + +!-------------------------- Local Variables ---------------------------- + integer, allocatable, dimension(:) :: grid_patch_s , grid_patch_e + integer, allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ + integer, allocatable, dimension(:) :: locpxl + integer :: numpxl,ipxl + + integer, allocatable :: frnp_(:) !index of source patches + integer, allocatable :: gu_(:) !index of urban patches in last year's grid + real(r8),allocatable :: cvsoil_(:,:) !heat capacity [J/(m2 K)] + real(r8),allocatable :: h_(:,:) !enthalpy of source patches [J/m2] + + integer :: k, ilc, num, inp_ + integer :: i, j, np, np_, selfnp_, l, ipft, ip, ip_, pc, pc_ + integer :: nsl !number of snow layer of the source patch with maximum area + integer :: nsl_max !maximum number of snow layer considering all source patches + integer :: u, u_, iu, selfu_, nurb, duclass + integer :: nlc = N_land_classification + integer :: ps, pe, ps_, pe_ !start and end index of patch pft + + real(r8), dimension(1:N_land_classification) :: lccpct_np + real(r8):: sum_lccpct_np, wgt(maxsnl+1:nl_soil), hc(maxsnl+1:0) + real(r8):: zi_sno(maxsnl+1:0) !local variable for snow node and depth calculation + real(r8):: vf_water !volumetric fraction liquid water within soil + real(r8):: vf_ice !volumetric fraction ice lens within soil + real(r8):: hcap !J/(m3 K) + real(r8):: c_water !Specific heat of water * density of liquid water + real(r8):: c_ice !Specific heat of ice * density of ice + real(r8):: denice_np(maxsnl+1:0), denh2o_np(maxsnl+1:0), rhosnow_np(maxsnl+1:0) + real(r8):: wbef,wpre !water before and water present for water calculation heck + ! real(r8):: fmelt !dimensionless melting factor + real(r8):: wt !fraction of vegetation covered with snow [-] + real(r8), parameter :: m = 1.0 !the value of m used in CLM4.5 is 1.0. + ! real(r8) :: deltim = 1800. !time step (seconds) TODO: be intent in + logical :: FROM_SOIL, FOUND + + ! update for zwt, wa, ldew + real(r8) :: tolerance, tol_z, tol_v, zi_soisno(0:nl_soil), sp_zi(0:nl_soil), sp_dz(1:nl_soil) +#ifdef Campbell_SOIL_MODEL + integer, parameter :: nprms = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: nprms = 5 +#endif + real(r8) :: prms(nprms, 1:nl_soil) + real(r8) :: ldew_tmp +!----------------------------------------------------------------------- + + IF (p_is_worker) THEN + + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + allocate(grid_patch_s_(numelm_)) + allocate(grid_patch_e_(numelm_)) + + grid_patch_e (:) = -1 + grid_patch_s (:) = -1 + grid_patch_e_(:) = -1 + grid_patch_s_(:) = -1 + + ! loop for numelm of next year, patches at the beginning and end of + ! the element were recorded landpatch%eindex is arranged in order, + ! and the not land element is skipped so, if element is missing, the + ! recorder is -1. + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO + + ! same as above, loop for numelm of previous year + ! patches at the beginning and end of the element were recorded + DO i=1, numelm_ + numpxl = count(landpatch_%eindex==landelm_%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + locpxl = pack([(ipxl, ipxl=1, numpatch_)], landpatch_%eindex==landelm_%eindex(i)) + + grid_patch_s_(i) = minval(locpxl) + grid_patch_e_(i) = maxval(locpxl) + ENDDO + + DO i=1, numelm + DO j=1,numelm_ + IF (landelm%eindex(i) == landelm_%eindex(j)) THEN + np = grid_patch_s (i) + np_= grid_patch_s_(j) + + IF (np.le.0) CYCLE + + DO WHILE (np.le.grid_patch_e(i)) + +IF (patchtype(np) .ne. 3) THEN !not a glacier patch + +IF (DEF_USE_PFT .or. DEF_FAST_PC) THEN + lccpct_np(:) = 0 + lccpct_np(1) = sum(lccpct_patches(np,1:), mask=patchtypes(:)==0) + lccpct_np(URBAN ) = lccpct_patches(np,URBAN ) + lccpct_np(WETLAND) = lccpct_patches(np,WETLAND) + lccpct_np(WATERBODY) = lccpct_patches(np,WATERBODY) + lccpct_np(GLACIERS) = lccpct_patches(np,GLACIERS) + + !TODO: treat cropland separately for FAST_PC + IF ( DEF_FAST_PC ) THEN + lccpct_np(CROPLAND) = lccpct_patches(np,CROPLAND) & + + lccpct_patches(np,14) + lccpct_np(1) = lccpct_np(1) - lccpct_np(CROPLAND) + ENDIF +ELSE + lccpct_np(:) = lccpct_patches(np,1:nlc) +ENDIF + + num = count(lccpct_np .gt. 0) + sum_lccpct_np = sum(lccpct_np) + allocate ( frnp_ ( num)) + allocate ( cvsoil_(maxsnl+1:nl_soil,num)) + allocate ( h_ (maxsnl+1:0, num)) + + ! Source patch type which differs from np's type exists + IF ( (sum_lccpct_np - lccpct_np(patchclass(np))) .gt. 0 ) THEN + + ! Get the index of source patches, and stored as frnp_ + k = 0 + DO ilc = 1, nlc + + IF (lccpct_np(ilc) .gt. 0) THEN + FOUND = .FALSE. + k = k + 1 + inp_ = np_ + + DO WHILE (inp_ .le. grid_patch_e_(j)) + + ! Get the index of source patch that has the + ! same LC, and stored as selfnp_ + IF (patchclass_(inp_) .eq. patchclass(np)) THEN + selfnp_ = inp_ + ENDIF + + IF (patchclass_(inp_) .eq. ilc) THEN + frnp_(k) = inp_ + FOUND = .TRUE. + EXIT + ENDIF + inp_ = inp_ + 1 + ENDDO + IF (.not.(FOUND)) THEN + PRINT*, 'source patch not found, np', np, 'patchclass_', & + patchclass_(grid_patch_s_(j):grid_patch_e_(j)) + ENDIF + ELSE + CYCLE + ENDIF + ENDDO + + ! Initialize + wliq_soisno (:,np) = 0 !liquid water in layers [kg/m2] + wice_soisno (:,np) = 0 !ice lens in layers [kg/m2] + t_soisno (:,np) = 0 !soil + snow layer temperature [K] + z_sno (:,np) = 0 !node depth [m] + dz_sno (:,np) = 0 !interface depth [m] + t_grnd (np) = 0 !ground surface temperature [K] + tleaf (np) = 0 !leaf temperature [K] + ldew (np) = 0 !depth of water on foliage [mm] + ldew_rain (np) = 0 !depth of rain on foliage [mm] + ldew_snow (np) = 0 !depth of snow on foliage [mm] + sag (np) = 0 !non dimensional snow age [-] + scv (np) = 0 !snow cover, water equivalent [mm] + snowdp (np) = 0 !snow depth [meter] + fsno (np) = 0 !frac of snow cover on ground + sigf (np) = 0 !frac of veg cover, exclud snow-covered veg [-] + zwt (np) = 0 !the depth to water table [m] + wa (np) = 0 !water storage in aquifer [mm] + wdsrf (np) = 0 !depth of surface water [mm] + smp (:,np) = 0 !soil matrix potential [mm] + hk (:,np) = 0 !hydraulic conductivity [mm h2o/s] + + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp (:,np) = 0 !vegetation water potential [mm] + gs0sun (np) = 0 !working copy of sunlit stomata conductance + gs0sha (np) = 0 !working copy of shaded stomata conductance + ENDIF + + IF(DEF_USE_OZONESTRESS)THEN + lai_old (np) = 0 !lai in last time step + ENDIF + + snw_rds (:,np) = 0 !effective grain radius (col,lyr) [microns, m-6] + mss_bcpho (:,np) = 0 !mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (:,np) = 0 !mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (:,np) = 0 !mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (:,np) = 0 !mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (:,np) = 0 !mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (:,np) = 0 !mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (:,np) = 0 !mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (:,np) = 0 !mass of dust species 4 in snow (col,lyr) [kg] + ssno_lyr(:,:,:,np) = 0 !snow layer absorption [-] + + trad (np) = 0 !radiative temperature of surface [K] + tref (np) = 0 !2 m height air temperature [kelvin] + qref (np) = 0 !2 m height air specific humidity + rst (np) = 0 !canopy stomatal resistance (s/m) + emis (np) = 0 !averaged bulk surface emissivity + z0m (np) = 0 !effective roughness [m] + zol (np) = 0 !dimensionless height (z/L) used in M-O theory + rib (np) = 0 !bulk Richardson number in surface layer + ustar (np) = 0 !u* in similarity theory [m/s] + qstar (np) = 0 !q* in similarity theory [kg/kg] + tstar (np) = 0 !t* in similarity theory [K] + fm (np) = 0 !integral of profile function for momentum + fh (np) = 0 !integral of profile function for heat + fq (np) = 0 !integral of profile function for moisture + + + ! ============================================================= + ! 1) Mass and Energy conserve adjustment (except for dz_sno). + ! ============================================================= + + ! Calculate the weight of temperature adjustment + c_water = cpliq * denh2o ! J/(m3 K) = 4188 [J/(kg K)]*1000(kg/m3) + c_ice = cpice * denice ! J/(m3 K) = 2117.27[J/(kg K)]*917 (kg/m3) + cvsoil_(:,:) = 0 + h_ (:,:) = 0 + wgt(maxsnl+1:nl_soil) = 0 + hc (maxsnl+1:0 ) = 0 + + DO k = 1, num + + ! Soil ground and wetland heat capacity from: MOD_GroundTemperature.F90 + DO l = 1, nl_soil + vf_water = wliq_soisno_(l,frnp_(k))/(dz_soi(l)*denh2o) + vf_ice = wice_soisno_(l,frnp_(k))/(dz_soi(l)*denice) + hcap = csol_(l,frnp_(k)) + vf_water*c_water + vf_ice*c_ice + cvsoil_(l,k) = hcap*dz_soi(l) + ENDDO + + ! no snow layer exist + IF( dz_sno_(0,frnp_(k))<1.e-6 .and. scv_(frnp_(k))>0.) THEN + cvsoil_(1,k) = cvsoil_(1,k) + cpice*scv_(frnp_(k)) + ENDIF + + ! Snow heat capacity + IF( z_sno_(0,frnp_(k)) < 0 ) THEN + cvsoil_(:0,k) = cpliq*wliq_soisno_(:0,frnp_(k)) & + + cpice*wice_soisno_(:0,frnp_(k)) + h_(:0,k) = (cpliq*wliq_soisno_(:0,frnp_(k)) + & + cpice*wice_soisno_(:0,frnp_(k))) & + * (t_soisno_(:0,frnp_(k)) - tfrz) & + + hfus*wliq_soisno_(:0,frnp_(k)) + ENDIF + + wgt(maxsnl+1:nl_soil) = wgt(maxsnl+1:nl_soil) & + + cvsoil_(maxsnl+1:nl_soil,k) * lccpct_np(patchclass_(frnp_(k))) + hc(:0) = hc(:0) & + + h_(:0,k) * lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np + ENDDO + + ! Get the maximum lccpct for snow layers assignment + inp_ = frnp_(1) + k = 2 + DO WHILE (k .le. num) + IF ( lccpct_np(patchclass_(frnp_(k))) & + .gt. lccpct_np(patchclass_(inp_)) ) THEN + inp_ = frnp_(k) + ENDIF + k = k + 1 + ENDDO + + ! check if snow layer exist in patch inp_ + nsl = count(z_sno_(:,inp_) .lt. 0) + nsl_max = count(wgt(:0) .gt. 0) + ! denh2o_np(maxsnl+1:0) = 0 + ! denice_np(maxsnl+1:0) = 0 + rhosnow_np(maxsnl+1:0) = 0 ! partial density of water/snow (ice + liquid) + + IF (nsl > 0) THEN + ! move wgt above nsl to nsl + IF ( nsl_max > nsl) THEN + DO l = nsl+1, nsl_max + wgt(-nsl+1) = wgt(-nsl+1) + wgt(-l+1) + hc (-nsl+1) = hc (-nsl+1) + hc (-l+1) + ENDDO + ENDIF + + DO k = 1, num + + t_soisno (-nsl+1:0,np) = t_soisno (-nsl+1:0,np) & + + t_soisno_(-nsl+1:0,frnp_(k))*cvsoil_(-nsl+1:0,k) & + * lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1:0) + wliq_soisno (-nsl+1:0,np) = wliq_soisno (-nsl+1:0,np) & + + wliq_soisno_(-nsl+1:0,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno (-nsl+1:0,np) = wice_soisno (-nsl+1:0,np) & + + wice_soisno_(-nsl+1:0,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + l = 1 + DO WHILE ( (l .le. nsl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + ! denh2o_np (-l+1) = denh2o_np(-l+1) & + ! + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ! denice_np (-l+1) = denice_np(-l+1) & + ! + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! Reference: MOD_GroundTemperature.F90 Line205 + rhosnow_np (-l+1) = rhosnow_np(-l+1) & + + (wliq_soisno_(-l+1,frnp_(k)) + wice_soisno_(-l+1,frnp_(k))) & + / dz_sno_(-l+1,frnp_(k)) & + * (lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np) + l = l + 1 + IF (l .gt. -maxsnl) EXIT + ENDDO + + ! if source patch has more snow layer than the main patch + IF (nsl .lt. -maxsnl) THEN + l = nsl+1 + DO WHILE ( (l .le. -maxsnl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + + wliq_soisno(-nsl+1,np) = wliq_soisno (-nsl+1,np) & + + wliq_soisno_(-l+1,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno(-nsl+1,np) = wice_soisno (-nsl+1,np) & + + wice_soisno_(-l+1,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + t_soisno (-nsl+1,np) = t_soisno (-nsl+1,np) & + + t_soisno_(-l+1,frnp_(k))*cvsoil_(-l+1,k) & + * lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1) + + ! denh2o_np (-nsl+1) = denh2o_np(-nsl+1) & + ! + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ! denice_np (-nsl+1) = denice_np(-nsl+1) & + ! + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rhosnow_np (-nsl+1) = rhosnow_np(-nsl+1) & + + (wliq_soisno_(-l+1,frnp_(k))+wice_soisno_(-l+1,frnp_(k))) & + / dz_sno_(-l+1,frnp_(k)) & + * (lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np) + l = l + 1 + IF (l .gt. -maxsnl) EXIT + ENDDO + ENDIF + ENDDO + + + + ! snow layer node and depth calculation according to new mass and density + zi_sno(0) = 0._r8 + DO l = 0, -nsl+1, -1 + + ! IF (denice_np(l)>0 .and. denh2o_np(l)>0) THEN + ! dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) & + ! + wliq_soisno(l,np)/denh2o_np(l) + + ! ELSEIF (denice_np(l)==0 .and. denh2o_np(l)>0) THEN + ! dz_sno (l,np) = wliq_soisno(l,np)/denh2o_np(l) + ! ! print*, 'denice=0! np=',np,'igbp=',patchclass(np),& + ! 'nsl=',nsl,'frnp_=',frnp_ + ! ! DO k = 1,num + ! ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ! ENDDO + + ! ELSEIF (denh2o_np(l)==0 .and. denice_np(l)>0) THEN + ! dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) + ! ! print*, 'denh2o=0! np=',np,'igbp=',patchclass(np),& + ! 'nsl=',nsl,'frnp_=',frnp_ + ! ! DO k = 1,num + ! ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! ! ENDDO + + ! ELSE + ! print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),& + ! 'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ENDDO + ! CALL CoLM_stop() + ! ENDIF + + + ! Reference: MOD_SnowLayersCombineDivide.F90's subroutine combo + IF (hc(l) < 0.) THEN + t_soisno (l,np) = tfrz + hc(l) / (cpice*wice_soisno(l,np) & + + cpliq*wliq_soisno(l,np)) + ELSEIF (hc(l) .le. hfus*wliq_soisno(l,np)) THEN + t_soisno (l,np) = tfrz + ELSE + t_soisno (l,np) = tfrz + (hc(l) - hfus*wliq_soisno(l,np)) & + / (cpice*wice_soisno(l,np)+cpliq*wliq_soisno(l,np)) + ENDIF + + + dz_sno (l,np) = (wice_soisno(l,np) + wliq_soisno(l,np))/rhosnow_np(l) + + z_sno (l,np) = zi_sno(l) - 0.5_r8*dz_sno(l,np) + IF (l-1 .lt. maxsnl+1) EXIT + zi_sno (l-1) = zi_sno(l) - dz_sno(l,np) + + ENDDO + + ELSE + ! no snow layer exist in the main patch, add a layer + ! move wgt above soil to layer 0 + IF ( nsl_max > nsl) THEN + DO l = nsl+1, nsl_max + wgt(0) = wgt(0) + wgt(-l+1) + ENDDO + ENDIF + + l = 0 + DO WHILE (wgt(l) .gt. 0) + DO k = 1, num + + wliq_soisno(0,np) = wliq_soisno(0,np) & + + wliq_soisno_(l,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno(0,np) = wice_soisno(0,np) & + + wice_soisno_(l,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + t_soisno (0,np) = t_soisno (0,np) & + + t_soisno_(l,frnp_(k))*cvsoil_(l,k) & + * lccpct_np(patchclass_(frnp_(k)))/wgt(0) + + IF (dz_sno_(l,frnp_(k)) .gt. 0) THEN + ! denh2o_np(0) = denh2o_np(0) & + ! + wliq_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ! denice_np(0) = denice_np(0) & + ! + wice_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rhosnow_np(0) = rhosnow_np(0) & + + (wliq_soisno_(l,frnp_(k)) + wice_soisno_(l,frnp_(k))) & + / dz_sno_(l,frnp_(k)) & + * (lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np) + ENDIF + ENDDO + + l = l-1 + IF (l .lt. maxsnl+1) EXIT + ENDDO + + IF (wgt(0) .gt. 0) THEN + + ! snow layer node and depth calculation according to + ! new mass and density + ! IF (denh2o_np(0)>0 .and. denh2o_np(0)>0) THEN + ! dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) & + ! + wliq_soisno(0,np)/denh2o_np(0) + ! ELSEIF (denice_np(0)==0 .and. denh2o_np(0)>0) THEN + ! dz_sno (0,np) = wliq_soisno(0,np)/denh2o_np(0) + ! ! print*, 'denice=0! stop! np=',np,'igbp=',patchclass(np),& + ! 'nsl=',nsl,'frnp_=',frnp_ + ! ! DO k = 1,num + ! ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ! ENDDO + ! ELSEIF (denice_np(0)>0 .and. denh2o_np(0)==0) THEN + ! dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) + ! ! print*, 'denh2o=0! stop! np=',np,'igbp=',patchclass(np),& + ! 'nsl=',nsl,'frnp_=',frnp_ + ! ! DO k = 1,num + ! ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! ! ENDDO + ! ELSE + ! print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),& + ! 'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ENDDO + ! CALL CoLM_stop() + ! ENDIF + + + ! Reference: MOD_SnowLayersCombineDivide.F90's subroutine combo + IF (hc(0) < 0.) THEN + t_soisno (0,np) = tfrz & + + hc(0) / (cpice*wice_soisno(0,np) + cpliq*wliq_soisno(0,np)) + ELSEIF (hc(0) .le. hfus*wliq_soisno(0,np)) THEN + t_soisno (0,np) = tfrz + ELSE + t_soisno (0,np) = tfrz + (hc(0) - hfus*wliq_soisno(0,np)) & + / (cpice*wice_soisno(0,np)+cpliq*wliq_soisno(0,np)) + ENDIF + + dz_sno (0,np) = (wice_soisno(0,np) + wliq_soisno(0,np))/rhosnow_np(0) + + zi_sno (0) = 0._r8 + z_sno (0,np) = zi_sno(0) - 0.5_r8*dz_sno(0,np) + ENDIF + + ENDIF + + + ! Variable adjustment + DO k = 1, num + + wliq_soisno (1:nl_soil,np) = wliq_soisno (1:nl_soil,np) & + + wliq_soisno_(1:nl_soil,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno (1:nl_soil,np) = wice_soisno (1:nl_soil,np) & + + wice_soisno_(1:nl_soil,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) & + + t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k) & + * lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) + + tleaf (np) = tleaf (np) + tleaf_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew (np) = ldew (np) + ldew_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew_rain (np) = ldew_rain (np) + ldew_rain_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew_snow (np) = ldew_snow (np) + ldew_snow_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + sag (np) = sag (np) + sag_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! TODO: use MOD_SnowFraction.F90 to calculate sigf later - DONE + ! sigf (np) = sigf (np) + sigf_ (frnp_(k)) & + ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wa (np) = wa (np) + wa_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wdsrf (np) = wdsrf (np) + wdsrf_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + zwt (np) = zwt (np) + zwt_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + + snw_rds (:,np) = snw_rds (:,np) + snw_rds_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_bcpho (:,np) = mss_bcpho (:,np) + mss_bcpho_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_bcphi (:,np) = mss_bcphi (:,np) + mss_bcphi_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_ocpho (:,np) = mss_ocpho (:,np) + mss_ocpho_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_ocphi (:,np) = mss_ocphi (:,np) + mss_ocphi_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst1 (:,np) = mss_dst1 (:,np) + mss_dst1_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst2 (:,np) = mss_dst2 (:,np) + mss_dst2_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst3 (:,np) = mss_dst3 (:,np) + mss_dst3_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst4 (:,np) = mss_dst4 (:,np) + mss_dst4_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ssno_lyr (:,:,:,np) = ssno_lyr (:,:,:,np) + ssno_lyr_ (:,:,:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! TODO: or use same type assignment + smp (:,np) = smp (:,np) + smp_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + hk (:,np) = hk (:,np) + hk_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp (:,np) = vegwp (:,np) + vegwp_ (:,frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + gs0sun (np) = gs0sun (np) + gs0sun_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + gs0sha (np) = gs0sha (np) + gs0sha_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + + IF(DEF_USE_OZONESTRESS)THEN + lai_old (np) = lai_old (np) + lai_old_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + + trad (np) = trad (np) + trad_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + tref (np) = tref (np) + tref_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + qref (np) = qref (np) + qref_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rst (np) = rst (np) + rst_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + emis (np) = emis (np) + emis_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + z0m (np) = z0m (np) + z0m_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + zol (np) = zol (np) + zol_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rib (np) = rib (np) + rib_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ustar (np) = ustar (np) + ustar_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + qstar (np) = qstar (np) + qstar_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + tstar (np) = tstar (np) + tstar_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fm (np) = fm (np) + fm_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fh (np) = fh (np) + fh_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fq (np) = fq (np) + fq_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO + + ! water balance check + wbef = 0 + wpre = 0 + DO k = 1, num + wbef = wbef + ldew_(frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + scv_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + wa_ (frnp_(k)) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k))) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k))) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO + + wpre = ldew(np) + scv(np) + wa(np) + sum(wliq_soisno(maxsnl+1:nl_soil,np)) & + + sum(wice_soisno(maxsnl+1:nl_soil,np)) + IF (wpre-wbef > 1.e-6) THEN + print*,'np=',np,'total err=',wpre-wbef + ENDIF + + wbef = 0 + wpre = 0 + DO k = 1, num + wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k))) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k))) & + * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO + + wpre = sum(wliq_soisno(maxsnl+1:nl_soil,np)) & + + sum(wice_soisno(maxsnl+1:nl_soil,np)) + IF (wpre-wbef > 1.e-6) THEN + print*,'np=',np,'wice+wliq err=',wpre-wbef + ENDIF + + + ! ============================================================= + ! 2) adjusted based on code of physical process. + ! ============================================================= + + DO l = maxsnl+1, 0 + IF ( z_sno(l,np) .lt. 0 ) THEN + scv(np) = scv(np) + wice_soisno(l,np) + wliq_soisno(l,np) + snowdp(np) = snowdp(np) + dz_sno(l,np) + ENDIF + ENDDO + + ! Use restart value from the same type of + ! source patch or remain initialized + ! IF (lccpct_np(patchclass(np)) .gt. 0) THEN + ! tleaf (np) = tleaf_ (selfnp_) + ! lake_icefrac(:,np) = lake_icefrac_(:,selfnp_) + ! t_lake (:,np) = t_lake_ (:,selfnp_) + ! ENDIF + + ! Fraction of soil covered by snow + zlnd = 0.01 !Roughness length for soil [m] + ! fsno(np) = 0.0 + ! IF (snowdp(np) > 0.) THEN + ! fmelt = (scv(np)/snowdp(np)/100.) ** m + ! fsno(np) = tanh(snowdp(np)/(2.5 * zlnd * fmelt)) + ! ENDIF + + ! Sigf, fsno + CALL snowfraction (tlai(np),tsai(np),z0m(np),zlnd,& + scv(np),snowdp(np),wt,sigf(np),fsno(np)) + sai(np) = tsai(np) * sigf(np) + + ! account for vegetation snow + IF ( DEF_VEG_SNOW ) THEN + lai(np) = tlai(np) * sigf(np) + ENDIF + + ! ! In case lai+sai come into existence this year, set sigf to 1; + ! Update: won't happen if CALL snowfraction + ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN + ! sigf(np) = 1 + ! ENDIF + + ! Set Groud temperature + IF ( sum( z_sno(:,np) ) .eq. 0 ) THEN + t_grnd(np) = t_soisno(1,np) + ELSE + DO k = maxsnl+1, 0 + IF ( z_sno(k,np) .lt. 0 ) THEN + t_grnd(np) = t_soisno(k,np) + EXIT + ENDIF + ENDDO + ENDIF + + + ! Zwt calculation suggested by Shupeng Zhang + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (wa(np) >= 0) THEN + DO l = nl_soil, 1, -1 + vf_water = (wliq_soisno(l,np)/denh2o) / dz_soi(l) + vf_ice = (wice_soisno(l,np)/denice) / dz_soi(l) + IF ((vf_water + vf_ice) < porsl(l,np)) THEN ! fraction of soil that is voids [-] + zwt(np) = zi_soi(l) ! interface depths (lower bound) of soil layers + EXIT + ELSEIF (l==1) THEN + zwt(np) = 0 + ENDIF + ENDDO + ELSE + PRINT*, 'Water table is below the soil column.' +#ifdef Campbell_SOIL_MODEL + prms(1,1:nl_soil) = bsw(1:nl_soil,np) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,np) + prms(2,1:nl_soil) = n_vgm (1:nl_soil,np) + prms(3,1:nl_soil) = L_vgm (1:nl_soil,np) + prms(4,1:nl_soil) = sc_vgm (1:nl_soil,np) + prms(5,1:nl_soil) = fc_vgm (1:nl_soil,np) +#endif + + tolerance = 1.e-3 + tol_z = tolerance / real(nl_soil,r8) /2.0 + zi_soisno = (/0., zi_soi/) + sp_zi(0:nl_soil) = zi_soisno(0:nl_soil) * 1000.0 ! from meter to mm + sp_dz(1:nl_soil) = sp_zi(1:nl_soil) - sp_zi(0:nl_soil-1) + tol_v = tol_z / maxval(sp_dz) + CALL get_zwt_from_wa(porsl(nl_soil,np), theta_r(nl_soil,np), psi0(nl_soil,np), hksati(nl_soil,np), & + nprms, prms(:,nl_soil), tol_v, tol_z, wa(np), sp_zi(nl_soil), zwt(np) ) + ENDIF + ENDIF + + + ! ELSE + ! ! Patch area stay unchanged or decrease, + ! use restart value or remain initialized + ! ! TODO: CALL REST - DONE + ! inp_ = np_ + ! DO WHILE (inp_ .le. grid_patch_e_(j)) + ! IF (patchclass_(inp_) .eq. patchclass(np)) THEN + ! selfnp_ = inp_ + ! frnp_(1) = inp_ + ! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) + ! wice_soisno (:,np) = wice_soisno_ (:,inp_) + ! t_soisno (:,np) = t_soisno_ (:,inp_) + ! z_sno (:,np) = z_sno_ (:,inp_) + ! dz_sno (:,np) = dz_sno_ (:,inp_) + ! t_grnd (np) = t_grnd_ (inp_) + ! tleaf (np) = tleaf_ (inp_) + ! ldew (np) = ldew_ (inp_) + ! sag (np) = sag_ (inp_) + ! scv (np) = scv_ (inp_) + ! snowdp (np) = snowdp_ (inp_) + ! fsno (np) = fsno_ (inp_) + ! sigf (np) = sigf_ (inp_) + ! ! In case lai+sai come into existence this year, set sigf to 1 + ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN + ! sigf(np) = 1 + ! ENDIF + ! zwt (np) = zwt_ (inp_) + ! wa (np) = wa_ (inp_) + ! EXIT + ! ENDIF + ! + ! inp_ = inp_ + 1 + ! ENDDO + + ENDIF + +! ELSEIF (patchtype(np)==3) THEN !glacier patch +! ! Used restart value for GLACIERS patches if patchclass exists last year, +! ! or remain initialized +! ! TODO: CALL REST - DONE +! inp_ = np_ +! DO WHILE (inp_ .le. grid_patch_e_(j)) +! IF (patchclass_(inp_) .eq. patchclass(np)) THEN +! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) +! wice_soisno (:,np) = wice_soisno_ (:,inp_) +! t_soisno (:,np) = t_soisno_ (:,inp_) +! z_sno (:,np) = z_sno_ (:,inp_) +! dz_sno (:,np) = dz_sno_ (:,inp_) +! t_grnd (np) = t_grnd_ (inp_) +! tleaf (np) = tleaf_ (inp_) +! ldew (np) = ldew_ (inp_) +! sag (np) = sag_ (inp_) +! scv (np) = scv_ (inp_) +! snowdp (np) = snowdp_ (inp_) +! fsno (np) = fsno_ (inp_) +! sigf (np) = sigf_ (inp_) +! zwt (np) = zwt_ (inp_) +! wa (np) = wa_ (inp_) +! EXIT +! ENDIF +! inp_ = inp_ + 1 +! ENDDO +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + IF (patchtype(np)==0) THEN + ps = patch_pft_s(np) + pe = patch_pft_e(np) + ! ps_ = patch_pft_s_(selfnp_) + ! pe_ = patch_pft_e_(selfnp_) + + ! if totally come from other types,ldew set to zero since ldew_p(:)=0 + ! using MEC replace STA + ldew_tmp = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + IF ((ldew_tmp) > 0) THEN + ldew_p(ps:pe) = ldew_p(ps:pe) * (ldew(np) / ldew_tmp) + ELSE + ldew(np) = 0 + ENDIF + + ! z0m_p was same-type assigned, then here we update sigf_p, sigf, fsno + CALL snowfraction_pftwrap (np,zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) + + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai(np) = sum(sai_p(ps:pe)*pftfrac(ps:pe)) + + ! account for vegetation snow + IF ( DEF_VEG_SNOW ) THEN + lai_p(ps:pe) = tlai_p(ps:pe) * sigf_p(ps:pe) + lai(np) = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ENDIF + + ENDIF + + ! ! TODO: CALL REST - DONE + ! IF (patchtype(np)==0 .and. lccpct_np(patchclass(np)) .gt. 0) THEN + ! ! Used restart value of the same pftclass for pft-specific variables + ! ! Note: For ip-specific variables, remain initialized value + ! for new soil patch or pftclass + ! ip = ps + ! ip_= ps_ + ! + ! IF (ip.le.0 .or. ip_.le.0) THEN + ! print *, "Error in LuLccMassEnergyConserve LULC_IGBP_PFT|LULC_IGBP_PC!" + ! STOP + ! ENDIF + ! + ! DO WHILE (ip.le.pe .and. ip_.le.pe_) + ! ! if a PFT is missing, CYCLE + ! IF (pftclass(ip) > pftclass_(ip_)) THEN + ! ip_= ip_+ 1 + ! CYCLE + ! ENDIF + ! + ! ! if a PFT is added, CYCLE + ! IF (pftclass(ip) < pftclass_(ip_)) THEN + ! ip = ip + 1 + ! CYCLE + ! ENDIF + ! + ! ! for the same PFT, set PFT value + ! tleaf_p (ip) = tleaf_p_ (ip_) + ! ldew_p (ip) = ldew_p_ (ip_) + ! ! use MOD_SnowFraction.F90 later + ! sigf_p (ip) = sigf_p_ (ip_) + ! IF ( (lai_p(ip) + sai_p(ip)).gt.0 .and. sigf_p(ip).eq.0 ) THEN + ! sigf_p(ip) = 1 + ! ENDIF + ! + ! ip = ip + 1 + ! ip_= ip_+ 1 + ! ENDDO + ! ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + ! ENDIF + +#endif + +#ifdef URBAN_MODEL + IF (patchclass(np)==URBAN) THEN + + ! If there isn't any urban patch in last year's grid,initialized value was + ! remained. Though the first source soil patch would be used for pervious + ! ground related variables. + u = patch2urban (np) + nurb = count( patchclass_(grid_patch_s_(j):grid_patch_e_(j)) == URBAN ) + + ! Get the index of urban patches in last year's grid, and index of urban + ! patch with the same urbclass + IF (nurb > 0) THEN + + allocate(gu_(nurb)) ! ind of urban patches in last year's grid + selfu_ = -1 ! ind of urban patch with same class in last year + inp_ = np_ ! for loop to record the index of urban patch + iu = 0 + + DO WHILE (inp_ .le. grid_patch_e_(j)) + IF (patchclass_(inp_) == URBAN) THEN + iu = iu + 1 + gu_(iu) = patch2urban_(inp_) + IF (landurban%settyp(u) == urbclass_(gu_(iu))) THEN + selfu_ = gu_(iu) + ENDIF + ENDIF + inp_ = inp_ + 1 + ENDDO + ENDIF + + ! Index of the same urbclass or the nearest class would be used for new + ! year's assignment + IF (selfu_ > 0) THEN + u_ = selfu_ + + ELSEIF (nurb > 0) THEN + duclass = abs ( landurban%settyp(u) - urbclass_(gu_(1)) ) + u_ = gu_(1) + iu = 2 + DO WHILE (iu .le. nurb) + IF (duclass .gt. abs( landurban%settyp(u) - urbclass_(gu_(iu)) )) THEN + u_ = gu_(iu) + duclass = abs( landurban%settyp(u) - urbclass_(u_) ) + ENDIF + iu = iu + 1 + ENDDO + ENDIF + + IF (u.le.0 .or. u_.le.0) THEN + print *, "Error in LuLccMassEnergyConserve URBAN_MODEL!" + STOP + ENDIF + + fwsun (u) = fwsun_ (u_) + dfwsun (u) = dfwsun_ (u_) + + sroof (:,:,u) = sroof_ (:,:,u_) + swsun (:,:,u) = swsun_ (:,:,u_) + swsha (:,:,u) = swsha_ (:,:,u_) + sgimp (:,:,u) = sgimp_ (:,:,u_) + sgper (:,:,u) = sgper_ (:,:,u_) + slake (:,:,u) = slake_ (:,:,u_) + + z_sno_roof (:,u) = z_sno_roof_ (:,u_) + z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) + z_sno_gper (:,u) = z_sno_gper_ (:,u_) + z_sno_lake (:,u) = z_sno_lake_ (:,u_) + + dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) + dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) + dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) + dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) + + lwsun (u) = lwsun_ (u_) + lwsha (u) = lwsha_ (u_) + lgimp (u) = lgimp_ (u_) + lgper (u) = lgper_ (u_) + lveg (u) = lveg_ (u_) + + t_roofsno (:,u) = t_roofsno_ (:,u_) + t_wallsun (:,u) = t_wallsun_ (:,u_) + t_wallsha (:,u) = t_wallsha_ (:,u_) + t_gimpsno (:,u) = t_gimpsno_ (:,u_) + t_gpersno (:,u) = t_gpersno_ (:,u_) + t_lakesno (:,u) = t_lakesno_ (:,u_) + + troof_inner (u) = troof_inner_ (u_) + twsun_inner (u) = twsun_inner_ (u_) + twsha_inner (u) = twsha_inner_ (u_) + + wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) + wice_roofsno (:,u) = wice_roofsno_ (:,u_) + wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) + wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) + wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) + wice_gpersno (:,u) = wice_gpersno_ (:,u_) + wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) + wice_lakesno (:,u) = wice_lakesno_ (:,u_) + + sag_roof (u) = sag_roof_ (u_) + sag_gimp (u) = sag_gimp_ (u_) + sag_gper (u) = sag_gper_ (u_) + sag_lake (u) = sag_lake_ (u_) + scv_roof (u) = scv_roof_ (u_) + scv_gimp (u) = scv_gimp_ (u_) + scv_gper (u) = scv_gper_ (u_) + scv_lake (u) = scv_lake_ (u_) + fsno_roof (u) = fsno_roof_ (u_) + fsno_gimp (u) = fsno_gimp_ (u_) + fsno_gper (u) = fsno_gper_ (u_) + fsno_lake (u) = fsno_lake_ (u_) + snowdp_roof (u) = snowdp_roof_ (u_) + snowdp_gimp (u) = snowdp_gimp_ (u_) + snowdp_gper (u) = snowdp_gper_ (u_) + snowdp_lake (u) = snowdp_lake_ (u_) + + Fhac (u) = Fhac_ (u_) + Fwst (u) = Fwst_ (u_) + Fach (u) = Fach_ (u_) + Fahe (u) = Fahe_ (u_) + Fhah (u) = Fhah_ (u_) + vehc (u) = vehc_ (u_) + meta (u) = meta_ (u_) + t_room (u) = t_room_ (u_) + t_roof (u) = t_roof_ (u_) + t_wall (u) = t_wall_ (u_) + tafu (u) = tafu_ (u_) + urb_green (u) = urb_green_ (u_) + + ! used soil patch value for variable on pervious ground + FROM_SOIL = .false. + IF (selfu_ < 0) THEN + DO k = 1, num + IF (patchtype_(frnp_(k)) == 0) THEN + FROM_SOIL = .true. + ENDIF + ENDDO + ENDIF + + ! Use the first source soil patch temporarily + IF (FROM_SOIL) THEN + z_sno_gper (:,u) = z_sno_ (:,frnp_(1)) + sag_gper (u) = sag_ (frnp_(1)) + scv_gper (u) = scv_ (frnp_(1)) + fsno_gper (u) = fsno_ (frnp_(1)) + snowdp_gper (u) = snowdp_ (frnp_(1)) + ENDIF + + !TODO: need to recalculate wliq_soisno, wice_soisno and scv value - DONE + wliq_soisno(: ,np) = 0. + wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) + wliq_soisno(: ,np) = wliq_soisno (: ,np) & + + wliq_gpersno(: ,u )*(1-froof(u))*fgper(u) + wliq_soisno(:1,np) = wliq_soisno (:1,np) & + + wliq_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) + + wice_soisno(: ,np) = 0. + wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) + wice_soisno(: ,np) = wice_soisno (: ,np) & + + wice_gpersno(: ,u )*(1-froof(u))*fgper(u) + wice_soisno(:1,np) = wice_soisno (:1,np) & + + wice_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) + + scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) & + + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) + + ENDIF +#endif + + ! CALL albland (np, patchtype(np),deltim,& + ! soil_s_v_alb(np),soil_d_v_alb(np),soil_s_n_alb(np),soil_d_n_alb(np),& + ! chil(patchclass(np)),rho(1:,1:,patchclass(np)),tau(1:,1:,patchclass(np)),& + ! fveg(np),green(np),lai(np),sai(np),coszen(np),& + ! wt,fsno(np),scv(np),scvold(np),sag(np),ssw,pg_snow(np),& + ! forc_t(np),t_grnd(np),t_soisno_(maxsnl+1:,np),& + ! dz_soisno_(maxsnl+1:,np),snl,wliq_soisno(maxsnl+1:,np),& + ! wice_soisno(maxsnl+1:,np),snw_rds(maxsnl+1:0,np),snofrz,& + ! mss_bcpho(maxsnl+1:0,np),mss_bcphi(maxsnl+1:0,np),& + ! mss_ocpho(maxsnl+1:0,np),mss_ocphi(maxsnl+1:0,np),& + ! mss_dst1(maxsnl+1:0,np),mss_dst2(maxsnl+1:0,np),& + ! mss_dst3(maxsnl+1:0,np),mss_dst4(maxsnl+1:0,np),& + ! alb(1:,1:,np),ssun(1:,1:,np),ssha(1:,1:,np),ssno(:,:,:,np),& + ! thermk(np),extkb(np),extkd(np)) + + + IF (allocated(frnp_ )) deallocate(frnp_ ) + IF (allocated(gu_ )) deallocate(gu_ ) + IF (allocated(cvsoil_)) deallocate(cvsoil_) + IF (allocated(h_ )) deallocate(h_ ) + np = np + 1 + ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) + IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) + IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) + IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) + IF (allocated(locpxl )) deallocate(locpxl ) + ENDIF + + END SUBROUTINE LulccMassEnergyConserve + +END MODULE MOD_Lulcc_MassEnergyConserve +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 new file mode 100644 index 0000000000..c2953c6cc1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 @@ -0,0 +1,136 @@ +#include + +MODULE MOD_Lulcc_TransferTraceReadin + +!------------------------------------------------------------------------ +! +! !DESCRIPTION: +! The transfer matrix and patch tracing vector were created using the +! land cover type data of the adjacent two years. Based on next year's +! patch, the pixels within the patch and last years' land cover type of +! these pixels were obtained. Then the percent of source land cover +! type of each patch was derived. +! +! Created by Wanyi Lin, Shupeng Zhang and Hua Yuan, 07/2023 +! +! !HISTORY: +! 05/2025, Wanyi Lin and Hua Yuan: change to reading the lulcc transfer +! tracing vector from data files which are produced in the making +! surface data stage. See mksrfdata/MOD_Lulcc_TransferTrace.F90. +! +!------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE + + !frac of source patches in a patch + real(r8), allocatable, dimension(:,:) :: lccpct_patches(:,:) + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_LulccTransferTrace + PUBLIC :: deallocate_LulccTransferTrace + PUBLIC :: LulccTransferTraceReadin + + ! PRIVATE MEMBER FUNCTIONS: + + +CONTAINS + + + SUBROUTINE allocate_LulccTransferTrace + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time invariant variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_SPMD_Task + + IMPLICIT NONE + + integer :: nlc = N_land_classification + + IF (p_is_worker) THEN + allocate (lccpct_patches (numpatch, 0:nlc)) + lccpct_patches (:,:) = 0 + ENDIF + + END SUBROUTINE allocate_LulccTransferTrace + + + SUBROUTINE LulccTransferTraceReadin (lc_year) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_AggregationRequestData + USE MOD_Mesh + USE MOD_MeshFilter + USE MOD_LandElm + USE MOD_DataType + USE MOD_Block + USE MOD_Pixel + USE MOD_5x5DataReadin + USE MOD_RegionClip + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_Vars_TimeInvariants + + IMPLICIT NONE + + integer, intent(in) :: lc_year + + character(len=256) :: dir_landdata, lndname, thisyr + character(len=4) :: c2 + integer :: ilc + real(r8), allocatable :: tmpvec(:) + + + IF (p_is_worker) THEN + IF (allocated(tmpvec)) deallocate (tmpvec) + allocate (tmpvec(numpatch)) + ENDIF + + write(thisyr,'(i4.4)') lc_year + dir_landdata = DEF_dir_landdata + DO ilc = 0, N_land_classification + write(c2, '(i2.2)') ilc + lndname = trim(dir_landdata)//'/lulcc/'//trim(thisyr)//& + '/lccpct_patches_lc'//trim(c2)//'.nc' + CALL ncio_read_vector(lndname, 'lccpct_patches', landpatch, tmpvec) + + IF (p_is_worker) THEN + lccpct_patches(:,ilc) = tmpvec + ENDIF + ENDDO + + + END SUBROUTINE LulccTransferTraceReadin + + + SUBROUTINE deallocate_LulccTransferTrace + ! -------------------------------------------------- + ! Deallocates memory for Lulcc time invariant variables + ! -------------------------------------------------- + USE MOD_SPMD_Task + + IF (p_is_worker) THEN + IF (allocated(lccpct_patches)) deallocate (lccpct_patches) + ENDIF + + END SUBROUTINE deallocate_LulccTransferTrace + +END MODULE MOD_Lulcc_TransferTraceReadin +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..ef50692cb6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 @@ -0,0 +1,201 @@ +#include + +MODULE MOD_Lulcc_Vars_TimeInvariants + +!----------------------------------------------------------------------- +! Created by Hua Yuan, 04/2022 +! +! !REVISIONS: +! +! 07/2023, Wenzong Dong: porting to MPI version +! 08/2023, Hua Yuan: unified PFT and PC process +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_PixelSet + + IMPLICIT NONE + SAVE +!----------------------------------------------------------------------- + ! for patch time invariant information + type(pixelset_type) :: landpatch_ + type(pixelset_type) :: landelm_ + integer :: numpatch_ + integer :: numelm_ + integer :: numpft_ + integer :: numpc_ + integer :: numurban_ + integer, allocatable :: patchclass_ (:) !index of land cover type + integer, allocatable :: patchtype_ (:) !land patch type + real(r8), allocatable:: csol_ (:,:) !heat capacity of soil solids [J/(m3 K)] + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + integer, allocatable :: pftclass_ (:) !PFT type + integer, allocatable :: patch_pft_s_ (:) !start PFT index of a patch + integer, allocatable :: patch_pft_e_ (:) !end PFT index of a patch + + ! for Urban model + integer, allocatable :: urbclass_ (:) !urban type + integer, allocatable :: patch2urban_ (:) !projection from patch to Urban + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_LulccTimeInvariants + PUBLIC :: deallocate_LulccTimeInvariants + PUBLIC :: SAVE_LulccTimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_LulccTimeInvariants + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time invariant variables + ! -------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_Mesh +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif +#ifdef URBAN_MODEL + USE MOD_LandUrban +#endif + + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (landpatch_%eindex (numpatch)) + allocate (landpatch_%ipxstt (numpatch)) + allocate (landpatch_%ipxend (numpatch)) + allocate (landpatch_%settyp (numpatch)) + allocate (landpatch_%ielm (numpatch)) + allocate (landpatch_%xblkgrp (numpatch)) + allocate (landpatch_%yblkgrp (numpatch)) + + allocate (landelm_%eindex (numelm)) + allocate (landelm_%ipxstt (numelm)) + allocate (landelm_%ipxend (numelm)) + allocate (landelm_%settyp (numelm)) + + allocate (patchclass_ (numpatch)) + allocate (patchtype_ (numpatch)) + allocate (csol_ (nl_soil,numpatch)) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + allocate (pftclass_ (numpft)) + allocate (patch_pft_s_ (numpatch)) + allocate (patch_pft_e_ (numpatch)) + ENDIF +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + allocate (urbclass_ (numurban)) + allocate (patch2urban_ (numpatch)) + ENDIF +#endif + ENDIF + ENDIF + END SUBROUTINE allocate_LulccTimeInvariants + + + SUBROUTINE SAVE_LulccTimeInvariants + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_Pixelset + USE MOD_Vars_TimeInvariants + USE MOD_Landpatch + USE MOD_Landelm + USE MOD_Mesh +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants + USE MOD_LandPFT +#endif +#ifdef URBAN_MODEL + USE MOD_LandUrban +#endif + + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + CALL copy_pixelset (landpatch, landpatch_ ) + CALL copy_pixelset (landelm , landelm_ ) + numpatch_ = numpatch + numelm_ = numelm + patchclass_ (:) = patchclass (:) + patchtype_ (:) = patchtype (:) + csol_ (:,:) = csol (:,:) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + numpft_ = numpft + pftclass_ (:) = pftclass (:) + patch_pft_s_ (:) = patch_pft_s (:) + patch_pft_e_ (:) = patch_pft_e (:) + ENDIF +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + numurban_ = numurban + urbclass_ (:) = landurban%settyp (:) + patch2urban_ (:) = patch2urban (:) + ENDIF +#endif + ENDIF + ENDIF + + CALL landpatch_%set_vecgs + + END SUBROUTINE SAVE_LulccTimeInvariants + + + SUBROUTINE deallocate_LulccTimeInvariants + USE MOD_SPMD_Task + USE MOD_PixelSet +! -------------------------------------------------- +! Deallocates memory for Lulcc time invariant variables +! -------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch_ > 0) THEN + CALL landpatch_%forc_free_mem + CALL landelm_%forc_free_mem + deallocate (patchclass_ ) + deallocate (patchtype_ ) + deallocate (csol_ ) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft_ > 0) THEN + deallocate (pftclass_ ) + deallocate (patch_pft_s_ ) + deallocate (patch_pft_e_ ) + ENDIF +#endif + +#ifdef URBAN_MODEL + IF (numurban_ > 0) THEN + deallocate (urbclass_ ) + deallocate (patch2urban_ ) + ENDIF +#endif + ENDIF + ENDIF + + END SUBROUTINE deallocate_LulccTimeInvariants + +END MODULE MOD_Lulcc_Vars_TimeInvariants +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..1eb2a359ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 @@ -0,0 +1,1206 @@ +#include + +MODULE MOD_Lulcc_Vars_TimeVariables + +!----------------------------------------------------------------------- +! +! Created by Hua Yuan, 04/2022 +! +! !REVISIONS: +! 07/2023, Wenzong Dong: porting to MPI version +! 08/2023, Hua Yuan: unified PFT and PC process +! 10/2023, Wanyi Lin: check with MOD_Vars_TimeVariables.F90, add +! variables, and remove unnecessary variables +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE +! ---------------------------------------------------------------------- +! Time-varying state variables which required by restart run + !TODO: need to check with MOD_Vars_TimeVariables.F90 whether + ! there are any variables missing. - DONE + real(r8), allocatable :: z_sno_ (:,:) !node depth [m] + real(r8), allocatable :: dz_sno_ (:,:) !interface depth [m] + real(r8), allocatable :: t_soisno_ (:,:) !soil temperature [K] + real(r8), allocatable :: wliq_soisno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno_ (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: smp_ (:,:) !soil matrix potential [mm] + real(r8), allocatable :: hk_ (:,:) !hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: t_grnd_ (:) !ground surface temperature [K] + + real(r8), allocatable :: tleaf_ (:) !leaf temperature [K] + real(r8), allocatable :: ldew_ (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: fwet_snow_ (:) !vegetation snow fractional cover [-] + real(r8), allocatable :: sag_ (:) !non dimensional snow age [-] + real(r8), allocatable :: scv_ (:) !snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp_ (:) !snow depth [meter] + real(r8), allocatable :: fsno_ (:) !frac of snow cover on ground + real(r8), allocatable :: sigf_ (:) !frac of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: zwt_ (:) !the depth to water table [m] + real(r8), allocatable :: wa_ (:) !water storage in aquifer [mm] + real(r8), allocatable :: wdsrf_ (:) !depth of surface water [mm] + real(r8), allocatable :: rss_ (:) !soil surface resistance [s/m] + + real(r8), allocatable :: t_lake_ (:,:) !lake layer temperature [K] + real(r8), allocatable :: lake_icefrac_ (:,:) !lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1_ (:) !top level eddy conductivity (W/m K) + + !Plant Hydraulic variables + real(r8), allocatable :: vegwp_ (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_ (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_ (:) !working copy of shaded stomata conductance + !END plant hydraulic variables + + !Ozone stress variables + real(r8), allocatable :: lai_old_ (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_ (:) !Ozone does, shaded leaf (mmol O3/m^2) + !End ozone stress variables + + real(r8), allocatable :: snw_rds_ (:,:) !effective grain radius (col,lyr) [microns, m-6] + real(r8), allocatable :: mss_bcpho_ (:,:) !mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_bcphi_ (:,:) !mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocpho_ (:,:) !mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocphi_ (:,:) !mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst1_ (:,:) !mass of dust species 1 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst2_ (:,:) !mass of dust species 2 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst3_ (:,:) !mass of dust species 3 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst4_ (:,:) !mass of dust species 4 in snow (col,lyr) [kg] + real(r8), allocatable :: ssno_lyr_ (:,:,:,:) !snow layer absorption [-] + + ! Additional variables required by regional model (such as WRF ) RSM) + real(r8), allocatable :: trad_ (:) !radiative temperature of surface [K] + real(r8), allocatable :: tref_ (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_ (:) !2 m height air specific humidity + real(r8), allocatable :: rst_ (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: emis_ (:) !averaged bulk surface emissivity + real(r8), allocatable :: z0m_ (:) !effective roughness [m] + real(r8), allocatable :: displa_ (:) !zero displacement height [m] + real(r8), allocatable :: zol_ (:) !dimensionless height (z/L) used in M-O theory + real(r8), allocatable :: rib_ (:) !bulk Richardson number in surface layer + real(r8), allocatable :: ustar_ (:) !u* in similarity theory [m/s] + real(r8), allocatable :: qstar_ (:) !q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar_ (:) !t* in similarity theory [K] + real(r8), allocatable :: fm_ (:) !integral of profile function for momentum + real(r8), allocatable :: fh_ (:) !integral of profile function for heat + real(r8), allocatable :: fq_ (:) !integral of profile function for moisture + + real(r8), allocatable :: sum_irrig_ (:) !total irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig_count_ (:) !total irrigation counts [-] + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + real(r8), allocatable :: tleaf_p_ (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_p_ (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_p_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_p_ (:) !depth of snow on foliage [mm] + real(r8), allocatable :: fwet_snow_p_ (:) !vegetation snow fractional cover [-] + real(r8), allocatable :: sigf_p_ (:) !frac of veg cover, excluding snow-covered veg [-] + + !TODO@yuan: to check the below for PC whether they are needed + real(r8), allocatable :: tref_p_ (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_p_ (:) !2 m height air specific humidity + real(r8), allocatable :: rst_p_ (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: z0m_p_ (:) !effective roughness [m] + + ! Plant Hydraulic variables + real(r8), allocatable :: vegwp_p_ (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_p_ (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_p_ (:) !working copy of shaded stomata conductance + ! end plant hydraulic variables + + ! Ozone Stress Variables + real(r8), allocatable :: lai_old_p_ (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_p_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_p_ (:) !Ozone does, shaded leaf (mmol O3/m^2) + ! End Ozone Stress Variables + + ! for URBAN_MODEL + real(r8), allocatable :: fwsun_ (:) !sunlit fraction of walls [-] + real(r8), allocatable :: dfwsun_ (:) !change of sunlit fraction of walls [-] + + ! shortwave absorption + real(r8), allocatable :: sroof_ (:,:,:) !roof absorption [-] + real(r8), allocatable :: swsun_ (:,:,:) !sunlit wall absorption [-] + real(r8), allocatable :: swsha_ (:,:,:) !shaded wall absorption [-] + real(r8), allocatable :: sgimp_ (:,:,:) !impervious absorption [-] + real(r8), allocatable :: sgper_ (:,:,:) !pervious absorption [-] + real(r8), allocatable :: slake_ (:,:,:) !urban lake absorption [-] + + ! net longwave radiation for last time temperature change + real(r8), allocatable :: lwsun_ (:) !net longwave of sunlit wall [W/m2] + real(r8), allocatable :: lwsha_ (:) !net longwave of shaded wall [W/m2] + real(r8), allocatable :: lgimp_ (:) !net longwave of impervious [W/m2] + real(r8), allocatable :: lgper_ (:) !net longwave of pervious [W/m2] + real(r8), allocatable :: lveg_ (:) !net longwave of vegetation [W/m2] + + real(r8), allocatable :: z_sno_roof_ (:,:) !node depth of roof [m] + real(r8), allocatable :: z_sno_gimp_ (:,:) !node depth of impervious [m] + real(r8), allocatable :: z_sno_gper_ (:,:) !node depth pervious [m] + real(r8), allocatable :: z_sno_lake_ (:,:) !node depth lake [m] + + real(r8), allocatable :: dz_sno_roof_ (:,:) !interface depth of roof [m] + real(r8), allocatable :: dz_sno_gimp_ (:,:) !interface depth of impervious [m] + real(r8), allocatable :: dz_sno_gper_ (:,:) !interface depth pervious [m] + real(r8), allocatable :: dz_sno_lake_ (:,:) !interface depth lake [m] + + real(r8), allocatable :: troof_inner_ (:) !temperature of roof [K] + real(r8), allocatable :: twsun_inner_ (:) !temperature of sunlit wall [K] + real(r8), allocatable :: twsha_inner_ (:) !temperature of shaded wall [K] + + real(r8), allocatable :: t_roofsno_ (:,:) !temperature of roof [K] + real(r8), allocatable :: t_wallsun_ (:,:) !temperature of sunlit wall [K] + real(r8), allocatable :: t_wallsha_ (:,:) !temperature of shaded wall [K] + real(r8), allocatable :: t_gimpsno_ (:,:) !temperature of impervious [K] + real(r8), allocatable :: t_gpersno_ (:,:) !temperature of pervious [K] + real(r8), allocatable :: t_lakesno_ (:,:) !temperature of pervious [K] + + real(r8), allocatable :: wliq_roofsno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gimpsno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gpersno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_lakesno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_roofsno_ (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gimpsno_ (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gpersno_ (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_lakesno_ (:,:) !ice lens in layers [kg/m2] + + real(r8), allocatable :: sag_roof_ (:) !roof snow age [-] + real(r8), allocatable :: sag_gimp_ (:) !impervious ground snow age [-] + real(r8), allocatable :: sag_gper_ (:) !pervious ground snow age [-] + real(r8), allocatable :: sag_lake_ (:) !urban lake snow age [-] + + real(r8), allocatable :: scv_roof_ (:) !roof snow cover [-] + real(r8), allocatable :: scv_gimp_ (:) !impervious ground snow cover [-] + real(r8), allocatable :: scv_gper_ (:) !pervious ground snow cover [-] + real(r8), allocatable :: scv_lake_ (:) !urban lake snow cover [-] + + real(r8), allocatable :: fsno_roof_ (:) !roof snow fraction [-] + real(r8), allocatable :: fsno_gimp_ (:) !impervious ground snow fraction [-] + real(r8), allocatable :: fsno_gper_ (:) !pervious ground snow fraction [-] + real(r8), allocatable :: fsno_lake_ (:) !urban lake snow fraction [-] + + real(r8), allocatable :: snowdp_roof_ (:) !roof snow depth [m] + real(r8), allocatable :: snowdp_gimp_ (:) !impervious ground snow depth [m] + real(r8), allocatable :: snowdp_gper_ (:) !pervious ground snow depth [m] + real(r8), allocatable :: snowdp_lake_ (:) !urban lake snow depth [m] + + !TODO: consider renaming the below variables + real(r8), allocatable :: Fhac_ (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fwst_ (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fach_ (:) !flux from inner and outer air exchange [W/m2] + real(r8), allocatable :: Fahe_ (:) !flux from metabolism and vehicle [W/m2] + real(r8), allocatable :: Fhah_ (:) !sensible heat flux from heating [W/m2] + real(r8), allocatable :: vehc_ (:) !flux from vehicle [W/m2] + real(r8), allocatable :: meta_ (:) !flux from metabolism [W/m2] + + real(r8), allocatable :: t_room_ (:) !temperature of inner building [K] + real(r8), allocatable :: t_roof_ (:) !temperature of roof [K] + real(r8), allocatable :: t_wall_ (:) !temperature of wall [K] + real(r8), allocatable :: tafu_ (:) !temperature of outer building [K] + + real(r8), allocatable :: urb_green_ (:) !fractional of green leaf in urban patch [-] + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_LulccTimeVariables + PUBLIC :: deallocate_LulccTimeVariables + PUBLIC :: SAVE_LulccTimeVariables + PUBLIC :: REST_LulccTimeVariables + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_LulccTimeVariables + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time variant variables + ! -------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeVariables + USE MOD_LandUrban +#endif + + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (z_sno_ (maxsnl+1:0,numpatch)) + allocate (dz_sno_ (maxsnl+1:0,numpatch)) + allocate (t_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (wliq_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (wice_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (smp_ (1:nl_soil,numpatch)) + allocate (hk_ (1:nl_soil,numpatch)) + allocate (t_grnd_ (numpatch)) + allocate (tleaf_ (numpatch)) + allocate (ldew_ (numpatch)) + allocate (ldew_rain_ (numpatch)) + allocate (ldew_snow_ (numpatch)) + allocate (fwet_snow_ (numpatch)) + allocate (sag_ (numpatch)) + allocate (scv_ (numpatch)) + allocate (snowdp_ (numpatch)) + allocate (fsno_ (numpatch)) + allocate (sigf_ (numpatch)) + allocate (zwt_ (numpatch)) + allocate (wa_ (numpatch)) + allocate (wdsrf_ (numpatch)) + allocate (rss_ (numpatch)) + + allocate (t_lake_ (nl_lake,numpatch)) + allocate (lake_icefrac_ (nl_lake,numpatch)) + allocate (savedtke1_ (numpatch)) + + !Plant Hydraulic variables + allocate (vegwp_ (1:nvegwcs,numpatch)) + allocate (gs0sun_ (numpatch)) + allocate (gs0sha_ (numpatch)) + !END plant hydraulic variables + + !Ozone Stress variables + allocate (lai_old_ (numpatch)) + allocate (o3uptakesun_ (numpatch)) + allocate (o3uptakesha_ (numpatch)) + !End ozone stress variables + + allocate (snw_rds_ (maxsnl+1:0,numpatch)) + allocate (mss_bcpho_ (maxsnl+1:0,numpatch)) + allocate (mss_bcphi_ (maxsnl+1:0,numpatch)) + allocate (mss_ocpho_ (maxsnl+1:0,numpatch)) + allocate (mss_ocphi_ (maxsnl+1:0,numpatch)) + allocate (mss_dst1_ (maxsnl+1:0,numpatch)) + allocate (mss_dst2_ (maxsnl+1:0,numpatch)) + allocate (mss_dst3_ (maxsnl+1:0,numpatch)) + allocate (mss_dst4_ (maxsnl+1:0,numpatch)) + allocate (ssno_lyr_ (2,2,maxsnl+1:1,numpatch)) + + allocate (trad_ (numpatch)) + allocate (tref_ (numpatch)) + allocate (qref_ (numpatch)) + allocate (rst_ (numpatch)) + allocate (emis_ (numpatch)) + allocate (z0m_ (numpatch)) + allocate (zol_ (numpatch)) + allocate (rib_ (numpatch)) + allocate (ustar_ (numpatch)) + allocate (qstar_ (numpatch)) + allocate (tstar_ (numpatch)) + allocate (fm_ (numpatch)) + allocate (fh_ (numpatch)) + allocate (fq_ (numpatch)) + + allocate (sum_irrig_ (numpatch)) + allocate (sum_irrig_count_ (numpatch)) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + allocate (tleaf_p_ (numpft)) + allocate (ldew_p_ (numpft)) + allocate (ldew_rain_p_ (numpft)) + allocate (ldew_snow_p_ (numpft)) + allocate (fwet_snow_p_ (numpft)) + allocate (sigf_p_ (numpft)) + allocate (tref_p_ (numpft)) + allocate (qref_p_ (numpft)) + allocate (rst_p_ (numpft)) + allocate (z0m_p_ (numpft)) + + ! Plant Hydraulic variables + allocate (vegwp_p_ (1:nvegwcs,numpft)) + allocate (gs0sun_p_ (numpft)) + allocate (gs0sha_p_ (numpft)) + ! end plant hydraulic variables + + ! Allocate Ozone Stress Variables + allocate (lai_old_p_ (numpft)) + allocate (o3uptakesun_p_ (numpft)) + allocate (o3uptakesha_p_ (numpft)) + ! End allocate Ozone Stress Variables + ENDIF +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + allocate (fwsun_ (numurban)) + allocate (dfwsun_ (numurban)) + + allocate (sroof_ (2,2,numurban)) + allocate (swsun_ (2,2,numurban)) + allocate (swsha_ (2,2,numurban)) + allocate (sgimp_ (2,2,numurban)) + allocate (sgper_ (2,2,numurban)) + allocate (slake_ (2,2,numurban)) + + allocate (lwsun_ (numurban)) + allocate (lwsha_ (numurban)) + allocate (lgimp_ (numurban)) + allocate (lgper_ (numurban)) + allocate (lveg_ (numurban)) + + allocate (z_sno_roof_ (maxsnl+1:0,numurban)) + allocate (z_sno_gimp_ (maxsnl+1:0,numurban)) + allocate (z_sno_gper_ (maxsnl+1:0,numurban)) + allocate (z_sno_lake_ (maxsnl+1:0,numurban)) + + allocate (dz_sno_roof_ (maxsnl+1:0,numurban)) + allocate (dz_sno_gimp_ (maxsnl+1:0,numurban)) + allocate (dz_sno_gper_ (maxsnl+1:0,numurban)) + allocate (dz_sno_lake_ (maxsnl+1:0,numurban)) + + allocate (t_roofsno_ (maxsnl+1:nl_roof,numurban)) + allocate (t_wallsun_ (maxsnl+1:nl_wall,numurban)) + allocate (t_wallsha_ (maxsnl+1:nl_wall,numurban)) + allocate (t_gimpsno_ (maxsnl+1:nl_soil,numurban)) + allocate (t_gpersno_ (maxsnl+1:nl_soil,numurban)) + allocate (t_lakesno_ (maxsnl+1:nl_soil,numurban)) + + allocate (troof_inner_ (numurban)) + allocate (twsun_inner_ (numurban)) + allocate (twsha_inner_ (numurban)) + + allocate (wliq_roofsno_(maxsnl+1:nl_roof,numurban)) + allocate (wice_roofsno_(maxsnl+1:nl_roof,numurban)) + allocate (wliq_gimpsno_(maxsnl+1:nl_soil,numurban)) + allocate (wice_gimpsno_(maxsnl+1:nl_soil,numurban)) + allocate (wliq_gpersno_(maxsnl+1:nl_soil,numurban)) + allocate (wice_gpersno_(maxsnl+1:nl_soil,numurban)) + allocate (wliq_lakesno_(maxsnl+1:nl_soil,numurban)) + allocate (wice_lakesno_(maxsnl+1:nl_soil,numurban)) + + allocate (sag_roof_ (numurban)) + allocate (sag_gimp_ (numurban)) + allocate (sag_gper_ (numurban)) + allocate (sag_lake_ (numurban)) + allocate (scv_roof_ (numurban)) + allocate (scv_gimp_ (numurban)) + allocate (scv_gper_ (numurban)) + allocate (scv_lake_ (numurban)) + allocate (fsno_roof_ (numurban)) + allocate (fsno_gimp_ (numurban)) + allocate (fsno_gper_ (numurban)) + allocate (fsno_lake_ (numurban)) + allocate (snowdp_roof_ (numurban)) + allocate (snowdp_gimp_ (numurban)) + allocate (snowdp_gper_ (numurban)) + allocate (snowdp_lake_ (numurban)) + + allocate (Fhac_ (numurban)) + allocate (Fwst_ (numurban)) + allocate (Fach_ (numurban)) + allocate (Fahe_ (numurban)) + allocate (Fhah_ (numurban)) + allocate (vehc_ (numurban)) + allocate (meta_ (numurban)) + allocate (t_room_ (numurban)) + allocate (t_roof_ (numurban)) + allocate (t_wall_ (numurban)) + allocate (tafu_ (numurban)) + allocate (urb_green_ (numurban)) + ENDIF +#endif + ENDIF + END SUBROUTINE allocate_LulccTimeVariables + + + SUBROUTINE SAVE_LulccTimeVariables + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global + USE MOD_Vars_TimeVariables +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeVariables +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeVariables +#endif + + IMPLICIT NONE + + IF (p_is_worker) THEN + z_sno_ = z_sno + dz_sno_ = dz_sno + t_soisno_ = t_soisno + wliq_soisno_ = wliq_soisno + wice_soisno_ = wice_soisno + smp_ = smp + hk_ = hk + t_grnd_ = t_grnd + tleaf_ = tleaf + ldew_ = ldew + ldew_rain_ = ldew_rain + ldew_snow_ = ldew_snow + fwet_snow_ = fwet_snow + sag_ = sag + scv_ = scv + snowdp_ = snowdp + fsno_ = fsno + sigf_ = sigf + zwt_ = zwt + wa_ = wa + wdsrf_ = wdsrf + rss_ = rss + + t_lake_ = t_lake + lake_icefrac_ = lake_icefrac + savedtke1_ = savedtke1 + +IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp_ = vegwp + gs0sun_ = gs0sun + gs0sha_ = gs0sha +ENDIF + +IF(DEF_USE_OZONESTRESS)THEN + lai_old_ = lai_old + o3uptakesun_ = o3uptakesun + o3uptakesha_ = o3uptakesha +ENDIF + snw_rds_ = snw_rds + mss_bcpho_ = mss_bcpho + mss_bcphi_ = mss_bcphi + mss_ocpho_ = mss_ocpho + mss_ocphi_ = mss_ocphi + mss_dst1_ = mss_dst1 + mss_dst2_ = mss_dst2 + mss_dst3_ = mss_dst3 + mss_dst4_ = mss_dst4 + ssno_lyr_ = ssno_lyr + + trad_ = trad + tref_ = tref + qref_ = qref + rst_ = rst + emis_ = emis + z0m_ = z0m + displa_ = displa + zol_ = zol + rib_ = rib + ustar_ = ustar + qstar_ = qstar + tstar_ = tstar + fm_ = fm + fh_ = fh + fq_ = fq + +IF (DEF_USE_IRRIGATION) THEN + sum_irrig_ = sum_irrig + sum_irrig_count_ = sum_irrig_count +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + tleaf_p_ = tleaf_p + ldew_p_ = ldew_p + ldew_rain_p_ = ldew_rain_p + ldew_snow_p_ = ldew_snow_p + fwet_snow_p_ = fwet_snow_p + sigf_p_ = sigf_p + + tref_p_ = tref_p + qref_p_ = qref_p + rst_p_ = rst_p + z0m_p_ = z0m_p +IF(DEF_USE_PLANTHYDRAULICS)THEN + ! Plant Hydraulic variables + vegwp_p_ = vegwp_p + gs0sun_p_ = gs0sun_p + gs0sha_p_ = gs0sha_p + ! end plant hydraulic variables +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + ! Ozone Stress Variables + lai_old_p_ = lai_old_p + o3uptakesun_p_ = o3uptakesun_p + o3uptakesha_p_ = o3uptakesha_p + ! End allocate Ozone Stress Variables +ENDIF +#endif + +#ifdef URBAN_MODEL + fwsun_ = fwsun + dfwsun_ = dfwsun + + sroof_ = sroof + swsun_ = swsun + swsha_ = swsha + sgimp_ = sgimp + sgper_ = sgper + slake_ = slake + + lwsun_ = lwsun + lwsha_ = lwsha + lgimp_ = lgimp + lgper_ = lgper + lveg_ = lveg + + z_sno_roof_ = z_sno_roof + z_sno_gimp_ = z_sno_gimp + z_sno_gper_ = z_sno_gper + z_sno_lake_ = z_sno_lake + + dz_sno_roof_ = dz_sno_roof + dz_sno_gimp_ = dz_sno_gimp + dz_sno_gper_ = dz_sno_gper + dz_sno_lake_ = dz_sno_lake + + t_roofsno_ = t_roofsno + t_wallsun_ = t_wallsun + t_wallsha_ = t_wallsha + t_gimpsno_ = t_gimpsno + t_gpersno_ = t_gpersno + t_lakesno_ = t_lakesno + + troof_inner_ = troof_inner + twsun_inner_ = twsun_inner + twsha_inner_ = twsha_inner + + wliq_roofsno_ = wliq_roofsno + wice_roofsno_ = wice_roofsno + wliq_gimpsno_ = wliq_gimpsno + wice_gimpsno_ = wice_gimpsno + wliq_gpersno_ = wliq_gpersno + wice_gpersno_ = wice_gpersno + wliq_lakesno_ = wliq_lakesno + wice_lakesno_ = wice_lakesno + + sag_roof_ = sag_roof + sag_gimp_ = sag_gimp + sag_gper_ = sag_gper + sag_lake_ = sag_lake + scv_roof_ = scv_roof + scv_gimp_ = scv_gimp + scv_gper_ = scv_gper + scv_lake_ = scv_lake + fsno_roof_ = fsno_roof + fsno_gimp_ = fsno_gimp + fsno_gper_ = fsno_gper + fsno_lake_ = fsno_lake + snowdp_roof_ = snowdp_roof + snowdp_gimp_ = snowdp_gimp + snowdp_gper_ = snowdp_gper + snowdp_lake_ = snowdp_lake + + Fhac_ = Fhac + Fwst_ = Fwst + Fach_ = Fach + Fahe_ = Fahe + Fhah_ = Fhah + vehc_ = vehc + meta_ = meta + t_room_ = t_room + t_roof_ = t_roof + t_wall_ = t_wall + tafu_ = tafu + urb_green_ = urb_green +#endif + ENDIF + + END SUBROUTINE SAVE_LulccTimeVariables + + + SUBROUTINE REST_LulccTimeVariables + + USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_LandElm + USE MOD_Mesh + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Lulcc_Vars_TimeInvariants +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeVariables + USE MOD_LandUrban +#endif + + IMPLICIT NONE + + real(r8), allocatable, dimension(:) :: grid_patch_s , grid_patch_e + real(r8), allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ + integer , allocatable, dimension(:) :: locpxl + integer i, j, np, np_, ip, ip_, pc, pc_, u, u_ + integer ps, ps_, pe, pe_ + integer numpxl, ipxl + + IF (p_is_worker) THEN + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + allocate(grid_patch_s_(numelm_)) + allocate(grid_patch_e_(numelm_)) + + grid_patch_e (:) = -1. + grid_patch_s (:) = -1. + grid_patch_e_(:) = -1. + grid_patch_s_(:) = -1. + + ! loop for numelm of next year, patches at the beginning and end of + ! the element were recorded landpatch%eindex is arranged in order, + ! and the not land element is skipped so, IF element is missing, the + ! recorder is -1. + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], & + landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO + + ! same as above, loop for numelm of previous year + ! patches at the beginning and end of the element were recorded + DO i=1, numelm_ + numpxl = count(landpatch_%eindex==landelm_%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + locpxl = pack([(ipxl, ipxl=1, numpatch_)], & + landpatch_%eindex==landelm_%eindex(i)) + + grid_patch_s_(i) = minval(locpxl) + grid_patch_e_(i) = maxval(locpxl) + ENDDO + + ! loop for element + ! print*, 'minelm is', minelm, 'maxelm is', maxelm + DO i=1, numelm + DO j=1,numelm_ + IF (landelm%eindex(i) == landelm_%eindex(j)) THEN + np = grid_patch_s (i) + np_= grid_patch_s_(j) + + IF (np.le.0 .or. np_.le.0) CYCLE + + ! IF element is still present, loop for patches in same element + DO WHILE (np.le.grid_patch_e(i) .and. np_.le.grid_patch_e_(j)) + + ! IF a patch is missing, CYCLE + IF (patchclass(np) > patchclass_(np_)) THEN + np_= np_+ 1 + CYCLE + ENDIF + + ! IF a patch is added, CYCLE + IF (patchclass(np) < patchclass_(np_)) THEN + np = np + 1 + CYCLE + ENDIF + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + u = patch2urban (np ) + u_= patch2urban_(np_) + + ! vars assignment needs same urb class for urban patch + IF (patchclass(np) == URBAN) THEN + ! IF a Urban type is missing, CYCLE + IF (landurban%settyp(u) > urbclass_(u_)) THEN + np_= np_+ 1 + CYCLE + ENDIF + + ! IF a urban type is added, CYCLE + IF (landurban%settyp(u) < urbclass_(u_)) THEN + np = np + 1 + CYCLE + ENDIF + ENDIF + ENDIF +#endif + ! otherwise, set patch value + ! only for the same patch type + z_sno (:,np) = z_sno_ (:,np_) + dz_sno (:,np) = dz_sno_ (:,np_) + t_soisno (:,np) = t_soisno_ (:,np_) + wliq_soisno (:,np) = wliq_soisno_ (:,np_) + wice_soisno (:,np) = wice_soisno_ (:,np_) + scv (np) = scv_ (np_) + smp (:,np) = smp_ (:,np_) + hk (:,np) = hk_ (:,np_) + t_grnd (np) = t_grnd_ (np_) + tleaf (np) = tleaf_ (np_) + ldew (np) = ldew_ (np_) + ldew_rain (np) = ldew_rain_ (np_) + ldew_snow (np) = ldew_snow_ (np_) + fwet_snow (np) = fwet_snow_ (np_) + sag (np) = sag_ (np_) + snowdp (np) = snowdp_ (np_) + fsno (np) = fsno_ (np_) + sigf (np) = sigf_ (np_) + ! In case lai+sai come into existence this year, set sigf to 1 + IF ( (sigf(np) .eq. 0) .and. ((lai(np) + sai(np)) .gt. 0) ) THEN + sigf(np) = 1 + ENDIF + zwt (np) = zwt_ (np_) + wa (np) = wa_ (np_) + wdsrf (np) = wdsrf_ (np_) + rss (np) = rss_ (np_) + + t_lake (:,np) = t_lake_ (:,np_) + lake_icefrac(:,np) = lake_icefrac_(:,np_) + savedtke1 (np) = savedtke1_ (np_) +IF(DEF_USE_PLANTHYDRAULICS)THEN + !Plant Hydraulic variables + vegwp (:,np) = vegwp_ (:,np_) + gs0sun (np) = gs0sun_ (np_) + gs0sha (np) = gs0sha_ (np_) + !END plant hydraulic variables +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + !Ozone Stress variables + lai_old (np) = lai_old_ (np_) + o3uptakesun (np) = o3uptakesun_ (np_) + o3uptakesha (np) = o3uptakesha_ (np_) + !End ozone stress variables +ENDIF + snw_rds (:,np) = snw_rds_ (:,np_) + mss_bcpho (:,np) = mss_bcpho_ (:,np_) + mss_bcphi (:,np) = mss_bcphi_ (:,np_) + mss_ocpho (:,np) = mss_ocpho_ (:,np_) + mss_ocphi (:,np) = mss_ocphi_ (:,np_) + mss_dst1 (:,np) = mss_dst1_ (:,np_) + mss_dst2 (:,np) = mss_dst2_ (:,np_) + mss_dst3 (:,np) = mss_dst3_ (:,np_) + mss_dst4 (:,np) = mss_dst4_ (:,np_) + ssno_lyr(2,2,:,np) = ssno_lyr_(2,2,:,np_) + + trad (np) = trad_ (np_) + tref (np) = tref_ (np_) + qref (np) = qref_ (np_) + rst (np) = rst_ (np_) + emis (np) = emis_ (np_) + z0m (np) = z0m_ (np_) + zol (np) = zol_ (np_) + rib (np) = rib_ (np_) + ustar (np) = ustar_ (np_) + qstar (np) = qstar_ (np_) + tstar (np) = tstar_ (np_) + fm (np) = fm_ (np_) + fh (np) = fh_ (np_) + fq (np) = fq_ (np_) + +IF(DEF_USE_IRRIGATION)THEN + sum_irrig (np) = sum_irrig_ (np_) + sum_irrig_count (np) = sum_irrig_count_ (np_) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +IF (patchtype(np)==0 .and. patchtype_(np_)==0) THEN + ip = patch_pft_s (np ) + ip_= patch_pft_s_(np_) + + IF (ip.le.0 .or. ip_.le.0) THEN + print *, "Error in REST_LulccTimeVariables LULC_IGBP_PFT|LULC_IGBP_PC!" + CALL CoLM_stop () + ENDIF + + DO WHILE (ip.le.patch_pft_e(np) .and. ip_.le.patch_pft_e_(np_)) + + ! IF a PFT is missing, CYCLE + IF (pftclass(ip) > pftclass_(ip_)) THEN + ip_= ip_+ 1 + CYCLE + ENDIF + + ! IF a PFT is added, CYCLE + IF (pftclass(ip) < pftclass_(ip_)) THEN + ip = ip + 1 + CYCLE + ENDIF + + ! for the same PFT, set PFT value + tleaf_p (ip) = tleaf_p_ (ip_) + ldew_p (ip) = ldew_p_ (ip_) + ldew_rain_p(ip) = ldew_rain_p_(ip_) + ldew_snow_p(ip) = ldew_snow_p_(ip_) + fwet_snow_p(ip) = fwet_snow_p_(ip_) + sigf_p (ip) = sigf_p_ (ip_) + + tref_p (ip) = tref_p_ (ip_) + qref_p (ip) = qref_p_ (ip_) + rst_p (ip) = rst_p_ (ip_) + z0m_p (ip) = z0m_p_ (ip_) + +IF(DEF_USE_PLANTHYDRAULICS)THEN + ! Plant Hydraulic variables + vegwp_p (:,ip) = vegwp_p_ (:,ip_) + gs0sun_p (ip) = gs0sun_p_ (ip_) + gs0sha_p (ip) = gs0sha_p_ (ip_) + ! end plant hydraulic variables +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + ! Ozone Stress Variables + lai_old_p (ip) = lai_old_p_ (ip_) + o3uptakesun_p (ip) = o3uptakesun_p_ (ip_) + o3uptakesha_p (ip) = o3uptakesha_p_ (ip_) + ! End allocate Ozone Stress Variables +ENDIF + ip = ip + 1 + ip_= ip_+ 1 + ENDDO + ps = patch_pft_s(np) + pe = patch_pft_e(np) + ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) +ENDIF +#endif + +#ifdef URBAN_MODEL +IF (patchclass(np)==URBAN .and. patchclass_(np_)==URBAN) THEN + + ! u = patch2urban (np ) + ! u_= patch2urban_(np_) + + IF (u.le.0 .or. u_.le.0) THEN + print *, "Error in REST_LulccTimeVariables URBAN_MODEL!" + CALL CoLM_stop () + ENDIF + + ! ! IF a Urban type is missing, CYCLE + ! IF (landurban%settyp(u) > urbclass_(u_)) THEN + ! np_= np_+ 1 + ! CYCLE + ! ENDIF + + ! ! IF a urban type is added, CYCLE + ! IF (landurban%settyp(u) < urbclass_(u_)) THEN + ! np = np + 1 + ! CYCLE + ! ENDIF + + ! otherwise, set urban value + ! include added urban and the same urban type + fwsun (u) = fwsun_ (u_) + dfwsun (u) = dfwsun_ (u_) + + sroof (:,:,u) = sroof_ (:,:,u_) + swsun (:,:,u) = swsun_ (:,:,u_) + swsha (:,:,u) = swsha_ (:,:,u_) + sgimp (:,:,u) = sgimp_ (:,:,u_) + sgper (:,:,u) = sgper_ (:,:,u_) + slake (:,:,u) = slake_ (:,:,u_) + + lwsun (u) = lwsun_ (u_) + lwsha (u) = lwsha_ (u_) + lgimp (u) = lgimp_ (u_) + lgper (u) = lgper_ (u_) + lveg (u) = lveg_ (u_) + + z_sno_roof (:,u) = z_sno_roof_ (:,u_) + z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) + z_sno_gper (:,u) = z_sno_gper_ (:,u_) + z_sno_lake (:,u) = z_sno_lake_ (:,u_) + + dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) + dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) + dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) + dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) + + t_roofsno (:,u) = t_roofsno_ (:,u_) + t_wallsun (:,u) = t_wallsun_ (:,u_) + t_wallsha (:,u) = t_wallsha_ (:,u_) + t_gimpsno (:,u) = t_gimpsno_ (:,u_) + t_gpersno (:,u) = t_gpersno_ (:,u_) + t_lakesno (:,u) = t_lakesno_ (:,u_) + + troof_inner (u) = troof_inner_ (u_) + twsun_inner (u) = twsun_inner_ (u_) + twsha_inner (u) = twsha_inner_ (u_) + + wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) + wice_roofsno (:,u) = wice_roofsno_ (:,u_) + wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) + wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) + wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) + wice_gpersno (:,u) = wice_gpersno_ (:,u_) + wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) + wice_lakesno (:,u) = wice_lakesno_ (:,u_) + + sag_roof (u) = sag_roof_ (u_) + sag_gimp (u) = sag_gimp_ (u_) + sag_gper (u) = sag_gper_ (u_) + sag_lake (u) = sag_lake_ (u_) + scv_roof (u) = scv_roof_ (u_) + scv_gimp (u) = scv_gimp_ (u_) + scv_gper (u) = scv_gper_ (u_) + scv_lake (u) = scv_lake_ (u_) + fsno_roof (u) = fsno_roof_ (u_) + fsno_gimp (u) = fsno_gimp_ (u_) + fsno_gper (u) = fsno_gper_ (u_) + fsno_lake (u) = fsno_lake_ (u_) + snowdp_roof (u) = snowdp_roof_ (u_) + snowdp_gimp (u) = snowdp_gimp_ (u_) + snowdp_gper (u) = snowdp_gper_ (u_) + snowdp_lake (u) = snowdp_lake_ (u_) + + Fhac (u) = Fhac_ (u_) + Fwst (u) = Fwst_ (u_) + Fach (u) = Fach_ (u_) + Fahe (u) = Fahe_ (u_) + Fhah (u) = Fhah_ (u_) + vehc (u) = vehc_ (u_) + meta (u) = meta_ (u_) + t_room (u) = t_room_ (u_) + t_roof (u) = t_roof_ (u_) + t_wall (u) = t_wall_ (u_) + tafu (u) = tafu_ (u_) + urb_green (u) = urb_green_ (u_) + + wliq_soisno(: ,np) = 0. + wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) + wliq_soisno(: ,np) = wliq_soisno (: ,np) & + + wliq_gpersno(: ,u )*(1-froof(u))*fgper(u) + wliq_soisno(:1,np) = wliq_soisno (:1,np) & + + wliq_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) + + wice_soisno(: ,np) = 0. + wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) + wice_soisno(: ,np) = wice_soisno (: ,np) & + + wice_gpersno(: ,u )*(1-froof(u))*fgper(u) + wice_soisno(:1,np) = wice_soisno (:1,np) & + + wice_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) + + scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) & + + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) +ENDIF +#endif + np = np + 1 + np_= np_+ 1 + ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (allocated(grid_patch_s )) deallocate (grid_patch_s ) + IF (allocated(grid_patch_e )) deallocate (grid_patch_e ) + IF (allocated(grid_patch_s_)) deallocate (grid_patch_s_ ) + IF (allocated(grid_patch_e_)) deallocate (grid_patch_e_ ) + IF (allocated(locpxl )) deallocate (locpxl ) + ENDIF + END SUBROUTINE REST_LulccTimeVariables + + + SUBROUTINE deallocate_LulccTimeVariables + + USE MOD_SPMD_Task + USE MOD_Lulcc_Vars_TimeInvariants, only: numpatch_, numpft_, numpc_, numurban_ + +! -------------------------------------------------- +! Deallocates memory for Lulcc time variant variables +! -------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch_ > 0) THEN + deallocate (z_sno_ ) + deallocate (dz_sno_ ) + deallocate (t_soisno_ ) + deallocate (wliq_soisno_ ) + deallocate (wice_soisno_ ) + deallocate (smp_ ) + deallocate (hk_ ) + deallocate (t_grnd_ ) + deallocate (tleaf_ ) + deallocate (ldew_ ) + deallocate (ldew_rain_ ) + deallocate (ldew_snow_ ) + deallocate (fwet_snow_ ) + deallocate (sag_ ) + deallocate (scv_ ) + deallocate (snowdp_ ) + deallocate (fsno_ ) + deallocate (sigf_ ) + deallocate (zwt_ ) + deallocate (wa_ ) + deallocate (wdsrf_ ) + deallocate (rss_ ) + + deallocate (t_lake_ ) + deallocate (lake_icefrac_ ) + deallocate (savedtke1_ ) + + !Plant Hydraulic variables + deallocate (vegwp_ ) + deallocate (gs0sun_ ) + deallocate (gs0sha_ ) + !END plant hydraulic variables + + !Ozone Stress variables + deallocate (lai_old_ ) + deallocate (o3uptakesun_ ) + deallocate (o3uptakesha_ ) + !End ozone stress variables + + deallocate (snw_rds_ ) + deallocate (mss_bcpho_ ) + deallocate (mss_bcphi_ ) + deallocate (mss_ocpho_ ) + deallocate (mss_ocphi_ ) + deallocate (mss_dst1_ ) + deallocate (mss_dst2_ ) + deallocate (mss_dst3_ ) + deallocate (mss_dst4_ ) + deallocate (ssno_lyr_ ) + + deallocate (trad_ ) + deallocate (tref_ ) + deallocate (qref_ ) + deallocate (rst_ ) + deallocate (emis_ ) + deallocate (z0m_ ) + deallocate (zol_ ) + deallocate (rib_ ) + deallocate (ustar_ ) + deallocate (qstar_ ) + deallocate (tstar_ ) + deallocate (fm_ ) + deallocate (fh_ ) + deallocate (fq_ ) + + deallocate (sum_irrig_ ) + deallocate (sum_irrig_count_ ) + + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft_ > 0) THEN + deallocate (tleaf_p_ ) + deallocate (ldew_p_ ) + deallocate (ldew_rain_p_ ) + deallocate (ldew_snow_p_ ) + deallocate (fwet_snow_p_ ) + deallocate (sigf_p_ ) + deallocate (tref_p_ ) + deallocate (qref_p_ ) + deallocate (rst_p_ ) + deallocate (z0m_p_ ) + + ! Plant Hydraulic variables + deallocate (vegwp_p_ ) + deallocate (gs0sun_p_ ) + deallocate (gs0sha_p_ ) + ! end plant hydraulic variables + + ! Allocate Ozone Stress Variables + deallocate (lai_old_p_ ) + deallocate (o3uptakesun_p_ ) + deallocate (o3uptakesha_p_ ) + ! End allocate Ozone Stress Variables + ENDIF +#endif + +#ifdef URBAN_MODEL + IF (numurban_ > 0) THEN + deallocate (fwsun_ ) + deallocate (dfwsun_ ) + + deallocate (sroof_ ) + deallocate (swsun_ ) + deallocate (swsha_ ) + deallocate (sgimp_ ) + deallocate (sgper_ ) + deallocate (slake_ ) + + deallocate (lwsun_ ) + deallocate (lwsha_ ) + deallocate (lgimp_ ) + deallocate (lgper_ ) + deallocate (lveg_ ) + + deallocate (z_sno_roof_ ) + deallocate (z_sno_gimp_ ) + deallocate (z_sno_gper_ ) + deallocate (z_sno_lake_ ) + + deallocate (dz_sno_roof_ ) + deallocate (dz_sno_gimp_ ) + deallocate (dz_sno_gper_ ) + deallocate (dz_sno_lake_ ) + + deallocate (t_roofsno_ ) + deallocate (t_wallsun_ ) + deallocate (t_wallsha_ ) + deallocate (t_gimpsno_ ) + deallocate (t_gpersno_ ) + deallocate (t_lakesno_ ) + + deallocate (troof_inner_ ) + deallocate (twsun_inner_ ) + deallocate (twsha_inner_ ) + + deallocate (wliq_roofsno_ ) + deallocate (wice_roofsno_ ) + deallocate (wliq_gimpsno_ ) + deallocate (wice_gimpsno_ ) + deallocate (wliq_gpersno_ ) + deallocate (wice_gpersno_ ) + deallocate (wliq_lakesno_ ) + deallocate (wice_lakesno_ ) + + deallocate (sag_roof_ ) + deallocate (sag_gimp_ ) + deallocate (sag_gper_ ) + deallocate (sag_lake_ ) + deallocate (scv_roof_ ) + deallocate (scv_gimp_ ) + deallocate (scv_gper_ ) + deallocate (scv_lake_ ) + deallocate (fsno_roof_ ) + deallocate (fsno_gimp_ ) + deallocate (fsno_gper_ ) + deallocate (fsno_lake_ ) + deallocate (snowdp_roof_ ) + deallocate (snowdp_gimp_ ) + deallocate (snowdp_gper_ ) + deallocate (snowdp_lake_ ) + + deallocate (Fhac_ ) + deallocate (Fwst_ ) + deallocate (Fach_ ) + deallocate (Fahe_ ) + deallocate (Fhah_ ) + deallocate (vehc_ ) + deallocate (meta_ ) + deallocate (t_room_ ) + deallocate (t_roof_ ) + deallocate (t_wall_ ) + deallocate (tafu_ ) + deallocate (urb_green_ ) + ENDIF +#endif + ENDIF + + END SUBROUTINE deallocate_LulccTimeVariables + +END MODULE MOD_Lulcc_Vars_TimeVariables +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 new file mode 100644 index 0000000000..8fbfe86df5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 @@ -0,0 +1,1455 @@ +#include + +MODULE MOD_3DCanopyRadiation + +!----------------------------------------------------------------------- +! +! --- A 3D Canopy Radiation Transfer Model --- +! for Plant Community (PC) Simulation +! +! Sun +! /// +! /// +! _____ tree _____ --- Layer3 +! /||||||| ||||||| +! /||||||||| ||||||||| +! / \|||||// / \|||||// +! / | / / | / --- Layer2 +! / | / / | / /xx\ +! / shadow |/ grass / |/ shrub/\xx/ +! __/.........|_________\\//\/......|________/..|/__ --- Layer1 +! ///////////////////////////////////////////////////////////////////// +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: +#ifdef LULC_IGBP_PC + PUBLIC :: ThreeDCanopy_wrap +#endif + PUBLIC :: ThreeDCanopy + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + +#ifdef LULC_IGBP_PC + + SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! This is a wrap SUBROUTINE to CALL 3D canopy radiative model below +! CALL ThreeDCanopy() +! +! Created by Hua Yuan, 08/2019 +! +! !REFERENCES: +! Yuan, H., R. E. Dickinson, Y. Dai, M. J. Shaikh, L. Zhou, W. Shangguan, +! and D. Ji, 2014: A 3D canopy radiative transfer model for global climate +! modeling: Description, validation, and application. Journal of Climate, +! 27, 1168-1192, https://doi.org/10.1175/JCLI-D-13-00155.1. +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW, DEF_PC_CROP_SPLIT + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_Global + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch + real(r8), intent(in) :: czen + real(r8), intent(in) :: albg(2,2) + real(r8), intent(out) :: albv(2,2) + real(r8), intent(out) :: tran(2,3) + real(r8), intent(out) :: ssun(2,2) + real(r8), intent(out) :: ssha(2,2) + +!-------------------------- Local Variables ---------------------------- + integer :: i, p, ps, pe, pn; + + ! sunlit absorption fraction calculation mode + ! .true. USE 3D model, otherwise USE 1D case + ! NOTE: The 3D version will be activated in the new release, + ! accompanied by a new set of canopy structure data. + logical, parameter :: fsun3D = .false. + + ! define allocatable variables + integer, allocatable :: canlay(:) + real(r8), allocatable :: albd(:,:), albi(:,:) + real(r8), allocatable :: fabd(:,:), fabi(:,:), fadd(:,:) + real(r8), allocatable :: ftdd(:,:), ftid(:,:), ftii(:,:) + real(r8), allocatable :: rho (:,:), tau (:,:) + real(r8), allocatable :: csiz(:), chgt(:), chil(:), lsai(:) + real(r8), allocatable :: fsun_id(:), fsun_ii(:), psun(:) + real(r8), allocatable :: phi1(:), phi2(:), gdir(:), fcover(:) + + ! vegetation snow optical properties, 1:vis, 2:nir + real(r8) :: rho_sno(2), tau_sno(2) + data rho_sno(1), rho_sno(2) /0.5, 0.2/ + data tau_sno(1), tau_sno(2) /0.3, 0.2/ +!----------------------------------------------------------------------- + + ! get patch PFT index + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + ! Calculate the end index of natrue PFT + DO i = ps, pe + pn = i + p = pftclass(i) + IF (DEF_PC_CROP_SPLIT .and. p.ge.15) THEN + pn = pn - 1 + EXIT + ENDIF + ENDDO + + ! If pn less than start index, there is no nature PFT + ! Otherwise, set the new end index + IF (pn.ge.ps) THEN + pe = pn + ELSE + RETURN + ENDIF + + ! allocate memory for defined variables + allocate (albd (ps:pe, 2) ) + allocate (albi (ps:pe, 2) ) + allocate (fabd (ps:pe, 2) ) + allocate (fabi (ps:pe, 2) ) + allocate (fadd (ps:pe, 2) ) + allocate (ftdd (ps:pe, 2) ) + allocate (ftid (ps:pe, 2) ) + allocate (ftii (ps:pe, 2) ) + allocate (rho (ps:pe, 2) ) + allocate (tau (ps:pe, 2) ) + allocate (csiz (ps:pe) ) + allocate (chgt (ps:pe) ) + allocate (chil (ps:pe) ) + allocate (lsai (ps:pe) ) + allocate (canlay (ps:pe) ) + allocate (fsun_id(ps:pe) ) + allocate (fsun_ii(ps:pe) ) + allocate (psun (ps:pe) ) + allocate (phi1 (ps:pe) ) + allocate (phi2 (ps:pe) ) + allocate (gdir (ps:pe) ) + allocate (fcover (ps:pe) ) + + ! initialization + albd=1.; albi=1.; fabd=0.; fabi=0.; + ftdd=1.; ftid=0.; ftii=1.; fadd=0.; + csiz(:) = (htop_p(ps:pe) - hbot_p(ps:pe)) / 2 + chgt(:) = (htop_p(ps:pe) + hbot_p(ps:pe)) / 2 + lsai(:) = lai_p(ps:pe) + sai_p(ps:pe) + fcover(ps:pe) = pftfrac(ps:pe) / sum(pftfrac(ps:pe)) + + ! calculate weighted plant optical properties + ! loop for each PFT + rho = 0. + tau = 0. + DO i = ps, pe + + p = pftclass(i) + canlay(i) = canlay_p(p) + chil(i) = chil_p(p) + + IF (lsai(i) > 0.) THEN + rho(i,:) = rho_p(:,1,p)*lai_p(i)/lsai(i) & + + rho_p(:,2,p)*sai_p(i)/lsai(i) + tau(i,:) = tau_p(:,1,p)*lai_p(i)/lsai(i) & + + tau_p(:,2,p)*sai_p(i)/lsai(i) + ENDIF + + ! account for snow on vegetation + IF ( DEF_VEG_SNOW ) THEN + ! modify rho, tau, USE: fwet_snow_p + rho(i,:) = (1-fwet_snow_p(i))*rho(i,:) + fwet_snow_p(i)*rho_sno(:) + tau(i,:) = (1-fwet_snow_p(i))*tau(i,:) + fwet_snow_p(i)*tau_sno(:) + ENDIF + + ENDDO + + ! CALL 3D canopy radiation transfer model + CALL ThreeDCanopy(ps, pe, canlay, fcover(ps:pe), csiz, chgt, chil, czen, & + lsai, rho, tau, albg(:,1), albg(:,2), albd, albi, & + fabd, fabi, ftdd, ftid, ftii, fadd, psun, fsun_id, fsun_ii, & + thermk_p(ps:pe), fshade_p(ps:pe) ) + + ! calculate extkb_p, extkd_p + ! applied for 1D case + extkd_p(ps:pe) = 0.719 !used for scaling-up coefficients from leaf to canopy + + ! 11/07/2018: calculate gee FUNCTION consider LAD + DO i = ps, pe + p = pftclass(i) + phi1(i) = 0.5 - 0.633 * chil_p(p) - 0.33 * chil_p(p) * chil_p(p) + phi2(i) = 0.877 * ( 1. - 2. * phi1(i) ) + ENDDO + + ! 11/07/2018: calculate gee FUNCTION consider LAD + gdir = phi1 + phi2*czen + extkb_p(ps:pe) = gdir/czen + + fsun_id(:) = 0. + fsun_ii(:) = 0. + + ! 1D sunlit leaves absorption fraction in diffuse format + ! Table 3, Yuan et al., (2014). + DO p = ps, pe + IF (lsai(p) > 0. .and. .not.fsun3D) THEN + fsun_id(p) = (1._r8 - exp(-2._r8*extkb_p(p)*lsai(p))) & + / (1._r8 - exp(-extkb_p(p)*lsai(p))) & + / 2.0_r8 * psun(p) + + fsun_ii(p) = (1._r8 - exp(-extkb_p(p)*lsai(p)-lsai(p))) & + / (1._r8 - exp(-lsai(p))) & + / (1._r8 + extkb_p(p)) * psun(p) + ENDIF + ENDDO + + ! Calculate albv, ssun, ssha and tran for PFTs + ! NOTE: CoLM (1/2,): vis/nir; (,1/2): dir/dif + albv(1,1) = albd(ps,1); albv(1,2) = albi(ps,1) + albv(2,1) = albd(ps,2); albv(2,2) = albi(ps,2) + + ! ssun(band, dir/dif, pft), fabd/fadd(pft, band) + ssun_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * fsun_id + fadd(:,1) + ssun_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * fsun_id + fadd(:,2) + ssha_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * (1.-fsun_id) + ssha_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * (1.-fsun_id) + ssun_p(1,2,ps:pe) = fabi(:,1) * fsun_ii + ssun_p(2,2,ps:pe) = fabi(:,2) * fsun_ii + ssha_p(1,2,ps:pe) = fabi(:,1) * (1.-fsun_ii) + ssha_p(2,2,ps:pe) = fabi(:,2) * (1.-fsun_ii) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + tran(1,1) = ftid(ps,1) + tran(2,1) = ftid(ps,2) + tran(1,3) = ftdd(ps,1) + tran(2,3) = ftdd(ps,2) + tran(1,2) = ftii(ps,1) + tran(2,2) = ftii(ps,2) + + ! deallocate memory for defined variables + deallocate (albd ) + deallocate (albi ) + deallocate (fabd ) + deallocate (fabi ) + deallocate (fadd ) + deallocate (ftdd ) + deallocate (ftid ) + deallocate (ftii ) + deallocate (rho ) + deallocate (tau ) + deallocate (csiz ) + deallocate (chgt ) + deallocate (chil ) + deallocate (lsai ) + deallocate (canlay ) + deallocate (fsun_id ) + deallocate (fsun_ii ) + deallocate (psun ) + deallocate (phi1 ) + deallocate (phi2 ) + deallocate (gdir ) + deallocate (fcover ) + + END SUBROUTINE ThreeDCanopy_wrap +#endif + + + SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & + lsai, rho, tau, albgrd, albgri, albd, albi, & + fabd, fabi, ftdd, ftid, ftii, fadd, psun, & + fsun_id, fsun_ii, thermk, fshade) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! ThreeDCanopy based on Dickinson (2008) using three canopy layer +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or +! diffuse flux given an underlying surface with known albedo. +! +! Created by Hua Yuan, 08/2019 +! +! !HISTORY: +! Before 2013: Robert E. Dickinson proposed the initial idea. Dickinson and +! Muhammad J. Shake contributed to the code writing. +! +! !REFERENCES: +! Yuan, H., R. E. Dickinson, Y. Dai, M. J. Shaikh, L. Zhou, W. Shangguan, +! and D. Ji, 2014: A 3D canopy radiative transfer model for global climate +! modeling: Description, validation, and application. Journal of Climate, +! 27, 1168-1192, https://doi.org/10.1175/JCLI-D-13-00155.1. +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + + integer, parameter :: numrad = 2 + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: ps, pe !pft index bounds + integer , intent(in) :: canlay(ps:pe) !canopy level for current pft + real(r8), intent(in) :: fcover(ps:pe) !fractional cover of pft within a patch + real(r8), intent(in) :: csiz (ps:pe) !crown size of vegetation + real(r8), intent(in) :: chgt (ps:pe) !central height of crown + ! NOTE: The 'cdcw' parameter will be activated in the new release, accompanied by + ! a new set of canopy structure data. Currently we set cdcw = 1, i.e., sphere + real(r8) :: cdcw (ps:pe) !crown depth to crown width + real(r8), intent(in) :: chil (ps:pe) !leaf angle distribution parameter + real(r8), intent(in) :: lsai (ps:pe) !LAI+SAI + real(r8), intent(in) :: rho (ps:pe,numrad) !leaf/stem refl weighted by fraction LAI and SAI + real(r8), intent(in) :: tau (ps:pe,numrad) !leaf/stem tran weighted by fraction LAI and SAI + + real(r8), intent(in) :: coszen !cosine solar zenith angle for next time step + real(r8), intent(in) :: albgrd(numrad) !ground albedo (direct) (column-level) + real(r8), intent(in) :: albgri(numrad) !ground albedo (diffuse)(column-level) + + real(r8), intent(out) :: albd(ps:pe,numrad) !surface albedo (direct) + real(r8), intent(out) :: albi(ps:pe,numrad) !surface albedo (diffuse) + real(r8), intent(out) :: fabd(ps:pe,numrad) !flux absorbed by veg per unit direct flux + real(r8), intent(out) :: fabi(ps:pe,numrad) !flux absorbed by veg per unit diffuse flux + real(r8), intent(out) :: ftdd(ps:pe,numrad) !down direct flux below veg per unit dir flx + real(r8), intent(out) :: ftid(ps:pe,numrad) !down diffuse flux below veg per unit dir flx + real(r8), intent(out) :: ftii(ps:pe,numrad) !down diffuse flux below veg per unit dif flx + real(r8), intent(out) :: fadd(ps:pe,numrad) !absorbed flux in direct mode per unit direct flux + real(r8), intent(out) :: psun (ps:pe) !percent sunlit vegetation cover + real(r8), intent(out) :: fsun_id (ps:pe) !frac of dif rad abs. by sunlit leaves incident dir + real(r8), intent(out) :: fsun_ii (ps:pe) !frac of dif rad abs. by sunlit leaves incident dif + real(r8), intent(out) :: thermk (ps:pe) !direct transmittance of diffuse radiation + real(r8), intent(out) :: fshade (ps:pe) !shadow in diffuse case of vegetation + +!-------------------------- Local Variables ---------------------------- + real(r8), parameter :: mpe = 1.0e-06_r8 !prevents overflow for division by zero + integer , parameter :: nlay=3 !number of canopy layers + real(r8), parameter :: D0=0.0_r8 !double accuracy real number + real(r8), parameter :: D1=1.0_r8 !double accuracy real number + real(r8), parameter :: D2=2.0_r8 !double accuracy real number + real(r8), parameter :: D3=3.0_r8 !double accuracy real number + real(r8), parameter :: D4=4.0_r8 !double accuracy real number + real(r8), parameter :: D6=6.0_r8 !double accuracy real number + real(r8), parameter :: D7=7.0_r8 !double accuracy real number + real(r8), parameter :: D8=8.0_r8 !double accuracy real number + real(r8), parameter :: D9=9.0_r8 !double accuracy real number + real(r8), parameter :: D10=10.0_r8 !double accuracy real number + real(r8), parameter :: D16=16.0_r8 !double accuracy real number + real(r8), parameter :: DH=0.5_r8 !quad accuracy real number + real(r16),parameter :: DDH=0.5_r16 !quad accuracy real number + real(r16),parameter :: DD0=0.0_r16 !quad accuracy real number + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + real(r8) ,parameter :: pi=3.14159265358979323846_r8 !pi + + integer :: ib !band index 1:vis 2:nir + integer :: ip,ic,ig,kband !array indices for pft,column,grid + integer :: kfr !variable for layer radiation coming from + integer :: klay !variable for layer absorbing radiation + integer :: kto !variable for layer radiation is transmitted to + integer :: lev !do loop variable + integer :: nn !do loop variable + integer :: nsoilveg !number of pfts in gridcell with veg and cosz > 0 + integer :: nstep !time step index + integer :: clev !canopy level for current pft + + real(r8) :: albd_col(numrad) !surface reflection (direct) for column + real(r8) :: albi_col(numrad) !surface reflection (diffuse) for column + real(r8) :: hbot_lay(nlay) !average canopy bottom in layer + real(r8) :: chgt_lay(nlay) !average canopy height in layer + real(r8) :: csiz_lay(nlay) !average canopy size in layer + real(r8) :: cdcw_lay(nlay) !crown depth to crown width for layers + real(r8) :: omg_lay(nlay,numrad) !average omega for all three layer + real(r8) :: rho_lay(nlay,numrad) !average rho for all three layer + real(r8) :: tau_lay(nlay,numrad) !average tau for all three layer + real(r8) :: lsai_lay(nlay) !average lsai for each layer + real(r8) :: cosz_lay(nlay) !0.001 <= coszen <= 1.000 + real(r8) :: cosd_lay(nlay) !0.001 <= coszen <= 1.000 + real(r8) :: delta !variable for increment layer in loop + real(r8) :: dif !diffuse radiation transmitted + real(r8) :: dir !direct radiation transmitted + real(r8) :: fabd_col(numrad) !flux absorbed by veg per unit diffuse flux + real(r8) :: fabd_lay(nlay,numrad) !layer absorption for direct beam + real(r8) :: fabi_col(numrad) !flux absorbed by veg per unit diffuse flux + real(r8) :: fabi_lay(nlay,numrad) !layer absorption for diffuse beam + real(r8) :: fabs_lay(0:4,numrad) !layer absorption for all five layers + real(r8) :: fabs_leq(0:4,numrad) !layer absorption for all five layers + real(r8) :: A(6,6) !three-layer radiation transfer equation + !(EQ. 19, Yuan et al., 2014) + real(r8) :: B(6,2) !three-layer radiation transfer equation + !(EQ. 19, Yuan et al., 2014) + real(r8) :: X(6,2) !three-layer radiation transfer equation + !(EQ. 19, Yuan et al., 2014) + real(r8) :: fabsm !pft absorption for multiple reflections + real(r8) :: faid_lay(nlay) !layer diffused absorption for direct beam + real(r8) :: faid_p !pft absorption direct beam + real(r8) :: faii_lay(nlay) !layer diffused absorption for diffuse beam + real(r8) :: faii_p !pft absorption diffuse beam + real(r8) :: fc0(nlay) !canopy fraction for layers + real(r8) :: frid_lay(nlay) !layer reflection for direct beam + real(r8) :: frid_p !pft reflection direct beam + real(r8) :: frii_lay(nlay) !layer reflection for indirect beam + real(r8) :: ftdd_lay(nlay) !unscattered layer transmission for direct beam + real(r8) :: ftdi_lay(nlay) !unscattered layer transmission for indirect beam + real(r8) :: ftdd_lay_orig(nlay) !unscattered layer transmission for direct beam + !without lad/crown_shape calibration + real(r8) :: ftdi_lay_orig(nlay) !unscattered layer transmission for indirect beam + !without lad/crown_shape calibration + real(r8) :: psun_lay(nlay) !percent sunlit vegetation cover for layers + real(r8) :: fsun_id_lay(nlay) !frac of dif rad abs. by sunlit leaf incident dir + real(r8) :: fsun_ii_lay(nlay) !frac of dif rad abs. by sunlit leaf incident dif + real(r8) :: fsun_dd_lay(nlay) !frac of dif rad abs. by sunlit leaf incident downward dir + real(r8) :: fsun_dw_lay(nlay) !frac of dif rad abs. by sunlit leaf incident downward dif + real(r8) :: fsun_up_lay(nlay) !frac of dif rad abs. by sunlit leaf incident upward dif + real(r8) :: ftid_lay(nlay) !diffused layer transmission for direct beam + real(r8) :: ftii_lay(nlay) !diffused layer transmission for diffuse beam + real(r8) :: ftran !pft transmittance + real(r8) :: gee=0.5_r8 !Ross G factor geometric blocking + real(r8) :: gdir(ps:pe) !G factor considering LAD for incident direct radiation + real(r8) :: gdif(ps:pe) !G factor considering LAD for incident diffuse radiation + real(r8) :: gdir_lay(nlay) !G factor considering LAD for incident direct radiation + real(r8) :: gdif_lay(nlay) !G factor considering LAD for incident diffuse radiation + real(r8) :: fcad(ps:pe) !calibration factor for LAD for direct radiation + real(r8) :: fcai(ps:pe) !calibration factor for LAD for diffuse radiation + real(r8) :: fcad_lay(nlay) !calibration factor for LAD for direct radiation + real(r8) :: fcai_lay(nlay) !calibration factor for LAD for diffuse radiation + real(r8) :: pad !probability function for absorption after two scat + real(r8) :: pai !probability of absorption for diffuse incident beam + real(r8) :: pfc !contribution of current pft in layer + real(r8) :: probm !prob photon reflect diffusely from ground reach canopy + real(r8) :: ref(0:nlay+1,0:nlay+1) !radiation reflected between five layers + real(r8) :: fadd_lay(nlay,numrad) !layer absorbed flux in direct mode per unit direct flux + real(r8) :: shad_oa(nlay,nlay) !shadow overlaps (direct beam) + real(r8) :: shadow_d(nlay) !layer shadow for direct beam + real(r8) :: shadow_i(nlay) !layer shadow for diffuse beam + real(r8) :: sum_fabd(3) !sum of absorption for all pfts in grid (direct) + real(r8) :: sum_fabi(3) !sum of absorption for all pfts in grid (diffuse) + real(r8) :: sum_fadd(nlay) !sum of absorbed flux in direct mode per unit direct flux + real(r8) :: taud_lay(nlay) !direct transmission for a layer + real(r8) :: taui_lay(nlay) !diffuse transmission for a layer + real(r8) :: trd(0:nlay+1,0:nlay+1) !direct radiation transmitted between five layers + real(r8) :: tri(0:4,0:4) !diffuse radiation transmitted between five layers + real(r8) :: tt(0:4,0:4) !unscattered direct radiation available at layer + real(r8) :: wl !fraction of LAI+SAI that is LAI + real(r8) :: ws !fraction of LAI+SAI that is SAI + real(r8) :: zenith !zenith angle + real(r8) :: ftdd_col !unscattered column transmission for direct beam + real(r8) :: fsun_f !forward incident light sunlit leaf absorption fraction + real(r8) :: fsun_b !backward incident light sunlit leaf absorption fraction + real(r8) :: fsun_a !temp variable 0.5*(fsun_f+fsun_b) + real(r8) :: fsun_d !temp variable 0.5*(fsun_f-fsun_b) + + real(r8) :: shadow_pd(ps:pe) !sky shadow area + real(r8) :: shadow_pi(ps:pe) !sky shadow area + real(r8) :: shadow_sky(ps:pe) !sky shadow area + real(r8) :: taud(ps:pe) !transmission to direct beam + real(r8) :: taui(ps:pe) !transmission to diffuse beam + real(r8) :: omega(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: ftdi(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: ftdd_orig(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: ftdi_orig(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: cosz(ps:pe) !0.001 <= coszen <= 1.000 + real(r8) :: cosd(ps:pe) !0.001 <= coszen <= 1.000 + logical :: soilveg(ps:pe) !true if pft over soil with veg and cosz > 0 + + real(r8) :: phi1(ps:pe), phi2(ps:pe) +!----------------------------------------------------------------------- + + ! 11/07/2018: calculate gee FUNCTION consider LAD + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + cdcw = 1. + cosz = coszen + zenith = acos(coszen) + cosz = cosz * sqrt(1 / (cdcw**2*sin(zenith)**2 + cos(zenith)**2)) + + cosd = cos(60._r8/180._r8*pi) + zenith = 60._r8/180._r8*pi + cosd = cosd * sqrt(1 / (cdcw**2*sin(zenith)**2 + cos(zenith)**2)) + + ! 11/07/2018: calculate gee FUNCTION consider LAD + gdir = phi1 + phi2*cosz + gdif = phi1 + phi2*cosd + + nsoilveg = 0 + + fc0 = D0 + omg_lay = D0; rho_lay = D0; tau_lay = D0 + chgt_lay = D0; cdcw_lay = D0; hbot_lay = D0 + csiz_lay = D0; lsai_lay = D0 + cosz_lay = D0; cosd_lay = D0 + gdir_lay = D0; gdif_lay = D0 + + DO ip = ps, pe + shadow_sky(ip) = D1 + + ! check elai and pft weight are non-zero + IF ( lsai(ip)>1.e-6_r8 .and. fcover(ip)>D0 ) THEN + + soilveg(ip) = .true. + nsoilveg = nsoilveg + 1 + + clev = canlay(ip) + fc0(clev) = fc0(clev) + fcover(ip) + + csiz_lay(clev) = csiz_lay(clev) + fcover(ip)*csiz(ip) + chgt_lay(clev) = chgt_lay(clev) + fcover(ip)*chgt(ip) + cdcw_lay(clev) = cdcw_lay(clev) + fcover(ip)*cdcw(ip) + lsai_lay(clev) = lsai_lay(clev) + fcover(ip)*lsai(ip) + cosz_lay(clev) = cosz_lay(clev) + fcover(ip)*cosz(ip) + cosd_lay(clev) = cosd_lay(clev) + fcover(ip)*cosd(ip) + gdir_lay(clev) = gdir_lay(clev) + fcover(ip)*gdir(ip) + gdif_lay(clev) = gdif_lay(clev) + fcover(ip)*gdif(ip) + + ! set optical properties + DO ib = 1, numrad + omega(ip,ib) = rho(ip,ib) + tau(ip,ib) + + ! sum of tau,rho and omega for pfts in a layer + tau_lay(clev,ib) = tau_lay(clev,ib) + fcover(ip)*(tau(ip,ib)) + rho_lay(clev,ib) = rho_lay(clev,ib) + fcover(ip)*(rho(ip,ib)) + omg_lay(clev,ib) = omg_lay(clev,ib) + fcover(ip)*(omega(ip,ib)) + + ENDDO ! ENDDO ib=1, numrad + ELSE + soilveg(ip) = .false. + ENDIF + ENDDO ! ENDDO ip + +!============================================================= +! layer average of lsai,tau,rho,omega... +!============================================================= + + DO lev = 1, 3 + IF (fc0(lev) > D0) THEN + csiz_lay(lev) = max(csiz_lay(lev)/fc0(lev),D0) + chgt_lay(lev) = max(chgt_lay(lev)/fc0(lev),D0) + hbot_lay(lev) = chgt_lay(lev) - csiz_lay(lev) + cdcw_lay(lev) = max(cdcw_lay(lev)/fc0(lev),D0) + lsai_lay(lev) = max(lsai_lay(lev)/fc0(lev),D0) + cosz_lay(lev) = max(cosz_lay(lev)/fc0(lev),D0) + cosd_lay(lev) = max(cosd_lay(lev)/fc0(lev),D0) + DO ib = 1, numrad + tau_lay(lev,ib) = max(tau_lay(lev,ib)/fc0(lev),D0) + rho_lay(lev,ib) = max(rho_lay(lev,ib)/fc0(lev),D0) + omg_lay(lev,ib) = max(omg_lay(lev,ib)/fc0(lev),D0) + ENDDO + gdir_lay(lev) = max(gdir_lay(lev)/fc0(lev),D0) + gdif_lay(lev) = max(gdif_lay(lev)/fc0(lev),D0) + ENDIF + ENDDO ! ENDDO ib + +!============================================================= +! layer shadows +!============================================================= + + shadow_d = D0 + shadow_i = D0 + DO lev =1, 3 + IF ( fc0(lev)>D0 .and. cosz_lay(lev)>D0 ) THEN + shadow_d(lev) = (D1 - exp(-D1*fc0(lev)/cosz_lay(lev))) & + / (D1 - fc0(lev)*exp(-D1/cosz_lay(lev))) + shadow_d(lev) = max(fc0(lev), shadow_d(lev)) + shadow_i(lev) = (D1 - exp(-D1*fc0(lev)/cosd_lay(lev))) & + / (D1 - fc0(lev)*exp(-D1/cosd_lay(lev))) + shadow_i(lev) = max(fc0(lev), shadow_i(lev)) + ENDIF + ENDDO + +!============================================================= +! taud and ftdd for layers +!============================================================= + + taud_lay = D0; taui_lay = D0 + ftdd_lay = D0; ftdi_lay = D0 + fcad_lay = D1; fcai_lay = D1 + ftdd_lay_orig = D0 + ftdi_lay_orig = D0 + + DO lev = 1, 3 + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + + taud_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev) & + / (cosz_lay(lev)*shadow_d(lev)) + taui_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev) & + / (cosd_lay(lev)*shadow_i(lev)) + + ! 11/07/2018: LAD calibration + ftdd_lay_orig(lev) = tee(DD1*taud_lay(lev)) + ftdi_lay_orig(lev) = tee(DD1*taui_lay(lev)) + + ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) + ftdd_lay(lev) = tee(DD1*taud_lay(lev)/gee*gdir_lay(lev)) + ftdi_lay(lev) = tee(DD1*taui_lay(lev)/gee*gdif_lay(lev)) + + ! calibration for chil + fcad_lay(lev) = (D1-ftdd_lay(lev)) / (D1-ftdd_lay_orig(lev)) + fcai_lay(lev) = (D1-ftdi_lay(lev)) / (D1-ftdi_lay_orig(lev)) + + ENDIF + ENDDO + + +!============================================================= +! absorption fraction in sunlit leaves in diffuse radiation format +! PART I +!============================================================= + + fsun_dd_lay(:) = D0 + fsun_dw_lay(:) = D0 + fsun_up_lay(:) = D0 + + DO lev = 1, 3 + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + + fsun_f = 0.5*(1. - tee(DD1*2.*taud_lay(lev))) & + / (1. - tee(DD1*taud_lay(lev))) + + fsun_b = 2.*(tee(DD1*taud_lay(lev)) - exp(-2.*taud_lay(lev))) & + / (1. - tee(DD1*taud_lay(lev))) + + fsun_a = 0.5*(fsun_f + fsun_b) + fsun_d = 0.5*(fsun_f - fsun_b) + + fsun_dd_lay(lev) = fsun_f + fsun_dw_lay(lev) = fsun_a + 0.5*cosz_lay(lev)*fsun_d + fsun_up_lay(lev) = fsun_a - 0.5*cosz_lay(lev)*fsun_d + ENDIF + ENDDO + +!============================================================= +! initialize local variables for layers +!============================================================= + + albd_col = D0; albi_col = D0 + fabd_col = D0; fabd_lay = D0 + fabi_col = D0; fabi_lay = D0 + frid_lay = D0; frii_lay = D0 + tt = D0 + +!============================================================= +! projection shadow overlapping fractions +!============================================================= + + zenith = acos(cosz_lay(3)) + shad_oa(3,2) = fc0(3)*OverlapArea(csiz_lay(3),chgt_lay(3)-hbot_lay(2), zenith) + shad_oa(3,1) = fc0(3)*OverlapArea(csiz_lay(3),chgt_lay(3)-hbot_lay(1), zenith) + zenith = acos(cosz_lay(2)) + shad_oa(2,1) = fc0(2)*OverlapArea(csiz_lay(2),chgt_lay(2)-hbot_lay(1), zenith) + +!============================================================= +! unscattered direct sunlight available at each layer +! 4:sky, 3:top 2:middle 1:bottom and 0:ground layer +!============================================================= + + ftdd_col = D0; tt = D0 + + tt(4,3) = shadow_d(3) + tt(4,3) = min(D1, max(D0, tt(4,3))) + tt(4,2) = shadow_d(2)*(D1-shadow_d(3)+shad_oa(3,2)) + tt(4,2) = min(1-tt(4,3), max(D0, tt(4,2))) + tt(4,1) = shadow_d(1)*(D1-(shadow_d(2)-shad_oa(2,1)) & + - (shadow_d(3)-shad_oa(3,1)) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))) + tt(4,1) = min(1-tt(4,3)-tt(4,2), max(D0, tt(4,1))) + + tt(4,0) = D1-(shadow_d(1)+shadow_d(2)+shadow_d(3) & + - (shadow_d(2)-shad_oa(2,1))*shadow_d(1) & + - (shadow_d(3)-shad_oa(3,2))*shadow_d(2) & + - (shadow_d(3)-shad_oa(3,1))*shadow_d(1) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))*shadow_d(1)) + tt(4,0) = min(1-tt(4,3)-tt(4,2)-tt(4,1), max(D0, tt(4,0))) + + IF (tt(4,0) < 0) THEN + print *, abs(tt(4,0)) + ENDIF + + ! direct sunlight passing through top canopy layer + IF (shadow_d(3) > 0) THEN + tt(3,2) = shadow_d(2)*(shadow_d(3)-shad_oa(3,2)) + tt(3,2) = min(shadow_d(3), max(D0, tt(3,2))) + tt(3,1) = shadow_d(1)*(shadow_d(3)-shad_oa(3,1) & + - (shadow_d(3)-shad_oa(3,2))*(shadow_d(2)-shad_oa(2,1))) + tt(3,1) = min(shadow_d(3)-tt(3,2), max(D0, tt(3,1))) + tt(3,0) = shadow_d(3)-tt(3,2)-tt(3,1) + + tt(3,2) = tt(3,2)*ftdd_lay(3) + tt(3,1) = tt(3,1)*ftdd_lay(3) + tt(3,0) = tt(3,0)*ftdd_lay(3) + ENDIF + + ! direct sunlight passing through middle canopy layer + IF (shadow_d(2) > 0) THEN + tt(2,1) = shadow_d(1)*(shadow_d(2)-shad_oa(2,1)) + tt(2,1) = min(shadow_d(2), max(D0, tt(2,1))) + tt(2,0) = shadow_d(2)-tt(2,1) + + tt(2,1) = tt(2,1)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) + tt(2,0) = tt(2,0)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) + ENDIF + + ! direct sunlight passing through third canopy layer + IF (shadow_d(1) > 0) THEN + tt(1,0) = ftdd_lay(1)*(tt(4,1) + tt(3,1) + tt(2,1))!*shadow_d(1)/shadow_d(1) + ENDIF + +!============================================= +! Aggregate direct radiation to layers +!============================================= + + tt(4,3) = tt(4,3) + tt(3,2) = tt(4,2) + tt(3,2) + tt(2,1) = tt(4,1) + tt(3,1) + tt(2,1) + tt(1,0) = tt(4,0) + tt(3,0) + tt(2,0) + tt(1,0) + ftdd_col = tt(1,0) + + tt(0:4,4) = D0; tt(0:3,3) = D0 + tt(4:4,2) = D0; tt(0:2,2) = D0 + tt(3:4,1) = D0; tt(0:1,1) = D0 + tt(2:4,0) = D0; tt(0:0,0) = D0 + + +!======================================= +! start radiation beam loop +! ib=1:visible band 2:nir band +!======================================= + + DO ib = 1, numrad + + !=============================== + ! get pft level tau and ftdd + !=============================== + + ! 10/12/2017 + ftdi(:,ib) = D1 + + DO ip = ps, pe + + taud(ip) = D0 + taui(ip) = D0 + shadow_pd(ip) = D0 + shadow_pi(ip) = D0 + + IF (soilveg(ip)) THEN + clev = canlay(ip) + + !================================================ + ! fractional contribution of current pft in layer + !================================================ + + pfc = min( fcover(ip)/fc0(clev), D1) + shadow_pd(ip) = pfc*shadow_d(clev) + shadow_pi(ip) = pfc*shadow_i(clev) + + !===================================== + ! get taud,taui at pft level + !===================================== + + taud(ip) = D3/D4*gee*fcover(ip)*(lsai(ip)) & + / (cosz(ip)*shadow_pd(ip)) + + taui(ip) = D3/D4*gee*fcover(ip)*(lsai(ip)) & + / (cosd(ip)*shadow_pi(ip)) + + !==================================== + ! transmission at pft level + !==================================== + + ftdd_orig(ip,ib) = tee(DD1*taud(ip)) + ftdi_orig(ip,ib) = tee(DD1*taui(ip)) + + ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) + ftdd(ip,ib) = tee(DD1*taud(ip)/gee*gdir(ip)) + ftdi(ip,ib) = tee(DD1*taui(ip)/gee*gdif(ip)) + + ! calibration for chil + fcad(ip) = (D1-ftdd(ip,ib)) / (D1-ftdd_orig(ip,ib)) + fcai(ip) = (D1-ftdi(ip,ib)) / (D1-ftdi_orig(ip,ib)) + + ENDIF ! ENDIF soilveg + ENDDO ! ENDDO ip + + !=============================================================== + ! absorption, reflection and transmittance for three canopy layer + ! using average optical properties of layers + ! subroutine CanopyRad calculates fluxes for unit input radiation + !=============================================================== + + ftid_lay=D0; ftii_lay=D1 + frid_lay=D0; frii_lay=D0 + faid_lay=D0; faii_lay=D0 + + DO lev = 1, 3 + IF (shadow_d(lev) > D0) THEN + CALL CanopyRad(taud_lay(lev), taui_lay(lev), ftdd_lay_orig(lev),& + ftdi_lay_orig(lev), cosz_lay(lev), cosd_lay(lev), shadow_d(lev), & + shadow_i(lev), fc0(lev), omg_lay(lev,ib), lsai_lay(lev), & + tau_lay(lev,ib), rho_lay(lev,ib), ftid_lay(lev), & + ftii_lay(lev), frid_lay(lev), frii_lay(lev),& + faid_lay(lev), faii_lay(lev)) + ENDIF + ENDDO ! ENDDO lev + + ! 11/07/2018: calibration for LAD + ftid_lay(:) = fcad_lay(:)*ftid_lay(:) + ftii_lay(:) = fcai_lay(:)*(ftii_lay(:)-ftdi_lay_orig(:)) + ftdi_lay(:) + frid_lay(:) = fcad_lay(:)*frid_lay(:) + frii_lay(:) = fcai_lay(:)*frii_lay(:) + faid_lay(:) = fcad_lay(:)*faid_lay(:) + faii_lay(:) = fcai_lay(:)*faii_lay(:) + + !============================================= + ! Calculate layer direct beam radiation absorbed + ! in the sunlit canopy as direct + !============================================= + + fadd_lay(:,ib) = D0 + + DO lev = 1, nlay + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + fadd_lay(lev,ib) = tt(lev+1,lev) * & + (D1-ftdd_lay(lev)) * (D1-omg_lay(lev,ib)) + ENDIF + ENDDO + + A = D0; B = D0; + fabs_leq = D0 + + ! Calculate the coefficients matrix A + A(1,1) = 1.0; A(1,3) = -shadow_i(3)*ftii_lay(3) + shadow_i(3) - 1.0; + A(2,2) = 1.0; A(2,3) = -shadow_i(3)*frii_lay(3); + A(3,3) = 1.0; A(3,2) = -shadow_i(2)*frii_lay(2); + A(3,5) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; + + A(4,4) = 1.0; A(4,5) = -shadow_i(2)*frii_lay(2); + A(4,2) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; + + A(5,5) = 1.0; A(5,4) = -shadow_i(1)*frii_lay(1); + A(5,6) =(-shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0) * albgri(ib); + + A(6,6) = 1.0 - albgri(ib)*shadow_i(1)*frii_lay(1); + A(6,4) = -shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0; + + ! The constant vector B at right side + B(1,1) = tt(4,3)*frid_lay(3); B(1,2) = shadow_i(3)*frii_lay(3); + B(2,1) = tt(4,3)*ftid_lay(3); B(2,2) = shadow_i(3)*ftii_lay(3) - shadow_i(3) + 1.0; + B(3,1) = tt(3,2)*frid_lay(2); B(3,2) = 0.0; + B(4,1) = tt(3,2)*ftid_lay(2); B(4,2) = 0.0; + + B(5,1) = tt(2,1)*frid_lay(1) & + + tt(1,0)*albgrd(ib)*(shadow_i(1)*ftii_lay(1) - shadow_i(1) + 1.0); + B(5,2) = 0.0; + + B(6,1) = tt(2,1)*ftid_lay(1) + tt(1,0)*albgrd(ib)*shadow_i(1)*frii_lay(1); + B(6,2) = 0.0; + + ! Get the resolution + CALL mGauss(A, B, X) + + ! ==================================================== + ! Set back to the absorption for each layer and albedo + ! ==================================================== + + ! Albedo + fabs_leq(4,:) = X(1,:) + + ! Three layers' absorption for incident direct radiation + fabs_leq(3,1) = tt(4,3)*faid_lay(3) & + + X(3,1) *shadow_i(3)*faii_lay(3) + fabs_leq(2,1) = tt(3,2)*faid_lay(2) & + + (X(2,1) + X(5,1)) *shadow_i(2)*faii_lay(2) + fabs_leq(1,1) = tt(2,1)*faid_lay(1) & + + (X(4,1) + X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib))*shadow_i(1)*faii_lay(1) + + ! Ground absorption + fabs_leq(0,1) = tt(1,0)*(1.0 - albgrd(ib)) + X(6,1)*(1.0 - albgri(ib)) + + + ! Three layers' absorption for incident diffuse radiation + fabs_leq(3,2) = (1. + X(3,2)) *shadow_i(3)*faii_lay(3) + fabs_leq(2,2) = (X(2,2) + X(5,2)) *shadow_i(2)*faii_lay(2) + fabs_leq(1,2) = (X(4,2) + X(6,2)*albgri(ib)) *shadow_i(1)*faii_lay(1) + + ! Ground absorption + fabs_leq(0,2) = X(6,2) * (1.0 - albgri(ib)) + + + ! IF everything is ok, substitute fabs_lay for fabs_leq + ! and delete the following line and the variables defined + ! but not used anymore + fabs_lay = fabs_leq + + ! set column absorption and reflection + fabd_lay(1:3,ib) = fabs_lay(1:3,1) + fabi_lay(1:3,ib) = fabs_lay(1:3,2) + fabd_col(ib) = fabs_lay(1,1) + fabs_lay(2,1) + fabs_lay(3,1) + fabi_col(ib) = fabs_lay(1,2) + fabs_lay(2,2) + fabs_lay(3,2) + albd_col(ib) = fabs_lay(4,1) + albi_col(ib) = fabs_lay(4,2) + + ! calculation for sunlit fraction and sunlit absorption for each layer + IF (ib == 1) THEN !visible band only + + psun_lay(:) = D0 + fsun_id_lay(:) = D0 + fsun_ii_lay(:) = D0 + + ! - layer 3 - + IF ( fc0(3)>D0 .and. lsai_lay(3)>D0 ) THEN + ! sunlit fraction for layers + psun_lay(3) = tt(4,3)/shadow_d(3) + ! absorption fraction in sunlit leaves in diffuse radiation format + ! PART II + fsun_id_lay(3) = (psun_lay(3)*fsun_dd_lay(3) + X(3,1)*fsun_up_lay(3)) & + / (psun_lay(3) + X(3,1)) + fsun_ii_lay(3) = (1.*fsun_dw_lay(3) + X(3,2)*fsun_up_lay(3)) & + / (1. + X(3,2)) + ENDIF + + ! - layer 2 - + IF ( fc0(2)>D0 .and. lsai_lay(2)>D0 ) THEN + ! sunlit fraction for layers + psun_lay(2) = tt(3,2)/shadow_d(2) + ! absorption fraction in sunlit leaves in diffuse radiation format + ! PART II + fsun_id_lay(2) = (psun_lay(2)*fsun_dd_lay(2) + X(2,1)*fsun_dw_lay(2) & + + X(5,1)*fsun_up_lay(2)) & + / (psun_lay(2) + X(2,1) + X(5,1)) + fsun_ii_lay(2) = (X(2,2)*fsun_dw_lay(2) + X(5,2)*fsun_up_lay(2)) & + / (X(2,2) + X(5,2)) + ENDIF + + ! - layer 1 - + IF ( fc0(1)>D0 .and. lsai_lay(1)>D0 ) THEN + ! sunlit fraction for layers + psun_lay(1) = tt(2,1)/shadow_d(1) + ! absorption fraction in sunlit leaves in diffuse radiation format + ! PART II + fsun_id_lay(1) = (psun_lay(1)*fsun_dd_lay(1) + X(4,1)*fsun_dw_lay(1) & + + (X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib))*fsun_up_lay(1)) & + / (psun_lay(1) + X(4,1) + X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib)) + fsun_ii_lay(1) = (X(4,2)*fsun_dw_lay(1) + X(6,2)*albgri(ib)*fsun_up_lay(1)) & + / (X(4,2) + X(6,2)*albgri(ib)) + ENDIF + ENDIF + + ! balance check + IF (abs(fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1) > 1e-6) THEN + print *, "Imbalance kband=1" + print *, fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1 + ENDIF + IF (abs(fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1) > 1e-6) THEN + print *, "Imbalance kband=2" + print *, fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1 + ENDIF + + !==================================================== + ! Calculate individual PFT absorption + !==================================================== + + sum_fabd = D0 + sum_fabi = D0 + sum_fadd = D0 + + DO ip = ps, pe + clev = canlay(ip) + IF (clev == D0) CYCLE + IF ( shadow_d(clev)>D0 .and. soilveg(ip) ) THEN + + !================================================= + ! fractional contribution of current pft in layer + !================================================= + + pfc = min( fcover(ip)/fc0(clev), D1) + + !========================================= + ! shadow contribution from ground to sky + !========================================= + + shadow_sky(ip) = shadow_pi(ip) + + !======================================================= + ! absorption, reflection and transmittance fluxes for + ! unit incident radiation over pft. + !======================================================= + + CALL CanopyRad(taud(ip), taui(ip), ftdd_orig(ip,ib), ftdi_orig(ip,ib), & + cosz(ip),cosd(ip), shadow_pd(ip), shadow_pi(ip), fcover(ip),& + omega(ip,ib), lsai(ip), tau(ip,ib),& + rho(ip,ib), ftid(ip,ib), ftii(ip,ib), albd(ip,ib),& + albi(ip,ib), faid_p, faii_p) + + ! calibration for LAD + ! 11/07/2018: calibration for LAD + ftid(ip,ib) = fcad(ip)*ftid(ip,ib) + ftii(ip,ib) = fcai(ip)*(ftii(ip,ib)-ftdi_orig(ip,ib)) + ftdi(ip,ib) + albd(ip,ib) = fcad(ip)*albd(ip,ib) + albi(ip,ib) = fcai(ip)*albi(ip,ib) + faid_p = fcad(ip)*faid_p + faii_p = fcai(ip)*faii_p + + ! absorptions after multiple reflections for each pft + probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) + ftran = (D1-shadow_pd(ip)+shadow_pd(ip)*ftdd(ip,ib))*albgrd(ib) & + + shadow_pd(ip)*ftid(ip,ib)*albgri(ib) + fabsm = ftran*faii_p*shadow_sky(ip)/(D1-probm) + fabd(ip,ib) = shadow_pd(ip)*faid_p + fabsm + + probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) + ftran = D1-shadow_pi(ip)*(D1 -ftii(ip,ib)) + fabsm = ftran*albgri(ib)*faii_p*shadow_sky(ip)/(D1-probm) + fabi(ip,ib) = shadow_pi(ip)*faii_p + fabsm + + ! sum of pft absorptions in column + sum_fabd(clev) = sum_fabd(clev) + fabd(ip,ib) + sum_fabi(clev) = sum_fabi(clev) + fabi(ip,ib) + + ! pft absorption in sunlit as direct beam + fadd(ip,ib) = shadow_pd(ip) * (D1-ftdd(ip,ib)) * (D1-omega(ip,ib)) + + ! sum of pft absorption in sunlit as direct beam + sum_fadd(clev) = sum_fadd(clev) + fadd(ip,ib) + + ENDIF ! ENDIF shadow & soilveg + ENDDO ! ENDDO ip + + DO ip = ps, pe + clev = canlay(ip) + + !=========================================================== + ! adjust pft absorption for total column absorption per + ! unit column area + !=========================================================== + + IF (soilveg(ip)) THEN + fabd(ip,ib) = fabd(ip,ib)*fabd_lay(clev,ib) & + / sum_fabd(clev)/fcover(ip) + fabi(ip,ib) = fabi(ip,ib)*fabi_lay(clev,ib) & + / sum_fabi(clev)/fcover(ip) + + fadd(ip,ib) = fadd(ip,ib)*fadd_lay(clev,ib) & + / sum_fadd(clev)/fcover(ip) + + fadd(ip,ib) = min(fabd(ip,ib), fadd(ip,ib)) + + psun(ip) = psun_lay(clev) + fsun_id(ip) = fsun_id_lay(clev) + fsun_ii(ip) = fsun_ii_lay(clev) + + ELSE + fabd(ip,ib) = D0 + fabi(ip,ib) = D0 + fadd(ip,ib) = D0 + + psun(ip) = D0 + fsun_id(ip) = D0 + fsun_ii(ip) = D0 + ENDIF + + ! column albedo is assigned to each pft in column + ! Added by Yuan, 06/03/2012 + albd(ip,ib) = albd_col(ib) + albi(ip,ib) = albi_col(ib) + + ! adjust ftdd and ftii for multi reflections between layers + +! 03/06/2020, yuan: NOTE! there is no physical mean of ftdd, +! ftid, ftii anymore. they are the same for each PFT can only +! be used to calculate the ground absorption. + ftdd(ip,ib) = ftdd_col + ftid(ip,ib) = (D1-albd(ip,ib)-fabd_col(ib)-& + ftdd(ip,ib)*(D1-albgrd(ib))) /(D1-albgri(ib)) + ftii(ip,ib) = (D1-albi(ip,ib)-fabi_col(ib))/(D1-albgri(ib)) + + !ftdd(ip,ib) = min(max(ftdd(ip,ib),D0),D1) + !ftii(ip,ib) = min(max(ftii(ip,ib),D0),D1) + !ftid(ip,ib) = min(max(ftid(ip,ib),D0),D1) + + ! check energy balance + !fabd(ip,ib) = D1 - albd(ip,ib) & + ! - ftdd(ip,ib)*(D1-albgrd(ib)) & + ! - ftid(ip,ib)*(D1-albgri(ib)) + !fabi(ip,ib) = D1 - albi(ip,ib) & + ! - ftii(ip,ib)*(D1-albgri(ib)) + + ENDDO ! ENDDO ip + ENDDO !ENDDO ib + + ! set parameters for longwave calculation + fshade(:) = shadow_pi(:) + thermk(:) = ftdi(:,1) + + END SUBROUTINE ThreeDCanopy + +!----------------------------------------------------------------------- +! FUNCTION tee +!----------------------------------------------------------------------- + + real(selected_real_kind(12)) FUNCTION tee(tau) + + IMPLICIT NONE + + real(r16), parameter :: DDH = 0.50_r16 !128-bit accuracy real + real(r16), parameter :: DD1 = 1.0_r16 !128-bit accuracy real + real(r16), parameter :: DD2 = 2.0_r16 !128-bit accuracy real + real(r16) :: tau ! transmittance + + tee = DDH*(DD1/tau/tau-(DD1/tau/tau+DD2/tau)*exp(-DD2*tau)) + + END FUNCTION tee + +!----------------------------------------------------------------------- +! FUNCTION overlapArea +!----------------------------------------------------------------------- + + real(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) + + IMPLICIT NONE + + real(r8), parameter :: rpi = 3.14159265358979323846_R8 !pi + real(r8), parameter :: D0 = 0.0_r8 !128-bit accuracy real + real(r8), parameter :: D1 = 1.0_r8 !128-bit accuracy real + + real(r8) :: radius !radius of bus + real(r8) :: hgt !height of canopy + real(r8) :: zenith !zenith angle + real(r8) :: cost !cosine of angle + real(r8) :: theta !angle + + IF (radius == D0) THEN + OverlapArea= D0 + RETURN + ENDIF + cost = hgt*tan(zenith)/radius/(D1+D1/cos(zenith)) + IF (cost >= 1) THEN + OverlapArea= D0 + RETURN + ENDIF + theta = acos(cost) + OverlapArea = (theta-cost*sin(theta))*(D1+D1/cos(zenith))/rpi + RETURN + END FUNCTION OverlapArea + +!----------------------------------------------------------------------- +! FUNCTION to calculate scattering, absorption, reflection and +! transmittance for unit input radiation +!----------------------------------------------------------------------- + + SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz, cosd, & + shadow_d, shadow_i, fc, omg, lsai, tau_p, rho_p, & + ftid, ftii, frid, frii, faid, faii) + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8) :: cosz !0.001 <= coszen <= 1.000 + real(r8) :: cosd !0.001 <= coszen <= 1.000 + real(r8) :: faid !direct absorption + real(r8) :: faii !diffuse absorption + real(r8) :: fc !fraction of grid covered with canopy + real(r8) :: frid !direct reflectance + real(r8) :: frii !diffuse reflectance + real(r8) :: frio !diffuse reflectance + real(r8) :: ftdd !down direct flux below veg per unit dir flx + real(r8) :: ftdi !down direct flux below veg per unit dif flux + real(r8) :: ftid !direct transmittance + real(r8) :: ftii !diffuse transmittance + real(r8) :: omg !frac of intercepted rad that is scattered + real(r8) :: rho_p !leaf/stem reflectance weighted by fract of LAI and SAI + real(r8) :: shadow_d !canopy shadow for direct solar + real(r8) :: shadow_i !canopy shadow for diffuse solar + real(r8) :: tau_d !radial optical depth for direct beam + real(r8) :: tau_i !radial optical depth for indirect beam + real(r8) :: tau_p !leaf/stem transmission weighted by frac of LAI & SAI + real(r8) :: lsai !elai+esai + + ! output variables + real(r8) :: phi_dif_d !difference of rad scattered forward-backward per direct beam + real(r8) :: phi_dif_i !difference of rad scattered forward-backward per direct beam + real(r8) :: phi_tot_d !total rad scattered in all direction per direct beam + real(r8) :: phi_tot_i !total rad scattered in all direction per diffuse beam + real(r8) :: phi_tot_o !total rad scattered in all direction per direct beam + real(r8) :: phi_dif_o !total rad scattered in all direction per diffuse beam + real(r8) :: pa2 !total rad scattered in all direction per direct beam + +!-------------------------- Local Variables ---------------------------- + logical :: runmode = .true. + real(r8) :: tau + real(r8) :: muv !forward frac of 3D scat rad in all direction for diffuse + real(r8) :: ac !forward frac of 3D scat rad in all direction for diffuse + real(r8) :: ald !forward frac of 3D scat rad in all direction for diffuse + real(r8) :: ali !forward frac of 3D scat rad in all direction for diffuse + + real(r8) :: wb !EQ. (2.14), Dickinson 1983, omega*beta + real(r8) :: alpha !EQ. (2.14), Dickinson 1983, alpha + real(r8) :: nd !EQ. (4), Appendix 1, Yuan, dissertation + real(r8) :: ni !EQ. (4), Appendix 1, Yuan, dissertation + real(r8) :: gee=0.5_r8 !Ross factor geometric blocking + + real(r8) , parameter :: D0 = 0.0_r8 !64-bit real number + real(r8) , parameter :: D1 = 1.0_r8 !64-bit real number + real(r8) , parameter :: D2 = 2.0_r8 !64-bit real number + real(r8) , parameter :: D3 = 3.0_r8 !64-bit real number + real(r8) , parameter :: D4 = 4.0_r8 !64-bit real number + real(r8) , parameter :: D6 = 6.0_r8 !64-bit real number + real(r8) , parameter :: DH = 0.5_r8 !64-bit real number + real(r16), parameter :: DD1 = 1.0_r16 !128-bit real number + + real(r8) , parameter :: pi = 3.14159265358979323846_R8 !pi +!----------------------------------------------------------------------- + + tau = D3/D4*gee*lsai + + CALL phi(runmode, tau_d, omg, tau_p, rho_p, phi_tot_d, phi_dif_d, pa2) + CALL phi(runmode, tau_i, omg, tau_p, rho_p, phi_tot_i, phi_dif_i, pa2) + CALL phi(runmode, tau , omg, tau_p, rho_p, phi_tot_o, phi_dif_o, pa2) + + IF (runmode) THEN + ! NOTE: modified + frio = DH*(phi_tot_o - DH*phi_dif_o) + frio = max(min(frio,D1),D0) + + muv = D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D2*pi)) ) + & + D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D6*pi)) ) + + wb = D2/D3*rho_p + D1/D3*tau_p + alpha = sqrt(D1-omg) * sqrt(D1-omg+D2*wb) + nd = (D1 + D2*alpha) / (D1 + D2*alpha*cosz) + ni = (D1 + D2*alpha) / (D1 + D2*alpha*cosd) + + ac = phi_tot_o * muv * (D1-tee(DD1*tau)) * (D1-omg) / (D1-omg*pa2) + ald = (nd-D1) * frio * fc * (D1/shadow_d - cosz/fc) + ali = (ni-D1) * frio * fc * (D1/shadow_i - cosd/fc) + ENDIF + +!----------------------------------------------------------------------- +!frac indirect downward rad through canopy for black soil & direct solar +!----------------------------------------------------------------------- + frid = DH*(phi_tot_d - DH*cosz*phi_dif_d) + frii = DH*(phi_tot_i - DH*cosd*phi_dif_i) + + IF (runmode) THEN + frid = frid + ald - DH*ac + frii = frii + ali - DH*ac + ENDIF + + frid = max(min(frid,D1),D0) + frii = max(min(frii,D1),D0) + +!--------------------------------------------------------------------- +!downward diffuse fraction from direct and diffuse sun +!--------------------------------------------------------------------- + ftid = DH*(phi_tot_d + DH*cosz*phi_dif_d) + ftii = DH*(phi_tot_i + DH*cosd*phi_dif_i) + ftdi + + IF (runmode) THEN + ftid = ftid - DH*ald - DH*ac + ftii = ftii - DH*ali - DH*ac + ENDIF + + ftid = max(min(ftid,D1),D0) + ftii = max(min(ftii,D1),D0) + +!--------------------------------------------------------------------- +! canopy absorption for direct or diffuse beams +!--------------------------------------------------------------------- + IF (.not. runmode) THEN + faid = D1 - ftdd - phi_tot_d + faii = D1 - ftdi - phi_tot_i + ELSE + faid = D1 - ftdd - frid - ftid + faii = D1 - frii - ftii + ENDIF + + faid = max(min(faid,D1),D0) + faii = max(min(faii,D1),D0) + + IF (shadow_d == D0) THEN + ! NOTE: corrected from D1 -> D0 + ftid = D0 + frid = D0 + faid = D0 + ENDIF + IF (shadow_i == D0) THEN + ftii = D1 + frii = D0 + faii = D0 + ENDIF + + END SUBROUTINE CanopyRad + + + SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) + + IMPLICIT NONE + + ! input variables + logical :: runmode + real(r8) :: omg !frac of intercepted rad that is scattered + real(r8) :: rho_p !leaf/stem reflectance weighted by frac of LAI and SAI + real(r8) :: tau !radial optical depth for direct beam + real(r8) :: tau_p !leaf/stem transmission weighted by frac of LAI & SAI + + ! output variables + real(r8) :: phi_dif !difference of rad scattered forward-backward + real(r8) :: phi_tot !total rad scattered in all direction + real(r8) :: pa2 !total rad scattered in all direction + + ! local variables + real(r8) :: pac !probability of absorption after two scatterings + real(r8) :: phi_1b !backward single scattered radiation + real(r8) :: phi_1f !forward single scattered radiation + real(r8) :: phi_2a !average second-order scattered radiation + real(r8) :: phi_2b !backward second-order scattered radiation + real(r8) :: phi_2f !forward second-order scattered radiation + real(r8) :: phi_mb !backward multiple scattered radiation + real(r8) :: phi_mf !forward multiple scattered radiation + real(r8) :: phi_tb !backward frac of 3D scat rad in all direction + real(r8) :: phi_tf !forward frac of 3D scat rad in all direction + real(r8) :: aa,bb !temporary constants + + real(r8) , parameter :: D0 = 0.0_r8 !64-bit real number + real(r8) , parameter :: D1 = 1.0_r8 !64-bit real number + + real(r16), parameter :: DD1 = 1.0_r16 !128-bit real number + real(r16), parameter :: DD2 = 2.0_r16 !128-bit real number + real(r16), parameter :: DD3 = 3.0_r16 !128-bit real number + real(r16), parameter :: DD4 = 4.0_r16 !128-bit real number + real(r16), parameter :: DD9 = 9.0_r16 !128-bit real number + real(r16), parameter :: DD10 = 10.0_r16 !128-bit real number + real(r16), parameter :: DDH = 0.5_r16 !128-bit real number + +!---------------------------------------------------------------------- +! single scattering terms for sphere with overlap corrections to path +! for direct and diffuse beams +!---------------------------------------------------------------------- + + ! forward first order normalized scattering + phi_1f = (DD1/tau/tau - (DD1/tau/tau + DD2/tau + DD2)*exp(-DD2*tau)) + + ! backward first order normalized scattering + phi_1b = DDH*(DD1 - tee(DD2*tau)) + +!---------------------------------------------------------------------- +! sphere double scattering terms (RED 2008 Eqs. 19,20) +!---------------------------------------------------------------------- + + IF (.not. runmode) THEN + + ! forward double scattering + phi_2f = DDH*(DD4*phi_1f/DD3 + tee(DD2*tau) + tee(DD4*tau)/DD9 - & + DD10*tee(DD1*tau)/DD9) + + ! backward double scattering + phi_2b = DDH*(DD1/DD3 - tee(DD2*tau) + DD2*tee(DD3*tau)/DD3) + + ELSE + ! fitting FUNCTION for second order scattering + aa = 0.70_r8 + bb = 1.74_r8 + + phi_2b = aa*( DD1/(bb+DD1) -DD1/(bb-D1)*tee(DD2*tau) + & + DD2/(bb+DD1)/(bb-DD1)*tee((DD1+bb)*tau) ) + + phi_2f = aa*( DD2*bb/(bb*bb-DD1)*phi_1f - & + (DD1/(bb+DD1)/(bb+DD1) + DD1/(bb-DD1)/(bb-DD1))*tee(DD1*tau) + & + DD1/(bb-DD1)/(bb-DD1)*tee(DD1*tau*bb) + & + DD1/(bb+DD1)/(bb+DD1)*tee(DD1*(bb+DD2)*tau) ) + ENDIF + + ! second order average scattering + phi_2a = DDH*(phi_2b + phi_2f) + +!---------------------------------------------------------------------- +! probability of absorption after two scattering +!---------------------------------------------------------------------- + + ! probability of absorption for diffuse beam + ! corrected probability of absorption for direct beam + pac = DD1-phi_2a / & + (DD1 - tee(DD1*tau) - (rho_p*phi_1b + tau_p*phi_1f)/(tau_p+rho_p)) + + pac = max(min(pac,D1),D0) + pa2 = pac + +!---------------------------------------------------------------------- +!third order and higher order scatterings +!---------------------------------------------------------------------- + + phi_mf = phi_2f + omg*pac*phi_2a/(DD1-omg*pac) + phi_mb = phi_2b + omg*pac*phi_2a/(DD1-omg*pac) + +!---------------------------------------------------------------------- +! total sphere scattering,forward,backward, avg & diff for direct beam +!---------------------------------------------------------------------- + + phi_tf = tau_p*phi_1f + DDH*omg*omg*phi_mf + phi_tb = rho_p*phi_1b + DDH*omg*omg*phi_mb + + phi_tot = phi_tf + phi_tb + phi_dif = phi_tf - phi_tb + + END SUBROUTINE phi + + SUBROUTINE mGauss(A, B, X) + + IMPLICIT NONE + + real(r8), intent(inout) :: A(6,6) + real(r8), intent(inout) :: B(6,2) + real(r8), intent(out) :: X(6,2) + + integer :: i, j + integer :: nstep(5) = (/0, 2, 1, 2, 1/) + + real(r8) :: f + + ! Elimination + DO i = 1, 5 + DO j = i+1, i+nstep(i) + IF (abs(A(i,i)) < 1.e-10) THEN + print *, "Error in Gauss's solution" + RETURN + ENDIF + f = - A(j,i)/A(i,i) + A(j,:) = A(j,:) + f*A(i,:) + B(j,:) = B(j,:) + f*B(i,:) + ENDDO + ENDDO + + ! Back substitution + X(6,:) = B(6,:)/A(6,6) + DO i = 5, 1, -1 + X(i,1) = (B(i,1) - sum(A(i,i+1:6)*X(i+1:6,1))) / A(i,i) + X(i,2) = (B(i,2) - sum(A(i,i+1:6)*X(i+1:6,2))) / A(i,i) + ENDDO + + END SUBROUTINE mGauss + +END MODULE MOD_3DCanopyRadiation +! --------- EOP ---------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 new file mode 100644 index 0000000000..3f943a1504 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 @@ -0,0 +1,434 @@ +#include + +MODULE MOD_Aerosol + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Vars_Global, only: maxsnl + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: AerosolMasses + PUBLIC :: AerosolFluxes + PUBLIC :: AerosolDepInit + PUBLIC :: AerosolDepReadin + +! PUBLIC DATA MEMBERS: +!----------------------------------------------------------------------- + + logical, parameter :: use_extrasnowlayers = .false. + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius + ! (also "fresh snow" value) [microns] + real(r8), parameter :: fresh_snw_rds_max = 204.526_r8 ! maximum warm fresh snow effective radius + + character(len=256) :: file_aerosol + + type(grid_type) :: grid_aerosol + type(block_data_real8_2d) :: f_aerdep + type(spatial_mapping_type) :: mg2p_aerdep + + integer, parameter :: start_year = 1849 + integer, parameter :: end_year = 2001 + + integer :: month_p + +CONTAINS + + SUBROUTINE AerosolMasses( dtime ,snl ,do_capsnow ,& + h2osno_ice ,h2osno_liq ,qflx_snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate column-integrated aerosol masses, and +! mass concentrations for radiative calculations and output +! (based on new snow level state, after SnowFilter is rebuilt. +! NEEDS TO BE AFTER SnowFiler is rebuilt in Hydrology2, otherwise there +! can be zero snow layers but an active column in filter) +!----------------------------------------------------------------------- + + IMPLICIT NONE + + ! !ARGUMENTS: + ! + real(r8),intent(in) :: dtime ! seconds in a time step [second] + integer, intent(in) :: snl ! number of snow layers + + logical, intent(in) :: do_capsnow ! true => do snow capping + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens (kg/m2) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water (kg/m2) + real(r8), intent(in) :: qflx_snwcp_ice ! excess snowfall due to snow capping (mm H2O /s) + + real(r8), intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective snow grain radius + ! [microns, m^-6] + + real(r8), intent(inout) :: mss_bcpho ( maxsnl+1:0 ) ! mass of hydrophobic BC in snow [kg] + real(r8), intent(inout) :: mss_bcphi ( maxsnl+1:0 ) ! mass of hydrophillic BC in snow [kg] + real(r8), intent(inout) :: mss_ocpho ( maxsnl+1:0 ) ! mass of hydrophobic OC in snow [kg] + real(r8), intent(inout) :: mss_ocphi ( maxsnl+1:0 ) ! mass of hydrophillic OC in snow [kg] + real(r8), intent(inout) :: mss_dst1 ( maxsnl+1:0 ) ! mass of dust species 1 in snow [kg] + real(r8), intent(inout) :: mss_dst2 ( maxsnl+1:0 ) ! mass of dust species 2 in snow [kg] + real(r8), intent(inout) :: mss_dst3 ( maxsnl+1:0 ) ! mass of dust species 3 in snow [kg] + real(r8), intent(inout) :: mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow [kg] + + real(r8), intent(out) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of BC 1 [kg/kg] + real(r8), intent(out) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of BC 2 [kg/kg] + real(r8), intent(out) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of OC 1 [kg/kg] + real(r8), intent(out) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of OC 2 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust 1 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust 2 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust 3 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust 4 [kg/kg] + + ! !LOCAL VARIABLES: + integer :: c,j ! indices + real(r8) :: snowmass ! liquid+ice snow mass in a layer [kg/m2] + real(r8) :: snowcap_scl_fct ! temporary factor used to correct for snow capping + + !----------------------------------------------------------------------- + + DO j = maxsnl+1, 0 + + ! layer mass of snow: + snowmass = h2osno_ice(j) + h2osno_liq(j) + + IF (.not. use_extrasnowlayers) THEN + ! Correct the top layer aerosol mass to account for snow capping. + ! This approach conserves the aerosol mass concentration + ! (but not the aerosol mass) when snow-capping is invoked + + IF (j == snl+1) THEN + IF (do_capsnow) THEN + + snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice*dtime)) + + mss_bcpho(j) = mss_bcpho(j)*snowcap_scl_fct + mss_bcphi(j) = mss_bcphi(j)*snowcap_scl_fct + mss_ocpho(j) = mss_ocpho(j)*snowcap_scl_fct + mss_ocphi(j) = mss_ocphi(j)*snowcap_scl_fct + + mss_dst1(j) = mss_dst1(j)*snowcap_scl_fct + mss_dst2(j) = mss_dst2(j)*snowcap_scl_fct + mss_dst3(j) = mss_dst3(j)*snowcap_scl_fct + mss_dst4(j) = mss_dst4(j)*snowcap_scl_fct + ENDIF + ENDIF + ENDIF + + IF (j >= snl+1) THEN + + mss_cnc_bcphi(j) = mss_bcphi(j) / snowmass + mss_cnc_bcpho(j) = mss_bcpho(j) / snowmass + + mss_cnc_ocphi(j) = mss_ocphi(j) / snowmass + mss_cnc_ocpho(j) = mss_ocpho(j) / snowmass + + mss_cnc_dst1(j) = mss_dst1(j) / snowmass + mss_cnc_dst2(j) = mss_dst2(j) / snowmass + mss_cnc_dst3(j) = mss_dst3(j) / snowmass + mss_cnc_dst4(j) = mss_dst4(j) / snowmass + + ELSE + ! 01/10/2023, yuan: set empty snow layers to snw_rds_min + snw_rds(j) = snw_rds_min + + mss_bcpho(j) = 0._r8 + mss_bcphi(j) = 0._r8 + mss_cnc_bcphi(j) = 0._r8 + mss_cnc_bcpho(j) = 0._r8 + + mss_ocpho(j) = 0._r8 + mss_ocphi(j) = 0._r8 + mss_cnc_ocphi(j) = 0._r8 + mss_cnc_ocpho(j) = 0._r8 + + mss_dst1(j) = 0._r8 + mss_dst2(j) = 0._r8 + mss_dst3(j) = 0._r8 + mss_dst4(j) = 0._r8 + mss_cnc_dst1(j) = 0._r8 + mss_cnc_dst2(j) = 0._r8 + mss_cnc_dst3(j) = 0._r8 + mss_cnc_dst4(j) = 0._r8 + ENDIF + ENDDO + + END SUBROUTINE AerosolMasses + + + + SUBROUTINE AerosolFluxes( dtime, snl, forc_aer, & + mss_bcphi ,mss_bcpho ,mss_ocphi ,mss_ocpho ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Compute aerosol fluxes through snowpack and aerosol deposition fluxes +! into top layer +! +!----------------------------------------------------------------------- + IMPLICIT NONE + ! + !----------------------------------------------------------------------- + ! !ARGUMENTS: + real(r8),intent(in) :: dtime ! seconds in a time step [second] + integer, intent(in) :: snl ! number of snow layers + + real(r8), intent(in) :: forc_aer (14 ) ! aerosol deposition from atmosphere [kg m-1 s-1] + + real(r8), intent(inout) :: mss_bcphi (maxsnl+1:0 ) ! hydrophillic BC mass in snow [kg] + real(r8), intent(inout) :: mss_bcpho (maxsnl+1:0 ) ! hydrophobic BC mass in snow [kg] + real(r8), intent(inout) :: mss_ocphi (maxsnl+1:0 ) ! hydrophillic OC mass in snow [kg] + real(r8), intent(inout) :: mss_ocpho (maxsnl+1:0 ) ! hydrophobic OC mass in snow [kg] + real(r8), intent(inout) :: mss_dst1 (maxsnl+1:0 ) ! mass of dust species 1 in snow [kg] + real(r8), intent(inout) :: mss_dst2 (maxsnl+1:0 ) ! mass of dust species 2 in snow [kg] + real(r8), intent(inout) :: mss_dst3 (maxsnl+1:0 ) ! mass of dust species 3 in snow [kg] + real(r8), intent(inout) :: mss_dst4 (maxsnl+1:0 ) ! mass of dust species 4 in snow [kg] + + ! !LOCAL VARIABLES: + real(r8) :: flx_bc_dep ! total BC deposition (col) [kg m-2 s-1] + real(r8) :: flx_bc_dep_phi ! hydrophillic BC deposition (col) [kg m-1 s-1] + real(r8) :: flx_bc_dep_pho ! hydrophobic BC deposition (col) [kg m-1 s-1] + real(r8) :: flx_oc_dep ! total OC deposition (col) [kg m-2 s-1] + real(r8) :: flx_oc_dep_phi ! hydrophillic OC deposition (col) [kg m-1 s-1] + real(r8) :: flx_oc_dep_pho ! hydrophobic OC deposition (col) [kg m-1 s-1] + real(r8) :: flx_dst_dep ! total dust deposition (col) [kg m-2 s-1] + + real(r8) :: flx_dst_dep_wet1 ! wet dust (species 1) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry1 ! dry dust (species 1) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet2 ! wet dust (species 2) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry2 ! dry dust (species 2) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet3 ! wet dust (species 3) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry3 ! dry dust (species 3) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet4 ! wet dust (species 4) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry4 ! dry dust (species 4) deposition (col) [kg m-2 s-1] + + integer :: c + + !----------------------------------------------------------------------- + ! set aerosol deposition fluxes from forcing array + ! The forcing array is either set from an external file + ! or from fluxes received from the atmosphere model +#ifdef MODAL_AER + ! Mapping for modal aerosol scheme where within-hydrometeor and + ! interstitial aerosol fluxes are differentiated. Here, "phi" + ! flavors of BC and OC correspond to within-hydrometeor + ! (cloud-borne) aerosol, and "pho" flavors are interstitial + ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are + ! purely diagnostic + ! + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + + + flx_bc_dep_phi = forc_aer(3) + flx_bc_dep_pho = forc_aer(1) + forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(6) + flx_oc_dep_pho = forc_aer(4) + forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#else + + ! Original mapping for bulk aerosol deposition. phi and pho BC/OC + ! species are distinguished in model, other fluxes (e.g., dry and + ! wet BC/OC) are purely diagnostic. + + flx_bc_dep_phi = forc_aer(1) + forc_aer(3) + flx_bc_dep_pho = forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(4) + forc_aer(6) + flx_oc_dep_pho = forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#endif + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + + mss_bcphi(snl+1) = mss_bcphi(snl+1) + (flx_bc_dep_phi*dtime) + mss_bcpho(snl+1) = mss_bcpho(snl+1) + (flx_bc_dep_pho*dtime) + mss_ocphi(snl+1) = mss_ocphi(snl+1) + (flx_oc_dep_phi*dtime) + mss_ocpho(snl+1) = mss_ocpho(snl+1) + (flx_oc_dep_pho*dtime) + + mss_dst1(snl+1) = mss_dst1(snl+1) + (flx_dst_dep_dry1 + flx_dst_dep_wet1)*dtime + mss_dst2(snl+1) = mss_dst2(snl+1) + (flx_dst_dep_dry2 + flx_dst_dep_wet2)*dtime + mss_dst3(snl+1) = mss_dst3(snl+1) + (flx_dst_dep_dry3 + flx_dst_dep_wet3)*dtime + mss_dst4(snl+1) = mss_dst4(snl+1) + (flx_dst_dep_dry4 + flx_dst_dep_wet4)*dtime + + END SUBROUTINE AerosolFluxes + + + SUBROUTINE AerosolDepInit () + + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + IMPLICIT NONE + + real(r8), allocatable :: lat(:), lon(:) + + IF (DEF_Aerosol_Clim) THEN + ! climatology data + file_aerosol = trim(DEF_dir_runtime) // & + '/aerosol/aerosoldep_monthly_2000_mean_0.9x1.25_c090529.nc' + ELSE + ! yearly change data + file_aerosol = trim(DEF_dir_runtime) // & + '/aerosol/aerosoldep_monthly_1849-2001_0.9x1.25_c090529.nc' + ENDIF + + CALL ncio_read_bcast_serial (file_aerosol, 'lat', lat) + CALL ncio_read_bcast_serial (file_aerosol, 'lon', lon) + + CALL grid_aerosol%define_by_center (lat, lon) + + CALL allocate_block_data (grid_aerosol, f_aerdep) + + CALL mg2p_aerdep%build_arealweighted (grid_aerosol, landpatch) + + month_p = -1 + + END SUBROUTINE AerosolDepInit + + + SUBROUTINE AerosolDepReadin (idate) + + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_Namelist + USE MOD_Vars_1DForcing +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + integer :: itime, year, month, mday + + year = idate(1) + CALL julian2monthday (idate(1), idate(2), month, mday) + + ! data before the start year, will use the start year + IF (year < start_year) year = start_year + ! data after the end year, will use the end year + IF (year > end_year ) year = end_year + + IF (month.eq.month_p) RETURN + + month_p = month + + ! calculate itime + ! NOTE: aerosol deposition is monthly data + IF (DEF_Aerosol_Clim) THEN + ! for climatology data + itime = month + ELSE + ! for yearly change data + itime = (year-start_year)*12 + month + ENDIF + + ! BCPHIDRY , hydrophilic BC dry deposition + CALL ncio_read_block_time (file_aerosol, 'BCPHIDRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(1,:)) + + ! BCPHODRY , hydrophobic BC dry deposition + CALL ncio_read_block_time (file_aerosol, 'BCPHODRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(2,:)) + + ! BCDEPWET , hydrophilic BC wet deposition + CALL ncio_read_block_time (file_aerosol, 'BCDEPWET', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(3,:)) + + ! OCPHIDRY , hydrophilic OC dry deposition + CALL ncio_read_block_time (file_aerosol, 'OCPHIDRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(4,:)) + + ! OCPHODRY , hydrophobic OC dry deposition + CALL ncio_read_block_time (file_aerosol, 'OCPHODRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(5,:)) + + ! OCDEPWET , hydrophilic OC wet deposition + CALL ncio_read_block_time (file_aerosol, 'OCDEPWET', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(6,:)) + + ! DSTX01WD , DSTX01 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX01WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(7,:)) + + ! DSTX01DD , DSTX01 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX01DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(8,:)) + + ! DSTX02WD , DSTX02 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX02WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(9,:)) + + ! DSTX02DD , DSTX02 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX02DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(10,:)) + + ! DSTX03WD , DSTX03 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX03WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(11,:)) + + ! DSTX03DD , DSTX03 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX03DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(12,:)) + + ! DSTX04WD , DSTX04 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX04WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(13,:)) + + ! DSTX04DD , DSTX04 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX04DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(14,:)) + +#ifdef RangeCheck + !CALL check_block_data ('aerosol', f_aerdep) + CALL check_vector_data (' aerosol [kg/m/s]', forc_aerdep) +#endif + + + END SUBROUTINE AerosolDepReadin + +END MODULE MOD_Aerosol diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 new file mode 100644 index 0000000000..fd5dd381ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 @@ -0,0 +1,2079 @@ +#include + +MODULE MOD_Albedo + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: albland + PUBLIC :: snowage + PUBLIC :: SnowAlbedo + PUBLIC :: albocean + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: twostream +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + PRIVATE :: twostream_mod + PRIVATE :: twostream_wrap +#endif + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE albland (ipatch,patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno,dz_soisno,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) + +!======================================================================= +! Calculates fragmented albedos (direct and diffuse) in +! wavelength regions split at 0.7um. +! +! (1) soil albedos: as in BATS formulations, which are the function of +! soil color and moisture in the surface soil layer +! (2) snow albedos: as in BATS formulations, which are inferred from +! the calculations of Wiscombe and Warren (1980) and the snow model +! and data of Anderson(1976), and the function of snow age, grain +! size, solar zenith angle, pollution, the amount of the fresh snow +! (3) canopy albedo: two-stream approximation model +! (4) glacier albedos: as in BATS, which are set to constants (0.8 for +! visible beam, 0.55 for near-infrared) +! (5) lake and wetland albedos: as in BATS, which depend on cosine solar +! zenith angle, based on data in Henderson-Sellers (1986). The +! frozen lake and wetland albedos are set to constants (0.6 for +! visible beam, 0.4 for near-infrared) +! (6) over the snow covered tile, the surface albedo is estimated by a +! linear combination of albedos for snow, canopy and bare soil (or +! lake, wetland, glacier). +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002, 03/2014 +! +! !REVISIONS: +! 12/2019, Hua Yuan: added a wrap FUNCTION for PFT calculation, details +! see twostream_wrap() added a wrap FUNCTION for PC (3D) +! calculation, details see ThreeDCanopy_wrap() +! +! 03/2020, Hua Yuan: added an improved two-stream model, details see +! twostream_mod() +! +! 08/2020, Hua Yuan: account for stem optical property effects in +! twostream model +! +! 01/2023, Hua Yuan: CALL SNICAR model to calculate snow +! albedo&absorption, added SNICAR related variables +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Vars_TimeInvariants, only: patchclass +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_Aerosol, only: AerosolMasses + USE MOD_SnowSnicar, only: SnowAge_grain +#ifdef LULC_IGBP_PC + USE MOD_3DCanopyRadiation, only: ThreeDCanopy_wrap +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- +! ground cover index + integer, intent(in) :: & + ipatch, &! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=water body) + integer, intent(in) :: & + snl ! number of snow layers + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + soil_s_v_alb, &! albedo of visible of the saturated soil + soil_d_v_alb, &! albedo of visible of the dry soil + soil_s_n_alb, &! albedo of near infrared of the saturated soil + soil_d_n_alb, &! albedo of near infrared of the dry soil + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + green, &! green leaf fraction + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + fwet_snow, &! vegetation snow fractional cover [-] + + coszen, &! cosine of solar zenith angle [-] + wt, &! fraction of vegetation covered by snow [-] + fsno, &! fraction of soil covered by snow [-] + ssw, &! water volumetric content of soil surface layer [m3/m3] + scv, &! snow cover, water equivalent [mm] + scvold, &! snow cover for previous time step [mm] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + forc_t, &! atmospheric temperature [K] + t_grnd ! ground surface temperature [K] + + real(r8), intent(in) :: & + wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) + wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) + snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] + t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] + dz_soisno ( maxsnl+1:1 ) ! layer thickness (m) + + real(r8), intent(inout) :: & + snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + + real(r8), intent(out) :: & + alb(2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(out) :: & + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] + ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] + +!-------------------------- Local Variables ---------------------------- + + real(r8) :: &! + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary variable [-] + albsoi(2,2), &! soil albedo [-] + albsno(2,2), &! snow albedo [-] + albsno_pur(2,2), &! snow albedo [-] + albsno_bc (2,2), &! snow albedo [-] + albsno_oc (2,2), &! snow albedo [-] + albsno_dst(2,2), &! snow albedo [-] + albg(2,2), &! albedo, ground + albv(2,2), &! albedo, vegetation [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse vis radiation [-] + dralbl, &! snow albedo for direct nir radiation [-] + dralbs, &! snow albedo for direct vis radiation [-] + lsai, &! leaf and stem area index (LAI+SAI) [m2/m2] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1, &! alb for NIR, incident on new snow (zen angle<60) [-] + upscat, &! upward scattered fraction for direct beam [-] + tran(2,3) ! canopy transmittances for solar radiation + + integer ps, pe + logical do_capsnow !true => DO snow capping + logical use_snicar_frc !true: IF radiative forcing is calculated, + !first estimate clean-snow albedo + logical use_snicar_ad !true: use SNICAR_AD_RT, false: use SNICAR_RT + + real(r8) snwcp_ice !excess precipitation due to snow capping [kg m-2 s-1] + real(r8) mss_cnc_bcphi ( maxsnl+1:0 ) !mass concentration of hydrophilic BC [kg/kg] + real(r8) mss_cnc_bcpho ( maxsnl+1:0 ) !mass concentration of hydrophobic BC [kg/kg] + real(r8) mss_cnc_ocphi ( maxsnl+1:0 ) !mass concentration of hydrophilic OC [kg/kg] + real(r8) mss_cnc_ocpho ( maxsnl+1:0 ) !mass concentration of hydrophobic OC [kg/kg] + real(r8) mss_cnc_dst1 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 1 [kg/kg] + real(r8) mss_cnc_dst2 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 2 [kg/kg] + real(r8) mss_cnc_dst3 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 3 [kg/kg] + real(r8) mss_cnc_dst4 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 4 [kg/kg] + +! ---------------------------------------------------------------------- +! 1. Initial set +! ---------------------------------------------------------------------- + +! visible and near infrared band albedo for new snow + snal0 = 0.85 !visible band + snal1 = 0.65 !near infrared + +! ---------------------------------------------------------------------- +! set default soil and vegetation albedos and solar absorption + alb (:,:) = 1. !averaged + albg(:,:) = 1. !ground + albv(:,:) = 1. !vegetation + ssun(:,:) = 0. !sunlit leaf absorption + ssha(:,:) = 0. !shaded leaf absorption + tran(:,1) = 0. !incident direct radiation diffuse transmittance + tran(:,2) = 1. !incident diffuse radiation diffuse transmittance + tran(:,3) = 1. !incident direct radiation direct transmittance + + ! 07/06/2023, yuan: use the values of previous timestep + ! for nighttime longwave calculations. + !thermk = 1.e-3 + IF (lai+sai <= 1.e-6) THEN + thermk = 1. + ENDIF + extkb = 1. + extkd = 0.718 + + albsno (:,:) = 1. !set initial snow albedo + albsno_pur(:,:) = 1. !set initial pure snow albedo + albsno_bc (:,:) = 1. !set initial BC snow albedo + albsno_oc (:,:) = 1. !set initial OC snow albedo + albsno_dst(:,:) = 1. !set initial dust snow albedo + + ! soil and snow absorption + ssoi (:,:) = 0. !set initial soil absorption + ssno (:,:) = 0. !set initial snow absorption + ssno_lyr(:,:,:) = 0. !set initial snow layer absorption + +IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + ssun_p(:,:,ps:pe) = 0. + ssha_p(:,:,ps:pe) = 0. + ! 07/06/2023, yuan: use the values of previous timestep. + !thermk_p(ps:pe) = 1.e-3 + WHERE (lai_p(ps:pe)+sai_p(ps:pe) <= 1.e-6) thermk_p(ps:pe) = 1. + extkb_p(ps:pe) = 1. + extkd_p(ps:pe) = 0.718 +#endif +ENDIF + +! ---------------------------------------------------------------------- +! Calculate column-integrated aerosol masses, and +! mass concentrations for radiative calculations and output +! (based on new snow level state, after SnowFilter is rebuilt. +! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there +! can be zero snow layers but an active column in filter) +IF (DEF_USE_SNICAR) THEN + snwcp_ice = 0.0 !excess precipitation due to snow capping [kg m-2 s-1] + do_capsnow = .false. !true => DO snow capping + + CALL AerosolMasses( deltim, snl ,do_capsnow ,& + wice_soisno(:0),wliq_soisno(:0),snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + +! ---------------------------------------------------------------------- +! Snow aging routine based on Flanner and Zender (2006), Linking snowpack +! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of +! wet-snow metamorphism in respect of liquid-water content, Ann. Glacial. + + CALL SnowAge_grain( deltim ,snl ,dz_soisno(:1) ,& + pg_snow ,snwcp_ice ,snofrz ,& + + do_capsnow ,fsno ,scv ,& + wliq_soisno(:0),wice_soisno(:0),t_soisno(:1) ,& + t_grnd ,forc_t ,snw_rds ) +ENDIF +! ---------------------------------------------------------------------- + + lsai = lai + sai + IF(coszen <= -0.3) THEN + RETURN !only DO albedo when coszen > -0.3 + ENDIF + + czen = max(coszen, 0.001) + +! ---------------------------------------------------------------------- +! 2. get albedo over land +! ---------------------------------------------------------------------- +! 2.1 soil albedos, depends on moisture + IF (patchtype <= 2) THEN !soil, urban and wetland + alb_s_inc = max(0.11-0.40*ssw, 0.) + albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) + albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) + albg(:,2) = albg(:,1) !diffused albedos setting + +! 2.2 albedos for permanent ice sheet. + ELSEIF (patchtype == 3) THEN !permanent ice sheet + albg(1,:) = 0.8 + albg(2,:) = 0.55 + +! 2.3 albedo for inland water + ELSEIF (patchtype >= 4) THEN + albg0 = 0.05/(czen+0.15) + albg(:,1) = albg0 + albg(:,2) = 0.1 !Subin (2012) + + IF(t_grnd < tfrz)THEN !frozen lake and wetland + albg(1,:) = 0.6 + albg(2,:) = 0.4 + ENDIF + ENDIF + + ! SAVE soil ground albedo + albsoi(:,:) = albg(:,:) + +! ---------------------------------------------------------------------- +! 3. albedo for snow cover. +! - Scheme 1: snow albedo depends on snow-age, zenith angle, and thickness +! of snow age gives reduction of visible radiation [CoLM2014]. +! - Scheme 2: SNICAR model +! ---------------------------------------------------------------------- + IF (scv > 0.) THEN + + IF (.not. DEF_USE_SNICAR) THEN + cons = 0.2 + conn = 0.5 + sl = 2.0 !sl helps control albedo zenith dependence + + ! 05/02/2023, Dai: move from CoLMMAIN.F90 + ! update the snow age + IF (snl == 0) sag=0. + CALL snowage (deltim,t_grnd,scv,scvold,sag) + + ! correction for snow age + age = 1.-1./(1.+sag) + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ELSE + + ! 01/09/2023, yuan: CALL SNICAR for snow albedo + use_snicar_frc = .false. ! true: IF radiative forcing is being calculated, + ! first estimate clean-snow albedo + use_snicar_ad = .true. ! use true: use SNICAR_AD_RT, false: use SNICAR_RT + + CALL SnowAlbedo( use_snicar_frc ,use_snicar_ad ,czen ,& + albg(:,1) ,albg(:,2) ,snl ,fsno ,& + scv ,wliq_soisno ,wice_soisno ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + albsno (:,1),albsno (:,2),albsno_pur(:,1),albsno_pur(:,2),& + albsno_bc (:,1),albsno_bc (:,2),albsno_oc (:,1),albsno_oc (:,2),& + albsno_dst(:,1),albsno_dst(:,2),ssno_lyr(1,1,:),ssno_lyr(2,1,:),& + ssno_lyr(1,2,:),ssno_lyr(2,2,:)) + + ! IF no snow layer exist + IF (snl == 0) THEN + ssno_lyr(:,:,1) = ssno_lyr(:,:,1) + ssno_lyr(:,:,0) + ssno_lyr(:,:,0) = 0. + ENDIF + ENDIF + ENDIF + +! 3.1 correction due to snow cover + albg(:,:) = (1.-fsno)*albg(:,:) + fsno*albsno(:,:) + alb (:,:) = albg(:,:) + +! ---------------------------------------------------------------------- +! 4. canopy albedos: two stream approximation or 3D canopy radiation transfer +! ---------------------------------------------------------------------- + IF (lai+sai > 1e-6 .and. patchtype < 3) THEN + + ! initialization + albv(:,:) = albg(:,:) + + IF (patchtype == 0) THEN !soil patches + +#if (defined LULC_USGS || defined LULC_IGBP) + CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + alb(:,:) = albv(:,:) +#endif + ELSE !other patchtypes (/=0) + CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + alb(:,:) = albv(:,:) + + ENDIF + ENDIF + + + IF (patchtype == 0) THEN +#ifdef LULC_IGBP_PFT + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) +#endif + +#ifdef LULC_IGBP_PC + ! Only process nature PFTs using 3D model if set DEF_PC_CROP_SPLIT true + CALL ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + + ! Process crop PFTs using 1D model if set DEF_PC_CROP_SPLIT true + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + + alb(:,:) = albv(:,:) +#endif + ENDIF + + ! treat soil/snow absorption in direct and diffuse respectively + ssoi(1,1) = tran(1,1)*(1.-albsoi(1,2)) + tran(1,3)*(1-albsoi(1,1)) + ssoi(2,1) = tran(2,1)*(1.-albsoi(2,2)) + tran(2,3)*(1-albsoi(2,1)) + ssoi(1,2) = tran(1,2)*(1.-albsoi(1,2)) + ssoi(2,2) = tran(2,2)*(1.-albsoi(2,2)) + + ssno(1,1) = tran(1,1)*(1.-albsno(1,2)) + tran(1,3)*(1-albsno(1,1)) + ssno(2,1) = tran(2,1)*(1.-albsno(2,2)) + tran(2,3)*(1-albsno(2,1)) + ssno(1,2) = tran(1,2)*(1.-albsno(1,2)) + ssno(2,2) = tran(2,2)*(1.-albsno(2,2)) + +!----------------------------------------------------------------------- + + END SUBROUTINE albland + + + SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! calculation of canopy albedos via two stream approximation (direct +! and diffuse ) and partition of incident solar +! +! Original author: Yongjiu Dai, June 11, 2001 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(2,2), &! (integral of i_up*exp(-kx) ) + edown(2,2) ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band iterator + +!----------------------------------------------------------------------- +! projected area of photo elements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + proj = phi1 + phi2 * coszen + extkb = proj / coszen + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSEIF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSEIF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + +#if (defined LULC_USGS) + ! yuan: to be consistent with CoLM2014, no stem considered + ! for twostream and leaf optical property calculations + sai_ = 0. +#else + sai_ = sai +#endif + + lsai = lai + sai_ + power3 = (lai+sai) / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + IF (lsai <= 1e-6) RETURN + + DO iw = 1, 2 ! WAVE_BAND_LOOP + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! account for stem optical property effects + scat = lai/lsai * ( tau(iw,1) + rho(iw,1) ) & + + sai_/lsai * ( tau(iw,2) + rho(iw,2) ) + + as = scat / 2. * proj / ( proj + coszen * phi2 ) + as = as * ( 1. - coszen * phi1 / ( proj + coszen * phi2 ) * & + log ( ( proj + coszen * phi2 + coszen * phi1 ) / ( coszen * phi1 ) ) ) + +! account for stem optical property effects + upscat = lai/lsai*tau(iw,1) + sai_/lsai*tau(iw,2) + ! 09/12/2014, yuan: a bug, change 1. - chil -> 1. + chil + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albg(iw,2)*p1/ce + f2 = 1. - albg(iw,2)*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albg(iw,1) - ( hh1 - albg(iw,2) * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = hh1 + hh2 + hh3 + tran(iw,1) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup(iw,1) = hh1 * (1. - s2*s2) / (2.*extkb) & + + hh2 * (1. - s1*s2) / (extkb + psi) & + + hh3 * (1. - s2/s1) / (extkb - psi) + + edown(iw,1) = hh4 * (1. - s2*s2) / (2.*extkb) & + + hh5 * (1. - s1*s2) / (extkb + psi) & + + hh6 * (1. - s2/s1) / (extkb - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (2.*extkb) ) * s2 & + + albg(iw,2) / ce * ( - h1 / (2.*extkb) / zmu2 * & + ( p3*lsai + p4 / (2.*extkb) ) - de ) * s2 & + + albg(iw,1) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / (4.*extkb*extkb) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = - h1 / (2.*extkb*zmu2) + hh2 + hh3 + tran(iw,1) = 1./ce * ( -h1/(2.*extkb*zmu2) * (p3*lsai + p4/(2.*extkb)) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup(iw,1) = (hh2 - h1/(2.*extkb*zmu2)) * (1. - s2*s2) / (2.*extkb) & + + hh3 * (lsai - 0.) & + + h1/(2.*extkb*zmu2) * ( lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + edown(iw,1) = (hh5 - (h1*p4/(4.*extkb*extkb*zmu) + de)/ce) * (1. - s2*s2)/(2.*extkb) & + + hh6 * (lsai - 0.) & + + h1*p3/(ce*4.*extkb*extkb*zmu2) * (lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + ENDIF + + ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) + ssha(iw,1) = scat * (1.-s2) & + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + +!----------------------------------------------------------------------- +! calculation of diffuse albedos and canopy transmittances +! albv(iw,2) ( i-up ) +! tran(iw,2) ( i-down ) +!----------------------------------------------------------------------- + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = 0. + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1. + + hh7 = -m2 / (m1*n2 - m2*n1) + hh8 = -m1 / (m2*n1 - m1*n2) + + hh9 = hh7 * p1 / ce + hh10 = hh8 * p2 / ce + + albv(iw,2) = hh7 + hh8 + tran(iw,2) = hh9 * s1 + hh10 / s1 + + IF (abs(sigma) .gt. 1.e-10) THEN + eup(iw,2) = hh7 * (1. - s1*s2) / (extkb + psi) & + + hh8 * (1. - s2/s1) / (extkb - psi) + edown(iw,2) = hh9 * (1. - s1*s2) / (extkb + psi) & + + hh10 * (1. - s2/s1) / (extkb - psi) + ELSE + eup(iw,2) = hh7 * (1. - s1*s2) / ( extkb + psi) + hh8 * (lsai - 0.) + edown(iw,2) = hh9 * (1. - s1*s2) / ( extkb + psi) + hh10 * (lsai - 0.) + ENDIF + + ssun(iw,2) = (1.-scat) / zmu * (eup(iw,2) + edown(iw,2)) + ssha(iw,2) = tran(iw,2) * ( albg(iw,2) -1. ) - ( albv(iw,2) - 1. ) & + - ( 1. - scat ) / zmu * ( eup(iw,2) + edown(iw,2) ) + + ENDDO ! WAVE_BAND_LOOP + + ! 03/06/2020, yuan: add direct transmittance (s2) to + ! tran for incident direct case + ! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + + END SUBROUTINE twostream + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! An improved two stream approximation +! +! Original author: Yongjiu Dai, June 11, 2001 +! Hua Yuan, 03/2020 +! +! !REFERENCES: +! 1) Yuan, H., Dai, Y., Dickinson, R. E., Pinty, B., Shangguan, W., +! Zhang, S., et al. (2017). Reexamination and further development of +! two-stream canopy radiative transfer models for global land modeling. +! Journal of Advances in Modeling Earth Systems, 9(1), 113-129. +! https://doi.org/10.1002/2016MS000773 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! cosine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscatter parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band loop index + integer ic ! direct/diffuse loop index + + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev + +!----------------------------------------------------------------------- +! projected area of photo elements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSEIF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSEIF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + + lsai = lai + sai + power3 = lsai / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + tmptau = 0.5_r8 * lsai + cosdif = - tmptau / log(exp(-0.87_r8*tmptau) / (1+0.92_r8*tmptau)) + + ! black ground case + albgblk = 1.e-6_r8 + + DO iw = 1, 2 ! WAVE_BAND_LOOP + + ! ic 1: incident direct; 2: incident diffuse + DO ic = 1, 2 + + IF (ic == 2) THEN + cosz = max(0.001_r8, cosdif) + theta = acos(cosz) + theta = theta/3.14159*180 + + theta = theta + chil*5._r8 + cosz = cos(theta/180*3.14159) + ELSE + cosz = coszen + ENDIF + + proj = phi1 + phi2 * cosz + extkb = proj / cosz + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! + stem optical properties + wtau = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + wrho = lai/lsai*rho(iw,1) + sai/lsai*rho(iw,2) + + scat = wtau + wrho + + as = scat / 2. * proj / ( proj + cosz * phi2 ) + as = as * ( 1. - cosz * phi1 / ( proj + cosz * phi2 ) * & + log ( ( proj + cosz * phi2 + cosz * phi1 ) / ( cosz * phi1 ) ) ) + +! + stem optical properties + ! scat ~ omega + ! upscat ~ betail*scat + ! beta0 ~ betadl + ! scat-2.*upscat ~ rho - tau + upscat = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + + ! [MODI 1] + beta0 = 0.5_r8 * ( scat + 1._r8/extkb*(1._r8+chil)**2/4._r8*(wrho-wtau) )/scat + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albgblk*p1/ce + f2 = 1. - albgblk*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (ic == 1) THEN + s2d = s2 + extkbd = extkb + ENDIF + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albgblk - ( hh1 - albgblk * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = hh1 + hh2 + hh3 + tran(iw,ic) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup = hh1 * (1. - s2*s2d) / (extkbd + extkb) & + + hh2 * (1. - s2d*s1) / (extkbd + psi) & + + hh3 * (1. - s2d/s1) / (extkbd - psi) + + edw = hh4 * (1. - s2*s2d) / (extkbd + extkb) & + + hh5 * (1. - s2d*s1) / (extkbd + psi) & + + hh6 * (1. - s2d/s1) / (extkbd - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (extkb+extkbd) ) * s2 & + + albgblk / ce * ( - h1 / (extkb+extkbd) / zmu2 * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + albgblk * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / ((extkb+extkbd)*(extkb+extkbd)) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = - h1 / ((extkb+extkbd)*zmu2) + hh2 + hh3 + tran(iw,ic) = 1./ce * ( -h1 / ((extkb+extkbd)*zmu2) * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup = (hh2 - h1/((extkb+extkbd)*zmu2)) * (1. - s2*s2d)/(extkb+extkbd) & + + hh3 * (lsai - 0.) & + + h1/((extkb+extkbd)*zmu2) * ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + edw = (hh5 - (h1*p4/((extkb+extkbd)*(extkb+extkbd)*zmu) + de)/ce) * & + (1. - s2*s2d) / (extkb+extkbd) + hh6 * (lsai - 0.) & + + h1*p3/(ce*(extkb+extkbd)*(extkb+extkbd)*zmu2) * & + ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + ENDIF + + sall(iw,ic) = 1. - albv(iw,ic) - (1.-albgblk)*(tran(iw,ic)+s2) + + IF (ic == 1) THEN + ssun(iw,ic) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup + edw) ) + ELSE + ssun(iw,ic) = (1.-scat) * ( extkb*(1.-s2*s2d)/(extkb+extkbd) + 1. / zmu * (eup + edw) ) + ENDIF + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ENDDO ! ic + + ! for reversed diffuse radiation back from ground + eup = hh1 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh2 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh3 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + edw = hh4 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh5 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh6 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + ssun_rev = s2d * (1._r8 - scat) * & + ( extkb*(1._r8-s2/s2d)/(extkb-extkbd) + 1._r8 / zmu * (eup + edw ) ) + + ! ----------------------------------------------------------- + ! consider the multiple reflectance between canopy and ground + ! ----------------------------------------------------------- + + ! common ratio for geometric series + q = albg(iw,2) * albv(iw,2) + + DO ic = 1, 2 ! from 1 to 2, cannot be reversed + + ! ----------------------------------------------------------- + ! re-calculate the absorption, transmission and albedo + ! for direct radiation + + ! 03/06/2020, yuan: tran originally meant diffuse flow, now the direct + ! transmittance is also included + ! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases + IF (ic == 1) THEN + tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d + + sall(iw,ic) = sall(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) + + albv(iw,ic) = 1. - sall(iw,ic) - & + (1.-albg(iw,2))*tran(iw,ic) - (1.-albg(iw,1))*s2d + + ssun(iw,ic) = ssun(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * ssun_rev + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ELSE + tran(iw,ic) = (s2 + tran(iw,ic)) / (1.-q) + + sall(iw,ic) = sall(iw,ic) + tran(iw,ic)*albg(iw,2)*sall(iw,2) + albv(iw,ic) = 1. - sall(iw,ic) - (1.-albg(iw,2))*tran(iw,ic) + + ssun(iw,ic) = ssun(iw,ic) + tran(iw,ic)*albg(iw,2)*ssun_rev + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + ENDIF + + ENDDO !ic + + ENDDO !iw + + ! restore extkb + extkb = extkbd + + END SUBROUTINE twostream_mod +#endif + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! A Wrap subroutine to calculate PFT radiation using two-stream model +! +! Created by Hua Yuan, 03/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Namelist, only: DEF_USE_PC, DEF_PC_CROP_SPLIT + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ! patch index + + ! environmental variables + real(r8), intent(in) :: & + coszen, &! cosine of solar zenith angle + albg(2,2) ! albedos of ground + + ! output + real(r8), intent(inout) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- Local Variables ---------------------------- + integer :: i, p, ps, pe + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) + +!----------------------------------------------------------------------- + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( tran_p (2,3,ps:pe) ) + allocate ( albv_p (2,2,ps:pe) ) + + DO i = ps, pe + p = pftclass(i) + + ! If defined DEF_PC_CROP_SPLIT, for crop PFTs, use 1D twostream model; + ! Otherwise, set their value to PC 3D model results. + IF ( DEF_USE_PC .and. (.not.DEF_PC_CROP_SPLIT .or. p.lt.15) ) THEN + albv_p(:,:,i) = albv(:,:) + tran_p(:,:,i) = tran(:,:) + CYCLE + ENDIF + + IF (lai_p(i)+sai_p(i) > 1.e-6) THEN + CALL twostream_mod (chil_p(p),rho_p(:,:,p),tau_p(:,:,p),1.,lai_p(i),sai_p(i),& + fwet_snow_p(i),coszen,albg,albv_p(:,:,i),tran_p(:,:,i),thermk_p(i),& + extkb_p(i),extkd_p(i),ssun_p(:,:,i),ssha_p(:,:,i)) + ELSE + albv_p(:,:,i) = albg(:,:) + ssun_p(:,:,i) = 0. + ssha_p(:,:,i) = 0. + tran_p(:,1,i) = 0. + tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. + ENDIF + ENDDO + + albv(1,1) = sum( albv_p(1,1,ps:pe)*pftfrac(ps:pe) ) + albv(1,2) = sum( albv_p(1,2,ps:pe)*pftfrac(ps:pe) ) + albv(2,1) = sum( albv_p(2,1,ps:pe)*pftfrac(ps:pe) ) + albv(2,2) = sum( albv_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + tran(1,1) = sum( tran_p(1,1,ps:pe)*pftfrac(ps:pe) ) + tran(1,2) = sum( tran_p(1,2,ps:pe)*pftfrac(ps:pe) ) + tran(1,3) = sum( tran_p(1,3,ps:pe)*pftfrac(ps:pe) ) + tran(2,1) = sum( tran_p(2,1,ps:pe)*pftfrac(ps:pe) ) + tran(2,2) = sum( tran_p(2,2,ps:pe)*pftfrac(ps:pe) ) + tran(2,3) = sum( tran_p(2,3,ps:pe)*pftfrac(ps:pe) ) + + IF (ssun(1,1)<0 .or. ssun(1,2)<0 .or. ssun(2,1)<0 .or. ssun(2,2)<0) THEN + print *, 'Warning: negative ssun in albedo calculation!',ipatch + print *, ssun + ENDIF + + deallocate ( tran_p ) + deallocate ( albv_p ) + + END SUBROUTINE twostream_wrap +#endif + + + SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) + +!======================================================================= +! Original version: Robert Dickinson +! Update snow cover and snow age, based on BATS code +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(in) :: tg ! temperature of soil at surface [K] + real(r8), intent(in) :: scv ! snow cover, water equivalent [mm] + real(r8), intent(in) :: scvold ! snow cover for previous time step [mm] + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + +!-------------------------- Local Variables ---------------------------- + + real(r8) :: age1 ! snow aging factor due to crystal growth [-] + real(r8) :: age2 ! snow aging factor due to surface growth [-] + real(r8) :: age3 ! snow aging factor due to accum of other particles [-] + real(r8) :: arg ! temporary variable used in snow age calculation [-] + real(r8) :: arg2 ! temporary variable used in snow age calculation [-] + real(r8) :: dela ! temporary variable used in snow age calculation [-] + real(r8) :: dels ! temporary variable used in snow age calculation [-] + real(r8) :: sge ! temporary variable used in snow age calculation [-] + +!----------------------------------------------------------------------- + IF(scv <= 0.) THEN + sag = 0. +! +! Over Antarctica +! + ELSEIF (scv > 800.) THEN + sag = 0. +! +! Away from Antarctica +! + ELSE + age3 = 0.3 + arg = 5.e3*(1./tfrz-1./tg) + arg2 = min(0.,10.*arg) + age2 = exp(arg2) + age1 = exp(arg) + dela = 1.e-6*deltim*(age1+age2+age3) + dels = 0.1*max(0.0,scv-scvold) + sge = (sag+dela)*(1.0-dels) + sag = max(0.0,sge) + ENDIF + + END SUBROUTINE snowage + + + SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& + albsod ,albsoi ,snl ,frac_sno ,& + h2osno ,h2osno_liq ,h2osno_ice ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + albgrd ,albgri ,albgrd_pur ,albgri_pur ,& + albgrd_bc ,albgri_bc ,albgrd_oc ,albgri_oc ,& + albgrd_dst ,albgri_dst ,flx_absdv ,flx_absdn ,& + flx_absiv ,flx_absin ) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! The calling sequence is: +! -> SNICAR_RT: snow albedos: direct beam (SNICAR) +! or +! SNICAR_AD_RT: snow albedos: direct beam (SNICAR-AD) +! -> SNICAR_RT: snow albedos: diffuse (SNICAR) +! or +! SNICAR_AD_RT: snow albedos: diffuse (SNICAR-AD) +! +! !ORIGINAL: +! 1) The Community Land Model version5.0 (CLM5.0) +! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) +! +! !REFERENCES: +! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. +! Geosci. Model Dev., 14, 7673-7704, https://doi.org/10.5194/gmd-14-7673-2021 +! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) +! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. +! Geosci. Model Dev., 16, 75-94, https://doi.org/10.5194/gmd-16-75-2023 +! +! !REVISIONS: +! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Vars_Global, only: maxsnl + USE MOD_SnowSnicar, only: SNICAR_RT, SNICAR_AD_RT + + ! and the evolution of snow effective radius + ! + ! DAI, Dec. 28, 2022 + + IMPLICIT NONE + +!------------------------------------------------------------------------- +! temporary setting + + integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + logical, parameter :: DO_SNO_OC = .true. ! to include organic carbon (OC) + logical, parameter :: DO_SNO_AER = .true. ! to include aerosols in snow radiative calculations + integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes + ! + ! !ARGUMENTS: + ! + logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, + ! first estimate clean-snow albedo + logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT + + real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle + real(r8), intent(in) :: albsod ( numrad ) ! direct-beam soil albedo (col,bnd) [frc] + real(r8), intent(in) :: albsoi ( numrad ) ! diffuse soil albedo (col,bnd) [frc] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0-1) + real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] + real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] + + real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass conc. of hydrophilic BC [kg/kg] + real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass conc. of hydrophobic BC [kg/kg] + real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass conc. of hydrophilic OC [kg/kg] + real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass conc. of hydrophobic OC [kg/kg] + real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 1 [kg/kg] + real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 2 [kg/kg] + real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 3 [kg/kg] + real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 4 [kg/kg] + + real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) + real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) + real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) + real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) + real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) + real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) + real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) + real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) + real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) + real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) + real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor VIS [frc] + real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor NIR [frc] + real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor VIS [frc] + real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor NIR [frc] + + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: i ! index for layers [idx] + integer :: aer ! index for sno_nbr_aer + integer :: ib ! band index + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) + integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) + + ! mass concentration of aerosol species for forcing calculation (zero) (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of aerosol species for BC forcing (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_bc (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of aerosol species for OC forcing (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_oc (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of aerosol species for dust forcing (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_dst (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of all aerosol species for feedback calculation (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_fdb (maxsnl+1:0,sno_nbr_aer) + + real(r8) :: albsfc (numrad) ! albedo of surface underneath snow (col,bnd) + real(r8) :: albsnd (numrad) ! snow albedo (direct) + real(r8) :: albsni (numrad) ! snow albedo (diffuse) + real(r8) :: albsnd_pur (numrad) ! direct pure snow albedo + real(r8) :: albsni_pur (numrad) ! diffuse pure snow albedo + real(r8) :: albsnd_bc (numrad) ! direct snow albedo without BC + real(r8) :: albsni_bc (numrad) ! diffuse snow albedo without BC + real(r8) :: albsnd_oc (numrad) ! direct snow albedo without OC + real(r8) :: albsni_oc (numrad) ! diffuse snow albedo without OC + real(r8) :: albsnd_dst (numrad) ! direct snow albedo without dust + real(r8) :: albsni_dst (numrad) ! diffuse snow albedo without dust + real(r8) :: flx_absd_snw (maxsnl+1:1,numrad) ! flux absorption for just snow (direct) [frc] + real(r8) :: flx_absi_snw (maxsnl+1:1,numrad) ! flux absorption for just snow (diffuse) [frc] + real(r8) :: foo_snw (maxsnl+1:1,numrad) ! dummy array for forcing calls + + integer :: snw_rds_in (maxsnl+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] + + integer , parameter :: nband =numrad ! number of solar radiation waveband classes + + !----------------------------------------------------------------------- + + ! Initialize output because solar radiation only done IF coszen > 0 + + DO ib = 1, numrad + albgrd(ib) = 1._r8 + albgri(ib) = 1._r8 + albgrd_pur(ib) = 1._r8 + albgri_pur(ib) = 1._r8 + albgrd_bc(ib) = 1._r8 + albgri_bc(ib) = 1._r8 + albgrd_oc(ib) = 1._r8 + albgri_oc(ib) = 1._r8 + albgrd_dst(ib) = 1._r8 + albgri_dst(ib) = 1._r8 + DO i=maxsnl+1,1,1 + flx_absdv(i) = 0._r8 + flx_absdn(i) = 0._r8 + flx_absiv(i) = 0._r8 + flx_absin(i) = 0._r8 + ENDDO + ENDDO ! END of numrad loop + + ! set variables to pass to SNICAR. + + flg_snw_ice = 1 + albsfc(:) = albsoi(:) + snw_rds_in(:) = nint(snw_rds(:)) + + ! zero aerosol input arrays + DO aer = 1, sno_nbr_aer + DO i = maxsnl+1, 0 + mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 + mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 + mss_cnc_aer_in_fdb(i,aer) = 0._r8 + ENDDO + ENDDO + + ! If radiative forcing is being calculated, first estimate clean-snow albedo + + IF (use_snicar_frc) THEN + + ! 1. PURE SNOW ALBEDO CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 2. BC input array: + ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) + ENDIF + mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_bc(:,8) = mss_cnc_dst4(:) + + ! BC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 3. OC input array: + ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) + + mss_cnc_aer_in_frc_oc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_oc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_oc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_oc(:,8) = mss_cnc_dst4(:) + + ! OC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + ENDIF ! END IF (DO_SNO_OC) + + ! 4. DUST FORCING CALCULATIONS + ! DUST input array: + ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] + mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) + + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ENDIF !END IF use_snicar_frc + + + ! -------------------------------------------- + ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: + ! -------------------------------------------- + ! Set aerosol input arrays + ! feedback input arrays have been zeroed + ! set soot and dust aerosol concentrations: + IF (DO_SNO_AER) THEN + mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) + + ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: + ! 1) Knowledge of their optical properties is primitive + ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, + ! it has a negligible darkening effect. + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) + ENDIF + + mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + + ! ground albedos and snow-fraction weighting of snow absorption factors + DO ib = 1, nband + IF (coszen_col > 0._r8) THEN + ! ground albedo was originally computed in SoilAlbedo, but is now computed here + ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT + ! was switched for SNICAR/SNICAR_AD_RT. + ! 09/01/2023, yuan: change to only snow albedo, the same below + !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno + !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + albgrd(ib) = albsnd(ib) + albgri(ib) = albsni(ib) + + ! albedos for radiative forcing calculations: + IF (use_snicar_frc) THEN + ! pure snow albedo for all-aerosol radiative forcing + !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno + !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + albgrd_pur(ib) = albsnd_pur(ib) + albgri_pur(ib) = albsni_pur(ib) + + ! BC forcing albedo + !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno + !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + albgrd_bc(ib) = albsnd_bc(ib) + albgri_bc(ib) = albsni_bc(ib) + + IF (DO_SNO_OC) THEN + ! OC forcing albedo + !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno + !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno + albgrd_oc(ib) = albsnd_oc(ib) + albgri_oc(ib) = albsni_oc(ib) + ENDIF + + ! dust forcing albedo + !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno + !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno + albgrd_dst(ib) = albsnd_dst(ib) + albgri_dst(ib) = albsni_dst(ib) + ENDIF + + ! also in this loop (but optionally in a different loop for vectorized code) + ! weight snow layer radiative absorption factors based on snow fraction and soil albedo + ! (NEEDED FOR ENERGY CONSERVATION) + DO i = maxsnl+1,1,1 + IF (subgridflag == 0 ) THEN + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ELSEIF (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ENDIF + ELSE + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absiv(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + ELSEIF (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absin(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + END SUBROUTINE SnowAlbedo + + + SUBROUTINE albocean (oro, scv, coszrs, alb) + +!----------------------------------------------------------------------- +! +! Compute surface albedos +! +! Computes surface albedos for direct/diffuse incident radiation for +! two spectral intervals: +! s = 0.2-0.7 micro-meters +! l = 0.7-5.0 micro-meters +! +! Albedos specified as follows: +! +! Ocean Uses solar zenith angle to compute albedo for direct +! radiation; diffuse radiation values constant; albedo +! independent of spectral interval and other physical +! factors such as ocean surface wind speed. +! +! Ocean with Surface albs specified; combined with overlying snow +! sea ice +! +! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! Yongjiu Dai and Xin-Zhong Liang (08/01/2001) +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag + real(r8), intent(in) :: scv ! snow water equivalent) [mm] + real(r8), intent(in) :: coszrs ! Cosine solar zenith angle + + real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms + ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms + +!-------------------------- Local Variables ---------------------------- + + real(r8) frsnow ! horizontal fraction of snow cover + real(r8) snwhgt ! physical snow height + real(r8) rghsnw ! roughness for horizontal snow cover fractn + + real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms + real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms + real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms + real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms + + real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] + real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters + +!----------------------------------------------------------------------- +! initialize all ocean/sea ice surface albedos to zero + + alb(:,:) = 0. + IF(coszrs<=0.0) RETURN + + IF(nint(oro)==2)THEN + alb(1,1) = asices + alb(2,1) = asicel + alb(1,2) = alb(1,1) + alb(2,2) = alb(2,1) + sasdif = asnows + saldif = asnowl + + IF(scv>0.)THEN + IF (coszrs<0.5) THEN + ! zenith angle regime 1 ( coszrs < 0.5 ). + ! set direct snow albedos (limit to 0.98 max) + sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) + saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) + ELSE + ! zenith angle regime 2 ( coszrs >= 0.5 ) + sasdir = asnows + saldir = asnowl + ENDIF + + ! compute both diffuse and direct total albedos + snwhgt = 20.*scv / 1000. + rghsnw = 0.25 + frsnow = snwhgt/(rghsnw+snwhgt) + alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow + alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow + alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow + alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow + ENDIF + ENDIF + +! ice-free ocean albedos function of solar zenith angle only, and +! independent of spectral interval: + + IF(nint(oro)==0)THEN + alb(2,1) = .026/(coszrs**1.7+.065) & + + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) + alb(1,1) = alb(2,1) + alb(1,2) = 0.06 + alb(2,2) = 0.06 + ENDIF + + END SUBROUTINE albocean + +END MODULE MOD_Albedo +! --------- EOP ---------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 new file mode 100644 index 0000000000..2c9b2ef86c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 @@ -0,0 +1,3374 @@ +#include + +#ifdef HYPERSPECTRAL +MODULE MOD_Albedo_HiRes + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: albland_HiRes + PUBLIC :: snowage + PUBLIC :: SnowAlbedo + PUBLIC :: albocean + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: twostream + PRIVATE :: twostream_hires +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + PRIVATE :: twostream_mod + PRIVATE :: twostream_wrap + PRIVATE :: twostream_hires_mod + PRIVATE :: twostream_hires_wrap +#endif + PRIVATE :: BSM_soil_moisture, calculate_tav, calculate_wgt_variable + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE albland_HiRes (ipatch, patchtype, deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno,dz_soisno,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd,& + + ! new parameters for high res + alb_hires ,& + dir_frac , dif_frac, & + reflectance, transmittance, & + soil_alb, kw, nw, porsl, & + reflectance_out, transmittance_out,& + doy, patchlatr, patchlonr ,& + ! new parameters for urban + urban_albedo, mean_albedo ,& + lat_north, lat_south, lon_west, lon_east) + +!======================================================================= +! Calculates fragmented albedos (direct and diffuse) in +! wavelength regions split at 0.7um. +! +! (1) soil albedos: as in BATS formulations, which are the function of +! soil color and moisture in the surface soil layer +! (2) snow albedos: as in BATS formulations, which are inferred from +! the calculations of Wiscombe and Warren (1980) and the snow model +! and data of Anderson(1976), and the function of snow age, grain size, +! solar zenith angle, pollution, the amount of the fresh snow +! (3) canopy albedo: two-stream approximation model +! (4) glacier albedos: as in BATS, which are set to constants (0.8 for visible beam, +! 0.55 for near-infrared) +! (5) lake and wetland albedos: as in BATS, which depend on cosine solar zenith angle, +! based on data in Henderson-Sellers (1986). The frozen lake and wetland albedos +! are set to constants (0.6 for visible beam, 0.4 for near-infrared) +! (6) over the snow covered tile, the surface albedo is estimated by a linear +! combination of albedos for snow, canopy and bare soil (or lake, wetland, glacier). +! +! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002, 03/2014 +! +! !REVISIONS: +! 12/2019, Hua Yuan: added a wrap FUNCTION for PFT calculation, details see +! twostream_wrap() added a wrap FUNCTION for PC (3D) calculation, +! details see ThreeDCanopy_wrap() +! +! 03/2020, Hua Yuan: added an improved two-stream model, details see +! twostream_mod() +! +! 08/2020, Hua Yuan: account for stem optical property effects in twostream +! model +! +! 01/2023, Hua Yuan: CALL SNICAR model to calculate snow albedo&absorption, +! added SNICAR related variables +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_USE_SNICAR, DEF_HighResSoil + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_HighRes_Parameters, only: rad2deg +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_Aerosol, only: AerosolMasses + USE MOD_SnowSnicar_HiRes, only: SnowAge_grain +#ifdef LULC_IGBP_PC + USE MOD_3DCanopyRadiation, only: ThreeDCanopy_wrap +#endif + + ! IEEE arithmetic module for isnan function, only for debug + ! use, intrinsic :: IEEE_ARITHMETIC, only: IEEE_IS_NAN, IEEE_SUPPORT_DATATYPE + + IMPLICIT NONE + +!------------------------- Dummy Arguments ----------------------------- +! ground cover index + integer, intent(in) :: & + ipatch, &! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=deep lake) + integer, intent(in) :: & + snl, &! number of snow layers + doy + + real(r8), intent(in) :: & + patchlatr, &! patch latitude (radian) + patchlonr ! patch longitude (radian) + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + soil_s_v_alb, &! albedo of visible of the saturated soil + soil_d_v_alb, &! albedo of visible of the dry soil + soil_s_n_alb, &! albedo of near infrared of the saturated soil + soil_d_n_alb, &! albedo of near infrared of the dry soil + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + green, &! green leaf fraction + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + fwet_snow, &! vegetation snow fractional cover [-] + + coszen, &! cosine of solar zenith angle [-] + wt, &! fraction of vegetation covered by snow [-] + fsno, &! fraction of soil covered by snow [-] + ssw, &! water volumetric content of soil surface layer [m3/m3] + scv, &! snow cover, water equivalent [mm] + scvold, &! snow cover for previous time step [mm] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + forc_t, &! atmospheric temperature [K] + t_grnd, &! ground surface temperature [K] + porsl + + real(r8), intent(in) :: & + wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) + wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) + snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] + t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] + dz_soisno ( maxsnl+1:1 ), &! layer thickness (m) + + dir_frac (211) ,&! + dif_frac (211) ,&! + reflectance (0:15,211,2) ,&! reflectance (PFT, wavelength, dir/dif) + transmittance(0:15,211,2) ,&! transmittance (PFT, wavelength, dir/dif) + soil_alb (211) ,&! soil albedo [-] + kw (211) ,&! soil albedo [-] + nw (211) ! soil albedo [-] + + + real(r8), intent(inout) :: & + snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + + real(r8), intent(out) :: & + alb(2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(out) :: & + alb_hires (211, 2) ,&! high resolution albedo, (wavelength, dir/dif) + reflectance_out (211, 0:15) ,&! + transmittance_out(211, 0:15) + + real(r8), intent(out) :: & + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] + ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] + + ! New inout parameters for urban + real(r8), ALLOCATABLE, intent(in) :: & + urban_albedo(:,:,:), &! (cluster_id, season,wavelength) + mean_albedo(:, :), &! (season, wavelength) + lat_north(:), lat_south(:),& + lon_west (:), lon_east(:) + + +!-------------------------- Local variables ---------------------------- + + real(r8) :: &! + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary varaiable [-] + albsoi(2,2), &! soil albedo [-] + albsno(2,2), &! snow albedo [-] + albsno_pur(2,2), &! snow albedo [-] + albsno_bc (2,2), &! snow albedo [-] + albsno_oc (2,2), &! snow albedo [-] + albsno_dst(2,2), &! snow albedo [-] + albg(2,2), &! albedo, ground + albv(2,2), &! albedo, vegetation [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse vis radiation [-] + dralbl, &! snow albedo for direct nir radiation [-] + dralbs, &! snow albedo for direct vis radiation [-] + lsai, &! leaf and stem area index (LAI+SAI) [m2/m2] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1, &! alb for NIR, incident on new snow (zen angle<60) [-] + upscat, &! upward scattered fraction for direct beam [-] + tran(2,3) ! canopy transmittances for solar radiation + +!-------------------------- Local high resolution variables ---------------------------- + real(r8) :: &! + + ! sun fraction + fsds_vis_dir_frac(29 ) ,& + fsds_nir_dir_frac(182) ,& + fsds_vis_dif_frac(29 ) ,& + fsds_nir_dif_frac(182) ,& + + ! ground + albg_hires(211, 2) ,& + + ! soil + albsoi_hires(211, 2) ,& + + ! snow + alb_sno_hires(211, 2) ,&! high resolution albedo, (wavelength, dir/dif) + + alb_sno_5band (5, 2) ,& + albsno_pur_5band(5, 2) ,&! snow albedo [-] + albsno_bc_5band (5, 2) ,&! snow albedo [-] + albsno_oc_5band (5, 2) ,&! snow albedo [-] + albsno_dst_5band(5, 2) ,&! snow albedo [-] + + ! vegetation + rho_hires(211, 2) ,& + tau_hires(211, 2) ,& + albv_hires(211, 2) ,& + tran_hires(211, 3) ,& + scat_hires(211) ,& + ssun_hires(211, 2) ,& + ssha_hires(211, 2) + + INTEGER, PARAMETER, DIMENSION(6) :: band_index = (/ & + 1, 30, 60, 80, 110, 212 &! 400, 700, 1000, 1200, 1500, 2500 nm + /) + + real(r8) :: smc + integer :: i, j, ibnd, start_index, end_index ! index for 5 bands [idx] + + integer ps, pe + logical do_capsnow !true => DO snow capping + logical use_snicar_frc !true: IF radiative forcing is being calculated, first estimate clean-snow albedo + logical use_snicar_ad !true: use SNICAR_AD_RT, false: use SNICAR_RT + + real(r8) snwcp_ice !excess precipitation due to snow capping [kg m-2 s-1] + real(r8) mss_cnc_bcphi ( maxsnl+1:0 ) !mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8) mss_cnc_bcpho ( maxsnl+1:0 ) !mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8) mss_cnc_ocphi ( maxsnl+1:0 ) !mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8) mss_cnc_ocpho ( maxsnl+1:0 ) !mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8) mss_cnc_dst1 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst2 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst3 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst4 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + + logical :: has_nan + + real(r8) :: lat, lon + INTEGER :: num_urban_lat, num_urban_lon + INTEGER :: i_cluster + INTEGER :: season_index +! ---------------------------------------------------------------------- +! 1. Initial set +! ---------------------------------------------------------------------- +! set fsds + fsds_vis_dir_frac(:) = dir_frac(1:29) + fsds_nir_dir_frac(:) = dir_frac(30:211) + fsds_vis_dif_frac(:) = dif_frac(1:29) + fsds_nir_dif_frac(:) = dif_frac(30:211) + +! visible and near infrared band albedo for new snow + snal0 = 0.85 !visible band + snal1 = 0.65 !near infrared + +! ---------------------------------------------------------------------- +! set default soil and vegetation albedos and solar absorption + alb (:,:) = 1. !averaged + albg(:,:) = 1. !ground + albv(:,:) = 1. !vegetation + ssun(:,:) = 0. !sunlit leaf absorption + ssha(:,:) = 0. !shaded leaf absorption + + alb_hires (:,:) = 1. ! high resolution albedo + albg_hires(:,:) = 1. ! high resolution ground albedo + albv_hires(:,:) = 1. ! high resolution vegetation albedo + ssun_hires (:,:) = 0. + ssha_hires (:,:) = 0. + + ! albsoi_hires (:,:) = 1. + + tran(:,1) = 0. !incident direct radiation diffuse transmittance + tran(:,2) = 1. !incident diffuse radiation diffuse transmittance + tran(:,3) = 1. !incident direct radiation direct transmittance + + tran_hires(:,1) = 0. !incident direct radiation diffuse transmittance + tran_hires(:,2) = 1. !incident diffuse radiation diffuse transmittance + tran_hires(:,3) = 1. !incident direct radiation direct transmittance + + reflectance_out (:,:) = -999. + transmittance_out(:,:) = -999. + + ! 07/06/2023, yuan: use the values of previous timestep. + ! for nighttime longwave calculations. + !thermk = 1.e-3 + IF (lai+sai <= 1.e-6) THEN + thermk = 1. + ENDIF + extkb = 1. + extkd = 0.718 + + albsno (:,:) = 1. !set initial snow albedo + albsno_pur(:,:) = 1. !set initial pure snow albedo + albsno_bc (:,:) = 1. !set initial BC snow albedo + albsno_oc (:,:) = 1. !set initial OC snow albedo + albsno_dst(:,:) = 1. !set initial dust snow albedo + + alb_sno_hires (:,:) = 1.! high resolution albedo, (wavelength, dir/dif) + albsno_pur_5band(:,:) = 1. + albsno_bc_5band (:,:) = 1. + albsno_oc_5band (:,:) = 1. + albsno_dst_5band(:,:) = 1. + + ! soil and snow absorption + ssoi (:,:) = 0. !set initial soil absorption + ssno (:,:) = 0. !set initial snow absorption + ssno_lyr(:,:,:) = 0. !set initial snow layer absorption + +IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + ssun_p(:,:,ps:pe) = 0. + ssha_p(:,:,ps:pe) = 0. + + ssun_hires_p(:,:,ps:pe) = 0. + ssha_hires_p(:,:,ps:pe) = 0. + ! 07/06/2023, yuan: use the values of previous timestep. + !thermk_p(ps:pe) = 1.e-3 + WHERE (lai_p(ps:pe)+sai_p(ps:pe) <= 1.e-6) thermk_p(ps:pe) = 1. + extkb_p(ps:pe) = 1. + extkd_p(ps:pe) = 0.718 +#endif +ENDIF + +! ---------------------------------------------------------------------- +! Calculate column-integrated aerosol masses, and +! mass concentrations for radiative calculations and output +! (based on new snow level state, after SnowFilter is rebuilt. +! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there +! can be zero snow layers but an active column in filter) +IF (DEF_USE_SNICAR) THEN + snwcp_ice = 0.0 !excess precipitation due to snow capping [kg m-2 s-1] + do_capsnow = .false. !true => DO snow capping + + CALL AerosolMasses( deltim, snl ,do_capsnow ,& + wice_soisno(:0),wliq_soisno(:0),snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + +! ---------------------------------------------------------------------- +! Snow aging routine based on Flanner and Zender (2006), Linking snowpack +! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of +! wet-snow metamorphism in respect of liquid-water content, Ann. Glaciol. + + CALL SnowAge_grain( deltim ,snl ,dz_soisno(:1) ,& + pg_snow ,snwcp_ice ,snofrz ,& + + do_capsnow ,fsno ,scv ,& + wliq_soisno (:0),wice_soisno(:0),& + t_soisno (:1),t_grnd ,& + forc_t ,snw_rds ) +END IF +! ---------------------------------------------------------------------- + + lsai = lai + sai + IF(coszen <= -0.3) THEN + RETURN !only DO albedo when coszen > -0.3 + ENDIF + + czen = max(coszen, 0.001) + +! ---------------------------------------------------------------------- +! 2. get albedo over land +! ---------------------------------------------------------------------- +! 2.1 soil albedos, depends on moisture + + ! IF (patchtype <= 2) THEN !soil, urban and wetland + IF (patchtype == 0) THEN !soil + + ! calculate broadband albedos + alb_s_inc = max(0.11-0.40*ssw, 0.) + albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) + albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) + albg(:,2) = albg(:,1) !diffused albedos setting + + IF ( DEF_HighResSoil ) THEN + ! calculate high res soil albedos + CALL BSM_soil_moisture( ssw * 100., porsl * 100., soil_alb, kw, nw, albg_hires ) + + ! calculate broadband albedos + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, albg(1,1), albg(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, albg(1,2), albg(2,2)) + + ELSE + + ! calculate high res soil albedos + albg_hires(1 :29 ,1) = albg(1,1) + albg_hires(30:211,1) = albg(2,1) + albg_hires(1 :29 ,2) = albg(1,2) + albg_hires(30:211,2) = albg(2,2) + + END IF + + !DEBUG: Temporarily handle the missing values of soil albedo in certain grids + IF (soil_alb(1) < 0.01) THEN + albg_hires(1:29 ,1) = albg(1,1) + albg_hires(30:211 ,1) = albg(2,1) + albg_hires(1:29 ,2) = albg(1,2) + albg_hires(30:211 ,2) = albg(2,2) + END IF + + ELSE IF(patchtype == 1) THEN !urban + + ! select constant albedo for urban + lat = rad2deg(patchlatr) + lon = rad2deg(patchlonr) + + ! 根据lat、lon边界选择cluster_id + i_cluster = 0 + DO i = 1, SIZE(lat_north) + IF (lat >= lat_south(i) .and. lat <= lat_north(i) .and. & + lon >= lon_west(i) .and. lon <= lon_east(i)) THEN + i_cluster = i + EXIT + END IF + END DO + + ! 根据季节选择albedo + ! 季节指数: 1=冬季, 2=春季, 3=夏季, 4=秋季 + IF (doy >= 355 .or. doy < 80) THEN + season_index = 1 ! 冬季 + ELSE IF (doy >= 80 .and. doy < 172) THEN + season_index = 2 ! 春季 + ELSE IF (doy >= 172 .and. doy < 266) THEN + season_index = 3 ! 夏季 + ELSE + season_index = 4 ! 秋季 + END IF + + ! 提取反照率数据 + IF (i_cluster > 0 .and. allocated(urban_albedo)) THEN + albg_hires(:, 1) = urban_albedo(i_cluster, season_index, :) + albg_hires(:, 2) = urban_albedo(i_cluster, season_index, :) + ELSE + ! 如果未找到合适的cluster或数据未分配，使用mean_albedo + IF (allocated(mean_albedo)) THEN + albg_hires(:, 1) = mean_albedo(season_index, :) + albg_hires(:, 2) = mean_albedo(season_index, :) + ELSE + ! 如果都没有数据，使用默认值 + albg_hires(1 :29 ,1) = 0.12 + albg_hires(30:211,1) = 0.20 + albg_hires(1 :29 ,2) = 0.12 + albg_hires(30:211,2) = 0.20 + END IF + END IF + + ! 计算宽波段反照率 (VIS 和 NIR) + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, albg(1,1), albg(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, albg(1,2), albg(2,2)) + + ELSE IF (patchtype == 2) THEN !wetland + ! calculate broadband albedos + alb_s_inc = max(0.11-0.40*ssw, 0.) + albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) + albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) + albg(:,2) = albg(:,1) !diffused albedos setting + + albg_hires(1 :29 ,1) = albg(1,1) + albg_hires(1 :29 ,2) = albg(1,2) + albg_hires(30:211,1) = albg(2,1) + albg_hires(30:211,2) = albg(2,2) + +! 2.2 albedos for permanent ice sheet. + ELSE IF(patchtype == 3) THEN !permanent ice sheet + albg(1,:) = 0.8 + albg(2,:) = 0.55 + + albg_hires(1 :29 ,:) = 0.8 + albg_hires(30:211,:) = 0.55 + +! 2.3 albedo for inland water + ELSE IF(patchtype >= 4) THEN + albg0 = 0.05/(czen+0.15) + albg(:,1) = albg0 + albg(:,2) = 0.1 !Subin (2012) + + albg_hires(:,1) = albg0 + albg_hires(:,2) = 0.1 + + IF(t_grnd < tfrz)THEN !frozen lake and wetland + albg(1,:) = 0.6 + albg(2,:) = 0.4 + + albg_hires(1 :29 ,:) = 0.6 + albg_hires(30:211,:) = 0.4 + ENDIF + ENDIF + + ! SAVE soil ground albedo + albsoi (:,:) = albg (:,:) + albsoi_hires(:,:) = albg_hires(:,:) + + ! ---------------------------------------------------------------------- +! 3. albedo for snow cover. +! - Scheme 1: snow albedo depends on snow-age, zenith angle, and thickness +! of snow age gives reduction of visible radiation [CoLM2014]. +! - Scheme 2: SNICAR model +! ---------------------------------------------------------------------- + IF (scv > 0.) THEN + + IF (.not. DEF_USE_SNICAR) THEN + cons = 0.2 + conn = 0.5 + sl = 2.0 !sl helps control albedo zenith dependence + + ! 05/02/2023, Dai: move from CoLMMAIN.F90 + ! update the snow age + IF (snl == 0) sag=0. + CALL snowage (deltim,t_grnd,scv,scvold,sag) + + ! correction for snow age + age = 1.-1./(1.+sag) + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ELSE + + ! 01/09/2023, yuan: CALL SNICAR for snow albedo + use_snicar_frc = .false. ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo + use_snicar_ad = .true. ! use true: use SNICAR_AD_RT, false: use SNICAR_RT + + CALL SnowAlbedo( use_snicar_frc ,use_snicar_ad ,coszen ,& + albg_hires(:,1),albg_hires(:,2),snl ,fsno ,& + scv ,wliq_soisno ,wice_soisno ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + alb_sno_5band (:,1),alb_sno_5band (:,2),albsno_pur_5band(:,1),albsno_pur_5band(:,2),& + albsno_bc_5band (:,1),albsno_bc_5band (:,2),albsno_oc_5band (:,1),albsno_oc_5band (:,2),& + albsno_dst_5band(:,1),albsno_dst_5band(:,2),ssno_lyr(1,1,:) ,ssno_lyr(2,1,:) ,& + ssno_lyr(1,2,:) ,ssno_lyr(2,2,:) ,dir_frac ,dif_frac ) + + ! IF no snow layer exist + IF (snl == 0) THEN + ssno_lyr(:,:,1) = ssno_lyr(:,:,1) + ssno_lyr(:,:,0) + ssno_lyr(:,:,0) = 0. + ENDIF + ENDIF + ENDIF + +! 3.1 correction due to snow cover + ! albg(:,:) = (1.-fsno)*albg(:,:) + fsno*albsno(:,:) + ! alb (:,:) = albg(:,:) + + do ibnd = 1, 5 + start_index = band_index(ibnd) + end_index = band_index(ibnd+1) - 1 + + alb_sno_hires(start_index:end_index, 1) = alb_sno_5band(ibnd, 1) + alb_sno_hires(start_index:end_index, 2) = alb_sno_5band(ibnd, 2) + end do + + albg_hires(:,1) = (1.-fsno)*albg_hires(:,1) + fsno*alb_sno_hires(:,1) + albg_hires(:,2) = (1.-fsno)*albg_hires(:,2) + fsno*alb_sno_hires(:,2) + + alb_hires(:,1) = albg_hires(:,1) + alb_hires(:,2) = albg_hires(:,2) + + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, albg(1,1), albg(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, albg(1,2), albg(2,2)) + + alb (:,:) = albg(:,:) + +! ---------------------------------------------------------------------- +! 4. canopy albedos: two stream approximation or 3D canopy radiation transfer +! ---------------------------------------------------------------------- + IF (lai+sai > 1e-6 .and. patchtype < 3) THEN + ! initialization + albv(:,:) = albg(:,:) + + IF (patchtype == 0) THEN !soil patches + +#if (defined LULC_USGS || defined LULC_IGBP) + ! High resolution vegetation + write(*,*) "NOT SUPPORT NOW!!!!!!!" + CALL twostream_hires (chil,reflectance,transmittance,green,lai,sai, fwet_snow,& + czen,albg_hires,albv_hires,tran_hires,thermk,extkb,extkd,ssun_hires,ssha_hires) + + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, alb(1,1), alb(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, alb(1,2), alb(2,2)) + + CALL calculate_wgt_variable(ssun_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, ssun(1,1), ssun(2,1)) + CALL calculate_wgt_variable(ssun_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, ssun(1,2), ssun(2,2)) + + CALL calculate_wgt_variable(ssha_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, ssha(1,1), ssha(2,1)) + CALL calculate_wgt_variable(ssha_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, ssha(1,2), ssha(2,2)) + + alb_hires(:,:) = albv_hires(:,:) + + ! ! two-band albedo + ! CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + ! czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + !albv(:,:) = (1.- wt)*albv(:,:) + wt*albsno(:,:) + !alb (:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) + + ! alb(:,:) = albv(:,:) + +#endif + ELSE !other patchtypes (/=0) + CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + !albv(:,:) = (1.- wt)*albv(:,:) + wt*albsno(:,:) + !alb (:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) + alb(:,:) = albv(:,:) + + alb_hires(1:29 ,1) = albv_hires(1,1) + alb_hires(30:211,1) = albv_hires(2,1) + alb_hires(1:29 ,2) = albv_hires(1,2) + alb_hires(30:211,2) = albv_hires(2,2) + + tran_hires(1:29 ,1) = tran(1,1) + tran_hires(30:211,1) = tran(2,1) + tran_hires(1:29 ,2) = tran(1,2) + tran_hires(30:211,2) = tran(2,2) + tran_hires(1:29 ,3) = tran(1,3) + tran_hires(30:211,3) = tran(2,3) + ENDIF + ENDIF + + + IF (patchtype == 0) THEN + +#ifdef LULC_IGBP_PFT + CALL twostream_hires_wrap (ipatch, czen, albg_hires, & + albv_hires, tran_hires, ssun_hires, ssha_hires, & + reflectance, transmittance, & + fsds_vis_dir_frac, fsds_nir_dir_frac, & + fsds_vis_dif_frac, fsds_nir_dif_frac, & + ssw, reflectance_out, transmittance_out, doy) + + ! convert alb(:,:) = albv(:,:) -> hyperspectral + CALL calculate_wgt_variable(albv_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, alb(1,1), alb(2,1)) + CALL calculate_wgt_variable(albv_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, alb(1,2), alb(2,2)) + + alb_hires(:,:) = albv_hires(:,:) +#endif + +#ifdef LULC_IGBP_PC + !NOTE: if patchclass is CROPLAND, using twostream model + IF (patchclass(ipatch) == CROPLAND) THEN + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) + ELSE + CALL ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) + ENDIF +#endif + ENDIF + + ! treat soil/snow albedo in direct and diffuse respectively + CALL calculate_wgt_variable((tran_hires(:,1)*(1.-albsoi_hires(:,2)) + tran_hires(:,3)*(1.-albsoi_hires(:,1))), fsds_vis_dir_frac, fsds_nir_dir_frac, ssoi(1,1), ssoi(2,1)) + CALL calculate_wgt_variable((tran_hires(:,2)*(1.-albsoi_hires(:,2))), fsds_vis_dif_frac, fsds_nir_dif_frac, ssoi(1,2), ssoi(2,2)) + + CALL calculate_wgt_variable((tran_hires(:,1)*(1.-alb_sno_hires(:,2)) + tran_hires(:,3)*(1.-alb_sno_hires(:,1))), fsds_vis_dir_frac, fsds_nir_dir_frac, ssno(1,1), ssno(2,1)) + CALL calculate_wgt_variable((tran_hires(:,2)*(1.-alb_sno_hires(:,2))), fsds_vis_dif_frac, fsds_nir_dif_frac, ssno(1,2), ssno(2,2)) + +!----------------------------------------------------------------------- + + END SUBROUTINE albland_HiRes + + + SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! calculation of canopy albedos via two stream approximation (direct +! and diffuse ) and partition of incident solar +! +! Original author: Yongjiu Dai, June 11, 2001 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(2,2), &! (integral of i_up*exp(-kx) ) + edown(2,2) ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band iterator + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + proj = phi1 + phi2 * coszen + extkb = proj / coszen + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + +#if(defined LULC_USGS) + ! yuan: to be consistance with CoLM2014, no stem considered + ! for twostream and leaf optical property calculations + sai_ = 0. +#else + sai_ = sai +#endif + + lsai = lai + sai_ + power3 = (lai+sai) / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + IF (lsai <= 1e-6) RETURN + + DO iw = 1, 2 ! WAVE_BAND_LOOP + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! account for stem optical property effects + scat = lai/lsai * ( tau(iw,1) + rho(iw,1) ) & + + sai_/lsai * ( tau(iw,2) + rho(iw,2) ) + + as = scat / 2. * proj / ( proj + coszen * phi2 ) + as = as * ( 1. - coszen * phi1 / ( proj + coszen * phi2 ) * & + log ( ( proj + coszen * phi2 + coszen * phi1 ) / ( coszen * phi1 ) ) ) + +! account for stem optical property effects + !TODO-done: betao -> beta0 + upscat = lai/lsai*tau(iw,1) + sai_/lsai*tau(iw,2) + ! 09/12/2014, yuan: a bug, change 1. - chil -> 1. + chil + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albg(iw,2)*p1/ce + f2 = 1. - albg(iw,2)*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albg(iw,1) - ( hh1 - albg(iw,2) * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = hh1 + hh2 + hh3 + tran(iw,1) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup(iw,1) = hh1 * (1. - s2*s2) / (2.*extkb) & + + hh2 * (1. - s1*s2) / (extkb + psi) & + + hh3 * (1. - s2/s1) / (extkb - psi) + + edown(iw,1) = hh4 * (1. - s2*s2) / (2.*extkb) & + + hh5 * (1. - s1*s2) / (extkb + psi) & + + hh6 * (1. - s2/s1) / (extkb - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (2.*extkb) ) * s2 & + + albg(iw,2) / ce * ( - h1 / (2.*extkb) / zmu2 * & + ( p3*lsai + p4 / (2.*extkb) ) - de ) * s2 & + + albg(iw,1) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / (4.*extkb*extkb) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = - h1 / (2.*extkb*zmu2) + hh2 + hh3 + tran(iw,1) = 1./ce * ( -h1/(2.*extkb*zmu2) * (p3*lsai + p4/(2.*extkb)) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup(iw,1) = (hh2 - h1/(2.*extkb*zmu2)) * (1. - s2*s2) / (2.*extkb) & + + hh3 * (lsai - 0.) & + + h1/(2.*extkb*zmu2) * ( lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + edown(iw,1) = (hh5 - (h1*p4/(4.*extkb*extkb*zmu) + de)/ce) * (1. - s2*s2)/(2.*extkb) & + + hh6 * (lsai - 0.) & + + h1*p3/(ce*4.*extkb*extkb*zmu2) * (lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + ENDIF + + ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) + ssha(iw,1) = scat * (1.-s2) & + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + +!----------------------------------------------------------------------- +! calculation of diffuse albedos and canopy transmittances +! albv(iw,2) ( i-up ) +! tran(iw,2) ( i-down ) +!----------------------------------------------------------------------- + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = 0. + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1. + + hh7 = -m2 / (m1*n2 - m2*n1) + hh8 = -m1 / (m2*n1 - m1*n2) + + hh9 = hh7 * p1 / ce + hh10 = hh8 * p2 / ce + + albv(iw,2) = hh7 + hh8 + tran(iw,2) = hh9 * s1 + hh10 / s1 + + IF (abs(sigma) .gt. 1.e-10) THEN + eup(iw,2) = hh7 * (1. - s1*s2) / (extkb + psi) & + + hh8 * (1. - s2/s1) / (extkb - psi) + edown(iw,2) = hh9 * (1. - s1*s2) / (extkb + psi) & + + hh10 * (1. - s2/s1) / (extkb - psi) + ELSE + eup(iw,2) = hh7 * (1. - s1*s2) / ( extkb + psi) + hh8 * (lsai - 0.) + edown(iw,2) = hh9 * (1. - s1*s2) / ( extkb + psi) + hh10 * (lsai - 0.) + ENDIF + + ssun(iw,2) = (1.-scat) / zmu * (eup(iw,2) + edown(iw,2)) + ssha(iw,2) = tran(iw,2) * ( albg(iw,2) -1. ) - ( albv(iw,2) - 1. ) & + - ( 1. - scat ) / zmu * ( eup(iw,2) + edown(iw,2) ) + + ENDDO ! WAVE_BAND_LOOP + +! 03/06/2020, yuan: add direct transmittance (s2) to +! tran for incident direct case +! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + + END SUBROUTINE twostream + + SUBROUTINE twostream_hires ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! calculation of canopy albedos via two stream approximation (direct +! and diffuse ) and partition of incident solar +! +! Original author: Yongjiu Dai, June 11, 2001 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(211,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(211,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(211,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(211,2), &! albedo, vegetation [-] + tran(211,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(211,2), &! sunlit canopy absorption for solar radiation + ssha(211,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(211,2), &! (integral of i_up*exp(-kx) ) + edown(211,2) ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band iterator + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + proj = phi1 + phi2 * coszen + extkb = proj / coszen + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + +#if(defined LULC_USGS) + ! yuan: to be consistance with CoLM2014, no stem considered + ! for twostream and leaf optical property calculations + sai_ = 0. +#else + sai_ = sai +#endif + + lsai = lai + sai_ + power3 = (lai+sai) / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + IF (lsai <= 1e-6) RETURN + + DO iw = 1, 211 ! WAVE_BAND_LOOP ! loop from 1 to 211 + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! account for stem optical property effects + scat = lai/lsai * ( tau(iw,1) + rho(iw,1) ) & + + sai_/lsai * ( tau(iw,2) + rho(iw,2) ) + + as = scat / 2. * proj / ( proj + coszen * phi2 ) + as = as * ( 1. - coszen * phi1 / ( proj + coszen * phi2 ) * & + log ( ( proj + coszen * phi2 + coszen * phi1 ) / ( coszen * phi1 ) ) ) + +! account for stem optical property effects + !TODO-done: betao -> beta0 + upscat = lai/lsai*tau(iw,1) + sai_/lsai*tau(iw,2) + ! 09/12/2014, yuan: a bug, change 1. - chil -> 1. + chil + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albg(iw,2)*p1/ce + f2 = 1. - albg(iw,2)*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albg(iw,1) - ( hh1 - albg(iw,2) * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = hh1 + hh2 + hh3 + tran(iw,1) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup(iw,1) = hh1 * (1. - s2*s2) / (2.*extkb) & + + hh2 * (1. - s1*s2) / (extkb + psi) & + + hh3 * (1. - s2/s1) / (extkb - psi) + + edown(iw,1) = hh4 * (1. - s2*s2) / (2.*extkb) & + + hh5 * (1. - s1*s2) / (extkb + psi) & + + hh6 * (1. - s2/s1) / (extkb - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (2.*extkb) ) * s2 & + + albg(iw,2) / ce * ( - h1 / (2.*extkb) / zmu2 * & + ( p3*lsai + p4 / (2.*extkb) ) - de ) * s2 & + + albg(iw,1) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / (4.*extkb*extkb) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = - h1 / (2.*extkb*zmu2) + hh2 + hh3 + tran(iw,1) = 1./ce * ( -h1/(2.*extkb*zmu2) * (p3*lsai + p4/(2.*extkb)) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup(iw,1) = (hh2 - h1/(2.*extkb*zmu2)) * (1. - s2*s2) / (2.*extkb) & + + hh3 * (lsai - 0.) & + + h1/(2.*extkb*zmu2) * ( lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + edown(iw,1) = (hh5 - (h1*p4/(4.*extkb*extkb*zmu) + de)/ce) * (1. - s2*s2)/(2.*extkb) & + + hh6 * (lsai - 0.) & + + h1*p3/(ce*4.*extkb*extkb*zmu2) * (lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + ENDIF + + ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) + ssha(iw,1) = scat * (1.-s2) & + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + +!----------------------------------------------------------------------- +! calculation of diffuse albedos and canopy transmittances +! albv(iw,2) ( i-up ) +! tran(iw,2) ( i-down ) +!----------------------------------------------------------------------- + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = 0. + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1. + + hh7 = -m2 / (m1*n2 - m2*n1) + hh8 = -m1 / (m2*n1 - m1*n2) + + hh9 = hh7 * p1 / ce + hh10 = hh8 * p2 / ce + + albv(iw,2) = hh7 + hh8 + tran(iw,2) = hh9 * s1 + hh10 / s1 + + IF (abs(sigma) .gt. 1.e-10) THEN + eup(iw,2) = hh7 * (1. - s1*s2) / (extkb + psi) & + + hh8 * (1. - s2/s1) / (extkb - psi) + edown(iw,2) = hh9 * (1. - s1*s2) / (extkb + psi) & + + hh10 * (1. - s2/s1) / (extkb - psi) + ELSE + eup(iw,2) = hh7 * (1. - s1*s2) / ( extkb + psi) + hh8 * (lsai - 0.) + edown(iw,2) = hh9 * (1. - s1*s2) / ( extkb + psi) + hh10 * (lsai - 0.) + ENDIF + + ssun(iw,2) = (1.-scat) / zmu * (eup(iw,2) + edown(iw,2)) + ssha(iw,2) = tran(iw,2) * ( albg(iw,2) -1. ) - ( albv(iw,2) - 1. ) & + - ( 1. - scat ) / zmu * ( eup(iw,2) + edown(iw,2) ) + + ENDDO ! WAVE_BAND_LOOP + +! 03/06/2020, yuan: add direct transmittance (s2) to +! tran for incident direct case +! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + + END SUBROUTINE twostream_hires + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! An improved two stream approximation +! +! Original author: Yongjiu Dai, June 11, 2001 +! Hua Yuan, 03/2020 +! +! REFERENCES: +! 1) Yuan, H., Dai, Y., Dickinson, R. E., Pinty, B., Shangguan, W., Zhang, S., +! et al. (2017). Reexamination and further development of two-stream canopy +! radiative transfer models for global land modeling. Journal of Advances in +! Modeling Earth Systems, 9(1), 113–129. https://doi.org/10.1002/2016MS000773 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band loop index + integer ic ! direct/diffuse loop index + + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + + lsai = lai + sai + power3 = lsai / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + tmptau = 0.5_r8 * lsai + cosdif = - tmptau / log(exp(-0.87_r8*tmptau) / (1+0.92_r8*tmptau)) + + ! black ground case + albgblk = 1.e-6_r8 + + DO iw = 1, 2 ! WAVE_BAND_LOOP + + ! ic 1: incident direct; 2: incident diffuse + DO ic = 1, 2 + + IF (ic == 2) THEN + cosz = max(0.001_r8, cosdif) + theta = acos(cosz) + theta = theta/3.14159*180 + + theta = theta + chil*5._r8 + cosz = cos(theta/180*3.14159) + ELSE + cosz = coszen + ENDIF + + proj = phi1 + phi2 * cosz + extkb = proj / cosz + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! + stem optical properties + wtau = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + wrho = lai/lsai*rho(iw,1) + sai/lsai*rho(iw,2) + + scat = wtau + wrho + + as = scat / 2. * proj / ( proj + cosz * phi2 ) + as = as * ( 1. - cosz * phi1 / ( proj + cosz * phi2 ) * & + log ( ( proj + cosz * phi2 + cosz * phi1 ) / ( cosz * phi1 ) ) ) + +! + stem optical properties + ! scat ~ omega + ! upscat ~ betail*scat + ! beta0 ~ betadl + ! scat-2.*upscat ~ rho - tau + upscat = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + + ! [MODI 1] + beta0 = 0.5_r8 * ( scat + 1._r8/extkb*(1._r8+chil)**2/4._r8*(wrho-wtau) )/scat + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albgblk*p1/ce + f2 = 1. - albgblk*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (ic == 1) THEN + s2d = s2 + extkbd = extkb + ENDIF + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albgblk - ( hh1 - albgblk * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = hh1 + hh2 + hh3 + tran(iw,ic) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup = hh1 * (1. - s2*s2d) / (extkbd + extkb) & + + hh2 * (1. - s2d*s1) / (extkbd + psi) & + + hh3 * (1. - s2d/s1) / (extkbd - psi) + + edw = hh4 * (1. - s2*s2d) / (extkbd + extkb) & + + hh5 * (1. - s2d*s1) / (extkbd + psi) & + + hh6 * (1. - s2d/s1) / (extkbd - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (extkb+extkbd) ) * s2 & + + albgblk / ce * ( - h1 / (extkb+extkbd) / zmu2 * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + albgblk * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / ((extkb+extkbd)*(extkb+extkbd)) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = - h1 / ((extkb+extkbd)*zmu2) + hh2 + hh3 + tran(iw,ic) = 1./ce * ( -h1 / ((extkb+extkbd)*zmu2) * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup = (hh2 - h1/((extkb+extkbd)*zmu2)) * (1. - s2*s2d)/(extkb+extkbd) & + + hh3 * (lsai - 0.) & + + h1/((extkb+extkbd)*zmu2) * ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + edw = (hh5 - (h1*p4/((extkb+extkbd)*(extkb+extkbd)*zmu) + de)/ce) * & + (1. - s2*s2d) / (extkb+extkbd) + hh6 * (lsai - 0.) & + + h1*p3/(ce*(extkb+extkbd)*(extkb+extkbd)*zmu2) * & + ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + ENDIF + + sall(iw,ic) = 1. - albv(iw,ic) - (1.-albgblk)*(tran(iw,ic)+s2) + + IF (ic == 1) THEN + ssun(iw,ic) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup + edw) ) + ELSE + ssun(iw,ic) = (1.-scat) * ( extkb*(1.-s2*s2d)/(extkb+extkbd) + 1. / zmu * (eup + edw) ) + ENDIF + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ENDDO ! ic + + ! for reversed diffuse radiation back from ground + eup = hh1 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh2 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh3 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + edw = hh4 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh5 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh6 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + ssun_rev = s2d * (1._r8 - scat) * & + ( extkb*(1._r8-s2/s2d)/(extkb-extkbd) + 1._r8 / zmu * (eup + edw ) ) + + ! ----------------------------------------------------------- + ! consider the multiple reflectance between canopy and ground + ! ----------------------------------------------------------- + + ! common ratio for geometric series + q = albg(iw,2) * albv(iw,2) + + DO ic = 1, 2 ! from 1 to 2, cannot be reversed + + ! ----------------------------------------------------------- + ! re-calculate the absorption, transmission and albedo + ! for direct radiation + +! 03/06/2020, yuan: tran originally meant diffuse flow, now the direct +! transmittance is also included +! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases + IF (ic == 1) THEN + tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d + + sall(iw,ic) = sall(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) + + albv(iw,ic) = 1. - sall(iw,ic) - & + (1.-albg(iw,2))*tran(iw,ic) - (1.-albg(iw,1))*s2d + + ssun(iw,ic) = ssun(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * ssun_rev + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ELSE + tran(iw,ic) = (s2 + tran(iw,ic)) / (1.-q) + + sall(iw,ic) = sall(iw,ic) + tran(iw,ic)*albg(iw,2)*sall(iw,2) + albv(iw,ic) = 1. - sall(iw,ic) - (1.-albg(iw,2))*tran(iw,ic) + + ssun(iw,ic) = ssun(iw,ic) + tran(iw,ic)*albg(iw,2)*ssun_rev + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + ENDIF + + ENDDO !ic + + End DO !iw + + ! restore extkb + extkb = extkbd + + END SUBROUTINE twostream_mod + + + SUBROUTINE twostream_hires_mod ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! An improved two stream approximation +! +! Original author: Yongjiu Dai, June 11, 2001 +! Hua Yuan, 03/2020 +! +! REFERENCES: +! 1) Yuan, H., Dai, Y., Dickinson, R. E., Pinty, B., Shangguan, W., Zhang, S., +! et al. (2017). Reexamination and further development of two-stream canopy +! radiative transfer models for global land modeling. Journal of Advances in +! Modeling Earth Systems, 9(1), 113–129. https://doi.org/10.1002/2016MS000773 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(211,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(211,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(211,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(211,2), &! albedo, vegetation [-] + tran(211,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(211,2), &! sunlit canopy absorption for solar radiation + ssha(211,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + real(r8) :: scat_sno_tmp + + integer iw ! band loop index + integer ic ! direct/diffuse loop index + + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(211,2), q, ssun_rev + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + + lsai = lai + sai + power3 = lsai / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + tmptau = 0.5_r8 * lsai + cosdif = - tmptau / log(exp(-0.87_r8*tmptau) / (1+0.92_r8*tmptau)) + + ! black ground case + albgblk = 1.e-6_r8 + + DO iw = 1, 211 ! WAVE_BAND_LOOP + + ! ic 1: incident direct; 2: incident diffuse + DO ic = 1, 2 + + IF (ic == 2) THEN + cosz = max(0.001_r8, cosdif) + theta = acos(cosz) + theta = theta/3.14159*180 + + theta = theta + chil*5._r8 + cosz = cos(theta/180*3.14159) + ELSE + cosz = coszen + ENDIF + + proj = phi1 + phi2 * cosz + extkb = proj / cosz + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! + stem optical properties + wtau = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + wrho = lai/lsai*rho(iw,1) + sai/lsai*rho(iw,2) + + scat = wtau + wrho + + as = scat / 2. * proj / ( proj + cosz * phi2 ) + as = as * ( 1. - cosz * phi1 / ( proj + cosz * phi2 ) * & + log ( ( proj + cosz * phi2 + cosz * phi1 ) / ( cosz * phi1 ) ) ) + +! + stem optical properties + ! scat ~ omega + ! upscat ~ betail*scat + ! beta0 ~ betadl + ! scat-2.*upscat ~ rho - tau + upscat = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + + ! [MODI 1] + beta0 = 0.5_r8 * ( scat + 1._r8/extkb*(1._r8+chil)**2/4._r8*(wrho-wtau) )/scat + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + if (iw < 30) then + scat_sno_tmp = scat_sno(1) + else + scat_sno_tmp = scat_sno(2) + end if + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno_tmp + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno_tmp*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno_tmp*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albgblk*p1/ce + f2 = 1. - albgblk*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (ic == 1) THEN + s2d = s2 + extkbd = extkb + ENDIF + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albgblk - ( hh1 - albgblk * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = hh1 + hh2 + hh3 + tran(iw,ic) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup = hh1 * (1. - s2*s2d) / (extkbd + extkb) & + + hh2 * (1. - s2d*s1) / (extkbd + psi) & + + hh3 * (1. - s2d/s1) / (extkbd - psi) + + edw = hh4 * (1. - s2*s2d) / (extkbd + extkb) & + + hh5 * (1. - s2d*s1) / (extkbd + psi) & + + hh6 * (1. - s2d/s1) / (extkbd - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (extkb+extkbd) ) * s2 & + + albgblk / ce * ( - h1 / (extkb+extkbd) / zmu2 * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + albgblk * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / ((extkb+extkbd)*(extkb+extkbd)) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = - h1 / ((extkb+extkbd)*zmu2) + hh2 + hh3 + tran(iw,ic) = 1./ce * ( -h1 / ((extkb+extkbd)*zmu2) * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup = (hh2 - h1/((extkb+extkbd)*zmu2)) * (1. - s2*s2d)/(extkb+extkbd) & + + hh3 * (lsai - 0.) & + + h1/((extkb+extkbd)*zmu2) * ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + edw = (hh5 - (h1*p4/((extkb+extkbd)*(extkb+extkbd)*zmu) + de)/ce) * & + (1. - s2*s2d) / (extkb+extkbd) + hh6 * (lsai - 0.) & + + h1*p3/(ce*(extkb+extkbd)*(extkb+extkbd)*zmu2) * & + ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + ENDIF + + sall(iw,ic) = 1. - albv(iw,ic) - (1.-albgblk)*(tran(iw,ic)+s2) + + IF (ic == 1) THEN + ssun(iw,ic) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup + edw) ) + ELSE + ssun(iw,ic) = (1.-scat) * ( extkb*(1.-s2*s2d)/(extkb+extkbd) + 1. / zmu * (eup + edw) ) + ENDIF + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ENDDO ! ic + + ! for reversed diffuse radiation back from ground + eup = hh1 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh2 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh3 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + edw = hh4 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh5 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh6 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + ssun_rev = s2d * (1._r8 - scat) * & + ( extkb*(1._r8-s2/s2d)/(extkb-extkbd) + 1._r8 / zmu * (eup + edw ) ) + + ! ----------------------------------------------------------- + ! consider the multiple reflectance between canopy and ground + ! ----------------------------------------------------------- + + ! common ratio for geometric series + q = albg(iw,2) * albv(iw,2) + + DO ic = 1, 2 ! from 1 to 2, cannot be reversed + + ! ----------------------------------------------------------- + ! re-calculate the absorption, transmission and albedo + ! for direct radiation + +! 03/06/2020, yuan: tran originally meant diffuse flow, now the direct +! transmittance is also included +! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases + IF (ic == 1) THEN + tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d + + sall(iw,ic) = sall(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) + + albv(iw,ic) = 1. - sall(iw,ic) - & + (1.-albg(iw,2))*tran(iw,ic) - (1.-albg(iw,1))*s2d + + ssun(iw,ic) = ssun(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * ssun_rev + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ELSE + tran(iw,ic) = (s2 + tran(iw,ic)) / (1.-q) + + sall(iw,ic) = sall(iw,ic) + tran(iw,ic)*albg(iw,2)*sall(iw,2) + albv(iw,ic) = 1. - sall(iw,ic) - (1.-albg(iw,2))*tran(iw,ic) + + ssun(iw,ic) = ssun(iw,ic) + tran(iw,ic)*albg(iw,2)*ssun_rev + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + ENDIF + + ENDDO !ic + + End DO !iw + + ! restore extkb + extkb = extkbd + + END SUBROUTINE twostream_hires_mod +#endif + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! A Wrap subroutine to calculate PFT radiation using two-stream model +! +! Created by Hua Yuan, 03/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + IMPLICIT NONE + + ! parameters + integer, intent(in) :: & + ipatch ! patch index + + ! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + + ! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + + integer :: i, p, ps, pe + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( tran_p (2,3,ps:pe) ) + allocate ( albv_p (2,2,ps:pe) ) + + DO i = ps, pe + p = pftclass(i) + IF (lai_p(i)+sai_p(i) > 1.e-6) THEN + CALL twostream_mod (chil_p(p),rho_p(:,:,p),tau_p(:,:,p),1.,lai_p(i),sai_p(i),& + fwet_snow_p(i),coszen,albg,albv_p(:,:,i),tran_p(:,:,i),thermk_p(i),& + extkb_p(i),extkd_p(i),ssun_p(:,:,i),ssha_p(:,:,i)) + ELSE + albv_p(:,:,i) = albg(:,:) + ssun_p(:,:,i) = 0. + ssha_p(:,:,i) = 0. + tran_p(:,1,i) = 0. + tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. + ENDIF + ENDDO + + albv(1,1) = sum( albv_p(1,1,ps:pe)*pftfrac(ps:pe) ) + albv(1,2) = sum( albv_p(1,2,ps:pe)*pftfrac(ps:pe) ) + albv(2,1) = sum( albv_p(2,1,ps:pe)*pftfrac(ps:pe) ) + albv(2,2) = sum( albv_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + tran(1,1) = sum( tran_p(1,1,ps:pe)*pftfrac(ps:pe) ) + tran(1,2) = sum( tran_p(1,2,ps:pe)*pftfrac(ps:pe) ) + tran(1,3) = sum( tran_p(1,3,ps:pe)*pftfrac(ps:pe) ) + tran(2,1) = sum( tran_p(2,1,ps:pe)*pftfrac(ps:pe) ) + tran(2,2) = sum( tran_p(2,2,ps:pe)*pftfrac(ps:pe) ) + tran(2,3) = sum( tran_p(2,3,ps:pe)*pftfrac(ps:pe) ) + + !NOTE: fordebug only below + IF (ssun(1,1)<0 .or. ssun(1,2)<0 .or. ssun(2,1)<0 .or. ssun(2,2)<0) THEN + print *, 'Warning:negative albedo',ipatch + print *, ssun + ENDIF + + deallocate ( tran_p ) + deallocate ( albv_p ) + + END SUBROUTINE twostream_wrap + + SUBROUTINE twostream_hires_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha, & + reflectance, transmittance ,& + fsds_vis_dir_frac, fsds_nir_dir_frac,& + fsds_vis_dif_frac, fsds_nir_dif_frac,& + ssw, reflectance_out, transmittance_out, doy ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! A Wrap subroutine to calculate PFT radiation using two-stream model +! +! Created by Hua Yuan, 03/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_HighRes_Parameters , only: update_params_PROSPECT!, satellite_PROSPECT + USE MOD_Namelist, only: DEF_HighResVeg, DEF_PROSPECT!, DEF_Satellite_Params + + IMPLICIT NONE + + ! parameters + integer, intent(in) :: & + ipatch, &! patch index + doy + + ! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(211,2) ! albedos of ground + + ! high resolution optical properties + real(r8), intent(in) :: & + reflectance (0:15,211,2), &! leaf reflectance + transmittance(0:15,211,2), &! leaf transmittance + fsds_vis_dir_frac(29 ) ,& + fsds_nir_dir_frac(182) ,& + fsds_vis_dif_frac(29 ) ,& + fsds_nir_dif_frac(182) ,& + ssw + + ! output + real(r8), intent(out) :: & + albv(211,2), &! albedo, vegetation [-] + tran(211,3), &! canopy transmittances for solar radiation + ssun(211,2), &! sunlit canopy absorption for solar radiation + ssha(211,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + + real(r8), intent(inout) :: & + reflectance_out (211,0:15), &! leaf reflectance + transmittance_out(211,0:15) ! leaf transmittance + + integer :: i, p, ps, pe, iwl + real(r8) :: reflectance_p (211, 2) + real(r8) :: transmittance_p(211, 2) + + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) + + real(r8) :: rho_hires(211), tau_hires(211) + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( tran_p (211,3,ps:pe) ) + allocate ( albv_p (211,2,ps:pe) ) + + DO i = ps, pe + p = pftclass(i) + IF (lai_p(i)+sai_p(i) > 1.e-6) THEN + + ! IF use PROSPECT, update the high resolution optical properties + ! IF ( DEF_PROSPECT .AND. DEF_Satellite_Params ) THEN + ! CALL satellite_PROSPECT(p, reflectance, transmittance ,& + ! reflectance_p, transmittance_p,& + ! ssw, doy) + ! ELSE IF ( DEF_PROSPECT ) THEN + IF ( DEF_PROSPECT ) THEN + CALL update_params_PROSPECT(p, reflectance, transmittance ,& + reflectance_p, transmittance_p,& + ssw) + ELSE + reflectance_p = reflectance (p,:,:) + transmittance_p = transmittance(p,:,:) + ENDIF + + reflectance_out (:,p) = reflectance_p (:,1) + transmittance_out(:,p) = transmittance_p(:,1) + + CALL twostream_hires_mod (chil_p(p),reflectance_p,transmittance_p,1.,lai_p(i),sai_p(i),& + fwet_snow_p(i),coszen,albg,albv_p(:,:,i),tran_p(:,:,i),thermk_p(i),& + extkb_p(i),extkd_p(i),ssun_hires_p(:,:,i),ssha_hires_p(:,:,i)) + + CALL calculate_wgt_variable(ssun_hires_p(:,1,i), fsds_vis_dir_frac, fsds_nir_dir_frac, ssun_p(1,1,i), ssun_p(2,1,i)) + CALL calculate_wgt_variable(ssun_hires_p(:,2,i), fsds_vis_dif_frac, fsds_nir_dif_frac, ssun_p(1,2,i), ssun_p(2,2,i)) + + CALL calculate_wgt_variable(ssha_hires_p(:,1,i), fsds_vis_dir_frac, fsds_nir_dir_frac, ssha_p(1,1,i), ssha_p(2,1,i)) + CALL calculate_wgt_variable(ssha_hires_p(:,2,i), fsds_vis_dif_frac, fsds_nir_dif_frac, ssha_p(1,2,i), ssha_p(2,2,i)) + + ELSE + albv_p(:,:,i) = albg(:,:) + + ssun_hires_p(:,:,i) = 0. + ssha_hires_p(:,:,i) = 0. + + ssun_p(:,:,i) = 0. + ssha_p(:,:,i) = 0. + tran_p(:,1,i) = 0. + tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. + ENDIF + ENDDO + + DO iwl = 1, 211 + albv(iwl,1) = SUM( albv_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + albv(iwl,2) = SUM( albv_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + + ssun(iwl,1) = sum( ssun_hires_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + ssun(iwl,2) = sum( ssun_hires_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(iwl,1) = sum( ssha_hires_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + ssha(iwl,2) = sum( ssha_hires_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + + tran(iwl,1) = sum( tran_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + tran(iwl,2) = sum( tran_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + tran(iwl,3) = sum( tran_p(iwl,3,ps:pe)*pftfrac(ps:pe) ) + END DO + + !NOTE: fordebug only below + IF ( ANY(ssun < 0) ) THEN + print *, 'Warning:negative albedo',ipatch + print *, ssun + ENDIF + + deallocate ( tran_p ) + deallocate ( albv_p ) + + END SUBROUTINE twostream_hires_wrap +#endif + + + SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) + +!======================================================================= +! Original version: Robert Dickinson +! Update snow cover and snow age, based on BATS code +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz + IMPLICIT NONE + +!-------------------------- Dummy Argument ----------------------------- + + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(in) :: tg ! temperature of soil at surface [K] + real(r8), intent(in) :: scv ! snow cover, water equivalent [mm] + real(r8), intent(in) :: scvold ! snow cover for previous time step [mm] + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + +!-------------------------- Local variables ---------------------------- + + real(r8) :: age1 ! snow aging factor due to crystal growth [-] + real(r8) :: age2 ! snow aging factor due to surface growth [-] + real(r8) :: age3 ! snow aging factor due to accum of other particles [-] + real(r8) :: arg ! temporary variable used in snow age calculation [-] + real(r8) :: arg2 ! temporary variable used in snow age calculation [-] + real(r8) :: dela ! temporary variable used in snow age calculation [-] + real(r8) :: dels ! temporary variable used in snow age calculation [-] + real(r8) :: sge ! temporary variable used in snow age calculation [-] + +!----------------------------------------------------------------------- + IF(scv <= 0.) THEN + sag = 0. +! +! Over antarctica +! + ELSE IF (scv > 800.) THEN + sag = 0. +! +! Away from antarctica +! + ELSE + age3 = 0.3 + arg = 5.e3*(1./tfrz-1./tg) + arg2 = min(0.,10.*arg) + age2 = exp(arg2) + age1 = exp(arg) + dela = 1.e-6*deltim*(age1+age2+age3) + dels = 0.1*max(0.0,scv-scvold) + sge = (sag+dela)*(1.0-dels) + sag = max(0.0,sge) + ENDIF + + END SUBROUTINE snowage + + + SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& + albsod ,albsoi ,snl ,frac_sno ,& + h2osno ,h2osno_liq ,h2osno_ice ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + albgrd ,albgri ,albgrd_pur ,albgri_pur ,& + albgrd_bc ,albgri_bc ,albgrd_oc ,albgri_oc ,& + albgrd_dst ,albgri_dst ,flx_absdv ,flx_absdn ,& + flx_absiv ,flx_absin ,dir_frac ,dif_frac ) + + ! !DESCRIPTION: + ! The calling sequence is: + ! -> SNICAR_RT: snow albedos: direct beam (SNICAR) + ! or + ! SNICAR_AD_RT: snow albedos: direct beam (SNICAR-AD) + ! -> SNICAR_RT: snow albedos: diffuse (SNICAR) + ! or + ! SNICAR_AD_RT: snow albedos: diffuse (SNICAR-AD) + ! + ! ORIGINAL: + ! 1) The Community Land Model version5.0 (CLM5.0) + ! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) + ! + ! REFERENCES: + ! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. + ! Geosci. Model Dev., 14, 7673–7704, https://doi.org/10.5194/gmd-14-7673-2021 + ! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) + ! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. + ! Geosci. Model Dev., 16, 75–94, https://doi.org/10.5194/gmd-16-75-2023 + ! + ! REVISIONS: + ! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING + + !----------------------------------------------------------------------- + ! !USES: + USE MOD_Vars_Global, only: maxsnl + USE MOD_SnowSnicar_HiRes, only: SNICAR_RT, SNICAR_AD_RT + + ! and the evolution of snow effective radius + ! + ! DAI, Dec. 28, 2022 + + IMPLICIT NONE + +!------------------------------------------------------------------------- +! temporay setting + + integer, parameter :: numrad = 5 ! number of solar radiation bands: vis, nir + integer, parameter :: numhires = 211 ! number of solar radiation bands: vis, nir + integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + logical, parameter :: DO_SNO_OC = .true. ! parameter to include organic carbon (OC) + logical, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes + ! + ! !ARGUMENTS: + ! + logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo + logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT + + real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle + real(r8), intent(in) :: albsod ( numhires ) ! direct-beam soil albedo (col,bnd) [frc] + real(r8), intent(in) :: albsoi ( numhires ) ! diffuse soil albedo (col,bnd) [frc] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] + real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] + + real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + + real(r8) , intent(in) :: dir_frac ( numhires ) ! + real(r8) , intent(in) :: dif_frac ( numhires ) ! + + real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) + real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) + real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) + real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) + real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) + real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) + real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) + real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) + real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) + real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) + real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): NIR [frc] + real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): NIR [frc] + + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + + integer :: i ! index for layers [idx] + integer :: ibnd, start_index, end_index ! index for 5 bands [idx] + integer :: aer ! index for sno_nbr_aer + integer :: ib ! band index + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) + integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) + + real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_bc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for BC forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_oc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for OC forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_dst (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for dust forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_fdb (maxsnl+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1] + + real(r8) :: albsfc (numrad) ! albedo of surface underneath snow (col,bnd) + real(r8) :: albsnd (numrad) ! snow albedo (direct) + real(r8) :: albsni (numrad) ! snow albedo (diffuse) + real(r8) :: albsnd_pur (numrad) ! direct pure snow albedo (radiative forcing) + real(r8) :: albsni_pur (numrad) ! diffuse pure snow albedo (radiative forcing) + real(r8) :: albsnd_bc (numrad) ! direct snow albedo without BC (radiative forcing) + real(r8) :: albsni_bc (numrad) ! diffuse snow albedo without BC (radiative forcing) + real(r8) :: albsnd_oc (numrad) ! direct snow albedo without OC (radiative forcing) + real(r8) :: albsni_oc (numrad) ! diffuse snow albedo without OC (radiative forcing) + real(r8) :: albsnd_dst (numrad) ! direct snow albedo without dust (radiative forcing) + real(r8) :: albsni_dst (numrad) ! diffuse snow albedo without dust (radiative forcing) + real(r8) :: flx_absd_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (direct) [frc] + real(r8) :: flx_absi_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (diffuse) [frc] + real(r8) :: foo_snw (maxsnl+1:1,numrad) ! dummy array for forcing calls + + integer :: snw_rds_in (maxsnl+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] + + integer , parameter :: nband =numrad ! number of solar radiation waveband classes + INTEGER, PARAMETER, DIMENSION(6) :: band_index = (/ & + 1, 30, 60, 80, 110, 212 &! 400, 700, 1000, 1200, 1500, 2500 nm + /) + + !----------------------------------------------------------------------- + + ! Initialize output because solar radiation only done IF coszen > 0 + + DO ib = 1, numrad + albgrd(ib) = 0._r8 + albgri(ib) = 0._r8 + albgrd_pur(ib) = 0._r8 + albgri_pur(ib) = 0._r8 + albgrd_bc(ib) = 0._r8 + albgri_bc(ib) = 0._r8 + albgrd_oc(ib) = 0._r8 + albgri_oc(ib) = 0._r8 + albgrd_dst(ib) = 0._r8 + albgri_dst(ib) = 0._r8 + DO i=maxsnl+1,1,1 + flx_absdv(i) = 0._r8 + flx_absdn(i) = 0._r8 + flx_absiv(i) = 0._r8 + flx_absin(i) = 0._r8 + ENDDO + ENDDO ! END of numrad loop + + ! set variables to pass to SNICAR. + + flg_snw_ice = 1 + + do ibnd = 1, 5 + start_index = band_index(ibnd) + end_index = band_index(ibnd+1) - 1 + + albsfc(ibnd) = SUM(albsoi (start_index:end_index) *& + dif_frac(start_index:end_index)) /& + SUM(dif_frac(start_index:end_index)) + end do + + snw_rds_in(:) = nint(snw_rds(:)) + + ! zero aerosol input arrays + DO aer = 1, sno_nbr_aer + DO i = maxsnl+1, 0 + mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 + mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 + mss_cnc_aer_in_fdb(i,aer) = 0._r8 + ENDDO + ENDDO + + ! If radiative forcing is being calculated, first estimate clean-snow albedo + + IF (use_snicar_frc) THEN + + ! 1. PURE SNOW ALBEDO CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 2. BC input array: + ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) + ENDIF + mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_bc(:,8) = mss_cnc_dst4(:) + + ! BC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 3. OC input array: + ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) + + mss_cnc_aer_in_frc_oc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_oc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_oc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_oc(:,8) = mss_cnc_dst4(:) + + ! OC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + ENDIF ! END IF (DO_SNO_OC) + + ! 4. DUST FORCING CALCULATIONS + ! DUST input array: + ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] + mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) + + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ENDIF !END IF use_snicar_frc + + + ! -------------------------------------------- + ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: + ! -------------------------------------------- + ! Set aerosol input arrays + ! feedback input arrays have been zeroed + ! set soot and dust aerosol concentrations: + IF (DO_SNO_AER) THEN + mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) + + ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: + ! 1) Knowledge of their optical properties is primitive + ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, + ! it has a negligible darkening effect. + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) + ENDIF + + mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + + ! ground albedos and snow-fraction weighting of snow absorption factors + DO ib = 1, nband + IF (coszen_col > 0._r8) THEN + ! ground albedo was originally computed in SoilAlbedo, but is now computed here + ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT was switched for SNICAR/SNICAR_AD_RT. + ! 09/01/2023, yuan: change to only snow albedo, the same below + !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno + !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + albgrd(ib) = albsnd(ib) + albgri(ib) = albsni(ib) + + ! albedos for radiative forcing calculations: + IF (use_snicar_frc) THEN + ! pure snow albedo for all-aerosol radiative forcing + !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno + !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + albgrd_pur(ib) = albsnd_pur(ib) + albgri_pur(ib) = albsni_pur(ib) + + ! BC forcing albedo + !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno + !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + albgrd_bc(ib) = albsnd_bc(ib) + albgri_bc(ib) = albsni_bc(ib) + + IF (DO_SNO_OC) THEN + ! OC forcing albedo + !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno + !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno + albgrd_oc(ib) = albsnd_oc(ib) + albgri_oc(ib) = albsni_oc(ib) + ENDIF + + ! dust forcing albedo + !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno + !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno + albgrd_dst(ib) = albsnd_dst(ib) + albgri_dst(ib) = albsni_dst(ib) + ENDIF + + ! also in this loop (but optionally in a different loop for vectorized code) + ! weight snow layer radiative absorption factors based on snow fraction and soil albedo + ! (NEEDED FOR ENERGY CONSERVATION) + DO i = maxsnl+1,1,1 + IF (subgridflag == 0 ) THEN + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + elseif (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ENDIF + ELSE + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absiv(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + elseif (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absin(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + END SUBROUTINE SnowAlbedo + + SUBROUTINE albocean (oro, scv, coszrs, alb) + +!----------------------------------------------------------------------- +! +! Compute surface albedos +! +! Computes surface albedos for direct/diffuse incident radiation for +! two spectral intervals: +! s = 0.2-0.7 micro-meters +! l = 0.7-5.0 micro-meters +! +! Albedos specified as follows: +! +! Ocean Uses solar zenith angle to compute albedo for direct +! radiation; diffuse radiation values constant; albedo +! independent of spectral interval and other physical +! factors such as ocean surface wind speed. +! +! Ocean with Surface albs specified; combined with overlying snow +! sea ice +! +! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! yongjiu dai and xin-zhong liang (08/01/2001) +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!------------------------------Arguments-------------------------------- + + real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag + real(r8), intent(in) :: scv ! snow water equivalent) [mm] + real(r8), intent(in) :: coszrs ! Cosine solar zenith angle + + real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms + ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms + +!---------------------------Local variables----------------------------- + + real(r8) frsnow ! horizontal fraction of snow cover + real(r8) snwhgt ! physical snow height + real(r8) rghsnw ! roughness for horizontal snow cover fractn + + real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms + real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms + real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms + real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms + + real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] + real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters + +!----------------------------------------------------------------------- +! initialize all ocean/sea ice surface albedos to zero + + alb(:,:) = 0. + IF(coszrs<=0.0) RETURN + + IF(nint(oro)==2)THEN + alb(1,1) = asices + alb(2,1) = asicel + alb(1,2) = alb(1,1) + alb(2,2) = alb(2,1) + sasdif = asnows + saldif = asnowl + + IF(scv>0.)THEN + IF (coszrs<0.5) THEN + ! zenith angle regime 1 ( coszrs < 0.5 ). + ! set direct snow albedos (limit to 0.98 max) + sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) + saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) + ELSE + ! zenith angle regime 2 ( coszrs >= 0.5 ) + sasdir = asnows + saldir = asnowl + ENDIF + + ! compute both diffuse and direct total albedos + snwhgt = 20.*scv / 1000. + rghsnw = 0.25 + frsnow = snwhgt/(rghsnw+snwhgt) + alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow + alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow + alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow + alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow + ENDIF + ENDIF + +! ice-free ocean albedos function of solar zenith angle only, and +! independent of spectral interval: + + IF(nint(oro)==0)THEN + alb(2,1) = .026/(coszrs**1.7+.065) & + + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) + alb(1,1) = alb(2,1) + alb(1,2) = 0.06 + alb(2,2) = 0.06 + ENDIF + + END SUBROUTINE albocean + + + pure function calculate_tav(alpha, nr) result(tav) + real(r8), intent(in) :: alpha + real(r8), dimension(211), intent(in) :: nr + real(r8) :: rd, n2(211), n_p(211), nm(211), a(211), k(211), sa + real(r8) :: b1(211), b2(211), b(211), b3(211), a3(211) + real(r8) :: ts(211), tp1(211), tp2(211), tp3(211), tp4(211), tp5(211), tp(211) + real(r8), dimension(211) :: tav + + rd = 3.141592653589793 / 180.0 + n2 = nr**2 + n_p = n2 + 1.0 + nm = n2 - 1.0 + a = (nr + 1.0) * (nr + 1.0) / 2.0 + k = -(n2 - 1.0) * (n2 - 1.0) / 4.0 + sa = sin(alpha * rd) + + b1 = 0.0 + if (alpha /= 90.0) then + b1 = sqrt((sa**2 - n_p / 2.0) * (sa**2 - n_p / 2.0) + k) + end if + + b2 = sa**2 - n_p / 2.0 + b = b1 - b2 + b3 = b**3 + a3 = a**3 + + ts = (k**2 / (6.0 * b3) + k / b - b / 2.0) - (k**2 / (6.0 * a3) + k / a - a / 2.0) + + tp1 = -2.0 * n2 * (b - a) / (n_p**2) + tp2 = -2.0 * n2 * n_p * log(b / a) / (nm**2) + tp3 = n2 * (1.0 / b - 1.0 / a) / 2.0 + tp4 = 16.0 * n2**2 * (n2**2 + 1.0) * log((2.0 * n_p * b - nm**2) / (2.0 * n_p * a - nm**2)) / (n_p**3 * nm**2) + tp5 = 16.0 * n2**3 * (1.0 / (2.0 * n_p * b - nm**2) - 1.0 / (2.0 * n_p * a - nm**2)) / n_p**3 + tp = tp1 + tp2 + tp3 + tp4 + tp5 + tav = (ts + tp) / (2.0 * sa**2) + + end function calculate_tav + + pure FUNCTION poisson_pmf(k, lambda) RESULT(pmf) + IMPLICIT NONE + INTEGER, INTENT(IN) :: k(:) + REAL(r8), INTENT(IN) :: lambda + REAL(r8) :: pmf(SIZE(k)) + INTEGER :: i + + DO i = 1, SIZE(k) + pmf(i) = EXP(-lambda) * lambda**REAL(k(i), KIND=r8) / FACTORIAL_R8( k(i) ) + END DO + + END FUNCTION poisson_pmf + + pure FUNCTION FACTORIAL_R8(k) RESULT(fact) + IMPLICIT NONE + INTEGER, INTENT(IN) :: k + INTEGER :: i + REAL(r8) :: fact + + fact = 1.0_r8 + IF (k <= 0) RETURN + DO i = 1, k + fact = fact * REAL(i, KIND=r8) + END DO + END FUNCTION FACTORIAL_R8 + + SUBROUTINE BSM_soil_moisture( & + ! input + soil_moisture, smc, albedo_dry, kw, nw, & + ! output + albedo_wet) + + IMPLICIT NONE + + ! Arguments + real(r8), intent(in) :: soil_moisture + real(r8), intent(in) :: smc + real(r8), intent(in) :: albedo_dry(211) + real(r8), intent(in) :: kw(211) + real(r8), intent(in) :: nw(211) + + real(r8), intent(out) :: albedo_wet(211, 2) + + ! Parameters + real(r8), parameter :: deleff = 0.0150 ! BSM soil model: film thickness not supplied, set to default of 0.015 m + + INTEGER, DIMENSION(7) :: k_arr = (/0, 1, 2, 3, 4, 5, 6/) + INTEGER :: nk, i + REAL(r8) :: mu + REAL(r8) :: rbac(211), p(211), Rw(211) + REAL(r8) :: fmul(7), tw(211, 7) + REAL(r8) :: Rwet_k(211, 7) + REAL(r8) :: kw_tmp(211, 7), numerator_tmp(211, 7), denominator_tmp(211, 7), dot_product_result(211) + + ! ===== Start of executable code ===== + nk = SIZE(k_arr) + + mu = (soil_moisture - 5.0) / smc + + IF (mu <= 0.0) THEN ! below 5 % SM -> model assumes no effect + albedo_wet(:, 1) = albedo_dry + albedo_wet(:, 2) = albedo_dry + ELSE + rbac = 1.0 - (1.0 - albedo_dry) * (albedo_dry * calculate_tav(90.0, 2.0 / nw) / calculate_tav(90.0, (/ (2.0, i = 1, 211) /)) + 1.0 - albedo_dry) + + p = 1.0 - calculate_tav(90.0, nw) / nw**2 + + Rw = 1.0 - calculate_tav(40.0, nw) + + fmul = poisson_pmf(k_arr, mu) + + do i = 1, nk + kw_tmp(:, i) = kw * k_arr(i) + tw(:, i) = exp(-2.0 * kw_tmp(:, i) * deleff) + + numerator_tmp(:, i) = Rw + (1.0 - Rw) * (1.0 - p) * tw(:, i) * rbac + denominator_tmp(:, i) = 1.0 - p * tw(:, i) * rbac + end do + + ! Rwet_k = Rw + (1.0 - Rw) * (1.0 - p) * tw * rbac / (1.0 - p * tw * rbac) + Rwet_k = numerator_tmp / denominator_tmp + + do i = 1, 211 + dot_product_result(i) = SUM(Rwet_k(i, 2:nk) * fmul(2:nk)) + end do + albedo_wet(:, 1) = (albedo_dry * fmul(1)) + dot_product_result + albedo_wet(:, 2) = albedo_wet(:, 1) + END IF + + END SUBROUTINE BSM_soil_moisture + + SUBROUTINE calculate_wgt_variable( variable, frac_vis, frac_nir, variable_vis, variable_nir ) + + ! Arguments + INTEGER, PARAMETER :: num_vis = 29 ! 400 - 690 nm + INTEGER, PARAMETER :: num_nir = 182 ! 700 - 2500 nm + + real(r8), intent(in) :: variable(211) + real(r8), intent(in) :: frac_vis(num_vis) + real(r8), intent(in) :: frac_nir(num_nir) + + real(r8), intent(out) :: variable_vis + real(r8), intent(out) :: variable_nir + + real(r8), parameter :: eps = 1.0e-12_r8 + real(r8) :: sum_vis, sum_nir + + sum_vis = SUM(frac_vis) + sum_nir = SUM(frac_nir) + + variable_vis = SUM(frac_vis * variable(1:num_vis)) / sum_vis + variable_nir = SUM(frac_nir * variable(num_vis+1:211)) / sum_nir + + END SUBROUTINE calculate_wgt_variable + +END MODULE MOD_Albedo_HiRes +#endif +! --------- EOP ---------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 new file mode 100644 index 0000000000..e4df0a565b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 @@ -0,0 +1,844 @@ +#include + +MODULE MOD_AssimStomataConductance + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: stomata + PUBLIC :: update_photosyn + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: sortin + PRIVATE :: calc_photo_params + PRIVATE :: WUE_solver + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE stomata (vmax25,effcon,c3c4,slti,hlti,shti, & + hhti,trda,trdm,trop,g1,g0,gradm,binter,tm, & + psrf,po2m,pco2m,pco2a,ea,ei,tlef,par, & +!Ozone stress variables + o3coefv,o3coefg, & +!End ozone stress variables +!WUE stomata model parameter + lambda, & +!End WUE stomata model parameter + rb,ra,rstfac,cint,assim,respc,rst ) + +!======================================================================= +! +! !DESCRIPTION: +! calculation of canopy photosynthetic rate using the integrated +! model relating assimilation and stomatal conductance. +! +! Original author: Yongjiu Dai, 08/11/2001 +! +! !REFERENCES: +! Dai et al., 2004: A two-big-leaf model for canopy temperature, +! photosynthesis and stomatal conductance. J. Climate, 17: 2281-2299. +! +! +! units are converted from mks to biological units in this routine. +! +! units +! ------- +! +! pco2m, pco2a, pco2i, po2m : pascals +! co2a, co2s, co2i, h2oa, h2os, h2oa : mol mol-1 +! vmax25, respcp, assim, gs, gb, ga : mol m-2 s-1 +! effcon : mol co2 mol quanta-1 +! 1/rb, 1/ra, 1/rst : m s-1 +! +! conversions +! ------------- +! +! 1 mol h2o = 0.018 kg +! 1 mol co2 = 0.044 kg +! h2o (mol mol-1) = ea / psrf ( pa pa-1 ) +! h2o (mol mol-1) = q*mm/(q*mm + 1) +! gs (co2) = gs (h2o) * 1./1.6 +! gs (mol m-2 s-1 ) = gs (m s-1) * 44.6*tf/t*p/po +! par (mol m-2 s-1 ) = par(w m-2) * 4.6*1.e-6 +! mm (molair/molh2o) = 1.611 +! +! !REVISIONS: +! 2021, Xingjie Lu: Add ozone stree and WUE model +! +!---------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm, &! temperature coefficient in gs-a model (328.16) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter ! conductance-photosynthesis intercept + integer, intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + real(r8),intent(in) :: & + tm, &! atmospheric air temperature (K) + psrf, &! surface atmospheric pressure (pa) + po2m, &! O2 concentration in atmos. (pascals) + pco2m, &! CO2 concentration in atmos. (pascals) + pco2a, &! CO2 concentration in canopy air space (pa) + ea, &! canopy air space vapor pressure (pa) + ei, &! saturation h2o vapor pressure in leaf stomata (pa) + tlef, &! leaf temperature (K) + par, &! photosynthetic active radiation (W m-2) +!Ozone stress variables + o3coefv, & + o3coefg, & +!End ozone stress variables + +!WUE stomata model parameter + lambda, &! marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + + rb, &! boundary resistance from canopy to cas (s m-1) + ra, &! aerodynamic resistance from cas to reference height (s m-1) + rstfac ! canopy resistance stress factors to soil moisture + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + assim, &! canopy assimilation rate (mol m-2 s-1) + respc, &! canopy respiration (mol m-2 s-1) + rst ! canopy stomatal resistance (s m-1) + + real(r8) gammas + +!-------------------------- Local Variables ---------------------------- + + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + + real(r8) & + c3, &! c3 vegetation : 1; 0 for c4 + c4, &! c4 vegetation : 1; 0 for c3 + rrkk, &! kc (1+o2/ko) + + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + bintc, &! residual stomatal conductance for co2 (mol co2 m-2 s-1) + acp, &! temporary variable for stomata model (mol co2 m-2 s-1) + vpd, &! vapor pressure deficit (kpa) + + tprcor, &! coefficient for unit transfer + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gsh2o, &! canopy conductance (mol m-2 s-1) + + atheta, &! wc, we coupling parameter + btheta, &! wc & we, ws coupling parameter + omss, &! intermediate calculation for oms + omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) + ome, &! light limited assimilation (omega-e: mol m-2 s-1) + oms, &! sink limited assimilation (omega-s: mol m-2 s-1) + omp, &! intermediate calculation for omc, ome + + co2m, &! co2 concentration in atmos (mol mol-1) + co2a, &! co2 concentration at cas (mol mol-1) + co2s, &! co2 concentration at canopy surface (mol mol-1) + co2st, &! co2 concentration at canopy surface (mol mol-1) + co2i, &! internal co2 concentration (mol mol-1) + pco2in, &! internal co2 concentration at the new iteration (pa) + pco2i, &! internal co2 concentration (pa) + pco2i_c, &! internal co2 concentration when Rubisco is limited (pa) + pco2i_e, &! internal co2 concentration when RuBP regeneration is limited (pa) + es, &! canopy surface h2o vapor pressure (pa) + + sqrtin, &! intermediate calculation for quadratic + assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) + assimn, &! net assimilation (mol co2 m-2 s-1) + hcdma, &! a-1 + aquad, &! a: ax^2 + bx + c = 0 + bquad, &! b: ax^2 + bx + c = 0 + cquad ! c: ax^2 + bx + c = 0 + + real(r8) :: & + eyy(iterationtotal), &! differnce of pco2i at two iteration step + pco2y(iterationtotal), &! adjusted to total iteration number + range ! + + integer ic +!----------------------------------------------------------------------- + + CALL calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, c3c4, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + bintc = binter * max( 0.1, rstfac ) + bintc = bintc * cint(3) + +!----------------------------------------------------------------------- +! first guess is midway between compensation point and maximum +! assimilation rate. ! pay attention on this iteration + + tprcor = 44.6*273.16*psrf/1.013e5 + + co2m = pco2m/psrf ! mol mol-1 + co2a = pco2a/psrf + + range = pco2m * ( 1. - 1.6/gradm ) - gammas + + DO ic = 1, iterationtotal ! loop for total iteration number + pco2y(ic) = 0. + eyy(ic) = 0. + ENDDO + + ITERATION_LOOP: DO ic = 1, iterationtotal + + !IF(.not. DEF_USE_WUEST .or. epar .lt. 1.e-12)THEN + IF(.not. DEF_USE_WUEST .or. abs(c4 - 1) .lt. 0.001)THEN + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) + pco2i_c = pco2i + pco2i_e = pco2i + ELSE + CALL WUE_solver(gammas, lambda, co2a, ei, ea, psrf, pco2i_c, pco2i_e) + ENDIF + +!----------------------------------------------------------------------- +! NET ASSIMILATION +! the leaf assimilation (or gross photosynthesis) rate is described +! as the minimum of three limiting rates: +! omc: the efficiency of the photosynthetic enzyme system (Rubisco-limited); +! ome: the amount of PAR captured by leaf chlorophyll; +! oms: the capacity of the leaf to export or utilize the products of photosynthesis. +! to aviod the abrupt transitions, two quadratic equations are used: +! atheta*omp^2 - omp*(omc+ome) + omc*ome = 0 +! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 +!----------------------------------------------------------------------- + + atheta = 0.877 + btheta = 0.95 + + ! As if DEF_USE_WUEST=.false., pco2i_c=pco2i_e=pco2i + omc = vm * ( pco2i_c-gammas ) / ( pco2i_c + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i_e-gammas ) / ( pco2i_e+2.*gammas ) * c3 + epar * c4 + !IF(.not. DEF_USE_WUEST .or. epar .lt. 1.e-12)THEN + IF(.not. DEF_USE_WUEST .or. abs(c4 - 1) .lt. 0.001)THEN + oms = omss * c3 + omss*pco2i * c4 + + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + ELSE + assim = max( 0., min(omc, ome)) + ENDIF + !print*,'assimn',assim,omc,ome + assimn= ( assim - respc) ! mol m-2 s-1 + +!----------------------------------------------------------------------- +! STOMATAL CONDUCTANCE +! +! (1) pathway for co2 flux +! co2m +! o +! | +! | +! < | +! 1.37/gsh2o > | Ac-Rd-Rsoil +! < v +! | +! <--- Ac-Rd | +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! co2i 1.6/gsh2o co2s 1.37/gbh2o co2a +! | ^ +! | | Rsoil +! | | +! +! (2) pathway for water vapor flux +! +! em +! o +! | +! | +! < ^ +! 1/gsh2o > | Ea +! < | +! | +! ---> Ec ! +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! ei 1/gsh2o es 1/gbh2o ea +! | ^ +! | | Eg +! | | +! +! (3) the relationship between net assimilation and tomatal conductance : +! gsh2o = m * An * [es/ei] / [pco2s/p] + b +! es = [gsh2o *ei + gbh2o * ea] / [gsh2o + gbh2o] +! ===> +! a*gsh2o^2 + b*gsh2o + c = 0 +! +!----------------------------------------------------------------------- + + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + + co2st = min( co2s, co2a ) + co2st = max( co2st,1.e-5 ) + + assmt = max( 1.e-12, assimn ) + + !IF(DEF_USE_WUEST .and. epar .ge. 1.e-12)THEN + IF(DEF_USE_WUEST .and. .not. abs(c4 - 1) .lt. 0.001)THEN + IF(omc .lt. ome)THEN + pco2i = pco2i_c + ELSE + pco2i = pco2i_e + ENDIF + gsh2o = assmt / (co2a - pco2i/psrf)*1.6 + pco2in = pco2i ! No need to iteratively solve pco2i for WUE model. + ! Let pco2in = pco2i to exit loop. + IF(pco2i .gt. pco2a)THEN + write(*,*) 'warning: pco2i greater than pco2a, use bb model' + ENDIF + ELSE + IF(DEF_USE_MEDLYNST)THEN + vpd = amax1((ei - ea),50._r8) * 1.e-3 ! in kpa + acp = 1.6*assmt/co2st ! in mol m-2 s-1 + aquad = 1._r8 + bquad = -2*(g0*1.e-6 + acp) - (g1*acp)**2/(gbh2o*vpd) ! in mol m-2 s-1 + cquad = (g0*1.e-6)**2 + (2*g0*1.e-6+acp*(1-g1**2)/vpd)*acp ! in (mol m-2 s-1)**2 + + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + + ELSE + hcdma = ei*co2st / ( gradm*assmt ) + + aquad = hcdma + bquad = gbh2o*hcdma - ei - bintc*hcdma + cquad = -gbh2o*( ea + hcdma*bintc ) + + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + + es = ( gsh2o-bintc ) * hcdma ! pa + es = min( es, ei ) + es = max( es, 1.e-2) + + gsh2o = es/hcdma + bintc ! mol m-2 s-1 + ENDIF + + pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa + ENDIF + eyy(ic) = pco2i - pco2in ! pa + +!----------------------------------------------------------------------- + + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT + + ENDDO ITERATION_LOOP + +! convert gsh2o (mol m-2 s-1) to resistance rst ( s m-1) + rst = min( 1.e6, 1./(gsh2o*tlef/tprcor) ) ! s m-1 + + END SUBROUTINE stomata + + + + SUBROUTINE sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) + +!----------------------------------------------------------------------- +! arranges successive pco2/error pairs in order of increasing pco2. +! estimates next guess for pco2 using combination of linear and +! quadratic fits. +! +! original author: P. J. Sellers (SiB2) +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ic,iterationtotal + real(r8), intent(in) :: range + real(r8), intent(in) :: gammas + real(r8), intent(inout), dimension(iterationtotal) :: eyy, pco2y + +!-------------------------- Local Variables ---------------------------- + integer i, j, n, i1, i2, i3, is, isp, ix + real(r8) a, b, pmin, emin, eyy_a + real(r8) pco2b, pco2yl, pco2yq + real(r8) ac1, ac2, bc1, bc2, cc1, cc2 + real(r8) bterm, aterm, cterm + +!----------------------------------------------------------------------- + + IF( ic .ge. 4 ) go to 500 + eyy_a = 1.0 + IF(eyy(1).lt.0.) eyy_a = -1.0 + pco2y(1) = gammas + 0.5*range + pco2y(2) = gammas + range*( 0.5 - 0.3*eyy_a ) + pco2y(3) = pco2y(1) - (pco2y(1)-pco2y(2))/(eyy(1)-eyy(2)+1.e-10)*eyy(1) + + pmin = min( pco2y(1), pco2y(2) ) + emin = min( eyy(1), eyy(2) ) + IF ( emin .gt. 0. .and. pco2y(3) .gt. pmin ) pco2y(3) = gammas + go to 200 +500 continue + + n = ic - 1 + DO 1000 j = 2, n + a = eyy(j) + b = pco2y(j) + DO 2000 i = j-1,1,-1 + IF(eyy(i) .le. a ) go to 100 + eyy(i+1) = eyy(i) + pco2y(i+1) = pco2y(i) +2000 continue + i = 0 +100 eyy(i+1) = a + pco2y(i+1) = b +1000 continue + + pco2b = 0. + is = 1 + DO 3000 ix = 1, n + IF( eyy(ix) .lt. 0. ) pco2b = pco2y(ix) + IF( eyy(ix) .lt. 0. ) is = ix +3000 continue + i1 = is-1 + i1 = max(1, i1) + i1 = min(n-2, i1) + i2 = i1 + 1 + i3 = i1 + 2 + isp = is + 1 + isp = min( isp, n ) + is = isp - 1 + + pco2yl=pco2y(is) - (pco2y(is)-pco2y(isp))/(eyy(is)-eyy(isp)+1.e-10)*eyy(is) + +!---------------------------------------------------------------------- +! method using a quadratic fit +!---------------------------------------------------------------------- + + ac1 = eyy(i1)*eyy(i1) - eyy(i2)*eyy(i2) + ac2 = eyy(i2)*eyy(i2) - eyy(i3)*eyy(i3) + bc1 = eyy(i1) - eyy(i2) + bc2 = eyy(i2) - eyy(i3) + cc1 = pco2y(i1) - pco2y(i2) + cc2 = pco2y(i2) - pco2y(i3) + bterm = (cc1*ac2-cc2*ac1)/(bc1*ac2-ac1*bc2+1.e-10) + aterm = (cc1-bc1*bterm)/(ac1+1.e-10) + cterm = pco2y(i2) - aterm*eyy(i2)*eyy(i2) - bterm*eyy(i2) + pco2yq= cterm + pco2yq= max( pco2yq, pco2b ) + pco2y(ic) = ( pco2yl+pco2yq)/2. + +200 continue + + pco2y(ic) = max ( pco2y(ic), 0.01 ) + + END SUBROUTINE sortin + + SUBROUTINE calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, c3c4, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + par, &! photosynthetic active radiation (W m-2) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm, &! temperature coefficient in gs-a model (328.16) + psrf ! surface atmospheric pressure (pa) + + integer, intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + respc, &! canopy respiration (mol m-2 s-1) + omss, &! intermediate calcuation for oms + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + qt, &! (tleaf - 298.16) / 10 + kc, &! Michaelis-Menten constant for co2 + ko, &! Michaelis-Menten constant for o2 + templ, &! intermediate value + temph, &! intermediate value + rgas, &! universal gas contant (8.314 J mol-1 K-1) + jmax25, &! potential rate of whole-chain electron transport at 25 C + jmax, &! potential rate of whole-chain electron transport (mol electron m-2 s-1) + respcp, &! respiration fraction of vmax (mol co2 m-2 s-1) + tprcor ! coefficient for unit transfer + +!----------------------------------------------------------------------- + + c3 = 0. + IF (c3c4.eq.1) c3 = 1. + c4 = 1. - c3 + +!----------------------------------------------------------------------- +! dependence on leaf temperature +! gammas - CO2 compensation point in the absence of day respiration +! ko - Michaelis-Menton constant for carboxylation by Rubisco +! kc - Michaelis-Menton constant for oxygenation by Rubisco +!----------------------------------------------------------------------- + + qt = 0.1*( tlef - trop ) + + kc = 30. * 2.1**qt + ko = 30000. * 1.2**qt + gammas = 0.5 * po2m / (2600. * 0.57**qt) * c3 ! = 0. for c4 plant ??? + + rrkk = kc * ( 1. + po2m/ko ) * c3 + +!---------------------------------------------------------------------- +! maximun capacity +! vm - maximum catalytic activity of Rubisco in the presence of +! saturating level of RuP2 and CO2 (mol m-2s-1) +! jmax - potential rate of whole-chain electron transport (mol m-2s-1) +! epar - electron transport rate for a given absorbed photon radiation +! respc - dark resipration (mol m-2s-1) +! omss - capacity of the leaf to export or utilize the products of photosynthesis. +! binter - coefficient from observation, 0.01 for c3 plant, 0.04 for c4 plant +!----------------------------------------------------------------------- + + vm = vmax25 * 2.1**qt ! (mol m-2 s-1) + templ = 1. + exp(slti*(hlti-tlef)) + temph = 1. + exp(shti*(tlef-hhti)) + vm = vm / temph * rstfac * c3 + vm / (templ*temph) * rstfac * c4 + vm = vm * cint(1) + + rgas = 8.314467591 ! universal gas constant (J mol-1 K-1) +!---> jmax25 = 2.39 * vmax25 - 14.2e-6 ! (mol m-2 s-1) +!---> jmax25 = 2.1 * vmax25 ! (mol m-2 s-1) +!/05/2014/ + jmax25 = 1.97 * vmax25 ! (mol m-2 s-1) + jmax = jmax25 * exp( 37.e3 * (tlef - trop) / (rgas*trop*tlef) ) * & + ( 1. + exp( (710.*trop-220.e3)/(rgas*trop) ) ) / & + ( 1. + exp( (710.*tlef-220.e3)/(rgas*tlef) ) ) + ! 37000 (J mol-1) + ! 220000 (J mol-1) + ! 710 (J K-1) + + jmax = jmax * rstfac + jmax = jmax * cint(2) + +!---> epar = min(4.6e-6 * par * effcon, 0.25*jmax) +! /05/2014/ + epar = min(4.6e-6 * par * effcon, jmax) + + respcp = 0.015 * c3 + 0.025 * c4 + respc = respcp * vmax25 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac +! respc = 0.7e-6 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac + respc = respc * cint(1) + + omss = ( vmax25/2. ) * (1.8**qt) / templ * rstfac * c3 & + + ( vmax25/5. ) * (1.8**qt) * rstfac * c4 + omss = omss * cint(1) + +!----------------------------------------------------------------------- + tprcor = 44.6*273.16*psrf/1.013e5 + +! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] +! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for +! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tlef " +! gbh2o = 0.5/rb * tprcor/tlef ! mol m-2 s-1 + gbh2o = 1./rb * tprcor/tlef ! mol m-2 s-1 + +! rb is for single leaf, but here the flux is for canopy, thus + ! Xingjie Lu: rb has already been converted to canopy scale, + ! thus, there is no need for gbh2o *cint(3) (sunlit/shaded LAI) +! gbh2o = gbh2o * cint(3) + + END SUBROUTINE calc_photo_params + + SUBROUTINE update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2o,& + effcon, vmax25, c3c4, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cint,& + assim, respc) + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + pco2m, &! CO2 concentration in atmos. (pascals) + pco2a, &! CO2 concentration in canopy air space (pa) + par, &! photosynthetic active radiation (W m-2) + psrf, &! surface atmospheric pressure (pa) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + gsh2o, &! canopy conductance (mol m-2 s-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + gradm, &! conductance-photosynthesis slope parameter + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm ! temperature coefficient in gs-a model (328.16) + + integer, intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + assim, &! canopy assimilation rate (mol m-2 s-1) + respc ! canopy respiration (mol m-2 s-1) + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + + real(r8) :: & + atheta, &! wc, we coupling parameter + btheta, &! wc & we, ws coupling parameter + omss, &! intermediate calcuation for oms + omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) + ome, &! light limited assimilation (omega-e: mol m-2 s-1) + oms, &! sink limited assimilation (omega-s: mol m-2 s-1) + omp, &! intermediate calcuation for omc, ome + + co2a, &! co2 concentration at cas (mol mol-1) + co2s, &! co2 concentration at canopy surface (mol mol-1) + co2st, &! co2 concentration at canopy surface (mol mol-1) + co2i, &! internal co2 concentration (mol mol-1) + pco2in, &! internal co2 concentration at the new iteration (pa) + pco2i, &! internal co2 concentration (pa) + es, &! canopy surface h2o vapor pressure (pa) + + sqrtin, &! intermediate calculation for quadratic + assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) + assimn ! net assimilation (mol co2 m-2 s-1) + + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + + real(r8) :: & + eyy(iterationtotal), &! differnce of pco2i at two iteration step + pco2y(iterationtotal), &! adjusted to total iteration number + range ! + + integer ic +!----------------------------------------------------------------------- + + CALL calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, c3c4, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + co2a = pco2a/psrf + + range = pco2m * ( 1. - 1.6/gradm ) - gammas + + DO ic = 1, iterationtotal ! loop for total iteration number + pco2y(ic) = 0. + eyy(ic) = 0. + ENDDO + + ITERATION_LOOP_UPDATE: DO ic = 1, iterationtotal + + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) + +!----------------------------------------------------------------------- +! NET ASSIMILATION +! the leaf assimilation (or gross photosynthesis) rate is described +! as the minimum of three limiting rates: +! omc: the efficiency of the photosynthetic enzyme system (Rubisco-limited); +! ome: the amount of PAR captured by leaf chlorophyll; +! oms: the capacity of the leaf to export or utilize the products of photosynthesis. +! to aviod the abrupt transitions, two quadratic equations are used: +! atheta*omp^2 - omp*(omc+ome) + omc*ome = 0 +! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 +!----------------------------------------------------------------------- + + atheta = 0.877 + btheta = 0.95 + + omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 + IF(.not. DEF_USE_WUEST .or. abs(c4 - 1) .lt. 0.001)THEN + oms = omss * c3 + omss*pco2i * c4 + + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + ELSE + assim = max( 0., min(omc, ome)) + ENDIF + + assimn= ( assim - respc) ! mol m-2 s-1 + +!----------------------------------------------------------------------- +! STOMATAL CONDUCTANCE +! +! (1) pathway for co2 flux +! co2m +! o +! | +! | +! < | +! 1.37/gsh2o > | Ac-Rd-Rsoil +! < v +! | +! <--- Ac-Rd | +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! co2i 1.6/gsh2o co2s 1.37/gbh2o co2a +! | ^ +! | | Rsoil +! | | +! +! (2) pathway for water vapor flux +! +! em +! o +! | +! | +! < ^ +! 1/gsh2o > | Ea +! < | +! | +! ---> Ec ! +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! ei 1/gsh2o es 1/gbh2o ea +! | ^ +! | | Eg +! | | +! +! (3) the relationship between net assimilation and tomatal conductance : +! gsh2o = m * An * [es/ei] / [pco2s/p] + b +! es = [gsh2o *ei + gbh2o * ea] / [gsh2o + gbh2o] +! ===> +! a*gsh2o^2 + b*gsh2o + c = 0 +! +!----------------------------------------------------------------------- + + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + co2st = min( co2s, co2a ) + co2st = max( co2st,1.e-5 ) + + assmt = max( 1.e-12, assimn ) + + + pco2in = ( co2s - 1.6 * assmt / gsh2o )*psrf ! pa + + eyy(ic) = pco2i - pco2in ! pa + +!----------------------------------------------------------------------- + + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT + + ENDDO ITERATION_LOOP_UPDATE + + END SUBROUTINE update_photosyn + + SUBROUTINE WUE_solver(gammas, lambda, co2a, ei, ea, psrf, pco2i_c, pco2i_e) + +!----------------------------------------------------------------------- +! Solve internal co2 concentration for Rubisco limit and RuBP regeneration limit. +! +! When Rubisco is limit (omc < ome), solve following equation (Liang et al., 2023, S18a) +! for pco2i_c: +! {1-(1.6*D)/[lambda*(gammas+rrkk)]} * co2i_c^2 & +! - {2*co2a+[1.6*D*(rrkk-gammas)]/[lambda*(gammas+rrkk)]-(1.6*D)/lambda} * co2i_c & +! + {co2a^2 - (1.6*D*co2a)/lambda + (1.6*D*rrkk*gammas)/[lambda*(gammas+rrkk)]} = 0 +! +! When RuBP is limit (omc>=ome), solve following equation (Liang et al., 2023, S18b) +! for pco2i_e: +! [1-(1.6*D)/(3*lambda*gammas)] * co2i_e^2 & +! - [2*co2a-(3.2*D)/(3*lambda)] * co2i_e & +! + [co2a^2 - (1.6*D*co2a)/lambda + (3.2*D*gammas)/(3*lambda)] = 0 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + gammas, &! CO2 compensation point (pa) + lambda, &! marginal water use efficiency ((mol h2o) (mol co2)-1) + co2a, &! co2 concentration at cas ((mol co2) (mol air)-1) + ea, &! canopy air space vapor pressure (pa) + ei, &! saturation h2o vapor pressure in leaf stomata (pa) + psrf ! air pressure (pa) + + real(r8),intent(out) :: & + pco2i_c, &! internal co2 concentration when Rubisco is limited (pa) + pco2i_e ! internal co2 concentration when RuBP regeneration is limited (pa) + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + D, &! leaf-to-air-vapour mole fraction difference ((mol h2o) (mol air)-1) + co2i_c, &! internal co2 concentration when Rubisco is limited ((mol co2) (mol air)-1) + co2i_e ! internal co2 concentration when RuBP is limited ((mol co2) (mol air)-1) + +!----------------------------------------------------------------------- + + ! solve co2i_c + D = amax1((ei - ea),50._r8) / psrf + + co2i_c = co2a - sqrt(1.6*D*(amax1(co2a-gammas/psrf,0._r8))/lambda) + co2i_e = co2a - co2a / ( 1 + 1.37 * sqrt(lambda * gammas/psrf / D)) + + pco2i_c = co2i_c * psrf + pco2i_e = co2i_e * psrf + + END SUBROUTINE WUE_solver + +END MODULE MOD_AssimStomataConductance +! -------------- EOP --------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 new file mode 100644 index 0000000000..4f9da1a27e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 @@ -0,0 +1,730 @@ +#include + +MODULE MOD_CanopyLayerProfile + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER SUBROUTINE/FUNCTIONS: + + PUBLIC :: uprofile, kprofile + PUBLIC :: uintegral, uintegralz, kintegral + PUBLIC :: ueffect, ueffectz, fuint, fkint, frd + PUBLIC :: udiff, kdiff, ufindroots, kfindroots + + PUBLIC :: cal_z0_displa + +!----------------------------------------------------------------------- + +CONTAINS + + real(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z + + real(r8) :: ulog,uexp + + ! A simple version of wind profile based on Dai et al., 2019. + ! A combination of u of canopy area and bare soil wighted by + ! their fractional cover. + ! + ! - Canopy area wind: min(uexp, ulog) - bare soil: ulog + ! fc: vegetation fractional cover, bee: free parameter = 1. + + ulog = utop*log(z/z0mg)/log(htop/z0mg) + uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) + + uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog + + RETURN + END FUNCTION uprofile + + + ! Exchange coefficient K profile based on Dai et al., 2019. + real(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: z + + real(r8) :: fac + real(r8) :: kcob, klin, kexp + + klin = ktop*z/htop + + fac = 1. / (1.+exp(-(displah-com1)/com2)) + kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) + + RETURN + END FUNCTION kprofile + + + ! numerical solution for wind profile integration (not used now) + real(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 + n = int( (htop-hbot) / dz ) + 1 + + uintegral = 0. + + DO i = 1, n + IF (i < n) THEN + z = htop - (i-0.5)*dz + ELSE + dz = htop - hbot - (n-1)*dz + z = hbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) + ! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegral = uintegral + u*dz / (htop-hbot) + ENDDO + + RETURN + END FUNCTION uintegral + + + ! numerical solution for wind profile integration (not used now) + real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, & + htop, hbot, ztop, zbot) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 + n = int( (ztop-zbot) / dz ) + 1 + + uintegralz = 0. + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) + ! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegralz = uintegralz + u*dz / (ztop-zbot) + ENDDO + + RETURN + END FUNCTION uintegralz + + + real(r8) FUNCTION ueffect(utop, htop, hbot, & + z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(htop,hbot,(htop+hbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, htop, hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffect = uint / (htop-hbot) + + RETURN + END FUNCTION ueffect + + + ! Calculate the effective wind speed between ztop and zbot + real(r8) FUNCTION ueffectz(utop, htop, hbot, & + ztop, zbot, z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(ztop,zbot,(ztop+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffectz = uint / (ztop-zbot) + + RETURN + END FUNCTION ueffectz + + + real(r8) FUNCTION fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0mg, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fuexpint, fulogint + + fulogint = utop/log(htop/z0mg) *& + (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) + + IF (udiff((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN + ! uexp is smaller + fuexpint = utop*(htop-hbot)/alpha*( & + exp(-alpha*(htop-ztop)/(htop-hbot))-& + exp(-alpha*(htop-zbot)/(htop-hbot)) ) + + fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint + ELSE + ! ulog is smaller + fuint = fulogint + ENDIF + + RETURN + END FUNCTION fuint + + + RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: udiff_ub, udiff_lb + + udiff_ub = udiff(ztop,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zmid,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (udiff_ub*udiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + + udiff_ub = udiff(zmid,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zbot,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (udiff_ub*udiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE ufindroots + + + real(r8) FUNCTION udiff(z, utop, htop, hbot, z0mg, alpha) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: z, utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8) :: uexp, ulog + + uexp = utop*exp(-alpha*(htop-z)/(htop-hbot)) + ulog = utop*log(z/z0mg)/log(htop/z0mg) + + udiff = uexp - ulog + + RETURN + END FUNCTION udiff + + + ! numerical solution for K profile integration (not used now) + real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + displah, htop, hbot, obu, ustar, ztop, zbot) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, k + + kintegral = 0. + + IF (ztop <= zbot) THEN + RETURN + ENDIF + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 + n = int( (ztop-zbot) / dz ) + 1 + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + k = kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + kintegral = kintegral + 1./k * dz + + ENDDO + + RETURN + END FUNCTION kintegral + + + real(r8) FUNCTION frd(ktop, htop, hbot, & + ztop, zbot, displah, z0h, obu, ustar, & + z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: ztop, zbot + real(r8), intent(in) :: displah, z0h, obu, ustar + real(r8), intent(in) :: z0mg, alpha, bee, fc + + ! local parameters + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 + + real(r8) :: roots(2), fac, kint + integer :: rootn + + rootn = 0 + kint = 0. + + ! calculate fac + fac = 1. / (1.+exp(-(displah-com1)/com2)) + roots(:) = 0. + + CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + frd = kint + + RETURN + END FUNCTION frd + + + real(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: ktop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0h, obu, ustar, fac, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fkexpint, fkcobint + + !NOTE: + ! klin = ktop*z/htop + ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& + (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) + + IF (kdiff((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN + ! kexp is smaller + IF (alpha > 0) THEN + fkexpint = -(htop-hbot)/alpha/ktop*( & + exp(alpha*(htop-ztop)/(htop-hbot))-& + exp(alpha*(htop-zbot)/(htop-hbot)) ) + ELSE + fkexpint = (ztop-zbot)/ktop + ENDIF + + fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint + ELSE + ! kcob is smaller + fkint = fkcobint + ENDIF + + RETURN + END FUNCTION fkint + + + RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: kdiff_ub, kdiff_lb + + ! CALL recursive SUBROUTINE kfindroots + kdiff_ub = kdiff(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (kdiff_ub*kdiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + + kdiff_ub = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (kdiff_ub*kdiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE kfindroots + + + real(r8) FUNCTION kdiff(z, ktop, htop, hbot, & + obu, ustar, fac, alpha) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: z, ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8) :: kexp, klin, kcob + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + + klin = ktop*z/htop + kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kdiff = kexp - kcob + + RETURN + END FUNCTION kdiff + + + SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) + + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + + real(r8), intent(in) :: lai + real(r8), intent(in) :: h + real(r8), intent(in) :: fc + real(r8), intent(out) :: z0 + real(r8), intent(out) :: displa + + real(r8), parameter :: Cd = 0.2 !leaf drag coefficient + real(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 + real(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 + + ! local variables + real(r8) :: fai, sqrtdragc, temp1, delta , lai0 + + ! when assume z0=0.01, displa=0 + ! to calculate lai0, delta displa + !---------------------------------------------------- + sqrtdragc = -vonkar/(log(0.01/h) - psih) + sqrtdragc = max(sqrtdragc, 0.0031**0.5) + IF (sqrtdragc .le. 0.3) THEN + fai = (sqrtdragc**2-0.003) / 0.3 + fai = min(fai, fc*(1-exp(-20.))) + ELSE + fai = 0.29 + print *, "z0m, displa error!" + ENDIF + + ! calculate delta displa when z0 = 0.01 + lai0 = -log(1.-fai/fc)/0.5 + temp1 = (2.*cd1*fai)**0.5 + delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & + (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) + + ! calculate z0m, displa + !---------------------------------------------------- + ! NOTE: potential bug below, only apply for spheric + ! crowns. For other cases, fc*(...) ==> a*fc*(...) + fai = fc*(1. - exp(-0.5*lai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + temp1 = (2.*cd1*fai)**0.5 + + IF (lai > lai0) THEN + displa = delta + h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ELSE + displa = h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ENDIF + + displa = max(displa, 0.) + z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) + + IF (z0 < 0.01) THEN + z0 = 0.01 + displa = 0. + ENDIF + + END SUBROUTINE cal_z0_displa + +END MODULE MOD_CanopyLayerProfile diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 new file mode 100644 index 0000000000..b47138a4e5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 @@ -0,0 +1,685 @@ +#include + +MODULE MOD_CheckEquilibrium + +!---------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Check equilibrium state. +! +! Created by Shupeng Zhang, 10/2024 +!---------------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Grid + USE netcdf + USE MOD_NetCDFSerial + USE MOD_SpatialMapping + USE MOD_Forcing, only: forcmask_pch + USE MOD_Vars_Global, only: spval + + ! ----- Variables ----- + integer :: nyearcheck + + integer :: timestrlen + character(len=24) :: timeform + + real(r8), allocatable :: tws_last (:) + real(r8), allocatable :: tws_this (:) + + real(r8), allocatable :: prcp_year (:) + real(r8), allocatable :: et_year (:) + real(r8), allocatable :: rnof_year (:) + real(r8), allocatable :: rchg_year (:) + + real(r8), allocatable :: patcharea (:) ! m^2 + + character(len=256) :: mesg_equilibrium + +#ifndef SinglePoint + type(grid_type) :: gridcheck + type(grid_concat_type) :: gcheck_concat + type(spatial_mapping_type) :: map_check + + integer :: check_data_id = 0 +#endif + + PUBLIC :: CheckEqb_init + PUBLIC :: CheckEquilibrium + PUBLIC :: CheckEqb_final + +CONTAINS + + !----------------------------------------------------------------------- + SUBROUTINE CheckEqb_init (n_spinupcycle, lc_year) + + USE MOD_Utils + USE MOD_Vars_Global, only: nl_soil + USE MOD_Forcing, only: gforc + USE MOD_LandPatch, only: numpatch, landpatch + USE MOD_Pixel, only: pixel + USE MOD_Mesh, only: mesh + USE MOD_Vars_TimeVariables, only: wdsrf, ldew, scv, wetwat, & + wliq_soisno, wice_soisno, wa + IMPLICIT NONE + + integer, intent(in) :: n_spinupcycle + integer, intent(in) :: lc_year + + ! Local Variable + integer :: ilev, ip, ie, ipxl + character(len=256) :: filename, cyear + real(r8) :: totaldtws, totalprcp, pct_dtws_prcp + + + IF (.not. DEF_CheckEquilibrium) RETURN + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + allocate (tws_last (numpatch)); tws_last (:) = spval; + allocate (tws_this (numpatch)); tws_this (:) = spval; + allocate (prcp_year (numpatch)); prcp_year(:) = spval; + allocate (et_year (numpatch)); et_year (:) = spval; + allocate (rnof_year (numpatch)); rnof_year(:) = spval; + allocate (rchg_year (numpatch)); rchg_year(:) = spval; + + ENDIF + ENDIF + + IF (n_spinupcycle >= 10000) THEN + timestrlen = 16 + timeform = "('spinup',I5.5,'-',I4.4)" + ELSEIF (n_spinupcycle >= 1000) THEN + timestrlen = 15 + timeform = "('spinup',I4.4,'-',I4.4)" + ELSEIF (n_spinupcycle >= 100) THEN + timestrlen = 14 + timeform = "('spinup',I3.3,'-',I4.4)" + ELSEIF (n_spinupcycle >= 10) THEN + timestrlen = 13 + timeform = "('spinup',I2.2,'-',I4.4)" + ELSE + timestrlen = 12 + timeform = "('spinup',I1.1,'-',I4.4)" + ENDIF + + mesg_equilibrium = '' + +#ifndef SinglePoint + ! grid +#ifdef GRIDBASED + write(cyear,'(i4.4)') lc_year + filename = trim(DEF_dir_landdata) // '/mesh/' //trim(cyear) // '/mesh.nc' + CALL gridcheck%define_from_file (filename) +#else + CALL gridcheck%define_by_copy (gforc) +#endif + ! grid info for output + CALL gcheck_concat%set (gridcheck) + ! mapping from patch to grid + CALL map_check%build_arealweighted (gridcheck, landpatch) +#endif + + IF ((p_is_worker) .and. (numpatch > 0)) THEN + tws_last = wdsrf ! 1. surface water + CALL add_spv (ldew, tws_last) ! 2. water on foliage + CALL add_spv (scv , tws_last) ! 3. snow cover water equivalent + IF (DEF_USE_VariablySaturatedFlow) THEN + CALL add_spv (wetwat, tws_last) ! 4. water in wetland + ENDIF + DO ilev = 1, nl_soil + CALL add_spv (wliq_soisno(ilev,:), tws_last) ! 5. liquid water in soil + CALL add_spv (wice_soisno(ilev,:), tws_last) ! 6. ice in soil + ENDDO + CALL add_spv (wa, tws_last) ! 7. water in aquifer + ENDIF + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + allocate (patcharea (numpatch)) + patcharea(:) = 0. + DO ip = 1, numpatch + ie = landpatch%ielm(ip) + DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) + patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + IF (landpatch%has_shared) THEN + patcharea(ip) = patcharea(ip) * landpatch%pctshared(ip) + ENDIF + ENDDO + ENDIF + + ENDIF + + nyearcheck = 0 + + END SUBROUTINE CheckEqb_init + + !----------------------------------------------------------------------- + SUBROUTINE CheckEqb_final () + + IMPLICIT NONE + + IF (.not. DEF_CheckEquilibrium) RETURN + + IF (allocated(tws_last )) deallocate(tws_last ) + IF (allocated(tws_this )) deallocate(tws_this ) + IF (allocated(prcp_year)) deallocate(prcp_year) + IF (allocated(et_year )) deallocate(et_year ) + IF (allocated(rnof_year)) deallocate(rnof_year) + IF (allocated(rchg_year)) deallocate(rchg_year) + IF (allocated(patcharea)) deallocate(patcharea) + + END SUBROUTINE CheckEqb_final + + !----------------------------------------------------------------------- + SUBROUTINE CheckEquilibrium ( & + idate, deltim, i_spinupcycle, is_spinup, dir_out, casename) + + USE MOD_Precision + USE MOD_TimeManager + USE MOD_DataType + USE MOD_LandPatch, only: numpatch + USE MOD_Vars_Global, only: nl_soil + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl + USE MOD_Vars_1DFluxes, only: fevpa, rnof, rsur + USE MOD_Vars_TimeInvariants, only: patchtype, patchmask + USE MOD_Vars_TimeVariables, only: wdsrf, ldew, scv, wetwat, wliq_soisno, & + wice_soisno, wa, zwt + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + integer, intent(in) :: i_spinupcycle + logical, intent(in) :: is_spinup + + character(len=*), intent(in) :: dir_out + character(len=*), intent(in) :: casename + + ! Local variables + logical :: docheck + integer :: ilev + character(len=256) :: filename, timestr + integer :: ncid, time_id, str_id, varid + real(r8) :: totaldtws, totalprcp, pct_dtws_prcp + + real(r8), allocatable :: rchg (:) + real(r8), allocatable :: dtws (:) + logical, allocatable :: filter (:) + real(r8), allocatable :: vecone (:) + type(block_data_real8_2d) :: sumarea + + + IF (.not. DEF_CheckEquilibrium) RETURN + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + CALL add_spv (forc_prc, prcp_year, deltim) + CALL add_spv (forc_prl, prcp_year, deltim) + CALL add_spv (fevpa, et_year, deltim) + CALL add_spv (rnof, rnof_year, deltim) + + allocate (rchg (numpatch)) + rchg = spval + WHERE ((forc_prc /= spval) .and. (forc_prl /= spval) .and. (fevpa /= spval) .and. (rsur /= spval)) + rchg = forc_prc + forc_prl - fevpa - rsur + END WHERE + + CALL add_spv (rchg, rchg_year, deltim) + + deallocate (rchg) + ENDIF + ENDIF + + docheck = isendofyear (idate, deltim) + + IF (docheck) THEN + + IF ((p_is_worker) .and. (numpatch > 0)) THEN + tws_this = wdsrf ! 1. surface water + CALL add_spv (ldew, tws_this) ! 2. water on foliage + CALL add_spv (scv , tws_this) ! 3. snow cover water equivalent + IF (DEF_USE_VariablySaturatedFlow) THEN + CALL add_spv (wetwat, tws_this) ! 4. water in wetland + ENDIF + DO ilev = 1, nl_soil + CALL add_spv (wliq_soisno(ilev,:), tws_this) ! 5. liquid water in soil + CALL add_spv (wice_soisno(ilev,:), tws_this) ! 6. ice in soil + ENDDO + CALL add_spv (wa, tws_this) ! 7. water in aquifer + ENDIF + + nyearcheck = nyearcheck + 1 + + IF (nyearcheck >= 1) THEN + + IF (p_is_worker) THEN + + totaldtws = 0. + totalprcp = 0. + + IF (numpatch > 0) THEN + + allocate (filter (numpatch)) + filter = patchmask + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF +#ifdef CatchLateralFlow + filter = filter .and. (patchtype <= 4) +#else + filter = filter .and. (patchtype <= 2) +#endif + + allocate (dtws (numpatch)) + WHERE (filter) + dtws = tws_this - tws_last + ELSEWHERE + dtws = spval + END WHERE + + IF (any(filter)) THEN + totaldtws = sum(dtws*patcharea, mask=filter) + totalprcp = sum(prcp_year*patcharea, mask=filter) + ENDIF + + allocate (vecone (numpatch)) + vecone(:) = 1. + + ENDIF + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, totaldtws, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, totalprcp, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + + IF (totalprcp > 0.) THEN + pct_dtws_prcp = totaldtws/totalprcp + ELSE + pct_dtws_prcp = spval + ENDIF + + IF (p_iam_worker == p_root) THEN + CALL mpi_send (pct_dtws_prcp, 1, MPI_REAL8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + ENDIF +#endif + ENDIF + + IF (p_is_master) THEN + + IF (is_spinup) THEN + write(timestr,timeform) i_spinupcycle, idate(1) + ELSE + write(timestr,'(I4.4)') idate(1) + ENDIF + +#ifdef USEMPI + CALL mpi_recv (pct_dtws_prcp, 1, MPI_REAL8, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + IF (pct_dtws_prcp /= spval) THEN + write(mesg_equilibrium,'(A,F0.2,3A)') 'Total delTWS/precipitation is ', & + pct_dtws_prcp*100., '% in ', trim(timestr), '. Check history for detail.' + ELSE + write(mesg_equilibrium,'(3A)') 'Precipitation is 0 ', trim(timestr), '.' + ENDIF + + filename = trim(dir_out) // '/' // trim(casename) //'_check_equilibrium.nc' + + IF (nyearcheck == 1) THEN + + CALL ncio_create_file (trim(filename)) + + CALL ncio_define_dimension(filename, 'iyear', 0) + CALL ncio_define_dimension(filename, 'timestr', timestrlen) + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + CALL nccheck( nf90_inq_dimid(ncid, 'iyear', time_id) ) + CALL nccheck( nf90_inq_dimid(ncid, 'timestr', str_id ) ) + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_var(ncid, 'iyear', NF90_CHAR, (/str_id,time_id/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name', 'iyear in all spinup cycles') ) + CALL nccheck( nf90_enddef(ncid) ) + CALL nccheck( nf90_close(ncid) ) + +#ifndef SinglePoint + CALL ncio_define_dimension(filename, 'lat' , gcheck_concat%ginfo%nlat) + CALL ncio_define_dimension(filename, 'lon' , gcheck_concat%ginfo%nlon) + + CALL ncio_write_serial (filename, 'lat', gcheck_concat%ginfo%lat_c, 'lat') + CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') + CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') + + CALL ncio_write_serial (filename, 'lon', gcheck_concat%ginfo%lon_c, 'lon') + CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') + CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') +#else + CALL ncio_define_dimension(filename, 'patch', numpatch) +#endif + + ENDIF + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, 'iyear', varid) ) + CALL nccheck( nf90_put_var(ncid, varid, timestr(1:timestrlen), & + (/1,nyearcheck/), (/timestrlen,1/)) ) + CALL nccheck( nf90_close(ncid) ) + + ENDIF + +#ifndef SinglePoint + IF (p_is_io) CALL allocate_block_data (gridcheck, sumarea) + + CALL map_check%get_sumarea (sumarea, filter) + + IF (nyearcheck == 1) THEN + CALL map_and_write_check_var ( & + vecone, filename, 'landarea', -1, sumarea, filter, & + 'area of land excluding water bodies and glaciers in grid', 'km^2', & + amount_in_grid = .true.) + ENDIF + + CALL map_and_write_check_var ( & + dtws, filename, 'tws_change', nyearcheck, sumarea, filter, & + 'Change in terrestrial water storage', 'mm') + CALL map_and_write_check_var ( & + prcp_year, filename, 'total_precipitation', nyearcheck, sumarea, filter, & + 'total precipitation in a year', 'mm') + CALL map_and_write_check_var ( & + et_year, filename, 'total_evapotranspiration', nyearcheck, sumarea, filter, & + 'total evapotranspiration in a year', 'mm') + CALL map_and_write_check_var ( & + rnof_year, filename, 'total_runoff', nyearcheck, sumarea, filter, & + 'total runoff in a year', 'mm') + CALL map_and_write_check_var ( & + rchg_year, filename, 'total_recharge', nyearcheck, sumarea, filter, & + 'total recharge to ground water in a year', 'mm') + CALL map_and_write_check_var ( & + zwt, filename, 'zwt', nyearcheck, sumarea, filter, & + 'depth to water table', 'm') +#else + CALL ncio_write_serial_time (filename, 'tws_change', & + nyearcheck, dtws, 'patch', 'iyear') + IF (nyearcheck == 1) THEN + CALL ncio_put_attr (filename, 'tws_change', 'long_name', & + 'Change in terrestrial water storage') + CALL ncio_put_attr (filename, 'tws_change', 'units', 'mm') + CALL ncio_put_attr (filename, 'tws_change', 'missing_value', spval) + ENDIF + + CALL ncio_write_serial_time (filename, 'total_precipitation', & + nyearcheck, prcp_year, 'patch', 'iyear') + IF (nyearcheck == 1) THEN + CALL ncio_put_attr (filename, 'total_precipitation', 'long_name', & + 'total precipitation in a year') + CALL ncio_put_attr (filename, 'total_precipitation', 'units', 'mm') + CALL ncio_put_attr (filename, 'total_precipitation', 'missing_value', spval) + ENDIF + + CALL ncio_write_serial_time (filename, 'total_evapotranspiration', & + nyearcheck, et_year, 'patch', 'iyear') + IF (nyearcheck == 1) THEN + CALL ncio_put_attr (filename, 'total_evapotranspiration', 'long_name', & + 'total evapotranspiration in a year') + CALL ncio_put_attr (filename, 'total_evapotranspiration', 'units', 'mm') + CALL ncio_put_attr (filename, 'total_evapotranspiration', 'missing_value', spval) + ENDIF + + CALL ncio_write_serial_time (filename, 'total_runoff', & + nyearcheck, rnof_year, 'patch', 'iyear') + IF (nyearcheck == 1) THEN + CALL ncio_put_attr (filename, 'total_runoff', 'long_name', & + 'total runoff in a year') + CALL ncio_put_attr (filename, 'total_runoff', 'units', 'mm') + CALL ncio_put_attr (filename, 'total_runoff', 'missing_value', spval) + ENDIF + + CALL ncio_write_serial_time (filename, 'total_recharge', & + nyearcheck, rchg_year, 'patch', 'iyear') + IF (nyearcheck == 1) THEN + CALL ncio_put_attr (filename, 'total_recharge', 'long_name', & + 'total recharge to ground water in a year') + CALL ncio_put_attr (filename, 'total_recharge', 'units', 'mm') + CALL ncio_put_attr (filename, 'total_recharge', 'missing_value', spval) + ENDIF + + CALL ncio_write_serial_time (filename, 'zwt', & + nyearcheck, zwt, 'patch', 'iyear') + IF (nyearcheck == 1) THEN + CALL ncio_put_attr (filename, 'zwt', 'long_name', 'depth to water table') + CALL ncio_put_attr (filename, 'zwt', 'units', 'm') + CALL ncio_put_attr (filename, 'zwt', 'missing_value', spval) + ENDIF +#endif + ENDIF + + IF ((p_is_worker) .and. (numpatch > 0)) THEN + prcp_year(:) = spval + et_year (:) = spval + rnof_year(:) = spval + rchg_year(:) = spval + tws_last = tws_this + ENDIF + + IF (allocated(dtws )) deallocate(dtws ) + IF (allocated(filter)) deallocate(filter) + IF (allocated(vecone)) deallocate(vecone) + + ENDIF + + END SUBROUTINE CheckEquilibrium + + !----------------------------------------------------------------------- +#ifndef SinglePoint + SUBROUTINE map_and_write_check_var ( & + vector, filename, varname, itime_in_file, sumarea, filter, & + longname, units, amount_in_grid) + + USE MOD_Block + IMPLICIT NONE + + real(r8), intent(in) :: vector(:) + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + logical, intent(in), optional :: amount_in_grid + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + + ! Local variables + type(block_data_real8_2d) :: data_xy_2d + integer :: xblk, yblk, xloc, yloc, xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: rmesg(3), smesg(3), isrc + real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) + logical :: amount + + IF (p_is_io) CALL allocate_block_data (gridcheck, data_xy_2d) + CALL map_check%pset2grid (vector, data_xy_2d, spv = spval, msk = filter) + + amount = .false. + IF (present(amount_in_grid)) amount = amount_in_grid + + IF (.not. amount) THEN + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + DO yloc = 1, gridcheck%ycnt(yblk) + DO xloc = 1, gridcheck%xcnt(xblk) + + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN + IF (data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN + data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & + = data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & + / sumarea%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + ELSE + data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval + ENDIF + + ENDDO + ENDDO + + ENDDO + ENDIF + ENDIF + + check_data_id = mod(check_data_id,100) + 1 +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + + allocate (vdata (gcheck_concat%ginfo%nlon, gcheck_concat%ginfo%nlat)) + vdata(:,:) = spval + +#ifdef USEMPI + DO idata = 1, gcheck_concat%ndatablk + CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & + check_data_id, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + + xgdsp = gcheck_concat%xsegs(ixseg)%gdsp + ygdsp = gcheck_concat%ysegs(iyseg)%gdsp + xcnt = gcheck_concat%xsegs(ixseg)%cnt + ycnt = gcheck_concat%ysegs(iyseg)%cnt + + allocate (rbuf(xcnt,ycnt)) + + CALL mpi_recv (rbuf, xcnt*ycnt, MPI_REAL8, & + isrc, check_data_id, p_comm_glb, p_stat, p_err) + + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf + deallocate (rbuf) + + ENDDO +#else + DO iyseg = 1, gcheck_concat%nyseg + DO ixseg = 1, gcheck_concat%nxseg + iblk = gcheck_concat%xsegs(ixseg)%blk + jblk = gcheck_concat%ysegs(iyseg)%blk + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + xbdsp = gcheck_concat%xsegs(ixseg)%bdsp + ybdsp = gcheck_concat%ysegs(iyseg)%bdsp + xgdsp = gcheck_concat%xsegs(ixseg)%gdsp + ygdsp = gcheck_concat%ysegs(iyseg)%gdsp + xcnt = gcheck_concat%xsegs(ixseg)%cnt + ycnt = gcheck_concat%ysegs(iyseg)%cnt + + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & + data_xy_2d%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + ENDIF + ENDDO + ENDDO +#endif + + IF (itime_in_file >= 1) THEN + CALL ncio_write_serial_time (filename, varname, itime_in_file, vdata, & + 'lon', 'lat', 'iyear', compress = 1) + ELSE + CALL ncio_write_serial (filename, varname, vdata, 'lon', 'lat', compress = 1) + ENDIF + + IF (itime_in_file <= 1) THEN + CALL ncio_put_attr (filename, varname, 'long_name', longname) + CALL ncio_put_attr (filename, varname, 'units', units) + CALL ncio_put_attr (filename, varname, 'missing_value', spval) + ENDIF + + deallocate (vdata) + + ENDIF + +#ifdef USEMPI + IF (p_is_io) THEN + DO iyseg = 1, gcheck_concat%nyseg + DO ixseg = 1, gcheck_concat%nxseg + + iblk = gcheck_concat%xsegs(ixseg)%blk + jblk = gcheck_concat%ysegs(iyseg)%blk + + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + xbdsp = gcheck_concat%xsegs(ixseg)%bdsp + ybdsp = gcheck_concat%ysegs(iyseg)%bdsp + xcnt = gcheck_concat%xsegs(ixseg)%cnt + ycnt = gcheck_concat%ysegs(iyseg)%cnt + + allocate (sbuf (xcnt,ycnt)) + sbuf = data_xy_2d%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + + smesg = (/p_iam_glb, ixseg, iyseg/) + CALL mpi_send (smesg, 3, MPI_INTEGER, & + p_address_master, check_data_id, p_comm_glb, p_err) + CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, & + p_address_master, check_data_id, p_comm_glb, p_err) + + deallocate (sbuf) + + ENDIF + ENDDO + ENDDO + ENDIF +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE map_and_write_check_var +#endif + + !----------------------------------------------------------------------- + SUBROUTINE add_spv (var, s, dt) + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), intent(in) :: var(:) + real(r8), intent(inout) :: s (:) + real(r8), intent(in), optional :: dt + ! Local variables + integer :: i + + IF (present(dt)) THEN + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i)*dt + ELSE + s(i) = var(i)*dt + ENDIF + ENDIF + ENDDO + ELSE + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i) + ELSE + s(i) = var(i) + ENDIF + ENDIF + ENDDO + ENDIF + + END SUBROUTINE add_spv + +END MODULE MOD_CheckEquilibrium diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 new file mode 100644 index 0000000000..a265a0bc59 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 @@ -0,0 +1,878 @@ +#include + +MODULE MOD_Const_LC + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Constant values set for land cover types +! +! Created by Hua Yuan, 08/2019 +! +! !REVISIONS: +! 08/2019, Hua Yuan: initial version adapted from IniTimeConst.F90 of CoLM2014 +! 08/2019, Hua Yuan: added constants values for IGBP land cover types +! 05/2023, Xingjie Lu: added Plant Hydraulics Parameters +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS + + IMPLICIT NONE + SAVE + +#ifdef LULC_USGS + +! GLCC USGS Land Use/Land Cover System Legend +!----------------------------------------------------------------------- +! 0 Ocean +! 1 Urban and Built-Up Land +! 2 Dryland Cropland and Pasture +! 3 Irrigated Cropland and Pasture +! 4 Mixed Dryland/Irrigated Cropland and Pasture +! 5 Cropland/Grassland Mosaic +! 6 Cropland/Woodland Mosaic +! 7 Grassland +! 8 Shrubland +! 9 Mixed Shrubland/Grassland +!10 Savanna +!11 Deciduous Broadleaf Forest +!12 Deciduous Needleleaf Forest +!13 Evergreen Broadleaf Forest +!14 Evergreen Needleleaf Forest +!15 Mixed Forest +!16 Inland Water +!17 Herbaceous Wetland +!18 Wooded Wetland +!19 Barren or Sparsely Vegetated +!20 Herbaceous Tundra +!21 Wooded Tundra +!22 Mixed Tundra +!23 Bare Ground Tundra +!24 Snow or Ice + + character(len=256) :: patchclassname (0:N_land_classification) = & + (/'0 Ocean ', & + '1 Urban and Built-Up Land ', & + '2 Dryland Cropland and Pasture ', & + '3 Irrigated Cropland and Pasture ', & + '4 Mixed Dryland/Irrigated Cropland and Pasture', & + '5 Cropland/Grassland Mosaic ', & + '6 Cropland/Woodland Mosaic ', & + '7 Grassland ', & + '8 Shrubland ', & + '9 Mixed Shrubland/Grassland ', & + '10 Savanna ', & + '11 Deciduous Broadleaf Forest ', & + '12 Deciduous Needleleaf Forest ', & + '13 Evergreen Broadleaf Forest ', & + '14 Evergreen Needleleaf Forest ', & + '15 Mixed Forest ', & + '16 Inland Water ', & + '17 Herbaceous Wetland ', & + '18 Wooded Wetland ', & + '19 Barren or Sparsely Vegetated ', & + '20 Herbaceous Tundra ', & + '21 Wooded Tundra ', & + '22 Mixed Tundra ', & + '23 Bare Ground Tundra ', & + '24 Snow or Ice '/) + + ! land patch types + ! 0: soil, 1: urban, 2: wetland, 3: ice, 4: lake + integer , parameter, dimension(N_land_classification) :: patchtypes_usgs & + = (/1, 0, 0, 0, 0, 0, 0, 0,& + 0, 0, 0, 0, 0, 0, 0, 4,& + 2, 2, 0, 0, 0, 0, 0, 3/) + + ! Look-up table canopy top height + !NOTE: now read from input NetCDF file + !NOTE: woody wetland 35m? + ! shrub land 0.5m? grass like land 1m? all set to 0.5 + real(r8), parameter, dimension(N_land_classification) :: htop0_usgs & + !=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.5,& + ! 0.5, 1.0, 20.0, 17.0, 35.0, 17.0, 20.0, 1.0,& + ! 1.0, 35.0, 0.5, 1.0, 1.0, 1.0, 1.0, 1.0/) + =(/ 1.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5,& + 0.5, 0.5, 20.0, 17.0, 35.0, 17.0, 20.0, 0.5,& + 0.5, 17.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) + + ! Look-up table canopy bottom height + ! 01/06/2020, yuan: adjust hbot: grass/shrub -> 0, tree->1 + real(r8), parameter, dimension(N_land_classification) :: hbot0_usgs & + !=(/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.1,& + ! 0.1, 0.1, 11.5, 8.5, 1.0, 8.5, 10.0, 0.1,& + ! 0.1, 1.0, 0.1, 0.01, 0.01, 0.01, 0.01, 0.01/) + =(/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& + 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0,& + 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + + ! defulat vegetation fractional cover + real(r8), parameter, dimension(N_land_classification) :: fveg0_usgs & + = 1.0 !(/.../) + + ! Look-up table stem area index + !NOTE: now read from input NetCDF file + real(r8), parameter, dimension(N_land_classification) :: sai0_usgs & + !=(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& + ! 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& + ! 2.0, 2.0, 0.0, 0.1, 0.1, 0.1, 0.0, 0.0/) + =(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& + 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& + 0.2, 2.0, 0.2, 0.2, 0.2, 0.2, 0.0, 0.0/) + + ! ratio to calculate roughness length z0m + real(r8), parameter, dimension(N_land_classification) :: z0mr_usgs = 0.1 + + ! ratio to calculate displacement height d + real(r8), parameter, dimension(N_land_classification) :: displar_usgs = 0.667 + + ! inverse sqrt of leaf dimension [m**-0.5, m=4 cm] + real(r8), parameter, dimension(N_land_classification) :: sqrtdi_usgs = 5.0 + + ! leaf angle distribution parameter + real(r8), parameter, dimension(N_land_classification) :: chil_usgs & + = (/-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, 0.010,& + 0.010, -0.300, 0.250, 0.010, 0.100, 0.010, 0.125, -0.300,& + -0.300, 0.100, 0.010, -0.300, -0.300, -0.300, -0.300, -0.300/) + + ! reflectance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhol_vis_usgs & + = (/0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.100,& + 0.100, 0.105, 0.100, 0.070, 0.100, 0.070, 0.070, 0.105,& + 0.105, 0.100, 0.100, 0.105, 0.105, 0.105, 0.105, 0.105/) + + ! reflectance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhos_vis_usgs & + = (/0.360, 0.360, 0.360, 0.360, 0.360, 0.360, 0.360, 0.160,& + 0.160, 0.360, 0.160, 0.160, 0.160, 0.160, 0.160, 0.360,& + 0.360, 0.160, 0.160, 0.360, 0.360, 0.360, 0.360, 0.360/) + + ! reflectance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhol_nir_usgs & + = (/0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.450,& + 0.450, 0.580, 0.450, 0.350, 0.450, 0.350, 0.400, 0.580,& + 0.580, 0.450, 0.450, 0.580, 0.580, 0.580, 0.580, 0.580/) + + ! reflectance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhos_nir_usgs & + = (/0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.390,& + 0.390, 0.580, 0.390, 0.390, 0.390, 0.390, 0.390, 0.580,& + 0.580, 0.390, 0.390, 0.580, 0.580, 0.580, 0.580, 0.580/) + + ! transmittance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taul_vis_usgs & + = (/0.070, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070,& + 0.070, 0.070, 0.050, 0.050, 0.050, 0.050, 0.050, 0.070,& + 0.070, 0.050, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070/) + + ! transmittance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taus_vis_usgs & + = (/0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001,& + 0.001, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220,& + 0.220, 0.001, 0.001, 0.220, 0.220, 0.220, 0.220, 0.220/) + + ! transmittance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taul_nir_usgs & + = (/0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250,& + 0.250, 0.250, 0.250, 0.100, 0.250, 0.100, 0.150, 0.250,& + 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250/) + + ! transmittance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taus_nir_usgs & + = (/0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001,& + 0.001, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380,& + 0.380, 0.001, 0.001, 0.380, 0.380, 0.380, 0.380, 0.380/) + + ! maximum carboxylation rate at 25 C at canopy top + ! /06/03/2014/ based on Bonan et al., 2010 (Table 2) + real(r8), parameter, dimension(N_land_classification) :: vmax25_usgs & + = (/100.0, 57.0, 57.0, 57.0, 52.0, 52.0, 52.0, 52.0,& + 52.0, 52.0, 52.0, 57.0, 72.0, 54.0, 52.0, 57.0,& + 52.0, 52.0, 52.0, 52.0, 52.0, 52.0, 52.0, 52.0/) + + ! quantum efficiency + !TODO: no C4, 0.05 may have problem + real(r8), parameter, dimension(N_land_classification) :: effcon_usgs & + = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08, 0.08, 0.08, 0.05, 0.05, 0.05, 0.05, 0.05/) + + !c3c4 flag + integer, parameter, dimension(N_land_classification) :: c3c4_usgs & + = (/1, 1, 1, 1, 1, 1, 1, 1,& + 1, 1, 1, 1, 1, 1, 1, 1,& + 1, 1, 1, 0, 0, 0, 0, 0/) + + ! conductance-photosynthesis slope parameter + !TODO: no C4, 4.0 may have problem + real(r8), parameter, dimension(N_land_classification) :: g1_usgs & + = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0,& + 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0,& + 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0/) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: g0_usgs & + = (/100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100/) + + ! conductance-photosynthesis slope parameter + !TODO: no C4, 4.0 may have problem + real(r8), parameter, dimension(N_land_classification) :: gradm_usgs & + = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0, 9.0, 9.0, 4.0, 4.0, 4.0, 4.0, 4.0/) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: binter_usgs & + = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01, 0.01, 0.01, 0.04, 0.04, 0.04, 0.04, 0.04/) + + ! respiration fraction + real(r8), parameter, dimension(N_land_classification) :: respcp_usgs & + = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015, 0.015, 0.015, 0.025, 0.025, 0.025, 0.025, 0.025/) + + ! slope of high temperature inhibition FUNCTION (s1) + real(r8), parameter, dimension(N_land_classification) :: shti_usgs = 0.3 + + ! slope of low temperature inhibition FUNCTION (s3) + real(r8), parameter, dimension(N_land_classification) :: slti_usgs = 0.2 + + ! temperature coefficient in gs-a model (s5) + real(r8), parameter, dimension(N_land_classification) :: trda_usgs = 1.3 + + ! temperature coefficient in gs-a model (s6) + real(r8), parameter, dimension(N_land_classification) :: trdm_usgs = 328.0 + + ! temperature coefficient in gs-a model (273.16+25) + real(r8), parameter, dimension(N_land_classification) :: trop_usgs = 298.0 + + ! 1/2 point of high temperature inhibition FUNCTION (s2) + real(r8), parameter, dimension(N_land_classification) :: hhti_usgs & + =(/308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 313.0,& + 313.0, 308.0, 311.0, 303.0, 313.0, 303.0, 307.0, 308.0,& + 308.0, 313.0, 313.0, 313.0, 313.0, 313.0, 313.0, 308.0/) + + ! 1/2 point of low temperature inhibition FUNCTION (s4) + real(r8), parameter, dimension(N_land_classification) :: hlti_usgs & + =(/281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 283.0,& + 283.0, 281.0, 283.0, 278.0, 288.0, 278.0, 281.0, 281.0,& + 281.0, 288.0, 283.0, 288.0, 288.0, 288.0, 288.0, 281.0/) + + ! coefficient of leaf nitrogen allocation + real(r8), parameter, dimension(N_land_classification) :: extkn_usgs = 0.5 + + ! depth at 50% roots + real(r8), parameter, dimension(N_land_classification) :: d50_usgs & + =(/23.0, 21.0, 23.0, 22.0, 15.7, 19.0, 9.3, 47.0,& + 28.2, 21.7, 16.0, 16.0, 15.0, 15.0, 15.5, 1.0,& + 9.3, 15.5, 27.0, 9.0, 9.0, 9.0, 9.0, 1.0/) + + ! coefficient of root profile + real(r8), parameter, dimension(N_land_classification) :: beta_usgs & + =(/-1.757, -1.835, -1.757, -1.796, -1.577, -1.738, -1.359, -3.245,& + -2.302, -1.654, -1.681, -1.681, -1.632, -1.632, -1.656, -1.000,& + -1.359, -1.656, -2.051, -2.621, -2.621, -2.621, -2.621, -1.000/) + + ! Table 2. Zeng, 2001 + ! urban ==> cropland + ! water/glacier ==> grass + real(r8), parameter, dimension(N_land_classification) :: roota_usgs & + =(/ 5.558, 5.558, 5.558, 5.558, 8.149, 5.558, 10.740, 7.022,& + 8.881, 7.920, 5.990, 7.066, 7.344, 6.706, 4.453, 10.740,& + 10.740, 4.453, 8.992, 8.992, 8.992, 8.992, 4.372, 10.740/) + + real(r8), parameter, dimension(N_land_classification) :: rootb_usgs & + =(/ 2.614, 2.614, 2.614, 2.614, 2.611, 2.614, 2.608, 1.415,& + 2.012, 1.964, 1.955, 1.953, 1.303, 2.175, 1.631, 2.608,& + 2.608, 1.631, 8.992, 8.992, 8.992, 8.992, 0.978, 2.608/) + + ! Plant Hydraulics Parameters + real(r8), parameter, dimension(N_land_classification) :: kmax_sun0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + real(r8), parameter, dimension(N_land_classification) :: kmax_sha0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + real(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + real(r8), parameter, dimension(N_land_classification) :: kmax_root0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sun0_usgs & + = (/-150000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-150000.0,-340000.0,-347272.7,& + -150000.0,-340000.0,-342500.0,-341250.0,-150000.0,-150000.0/) *1 + + ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sha0_usgs & + = (/-150000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-150000.0,-340000.0,-347272.7,& + -150000.0,-340000.0,-342500.0,-341250.0,-150000.0,-150000.0/) *1 + + ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_usgs & + = (/-200000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-200000.0,-340000.0,-347272.7,& + -200000.0,-340000.0,-342500.0,-341250.0,-200000.0,-200000.0/) *1 + + ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_root0_usgs & + = (/-200000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-200000.0,-340000.0,-347272.7,& + -200000.0,-340000.0,-342500.0,-341250.0,-200000.0,-200000.0/)*1 + + ! shape-fitting parameter for vulnerability curve (-) + real(r8), parameter, dimension(N_land_classification) :: ck0_usgs & + = (/ 0., 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 0., 3.95, 3.95, & + 0., 3.95, 3.95, 3.95, 0., 0./) + + ! lambda for WUE stomata model + real(r8), parameter, dimension(N_land_classification) :: lambda_usgs & + = (/1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000./) +!end plant hydraulic parameters +#else + +! MODIS IGBP Land Use/Land Cover System Legend +!----------------------------------------------------------------------- +! 0 Ocean +! 1 Evergreen Needleleaf Forests +! 2 Evergreen Broadleaf Forests +! 3 Deciduous Needleleaf Forests +! 4 Deciduous Broadleaf Forests +! 5 Mixed Forests +! 6 Closed Shrublands +! 7 Open Shrublands +! 8 Woody Savannas +! 9 Savannas +!10 Grasslands +!11 Permanent Wetlands +!12 Croplands +!13 Urban and Built-up Lands +!14 Cropland/Natural Vegetation Mosaics +!15 Permanent Snow and Ice +!16 Barren +!17 Water Bodies + + character(len=256) :: patchclassname (0:N_land_classification) = & + (/'0 Ocean ', '1 Evergreen Needleleaf Forests ', & + '2 Evergreen Broadleaf Forests ', '3 Deciduous Needleleaf Forests ', & + '4 Deciduous Broadleaf Forests ', '5 Mixed Forests ', & + '6 Closed Shrublands ', '7 Open Shrublands ', & + '8 Woody Savannas ', '9 Savannas ', & + '10 Grasslands ', '11 Permanent Wetlands ', & + '12 Croplands ', '13 Urban and Built-up Lands ', & + '14 Cropland/Natural Vegetation Mosaics', '15 Permanent Snow and Ice ', & + '16 Barren ', '17 Water Bodies ' /) + + ! land patch types + ! 0: soil, 1: urban, 2: wetland, 3: ice, 4: lake + integer , parameter, dimension(N_land_classification) :: patchtypes_igbp & + = (/0, 0, 0, 0, 0, 0, 0, 0,& + 0, 0, 2, 0, 1, 0, 3, 0,& + 4 /) + + ! Look-up table canopy top height + !NOTE: now read from input NetCDF file + ! shrub land 0.5m? grass like land 1m? all set to 0.5 + real(r8), parameter, dimension(N_land_classification) :: htop0_igbp & + !=(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 1.0,& + ! 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,& + ! 1.0 /) + =(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 1.0,& + 0.5, 0.5, 0.5, 0.5, 1.0, 0.5, 0.5, 0.5,& + 0.5 /) + + ! Look-up table canopy bottom height + ! 01/06/2020, yuan: adjust hbop: grass/shrub -> 0, tree->1 + real(r8), parameter, dimension(N_land_classification) :: hbot0_igbp & + !=(/ 8.5, 1.0, 8.5, 11.5, 10.0, 0.1, 0.1, 0.1,& + ! 0.1, 0.01, 0.01, 0.01, 0.3, 0.01, 0.01, 0.01,& + ! 0.01 /) + =(/ 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0,& + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& + 0.0 /) + + ! Look-up table vegetation fractional cover + real(r8), parameter, dimension(N_land_classification) :: fveg0_igbp & + = 1.0 !(/.../) + + ! Look-up table stem area index + !NOTE: now read from input NetCDF file + real(r8), parameter, dimension(N_land_classification) :: sai0_igbp & + =(/2.0, 2.0, 2.0, 2.0, 2.0, 0.5, 0.5, 0.5,& + 0.5, 0.2, 0.2, 0.2, 0.2, 0.2, 0.0, 0.0,& + 0.0 /) + + ! ratio to calculate roughness length z0m + real(r8), parameter, dimension(N_land_classification) :: z0mr_igbp = 0.1 + + ! ratio to calculate displacement height d + real(r8), parameter, dimension(N_land_classification) :: displar_igbp = 0.667 + + ! inverse&sqrt leaf specific dimension size 4 cm + real(r8), parameter, dimension(N_land_classification) :: sqrtdi_igbp = 5.0 + + ! leaf angle distribution parameter + real(r8), parameter, dimension(N_land_classification) :: chil_igbp & + = (/ 0.010, 0.100, 0.010, 0.250, 0.125, 0.010, 0.010, 0.010,& + 0.010, -0.300, 0.100, -0.300, 0.010, -0.300, 0.010, 0.010,& + 0.010 /) + + ! reflectance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhol_vis_igbp & + = (/0.070, 0.100, 0.070, 0.100, 0.070, 0.105, 0.105, 0.105,& + 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105,& + 0.105 /) + + ! reflectance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhos_vis_igbp & + = (/0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160,& + 0.160, 0.360, 0.160, 0.360, 0.160, 0.360, 0.160, 0.160,& + 0.160 /) + + ! reflectance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhol_nir_igbp & + = (/0.350, 0.450, 0.350, 0.450, 0.400, 0.450, 0.450, 0.580,& + 0.580, 0.580, 0.450, 0.580, 0.450, 0.580, 0.450, 0.450,& + 0.580 /) + + ! reflectance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhos_nir_igbp & + = (/0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390,& + 0.390, 0.580, 0.390, 0.580, 0.390, 0.580, 0.390, 0.390,& + 0.580 /) + + ! transmittance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taul_vis_igbp & + = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050,& + 0.050, 0.070, 0.050, 0.070, 0.050, 0.070, 0.050, 0.050,& + 0.050 /) + + ! transmittance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taus_vis_igbp & + = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,& + 0.001, 0.220, 0.001, 0.220, 0.001, 0.220, 0.001, 0.001,& + 0.001 /) + + ! transmittance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taul_nir_igbp & + = (/0.100, 0.250, 0.100, 0.250, 0.150, 0.250, 0.250, 0.250,& + 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250,& + 0.250 /) + + ! transmittance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taus_nir_igbp & + = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,& + 0.001, 0.380, 0.001, 0.380, 0.001, 0.380, 0.001, 0.001,& + 0.001 /) + + ! maximum carboxylation rate at 25 C at canopy top + ! /06/03/2014/ based on Bonan et al., 2010 (Table 2) + real(r8), parameter, dimension(N_land_classification) :: vmax25_igbp & + = (/ 54.0, 72.0, 57.0, 52.0, 52.0, 52.0, 52.0, 52.0,& + 52.0, 52.0, 52.0, 57.0,100.0, 57.0, 52.0, 52.0,& + 52.0 /) + + ! quantum efficiency + !TODO: no C4 + real(r8), parameter, dimension(N_land_classification) :: effcon_igbp & + = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08 /) + + !c3c4 flag + integer, parameter, dimension(N_land_classification) :: c3c4_igbp & + = (/1, 1, 1, 1, 1, 1, 1, 1,& + 1, 1, 1, 1, 1, 1, 1, 1,& + 1 /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter, dimension(N_land_classification) :: g1_igbp & + = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0 /) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: g0_igbp & + = (/100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100,& + 100 /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter, dimension(N_land_classification) :: gradm_igbp & + = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0 /) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: binter_igbp & + = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01 /) + + ! respiration fraction + real(r8), parameter, dimension(N_land_classification) :: respcp_igbp & + = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015 /) + + ! slope of high temperature inhibition FUNCTION (s1) + real(r8), parameter, dimension(N_land_classification) :: shti_igbp = 0.3 + + ! slope of low temperature inhibition FUNCTION (s3) + real(r8), parameter, dimension(N_land_classification) :: slti_igbp = 0.2 + + ! temperature coefficient in gs-a model (s5) + real(r8), parameter, dimension(N_land_classification) :: trda_igbp = 1.3 + + ! temperature coefficient in gs-a model (s6) + real(r8), parameter, dimension(N_land_classification) :: trdm_igbp = 328.0 + + ! temperature coefficient in gs-a model (273.16+25) + real(r8), parameter, dimension(N_land_classification) :: trop_igbp = 298.0 + + ! 1/2 point of high temperature inhibition FUNCTION (s2) + real(r8), parameter, dimension(N_land_classification) :: hhti_igbp & + =(/303.0, 313.0, 303.0, 311.0, 307.0, 308.0, 313.0, 313.0,& + 313.0, 308.0, 313.0, 308.0, 308.0, 308.0, 303.0, 313.0,& + 308.0 /) + + ! 1/2 point of low temperature inhibition FUNCTION (s4) + real(r8), parameter, dimension(N_land_classification) :: hlti_igbp & + =(/278.0, 288.0, 278.0, 283.0, 281.0, 281.0, 288.0, 288.0,& + 288.0, 281.0, 283.0, 281.0, 281.0, 281.0, 278.0, 288.0,& + 281.0 /) + + ! coefficient of leaf nitrogen allocation + real(r8), parameter, dimension(N_land_classification) :: extkn_igbp = 0.5 + + ! depth at 50% roots + real(r8), parameter, dimension(N_land_classification) :: d50_igbp & + =(/15.0, 15.0, 16.0, 16.0, 15.5, 19.0, 28.0, 18.5,& + 28.0, 9.0, 9.0, 22.0, 23.0, 22.0, 1.0, 9.0,& + 1.0 /) + ! coefficient of root profile + real(r8), parameter, dimension(N_land_classification) :: beta_igbp & + =(/-1.623, -1.623, -1.681, -1.681, -1.652, -1.336, -1.909, -1.582,& + -1.798, -1.359, -1.359, -1.796, -1.757, -1.796, -1.000, -2.261,& + -1.000 /) + + ! Table 2. Zeng, 2001 + ! water/glacier ==> grass + ! urban ==> cropland + real(r8), parameter, dimension(N_land_classification) :: roota_igbp & + =(/ 6.706, 7.344, 7.066, 5.990, 4.453, 6.326, 7.718, 7.604,& + 8.235, 10.740, 10.740, 5.558, 5.558, 5.558, 10.740, 4.372,& + 10.740 /) + + real(r8), parameter, dimension(N_land_classification) :: rootb_igbp & + =(/ 2.175, 1.303, 1.953, 1.955, 1.631, 1.567, 1.262, 2.300,& + 1.627, 2.608, 2.608, 2.614, 2.614, 2.614, 2.608, 0.978,& + 2.608 /) + + ! Plant Hydraulics Parameters + real(r8), parameter, dimension(N_land_classification) :: kmax_sun0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + real(r8), parameter, dimension(N_land_classification) :: kmax_sha0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + real(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + real(r8), parameter, dimension(N_land_classification) :: kmax_root0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sun0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -150000.0, -343636.4, -150000.0, -150000.0, -150000.0/) *1 + + ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sha0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -150000.0, -343636.4, -150000.0, -150000.0, -150000.0/) *1 + + ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -200000.0, -343636.4, -200000.0, -200000.0, -200000.0/) *1 + + ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_root0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -200000.0, -343636.4, -200000.0, -200000.0, -200000.0/) *1 + + ! shape-fitting parameter for vulnerability curve (-) + real(r8), parameter, dimension(N_land_classification) :: ck0_igbp & + = (/3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 3.95, 3.95 /) + !end plant hydraulic parameters + + ! lambda for WUE stomata model + real(r8), parameter, dimension(N_land_classification) :: lambda_igbp & + = (/1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000./) +#endif + + real(r8), dimension(N_land_classification) :: & + patchtypes, &! land patch types + htop0, &! canopy top height + hbot0, &! canopy bottom height + fveg0, &! canopy vegetation fractional cover + sai0, &! canopy stem area index + chil, &! leaf angle distribution factor + z0mr, &! ratio to calculate roughness length z0m + displar, &! ratio to calculate displacement height d + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + + vmax25, &! maximum carboxylation rate at 25 C at canopy top + effcon, &! quantum efficiency + g1, &! conductance-photosynthesis slope parameter + g0, &! conductance-photosynthesis intercept + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + respcp, &! respiration fraction + shti, &! slope of high temperature inhibition function (s1) + slti, &! slope of low temperature inhibition function (s3) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273.16+25) + hhti, &! 1/2 point of high temperature inhibition function (s2) + hlti, &! 1/2 point of low temperature inhibition function (s4) + extkn, &! coefficient of leaf nitrogen allocation + + lambda, &! marginal water cost of carbon gain (mol mol-1) + + d50, &! depth at 50% roots + beta ! coefficient of root profile + + integer, dimension(N_land_classification) :: c3c4 ! c3c4 flag + +! Plant Hydraulic Parameters + real(r8), dimension(N_land_classification) :: & + kmax_sun, &! Plant Hydraulics Parameters (TODO@Xingjie Lu, please give more details) + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) +! end plant hydraulic parameters + + real(r8), PRIVATE, dimension(N_land_classification) :: & + roota, &! root fraction para + rootb ! root fraction para + + real(r8) :: & + rho(2,2,N_land_classification),&! leaf reflectance + tau(2,2,N_land_classification) ! leaf transmittance + + ! scheme 1: Schenk and Jackson, 2002, 2: Zeng 2001 + integer, PRIVATE :: ROOTFR_SCHEME = 1 + + ! fraction of roots in each soil layer + real(r8), dimension(nl_soil,N_land_classification) :: rootfr + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Init_LC_Const + +CONTAINS + + SUBROUTINE Init_LC_Const + + USE MOD_Namelist + IMPLICIT NONE + + integer :: i, nsl + +#ifdef LULC_USGS + patchtypes (:) = patchtypes_usgs (:) + htop0 (:) = htop0_usgs (:) + hbot0 (:) = hbot0_usgs (:) + fveg0 (:) = fveg0_usgs (:) + sai0 (:) = sai0_usgs (:) + z0mr (:) = z0mr_usgs (:) + displar (:) = displar_usgs (:) + sqrtdi (:) = sqrtdi_usgs (:) + chil (:) = chil_usgs (:) + vmax25 (:) = vmax25_usgs (:) * 1.e-6 + effcon (:) = effcon_usgs (:) + c3c4 (:) = c3c4_usgs (:) + g1 (:) = g1_usgs (:) + g0 (:) = g0_usgs (:) + gradm (:) = gradm_usgs (:) + binter (:) = binter_usgs (:) + respcp (:) = respcp_usgs (:) + shti (:) = shti_usgs (:) + slti (:) = slti_usgs (:) + trda (:) = trda_usgs (:) + trdm (:) = trdm_usgs (:) + trop (:) = trop_usgs (:) + hhti (:) = hhti_usgs (:) + hlti (:) = hlti_usgs (:) + extkn (:) = extkn_usgs (:) + d50 (:) = d50_usgs (:) + beta (:) = beta_usgs (:) +IF (DEF_USE_PLANTHYDRAULICS) THEN + kmax_sun (:) = kmax_sun0_usgs (:) + kmax_sha (:) = kmax_sha0_usgs (:) + kmax_xyl (:) = kmax_xyl0_usgs (:) + kmax_root (:) = kmax_root0_usgs (:) + psi50_sun (:) = psi50_sun0_usgs (:) + psi50_sha (:) = psi50_sha0_usgs (:) + psi50_xyl (:) = psi50_xyl0_usgs (:) + psi50_root (:) = psi50_root0_usgs(:) + ck (:) = ck0_usgs (:) +ENDIF +IF (DEF_USE_WUEST)THEN + lambda (:) = lambda_usgs (:) +ENDIF + roota (:) = roota_usgs (:) + rootb (:) = rootb_usgs (:) + rho (1,1,:) = rhol_vis_usgs (:) + rho (2,1,:) = rhol_nir_usgs (:) + rho (1,2,:) = rhos_vis_usgs (:) + rho (2,2,:) = rhos_nir_usgs (:) + tau (1,1,:) = taul_vis_usgs (:) + tau (2,1,:) = taul_nir_usgs (:) + tau (1,2,:) = taus_vis_usgs (:) + tau (2,2,:) = taus_nir_usgs (:) +#else + patchtypes (:) = patchtypes_igbp (:) + htop0 (:) = htop0_igbp (:) + hbot0 (:) = hbot0_igbp (:) + fveg0 (:) = fveg0_igbp (:) + sai0 (:) = sai0_igbp (:) + z0mr (:) = z0mr_igbp (:) + displar (:) = displar_igbp (:) + sqrtdi (:) = sqrtdi_igbp (:) + chil (:) = chil_igbp (:) + vmax25 (:) = vmax25_igbp (:) * 1.e-6 + effcon (:) = effcon_igbp (:) + c3c4 (:) = c3c4_igbp (:) + g1 (:) = g1_igbp (:) + g0 (:) = g0_igbp (:) + gradm (:) = gradm_igbp (:) + binter (:) = binter_igbp (:) + respcp (:) = respcp_igbp (:) + shti (:) = shti_igbp (:) + slti (:) = slti_igbp (:) + trda (:) = trda_igbp (:) + trdm (:) = trdm_igbp (:) + trop (:) = trop_igbp (:) + hhti (:) = hhti_igbp (:) + hlti (:) = hlti_igbp (:) + extkn (:) = extkn_igbp (:) + d50 (:) = d50_igbp (:) + beta (:) = beta_igbp (:) +IF(DEF_USE_PLANTHYDRAULICS)THEN + kmax_sun (:) = kmax_sun0_igbp (:) + kmax_sha (:) = kmax_sha0_igbp (:) + kmax_xyl (:) = kmax_xyl0_igbp (:) + kmax_root (:) = kmax_root0_igbp (:) + psi50_sun (:) = psi50_sun0_igbp (:) + psi50_sha (:) = psi50_sha0_igbp (:) + psi50_xyl (:) = psi50_xyl0_igbp (:) + psi50_root (:) = psi50_root0_igbp(:) + ck (:) = ck0_igbp (:) +ENDIF +IF (DEF_USE_WUEST)THEN + lambda (:) = lambda_igbp (:) +ENDIF + roota (:) = roota_igbp (:) + rootb (:) = rootb_igbp (:) + rho (1,1,:) = rhol_vis_igbp (:) + rho (2,1,:) = rhol_nir_igbp (:) + rho (1,2,:) = rhos_vis_igbp (:) + rho (2,2,:) = rhos_nir_igbp (:) + tau (1,1,:) = taul_vis_igbp (:) + tau (2,1,:) = taul_nir_igbp (:) + tau (1,2,:) = taus_vis_igbp (:) + tau (2,2,:) = taus_nir_igbp (:) +#endif + + ! ---------------------------------------------------------- + ! The definition of global root distribution is based on + ! Schenk and Jackson, 2002: The Global Biogeography of Roots. + ! Ecological Monagraph 72(3): 311-328. + ! ---------------------------------------------------------- + IF (ROOTFR_SCHEME == 1) THEN + DO i = 1, N_land_classification + rootfr(1,i)=1./(1.+(zi_soi(1)*100./d50(i))**beta(i)) + rootfr(nl_soil,i)=1.-1./(1.+(zi_soi(nl_soil-1)*100./d50(i))**beta(i)) + + DO nsl=2,nl_soil-1 + rootfr(nsl,i)=1./(1.+(zi_soi(nsl)*100./d50(i))**beta(i)) & + -1./(1.+(zi_soi(nsl-1)*100./d50(i))**beta(i)) + ENDDO + ENDDO + ELSE + DO i = 1, N_land_classification + rootfr(1,i) = 1. - 0.5*( & + exp(-roota(i) * zi_soi(1)) & + + exp(-rootb(i) * zi_soi(1)) ) + + rootfr(nl_soil,i) = 0.5*( & + exp(-roota(i) * zi_soi(nl_soil)) & + + exp(-rootb(i) * zi_soi(nl_soil)) ) + + DO nsl = 2, nl_soil-1 + rootfr(nsl,i) = 0.5*( & + exp(-roota(i) * zi_soi(nsl-1)) & + + exp(-rootb(i) * zi_soi(nsl-1)) & + - exp(-roota(i) * zi_soi(nsl)) & + - exp(-rootb(i) * zi_soi(nsl)) ) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE Init_LC_Const + +END MODULE MOD_Const_LC +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 new file mode 100644 index 0000000000..0ae52b2ce0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 @@ -0,0 +1,1817 @@ +#include + +MODULE MOD_Const_PFT + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Set constants for plant functional types (PFTs) +! +! Created by Hua Yuan, 08/2019 +! +! !REVISIONS: +! 10/2021, Xingjie Lu: added for crop PFTs +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_TimeManager, only: get_calday + + IMPLICIT NONE + SAVE + +! Plant Functional Type classification +!----------------------------------------------------------------------- +! 0 not vegetated +! 1 needleleaf evergreen temperate tree +! 2 needleleaf evergreen boreal tree +! 3 needleleaf deciduous boreal tree +! 4 broadleaf evergreen tropical tree +! 5 broadleaf evergreen temperate tree +! 6 broadleaf deciduous tropical tree +! 7 broadleaf deciduous temperate tree +! 8 broadleaf deciduous boreal tree +! 9 broadleaf evergreen shrub +!10 broadleaf deciduous temperate shrub +!11 broadleaf deciduous boreal shrub +!12 c3 arctic grass +!13 c3 non-arctic grass +!14 c4 grass +!15 c3 crop +!16 c3_irrigated +!17 temperate_corn +!18 irrigated_temperate_corn +!19 spring_wheat +!20 irrigated_spring_wheat +!21 winter_wheat +!22 irrigated_winter_wheat +!23 temperate_soybean +!24 irrigated_temperate_soybean +!25 barley +!26 irrigated_barley +!27 winter_barley +!28 irrigated_winter_barley +!29 rye +!30 irrigated_rye +!31 winter_rye +!32 irrigated_winter_rye +!33 cassava +!34 irrigated_cassava +!35 citrus +!36 irrigated_citrus +!37 cocoa +!38 irrigated_cocoa +!39 coffee +!40 irrigated_coffee +!41 cotton +!42 irrigated_cotton +!43 datepalm +!44 irrigated_datepalm +!45 foddergrass +!46 irrigated_foddergrass +!47 grapes +!48 irrigated_grapes +!49 groundnuts +!50 irrigated_groundnuts +!51 millet +!52 irrigated_millet +!53 oilpalm +!54 irrigated_oilpalm +!55 potatoes +!56 irrigated_potatoes +!57 pulses +!58 irrigated_pulses +!59 rapeseed +!60 irrigated_rapeseed +!61 rice +!62 irrigated_rice +!63 sorghum +!64 irrigated_sorghum +!65 sugarbeet +!66 irrigated_sugarbeet +!67 sugarcane +!68 irrigated_sugarcane +!69 sunflower +!70 irrigated_sunflower +!71 miscanthus +!72 irrigated_miscanthus +!73 switchgrass +!74 irrigated_switchgrass +!75 tropical_corn +!76 irrigated_tropical_corn +!77 tropical_soybean +!78 irrigated_tropical_soybean + + character(len=256) :: pftclassname (0:N_PFT+N_CFT-1) = & + (/'0 not vegetated ', '1 needleleaf evergreen temperate tree ', & + '2 needleleaf evergreen boreal tree ', '3 needleleaf deciduous boreal tree ', & + '4 broadleaf evergreen tropical tree ', '5 broadleaf evergreen temperate tree ', & + '6 broadleaf deciduous tropical tree ', '7 broadleaf deciduous temperate tree ', & + '8 broadleaf deciduous boreal tree ', '9 broadleaf evergreen shrub ', & + '10 broadleaf deciduous temperate shrub', '11 broadleaf deciduous boreal shrub ', & + '12 c3 arctic grass ', '13 c3 non-arctic grass ', & + '14 c4 grass ', '15 c3 crop ' & +#ifdef CROP + ,'16 c3_irrigated ', '17 temperate_corn ', & + '18 irrigated_temperate_corn ', '19 spring_wheat ', & + '20 irrigated_spring_wheat ', '21 winter_wheat ', & + '22 irrigated_winter_wheat ', '23 temperate_soybean ', & + '24 irrigated_temperate_soybean ', '25 barley ', & + '26 irrigated_barley ', '27 winter_barley ', & + '28 irrigated_winter_barley ', '29 rye ', & + '30 irrigated_rye ', '31 winter_rye ', & + '32 irrigated_winter_rye ', '33 cassava ', & + '34 irrigated_cassava ', '35 citrus ', & + '36 irrigated_citrus ', '37 cocoa ', & + '38 irrigated_cocoa ', '39 coffee ', & + '40 irrigated_coffee ', '41 cotton ', & + '42 irrigated_cotton ', '43 datepalm ', & + '44 irrigated_datepalm ', '45 foddergrass ', & + '46 irrigated_foddergrass ', '47 grapes ', & + '48 irrigated_grapes ', '49 groundnuts ', & + '50 irrigated_groundnuts ', '51 millet ', & + '52 irrigated_millet ', '53 oilpalm ', & + '54 irrigated_oilpalm ', '55 potatoes ', & + '56 irrigated_potatoes ', '57 pulses ', & + '58 irrigated_pulses ', '59 rapeseed ', & + '60 irrigated_rapeseed ', '61 rice ', & + '62 irrigated_rice ', '63 sorghum ', & + '64 irrigated_sorghum ', '65 sugarbeet ', & + '66 irrigated_sugarbeet ', '67 sugarcane ', & + '68 irrigated_sugarcane ', '69 sunflower ', & + '70 irrigated_sunflower ', '71 miscanthus ', & + '72 irrigated_miscanthus ', '73 switchgrass ', & + '74 irrigated_switchgrass ', '75 tropical_corn ', & + '76 irrigated_tropical_corn ', '77 tropical_soybean ', & + '78 irrigated_tropical_soybean ' & +#endif + /) + + ! canopy layer number + integer , parameter :: canlay_p(0:N_PFT+N_CFT-1) & + = (/0, 2, 2, 2, 2, 2, 2, 2 & + , 2, 1, 1, 1, 1, 1, 1, 1 & +#ifdef CROP + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1 & +#endif + /) + + ! canopy top height + real(r8), parameter :: htop0_p(0:N_PFT+N_CFT-1) & + =(/ 0.5, 17.0, 17.0, 14.0, 35.0, 35.0, 18.0, 20.0& + ,20.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& +#ifdef CROP + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 & +#endif + /) + + ! canopy bottom height + ! 01/06/2020, yuan: adjust htop: grass/shrub -> 0, tree->1 + real(r8), parameter :: hbot0_p(0:N_PFT+N_CFT-1) & + !TODO: check the setting values + !=(/0.01, 8.5, 8.5, 7.0, 1.0, 1.0, 10.0, 11.5& + ! 11.5, 0.1, 0.1, 0.1, 0.01, 0.01, 0.01, 0.01/) + =(/0.00, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0& + , 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& +#ifdef CROP + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 & +#endif + /) + + ! default vegetation fractional cover + real(r8), parameter :: fveg0_p(0:N_PFT+N_CFT-1) & + = 1.0 !(/.../) + + ! default stem area index + real(r8), parameter :: sai0_p(0:N_PFT+N_CFT-1) & + =(/0.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0& + , 2.0, 0.5, 0.5, 0.5, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + ! ratio to calculate roughness length z0m + real(r8), parameter :: z0mr_p(0:N_PFT+N_CFT-1) = 0.1 + + ! ratio to calculate displacement height d + real(r8), parameter :: displar_p(0:N_PFT+N_CFT-1) = 0.667 + + ! inverse&sqrt leaf specific dimension size 4 cm + real(r8), parameter :: sqrtdi_p(0:N_PFT+N_CFT-1) = 5.0 + + ! leaf angle distribution parameter + real(r8), parameter :: chil_p(0:N_PFT+N_CFT-1) & + = (/-0.300, 0.010, 0.010, 0.010, 0.100, 0.100, 0.010, 0.250& + , 0.250, 0.010, 0.250, 0.250, -0.300, -0.300, -0.300, -0.300& +#ifdef CROP + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300 & +#endif + /) + + ! reflectance of green leaf in visible band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & + = (/0.110, 0.070, 0.070, 0.070, 0.100, 0.110, 0.100, 0.100& + , 0.100, 0.070, 0.100, 0.100, 0.110, 0.110, 0.110, 0.110& +#else + real(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & + = (/0.110, 0.070, 0.070, 0.070, 0.100, 0.100, 0.100, 0.100& + , 0.100, 0.070, 0.100, 0.100, 0.110, 0.110, 0.110, 0.110& +#endif +#ifdef CROP + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110 & +#endif + /) + + ! reflectance of dead leaf in visible band + real(r8), parameter :: rhos_vis_p(0:N_PFT+N_CFT-1) & + = (/0.310, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160& + , 0.160, 0.160, 0.160, 0.160, 0.310, 0.310, 0.310, 0.310& +#ifdef CROP + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310 & +#endif + /) + + ! reflectance of green leaf in near infrared band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & + = (/0.350, 0.360, 0.370, 0.360, 0.450, 0.460, 0.450, 0.420& + , 0.450, 0.350, 0.450, 0.450, 0.350, 0.350, 0.350, 0.350& +#else + real(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & + = (/0.350, 0.350, 0.350, 0.350, 0.450, 0.450, 0.450, 0.450& + , 0.450, 0.350, 0.450, 0.450, 0.350, 0.350, 0.350, 0.350& +#endif +#ifdef CROP + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350 & +#endif + /) + + ! reflectance of dead leaf in near infrared band + real(r8), parameter :: rhos_nir_p(0:N_PFT+N_CFT-1) & + = (/0.530, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390& + , 0.390, 0.390, 0.390, 0.390, 0.530, 0.530, 0.530, 0.530& +#ifdef CROP + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530 & +#endif + /) + + ! transmittance of green leaf in visible band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & + = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.060, 0.050, 0.060& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& +#else + real(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & + = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& +#endif +#ifdef CROP + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050 & +#endif + /) + + ! transmittance of dead leaf in visible band + real(r8), parameter :: taus_vis_p(0:N_PFT+N_CFT-1) & + = (/0.120, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001& + , 0.001, 0.001, 0.001, 0.001, 0.120, 0.120, 0.120, 0.120& +#ifdef CROP + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120 & +#endif + /) + + ! transmittance of green leaf in near infrared band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & + = (/0.340, 0.280, 0.290, 0.380, 0.250, 0.330, 0.250, 0.430& + , 0.400, 0.100, 0.250, 0.250, 0.340, 0.340, 0.340, 0.340& +#else + real(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & + = (/0.340, 0.100, 0.100, 0.100, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.100, 0.250, 0.250, 0.340, 0.340, 0.340, 0.340& +#endif +#ifdef CROP + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340 & +#endif + /) + + ! transmittance of dead leaf in near infrared band + real(r8), parameter :: taus_nir_p(0:N_PFT+N_CFT-1) & + = (/0.250, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001& + , 0.001, 0.001, 0.001, 0.001, 0.250, 0.250, 0.250, 0.250& +#ifdef CROP + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250 & +#endif + /) + + ! maximum carboxylation rate at 25 C at canopy top + ! /06/03/2014/ based on Bonan et al., 2011 (Table 2) + !real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & + ! = (/ 52.0, 61.0, 54.0, 57.0, 72.0, 72.0, 52.0, 52.0& + ! , 52.0, 72.0, 52.0, 52.0, 52.0, 52.0, 52.0, 57.0& + ! /07/27/2022/ based on Bonan et al., 2011 (Table 2, VmaxF(N)) + ! Temporarilly tune Vegetation parameter to match VGM model (soil too wet) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & +! = (/ 52.0, 16.1, 16.5, 22.5, 12.3, 10.7, 16.2, 15.1& +! , 15.3, 21.4, 22.0, 26.6, 34.2, 20.6, 10.0, 57.0& +! = (/ 52.0, 56.0, 54.0, 57.0, 18.0, 23.0, 31.3, 36.1& +! , 52.0, 40.0, 37.5, 52.0, 52.0, 52.0, 13.4, 57.0& + = (/ 52.0, 25.2, 26.5, 34.1, 13.2, 15.7, 20.3, 24.2& + , 28.0, 33.1, 33.4, 48.5, 55.7, 41.5, 10.0, 57.0& +#ifdef CROP + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0 & +#endif + /) * 1.e-6 +#else + real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & +! = (/ 52.0, 55.0, 42.0, 29.0, 41.0, 51.0, 36.0, 30.0& +! , 40.0, 36.0, 30.0, 19.0, 21.0, 26.0, 25.0, 57.0& + = (/ 52.0, 56.0, 54.0, 57.0, 18.0, 23.0, 31.3, 36.1& + , 52.0, 40.0, 37.5, 52.0, 52.0, 52.0, 13.4, 57.0& +#ifdef CROP + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0 & +#endif + /) * 1.e-6 +#endif + + ! quantum efficiency + real(r8), parameter :: effcon_p(0:N_PFT+N_CFT-1) & + = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.05, 0.08& +#ifdef CROP + , 0.08, 0.05, 0.05, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.05, 0.05, 0.08, 0.08 & +#endif + /) + + !C3C4 switch 1: C3, 0: C4 + integer, parameter :: c3c4_p(0:N_PFT+N_CFT-1) & + = (/1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 0, 1& +#ifdef CROP + , 1, 0, 0, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 0, 0, 1, 1 & +#endif + /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter :: g1_p(0:N_PFT+N_CFT-1) & + = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& +#ifdef CROP + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0 & +#endif + /) + + ! conductance-photosynthesis intercept + real(r8), parameter :: g0_p(0:N_PFT+N_CFT-1) & + = (/100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& +#ifdef CROP + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100 & +#endif + /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter :: gradm_p(0:N_PFT+N_CFT-1) & + = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 4.0, 9.0& +#ifdef CROP + , 9.0, 4.0, 4.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& + , 9.0, 9.0, 9.0, 4.0, 4.0, 9.0, 9.0 & +#endif + /) + + ! conductance-photosynthesis intercept + real(r8), parameter :: binter_p(0:N_PFT+N_CFT-1) & + = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.04, 0.01& +#ifdef CROP + , 0.01, 0.04, 0.04, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.04, 0.04, 0.01, 0.01 & +#endif + /) + + ! respiration fraction + real(r8), parameter :: respcp_p(0:N_PFT+N_CFT-1) & + = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.025, 0.015& +#ifdef CROP + , 0.015, 0.025, 0.025, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.025, 0.025, 0.015, 0.015 & +#endif + /) + + ! slope of high temperature inhibition FUNCTION (s1) + real(r8), parameter :: shti_p(0:N_PFT+N_CFT-1) = 0.3 + + ! slope of low temperature inhibition FUNCTION (s3) + real(r8), parameter :: slti_p(0:N_PFT+N_CFT-1) = 0.2 + + ! temperature coefficient in gs-a model (s5) + real(r8), parameter :: trda_p(0:N_PFT+N_CFT-1) = 1.3 + + ! temperature coefficient in gs-a model (s6) + real(r8), parameter :: trdm_p(0:N_PFT+N_CFT-1) = 328.0 + + ! temperature coefficient in gs-a model (273.16+25) + real(r8), parameter :: trop_p(0:N_PFT+N_CFT-1) = 298.0 + + ! 1/2 point of high temperature inhibition FUNCTION (s2) + real(r8), parameter :: hhti_p(0:N_PFT+N_CFT-1) & + =(/308.0, 303.0, 303.0, 303.0, 313.0, 313.0, 311.0, 311.0& + ,311.0, 313.0, 313.0, 303.0, 303.0, 308.0, 313.0, 308.0& +#ifdef CROP + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0 & +#endif + /) + + ! 1/2 point of low temperature inhibition FUNCTION (s4) + real(r8), parameter :: hlti_p(0:N_PFT+N_CFT-1) & + =(/281.0, 278.0, 278.0, 278.0, 288.0, 288.0, 283.0, 283.0& + ,283.0, 283.0, 283.0, 278.0, 278.0, 281.0, 288.0, 281.0& +#ifdef CROP + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0 & +#endif + /) + + ! coefficient of leaf nitrogen allocation + real(r8), parameter :: extkn_p(0:N_PFT+N_CFT-1) = 0.5 + + real(r8) :: & +#ifndef CROP + rho_p(2,2,0:N_PFT-1), &!leaf reflectance + tau_p(2,2,0:N_PFT-1) !leaf transmittance +#else + rho_p(2,2,0:N_PFT+N_CFT-1), &!leaf reflectance + tau_p(2,2,0:N_PFT+N_CFT-1) !leaf transmittance +#endif + + ! depth at 50% roots + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: d50_p & + =(/27.0, 21.0, 12.0, 12.0, 15.0, 23.0, 16.0, 23.0& + ,12.0, 23.5, 23.5, 23.5, 9.0, 7.0, 16.0, 22.0& +#ifdef CROP + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0 & +#endif + /) + + ! coefficient of root profile + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: beta_p & + =(/-2.051, -1.835, -1.880, -1.880, -1.632, -1.757, -1.681, -1.757& + , -1.880, -1.623, -1.623, -1.623, -2.621, -1.176, -1.452, -1.796& +#ifdef CROP + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796 & +#endif + /) + + ! woody (1) or grass (0) + integer , parameter, dimension(0:N_PFT+N_CFT-1) :: woody & + =(/0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0 & +#ifdef CROP + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & +#endif + /) + + ! Set the root distribution parameters of PFT + real(r8), PRIVATE, parameter :: roota(0:N_PFT+N_CFT-1) & + =(/ 0.0, 7.0, 7.0, 7.0, 7.0, 7.0, 6.0, 6.0& + , 6.0, 7.0, 7.0, 7.0, 11.0, 11.0, 11.0, 6.0& +#ifdef CROP + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0 & +#endif + /) + + real(r8), PRIVATE, parameter :: rootb(0:N_PFT+N_CFT-1) & + =(/ 0.0, 2.0, 2.0, 2.0, 1.0, 1.0, 2.0, 2.0& + , 2.0, 1.5, 1.5, 1.5, 2.0, 2.0, 2.0, 3.0& +#ifdef CROP + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0 & +#endif + /) + + +! bgc PFT constants + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grperc = 0.11_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grpnow = 1._r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flab = 0.25_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_fcel = 0.5_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flig = 0.25_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flab = 0.25_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_fcel = 0.5_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flig = 0.25_r8 + + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isshrub & ! True => is a shrub + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .True., .True., .True., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isgrass & ! True => is a grass + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .True., .True., .True., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + ! True => is tropical broadleaf evergreen tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbetr & + =(/.False., .False., .False., .False., .True., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + ! True => is a broadleaf deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbdtr & + =(/.False., .False., .False., .False., .False., .False., .True., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isevg & ! True => is a evergreen tree + =(/.False., .True., .True., .False., .True., .True., .False., .False. & + , .False., .True., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + ! True => is a seasonal deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: issed & + =(/.False., .False., .False., .True., .False., .False., .False., .True. & + , .True., .False., .False., .True., .True., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isstd & ! True => is a stress deciduous tree + =(/.False., .False., .False., .False., .False., .False., .True., .False. & + , .False., .False., .True., .False., .False., .True., .True., .True. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbare & ! True => is a bare land + =(/.True., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: iscrop & ! True => is a crop land + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .True. & +#ifdef CROP + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isnatveg &! True => is a natural vegetation + =(/.False., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fsr_pft & + =(/ 0., 0.26, 0.26, 0.26, 0.25, 0.25, 0.25, 0.25 & + , 0.25, 0.28, 0.28, 0.28, 0.33, 0.33, 0.33, 0.33 & +#ifdef CROP + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fd_pft & + =(/ 0., 24., 24., 24., 24., 24., 24., 24. & + , 24., 24., 24., 24., 24., 24., 24., 24. & +#ifdef CROP + , 24., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leafcn & + =(/ 1., 58., 58., 25.8131130614352 & + , 29.603315571344, 29.603315571344, 23.4521575984991, 23.4521575984991 & + , 23.4521575984991, 36.4166059723234, 23.2558139534884, 23.2558139534884 & + , 28.0269058295964, 28.0269058295964, 35.3606789250354, 28.0269058295964 & +#ifdef CROP + , 25., 25., 25., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 25. & + , 25., 20., 20., 20. & + , 20., 20., 20., 25. & + , 25., 20., 20. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: frootcn & + =(/ 1., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& +#ifdef CROP + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: livewdcn & + =(/ 1., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 0., 0., 0., 0.& +#ifdef CROP + , 0., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: deadwdcn & + =(/ 1., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 0., 0., 0., 0.& +#ifdef CROP + , 0., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: graincn & + =(/-999., -999., -999., -999., -999., -999., -999., -999.& + , -999., -999., -999., -999., -999., -999., -999., -999.& +#ifdef CROP + , -999., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lflitcn & + =(/ 1., 70., 80., 50., 60., 60., 50., 50.& + , 50., 60., 50., 50., 50., 50., 50., 50.& +#ifdef CROP + , 50., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leaf_long & + =(/ 0., 3.30916666666667, 3.30916666666667, 0.506666666666667& + , 1.4025, 1.4025, 0.48333333333333, 0.483333333333333& + , 0.483333333333333, 1.32333333333333, 0.39, 0.39& + , 0.320833333333333, 0.32083333333333, 0.14, 0.320833333333333& +#ifdef CROP + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_leaf & + =(/ 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_lstem & + =(/ 0., 0.3, 0.3, 0.3, 0.27, 0.27, 0.27, 0.27& + , 0.27, 0.35, 0.35, 0.35, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_dstem & + =(/ 0., 0.3, 0.3, 0.3, 0.27, 0.27, 0.27, 0.27& + , 0.27, 0.35, 0.35, 0.35, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_other & + =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.45, 0.45& + , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_leaf & + =(/ 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lstem & + =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35& + , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lroot & + =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& + , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_root & + =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& + , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_droot & + =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& + , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_other & + =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35& + , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: froot_leaf & + =(/ 0., 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5& + , 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5& +#ifdef CROP + , 1., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: croot_stem & + =(/ 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3& + , 0.3, 0.3, 0.3, 0.3, 0., 0., 0., 0.& +#ifdef CROP + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: stem_leaf & + =(/ 0., 2.3, 2.3, 1., 2.3, 1.5, 1., 2.3& + , 2.3, 1.4, 0.24, 0.24, 0., 0., 0., 0.& +#ifdef CROP + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: flivewd & + =(/ 0., 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1& + , 0.1, 0.5, 0.5, 0.1, 0., 0., 0., 0.& +#ifdef CROP + , 0., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fcur2 & + =(/ 0., 1., 1., 0., 1., 1., 0., 0.& + , 0., 1., 0., 0., 0., 0., 0., 0.& +#ifdef CROP + , 0., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: dsladlai & + =(/ 0., 0.00125, 0.001, 0.003, 0.00122, 0.0015, 0.0027, 0.0027& + , 0.0027, 0., 0., 0., 0., 0., 0., 0.& +#ifdef CROP + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: slatop & + =(/ 0., 0.01222, 0.01122, 0.02432, 0.03143, 0.02728, 0.03385, 0.03541& + , 0.0447, 0.01332, 0.02255, 0.01564, 0.01077, 0.02663, 0.01983, 0.04024& +#ifdef CROP + , 0.035, 0.05, 0.05, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.05, 0.05, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.05, 0.05, 0.035, 0.035 & +#endif + /) +!--- crop variables --- + ! Max fertilizer to be applied in total (kg N/m2) + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: manure & + = (/ 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & +#ifdef CROP + , 0., 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020 & + , 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020 & + , 0.0020, 0., 0., 0., 0., 0., 0., 0. & + , 0., 0.0020, 0.0020, 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0.0020, 0.0020, 0. & + , 0., 0., 0., 0.0020, 0.0020, 0., 0., 0. & + , 0., 0., 0., 0.0020, 0.0020, 0.0020, 0.0020 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: lfemerg & ! parameter used in CNPhenology + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.11, 0.11, 0.07, 0.07, 0.03, 0.03, 0.15 & + , 0.15, 0.07, 0.07, 0.03, 0.03, 0.07, 0.07, 0.03 & + , 0.03, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.07, 0.07, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.12, 0.12, -999.9 & + , -999.9, -999.9, -999.9, 0.11, 0.11, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.11, 0.11, 0.15, 0.15 & +#endif + /) + + integer, parameter, dimension(0:N_PFT+N_CFT-1) :: mxmat & ! parameter used in CNPhenology + = (/-999, -999, -999, -999, -999, -99 , -999, -999 & + , -999, -999, -999, -999, -999, -999, -999, -999 & +#ifdef CROP + , -999, 150, 150, 150, 150, 270, 270, 150 & + , 150, 150, 150, 270, 270, 150, 150, 270 & + , 270, -999, -999, -999, -999, -999, -999, -999 & + , -999, 150, 150, -999, -999, -999, -999, -999 & + , -999, -999, -999, -999, -999, -999, -999, -999 & + , -999, -999, -999, -999, -999, 150, 150, -999 & + , -999, -999, -999, 300, 300, -999, -999, -999 & + , -999, -999, -999, 150, 150, 150, 150 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: grnfill & ! parameter used in CNPhenology + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.64, 0.64, 0.6, 0.6, 0.67, 0.67, 0.69 & + , 0.69, 0.6, 0.6, 0.67, 0.67, 0.6, 0.6, 0.67 & + , 0.67, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.6, 0.6, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.68, 0.68, -999.9 & + , -999.9, -999.9, -999.9, 0.64, 0.64, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.64, 0.64, 0.69, 0.69 & +#endif + /) + + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: baset & ! parameter used in accFlds + = (/0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & +#ifdef CROP + , 0., 8., 8., 0., 0., 0., 0., 10. & + , 10., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 10., 10., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 10., 10., 0. & + , 0., 0., 0., 10., 10., 0., 0., 0. & + , 0., 0., 0., 8., 8., 10., 10. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: astemf & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.0, 0.0, 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, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.3, 0.3, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.05, 0.05, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.0, 0.0, 0.05, 0.05 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arooti & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.4, 0.4, 0.1, 0.1, 0.1, 0.1, 0.2 & + , 0.2, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.1, 0.1, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.1, 0.1, -999.9 & + , -999.9, -999.9, -999.9, 0.4, 0.4, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.4, 0.4, 0.2, 0.2 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arootf & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.05, 0.05, 0.0, 0.0, 0.0, 0.0, 0.1 & + , 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 & + , 0.0, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.2, 0.2, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.0, 0.0, -999.9 & + , -999.9, -999.9, -999.9, 0.05, 0.05, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.05, 0.05, 0.1, 0.1 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) ::fleafi & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.8, 0.8, 0.9, 0.9, 0.9, 0.9, 0.9 & + , 0.9, 0.85, 0.85, 0.9, 0.9, 0.9, 0.9, 0.9 & + , 0.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.85, 0.85, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.75, 0.75, -999.9 & + , -999.9, -999.9, -999.9, 0.8, 0.8, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.8, 0.8, 0.85, 0.85 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: bfact & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: declfact & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconss & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 2., 2., 1., 1., 1., 1., 5. & + , 5., 1., 1., 1., 1., 1., 1., 1. & + , 1., -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 5., 5., -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 1., 1., -999.9 & + , -999.9, -999.9, -999.9, 2., 2., -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 2., 2., 5., 5. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconsl & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 5., 5., 3., 3., 3., 3., 2. & + , 2., 3., 3., 3., 3., 3., 3., 3. & + , 3., -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 2., 2., -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 3., 3., -999.9 & + , -999.9, -999.9, -999.9, 5., 5., -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 5., 5., 2., 2. & +#endif + /) + + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fleafcn & ! C:N during grain fill; leaf + = (/999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & +#ifdef CROP + , 999., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fstemcn & ! C:N during grain fill; stem + = (/999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & +#ifdef CROP + , 999., 120., 120., 100., 100., 100., 100., 130. & + , 130., 100., 100., 100., 100., 100., 100., 100. & + , 100., 999., 999., 999., 999., 999., 999., 999. & + , 999., 130., 130., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 100., 100., 999. & + , 999., 999., 999., 120., 120., 999., 999., 999. & + , 999., 999., 999., 120., 120., 130., 130. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: ffrootcn & ! C:N during grain fill; fine root + = (/999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & +#ifdef CROP + , 999., 0., 0., 40., 40., 40., 40., 0. & + , 0., 40., 40., 40., 40., 40., 40., 40. & + , 40., 999., 999., 999., 999., 999., 999., 999. & + , 999., 0., 0., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 40., 40., 999. & + , 999., 999., 999., 0., 0., 999., 999., 999. & + , 999., 999., 999., 0., 0., 0., 0. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: laimx & ! maximum leaf area index + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 5., 5., 7., 7., 7., 7., 6. & + , 6., 7., 7., 7., 7., 7., 7., 7. & + , 7., -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 6., 6., -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 7., 7., -999.9 & + , -999.9, -999.9, -999.9, 5., 5., -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 5., 5., 6., 6. & +#endif + /) +#ifdef CROP + integer, parameter, dimension(0:N_PFT+N_CFT-1) :: mergetoclmpft & ! merge crop functional types + = (/0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18 & + , 19, 20, 21, 22, 23, 24, 19, 20, 21, 22, 19, 20, 21, 22, 61, 62, 19, 20, 61 & + , 62, 61, 62, 41, 42, 41, 42, 19, 20, 19, 20, 61, 62, 75, 76, 61, 62, 19, 20 & + , 19, 20, 19, 20, 61, 62, 75, 76, 19, 20, 67, 68, 19, 20, 75, 76, 75, 76, 75 & + , 76, 77, 78/) +#endif +! end bgc variables + +! Plant Hydraulics Parameters + real(r8), parameter :: kmax_sun_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + + real(r8), parameter :: kmax_sha_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + real(r8), parameter :: kmax_xyl_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + + real(r8), parameter :: kmax_root_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + + ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), parameter :: psi50_sun_p(0:N_PFT+N_CFT-1) & + = (/-150000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), parameter :: psi50_sha_p(0:N_PFT+N_CFT-1) & + = (/-150000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), parameter :: psi50_xyl_p(0:N_PFT+N_CFT-1) & + = (/-200000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), parameter :: psi50_root_p(0:N_PFT+N_CFT-1) & + = (/-200000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! shape-fitting parameter for vulnerability curve (-) + real(r8), parameter :: ck_p(0:N_PFT+N_CFT-1) & + = (/3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& +#ifdef CROP + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& +#endif + /) +!end plant hydraulic parameters + + ! Temporally tune Vegetation parameter to match VGM model (soil too wet) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), parameter :: lambda_p(0:N_PFT+N_CFT-1) & + = (/1000., 222., 383., 467., 2500., 500., 737., 428.& + , 199., 749., 751., 200., 150., 480., 800., 1000.& +#ifdef CROP + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000.& +#endif + /) +#else + real(r8), parameter :: lambda_p(0:N_PFT+N_CFT-1) & + = (/1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& +#ifdef CROP + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000.& +#endif + /) +#endif + ! irrigation parameter for irrigated crop + logical , parameter :: irrig_crop(0:N_PFT+N_CFT-1) & + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True. & +#endif + /) + + + ! scheme 1: Schenk and Jackson, 2002, 2: Zeng 2001 + integer, PRIVATE :: ROOTFR_SCHEME = 1 + + !fraction of roots in each soil layer +#ifdef CROP + real(r8), dimension(nl_soil,N_PFT+N_CFT) :: & + rootfr_p(1:nl_soil, 0:N_PFT+N_CFT-1) +#else + real(r8), dimension(nl_soil,N_PFT) :: & + rootfr_p(1:nl_soil, 0:N_PFT-1) +#endif + + integer, PRIVATE :: i, nsl + + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Init_PFT_Const + +CONTAINS + + SUBROUTINE Init_PFT_Const + + IMPLICIT NONE + + rho_p(1,1,:) = rhol_vis_p(:) + rho_p(2,1,:) = rhol_nir_p(:) + rho_p(1,2,:) = rhos_vis_p(:) + rho_p(2,2,:) = rhos_nir_p(:) + tau_p(1,1,:) = taul_vis_p(:) + tau_p(2,1,:) = taul_nir_p(:) + tau_p(1,2,:) = taus_vis_p(:) + tau_p(2,2,:) = taus_nir_p(:) + +IF (ROOTFR_SCHEME == 1) THEN +#ifdef CROP + DO i = 0, N_PFT+N_CFT-1 +#else + DO i = 0, N_PFT-1 +#endif + rootfr_p(1,i)=1./(1.+(zi_soi(1)*100./d50_p(i))**beta_p(i)) + rootfr_p(nl_soil,i)=1.-1./(1.+(zi_soi(nl_soil-1)*100./d50_p(i))**beta_p(i)) + + DO nsl=2,nl_soil-1 + rootfr_p(nsl,i)=1./(1.+(zi_soi(nsl)*100./d50_p(i))**beta_p(i)) & + -1./(1.+(zi_soi(nsl-1)*100./d50_p(i))**beta_p(i)) + ENDDO + ENDDO +ELSE + ! PFT rootfr_p (Zeng, 2001) +#ifdef CROP + DO i = 0, N_PFT+N_CFT-1 +#else + DO i = 0, N_PFT-1 +#endif + rootfr_p(1,i) = 1. - 0.5*( & + exp(-roota(i) * zi_soi(1)) & + + exp(-rootb(i) * zi_soi(1)) ) + + rootfr_p(nl_soil,i) = 0.5*( & + exp(-roota(i) * zi_soi(nl_soil)) & + + exp(-rootb(i) * zi_soi(nl_soil)) ) + + DO nsl = 2, nl_soil-1 + rootfr_p(nsl,i) = 0.5*( & + exp(-roota(i) * zi_soi(nsl-1)) & + + exp(-rootb(i) * zi_soi(nsl-1)) & + - exp(-roota(i) * zi_soi(nsl)) & + - exp(-rootb(i) * zi_soi(nsl)) ) + ENDDO + ENDDO +ENDIF + + + END SUBROUTINE Init_PFT_Const + +END MODULE MOD_Const_PFT +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 new file mode 100644 index 0000000000..2a9e8e5b6e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 @@ -0,0 +1,30 @@ +MODULE MOD_Const_Physical + +!======================================================================= +! physical constants +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + + PUBLIC + real(r8), parameter :: denice = 917. ! density of ice [kg/m3] + real(r8), parameter :: denh2o = 1000. ! density of liquid water [kg/m3] + real(r8), parameter :: cpliq = 4188. ! Specific heat of water [J/kg/K] + real(r8), parameter :: cpice = 2117.27 ! Specific heat of ice [J/kg/K] + real(r8), parameter :: cpair = 1004.64 ! specific heat of dry air [J/kg/K] + real(r8), parameter :: hfus = 0.3336e6 ! latent heat of fusion for ice [J/kg] + real(r8), parameter :: hvap = 2.5104e6 ! latent heat of evap for water [J/kg] + real(r8), parameter :: hsub = 2.8440e6 ! latent heat of sublimation [J/kg] + real(r8), parameter :: tkair = 0.023 ! thermal conductivity of air [W/m/k] + real(r8), parameter :: tkice = 2.290 ! thermal conductivity of ice [W/m/k] + real(r8), parameter :: tkwat = 0.6 ! thermal conductivity of water [W/m/k] + real(r8), parameter :: tfrz = 273.16 ! freezing temperature [K] + real(r8), parameter :: rgas = 287.04 ! gas constant for dry air [J/kg/K] + real(r8), parameter :: roverg = 4.71047e4 ! rw/g = (8.3144/0.018)/(9.80616)*1000. mm/K + real(r8), parameter :: rwat = 461.296 ! gas constant for water vapor [J/(kg K)] + real(r8), parameter :: grav = 9.80616 ! gravity constant [m/s2] + real(r8), parameter :: vonkar = 0.4 ! von Karman constant [-] + real(r8), parameter :: stefnc = 5.67e-8 ! Stefan-Boltzmann constant [W/m2/K4] + +END MODULE MOD_Const_Physical diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 new file mode 100644 index 0000000000..93eb4f91cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 @@ -0,0 +1,377 @@ +#include + +#ifdef CROP +MODULE MOD_CropReadin + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: CROP_readin + +CONTAINS + + SUBROUTINE CROP_readin () +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Read in crop planting date from data, and fertilization from data. +! Save these data in patch vector. +! +! Original: Shupeng Zhang, Zhongwang Wei, and Xingjie Lu, 2022 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_LandPatch + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_SpatialMapping + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + + USE MOD_Vars_Global + USE MOD_LandPFT + USE MOD_Vars_PFTimeVariables + USE MOD_RangeCheck + USE MOD_Block + + IMPLICIT NONE + + character(len=256) :: file_crop + type(grid_type) :: grid_crop + type(block_data_real8_2d) :: f_xy_crop + type(spatial_mapping_type) :: mg2patch_crop + type(spatial_mapping_type) :: mg2pft_crop + character(len=256) :: file_irrig + type(grid_type) :: grid_irrig + type(block_data_int32_2d) :: f_xy_irrig + type(spatial_mapping_type) :: mg2pft_irrig + + character(len=256) :: file_irrigalloc + type(grid_type) :: grid_irrigalloc + type(block_data_real8_2d) :: f_xy_irrigalloc + type(spatial_mapping_type) :: mg2p_irrigalloc + + character(len=256) :: file_fert + type(grid_type) :: grid_fert + type(block_data_real8_2d) :: f_xy_fert + type(spatial_mapping_type) :: mg2pft_fert + + real(r8),allocatable :: pdrice2_tmp (:) + real(r8),allocatable :: plantdate_tmp (:) + real(r8),allocatable :: fertnitro_tmp (:) + integer ,allocatable :: irrig_method_tmp (:) + + real(r8),allocatable :: fertilizer_tmp (:) + real(r8),allocatable :: manure_tmp (:) + + ! Local variables + real(r8), allocatable :: lat(:), lon(:) + real(r8) :: missing_value + integer :: cft, npatch, ipft + character(len=2) :: cx + integer :: iblkme, iblk, jblk + integer :: maxvalue, minvalue + + ! READ in crops + + file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' + + CALL ncio_read_bcast_serial (file_crop, 'lat', lat) + CALL ncio_read_bcast_serial (file_crop, 'lon', lon) + + CALL grid_crop%define_by_center (lat, lon) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_crop, f_xy_crop) + ENDIF + + ! missing value + IF (p_is_master) THEN + CALL ncio_get_attr (file_crop, 'pdrice2', 'missing_value', missing_value) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + IF (p_is_io) THEN + CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) + ENDIF + + CALL mg2patch_crop%build_arealweighted (grid_crop, landpatch) + CALL mg2patch_crop%set_missing_value (f_xy_crop, missing_value) + + CALL mg2pft_crop%build_arealweighted (grid_crop, landpft) + CALL mg2pft_crop%set_missing_value (f_xy_crop, missing_value) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_worker) THEN + IF (numpatch > 0) allocate(pdrice2_tmp (numpatch)) + IF (numpft > 0) allocate(plantdate_tmp (numpft)) + IF (numpft > 0) allocate(fertnitro_tmp (numpft)) + IF (numpft > 0) allocate(irrig_method_tmp (numpft)) + ENDIF + + ! (1) Read in plant date for rice2. + file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' + IF (p_is_io) THEN + CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) + ENDIF + + CALL mg2patch_crop%grid2pset (f_xy_crop, pdrice2_tmp) + + IF (p_is_worker) THEN + DO npatch = 1, numpatch + IF (pdrice2_tmp(npatch) /= spval) THEN + pdrice2 (npatch) = int(pdrice2_tmp (npatch)) + ELSE + pdrice2 (npatch) = 0 + ENDIF + ENDDO + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('plant date value for rice2 ', pdrice2) +#endif + + ! (2) Read in plant date. + IF (p_is_worker) THEN + IF (numpft > 0) plantdate_p(:) = -99999999._r8 + ENDIF + + file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' + DO cft = 15, 78 + write(cx, '(i2.2)') cft + IF (p_is_io) THEN + CALL ncio_read_block_time (file_crop, & + 'PLANTDATE_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) + ENDIF + + CALL mg2pft_crop%grid2pset (f_xy_crop, plantdate_tmp) + + IF (p_is_worker) THEN + DO ipft = 1, numpft + IF(landpft%settyp(ipft) .eq. cft)THEN + plantdate_p(ipft) = plantdate_tmp(ipft) + IF(plantdate_p(ipft) <= 0._r8) THEN + plantdate_p(ipft) = -99999999._r8 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('plantdate_pfts value ', plantdate_p) +#endif + + ! (3) Read in fertlization + IF (DEF_FERT_SOURCE == 1) THEN + IF (p_is_worker) THEN + IF (numpft > 0) fertnitro_p(:) = -99999999._r8 + ENDIF + + file_fert = trim(DEF_dir_runtime) // '/crop/fertnitro_fillcoast.nc' + DO cft = 15, 78 + write(cx, '(i2.2)') cft + IF (p_is_io) THEN + CALL ncio_read_block_time (file_fert, & + 'CONST_FERTNITRO_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) + ENDIF + + CALL mg2pft_crop%grid2pset (f_xy_crop, fertnitro_tmp) + + IF (p_is_worker) THEN + DO ipft = 1, numpft + IF(landpft%settyp(ipft) .eq. cft)THEN + fertnitro_p(ipft) = fertnitro_tmp(ipft) + IF(fertnitro_p(ipft) <= 0._r8) THEN + fertnitro_p(ipft) = 0._r8 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + ELSEIF (DEF_FERT_SOURCE == 2)THEN + IF (p_is_worker) THEN + IF (numpft > 0) THEN + allocate(fertilizer_tmp(numpft)) + allocate(manure_tmp(numpft)) + ENDIF + ENDIF + + file_fert = trim(DEF_dir_runtime) // '/crop/fertilizer_2015soc.nc' + + CALL ncio_read_bcast_serial (file_fert, 'lat', lat) + CALL ncio_read_bcast_serial (file_fert, 'lon', lon) + CALL grid_fert%define_by_center (lat, lon) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_fert, f_xy_fert) + ENDIF + + CALL mg2pft_fert%build_arealweighted (grid_fert, landpft) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_worker) THEN + fertnitro_p(:) = -99999999._r8 + manunitro_p(:) = -99999999._r8 + ENDIF + + ! read manure + IF (p_is_io) THEN + CALL ncio_read_block (file_fert, 'manure', grid_fert, f_xy_fert) + ENDIF + + CALL mg2pft_fert%grid2pset (f_xy_fert, manure_tmp) + + IF (p_is_worker) THEN + DO ipft = 1, numpft + IF (landpft%settyp(ipft) .ge. 15) THEN + manunitro_p(ipft) = manure_tmp(ipft) + IF (manunitro_p(ipft) < 0._r8) THEN + manunitro_p(ipft) = 0._r8 + ENDIF + ENDIF + ENDDO + ENDIF + + ! read fertilizer + DO cft = 1, 64 + IF (p_is_io) THEN + CALL ncio_read_block_time (file_fert, 'fertilizer', grid_fert, cft, f_xy_fert) + ENDIF + + CALL mg2pft_fert%grid2pset (f_xy_fert, fertilizer_tmp) + + IF (p_is_worker) THEN + DO ipft = 1, numpft + IF (landpft%settyp(ipft) .eq. cft+14) THEN + fertnitro_p(ipft) = fertilizer_tmp(ipft) + IF (fertnitro_p(ipft) < 0._r8) THEN + fertnitro_p(ipft) = 0._r8 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + IF (allocated (fertilizer_tmp)) deallocate(fertilizer_tmp) + IF (allocated (manure_tmp)) deallocate(manure_tmp) + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('fert nitro value ', fertnitro_p) +#endif + + ! (4) Read in irrigation method + !file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method.nc' + file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method_96x144.nc' + + CALL ncio_read_bcast_serial (file_irrig, 'lat', lat) + CALL ncio_read_bcast_serial (file_irrig, 'lon', lon) + + CALL grid_irrig%define_by_center (lat, lon) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_irrig, f_xy_irrig) + ENDIF + + CALL mg2pft_irrig%build_arealweighted (grid_irrig, landpft) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_worker) THEN + IF (numpft > 0) irrig_method_p(:) = -99999999 + ENDIF + + DO cft = 1, N_CFT + IF (p_is_io) THEN + CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig) + ENDIF + + CALL mg2pft_irrig%grid2pset_dominant (f_xy_irrig, irrig_method_tmp) + + IF (p_is_worker) THEN + DO ipft = 1, numpft + + IF(landpft%settyp(ipft) .eq. cft + 14)THEN + irrig_method_p(ipft) = irrig_method_tmp(ipft) + IF(irrig_method_p(ipft) < 0) THEN + irrig_method_p(ipft) = -99999999 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('irrigation method ', irrig_method_p) +#endif + + IF (allocated (pdrice2_tmp )) deallocate(pdrice2_tmp ) + IF (allocated (plantdate_tmp)) deallocate(plantdate_tmp) + IF (allocated (fertnitro_tmp)) deallocate(fertnitro_tmp) + IF (allocated (irrig_method_tmp)) deallocate(irrig_method_tmp) + + IF (DEF_IRRIGATION_ALLOCATION == 3) THEN + ! (5) Read in irrigation allocated to groundwater + file_irrigalloc = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_allocation.nc' + + CALL ncio_read_bcast_serial (file_irrigalloc, 'lat', lat) + CALL ncio_read_bcast_serial (file_irrigalloc, 'lon', lon) + + CALL grid_irrigalloc%define_by_center (lat, lon) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_irrigalloc, f_xy_irrigalloc) + ENDIF + + call mg2p_irrigalloc%build_arealweighted (grid_irrigalloc, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_worker) THEN + irrig_gw_alloc(:) = 0._r8 + ENDIF + + IF (p_is_io) THEN + CALL ncio_read_block (file_irrigalloc, 'irrig_gw_alloc', grid_irrigalloc, f_xy_irrigalloc) + ENDIF + + call mg2p_irrigalloc%grid2pset (f_xy_irrigalloc, irrig_gw_alloc) + +#ifdef RangeCheck + CALL check_vector_data ('irrigation goundwater allocation ', irrig_gw_alloc) +#endif + + ! (6) Read in irrigation allocated to surfacewater + IF (p_is_worker) THEN + irrig_sw_alloc(:) = 0._r8 + ENDIF + + IF (p_is_io) THEN + CALL ncio_read_block (file_irrigalloc, 'irrig_sw_alloc', grid_irrigalloc, f_xy_irrigalloc) + ENDIF + + call mg2p_irrigalloc%grid2pset (f_xy_irrigalloc, irrig_sw_alloc) + +#ifdef RangeCheck + CALL check_vector_data ('irrigation surfacewater allocation ', irrig_sw_alloc) +#endif + ENDIF + + END SUBROUTINE CROP_readin + +END MODULE MOD_CropReadin +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 new file mode 100644 index 0000000000..333547bc1f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 @@ -0,0 +1,156 @@ +#include + +MODULE MOD_Eroot + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: eroot + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE eroot (nl_soil,trsmx0,porsl, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr, dz_soisno,t_soisno,wliq_soisno,rootr,etrc,rstfac) + +!======================================================================= +! !DESCRIPTION: +! effective root fraction and maximum possible transpiration rate +! +! Original author: Yongjiu Dai, 08/30/2002 +! +! !REVISIONS: +! 09/2021, Shupeng Zhang and Xingjie Lu: add vanGenuchten scheme to +! calculate soil water potential. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denh2o + USE MOD_Namelist, only: DEF_RSTFAC + USE MOD_Const_Physical, only: tfrz +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq, soil_vliq_from_psi +#endif + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: nl_soil ! upper bound of array + + real(r8), intent(in) :: trsmx0 ! max transpiration for moist soil+100% veg.[mm/s] + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) ! Clapp-Hornberger "B" +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil) + real(r8), intent(in) :: alpha_vgm(1:nl_soil) + real(r8), intent(in) :: n_vgm (1:nl_soil) + real(r8), intent(in) :: L_vgm (1:nl_soil) + real(r8), intent(in) :: sc_vgm (1:nl_soil) + real(r8), intent(in) :: fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: psi0(1:nl_soil) ! saturated soil suction (mm) (NEGATIVE) + real(r8), intent(in) :: rootfr(1:nl_soil) ! fraction of roots in a layer, + real(r8), intent(in) :: dz_soisno(1:nl_soil) ! layer thickness (m) + real(r8), intent(in) :: t_soisno(1:nl_soil) ! soil/snow skin temperature (K) + real(r8), intent(in) :: wliq_soisno(1:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(out) :: rootr(1:nl_soil) ! root resistance of a layer, all layers add to 1 + real(r8), intent(out) :: etrc ! maximum possible transpiration rate (mm h2o/s) + real(r8), intent(out) :: rstfac ! factor of soil water stress for photosynthesis + +!-------------------------- Local Variables ---------------------------- + + real(r8) roota ! accumulates root resistance factors + real(r8) rresis(1:nl_soil) ! soil water contribution to root resistance + real(r8) s_node ! vol_liq/porosity + real(r8) smpmax ! wilting point potential in mm + real(r8) smp_node ! matrix potential + + !new method to calculate root resistance + real(r8) :: smpswc = -1.5e5 ! soil water potential at wilting point (mm) + real(r8) :: smpsfc = -3.3e3 ! soil water potential at field capacity (mm) + real(r8) :: liqswc, liqsfc, liqsat ! liquid water content at wilting point, field capacity, and saturation (kg/m2) + + integer i ! loop counter + +!----------------------------------------------------------------------- + IF (DEF_RSTFAC == 1) THEN + ! transpiration potential(etrc) and root resistance factors (rstfac) + + roota = 1.e-10 ! must be non-zero to begin + DO i = 1, nl_soil + + IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN + smpmax = -1.5e5 + s_node = max(wliq_soisno(i)/(1000.*dz_soisno(i)*porsl(i)),0.001) + s_node = min(1., s_node) +#ifdef Campbell_SOIL_MODEL + smp_node = max(smpmax, psi0(i)*s_node**(-bsw(i))) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + smp_node = soil_psi_from_vliq ( s_node*(porsl(i)-theta_r(i)) + theta_r(i), & + porsl(i), theta_r(i), psi0(i), & + 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + smp_node = max(smpmax, smp_node) +#endif + rresis(i) =(1.-smp_node/smpmax)/(1.-psi0(i)/smpmax) + rootr(i) = rootfr(i)*rresis(i) + roota = roota + rootr(i) + ELSE + rootr(i) = 0. + ENDIF + ENDDO + ELSEIF (DEF_RSTFAC == 2) THEN + !new method to calculate root resistance + roota = 1.e-10 + DO i = 1, nl_soil + IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN +#ifdef Campbell_SOIL_MODEL + liqswc = denh2o*dz_soisno(i)*porsl(i)*((smpswc/psi0(i))**(-1/bsw(i))) + liqsfc = denh2o*dz_soisno(i)*porsl(i)*((smpsfc/psi0(i))**(-1/bsw(i))) + liqsat = denh2o*dz_soisno(i)*porsl(i) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + liqswc = soil_vliq_from_psi(smpswc, porsl(i), theta_r(i), psi0(i), 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + liqswc = denh2o*dz_soisno(i)*liqswc + liqsfc = soil_vliq_from_psi(smpsfc, porsl(i), theta_r(i), psi0(i), 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + liqsfc = denh2o*dz_soisno(i)*liqsfc + liqsat = denh2o*dz_soisno(i)*porsl(i) +#endif + rresis(i) = (wliq_soisno(i)-liqswc)/(liqsfc-liqswc) + rresis(i) = min(1.0, rresis(i)) + rresis(i) = max(0.0, rresis(i)) + rootr(i) = rootfr(i)*rresis(i) + roota = roota + rootr(i) + ELSE + rootr(i) = 0. + ENDIF + ENDDO + ENDIF + + ! normalize root resistances to get layer contribution to ET + rootr(:) = rootr(:)/roota + + ! determine maximum possible transpiration rate + etrc = trsmx0*roota + rstfac = roota + + END SUBROUTINE eroot + +END MODULE MOD_Eroot diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 new file mode 100644 index 0000000000..b03ec209d1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 @@ -0,0 +1,139 @@ +#include + +#ifdef BGC +MODULE MOD_FireData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in fire data. +! +! Original: +! 2023, Lu Xingjie and Zhang Shupeng: prepare the original version of +! the fire data module. +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_Vars_TimeInvariants, only: abm_lf, gdp_lf, peatf_lf + USE MOD_Vars_TimeVariables, only: hdm_lf + IMPLICIT NONE + + character(len=256) :: file_fire + + type(grid_type) :: grid_fire + type(spatial_mapping_type) :: mg2p_fire + +CONTAINS + + SUBROUTINE init_fire_data (YY) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open fire netcdf file from DEF_dir_runtime, read latitude and +! longitude info. Initialize fire data read in. +!----------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + type(block_data_real8_2d) :: f_xy_fire + + file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' + + CALL ncio_read_bcast_serial (file_fire, 'lat', lat) + CALL ncio_read_bcast_serial (file_fire, 'lon', lon) + + CALL grid_fire%define_by_center (lat, lon) + + CALL mg2p_fire%build_arealweighted (grid_fire, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_fire, f_xy_fire) + ENDIF + + file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' + IF (p_is_io) THEN + CALL ncio_read_block (file_fire, 'abm', grid_fire, f_xy_fire) + ENDIF + CALL mg2p_fire%grid2pset (f_xy_fire, abm_lf) +#ifdef RangeCheck + CALL check_vector_data ('abm', abm_lf) +#endif + + file_fire = trim(DEF_dir_runtime) // '/fire/peatf_colm_360x720_c100428.nc' + IF (p_is_io) THEN + CALL ncio_read_block (file_fire, 'peatf', grid_fire, f_xy_fire) + ENDIF + CALL mg2p_fire%grid2pset (f_xy_fire, peatf_lf) +#ifdef RangeCheck + CALL check_vector_data ('peatf', peatf_lf) +#endif + + file_fire = trim(DEF_dir_runtime) // '/fire/gdp_colm_360x720_c100428.nc' + IF (p_is_io) THEN + CALL ncio_read_block (file_fire, 'gdp', grid_fire, f_xy_fire) + ENDIF + CALL mg2p_fire%grid2pset (f_xy_fire, gdp_lf) +#ifdef RangeCheck + CALL check_vector_data ('gdp', gdp_lf) +#endif + + CALL update_hdm_data (YY) + + END SUBROUTINE init_fire_data + + SUBROUTINE update_hdm_data (YY) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Fire data from CLM5 dataset (month when crop fire peak +! (abm), GDP, peatland fraction (peatf), and population density +! +! Original: Xingjie Lu and Shupeng Zhang, 2022 +!----------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_DataType + USE MOD_Namelist + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY + + ! Local Variables + type(block_data_real8_2d) :: f_xy_fire + integer :: itime + + itime = max(1850,min(YY,2016)) - 1849 + + file_fire = trim(DEF_dir_runtime) & + // '/fire/colmforc.Li_2017_HYDEv3.2_CMIP6_hdm_0.5x0.5_AVHRR_simyr1850-2016_c180202.nc' + + IF (p_is_io) THEN + CALL allocate_block_data (grid_fire, f_xy_fire) + CALL ncio_read_block_time (file_fire, 'hdm', grid_fire, itime, f_xy_fire) + ENDIF + + CALL mg2p_fire%grid2pset (f_xy_fire, hdm_lf) + +#ifdef RangeCheck + CALL check_vector_data ('hdm', hdm_lf) +#endif + + END SUBROUTINE update_hdm_data + +END MODULE MOD_FireData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 new file mode 100644 index 0000000000..b20ecf5cc2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 @@ -0,0 +1,1810 @@ +#include + +MODULE MOD_Forcing + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! read in the atmospheric forcing using user defined interpolation method or +! downscaling forcing +! +! !REVISIONS: +! Yongjiu Dai and Hua Yuan, 04/2014: initial code from CoLM2014 (metdata.F90, +! GETMET.F90 and rd_forcing.F90 +! +! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version +! 2) codes for dealing with missing forcing value +! 3) interface for downscaling +! +! !TODO...(need complement) +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_UserSpecifiedForcing + USE MOD_TimeManager + USE MOD_SPMD_Task + USE MOD_MonthlyinSituCO2MaunaLoa + USE MOD_Vars_Global, only: pi + USE MOD_OrbCoszen + USE MOD_UserDefFun + + IMPLICIT NONE + + type (grid_type), PUBLIC :: gforc + + type (spatial_mapping_type) :: mg2p_forc ! area weighted mapping from forcing to model unit + + real(r8) :: forc_missing_value + logical, allocatable :: forcmask_pch (:) + + ! for Forcing_Downscaling + type(block_data_real8_2d) :: topo_grid, maxelv_grid + + type(pointer_real8_1d), allocatable :: forc_topo_grid (:) + type(pointer_real8_1d), allocatable :: forc_maxelv_grid (:) + + type(pointer_real8_1d), allocatable :: forc_t_grid (:) + type(pointer_real8_1d), allocatable :: forc_th_grid (:) + type(pointer_real8_1d), allocatable :: forc_q_grid (:) + type(pointer_real8_1d), allocatable :: forc_pbot_grid (:) + type(pointer_real8_1d), allocatable :: forc_rho_grid (:) + type(pointer_real8_1d), allocatable :: forc_prc_grid (:) + type(pointer_real8_1d), allocatable :: forc_prl_grid (:) + type(pointer_real8_1d), allocatable :: forc_lwrad_grid (:) + type(pointer_real8_1d), allocatable :: forc_swrad_grid (:) + type(pointer_real8_1d), allocatable :: forc_hgt_grid (:) + type(pointer_real8_1d), allocatable :: forc_us_grid (:) + type(pointer_real8_1d), allocatable :: forc_vs_grid (:) + + type(pointer_real8_1d), allocatable :: forc_t_part (:) + type(pointer_real8_1d), allocatable :: forc_th_part (:) + type(pointer_real8_1d), allocatable :: forc_q_part (:) + type(pointer_real8_1d), allocatable :: forc_pbot_part (:) + type(pointer_real8_1d), allocatable :: forc_rhoair_part (:) + type(pointer_real8_1d), allocatable :: forc_prc_part (:) + type(pointer_real8_1d), allocatable :: forc_prl_part (:) + type(pointer_real8_1d), allocatable :: forc_frl_part (:) + type(pointer_real8_1d), allocatable :: forc_swrad_part (:) + type(pointer_real8_1d), allocatable :: forc_us_part (:) + type(pointer_real8_1d), allocatable :: forc_vs_part (:) + + logical, allocatable :: glacierss (:) + + ! local variables + integer :: deltim_int ! model time step length + ! real(r8) :: deltim_real ! model time step length + + ! for SinglePoint + type(timestamp), allocatable :: forctime (:) + integer, allocatable :: iforctime(:) + + logical :: forcing_read_ahead + real(r8), allocatable :: forc_disk(:,:) + + type(timestamp), allocatable :: tstamp_LB(:) ! time stamp of low boundary data + type(timestamp), allocatable :: tstamp_UB(:) ! time stamp of up boundary data + + type(block_data_real8_2d) :: avgcos ! time-average of cos(zenith) + type(block_data_real8_2d) :: metdata ! forcing data +#ifdef URBAN_MODEL + type(block_data_real8_2d) :: rainf + type(block_data_real8_2d) :: snowf +#endif + + type(block_data_real8_2d), allocatable :: forcn (:) ! forcing data + type(block_data_real8_2d), allocatable :: forcn_LB (:) ! forcing data at lower boundary + type(block_data_real8_2d), allocatable :: forcn_UB (:) ! forcing data at upper boundary + + PUBLIC :: forcing_init + PUBLIC :: read_forcing + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulcc_call) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Block + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif + USE MOD_UserSpecifiedForcing + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_Vars_TimeInvariants + USE MOD_Vars_1DForcing + IMPLICIT NONE + + character(len=*), intent(in) :: dir_forcing + real(r8), intent(in) :: deltatime ! model time step + type(timestamp), intent(in) :: ststamp + integer, intent(in) :: lc_year ! which year of land cover data used + type(timestamp), intent(in), optional :: etstamp + logical, intent(in), optional :: lulcc_call ! whether it is a lulcc CALL + + ! Local variables + integer :: idate(3) + type(timestamp) :: tstamp + character(len=256) :: filename, lndname, cyear + integer :: ivar, year, month, day, time_i + integer :: ielm, istt, iend + type(block_data_real8_2d) :: areagrid + + integer :: iblkme, xblk, yblk, xloc, yloc + + CALL init_user_specified_forcing + + ! CO2 data initialization + CALL init_monthly_co2_mlo + + ! get value of fmetdat and deltim + deltim_int = int(deltatime) + ! deltim_real = deltatime + + ! set initial values + IF (allocated(tstamp_LB)) deallocate(tstamp_LB) + IF (allocated(tstamp_UB)) deallocate(tstamp_UB) + allocate (tstamp_LB(NVAR)) + allocate (tstamp_UB(NVAR)) + tstamp_LB(:) = timestamp(-1, -1, -1) + tstamp_UB(:) = timestamp(-1, -1, -1) + + idate = (/ststamp%year, ststamp%day, ststamp%sec/) + CALL adj2begin (idate) + + CALL metread_latlon (dir_forcing, idate) + + IF (p_is_io) THEN + + IF (allocated(forcn )) deallocate(forcn ) + IF (allocated(forcn_LB)) deallocate(forcn_LB) + IF (allocated(forcn_UB)) deallocate(forcn_UB) + allocate (forcn (NVAR)) + allocate (forcn_LB (NVAR)) + allocate (forcn_UB (NVAR)) + + DO ivar = 1, NVAR + CALL allocate_block_data (gforc, forcn (ivar)) + CALL allocate_block_data (gforc, forcn_LB(ivar)) + CALL allocate_block_data (gforc, forcn_UB(ivar)) + ENDDO + + ! allocate memory for forcing data + CALL allocate_block_data (gforc, metdata) ! forcing data + CALL allocate_block_data (gforc, avgcos ) ! time-average of cos(zenith) +#if (defined URBAN_MODEL && defined SinglePoint) + CALL allocate_block_data (gforc, rainf) + CALL allocate_block_data (gforc, snowf) +#endif + + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (forcmask_pch(numpatch)); forcmask_pch(:) = .true. + ENDIF + ENDIF + + IF (DEF_forcing%has_missing_value) THEN + + tstamp = idate + CALL setstampLB(tstamp, 1, year, month, day, time_i) + filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) + tstamp_LB(1) = timestamp(-1, -1, -1) + + IF (p_is_master) THEN + CALL ncio_get_attr (filename, vname(1), trim(DEF_forcing%missing_value_name), & + forc_missing_value) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (forc_missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + + CALL ncio_read_block_time (filename, vname(1), gforc, time_i, metdata) + + ENDIF + + IF (trim(DEF_Forcing_Interp_Method) == 'arealweight') THEN + IF (present(lulcc_call)) CALL mg2p_forc%forc_free_mem + CALL mg2p_forc%build_arealweighted (gforc, landpatch) + ELSEIF (trim(DEF_Forcing_Interp_Method) == 'bilinear') THEN + IF (present(lulcc_call)) CALL mg2p_forc%forc_free_mem + CALL mg2p_forc%build_bilinear (gforc, landpatch) + ENDIF + + IF (DEF_forcing%has_missing_value) THEN + CALL mg2p_forc%set_missing_value (metdata, forc_missing_value, forcmask_pch) + ENDIF + + IF (p_is_worker .and. (numpatch > 0)) THEN + forc_topo = elvmean + WHERE(forc_topo == spval) forc_topo = 0. + ENDIF + + IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN + + IF (p_is_io) CALL allocate_block_data (gforc, topo_grid) + CALL mg2p_forc%pset2grid (forc_topo, topo_grid, msk = patchmask) + + IF (p_is_io) CALL allocate_block_data (gforc, areagrid) + CALL mg2p_forc%get_sumarea(areagrid, patchmask) + CALL block_data_division (topo_grid, areagrid) + + IF (p_is_io) CALL allocate_block_data (gforc, maxelv_grid) + CALL mg2p_forc%pset2grid_max (forc_topo, maxelv_grid, msk = patchmask) + + + CALL mg2p_forc%allocate_part (forc_topo_grid ) + CALL mg2p_forc%allocate_part (forc_maxelv_grid) + + CALL mg2p_forc%allocate_part (forc_t_grid ) + CALL mg2p_forc%allocate_part (forc_th_grid ) + CALL mg2p_forc%allocate_part (forc_q_grid ) + CALL mg2p_forc%allocate_part (forc_pbot_grid ) + CALL mg2p_forc%allocate_part (forc_rho_grid ) + CALL mg2p_forc%allocate_part (forc_prc_grid ) + CALL mg2p_forc%allocate_part (forc_prl_grid ) + CALL mg2p_forc%allocate_part (forc_lwrad_grid ) + CALL mg2p_forc%allocate_part (forc_swrad_grid ) + CALL mg2p_forc%allocate_part (forc_hgt_grid ) + CALL mg2p_forc%allocate_part (forc_us_grid ) + CALL mg2p_forc%allocate_part (forc_vs_grid ) + + CALL mg2p_forc%allocate_part (forc_t_part ) + CALL mg2p_forc%allocate_part (forc_th_part ) + CALL mg2p_forc%allocate_part (forc_q_part ) + CALL mg2p_forc%allocate_part (forc_pbot_part ) + CALL mg2p_forc%allocate_part (forc_rhoair_part) + CALL mg2p_forc%allocate_part (forc_prc_part ) + CALL mg2p_forc%allocate_part (forc_prl_part ) + CALL mg2p_forc%allocate_part (forc_frl_part ) + CALL mg2p_forc%allocate_part (forc_swrad_part ) + CALL mg2p_forc%allocate_part (forc_us_part ) + CALL mg2p_forc%allocate_part (forc_vs_part ) + + CALL mg2p_forc%grid2part (topo_grid, forc_topo_grid ) + CALL mg2p_forc%grid2part (maxelv_grid, forc_maxelv_grid) + + IF (p_is_worker .and. (numpatch > 0)) THEN + allocate (glacierss(numpatch)) + glacierss(:) = patchtype(:) == 3 + ENDIF + + ENDIF + + forcing_read_ahead = .false. + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + IF (USE_SITE_ForcingReadAhead .and. present(etstamp)) THEN + forcing_read_ahead = .true. + CALL metread_time (dir_forcing, ststamp, etstamp, deltatime) + ELSE + CALL metread_time (dir_forcing) + ENDIF + allocate (iforctime(NVAR)) + ENDIF + + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + + filename = trim(dir_forcing)//trim(fprefix(1)) + +#ifndef URBAN_MODEL + IF (ncio_var_exist(filename,'reference_height_v')) THEN + CALL ncio_read_serial (filename, 'reference_height_v', Height_V) + ENDIF + + IF (ncio_var_exist(filename,'reference_height_t')) THEN + CALL ncio_read_serial (filename, 'reference_height_t', Height_T) + ENDIF + + IF (ncio_var_exist(filename,'reference_height_q')) THEN + CALL ncio_read_serial (filename, 'reference_height_q', Height_Q) + ENDIF +#else + IF (ncio_var_exist(filename,'measurement_height_above_ground')) THEN + CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_V) + CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_T) + CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_Q) + ENDIF +#endif + + ENDIF + + END SUBROUTINE forcing_init + + ! ---- forcing finalize ---- + SUBROUTINE forcing_final () + + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + IF (allocated(forcmask_pch)) deallocate(forcmask_pch) + IF (allocated(glacierss )) deallocate(glacierss ) + IF (allocated(forctime )) deallocate(forctime ) + IF (allocated(iforctime )) deallocate(iforctime ) + IF (allocated(forc_disk )) deallocate(forc_disk ) + IF (allocated(tstamp_LB )) deallocate(tstamp_LB ) + IF (allocated(tstamp_UB )) deallocate(tstamp_UB ) + + IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + CALL mg2p_forc%deallocate_part (forc_topo_grid ) + CALL mg2p_forc%deallocate_part (forc_maxelv_grid) + + CALL mg2p_forc%deallocate_part (forc_t_grid ) + CALL mg2p_forc%deallocate_part (forc_th_grid ) + CALL mg2p_forc%deallocate_part (forc_q_grid ) + CALL mg2p_forc%deallocate_part (forc_pbot_grid ) + CALL mg2p_forc%deallocate_part (forc_rho_grid ) + CALL mg2p_forc%deallocate_part (forc_prc_grid ) + CALL mg2p_forc%deallocate_part (forc_prl_grid ) + CALL mg2p_forc%deallocate_part (forc_lwrad_grid ) + CALL mg2p_forc%deallocate_part (forc_swrad_grid ) + CALL mg2p_forc%deallocate_part (forc_hgt_grid ) + CALL mg2p_forc%deallocate_part (forc_us_grid ) + CALL mg2p_forc%deallocate_part (forc_vs_grid ) + + CALL mg2p_forc%deallocate_part (forc_t_part ) + CALL mg2p_forc%deallocate_part (forc_th_part ) + CALL mg2p_forc%deallocate_part (forc_q_part ) + CALL mg2p_forc%deallocate_part (forc_pbot_part ) + CALL mg2p_forc%deallocate_part (forc_rhoair_part) + CALL mg2p_forc%deallocate_part (forc_prc_part ) + CALL mg2p_forc%deallocate_part (forc_prl_part ) + CALL mg2p_forc%deallocate_part (forc_frl_part ) + CALL mg2p_forc%deallocate_part (forc_swrad_part ) + CALL mg2p_forc%deallocate_part (forc_us_part ) + CALL mg2p_forc%deallocate_part (forc_vs_part ) + + ENDIF + ENDIF + ENDIF + + END SUBROUTINE forcing_final + + ! ------------ + SUBROUTINE forcing_reset () + + IMPLICIT NONE + + tstamp_LB(:) = timestamp(-1, -1, -1) + tstamp_UB(:) = timestamp(-1, -1, -1) + + END SUBROUTINE forcing_reset + + +!----------------------------------------------------------------------- + SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) + USE MOD_OrbCosazi + USE MOD_Precision + USE MOD_Namelist + USE MOD_Const_Physical, only: rgas, grav + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables, only: alb + USE MOD_Vars_1DForcing + USE MOD_Vars_2DForcing + USE MOD_Block + USE MOD_SPMD_Task + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandPatch + USE MOD_RangeCheck + USE MOD_UserSpecifiedForcing + USE MOD_ForcingDownscaling, only: rair, cpair, downscale_forcings, downscale_wind, downscale_wind_simple + USE MOD_NetCDFVector + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + character(len=*), intent(in) :: dir_forcing + logical, intent(in) :: is_spinup + + ! local variables: + integer :: ivar, istt, iend, id(3) + integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ipart, ne + real(r8) :: calday ! Julian cal day (1.xx to 365.xx) + real(r8) :: sunang, cloud, difrat, vnrat + real(r8) :: a, hsolar, ratio_rvrf + type(block_data_real8_2d) :: forc_xy_solarin + integer :: ii + character(10) :: cyear = "2005" + character(256):: lndname + + type(timestamp) :: mtstamp + integer :: dtLB, dtUB + real(r8) :: cosz, coszen(numpatch), cosa, cosazi(numpatch), balb + integer :: year, month, mday + logical :: has_u,has_v + real solar, frl, prcp, tm, us, vs, pres, qm + real(r8) :: pco2m + real(r8), dimension(12, numpatch) :: spaceship !NOTE: 12 is the dimension size of spaceship + integer target_server, ierr + + IF (p_is_io) THEN + !------------------------------------------------------------ + ! READ in THE ATMOSPHERIC FORCING + ! read lower and upper boundary forcing data + CALL metreadLBUB(idate, dir_forcing, is_spinup) + ! set model time stamp + id(:) = idate(:) + !CALL adj2end(id) + mtstamp = id + has_u = .true. + has_v = .true. + ! loop for variables + DO ivar = 1, NVAR + IF (ivar == 5 .and. trim(vname(ivar)) == 'NULL') has_u = .false. + IF (ivar == 6 .and. trim(vname(ivar)) == 'NULL') has_v = .false. + IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE + IF (trim(tintalgo(ivar)) == 'NULL') CYCLE + + ! to make sure the forcing data calculated is in the range of time + ! interval [LB, UB] + IF ( (mtstamp < tstamp_LB(ivar)) .or. (tstamp_UB(ivar) < mtstamp) ) THEN + write(6, *) "the data required is out of range! STOP!"; CALL CoLM_stop() + ENDIF + + ! calculate distance to lower/upper boundary + dtLB = mtstamp - tstamp_LB(ivar) + dtUB = tstamp_UB(ivar) - mtstamp + + ! linear method, for T, Pres, Q, W, LW + IF (tintalgo(ivar) == 'linear') THEN + IF ( (dtLB+dtUB) > 0 ) THEN + CALL block_data_linear_interp ( & + forcn_LB(ivar), real(dtUB,r8)/real(dtLB+dtUB,r8), & + forcn_UB(ivar), real(dtLB,r8)/real(dtLB+dtUB,r8), & + forcn(ivar)) + ELSE + CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) + ENDIF + ENDIF + + ! for precipitation, two algorithms available + ! nearest method, for precipitation + IF (tintalgo(ivar) == 'nearest') THEN + IF (dtLB <= dtUB) THEN + CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) + ELSE + CALL block_data_copy (forcn_UB(ivar), forcn(ivar)) + ENDIF + ENDIF + + ! set all the same value, for precipitation + IF (tintalgo(ivar) == 'uniform') THEN + IF (trim(timelog(ivar)) == 'forward') THEN + CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) + ELSE + CALL block_data_copy (forcn_UB(ivar), forcn(ivar)) + ENDIF + ENDIF + + ! coszen method, for SW + IF (tintalgo(ivar) == 'coszen') THEN + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) + + ilat = gforc%ydsp(jb) + j + ilon = gforc%xdsp(ib) + i + IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon + + calday = calendarday(mtstamp) + cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) + cosz = max(0.001, cosz) + ! 10/24/2024, yuan: deal with time log with backward or forward + IF (trim(timelog(ivar)) == 'forward') THEN + forcn(ivar)%blk(ib,jb)%val(i,j) = & + cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_LB(ivar)%blk(ib,jb)%val(i,j) + ELSE + forcn(ivar)%blk(ib,jb)%val(i,j) = & + cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_UB(ivar)%blk(ib,jb)%val(i,j) + ENDIF + + ENDDO + ENDDO + ENDDO + ENDIF + + ENDDO + + ! preprocess for forcing data, only for QIAN data right now? + CALL metpreprocess (gforc, forcn, & + DEF_forcing%has_missing_value, forcn_UB(1), forc_missing_value) + + CALL allocate_block_data (gforc, forc_xy_solarin) + + CALL block_data_copy (forcn(1), forc_xy_t ) + CALL block_data_copy (forcn(2), forc_xy_q ) + CALL block_data_copy (forcn(3), forc_xy_psrf ) + CALL block_data_copy (forcn(3), forc_xy_pbot ) + CALL block_data_copy (forcn(4), forc_xy_prl, sca = 2/3._r8) + CALL block_data_copy (forcn(4), forc_xy_prc, sca = 1/3._r8) + CALL block_data_copy (forcn(7), forc_xy_solarin) + CALL block_data_copy (forcn(8), forc_xy_frl ) + IF (DEF_USE_CBL_HEIGHT) THEN + CALL block_data_copy (forcn(9), forc_xy_hpbl ) + ENDIF + + IF (has_u .and. has_v) THEN + CALL block_data_copy (forcn(5), forc_xy_us ) + CALL block_data_copy (forcn(6), forc_xy_vs ) + ELSEIF (has_u) THEN + CALL block_data_copy (forcn(5), forc_xy_us , sca = 1/sqrt(2.0_r8)) + CALL block_data_copy (forcn(5), forc_xy_vs , sca = 1/sqrt(2.0_r8)) + ELSEIF (has_v) THEN + CALL block_data_copy (forcn(6), forc_xy_us , sca = 1/sqrt(2.0_r8)) + CALL block_data_copy (forcn(6), forc_xy_vs , sca = 1/sqrt(2.0_r8)) + ELSE + IF (.not.trim(DEF_forcing%dataset) == 'CPL7') THEN + write(6, *) "At least one of the wind components must be provided! STOP!"; + CALL CoLM_stop() + ENDIF + ENDIF + + CALL flush_block_data (forc_xy_hgt_u, real(HEIGHT_V,r8)) + CALL flush_block_data (forc_xy_hgt_t, real(HEIGHT_T,r8)) + CALL flush_block_data (forc_xy_hgt_q, real(HEIGHT_Q,r8)) + + IF (solarin_all_band) THEN + + IF (trim(DEF_forcing%dataset) == 'QIAN') THEN + !--------------------------------------------------------------- + ! 04/2014, yuan: NOTE! codes from CLM4.5-CESM1.2.0 + ! relationship between incoming NIR or VIS radiation and ratio of + ! direct to diffuse radiation calculated based on one year's worth of + ! hourly CAM output from CAM version cam3_5_55 + !--------------------------------------------------------------- + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) + + hsolar = forc_xy_solarin%blk(ib,jb)%val(i,j)*0.5_R8 + + ! NIR (dir, diff) + ratio_rvrf = min(0.99_R8,max(0.29548_R8 + 0.00504_R8*hsolar & + -1.4957e-05_R8*hsolar**2 + 1.4881e-08_R8*hsolar**3,0.01_R8)) + forc_xy_soll %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar + forc_xy_solld%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar + + ! VIS (dir, diff) + ratio_rvrf = min(0.99_R8,max(0.17639_R8 + 0.00380_R8*hsolar & + -9.0039e-06_R8*hsolar**2 + 8.1351e-09_R8*hsolar**3,0.01_R8)) + forc_xy_sols %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar + forc_xy_solsd%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar + + ENDDO + ENDDO + ENDDO + + ELSE + !--------------------------------------------------------------- + ! as the downward solar is in full band, an empirical expression + ! will be used to divide fractions of band and incident + ! (visible, near-infrad, dirct, diffuse) + ! Julian calday (1.xx to 365.xx) + !--------------------------------------------------------------- + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) + + IF (DEF_forcing%has_missing_value) THEN + IF (forcn_UB(1)%blk(ib,jb)%val(i,j) == forc_missing_value) THEN + CYCLE + ENDIF + ENDIF + + ilat = gforc%ydsp(jb) + j + ilon = gforc%xdsp(ib) + i + IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon + + a = max(0., forc_xy_solarin%blk(ib,jb)%val(i,j)) + calday = calendarday(idate) + sunang = orb_coszen (calday, gforc%rlon(ilon), gforc%rlat(ilat)) + + IF (sunang .eq. 0)THEN + cloud = 0. + ELSE + cloud = (1160.*sunang-a)/(963.*sunang) + ENDIF + cloud = max(cloud,0.) + cloud = min(cloud,1.) + cloud = max(0.58,cloud) + + difrat = 0.0604/(sunang-0.0223)+0.0683 + IF(difrat.lt.0.) difrat = 0. + IF(difrat.gt.1.) difrat = 1. + + difrat = difrat+(1.0-difrat)*cloud + vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.)) + + forc_xy_sols %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*vnrat + forc_xy_soll %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*(1.0-vnrat) + forc_xy_solsd%blk(ib,jb)%val(i,j) = a*difrat*vnrat + forc_xy_solld%blk(ib,jb)%val(i,j) = a*difrat*(1.0-vnrat) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + ! [GET ATMOSPHERE CO2 CONCENTRATION DATA] + year = idate(1) + CALL julian2monthday (idate(1), idate(2), month, mday) + pco2m = get_monthly_co2_mlo(year, month)*1.e-6 + CALL block_data_copy (forc_xy_pbot, forc_xy_pco2m, sca = pco2m ) + CALL block_data_copy (forc_xy_pbot, forc_xy_po2m , sca = 0.209_r8 ) + + ENDIF + + IF ((.not. DEF_USE_Forcing_Downscaling).and.(.not. DEF_USE_Forcing_Downscaling_Simple)) THEN + + ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] + ! -> the 1d vector of subgrid points [numpatch] + CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m) + CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m ) + CALL mg2p_forc%grid2pset (forc_xy_us , forc_us ) + CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs ) + + CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf ) + + CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols ) + CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll ) + CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd) + CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld) + + CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t) + CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u) + CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q) + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl) + ENDIF + + CALL mg2p_forc%grid2pset (forc_xy_t , forc_t ) + CALL mg2p_forc%grid2pset (forc_xy_q , forc_q ) + CALL mg2p_forc%grid2pset (forc_xy_prc , forc_prc ) + CALL mg2p_forc%grid2pset (forc_xy_prl , forc_prl ) + CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot ) + CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl ) + + IF (p_is_worker) THEN + + DO np = 1, numpatch + + IF (.not. forcmask_pch(np)) CYCLE + + ! The standard measuring conditions for temperature are two meters above the ground + ! Scientists have measured the most frigid temperature ever + ! recorded on the continent's eastern highlands: about (180K) colder than dry ice. + IF(forc_t(np) < 180.) forc_t(np) = 180. + ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; + ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 + IF(forc_t(np) > 326.) forc_t(np) = 326. + + forc_rhoair(np) = (forc_pbot(np) & + - 0.378*forc_q(np)*forc_pbot(np)/(0.622+0.378*forc_q(np)))& + / (rgas*forc_t(np)) + + ENDDO + + ENDIF + + ELSE + ! ------------------------------------------------------ + ! Forcing downscaling module + ! ------------------------------------------------------ + ! init forcing on patches + CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m) + CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m ) + CALL mg2p_forc%grid2pset (forc_xy_us , forc_us ) + CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs ) + CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf ) + CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols ) + CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll ) + CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd) + CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld) + CALL mg2p_forc%grid2pset (forc_xy_solarin, forc_swrad) + CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t) + CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u) + CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q) + CALL mg2p_forc%grid2pset (forc_xy_t , forc_t ) + CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot ) + CALL mg2p_forc%grid2pset (forc_xy_q , forc_q ) + CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl ) + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl) + ENDIF + + ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] + ! -> the 1d vector of subgrid points [numelm] + ! by selected mapping methods + CALL mg2p_forc%grid2part (forc_xy_t , forc_t_grid ) + CALL mg2p_forc%grid2part (forc_xy_q , forc_q_grid ) + CALL mg2p_forc%grid2part (forc_xy_prc , forc_prc_grid ) + CALL mg2p_forc%grid2part (forc_xy_prl , forc_prl_grid ) + CALL mg2p_forc%grid2part (forc_xy_pbot , forc_pbot_grid ) + CALL mg2p_forc%grid2part (forc_xy_frl , forc_lwrad_grid) + CALL mg2p_forc%grid2part (forc_xy_hgt_t, forc_hgt_grid ) + CALL mg2p_forc%grid2part (forc_xy_solarin, forc_swrad_grid) + CALL mg2p_forc%grid2part (forc_xy_us, forc_us_grid ) + CALL mg2p_forc%grid2part (forc_xy_vs, forc_vs_grid ) + + calday = calendarday(idate) + + IF (p_is_worker) THEN + DO np = 1, numpatch ! patches + + ! calculate albedo of each patches + IF (forc_sols(np)+forc_solsd(np)+forc_soll(np)+forc_solld(np) == 0.) THEN + balb = 0 + ELSE + balb = ( alb(1,1,np)*forc_sols (np) + alb(1,2,np)*forc_solsd(np) & + + alb(2,1,np)*forc_soll (np) + alb(2,2,np)*forc_solld(np) ) & + / (forc_sols(np)+forc_solsd(np)+forc_soll(np)+forc_solld(np)) + ENDIF + + DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch + + IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE + + ! The standard measuring conditions for temperature are two meters above + ! the ground. Scientists have measured the most frigid temperature ever + ! recorded on the continent's eastern highlands: about (180K) colder than + ! dry ice. + IF (forc_t_grid(np)%val(ipart) < 180.) forc_t_grid(np)%val(ipart) = 180. + ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; + ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 + IF (forc_t_grid(np)%val(ipart) > 326.) forc_t_grid(np)%val(ipart) = 326. + + forc_rho_grid(np)%val(ipart) = (forc_pbot_grid(np)%val(ipart) & + - 0.378*forc_q_grid(np)%val(ipart)*forc_pbot_grid(np)%val(ipart) & + /(0.622+0.378*forc_q_grid(np)%val(ipart)))/(rgas*forc_t_grid(np)%val(ipart)) + + forc_th_grid(np)%val(ipart) = forc_t_grid(np)%val(ipart) & + * (1.e5/forc_pbot_grid(np)%val(ipart)) ** (rair/cpair) + + ! calculate sun zenith angle and sun azimuth angle and turn to degree + coszen(np) = orb_coszen(calday, patchlonr(np), patchlatr(np)) + cosazi(np) = orb_cosazi(calday, patchlonr(np), patchlatr(np), coszen(np)) + + ! downscale forcing from grid to part + IF (DEF_USE_Forcing_Downscaling) THEN + ! Complex downscaling with topographic effects + CALL downscale_forcings ( & + glacierss(np), & + + ! non-adjusted forcing + forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), & + forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), & + forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), & + forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), & + forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), & + forc_hgt_grid(np)%val(ipart), forc_swrad_grid(np)%val(ipart), & + forc_us_grid(np)%val(ipart), forc_vs_grid(np)%val(ipart), & + + ! topography-based factor on patch + slp_type_patches(:,np), asp_type_patches(:,np), cur_patches(np), & + + ! other factors + calday, coszen(np), cosazi(np), & + + ! adjusted forcing + forc_topo(np), forc_t_part(np)%val(ipart), & + forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), & + forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), & + forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), & + + forc_frl_part(np)%val(ipart), forc_swrad_part(np)%val(ipart), & + forc_us_part(np)%val(ipart), forc_vs_part(np)%val(ipart), & + + ! optional factors for complex downscaling + area_type_patches(:,np), svf_patches(np), balb, & +#ifdef SinglePoint + sf_lut_patches (:,:,np) & +#else + sf_curve_patches(:,:,np) & +#endif + ) + + ELSEIF (DEF_USE_Forcing_Downscaling_Simple) THEN + ! Simple downscaling without optional parameters + CALL downscale_forcings ( & + glacierss(np), & + + ! non-adjusted forcing + forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), & + forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), & + forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), & + forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), & + forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), & + forc_hgt_grid(np)%val(ipart), forc_swrad_grid(np)%val(ipart), & + forc_us_grid(np)%val(ipart), forc_vs_grid(np)%val(ipart), & + + ! topography-based factor on patch + slp_type_patches(:,np), asp_type_patches(:,np), cur_patches(np), & + + ! other factors + calday, coszen(np), cosazi(np), & + + ! adjusted forcing + forc_topo(np), forc_t_part(np)%val(ipart), & + forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), & + forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), & + forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), & + + forc_frl_part(np)%val(ipart), forc_swrad_part(np)%val(ipart), & + forc_us_part(np)%val(ipart), forc_vs_part(np)%val(ipart) & + ) + + ENDIF + + ENDDO + ENDDO + ENDIF + + ! mapping parts to patches + CALL mg2p_forc%part2pset (forc_t_part, forc_t ) + CALL mg2p_forc%part2pset (forc_q_part, forc_q ) + CALL mg2p_forc%part2pset (forc_pbot_part, forc_pbot ) + CALL mg2p_forc%part2pset (forc_rhoair_part, forc_rhoair) + CALL mg2p_forc%part2pset (forc_prc_part, forc_prc ) + CALL mg2p_forc%part2pset (forc_prl_part, forc_prl ) + CALL mg2p_forc%part2pset (forc_frl_part, forc_frl ) + CALL mg2p_forc%part2pset (forc_swrad_part, forc_swrad ) + CALL mg2p_forc%part2pset (forc_us_part, forc_us ) + CALL mg2p_forc%part2pset (forc_vs_part, forc_vs ) + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + forc_psrf = forc_pbot + ENDIF + ENDIF + + ! wind downscaling + IF (p_is_worker) THEN + IF (DEF_USE_Forcing_Downscaling) THEN + DO np = 1, numpatch + IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle + CALL downscale_wind(forc_us(np), forc_vs(np), slp_type_patches(:,np), & + asp_type_patches(:,np), area_type_patches(:,np), cur_patches(np)) + ENDDO + + ELSEIF (DEF_USE_Forcing_Downscaling_Simple) THEN + DO np = 1, numpatch + IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle + CALL downscale_wind_simple(forc_us(np), forc_vs(np), slp_type_patches(:,np), & + asp_type_patches(:,np), cur_patches(np)) + ENDDO + + ENDIF + ENDIF + +#ifndef SinglePoint + IF (trim(DEF_DS_precipitation_adjust_scheme) == 'III') THEN + ! Sisi Chen, Lu Li, Yongjiu Dai et al., 2024, JGR + ! Using MPI to pass the forcing variable field to Python to + ! accomplish precipitation downscaling + IF (p_is_worker) THEN + spaceship(1,1:numpatch) = forc_topo + spaceship(2,1:numpatch) = forc_t + spaceship(3,1:numpatch) = forc_pbot + spaceship(4,1:numpatch) = forc_q + spaceship(5,1:numpatch) = forc_frl + spaceship(6,1:numpatch) = forc_swrad + spaceship(7,1:numpatch) = forc_us + spaceship(8,1:numpatch) = forc_vs + spaceship(9,1:numpatch) = INT(calday) + spaceship(10,1:numpatch) = patchlatr + spaceship(11,1:numpatch) = patchlonr + + target_server = p_iam_glb/5+p_np_glb + CALL MPI_SEND(spaceship,12*numpatch,MPI_REAL8,target_server,0,MPI_COMM_WORLD,ierr) + CALL MPI_RECV(forc_prc,numpatch,MPI_REAL8,target_server,0,MPI_COMM_WORLD,& + MPI_STATUS_IGNORE,ierr) + + forc_prl = forc_prc/3600*2/3._r8 + forc_prc = forc_prc/3600*1/3._r8 + ENDIF + ENDIF + + ! mapping forc_prl to forc_prl_part, forc_prc to forc_prc_part + IF (p_is_worker) THEN + DO np = 1, numpatch ! patches + DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch + IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE + + forc_prl_part(np)%val(ipart) = forc_prl(np) + forc_prc_part(np)%val(ipart) = forc_prc(np) + + ENDDO + ENDDO + ENDIF + + ! Conservation of convective and large scale precipitation in the grid of forcing + CALL mg2p_forc%normalize (forc_xy_prc, forc_prc_part) + CALL mg2p_forc%normalize (forc_xy_prl, forc_prl_part) + + ! mapping parts to patches + CALL mg2p_forc%part2pset (forc_prc_part, forc_prc) + CALL mg2p_forc%part2pset (forc_prl_part, forc_prl) + + ! Conservation of short- and long- waves radiation in the grid of forcing + CALL mg2p_forc%normalize (forc_xy_solarin, forc_swrad_part) + CALL mg2p_forc%normalize (forc_xy_frl, forc_frl_part ) + CALL mg2p_forc%part2pset (forc_frl_part, forc_frl ) + CALL mg2p_forc%part2pset (forc_swrad_part, forc_swrad ) +#endif + + ! divide fractions of downscaled shortwave radiation + IF (p_is_worker) THEN + DO j = 1, numpatch + a = forc_swrad(j) + IF (isnan_ud(a)) a = 0 + calday = calendarday(idate) + sunang = orb_coszen (calday, patchlonr(j), patchlatr(j)) + IF (sunang.eq.0) THEN + cloud = 0. + ELSE + cloud = (1160.*sunang-a)/(963.*sunang) + ENDIF + cloud = max(cloud,0.0001) + cloud = min(cloud,1.) + cloud = max(0.58,cloud) + + difrat = 0.0604/(sunang-0.0223)+0.0683 + IF(difrat.lt.0.) difrat = 0. + IF(difrat.gt.1.) difrat = 1. + + difrat = difrat+(1.0-difrat)*cloud + vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.)) + + forc_sols(j) = a*(1.0-difrat)*vnrat + forc_soll(j) = a*(1.0-difrat)*(1.0-vnrat) + forc_solsd(j) = a*difrat*vnrat + forc_solld(j) = a*difrat*(1.0-vnrat) + ENDDO + ENDIF + ENDIF + +#ifdef RangeCheck +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) write(*,'(/, A20)') 'Checking forcing ...' + + CALL check_vector_data ('Forcing us [m/s] ', forc_us ) + CALL check_vector_data ('Forcing vs [m/s] ', forc_vs ) + CALL check_vector_data ('Forcing t [kelvin]', forc_t ) + CALL check_vector_data ('Forcing q [kg/kg] ', forc_q ) + CALL check_vector_data ('Forcing prc [mm/s] ', forc_prc ) + CALL check_vector_data ('Forcing psrf [pa] ', forc_psrf ) + CALL check_vector_data ('Forcing prl [mm/s] ', forc_prl ) + CALL check_vector_data ('Forcing sols [W/m2] ', forc_sols ) + CALL check_vector_data ('Forcing soll [W/m2] ', forc_soll ) + CALL check_vector_data ('Forcing solsd [W/m2] ', forc_solsd) + CALL check_vector_data ('Forcing solld [W/m2] ', forc_solld) + CALL check_vector_data ('Forcing frl [W/m2] ', forc_frl ) + IF (DEF_USE_CBL_HEIGHT) THEN + CALL check_vector_data ('Forcing hpbl ', forc_hpbl ) + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif +#endif + + END SUBROUTINE read_forcing + + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! read lower and upper boundary forcing data, a major interface of this +! MODULE +! +! !REVISIONS: +! 04/2014, Hua Yuan: initial code +! +!----------------------------------------------------------------------- + SUBROUTINE metreadLBUB (idate, dir_forcing, is_spinup) + + USE MOD_UserSpecifiedForcing + USE MOD_Namelist + USE MOD_Block + USE MOD_DataType + USE MOD_Block + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: idate(3) + character(len=*), intent(in) :: dir_forcing + logical, intent(in) :: is_spinup + + ! Local variables + integer :: ivar, year, month, day, time_i + integer :: iblkme, ib, jb, i, j + type(timestamp) :: mtstamp + character(len=256) :: filename + + mtstamp = idate + + DO ivar = 1, NVAR + + IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE + + ! lower and upper boundary data already exist, CYCLE + IF ( .not.(tstamp_LB(ivar)=='NULL') .and. .not.(tstamp_UB(ivar)=='NULL') .and. & + tstamp_LB(ivar)<=mtstamp .and. mtstampendyr .or. (month>endmo .and. year==endyr) ) THEN + write(*,*) 'model year/month: ', year, month + write(*,*) 'forcing end year/month defined: ', endyr, endmo + print *, 'Warning: reaching the END of forcing data defined!' + ENDIF + + ! read forcing data + filename = trim(dir_forcing)//trim(metfilename(year, month, day, ivar, is_spinup)) + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + + IF (forcing_read_ahead) THEN + metdata%blk(gblock%xblkme(1),gblock%yblkme(1))%val = forc_disk(time_i,ivar) + ELSE +#ifndef URBAN_MODEL + CALL ncio_read_site_time (filename, vname(ivar), time_i, metdata) +#else + IF (trim(vname(ivar)) == 'Rainf') THEN + CALL ncio_read_site_time (filename, 'Rainf', time_i, rainf) + CALL ncio_read_site_time (filename, 'Snowf', time_i, snowf) + + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + metdata%blk(ib,jb)%val(1,1) = rainf%blk(ib,jb)%val(1,1) & + + snowf%blk(ib,jb)%val(1,1) + ENDDO + ELSE + CALL ncio_read_site_time (filename, vname(ivar), time_i, metdata) + ENDIF +#endif + ENDIF + ELSE + CALL ncio_read_block_time (filename, vname(ivar), gforc, time_i, metdata) + ENDIF + + CALL block_data_copy (metdata, forcn_UB(ivar)) + + ! calculate time average coszen, for shortwave radiation + IF (ivar == 7) THEN + CALL calavgcos(idate) + ENDIF + ENDIF + + ENDDO + + END SUBROUTINE metreadLBUB + + +!----------------------------------------------------------------------- + SUBROUTINE metread_latlon (dir_forcing, idate) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_UserSpecifiedForcing + USE MOD_Namelist + IMPLICIT NONE + + character(len=*), intent(in) :: dir_forcing + integer, intent(in) :: idate(3) + + ! Local variables + character(len=256) :: filename + integer :: year, month, day, time_i + type(timestamp) :: mtstamp + real(r8), allocatable :: latxy (:,:) ! latitude values in 2d + real(r8), allocatable :: lonxy (:,:) ! longitude values in 2d + real(r8), allocatable :: lon_in(:) + real(r8), allocatable :: lat_in(:) + + IF (trim(DEF_forcing%dataset) == 'POINT' .or. trim(DEF_forcing%dataset) == 'CPL7' ) THEN + CALL gforc%define_by_ndims (360, 180) + ELSE + + mtstamp = idate + + CALL setstampLB(mtstamp, 1, year, month, day, time_i) + filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) + tstamp_LB(1) = timestamp(-1, -1, -1) + + IF (dim2d) THEN + CALL ncio_read_bcast_serial (filename, latname, latxy) + CALL ncio_read_bcast_serial (filename, lonname, lonxy) + + allocate (lat_in (size(latxy,2))) + allocate (lon_in (size(lonxy,1))) + lat_in = latxy(1,:) + lon_in = lonxy(:,1) + + deallocate (latxy) + deallocate (lonxy) + ELSE + CALL ncio_read_bcast_serial (filename, latname, lat_in) + CALL ncio_read_bcast_serial (filename, lonname, lon_in) + ENDIF + + IF (.not. DEF_forcing%regional) THEN + CALL gforc%define_by_center (lat_in, lon_in) + ELSE + CALL gforc%define_by_center (lat_in, lon_in, & + south = DEF_forcing%regbnd(1), north = DEF_forcing%regbnd(2), & + west = DEF_forcing%regbnd(3), east = DEF_forcing%regbnd(4)) + ENDIF + + deallocate (lat_in) + deallocate (lon_in) + ENDIF + + CALL gforc%set_rlon () + CALL gforc%set_rlat () + + END SUBROUTINE metread_latlon + +!----------------------------------------------------------------------- + SUBROUTINE metread_time (dir_forcing, ststamp, etstamp, deltime) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_UserSpecifiedForcing + USE MOD_Namelist + IMPLICIT NONE + + character(len=*), intent(in) :: dir_forcing + type(timestamp), intent(in), optional :: ststamp, etstamp + real(r8), intent(in), optional :: deltime + + ! Local variables + character(len=256) :: filename + character(len=256) :: timeunit, timestr + real(r8), allocatable :: forctime_sec(:), metcache(:,:,:) + integer :: year, month, day, hour, minute, second + integer :: itime, maxday, id(3) + integer*8 :: sec_long + integer :: ivar, ntime, its, ite, it + real(r8) firstsec + + type(timestamp) :: etstamp_f + type(timestamp), allocatable :: forctime_ (:) + + + filename = trim(dir_forcing)//trim(fprefix(1)) + + CALL ncio_read_serial (filename, 'time', forctime_sec) + CALL ncio_get_attr (filename, 'time', 'units', timeunit) + + timestr = timeunit(15:18) // ' ' // timeunit(20:21) // ' ' // timeunit(23:24) & + // ' ' // timeunit(26:27) // ' ' // timeunit(29:30) // ' ' // timeunit(32:33) + read(timestr,*) year, month, day, hour, minute, second + + allocate (forctime (size(forctime_sec))) + + id(1) = year + id(2) = get_calday(month*100+day, isleapyear(year)) + id(3) = hour*3600 + minute*60 + second + + firstsec = forctime_sec(1) + DO WHILE (firstsec > 86400) + CALL ticktime (86400., id) + firstsec = firstsec - 86400 + ENDDO + CALL ticktime (firstsec, id) + + !forctime(1)%year = year + !forctime(1)%day = get_calday(month*100+day, isleapyear(year)) + !forctime(1)%sec = hour*3600 + minute*60 + second + forctime_sec(1) + + !id(:) = (/forctime(1)%year, forctime(1)%day, forctime(1)%sec/) + CALL adj2end(id) + forctime(1) = id + + ntime = size(forctime) + + DO itime = 2, ntime + id(:) = (/forctime(itime-1)%year, forctime(itime-1)%day, forctime(itime-1)%sec/) + CALL ticktime (forctime_sec(itime)-forctime_sec(itime-1), id) + forctime(itime) = id + ENDDO + + IF (forcing_read_ahead) THEN + + CALL ticktime (deltime, id) + etstamp_f = id + + IF ((ststamp < forctime(1)) .or. (etstamp_f < etstamp)) THEN + write(*,*) 'Error: Forcing does not cover simulation period!' + write(*,*) 'Model start ', ststamp, ' -> Model END ', etstamp + write(*,*) 'Forc start ', forctime(1), ' -> Forc END ', etstamp_f + CALL CoLM_stop () + ELSE + its = 1 + DO WHILE (.not. (ststamp < forctime(its+1))) + its = its + 1 + IF (its >= ntime) EXIT + ENDDO + + ite = ntime + DO WHILE (etstamp < forctime(ite-1)) + ite = ite - 1 + IF (ite <= 1) EXIT + ENDDO + + ntime = ite-its+1 + + allocate (forctime_(ntime)) + DO it = 1, ntime + forctime_(it) = forctime(it+its-1) + ENDDO + + deallocate (forctime) + allocate (forctime (ntime)) + DO it = 1, ntime + forctime(it) = forctime_(it) + ENDDO + + deallocate(forctime_) + ENDIF + + allocate (forc_disk (size(forctime),NVAR)) + + filename = trim(dir_forcing)//trim(metfilename(-1,-1,-1,-1)) + DO ivar = 1, NVAR + IF (trim(vname(ivar)) /= 'NULL') THEN +#ifndef URBAN_MODEL + CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache) + forc_disk(:,ivar) = metcache(1,1,:) +#else + IF (trim(vname(ivar)) == 'Rainf') THEN + CALL ncio_read_period_serial (filename, 'Rainf', its, ite, metcache) + forc_disk(:,ivar) = metcache(1,1,:) + + CALL ncio_read_period_serial (filename, 'Snowf', its, ite, metcache) + forc_disk(:,ivar) = forc_disk(:,ivar) + metcache(1,1,:) + ELSE + CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache) + forc_disk(:,ivar) = metcache(1,1,:) + ENDIF +#endif + ENDIF + ENDDO + + IF (allocated(metcache)) deallocate(metcache) + ENDIF + + END SUBROUTINE metread_time + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! set the lower boundary time stamp and record information, +! a KEY FUNCTION of this MODULE +! +! - for time stamp, set it regularly as the model time step. +! - for record information, account for: +! o year alternation +! o month alternation +! o leap year +! o required data just beyond the first record +! +! !REVISIONS: +! 04/2014, Hua Yuan: initial code +! +!----------------------------------------------------------------------- + SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) + + IMPLICIT NONE + type(timestamp), intent(in) :: mtstamp + integer, intent(in) :: var_i + integer, intent(out) :: year + integer, intent(out) :: month + integer, intent(out) :: mday + integer, intent(out) :: time_i + + integer :: i, day, sec, ntime + integer :: months(0:12) + + year = mtstamp%year + day = mtstamp%day + sec = mtstamp%sec + + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + + ntime = size(forctime) + time_i = 1 + + IF ((mtstamp < forctime(1)) .or. (forctime(ntime) < mtstamp)) THEN + write(*,*) 'Error: Forcing does not cover simulation period!' + write(*,*) 'Need ', mtstamp, ', Forc start ', forctime(1), ', Forc END', forctime(ntime) + CALL CoLM_stop () + ELSE + DO WHILE (.not. (mtstamp < forctime(time_i+1))) + time_i = time_i + 1 + ENDDO + iforctime(var_i) = time_i + tstamp_LB(var_i) = forctime(iforctime(var_i)) + ENDIF + + RETURN + ENDIF + + tstamp_LB(var_i)%year = year + tstamp_LB(var_i)%day = day + + ! in the case of one year one file + IF ( trim(groupby) == 'year' ) THEN + + ! calculate the initial second + sec = 86400*(day-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(day-1) + tstamp_LB(var_i)%sec = sec + + ! set time stamp (ststamp_LB) + IF (sec < 0) THEN + tstamp_LB(var_i)%sec = 86400 + sec + tstamp_LB(var_i)%day = day - 1 + IF (tstamp_LB(var_i)%day == 0) THEN + tstamp_LB(var_i)%year = year - 1 + IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN + tstamp_LB(var_i)%day = 366 + ELSE + tstamp_LB(var_i)%day = 365 + ENDIF + ENDIF + ENDIF + + ! set record info (year, time_i) + IF ( sec<0 .or. (sec==0 .and. offset(var_i).NE.0) ) THEN + + ! IF the required data just behind the first record + ! -> set to the first record + IF ( year==startyr .and. month==startmo .and. day==1 ) THEN + sec = offset(var_i) + + ! ELSE, set to one record backward + ELSE + sec = 86400 + sec + day = day - 1 + IF (day == 0) THEN + year = year - 1 + IF ( isleapyear(year) ) THEN + day = 366 + ELSE + day = 365 + ENDIF + ENDIF + ENDIF + ENDIF ! ENDIF (sec <= 0) + + ! in case of leapyear with a non-leapyear calendar + ! USE the data 1 day before after FEB 28th (Julian day 59). + IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN + day = day - 1 + ENDIF + + ! get record time index + sec = 86400*(day-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + ! in the case of one month one file + IF ( trim(groupby) == 'month' ) THEN + + IF ( isleapyear(year) ) THEN + months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) + ELSE + months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + ENDIF + + ! calculate initial month and day values + CALL julian2monthday(year, day, month, mday) + + ! calculate initial second value + sec = 86400*(mday-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(mday-1) + tstamp_LB(var_i)%sec = sec + + ! set time stamp (ststamp_LB) + IF (sec < 0) THEN + tstamp_LB(var_i)%sec = 86400 + sec + tstamp_LB(var_i)%day = day - 1 + IF (tstamp_LB(var_i)%day == 0) THEN + tstamp_LB(var_i)%year = year - 1 + IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN + tstamp_LB(var_i)%day = 366 + ELSE + tstamp_LB(var_i)%day = 365 + ENDIF + ENDIF + ENDIF + + ! set record info (year, month, time_i) + IF ( sec<0 .or. (sec==0 .and. offset(var_i).ne.0) ) THEN + + ! IF just behind the first record -> set to first record + IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN + sec = offset(var_i) + + ! set to one record backward + ELSE + sec = 86400 + sec + mday = mday - 1 + IF (mday == 0) THEN + month = month - 1 + ! bug found by Zhu Siguang & Zhang Xiangxiang, 05/19/2014 + ! move the below line in the 'ELSE' statement + !mday = months(month) - months(month-1) + IF (month == 0) THEN + month = 12 + year = year - 1 + mday = 31 + ELSE + mday = months(month) - months(month-1) + ENDIF + ENDIF + ENDIF + ENDIF + + ! in case of leapyear with a non-leapyear calendar + ! USE the data 1 day before, i.e., FEB 28th. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! get record time index + sec = 86400*(mday-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + ! in the case of one day one file + IF ( trim(groupby) == 'day' ) THEN + + ! calculate initial month and day values + CALL julian2monthday(year, day, month, mday) + + ! calculate initial second value + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + sec = (time_i-1)*dtime(var_i) + offset(var_i) + tstamp_LB(var_i)%sec = sec + + ! set time stamp (ststamp_LB) + IF (sec < 0) THEN + tstamp_LB(var_i)%sec = 86400 + sec + tstamp_LB(var_i)%day = day - 1 + IF (tstamp_LB(var_i)%day == 0) THEN + tstamp_LB(var_i)%year = year - 1 + IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN + tstamp_LB(var_i)%day = 366 + ELSE + tstamp_LB(var_i)%day = 365 + ENDIF + ENDIF + + IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN + sec = offset(var_i) + ! set to one record backward + ELSE + sec = 86400 + sec + year = tstamp_LB(var_i)%year + CALL julian2monthday(tstamp_LB(var_i)%year, tstamp_LB(var_i)%day, month, mday) + ENDIF + ENDIF + + ! in case of leapyear with a non-leapyear calendar + ! USE the data 1 day before, i.e., FEB 28th. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! get record time index + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF (time_i <= 0) THEN + write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop() + ENDIF + + RETURN + + END SUBROUTINE setstampLB + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! set the upper boundary time stamp and record information, +! a KEY FUNCTION of this MODULE +! +! !REVISIONS: +! 04/2014, Hua Yuan: initial code +! +!----------------------------------------------------------------------- + SUBROUTINE setstampUB(var_i, year, month, mday, time_i) + + IMPLICIT NONE + integer, intent(in) :: var_i + integer, intent(out) :: year + integer, intent(out) :: month + integer, intent(out) :: mday + integer, intent(out) :: time_i + + integer :: day, sec + integer :: months(0:12) + + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + IF ( tstamp_UB(var_i) == 'NULL' ) THEN + tstamp_UB(var_i) = forctime(iforctime(var_i)+1) + ELSE + iforctime(var_i) = iforctime(var_i) + 1 + tstamp_LB(var_i) = forctime(iforctime(var_i)) + tstamp_UB(var_i) = forctime(iforctime(var_i)+1) + ENDIF + + time_i = iforctime(var_i)+1 + year = tstamp_UB(var_i)%year + day = tstamp_UB(var_i)%day + + CALL julian2monthday(year, day, month, mday) + + RETURN + ENDIF + + ! calculate the time stamp + IF ( tstamp_UB(var_i) == 'NULL' ) THEN + tstamp_UB(var_i) = tstamp_LB(var_i) + dtime(var_i) + ELSE + tstamp_LB(var_i) = tstamp_UB(var_i) + tstamp_UB(var_i) = tstamp_UB(var_i) + dtime(var_i) + ENDIF + + ! calculate initial year, day, and second values + year = tstamp_UB(var_i)%year + day = tstamp_UB(var_i)%day + sec = tstamp_UB(var_i)%sec + + IF ( trim(groupby) == 'year' ) THEN + + ! adjust year value + IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN + sec = 0 + day = day + 1 + IF( isleapyear(year) .and. day==367) THEN + year = year + 1; day = 1 + ENDIF + IF( .not. isleapyear(year) .and. day==366) THEN + year = year + 1; day = 1 + ENDIF + ENDIF + + ! in case of leapyear with a non-leapyear calendar + ! USE the data 1 day before after FEB 28th (Julian day 59). + IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN + day = day - 1 + ENDIF + + ! set record index + sec = 86400*(day-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF ( trim(groupby) == 'month' ) THEN + + IF ( isleapyear(year) ) THEN + months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) + ELSE + months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + ENDIF + + ! calculate initial month and day values + CALL julian2monthday(year, day, month, mday) + + ! record in the next day, adjust year, month and second values + IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN + sec = 0 + mday = mday + 1 + IF ( mday > (months(month)-months(month-1)) ) THEN + mday = 1 + ! bug found by Zhu Siguang, 05/25/2014 + ! move the below line in the 'ELSE' statement + !month = month + 1 + IF (month == 12) THEN + month = 1 + year = year + 1 + ELSE + month = month + 1 + ENDIF + ENDIF + ENDIF + + ! in case of leapyear with a non-leapyear calendar + ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! set record index + sec = 86400*(mday-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF ( trim(groupby) == 'day' ) THEN + IF ( isleapyear(year) ) THEN + months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) + ELSE + months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + ENDIF + + ! calculate initial month and day values + CALL julian2monthday(year, day, month, mday) + !mday = day + + ! record in the next day, adjust year, month and second values + IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN + sec = 0 + mday = mday + 1 + IF ( mday > (months(month)-months(month-1)) ) THEN + mday = 1 + ! bug found by Zhu Siguang, 05/25/2014 + ! move the below line in the 'ELSE' statement + !month = month + 1 + IF (month == 12) THEN + month = 1 + year = year + 1 + ELSE + month = month + 1 + ENDIF + ENDIF + ENDIF + + ! in case of leapyear with a non-leapyear calendar + ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! set record index + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF (time_i < 0) THEN + write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop() + ENDIF + + RETURN + + END SUBROUTINE setstampUB + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculate time average coszen value between [LB, UB] +! +! !REVISIONS: +! 04/2014, Hua Yuan: this method is adapted from CLM +! +!----------------------------------------------------------------------- + SUBROUTINE calavgcos(idate) + + USE MOD_Block + USE MOD_DataType + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + integer :: ntime, iblkme, ib, jb, i, j, ilon, ilat + real(r8) :: calday, cosz + type(timestamp) :: tstamp + + tstamp = idate !tstamp_LB(7) + ntime = 0 + DO WHILE (tstamp < tstamp_UB(7)) + ntime = ntime + 1 + tstamp = tstamp + deltim_int + ENDDO + + tstamp = idate !tstamp_LB(7) + CALL flush_block_data (avgcos, 0._r8) + + DO WHILE (tstamp < tstamp_UB(7)) + + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) + + ilat = gforc%ydsp(jb) + j + ilon = gforc%xdsp(ib) + i + IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon + + calday = calendarday(tstamp) + cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) + cosz = max(0.001, cosz) + avgcos%blk(ib,jb)%val(i,j) = avgcos%blk(ib,jb)%val(i,j) & + + cosz / real(ntime,r8) ! * deltim_real /real(tstamp_UB(7)-tstamp_LB(7)) + + ENDDO + ENDDO + ENDDO + + tstamp = tstamp + deltim_int + + ENDDO + + END SUBROUTINE calavgcos + +END MODULE MOD_Forcing diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 new file mode 100644 index 0000000000..c557b30784 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 @@ -0,0 +1,1049 @@ +#include + +MODULE MOD_ForcingDownscaling + +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! Downscaling meteorological forcings +! +! !INITIAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISIONS: +! Updated by Yongjiu Dai, January 16, 2023 +! Revised by Lu Li, January 24, 2024 +! Revised by Sisi Chen, Lu Li, June, 2024 +!----------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Qsadv + USE MOD_Namelist + USE MOD_Const_Physical + USE MOD_Vars_Global + USE MOD_UserDefFun + + IMPLICIT NONE + + real(r8), parameter :: SHR_CONST_MWDAIR = 28.966_r8 ! molecular weight dry air [kg/kmole] + real(r8), parameter :: SHR_CONST_MWWV = 18.016_r8 ! molecular weight water vapor + real(r8), parameter :: SHR_CONST_AVOGAD = 6.02214e26_r8 ! Avogadro's number [molecules/kmole] + real(r8), parameter :: SHR_CONST_BOLTZ = 1.38065e-23_r8 ! Boltzmann's constant [J/K/molecule] + ! Universal gas constant [J/K/kmole] + real(r8), parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ + ! Dry air gas constant [J/K/kg] + real(r8), parameter :: rair = SHR_CONST_RGAS/SHR_CONST_MWDAIR + + ! On the windward side of the range, annual mean lapse rates of 3.9-5.2 (deg km-1), substantially + ! smaller than the often-assumed 6.5 (deg km-1). The data sets show similar seasonal and diurnal + ! variability, with lapse rates smallest (2.5-3.5 deg km-1) in late-summer minimum temperatures, + ! and largest (6.5-7.5 deg km-1) in spring maximum temperatures. Geographic (windward versus lee + ! side) differences in lapse rates are substantial. [Minder et al., 2010, Surface temperature + ! lapse rates over complex terrain: Lessons from the Cascade Mountains. JGR, 115, + ! doi:10.1029/2009JD013493] + ! + ! Kunkel, K. E., 1989: Simple procedures for extrapolation of humidity variables in the + ! mountainous western United States. J. Climate, 2, 656-669. lapse_rate = /Jan - + ! Dec/4.4,5.9,7.1,7.8,8.1,8.2,8.1,8.1,7.7,6.8,5.5,4.7/ (deg km-1) + real(r8), parameter :: lapse_rate = 0.006_r8 ! surface temperature lapse rate (deg m-1) + + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: downscale_forcings ! Downscale atmospheric forcing + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: rhos ! calculate atmospheric density + +!----------------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------------- + + PURE FUNCTION rhos(qbot, pbot, tbot) + +!----------------------------------------------------------------------------- +! DESCRIPTION: +! Compute atmospheric density (kg/m**3) +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + ! ARGUMENTS: + real(r8) :: rhos ! function result: atmospheric density (kg/m**3) + real(r8), intent(in) :: qbot ! atmospheric specific humidity (kg/kg) + real(r8), intent(in) :: pbot ! atmospheric pressure (Pa) + real(r8), intent(in) :: tbot ! atmospheric temperature (K) + + ! LOCAL VARIABLES: + real(r8) :: egcm + real(r8) :: wv_to_dair_weight_ratio ! ratio of molecular weight of water vapor to dry air [-] + + wv_to_dair_weight_ratio = SHR_CONST_MWWV/SHR_CONST_MWDAIR + + egcm = qbot*pbot / (wv_to_dair_weight_ratio + (1._r8 - wv_to_dair_weight_ratio)*qbot) + rhos = (pbot - (1._r8 - wv_to_dair_weight_ratio)*egcm) / (rair*tbot) + + END FUNCTION rhos + +!----------------------------------------------------------------------------- + + SUBROUTINE downscale_forcings (& + glaciers, & + + ! non-adjusted forcing + forc_topo_g ,forc_maxelv_g ,forc_t_g ,forc_th_g ,forc_q_g ,& + forc_pbot_g ,forc_rho_g ,forc_prc_g ,forc_prl_g ,forc_lwrad_g ,& + forc_hgt_g ,forc_swrad_g ,forc_us_g ,forc_vs_g , & + + ! topography-based factor on patch + slp_type_c, asp_type_c, cur_c, & + + ! other factors + julian_day, coszen, cosazi, & + + ! adjusted forcing + forc_topo_c ,forc_t_c ,forc_th_c ,forc_q_c ,forc_pbot_c ,& + forc_rho_c ,forc_prc_c ,forc_prl_c ,forc_lwrad_c, forc_swrad_c, & + forc_us_c ,forc_vs_c, & + + ! optional parameters for full downscaling + area_type_c, svf_c, alb, & +#ifdef SinglePoint + sf_lut_c & +#else + sf_curve_c & +#endif + ) + +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! Downscale atmospheric forcing fields. +! +! Downscaling is done based on the difference between each land model +! column's elevation and the atmosphere's surface elevation (which is +! the elevation at which the atmospheric forcings are valid). +! +! Note that the downscaling procedure can result in changes in grid +! cell mean values compared to what was provided by the atmosphere. We +! conserve fluxes of mass and energy, but allow states such as +! temperature to differ. +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + integer, parameter :: S = 1370 ! solar constant (W/m**2) + real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith angle + + ! ARGUMENTS: + logical, intent(in) :: glaciers ! true: glacier column (itypwat = 3) + real(r8), intent(in) :: julian_day ! day of year + real(r8), intent(in) :: coszen ! cosine of sun zenith angle at an hour + real(r8), intent(in) :: cosazi ! cosine of sun azimuth angle at an hour + + ! topography-based factor + real(r8), intent(in) :: cur_c ! curvature + ! topographic aspect of each type of one patch(rad) - can be different dimensions + real(r8), intent(in) :: asp_type_c (:) + ! topographic slope of each character of one patch - can be different dimensions + real(r8), intent(in) :: slp_type_c (:) + + ! optional parameters for complex downscaling + real(r8), intent(in), optional :: alb ! blue sky albedo + real(r8), intent(in), optional :: svf_c ! sky view factor + ! area percentage of each character of one patch + real(r8), intent(in), optional :: area_type_c(:) +#ifdef SinglePoint + ! look up table of shadow mask of a patch + real(r8), intent(in), optional :: sf_lut_c (:,:) +#else + ! curve of shadow mask of a patch + real(r8), intent(in), optional :: sf_curve_c (:,:) +#endif + + ! non-downscaled fields: + real(r8), intent(in) :: forc_topo_g ! atmospheric surface height [m] + real(r8), intent(in) :: forc_maxelv_g ! max atmospheric surface height [m] + real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin] + real(r8), intent(in) :: forc_th_g ! atmospheric potential temperature [Kelvin] + real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg] + real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] + real(r8), intent(in) :: forc_rho_g ! atmospheric density [kg/m**3] + real(r8), intent(in) :: forc_prc_g ! convective precipitation in grid [mm/s] + real(r8), intent(in) :: forc_prl_g ! large-scale precipitation in grid [mm/s] + real(r8), intent(in) :: forc_lwrad_g ! grid downward longwave [W/m**2] + real(r8), intent(in) :: forc_swrad_g ! grid downward shortwave [W/m**2] + real(r8), intent(in) :: forc_hgt_g ! atmospheric reference height [m] + real(r8), intent(in) :: forc_us_g ! eastward wind [m/s] + real(r8), intent(in) :: forc_vs_g ! northward wind [m/s] + + ! downscaled fields: + real(r8), intent(in) :: forc_topo_c ! column surface height [m] + real(r8), intent(out) :: forc_t_c ! atmospheric temperature [Kelvin] + real(r8), intent(out) :: forc_th_c ! atmospheric potential temperature [Kelvin] + real(r8), intent(out) :: forc_q_c ! atmospheric specific humidity [kg/kg] + real(r8), intent(out) :: forc_pbot_c ! atmospheric pressure [Pa] + real(r8), intent(out) :: forc_rho_c ! atmospheric density [kg/m**3] + real(r8), intent(out) :: forc_prc_c ! column convective precipitation [mm/s] + real(r8), intent(out) :: forc_prl_c ! column large-scale precipitation [mm/s] + real(r8), intent(out) :: forc_lwrad_c ! column downward longwave [W/m**2] + real(r8), intent(out) :: forc_swrad_c ! column downward shortwave [W/m**2] + real(r8), intent(out) :: forc_us_c ! column eastward wind [m/s] + real(r8), intent(out) :: forc_vs_c ! column northward wind [m/s] + + ! Local variables for topo downscaling: + real(r8) :: hsurf_g, hsurf_c + real(r8) :: Hbot, zbot + real(r8) :: tbot_g, pbot_g, thbot_g, qbot_g, qs_g, es_g, rhos_g + real(r8) :: tbot_c, pbot_c, thbot_c, qbot_c, qs_c, es_c, rhos_c + real(r8) :: rhos_c_estimate, rhos_g_estimate + real(r8) :: dum1, dum2 + real(r8) :: max_elev_c ! the maximum column level elevation value within the grid + real(r8) :: delta_prc_c ! deviation of the column convective prec. from the grid level prec. + real(r8) :: delta_prl_c ! deviation of the column large-scale prec. from the grid level prec. + +!----------------------------------------------------------------------------- + + ! -------------------------------------------------------------------------------------- + ! 1. adjust air temperature, potential temperature, specific humidity, pressure, density + ! -------------------------------------------------------------------------------------- + hsurf_g = forc_topo_g ! gridcell sfc elevation + tbot_g = forc_t_g ! atm sfc temp + thbot_g = forc_th_g ! atm sfc pot temp + qbot_g = forc_q_g ! atm sfc spec humid + pbot_g = forc_pbot_g ! atm sfc pressure + rhos_g = forc_rho_g ! atm density + zbot = forc_hgt_g ! atm ref height + + hsurf_c = forc_topo_c ! column sfc elevation + tbot_c = tbot_g-lapse_rate*(hsurf_c-hsurf_g) ! adjust [temp] for column + Hbot = rair*0.5_r8*(tbot_g+tbot_c)/grav ! scale ht at avg temp + pbot_c = pbot_g*exp(-(hsurf_c-hsurf_g)/Hbot) ! adjust [press] for column + + ! Derivation of potential temperature calculation: + ! + ! The textbook definition would be: + ! thbot_c = tbot_c * (p0/pbot_c)^(rair/cpair) + ! + ! Note that pressure is related to scale height as: + ! pbot_c = p0 * exp(-zbot/Hbot) + ! + ! Plugging this in to the textbook definition, then manipulating, we get: + ! thbot_c = tbot_c * (p0/(p0*exp(-zbot/Hbot)))^(rair/cpair) + ! = tbot_c * (1/exp(-zbot/Hbot))^(rair/cpair) + ! = tbot_c * (exp(zbot/Hbot))^(rair/cpair) + ! = tbot_c * exp((zbot/Hbot) * (rair/cpair)) + + ! But we want everything expressed in delta form, resulting in: + ! adjust [pot temp] for column + thbot_c = thbot_g + (tbot_c - tbot_g)*exp((zbot/Hbot)*(rair/cpair)) + + CALL Qsadv(tbot_g,pbot_g,es_g,dum1,qs_g,dum2) ! es, qs for gridcell + CALL Qsadv(tbot_c,pbot_c,es_c,dum1,qs_c,dum2) ! es, qs for column + qbot_c = qbot_g*(qs_c/qs_g) ! adjust [q] for column + + rhos_c_estimate = rhos(qbot=qbot_c, pbot=pbot_c, tbot=tbot_c) + rhos_g_estimate = rhos(qbot=qbot_g, pbot=pbot_g, tbot=tbot_g) + rhos_c = rhos_g * (rhos_c_estimate / rhos_g_estimate) ! adjust [density] for column + + ! save + forc_t_c = tbot_c + forc_th_c = thbot_c + forc_q_c = qbot_c + forc_pbot_c = pbot_c + forc_rho_c = rhos_c + + ! -------------------------------------------------------------------------------------- + ! 2. adjust wind speed + ! -------------------------------------------------------------------------------------- + forc_us_c = forc_us_g + forc_vs_c = forc_vs_g + + ! -------------------------------------------------------------------------------------- + ! 3. adjust longwave radiation and shortwave radiation + ! -------------------------------------------------------------------------------------- + CALL downscale_longwave (glaciers, & + forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & + forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) + + ! Check if optional parameters are present for complex downscaling + IF (present(area_type_c) .and. present(svf_c) .and. present(alb) .and. & +#ifdef SinglePoint + present(sf_lut_c) & +#else + present(sf_curve_c) & +#endif + ) THEN + ! Complex downscaling with topographic effects + CALL downscale_shortwave(& + forc_topo_g, forc_pbot_g, forc_swrad_g, & + forc_topo_c, forc_pbot_c, forc_swrad_c, & + julian_day, coszen, cosazi, alb, & + slp_type_c, asp_type_c, svf_c, & +#ifdef SinglePoint + sf_lut_c, & +#else + sf_curve_c, & +#endif + area_type_c) + ELSE + ! Simple downscaling + CALL downscale_shortwave_simple(& + forc_topo_g, forc_pbot_g, forc_swrad_g, & + forc_topo_c, forc_pbot_c, forc_swrad_c, & + julian_day, coszen, cosazi, & + slp_type_c, asp_type_c) + ENDIF + + ! -------------------------------------------------------------------------------------- + ! 4. adjust precipitation + ! -------------------------------------------------------------------------------------- + IF (trim(DEF_DS_precipitation_adjust_scheme) == 'I') THEN + ! Tesfa et al, 2020: Exploring Topography-Based Methods for Downscaling + ! Subgrid Precipitation for Use in Earth System Models. Equation (5) + ! https://doi.org/ 10.1029/2019JD031456 + + IF (forc_maxelv_g /= 0.) THEN + delta_prc_c = forc_prc_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g + ELSE + delta_prc_c = 0. + ENDIF + forc_prc_c = forc_prc_g + delta_prc_c ! convective precipitation [mm/s] + IF (forc_prc_c<=0) forc_prc_c = forc_prc_g ! the limit value is non-negative + IF (forc_prc_c==0) forc_prc_c = 1.0e-10_r8 ! avoid denominator being 0 when conserving water quantity + + IF (forc_maxelv_g /= 0.) THEN + delta_prl_c = forc_prl_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g + ELSE + delta_prl_c = 0. + ENDIF + forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s] + IF (forc_prl_c<=0) forc_prl_c = forc_prl_g ! the limit value is non-negative + IF (forc_prl_c==0) forc_prl_c = 1.0e-10_r8 ! avoid denominator being 0 when conserving water quantity + + ELSEIF (trim(DEF_DS_precipitation_adjust_scheme) == 'II') THEN + ! Liston, G. E. and Elder, K.: A meteorological distribution system + ! for high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol., 7, 217-234, 2006. + ! Equation (33) and Table 1: chi range from January to December: + ! [0.35,0.35,0.35,0.30,0.25,0.20,0.20,0.20,0.20,0.25,0.30,0.35] (1/km) + + delta_prc_c = forc_prc_g *1.0*0.27*(forc_topo_c - forc_topo_g) & + /(1.0 - 0.27*(forc_topo_c - forc_topo_g)) + forc_prc_c = forc_prc_g + delta_prc_c ! large scale precipitation [mm/s] + + delta_prl_c = forc_prl_g *1.0*0.27*(forc_topo_c - forc_topo_g) & + /(1.0 - 0.27*(forc_topo_c - forc_topo_g)) + forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s] + ENDIF + + IF (forc_prl_c < 0) THEN + write(*,*) 'negative prl', forc_prl_g, forc_maxelv_g, forc_topo_c, forc_topo_g + forc_prl_c = 0. + ENDIF + + IF (forc_prc_c < 0) THEN + write(*,*) 'negative prc', forc_prc_g, forc_maxelv_g, forc_topo_c, forc_topo_g + forc_prc_c = 0. + ENDIF + + END SUBROUTINE downscale_forcings +!----------------------------------------------------------------------------- + + SUBROUTINE downscale_wind(forc_us_g, forc_vs_g, & + slp_type_c, asp_type_c, area_type_c, cur_c) + +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! Downscale wind speed +! +! Liston, G. E. and Elder, K.: A meteorological distribution system for +! high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol., +! 7, 217-234, 2006. +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + ! ARGUMENTS: + real(r8), intent(inout) :: forc_us_g ! eastward wind (m/s) + real(r8), intent(inout) :: forc_vs_g ! northward wind (m/s) + + real(r8), intent(in) :: cur_c ! curvature + ! topographic aspect of each character of one patch + real(r8), intent(in) :: asp_type_c (1:num_slope_type) + ! topographic slope of each character of one patch + real(r8), intent(in) :: slp_type_c (1:num_slope_type) + ! area percentage of each character of one patch + real(r8), intent(in) :: area_type_c (1:num_slope_type) + + ! local variables + real(r8) :: wind_dir ! wind direction + real(r8) :: ws_g ! non-downscaled wind speed + real(r8) :: wind_dir_slp (1:num_slope_type) ! the slope in the direction of the wind + real(r8) :: ws_c_type(1:num_slope_type) ! downscaled wind speed of each type in each patch + real(r8) :: ws_c ! downscaled wind speed + real(r8) :: scale_factor ! Combined scaling factor for regulating wind speed + integer :: g, c, i + +!----------------------------------------------------------------------------- + + ! calculate wind direction + IF (forc_us_g == 0.) THEN + wind_dir = PI/2 + ELSE + wind_dir = atan(forc_vs_g /forc_us_g) + ENDIF + + ! non-adjusted wind speed + ws_g = sqrt(forc_vs_g *forc_vs_g +forc_us_g *forc_us_g ) + + ! compute the slope in the direction of the wind + DO i = 1, num_slope_type + wind_dir_slp(i) = slp_type_c(i)*cos(wind_dir-asp_type_c(i)) + ENDDO + + ! compute wind speed adjustment + DO i = 1, num_slope_type + scale_factor = (1+(0.58*wind_dir_slp(i))+0.42*cur_c) + ! Limiting the scope of proportionality adjustments + IF (scale_factor>1.5) THEN + scale_factor = 1.5 + ELSEIF (scale_factor<-1.5) THEN + scale_factor = -1.5 + ENDIF + ws_c_type(i) = ws_g *scale_factor*area_type_c(i) + ENDDO + + ! adjusted wind speed + ws_c = sum(ws_c_type(:)) + forc_us_g = ws_c*cos(wind_dir) + forc_vs_g = ws_c*sin(wind_dir) + + END SUBROUTINE downscale_wind + +!----------------------------------------------------------------------------- + + SUBROUTINE downscale_wind_simple(forc_us_g, forc_vs_g, & + slp_type_c, area_type_c, cur_c) + +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! Downscale wind speed using a simple method for land-atmosphere coupling models +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + ! ARGUMENTS: + real(r8), intent(inout) :: forc_us_g ! eastward wind (m/s) + real(r8), intent(inout) :: forc_vs_g ! northward wind (m/s) + + real(r8), intent(in) :: cur_c ! curvature + ! topographic slope of each character of one patch + real(r8), intent(in) :: slp_type_c (1:num_aspect_type) + ! area percentage of each character of one patch + real(r8), intent(in) :: area_type_c (1:num_aspect_type) + + ! local variables + real(r8) :: asp_type_c(1:num_aspect_type) ! topographic aspect of each type of one patch (rad) + real(r8) :: slp_type_c_rad ! Convert tan slope value to slope angle value + + real(r8) :: wind_dir ! wind direction + real(r8) :: ws_g ! non-downscaled wind speed + real(r8) :: wind_dir_slp (1:num_aspect_type) ! the slope in the direction of the wind + real(r8) :: ws_c_type(1:num_aspect_type) ! downscaled wind speed of each type in each patch + real(r8) :: ws_c ! downscaled wind speed + real(r8) :: scale_factor ! Combined scaling factor for regulating wind speed + integer :: u_sign, v_sign, i, wind_dir_u, wind_dir_v + + ! Initialize aspect type + asp_type_c(1) = 0.0_r8*PI/180 ! north + asp_type_c(2) = 45.0_r8*PI/180 ! northeast + asp_type_c(3) = 90.0_r8*PI/180 ! east + asp_type_c(4) = 135.0_r8*PI/180 ! southeast + asp_type_c(5) = 180.0_r8*PI/180 ! south + asp_type_c(6) = 225.0_r8*PI/180 ! southwest + asp_type_c(7) = 270.0_r8*PI/180 ! west + asp_type_c(8) = 315.0_r8*PI/180 ! northwest + asp_type_c(9) = -9999.0_r8 ! flat +!----------------------------------------------------------------------------- + + ! calculate wind direction + IF (forc_us_g == 0.) THEN + wind_dir = PI/2 + ELSE + wind_dir = atan2(forc_vs_g, forc_us_g) + ENDIF + + ! convert to 0-2*PI range + !wind_dir = wind_dir + 3*PI/2 + !wind_dir = mod(wind_dir, 2*PI) + + ! 0° is north + IF (wind_dir > PI/2) THEN + wind_dir = 2*PI - wind_dir + PI/2 + ELSE + wind_dir = PI/2 - wind_dir + ENDIF + + ! non-adjusted wind speed + ws_g = sqrt(forc_vs_g *forc_vs_g +forc_us_g *forc_us_g ) + + ! log the + - sign of the u,v direction + IF (forc_us_g >= 0.0_r8) THEN + u_sign = 1 + ELSE + u_sign = -1 + ENDIF + IF (forc_vs_g >= 0.0_r8) THEN + v_sign = 1 + ELSE + v_sign = -1 + ENDIF + + + ! compute the slope in the direction of the wind + DO i = 1, num_aspect_type + IF (slp_type_c(i) == -1.0e36) THEN + ! no slope in the direction of the aspect + wind_dir_slp(i) = -1.0e36 + ELSE + ! slope in the direction of the wind + slp_type_c_rad = atan(slp_type_c(i)) + wind_dir_slp(i) = slp_type_c_rad*cos(wind_dir-asp_type_c(i)) + ENDIF + ENDDO + + ! compute wind speed adjustment + DO i = 1, num_aspect_type + ! For the flat area, we do not adjust the wind speed + IF (asp_type_c(i) == -9999.0_r8) THEN + scale_factor = 1.0_r8 + ELSE IF ((wind_dir_slp(i) == -1.0e36).or.(cur_c == -1.0e36)) THEN + ! no slope in the direction of the aspect + scale_factor = -1.0e36 + ELSE + scale_factor = (1+(0.58*wind_dir_slp(i))+0.42*cur_c) + !write(*,*) 'scale_factor', scale_factor, 'wind_dir_slp(i)', wind_dir_slp(i), 'cur_c', cur_c + ENDIF + + ! Limiting the scope of proportionality adjustments + IF (scale_factor>1.5) THEN + scale_factor = 1.5 + ELSEIF (scale_factor<-1.5) THEN + scale_factor = -1.5 + ENDIF + + ! Downscale wind speed for each type in each patch + IF ((scale_factor == -1.0e36).or.(area_type_c(i) == -1.0e36)) THEN + ws_c_type(i) = -1.0e36 + ELSE + ws_c_type(i) = ws_g *scale_factor*area_type_c(i) + ENDIF + + ENDDO + + ! adjusted wind speed + ws_c = sum(ws_c_type(:),mask=ws_c_type(:) /= -1.0e36) + + ! caculate u and v components of the wind + IF (wind_dir > PI/2) THEN + wind_dir = 2*PI - wind_dir + PI/2 + ELSE + wind_dir = PI/2 - wind_dir + ENDIF + + forc_us_g = u_sign*sqrt((ws_c*cos(wind_dir))**2) + forc_vs_g = v_sign*sqrt((ws_c*sin(wind_dir))**2) + + END SUBROUTINE downscale_wind_simple +!----------------------------------------------------------------------------- + + SUBROUTINE downscale_longwave (glaciers, & + forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & + forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) + +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! Downscale longwave radiation +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + ! ARGUMENTS: + logical, intent(in) :: glaciers ! true: glacier column + + real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) + real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin] + real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg] + real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] + real(r8), intent(in) :: forc_lwrad_g ! downward longwave (W/m**2) + + real(r8), intent(in) :: forc_topo_c ! column surface height (m) + real(r8), intent(in) :: forc_t_c ! atmospheric temperature [Kelvin] + real(r8), intent(in) :: forc_q_c ! atmospheric specific humidity [kg/kg] + real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] + real(r8), intent(out):: forc_lwrad_c ! downward longwave (W/m**2) + + ! LOCAL VARIABLES: + real(r8) :: hsurf_c ! column-level elevation (m) + real(r8) :: hsurf_g ! gridcell-level elevation (m) + + real(r8) :: pv_g ! the water vapor pressure at grid cell (hPa) + real(r8) :: pv_c ! the water vapor pressure at column (hPa) + real(r8) :: emissivity_clearsky_g ! clear-sky emissivity at grid cell + real(r8) :: emissivity_clearsky_c ! clear-sky emissivity at grid column + real(r8) :: emissivity_allsky_g ! all-sky emissivity at grid cell + real(r8) :: es_g, es_c, dum1, dum2, dum3 + + real(r8), parameter :: lapse_rate_longwave = 0.032_r8 ! longwave radiation lapse rate (W m-2 m-1) + ! relative limit for how much longwave downscaling can be done (unitless) + real(r8), parameter :: longwave_downscaling_limit = 0.5_r8 + +!-------------------------------------------------------------------------- + + ! Initialize (needs to be done for ALL active columns) + forc_lwrad_c = forc_lwrad_g + hsurf_g = forc_topo_g + hsurf_c = forc_topo_c + + IF (trim(DEF_DS_longwave_adjust_scheme) == 'I') THEN + ! Fiddes and Gruber, 2014, TopoSCALE v.1.0: downscaling gridded climate data in complex + ! terrain. Geosci. Model Dev., 7, 387-405. doi:10.5194/gmd-7-387-2014. Equation (1) (2) + ! (3); here, the empirical parameters x1 and x2 are different from Konzelmann et al. (1994) + ! where x1 = 0.443 and x2 = 8 (optimal for measurements on the Greenland ice sheet) + + CALL Qsadv(forc_t_g, forc_pbot_g, es_g,dum1,dum2,dum3) + CALL Qsadv(forc_t_c, forc_pbot_c, es_c,dum1,dum2,dum3) + pv_g = forc_q_g*es_g/100._r8 ! (hPa) + pv_c = forc_q_c*es_c/100._r8 ! (hPa) + + emissivity_clearsky_g = 0.23_r8 + 0.43_r8*(pv_g/forc_t_g)**(1._r8/5.7_r8) + emissivity_clearsky_c = 0.23_r8 + 0.43_r8*(pv_c/forc_t_c)**(1._r8/5.7_r8) + emissivity_allsky_g = forc_lwrad_g / (5.67e-8_r8*forc_t_g**4) + + forc_lwrad_c = & + (emissivity_clearsky_c + (emissivity_allsky_g - emissivity_clearsky_g)) & + * 5.67e-8_r8*forc_t_c**4 + ELSE + ! Longwave radiation is downscaled by assuming a linear decrease in downwelling longwave + ! radiation with increasing elevation (0.032 W m-2 m-1, limited to 0.5 - 1.5 times the + ! gridcell mean value, then normalized to conserve gridcell total energy) (Van Tricht et + ! al., 2016, TC) Figure 6, doi:10.5194/tc-10-2379-2016 + + IF (glaciers) THEN + forc_lwrad_c = forc_lwrad_g - lapse_rate_longwave * (hsurf_c-hsurf_g) + + ! Here we assume that deltaLW = (dLW/dT)*(dT/dz)*deltaz + ! We get dLW/dT = 4*eps*sigma*T^3 = 4*LW/T from the Stefan-Boltzmann law, + ! evaluated at the mean temp. We assume the same temperature lapse rate as above. + + ELSE + forc_lwrad_c = forc_lwrad_g & + - 4.0_r8 * forc_lwrad_g/(0.5_r8*(forc_t_c+forc_t_g)) & + * lapse_rate * (hsurf_c - hsurf_g) + ENDIF + ENDIF + + ! But ensure that we don't depart too far from the atmospheric forcing value: + ! negative values of lwrad are certainly bad, but small positive values might + ! also be bad. We can especially run into trouble due to the normalization: a + ! small lwrad value in one column can lead to a big normalization factor, + ! leading to huge lwrad values in other columns. + + forc_lwrad_c = min(forc_lwrad_c, forc_lwrad_g * (1._r8 + longwave_downscaling_limit)) + forc_lwrad_c = max(forc_lwrad_c, forc_lwrad_g * (1._r8 - longwave_downscaling_limit)) + + END SUBROUTINE downscale_longwave + +!----------------------------------------------------------------------------- + SUBROUTINE downscale_shortwave( & + forc_topo_g, forc_pbot_g, forc_swrad_g, & + forc_topo_c, forc_pbot_c, forc_swrad_c, & + julian_day, coszen, cosazi, alb, & + slp_type_c, asp_type_c, svf_c, & +#ifdef SinglePoint + sf_lut_c, & +#else + sf_curve_c, & +#endif + area_type_c) + +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Rouf, T., Mei, Y., Maggioni, V., Houser, P., & Noonan, M. (2020). A +! Physically Based Atmospheric Variables Downscaling Technique. Journal +! of Hydrometeorology, 21(1), 93-108. +! https://doi.org/10.1175/JHM-D-19-0109.1 +! +! Sisi Chen, Lu Li, Yongjiu Dai, et al. Exploring Topography +! Downscaling Methods for Hyper-Resolution Land Surface Modeling. +! Authorea. April 25, 2024. DOI: 10.22541/au.171403656.68476353/v1 +! +! Must be done after downscaling of surface pressure +!----------------------------------------------------------------------------- + + IMPLICIT NONE + + integer, parameter :: S = 1370 ! solar constant (W/m**2) + real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith + ! relative limit for how much shortwave downscaling can be done (unitless) + real(r8), parameter :: shortwave_downscaling_limit = 0.5_r8 + + ! ARGUMENTS: + real(r8), intent(in) :: julian_day ! day of year + real(r8), intent(in) :: coszen ! zenith angle at an hour + real(r8), intent(in) :: cosazi ! azimuth angle at an hour + real(r8), intent(in) :: alb ! blue sky albedo + + real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) + real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] + real(r8), intent(in) :: forc_swrad_g ! downward shortwave (W/m**2) + + real(r8), intent(in) :: forc_topo_c ! column surface height (m) + real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] + real(r8), intent(out):: forc_swrad_c ! downward shortwave (W/m**2) + + real(r8), intent(in) :: svf_c ! sky view factor +# ifdef SinglePoint + ! look up table of shadow mask of a patch + real(r8), intent(in) :: sf_lut_c (1:num_azimuth,1:num_zenith) +# else + ! curve of shadow mask of a patch + real(r8), intent(in) :: sf_curve_c (1:num_azimuth,1:num_zenith_parameter) +# endif + ! topographic aspect of each character of one patch (°) + real(r8), intent(in) :: asp_type_c (1:num_slope_type) + ! topographic slope of each character of one patch + real(r8), intent(in) :: slp_type_c (1:num_slope_type) + ! area percentage of each character of one patch + real(r8), intent(in) :: area_type_c(1:num_slope_type) + + ! LOCAL VARIABLES: + real(r8) :: zen_rad, zen_deg, azi_rad, azi_deg ! rad and deg of sun zenith and azimuth angle + integer :: idx_azi, idx_zen ! index used to cal shadow factor from + ! look up table + real(r8) :: sf_c ! shadow factor + real(r8) :: rt_R ! The ratio of the current distance between + ! the sun and the earth + real(r8) :: toa_swrad ! top of atmosphere shortwave radiation + real(r8) :: clr_idx ! atmospheric transparency + real(r8) :: diff_wgt ! diffuse weight + real(r8) :: k_c ! column broadband attenuation coefficient [Pa^-1] + real(r8) :: opt_factor ! optical length factor + real(r8) :: a_p + real(r8) :: svf, balb + + real(r8) :: diff_swrad_g, beam_swrad_g ! diffuse and beam radiation + real(r8) :: diff_swrad_c, beam_swrad_c, refl_swrad_c! downscaled diffuse, beam radiation + ! and reflect radiation + real(r8) :: beam_swrad_type (1:num_slope_type) ! beam radiation of one characterized patch + real(r8) :: refl_swrad_type (1:num_slope_type) ! refl. radiation of one characterized patch + real(r8) :: tcf_type (1:num_slope_type) ! terrain configure factor + real(r8) :: cosill_type (1:num_slope_type) ! illumination angle (cos) at defined types + + real(r8) :: zenith_segment, a1, a2 ! Segmented function segmentation + ! points (rad), parameter1, parameter2 + + integer :: i + +!----------------------------------------------------------------------------- + + ! calculate shadow factor according to sun zenith and azimuth angle + zen_rad = acos(coszen) + azi_rad = acos(cosazi) + azi_deg = azi_rad*180.0/PI ! turn deg + + idx_azi = INT(azi_deg*num_azimuth/360) + + IF (idx_azi==0) idx_azi = 1 + +#ifdef SinglePoint + zen_deg = zen_rad*180/PI ! turn deg + idx_zen = INT(zen_deg*num_zenith/90) + IF (idx_zen==0) idx_zen = 1 + !constrain the upper boundary of zenith angle to 90 deg + IF (idx_zen>num_zenith) idx_zen = num_zenith + + sf_c = sf_lut_c(idx_azi, idx_zen) +#else + ! Constructing a shadow factor function from zenith angle parameters + ! shadow factor = exp(-1*exp(a1*zenith+a2)) + zenith_segment = sf_curve_c(idx_azi, 1) ! Segmented function segmentation points (rad) + a1 = sf_curve_c(idx_azi, 2) ! parameter of function + a2 = sf_curve_c(idx_azi, 3) ! parameter of function + + IF (zen_rad <= zenith_segment) THEN + sf_c = 1. + ELSEIF (a1<=1e-10) THEN + sf_c = 1. + ELSE + sf_c = exp(-1*exp(min(a1*zen_rad+a2,3.5))) + ENDIF +#endif + + IF (sf_c<0) sf_c = 0 + IF (sf_c>1) sf_c = 1 + + ! calculate top-of-atmosphere incident shortwave radiation + rt_R = 1-0.01672*cos(0.9856*(julian_day-4)) + toa_swrad = S*(rt_R**2)*coszen + + ! calculate clearness index + IF (toa_swrad.eq.0) THEN + clr_idx = 0 + ELSE + clr_idx = forc_swrad_g/toa_swrad + ENDIF + IF (clr_idx>1) clr_idx = 1 + + ! calculate diffuse weight + ! Ruiz-Arias, J. A., Alsamamra, H., Tovar-Pescador, J., & Pozo-Vázquez, D. (2010). + ! Proposal of a regressive model for the hourly diffuse solar radiation under all sky + ! conditions. Energy Conversion and Management, 51(5), 881-893. + ! https://doi.org/10.1016/j.enconman.2009.11.024 + diff_wgt = 0.952-1.041*exp(-1*exp(min(2.3-4.702*clr_idx,3.5))) + IF (diff_wgt>1) diff_wgt = 1 + IF (diff_wgt<0) diff_wgt = 0 + + ! calculate diffuse and beam radiation + diff_swrad_g = forc_swrad_g*diff_wgt + beam_swrad_g = forc_swrad_g*(1-diff_wgt) + + ! calculate broadband attenuation coefficient [Pa^-1] + IF (clr_idx.le.0) THEN + k_c = 0 + ELSE + k_c = log(clr_idx)/forc_pbot_c + ENDIF + + ! calculate factor to account for the difference of optical path length + ! due to pressure difference + opt_factor = exp(k_c*(forc_pbot_g-forc_pbot_c)) + ! Control the boundary of optical path length + IF ((opt_factor>10000).or.(opt_factor<-10000)) opt_factor = 0 + + ! Adjust the zenith angle so that the range of zenith angles is less than 85° + IF (zen_rad>thr) zen_rad=thr + + ! loop for four defined types to downscale beam radiation + DO i = 1, num_slope_type + ! calculate the cosine of solar illumination angle, cos(θ), + ! ranging between −1 and 1, indicates if the sun is below or + ! above the local horizon (note that values lower than 0 are set to 0 indicate self shadow) + cosill_type(i) = cos(slp_type_c(i))+tan(zen_rad)*sin(slp_type_c(i))*cos(asp_type_c(i)) + IF (cosill_type(i)>1) cosill_type(i) = 1 + IF (cosill_type(i)<0) cosill_type(i) = 0 + + ! downscaling beam radiation + a_p = area_type_c(i) + IF (a_p.gt.1.0) a_p = 1 + IF (a_p.lt.0) a_p = 0 + beam_swrad_type(i) = sf_c*cosill_type(i)*opt_factor*a_p*beam_swrad_g + ENDDO + beam_swrad_c = sum(beam_swrad_type) + + ! downscaling diffuse radiation + svf = svf_c + IF (svf>1) svf = 1 + IF (svf<0) svf = 0 + diff_swrad_c = svf*diff_swrad_g + + ! downscaling reflected radiation + balb = alb + DO i = 1, num_slope_type + tcf_type(i) = (1+cos(slp_type_c(i)))/2-svf + IF (tcf_type(i)<0) tcf_type(i) = 0 + + IF (isnan_ud(alb)) THEN + refl_swrad_type(i) = -1.0e36 + ELSE + IF ((balb<0).or.(balb>1)) balb = 0 + refl_swrad_type(i) = balb*tcf_type(i)*(beam_swrad_c*coszen+(1-svf)*diff_swrad_c) + ENDIF + ENDDO + refl_swrad_c = sum(refl_swrad_type, mask = refl_swrad_type /= -1.0e36) + forc_swrad_c = beam_swrad_c+diff_swrad_c+refl_swrad_c + + ! But ensure that we don't depart too far from the atmospheric forcing value: + ! negative values of swrad are certainly bad, but small positive values might + ! also be bad. We can especially run into trouble due to the normalization: a + ! small swrad value in one column can lead to a big normalization factor, + ! leading to huge swrad values in other columns. + + forc_swrad_c = min(forc_swrad_c, & + forc_swrad_g * (1._r8 + shortwave_downscaling_limit)) + forc_swrad_c = max(forc_swrad_c, & + forc_swrad_g * (1._r8 - shortwave_downscaling_limit)) + ! Ensure that the denominator is not 0 during shortwave normalization + IF (forc_swrad_c==0.) forc_swrad_c = 0.0001 + + END SUBROUTINE downscale_shortwave + +!----------------------------------------------------------------------------- + SUBROUTINE downscale_shortwave_simple( & + forc_topo_g, forc_pbot_g, forc_swrad_g, & + forc_topo_c, forc_pbot_c, forc_swrad_c, & + julian_day, coszen, cosazi, & + slp_type_c, area_type_c) +!----------------------------------------------------------------------------- +! !DESCRIPTION: +! This subroutine performs a simple downscaling of shortwave radiation for +! land-atmosphere coupling models. The adjustments are only made for direct +! radiation without considering the impact of shadow factor. +! + IMPLICIT NONE + + integer, parameter :: S = 1370 ! solar constant (W/m**2) + real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith + ! relative limit for how much shortwave downscaling can be done (unitless) + real(r8), parameter :: shortwave_downscaling_limit = 0.2_r8 + + ! ARGUMENTS: + real(r8), intent(in) :: julian_day ! day of year + real(r8), intent(in) :: coszen ! zenith angle at an hour + real(r8), intent(in) :: cosazi ! azimuth angle at an hour + + real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) + real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] + real(r8), intent(in) :: forc_swrad_g ! downward shortwave (W/m**2) + + real(r8), intent(in) :: forc_topo_c ! column surface height (m) + real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] + real(r8), intent(out):: forc_swrad_c ! downward shortwave (W/m**2) + + ! tan value of topographic slope of each direction of one patch + real(r8), intent(in) :: slp_type_c (1:num_aspect_type) + ! area percentage of each character of one patch + real(r8), intent(in) :: area_type_c(1:num_aspect_type) + + ! LOCAL VARIABLES: + + real(r8) :: asp_type_c (1:num_aspect_type) ! topographic aspect fraction of one patch (%100) num_aspect_type = 1:north, 2:northeast, 3:east, + ! 4:southeast, 5:south, 6:southwest, 7:west, 8:northwest, 9:flat + real(r8) :: slp_type_c_rad ! Convert tan slope value to slope angle value + + real(r8) :: zen_rad, azi_rad ! rad of sun zenith and azimuth angle + integer :: idx_azi, idx_zen ! index used to cal shadow factor from + ! look up table + real(r8) :: sf_c ! shadow factor + real(r8) :: rt_R ! The ratio of the current distance between + ! the sun and the earth + real(r8) :: toa_swrad ! top of atmosphere shortwave radiation + real(r8) :: clr_idx ! atmospheric transparency + real(r8) :: diff_wgt ! diffuse weight + real(r8) :: k_c ! column broadband attenuation coefficient [Pa^-1] + real(r8) :: opt_factor ! optical length factor + real(r8) :: a_p + real(r8) :: diff_swrad_g, beam_swrad_g ! diffuse and beam radiation + real(r8) :: diff_swrad_c, beam_swrad_c ! downscaled diffuse, beam radiation + + real(r8) :: beam_swrad_type (1:num_aspect_type) ! beam radiation of one characterized patch + real(r8) :: cosill_type (1:num_aspect_type) ! illumination angle (cos) at defined types + + integer :: i +!------------------------------------------------------------------------------ + + ! Initialize aspect type + asp_type_c(1) = 0.0_r8*PI/180 ! north + asp_type_c(2) = 45.0_r8*PI/180 ! northeast + asp_type_c(3) = 90.0_r8*PI/180 ! east + asp_type_c(4) = 135.0_r8*PI/180 ! southeast + asp_type_c(5) = 180.0_r8*PI/180 ! south + asp_type_c(6) = 225.0_r8*PI/180 ! southwest + asp_type_c(7) = 270.0_r8*PI/180 ! west + asp_type_c(8) = 315.0_r8*PI/180 ! northwest + asp_type_c(9) = -9999.0_r8 ! flat + + ! calculate shadow factor according to sun zenith and azimuth angle + zen_rad = acos(coszen) + azi_rad = acos(cosazi) + + ! calculate top-of-atmosphere incident shortwave radiation + rt_R = 1-0.01672*cos(0.9856*(julian_day-4)) + toa_swrad = S*(rt_R**2)*coszen + + ! calculate clearness index + IF (toa_swrad < 1.e-7) THEN + clr_idx = 0 + ELSE + clr_idx = forc_swrad_g/toa_swrad + ENDIF + IF (clr_idx>1) clr_idx = 1 + + ! calculate diffuse weight + ! Ruiz-Arias, J. A., Alsamamra, H., Tovar-Pescador, J., & Pozo-Vázquez, D. (2010). + ! Proposal of a regressive model for the hourly diffuse solar radiation under all sky + ! conditions. Energy Conversion and Management, 51(5), 881-893. + ! https://doi.org/10.1016/j.enconman.2009.11.024 + diff_wgt = 0.952-1.041*exp(-1*exp(min(2.3-4.702*clr_idx,3.5))) + IF (diff_wgt>1) diff_wgt = 1 + IF (diff_wgt<0) diff_wgt = 0 + + ! calculate diffuse and beam radiation + diff_swrad_g = forc_swrad_g*diff_wgt + beam_swrad_g = forc_swrad_g*(1-diff_wgt) + + ! calculate broadband attenuation coefficient [Pa^-1] + IF (clr_idx.le.0) THEN + k_c = 0 + ELSE + k_c = log(clr_idx)/forc_pbot_c + ENDIF + + ! calculate factor to account for the difference of optical path length + ! due to pressure difference + opt_factor = exp(k_c*(forc_pbot_g-forc_pbot_c)) + ! Control the boundary of optical path length + IF ((opt_factor>10000).or.(opt_factor<-10000)) opt_factor = 0 + + ! Adjust the zenith angle so that the range of zenith angles is less than 85° + IF (zen_rad>thr) zen_rad = thr + + ! loop for four defined types to downscale beam radiation + DO i = 1, num_aspect_type + ! calculate the cosine of solar illumination angle, cos(θ), + ! ranging between −1 and 1, indicates if the sun is below or + ! above the local horizon (note that values lower than 0 are set to 0 indicate self shadow) + IF (i == 9) THEN + ! flat area, no slope + cosill_type(i) = 1.0_r8 + ELSE + slp_type_c_rad = atan(slp_type_c(i)) + cosill_type(i) = cos(slp_type_c_rad)+tan(zen_rad)*sin(slp_type_c_rad)*cos(asp_type_c(i)) + ENDIF + + ! Ensure that the cosine of illumination angle is between 0 and 1 + IF (cosill_type(i)>1) cosill_type(i) = 1 + IF (cosill_type(i)<0) cosill_type(i) = 0 + + ! downscaling beam radiation + a_p = area_type_c(i) + IF (a_p.gt.1.0) a_p = 1 + IF (a_p.lt.0) a_p = 0 + beam_swrad_type(i) = cosill_type(i)*opt_factor*a_p*beam_swrad_g + ENDDO + beam_swrad_c = sum(beam_swrad_type) + + ! do not downscale diffuse radiation + diff_swrad_c = diff_swrad_g + + forc_swrad_c = beam_swrad_c+diff_swrad_c + + ! But ensure that we don't depart too far from the atmospheric forcing value: + ! negative values of swrad are certainly bad, but small positive values might + ! also be bad. We can especially run into trouble due to the normalization: a + ! small swrad value in one column can lead to a big normalization factor, + ! leading to huge swrad values in other columns. + + forc_swrad_c = min(forc_swrad_c, & + forc_swrad_g * (1._r8 + shortwave_downscaling_limit)) + forc_swrad_c = max(forc_swrad_c, & + forc_swrad_g * (1._r8 - shortwave_downscaling_limit)) + ! Ensure that the denominator is not 0 during shortwave normalization + IF (forc_swrad_c < 1.e-4) forc_swrad_c = 0.0001 + + END SUBROUTINE downscale_shortwave_simple + + + +END MODULE MOD_ForcingDownscaling diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 new file mode 100644 index 0000000000..2a93a983f3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 @@ -0,0 +1,572 @@ +MODULE MOD_FrictionVelocity + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: moninobuk + PUBLIC :: moninobukm + PUBLIC :: moninobukini + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: psi + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of friction velocity, relation for potential temperature +! and humidity profiles of surface boundary layer. +! the scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation of +! sea surface fluxes using TOGA CORE and TAO data. J. Climate, Vol. +! 11: 2628-2644 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fm10m ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + +! real(r8), external :: psi ! stability FUNCTION for unstable case +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + + ! for 10 meter wind-velocity + zldis=10.+z0m + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm10m = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobuk + + + SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& + ustar,fh2m,fq2m,htop,fmtop,fm,fh,fq,fht,fqt,phih) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of friction velocity, relation for potential temperature +! and humidity profiles of surface boundary layer. the scheme is based +! on the work of Zeng et al. (1998): Intercomparison of bulk aerodynamic +! algorithms for the computation of sea surface fluxes using TOGA CORE +! and TAO data. J. Climate, Vol. 11: 2628-2644 +! +! !REVISIONS: +! 09/2017, Hua Yuan: adapted from moninobuk FUNCTION to calculate canopy +! top fm, fq and phih for roughness sublayer u/k profile +! calculation. +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: displat ! displacement height of the top layer [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: z0mt ! roughness length of the top layer, latent heat [m] + real(r8), intent(in) :: htop ! canopy top height of the top layer [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fmtop ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: fht ! integral of profile FUNCTION for heat at the top layer + real(r8), intent(out) :: fqt ! integral of profile FUNCTION for moisture at the top layer + real(r8), intent(out) :: phih ! phi(h), similarity FUNCTION for sensible heat + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + +! real(r8), external :: psi ! stability FUNCTION for unstable case +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + + ! for canopy top wind-velocity + !NOTE: changed for canopy top wind-velocity (no wake assumed) + zldis=htop-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fmtop = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for top layer temperature + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fht = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for canopy top phi(h) + ! CESM TECH NOTE EQ. (5.31) + zldis=htop-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + ! for top layer humidity + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fqt = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobukm + + real(r8) FUNCTION kmoninobuk(displa,obu,ustar,z) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! k profile calculation for bare ground case +! +! Created by Hua Yuan, 09/2017 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ustar ! friction velocity [m/s] + real(r8), intent(in) :: z ! height of windspeed [m] + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) phih ! phi(h), similarity FUNCTION for sensible heat + +!----------------------------------------------------------------------- + + IF ( z .le. displa ) THEN + kmoninobuk = 0. + RETURN + ENDIF + + ! for canopy top phi(h) + zldis=z-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + + kmoninobuk = vonkar*(z-displa)*ustar/phih + + END FUNCTION kmoninobuk + + real(r8) FUNCTION kintmoninobuk(displa,z0h,obu,ustar,ztop,zbot) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! k profile integration for bare ground case +! +! Created by Hua Yuan, 09/2017 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ustar ! friction velocity [m/s] + real(r8), intent(in) :: ztop ! height top + real(r8), intent(in) :: zbot ! height bottom + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + + real(r8) :: fh_top, fh_bot ! integral of profile FUNCTION for heat + +!----------------------------------------------------------------------- + + zldis=ztop-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh_top = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh_top = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh_top = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh_top = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + zldis=zbot-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh_bot = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh_bot = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh_bot = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh_bot = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + kintmoninobuk = (fh_top-fh_bot)/(vonkar*ustar) + + END FUNCTION kintmoninobuk + + + SUBROUTINE moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + +! ====================================================================== +! Original author: Yongjiu Dai, September 15, 1999 +! +! initialization of Monin-Obukhov length, +! the scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation +! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, Vol. +! 11: 2628-2644 +! ====================================================================== + + USE MOD_Precision + USE MOD_Const_Physical, only: grav, vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: ur ! wind speed at reference height [m/s] + real(r8), intent(in) :: thm ! intermediate variable (tm+0.0098*ht) + real(r8), intent(in) :: th ! potential temperature [kelvin] + real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) + real(r8), intent(in) :: dth ! diff of virtual temp. between ref. height and surface + real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8), intent(in) :: dqh ! diff of humidity between ref. height and surface + real(r8), intent(in) :: zldis ! reference height "minus" zero displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + + real(r8), intent(out) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(out) :: obu ! monin-obukhov length (m) + +!-------------------------- Local Variables ---------------------------- + real(r8) wc ! convective velocity [m/s] + real(r8) rib ! bulk Richardson number + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + +!----------------------------------------------------------------------- +! Initial values of u* and convective velocity + + wc=0.5 + IF(dthv >= 0.)THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF + + rib=grav*zldis*dthv/(thv*um*um) + + IF(rib >= 0.)THEN ! neutral or stable + zeta = rib*log(zldis/z0m)/(1.-5.*min(rib,0.19)) + zeta = min(2.,max(zeta,1.e-6)) + ELSE ! unstable + zeta = rib*log(zldis/z0m) + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu=zldis/zeta + + END SUBROUTINE moninobukini + + + real(r8) FUNCTION psi(k,zeta) + +!======================================================================= +! stability FUNCTION for unstable case (rib < 0) + + USE MOD_Precision + IMPLICIT NONE + + integer k + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) chik ! + + chik = (1.-16.*zeta)**0.25 + IF(k == 1)THEN + psi = 2.*log((1.+chik)*0.5)+log((1.+chik*chik)*0.5)-2.*atan(chik)+2.*atan(1.) + ELSE + psi = 2.*log((1.+chik*chik)*0.5) + ENDIF + + END FUNCTION psi + +END MODULE MOD_FrictionVelocity +! --------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 new file mode 100644 index 0000000000..07f8a0894c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 @@ -0,0 +1,1142 @@ +#include + +MODULE MOD_Glacier + +!----------------------------------------------------------------------- +! Energy and Mass Balance Model of LAND ICE (GLACIER / ICE SHEET) +! +! Original author: Yongjiu Dai, /05/2014/ +! +! !REVISIONS: +! 01/2023, Hua Yuan: added GLACIER_WATER_snicar() to account for SNICAR +! model effects on snow water [see snowwater_snicar()], snow +! layers combine [see snowlayerscombine_snicar()], snow layers +! divide [see snowlayersdivide_snicar()] +! +! 01/2023, Hua Yuan: added snow layer absorption in GLACIER_TEMP() +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: GLACIER_TEMP + PUBLIC :: GLACIER_WATER + PUBLIC :: GLACIER_WATER_snicar + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: groundfluxes_glacier + PRIVATE :: groundtem_glacier + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE GLACIER_TEMP (patchtype,lb ,nl_ice ,deltim ,& + zlnd ,zsno ,capr ,cnfac ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_hpbl ,& + forc_rhoair ,forc_psrf ,coszen ,sabg ,& + forc_frl ,fsno ,dz_icesno ,z_icesno ,& + zi_icesno ,t_icesno ,wice_icesno ,wliq_icesno ,& + scv ,snowdp ,imelt ,taux ,& + tauy ,fsena ,fevpa ,lfevpa ,& + fseng ,fevpg ,olrg ,fgrnd ,& + qseva ,qsdew ,qsubl ,qfros ,& + sm ,tref ,qref ,trad ,& + errore ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,pg_rain ,& + pg_snow ,t_precip ,snofrz ,sabg_snow_lyr) + +!----------------------------------------------------------------------- +! this is the main SUBROUTINE to execute the calculation of thermal processes +! and surface fluxes of the land ice (glacier and ice sheet) +! +! Original author: Yongjiu Dai and Nan Wei, /05/2014/ +! Modified by Nan Wei, 07/2017/ interaction btw prec and land ice +! FLOW DIAGRAM FOR GLACIER_TEMP.F90 +! +! GLACIER_TEMP ===> qsadv +! groundfluxes | ---------> |moninobukini +! | |moninobuk +! +! groundTem | ---------> |meltf +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: hvap,hsub,rgas,cpair,stefnc,tfrz,cpliq,cpice + USE MOD_FrictionVelocity + USE MOD_Qsadv + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: & + patchtype,& ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + lb, &! lower bound of array + nl_ice ! upper bound of array + + real(r8), intent(in) :: & + deltim, &! model time step [second] + zlnd, &! roughness length for ice surface [m] + zsno, &! roughness length for snow [m] + capr, &! tuning factor to turn first layer T into surface T + cnfac, &! Crank Nicholson factor between 0 and 1 + + ! Atmospherical variables and observational height + forc_hgt_u, &! observational height of wind [m] + forc_hgt_t, &! observational height of temperature [m] + forc_hgt_q, &! observational height of humidity [m] + forc_us, &! wind component in eastward direction [m/s] + forc_vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + forc_q, &! specific humidity at agcm reference height [kg/kg] + forc_rhoair, &! density air [kg/m3] + forc_psrf, &! atmosphere pressure at the surface [pa] + t_precip, &! snowfall/rainfall temperature [kelvin] + pg_rain, &! rainfall [kg/(m2 s)] + pg_snow, &! snowfall [kg/(m2 s)] + forc_hpbl, &! atmospheric boundary layer height [m] + + ! Radiative fluxes + coszen, &! cosine of the solar zenith angle + sabg, &! solar radiation absorbed by ground [W/m2] + forc_frl, &! atmospheric infrared (longwave) radiation [W/m2] + + ! State variable (1) + fsno, &! fraction of ground covered by snow + dz_icesno(lb:nl_ice), &! layer thickness [m] + z_icesno (lb:nl_ice), &! node depth [m] + zi_icesno(lb-1:nl_ice) ! interface depth [m] + + real(r8), intent(in) :: & + sabg_snow_lyr (lb:1) ! snow layer absorption [W/m-2] + + ! State variables (2) + real(r8), intent(inout) :: & + t_icesno(lb:nl_ice), &! snow/ice temperature [K] + wice_icesno(lb:nl_ice),&! ice lens [kg/m2] + wliq_icesno(lb:nl_ice),&! liquid water [kg/m2] + scv, &! snow cover, water equivalent [mm, kg/m2] + snowdp ! snow depth [m] + + real(r8), intent(inout) :: & + snofrz (lb:0) ! snow freezing rate (lyr) [kg m-2 s-1] + + integer, intent(out) :: & + imelt(lb:nl_ice) ! flag for melting or freezing [-] + + ! Output fluxes + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat to atmosphere [W/m2] + lfevpa, &! latent heat flux to atmosphere [W/m2] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + olrg, &! outgoing long-wave radiation to atmosphere + fgrnd, &! ground heat flux [W/m2] + + fevpa, &! evapotranspiration to atmosphere (mm h2o/s) + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros, &! surface dew added to snow pack (mm h2o /s) [+] + + sm, &! rate of snowmelt [kg/(m2 s)] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air specific humidity + trad, &! radiative temperature [K] + + emis, &! averaged bulk surface emissivity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! u* in similarity theory [m/s] + qstar, &! q* in similarity theory [kg/kg] + tstar, &! t* in similarity theory [K] + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + integer i,j + + real(r8) :: & + cgrnd, &! deriv. of ice energy flux wrt to ice temp [w/m2/k] + cgrndl, &! deriv, of ice sensible heat flux wrt ice temp [w/m2/k] + cgrnds, &! deriv of ice latent heat flux wrt ice temp [w/m**2/k] + degdT, &! d(eg)/dT + dqgdT, &! d(qg)/dT + eg, &! water vapor pressure at temperature T [pa] + egsmax, &! max. evaporation which ice can provide at one time step + egidif, &! the excess of evaporation over "egsmax" + emg, &! ground emissivity (0.96) + errore, &! energy balance error [w/m2] + fact(lb:nl_ice), &! used in computing tridiagonal matrix + htvp, &! latent heat of vapor of water (or sublimation) [j/kg] + qg, &! ground specific humidity [kg/kg] + qsatg, &! saturated humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + qred, &! ice surface relative humidity + thm, &! intermediate variable (forc_t+0.0098*forc_hgt_t) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + t_grnd, &! ground surface temperature [K] + t_icesno_bef(lb:nl_ice), &! ice/snow temperature before update + tinc, &! temperature difference of two time step + ur, &! wind speed at reference height [m/s] + xmf ! total latent heat of phase change of ground water + +!======================================================================= +! [1] Initial set and propositional variables +!======================================================================= + + ! temperature and water mass from previous time step + t_grnd = t_icesno(lb) + t_icesno_bef(lb:) = t_icesno(lb:) + + ! emissivity + emg = 0.97 + + ! latent heat, assumed that the sublimation occurs only as wliq_icesno=0 + htvp = hvap + IF(wliq_icesno(lb)<=0. .and. wice_icesno(lb)>0.) htvp = hsub + + ! potential temperature at the reference height + thm = forc_t + 0.0098*forc_hgt_t ! intermediate variable equivalent to + ! forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) ! potential T + thv = th*(1.+0.61*forc_q) ! virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) ! limit set to 0.1 + +!======================================================================= +! [2] specific humidity and its derivative at ground surface +!======================================================================= + + qred = 1. + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + + qg = qred*qsatg + dqgdT = qred*qsatgdT + +!======================================================================= +! [3] Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!======================================================================= + + CALL groundfluxes_glacier (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& + forc_hpbl,& + fsno,cgrnd,cgrndl,cgrnds,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq) + +!======================================================================= +! [4] Ground temperature +!======================================================================= + + CALL groundtem_glacier (patchtype,lb,nl_ice,deltim,& + capr,cnfac,dz_icesno,z_icesno,zi_icesno,& + t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! [5] Correct fluxes to present ice temperature +!======================================================================= + + t_grnd = t_icesno(lb) + tinc = t_icesno(lb) - t_icesno_bef(lb) + fseng = fseng + tinc*cgrnds + fevpg = fevpg + tinc*cgrndl + +! calculation of evaporative potential; flux in kg m-2 s-1. +! egidif holds the excess energy IF all water is evaporated +! during the timestep. this energy is later added to the sensible heat flux. + + egsmax = (wice_icesno(lb)+wliq_icesno(lb)) / deltim + + egidif = max( 0., fevpg - egsmax ) + fevpg = min ( fevpg, egsmax ) + fseng = fseng + htvp*egidif + +! total fluxes to atmosphere + fsena = fseng + fevpa = fevpg + lfevpa= htvp*fevpg ! W/m^2 (accounting for sublimation) + + qseva = 0. + qsubl = 0. + qfros = 0. + qsdew = 0. + + IF(fevpg >= 0)THEN + qseva = min(wliq_icesno(lb)/deltim, fevpg) + qsubl = fevpg - qseva + ELSE + IF(t_grnd < tfrz)THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF + ENDIF + +! ground heat flux + fgrnd = sabg + emg*forc_frl & + - emg*stefnc*t_icesno_bef(lb)**3*(t_icesno_bef(lb) + 4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq * pg_rain * (t_precip - t_icesno(lb)) & + + cpice * pg_snow * (t_precip - t_icesno(lb)) + +! outgoing long-wave radiation from ground + olrg = (1.-emg)*forc_frl + emg*stefnc * t_icesno_bef(lb)**4 & +! for conservation we put the increase of ground longwave to outgoing + + 4.*emg*stefnc*t_icesno_bef(lb)**3*tinc + +! averaged bulk surface emissivity + emis = emg + +! radiative temperature + trad = (olrg/stefnc)**0.25 + +!======================================================================= +! [6] energy balance error +!======================================================================= + + errore = sabg + forc_frl - olrg - fsena - lfevpa - xmf & + + cpliq * pg_rain * (t_precip-t_icesno(lb)) & + + cpice * pg_snow * (t_precip-t_icesno(lb)) + DO j = lb, nl_ice + errore = errore - (t_icesno(j)-t_icesno_bef(j))/fact(j) + ENDDO + +#if (defined CoLMDEBUG) + IF(abs(errore)>.2)THEN + write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' + write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) + STOP + ENDIF +100 format(10(f7.3)) +#endif + + END SUBROUTINE GLACIER_TEMP + + + + SUBROUTINE groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,& + ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& + hpbl,& + fsno,cgrnd,cgrndl,cgrnds,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of thermal processes +! and surface fluxes of land ice (glacier and ice sheet) +! +! Original author: Yongjiu Dai and Nan Wei, /05/2014/ +! +! !REVISIONS: +! 05/2023, Shaofeng Liu: add option to CALL moninobuk_leddy, the LargeEddy +! surface turbulence scheme (LZD2022); make a proper update of um. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT + USE MOD_TurbulenceLEddy + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + zlnd, &! roughness length for ice [m] + zsno, &! roughness length for snow [m] + + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + fsno, &! fraction of ground covered by snow + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + t_grnd, &! ground surface temperature [K] + qg, &! ground specific humidity [kg/kg] + dqgdT, &! d(qg)/dT + htvp ! latent heat of vapor of water (or sublimation) [j/kg] + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] + + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat to atmosphere [W/m2] + fevpa, &! evapotranspiration to atmosphere [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + cgrnd, &! deriv. of ice energy flux wrt to ice temp [w/m2/k] + cgrndl, &! deriv, of ice sensible heat flux wrt ice temp [w/m2/k] + cgrnds, &! deriv of ice latent heat flux wrt ice temp [w/m**2/k] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile FUNCTION for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0hg, &! roughness length over ground, sensible heat [m] + z0qg ! roughness length over ground, latent heat [m] + +!----------------------------------------------------------------------- +! initial roughness length + IF(fsno > 0.)THEN + ! z0mg = zsno + z0mg = 0.002 ! Table 1 of Brock et al., (2006) + z0hg = z0mg + z0qg = z0mg + ELSE + ! z0mg = zlnd + z0mg = 0.001 ! Table 1 of Brock et al., (2006) + z0hg = z0mg + z0qg = z0mg + ENDIF + +! potential temperature at the reference height + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + z0m = z0mg + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-t_grnd + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + raiw = rhoair/raw + cgrnds = raih + cgrndl = raiw*dqgdT + cgrnd = cgrnds + htvp*cgrndl + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + fseng = -raih*dth + fevpg = -raiw*dqh + + fsena = fseng + fevpa = fevpg + +! 2 m height air temperature + tref = (thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar)) + qref = ( qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar)) + + END SUBROUTINE groundfluxes_glacier + + + + SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& + capr,cnfac,dz_icesno,z_icesno,zi_icesno,& + t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! SNOW and LAND ICE temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of snow/ice is computed from the +! formulation used in SNTHERM (Jordan 1991) and Yen (1981), +! respectively. +! o Boundary conditions: +! F = Rnet - Hg - LEg (top) + HPR, F= 0 (base of the land ice column). +! o Ice/snow temperature is predicted from heat conduction in 10 ice +! layers and up to 5 snow layers. The thermal conductivities at the +! interfaces between two neighbor layers (j, j+1) are derived from an +! assumption that the flux across the interface is equal to that from +! the node j to the interface and the flux from the interface to the +! node j+1. The equation is solved using the Crank-Nicholson method +! and resulted in a tridiagonal system equation. +! +! Phase change (see meltf.F90) +! +! Original author: Yongjiu Dai, /05/2014/ +! +! !REVISIONS: +! 01/2023, Hua Yuan: account for snow layer absorption (SNICAR) in +! ground heat flux, temperature and melt calculation. +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Const_Physical, only: stefnc,cpice,cpliq,denh2o,denice,tfrz,tkwat,tkice,tkair + USE MOD_PhaseChange + USE MOD_Utils + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: patchtype !land patch type (0=soil, 1=urban and built-up, + !2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_ice !upper bound of array + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: dz_icesno(lb:nl_ice) !layer thickness [m] + real(r8), intent(in) :: z_icesno (lb:nl_ice) !node depth [m] + real(r8), intent(in) :: zi_icesno(lb-1:nl_ice) !interface depth [m] + + real(r8), intent(in) :: sabg !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: forc_frl !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: fseng !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpg !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgrnd !deriv. of ice energy flux wrt to ice temp [W/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [J/kg] + real(r8), intent(in) :: emg !ground emissivity (0.97 for snow, + real(r8), intent(in) :: t_precip !snowfall/rainfall temperature [kelvin] + real(r8), intent(in) :: pg_rain !rainfall [kg/(m2 s)] + real(r8), intent(in) :: pg_snow !snowfall [kg/(m2 s)] + + real(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] + + real(r8), intent(inout) :: t_icesno (lb:nl_ice) !snow and ice temperature [K] + real(r8), intent(inout) :: wice_icesno(lb:nl_ice) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_icesno(lb:nl_ice) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact(lb:nl_ice) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_ice) !flag for melting or freezing [-] + + real(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] + +!-------------------------- Local Variables ---------------------------- + real(r8) rhosnow ! partial density of water (ice + liquid) + real(r8) cv(lb:nl_ice) ! heat capacity [J/(m2 K)] + real(r8) thk(lb:nl_ice) ! thermal conductivity of layer + real(r8) tk(lb:nl_ice) ! thermal conductivity [W/(m K)] + + real(r8) at(lb:nl_ice) !"a" vector for tridiagonal matrix + real(r8) bt(lb:nl_ice) !"b" vector for tridiagonal matrix + real(r8) ct(lb:nl_ice) !"c" vector for tridiagonal matrix + real(r8) rt(lb:nl_ice) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_ice) ! heat diffusion through the layer interface [W/m2] + real(r8) fn1 (lb:nl_ice) ! heat diffusion through the layer interface [W/m2] + real(r8) dzm ! used in computing tridiagonal matrix + real(r8) dzp ! used in computing tridiagonal matrix + + real(r8) t_icesno_bef(lb:nl_ice) ! snow/ice temperature before update + real(r8) wice_icesno_bef(lb:0) ! ice lens [kg/m2] + real(r8) hs ! net energy flux into the surface (w/m2) + real(r8) dhsdt ! d(hs)/dT + real(r8) brr(lb:nl_ice) ! temporary set + + integer i,j + + real(r8) :: porsl(1:nl_ice) ! not used + real(r8) :: psi0 (1:nl_ice) ! not used +#ifdef Campbell_SOIL_MODEL + real(r8) :: bsw(1:nl_ice) ! not used +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8) :: theta_r (1:nl_ice), & + alpha_vgm(1:nl_ice), & + n_vgm (1:nl_ice), & + L_vgm (1:nl_ice), & + sc_vgm (1:nl_ice), & + fc_vgm (1:nl_ice) +#endif + +!----------------------------------------------------------------------- +! SNOW and LAND ICE heat capacity + cv(1:) = wice_icesno(1:)*cpice + wliq_icesno(1:)*cpliq + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + + IF(lb<=0)THEN + cv(:0) = cpliq*wliq_icesno(:0) + cpice*wice_icesno(:0) + ENDIF + +! SNOW and LAND ICE thermal conductivity [W/(m K)] + DO j = lb, nl_ice + thk(j) = tkwat + IF(t_icesno(j)<=tfrz) thk(j) = 9.828*exp(-0.0057*t_icesno(j)) + ENDDO + + IF(lb < 1)THEN + DO j = lb, 0 + rhosnow = (wice_icesno(j)+wliq_icesno(j))/dz_icesno(j) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(j) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(j) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(j) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(j) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(j) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(j) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO j = lb, nl_ice-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top ice node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and ice + IF((j==0) .and. (z_icesno(j+1)-zi_icesno(j)=1)THEN + gwat = pg_rain + sm - qseva + ELSE + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_icesno(lb:0),wice_icesno(lb:0),wliq_icesno(lb:0),gwat) + ENDIF + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + + IF(snl<0)THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lb = snl + 1 ! lower bound of array + CALL snowcompaction (lb,deltim,& + imelt(lb:0),fiold(lb:0),t_icesno(lb:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),forc_us,forc_vs,dz_icesno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + CALL snowlayerscombine (lb,snl,& + z_icesno(lb:1),dz_icesno(lb:1),zi_icesno(lb-1:1),& + wliq_icesno(lb:1),wice_icesno(lb:1),t_icesno(lb:1),scv,snowdp) + + ! Divide thick snow elements + IF(snl<0) & + CALL snowlayersdivide (lb,snl,& + z_icesno(lb:0),dz_icesno(lb:0),zi_icesno(lb-1:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),t_icesno(lb:0)) + ENDIF + + IF (snl > maxsnl) THEN + wice_icesno(maxsnl+1:snl) = 0. + wliq_icesno(maxsnl+1:snl) = 0. + t_icesno (maxsnl+1:snl) = 0. + z_icesno (maxsnl+1:snl) = 0. + dz_icesno (maxsnl+1:snl) = 0. + ENDIF + + IF(lb >= 1)THEN + wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) + wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) + ENDIF + + END SUBROUTINE GLACIER_WATER + + + SUBROUTINE GLACIER_WATER_snicar ( nl_ice ,maxsnl ,deltim ,& + z_icesno ,dz_icesno ,zi_icesno ,t_icesno ,& + wliq_icesno ,wice_icesno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat ,ssi ,& + wimp ,forc_us ,forc_vs ,& + ! SNICAR + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + +!======================================================================= + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_SnowLayersCombineDivide + USE MOD_SoilSnowHydrology + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: nl_ice ! upper bound of array + integer, intent(in) :: maxsnl ! maximum number of snow layers + + real(r8), intent(in) :: & + deltim , &! time step (s) + ssi , &! irreducible water saturation of snow + wimp , &! water impermeable IF porosity less than wimp + pg_rain , &! rainfall (mm h2o/s) + pg_snow , &! snowfall (mm h2o/s) + sm , &! snow melt (mm h2o/s) + qseva , &! ground surface evaporation rate (mm h2o/s) + qsdew , &! ground surface dew formation (mm h2o /s) [+] + qsubl , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros , &! surface dew added to snow pack (mm h2o /s) [+] + fiold(maxsnl+1:nl_ice) ! fraction of ice relative to the total water + + ! flag for: melting=1, freezing=2, nothing happened=0 + integer, intent(in) :: imelt(maxsnl+1:nl_ice) + integer, intent(inout) :: snl ! lower bound of array + + real(r8), intent(inout) :: & + z_icesno (maxsnl+1:nl_ice) , &! layer depth (m) + dz_icesno (maxsnl+1:nl_ice) , &! layer thickness (m) + zi_icesno (maxsnl :nl_ice) , &! interface level below a "z" level (m) + t_icesno (maxsnl+1:nl_ice) , &! snow/ice skin temperature (K) + wice_icesno(maxsnl+1:nl_ice) , &! ice lens (kg/m2) + wliq_icesno(maxsnl+1:nl_ice) , &! liquid water (kg/m2) + scv , &! snow mass (kg/m2) + snowdp ! snow depth (m) + + real(r8), intent(out) :: & + gwat ! net water input from top (mm/s) + + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs + +! Aerosol Fluxes (Jan. 07, 2023) + ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8), intent(in) :: forc_aer ( 14 ) + + real(r8), intent(inout) :: & + mss_bcpho (maxsnl+1:0), &! mass of hydrophobic BC in snow (lyr) [kg] + mss_bcphi (maxsnl+1:0), &! mass of hydrophillic BC in snow (lyr) [kg] + mss_ocpho (maxsnl+1:0), &! mass of hydrophobic OC in snow (lyr) [kg] + mss_ocphi (maxsnl+1:0), &! mass of hydrophillic OC in snow (lyr) [kg] + mss_dst1 (maxsnl+1:0), &! mass of dust species 1 in snow (lyr) [kg] + mss_dst2 (maxsnl+1:0), &! mass of dust species 2 in snow (lyr) [kg] + mss_dst3 (maxsnl+1:0), &! mass of dust species 3 in snow (lyr) [kg] + mss_dst4 (maxsnl+1:0) ! mass of dust species 4 in snow (lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) + +!-------------------------- Local Variables ---------------------------- + + integer lb, j + +!======================================================================= +! [1] update the liquid water within snow layer and the water onto the +! ice surface +! +! Snow melting is treated in a realistic fashion, with meltwater +! percolating downward through snow layers as long as the snow is +! unsaturated. Once the underlying snow is saturated, any additional +! meltwater runs off. When glacier ice melts, however, the meltwater is +! assumed to remain in place until it refreezes. In warm parts of the +! ice sheet, the meltwater does not refreeze, but stays in place +! indefinitely. +!======================================================================= + + lb = snl + 1 + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_icesno(lb:0),wice_icesno(lb:0),wliq_icesno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + + IF(snl<0)THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lb = snl + 1 ! lower bound of array + CALL snowcompaction (lb,deltim,& + imelt(lb:0),fiold(lb:0),t_icesno(lb:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),forc_us,forc_vs,dz_icesno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + CALL snowlayerscombine_snicar (lb,snl,& + z_icesno(lb:1),dz_icesno(lb:1),zi_icesno(lb-1:1),& + wliq_icesno(lb:1),wice_icesno(lb:1),t_icesno(lb:1),scv,snowdp,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + + ! Divide thick snow elements + IF(snl<0) & + CALL snowlayersdivide_snicar (lb,snl,& + z_icesno(lb:0),dz_icesno(lb:0),zi_icesno(lb-1:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),t_icesno(lb:0),& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + + IF (snl > maxsnl) THEN + wice_icesno(maxsnl+1:snl) = 0. + wliq_icesno(maxsnl+1:snl) = 0. + t_icesno (maxsnl+1:snl) = 0. + z_icesno (maxsnl+1:snl) = 0. + dz_icesno (maxsnl+1:snl) = 0. + ENDIF + + IF(lb >= 1)THEN + wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) + wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) + ENDIF + + END SUBROUTINE GLACIER_WATER_snicar + +END MODULE MOD_Glacier diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 new file mode 100644 index 0000000000..0aad77fe8e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 @@ -0,0 +1,264 @@ +MODULE MOD_GroundFluxes + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: GroundFluxes + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & + us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, t_grnd, qg, rss, dqgdT, htvp, & + fsno, cgrnd, cgrndl, cgrnds, & + t_soil, t_snow, q_soil, q_snow, & + taux, tauy, fseng, fseng_soil, fseng_snow, & + fevpg, fevpg_soil, fevpg_snow, tref, qref, & + z0m, z0hg, zol, rib, ustar, qstar, tstar, fm, fh, fq) + +!----------------------------------------------------------------------- +! This is the main SUBROUTINE to execute the calculation of thermal +! processes and surface fluxes +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002 +! +! !REVISIONS: +! 09/2019, Hua Yuan: removed sigf to be consistent with PFT runs, removed +! fsena, fevpa, renamed z0ma to z0m. +! +! 05/2023, Shaofeng Liu: add option to call moninobuk_leddy, the LargeEddy +! surface turbulence scheme (LZD2022); make a proper update of um. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + USE mod_namelist, only: DEF_USE_CBL_HEIGHT,DEF_RSS_SCHEME + USE MOD_TurbulenceLEddy + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + hpbl, &! atmospheric boundary layer height [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + fsno, &! fraction of ground covered by snow + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + t_grnd, &! ground surface temperature [K] + t_soil, &! ground soil temperature [K] + t_snow, &! ground snow temperature [K] + qg, &! ground specific humidity [kg/kg] + q_soil, &! ground soil specific humidity [kg/kg] + q_snow, &! ground snow specific humidity [kg/kg] + dqgdT, &! d(qg)/dT + rss, &! soil surface resistance for evaporation [s/m] + htvp ! latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil,&! sensible heat flux from ground soil [W/m2] + fseng_snow,&! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil,&! evaporation heat flux from ground soil [mm/s] + fevpg_snow,&! evaporation heat flux from ground snow [mm/s] + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile FUNCTION for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] + +!----------------------------------------------------------------------- + ! initial roughness length + ! 09/2019, yuan: change to a combination of zlnd and zsno + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg + + ! potential temperature at the reference height + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + z0m = z0mg + + !----------------------------------------------------------------------- + ! Compute sensible and latent fluxes and their derivatives with respect + ! to ground temperature using ground temperatures from previous time step. + !----------------------------------------------------------------------- + ! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-t_grnd + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + + ! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + ! 2023.04.06, weinan + !thvstar=tstar+0.61*th*qstar + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- + + ! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + + ! 08/23/2019, yuan: add soil surface resistance (rss) + IF (dqh > 0.) THEN + raiw = rhoair/raw !dew case. assume no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + raiw = rss*rhoair/raw + ELSE + raiw = rhoair/(raw+rss) + ENDIF + ENDIF + + cgrnds = raih + cgrndl = raiw*dqgdT + cgrnd = cgrnds + htvp*cgrndl + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + + ! surface fluxes of momentum, sensible and latent + ! using ground temperatures from previous time step + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + fseng = -raih*dth + fevpg = -raiw*dqh + + fseng_soil = -raih * (thm - t_soil) + fseng_snow = -raih * (thm - t_snow) + fevpg_soil = -raiw * ( qm - q_soil) + fevpg_snow = -raiw * ( qm - q_snow) + + ! 2 m height air temperature + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE GroundFluxes + +END MODULE MOD_GroundFluxes diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 new file mode 100644 index 0000000000..bf41b8b68b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 @@ -0,0 +1,447 @@ +#include + +MODULE MOD_GroundTemperature + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: GroundTemperature + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE GroundTemperature (patchtype,is_dry_lake,lb,nl_soil,deltim,& + capr,cnfac,vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm,& + sc_vgm , fc_vgm,& +#endif + csol,k_solids,dksatu,dksatf,dkdry,& + BA_alpha,BA_beta,& + sigf,dz_soisno,z_soisno,zi_soisno,& + t_soisno,t_grnd,t_soil,t_snow,wice_soisno,wliq_soisno,scv,snowdp,fsno,& + frl,dlrad,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + fseng,fseng_soil,fseng_snow,fevpg,fevpg_soil,fevpg_snow,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! Snow and soil temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of soil is computed from +! the algorithm of Johansen (as reported by Farouki 1981), and of snow +! is from the formulation used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg + Hpr(top), F= 0 (base of the soil column). +! o Soil / snow temperature is predicted from heat conduction +! in 10 soil layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers (j, +! j+1) are derived from an assumption that the flux across the +! interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. The equation is solved +! using the Crank-Nicholson method and resulted in a tridiagonal +! system equation. +! +! Phase change (see meltf.F90) +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2018 +! +! !REVISIONS: +! 07/2017, Nan Wei: interaction btw prec and land surface +! 01/2019, Nan Wei: USE the new version of soil thermal parameters to +! calculate soil temperature +! 01/2023, Hua Yuan: modified ground heat flux, temperature and meltf +! calculation for SNICAR model +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: stefnc,denh2o,denice,tfrz,cpice,cpliq,tkwat,tkice,tkair + USE MOD_Namelist, only: DEF_USE_SNICAR, DEF_SPLIT_SOILSNOW + USE MOD_PhaseChange + USE MOD_SoilThermalParameters + USE MOD_SPMD_Task + USE MOD_Utils + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_soil !upper bound of array + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + logical, intent(in) :: is_dry_lake + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor + !to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz in mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand + + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil), & ! + alpha_vgm(1:nl_soil), & ! + n_vgm (1:nl_soil), & ! + L_vgm (1:nl_soil), & ! + sc_vgm (1:nl_soil), & ! + fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal cond. of minerals soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal cond. of sat. unfrozen soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal cond. of sat. frozen soil [W/m-K] + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal cond. of dry soil [W/m-K] + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal cond. + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal cond. + + real(r8), intent(in) :: sigf !frac. of veg, excluding snow-covered veg [-] + real(r8), intent(in) :: dz_soisno(lb:nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_soisno (lb:nl_soil) !node depth [m] + real(r8), intent(in) :: zi_soisno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabg_snow_lyr(lb:1) !snow layer absorption [W/m-2] + + real(r8), intent(in) :: t_grnd !ground surface temperature [K] + real(r8), intent(in) :: t_soil !ground soil temperature [K] + real(r8), intent(in) :: t_snow !ground snow temperature [K] + real(r8), intent(in) :: sabg !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: sabg_soil !solar radiation absorbed by soil [W/m2] + real(r8), intent(in) :: sabg_snow !solar radiation absorbed by snow [W/m2] + real(r8), intent(in) :: frl !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: dlrad !downward longwave radiation blow the canopy [W/m2] + real(r8), intent(in) :: fseng !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fseng_soil !sensible heat flux from ground soil [W/m2] + real(r8), intent(in) :: fseng_snow !sensible heat flux from ground snow [W/m2] + real(r8), intent(in) :: fevpg !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: fevpg_soil !evaporation heat flux from ground soil [mm/s] + real(r8), intent(in) :: fevpg_snow !evaporation heat flux from ground snow [mm/s] + real(r8), intent(in) :: cgrnd !deriv. of soil energy flux wrt to soil temp [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] + real(r8), intent(in) :: emg !ground emissivity (0.97 for snow, 0.96 for soil) + real(r8), intent(in) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: t_precip !snowfall/rainfall temperature [kelvin] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + real(r8), intent(in) :: fsno !snow fractional cover [-] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + + real(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + + real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_soisno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) wice_soisno_bef(lb:0) !ice lens [kg/m2] + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) hs_soil !net energy flux into the surface soil (w/m2) + real(r8) hs_snow !net energy flux into the surface snow (w/m2) + real(r8) dhsdT !d(hs)/dT + real(r8) brr (lb:nl_soil) !temporary set + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice (1:nl_soil) !volumetric fraction ice lens within soil + real(r8) rhosnow !partial density of water (ice + liquid) + integer i,j + +!----------------------------------------------------------------------- +! soil ground and wetland heat capacity + DO i = 1, nl_soil + vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) + vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_soisno(i) + ENDDO + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + +! Snow heat capacity + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) + ENDIF + +! Snow thermal conductivity + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_soisno(i)+wliq_soisno(i))/dz_soisno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + IF((i==0) .and. (z_soisno(i+1)-zi_soisno(i)100% cover + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs = sabg_snow_lyr(lb) + sabg_soil + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) + ELSE + hs = sabg + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) + ENDIF + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + hs = hs - emg*stefnc*t_grnd**4 + ELSE + ! 03/08/2020, yuan: separate soil and snow + hs = hs - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 + + ! 03/08/2020, yuan: calculate hs_soil, hs_snow for + ! soil/snow fractional cover separately. + hs_soil = dlrad*emg & + - emg*stefnc*t_soil**4 & + - (fseng_soil+fevpg_soil*htvp) & + + cpliq*pg_rain*(t_precip-t_soil) & + + cpice*pg_snow*(t_precip-t_soil) + + hs_soil = hs_soil*(1.-fsno) + sabg_soil + + hs_snow = dlrad*emg & + - emg*stefnc*t_snow**4 & + - (fseng_snow+fevpg_snow*htvp) & + + cpliq*pg_rain*(t_precip-t_snow) & + + cpice*pg_snow*(t_precip-t_snow) + + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs_snow = hs_snow*fsno + sabg_snow_lyr(lb) + ELSE + hs_snow = hs_snow*fsno + sabg_snow + ENDIF + + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + + IF (abs(sabg_soil+sabg_snow-sabg)>1.e-6 .or. abs(hs_soil+hs_snow-hs)>1.e-6) THEN + print *, "MOD_GroundTemperature.F90: Error in spliting soil and snow surface!" + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "hs", hs, "hs_soil", hs_soil, "hs_snow:", hs_snow, "fsno:", fsno + print *, "hs_soil+hs_snow", hs_soil+hs_snow, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow + print *, "lb:", lb, "sabg_snow_lyr:", sabg_snow_lyr + CALL CoLM_stop() + ENDIF + ENDIF + + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + t_soisno_bef(lb:) = t_soisno(lb:) + + j = lb + fact(j) = deltim / cv(j) * dz_soisno(j) & + / (0.5*(z_soisno(j)-zi_soisno(j-1)+capr*(z_soisno(j+1)-zi_soisno(j-1)))) + + DO j = lb + 1, nl_soil + fact(j) = deltim/cv(j) + ENDDO + + DO j = lb, nl_soil - 1 + fn(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) + ENDDO + fn(nl_soil) = 0. + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = lb + dzp = z_soisno(j+1)-z_soisno(j) + at(j) = 0. + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + + ! the first layer + IF (j<1 .and. DEF_SPLIT_SOILSNOW) THEN ! snow covered and split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*fsno*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs_snow - fsno*dhsdT*t_soisno(j) + cnfac*fn(j) ) + ELSE ! not a snow layer or don't split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs - dhsdT*t_soisno(j) + cnfac*fn(j) ) + ENDIF + + DO j = lb + 1, nl_soil - 1 + + dzm = (z_soisno(j)-z_soisno(j-1)) + dzp = (z_soisno(j+1)-z_soisno(j)) + + IF (j < 1) THEN ! snow layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (DEF_USE_SNICAR) THEN + rt(j) = t_soisno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF + ENDIF + + IF (j == 1) THEN ! the first soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (.not.DEF_SPLIT_SOILSNOW) THEN + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) & + - (1.-fsno)*dhsdT*fact(j) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) & + + fact(j)*( hs_soil - (1.-fsno)*dhsdT*t_soisno(j) ) + ENDIF + ENDIF + + IF (j > 1) THEN ! inner soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF + + ENDDO + + j = nl_soil + dzm = (z_soisno(j)-z_soisno(j-1)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*tk(j-1)/dzm + ct(j) = 0. + rt(j) = t_soisno(j) - cnfac*fact(j)*fn(j-1) + +! solve for t_soisno + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_soisno) +!======================================================================= +! melting or freezing +!======================================================================= + + DO j = lb, nl_soil - 1 + fn1(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) + ENDDO + fn1(nl_soil) = 0. + + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + + DO j = lb + 1, nl_soil + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO + + + IF (DEF_USE_SNICAR) THEN + + wice_soisno_bef(lb:0) = wice_soisno(lb:0) + + CALL meltf_snicar (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,sabg_snow_lyr(lb:),dhsdT, & + t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_soisno(1:nl_soil)) + + ! layer freezing mass flux (positive): + DO j = lb, 0 + IF (imelt(j)==2 .and. j<1) THEN + snofrz(j) = max(0._r8,(wice_soisno(j)-wice_soisno_bef(j)))/deltim + ENDIF + ENDDO + + ELSE + CALL meltf (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,dhsdT, & + t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_soisno(1:nl_soil)) + ENDIF + +!----------------------------------------------------------------------- + + END SUBROUTINE GroundTemperature + +END MODULE MOD_GroundTemperature diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 new file mode 100644 index 0000000000..bb64bd23c7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 @@ -0,0 +1,550 @@ +#include + +MODULE MOD_HighRes_Parameters + +!----------------------------------------------------------------------- +! USES: +USE MOD_Precision +USE MOD_NetCDFSerial +USE MOD_Namelist, only : DEF_USE_SNICAR, DEF_HighResSoil, DEF_HighResVeg, DEF_PROSPECT !, DEF_Satellite_Params +USE MOD_Namelist, only : DEF_HighResUrban_albedo +! USE MOD_Namelist, only : DEF_file_soiloptics, DEF_file_satellite_params, DEF_sla_varname +IMPLICIT NONE +SAVE + +REAL(r8) :: reflectance ( 0:15, 211, 2 ) ! (species, leaf/stem, wavelength) +REAL(r8) :: transmittance ( 0:15, 211, 2 ) ! (species, leaf/stem, wavelength) +! REAL(r8) :: soil_alb ( 211 ) ! (wavelength) +REAL(r8) :: kw ( 211 ) ! (wavelength) +REAL(r8) :: nw ( 211 ) ! (wavelength) +REAL(r8) :: clr_frac ( 211, 89, 5 ) ! (wvl_ctr, SZA, loc ) +REAL(r8) :: cld_frac ( 211, 5 ) ! (wvl_ctr, loc, ) +! Urban hyperspectral albedo +REAL(r8), ALLOCATABLE :: urban_albedo( :, :, : ) ! (cluster_id, season wavelength) +REAL(r8), ALLOCATABLE :: mean_albedo ( :, : ) ! (season, wavelength) +REAL(r8), ALLOCATABLE :: lat_north ( : ) ! (cluster_id) +REAL(r8), ALLOCATABLE :: lat_south ( : ) ! (cluster_id) +REAL(r8), ALLOCATABLE :: lon_east ( : ) ! (cluster_id) +REAL(r8), ALLOCATABLE :: lon_west ( : ) ! (cluster_id) + +! ! ONLY VALID when DEF_Satellite_Params is TRUE +! REAL(r8) :: chl_satellite(366) +! REAL(r8) :: sla_satellite + +PUBLIC :: flux_frac_init +PUBLIC :: leaf_property_init +! PUBLIC :: surface_albedo_single_init +PUBLIC :: get_water_optical_properties +PUBLIC :: get_loc_params +! PUBLIC :: satellite_PROSPECT_init + +CONTAINS +!----------------------------------------------------------------------- + +subroutine flux_frac_init( ) + + USE NETCDF + IMPLICIT NONE + !------------------------------------------------------------------- + INTEGER :: i, ncid, varid + CHARACTER(len=256) :: file_path + !------------------------------------------------------------------- + + ! open the file base on the SZA and latitude + file_path = "/ddn_lustre/weiliren/data/CoLM_hires_params/fsds/swnb_480bnd_fsds.nc" + + ! open the file + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , trace=trim(file_path)//' cannot open' ) + + ! get the variable id + + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , trace=trim(file_path)//' cannot open' ) + + ! get the variable id + CALL nccheck( nf90_inq_varid(ncid, 'flx_frc_cld', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_get_var(ncid, varid, cld_frac) , trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_inq_varid(ncid, 'flx_frc_clr', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_get_var(ncid, varid, clr_frac) , trace=trim(file_path)//' cannot get data' ) + + ! close the file + CALL nccheck( nf90_close(ncid) , trace=trim(file_path)//' cannot close' ) +end subroutine flux_frac_init + + +subroutine leaf_property_init( rho_p, tau_p ) + ! Plant Functional Type classification + !--------------------------- + ! 0 not vegetated + ! 1 needleleaf evergreen temperate tree + ! 2 needleleaf evergreen boreal tree + ! 3 needleleaf deciduous boreal tree + ! 4 broadleaf evergreen tropical tree + ! 5 broadleaf evergreen temperate tree + ! 6 broadleaf deciduous tropical tree + ! 7 broadleaf deciduous temperate tree + ! 8 broadleaf deciduous boreal tree + ! 9 broadleaf evergreen shrub + !10 broadleaf deciduous temperate shrub + !11 broadleaf deciduous boreal shrub + !12 c3 arctic grass + !13 c3 non-arctic grass + !14 c4 grass + !15 c3 crop + !16 c3_irrigated + + USE NETCDF + IMPLICIT NONE + !------------------------------------------------------------------- + REAL(r8), INTENT(IN) :: rho_p(2, 2, 0:15), tau_p(2, 2, 0:15) ! (leaf/stem, vis/nir, species) + INTEGER :: i, j, ncid, varid, ndims, dimids(3), dimlen(3) + CHARACTER(len=256) :: file_path + REAL(r8), allocatable :: reflectance_temp(:,:,:), transmittance_temp(:,:,:) + !------------------------------------------------------------------- + ! open the file base on the SZA and latitude + + ! Parameters for hyperspectral leaf properties + IF ( DEF_HighResVeg .OR. DEF_PROSPECT ) THEN + + file_path = "/ddn_lustre/weiliren/data/CoLM_hires_params/leaf_optical_properties/colm_PFT_params.nc" + + ! open the file + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , trace=trim(file_path)//' cannot open' ) + + ! get the variable id + CALL nccheck( nf90_inq_varid(ncid, 'reflectance', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids) , trace=trim(file_path)//' cannot get var dims' ) + + do i = 1, size(dimlen) + CALL nccheck( nf90_inquire_dimension(ncid, dimids(i), len=dimlen(i)) ) + end do + + ! allocate the memory, and get the reflectance data + allocate( reflectance_temp( dimlen(1), dimlen(2), dimlen(3) ) ) + CALL nccheck( nf90_get_var(ncid, varid, reflectance_temp) ) + + CALL nccheck( nf90_inq_varid(ncid, 'transmittance', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids) , trace=trim(file_path)//' cannot get var dims' ) + + ! allocate the memory, and get the transmittance data + allocate( transmittance_temp( dimlen(1), dimlen(2), dimlen(3) ) ) + CALL nccheck( nf90_get_var(ncid, varid, transmittance_temp) ) + + ! close the file + CALL nccheck( nf90_close(ncid) , trace=trim(file_path)//' cannot close' ) + + do i = 0, 15 + do j = 1, 2 + reflectance (i, :, j) = reflectance_temp (:, j, i+1) + transmittance(i, :, j) = transmittance_temp(:, j, i+1) + end do + end do + + DEALLOCATE( reflectance_temp ) + DEALLOCATE( transmittance_temp ) + + ELSE + + do i = 0, 15 + reflectance(i, 1 :29 , 1) = rho_p(1, 1, i) + reflectance(i, 1 :29 , 2) = rho_p(1, 2, i) + reflectance(i, 30:211, 1) = rho_p(2, 1, i) + reflectance(i, 30:211, 2) = rho_p(2, 2, i) + + transmittance(i, 1 :29 , 1) = tau_p(1, 1, i) + transmittance(i, 1 :29 , 2) = tau_p(1, 2, i) + transmittance(i, 30:211, 1) = tau_p(2, 1, i) + transmittance(i, 30:211, 2) = tau_p(2, 2, i) + end do + + END IF + + ! 3. Close file + +end subroutine leaf_property_init + + +! No longer used +! subroutine surface_albedo_single_init( ) +! IMPLICIT NONE +! INTEGER :: i, unit +! !------------------------------------------------------------------- + +! unit = 10 + +! if (DEF_file_soiloptics == 'Null') then +! write(*,*) "Error: soiloptics file is not defined" +! stop +! end if +! open(unit=unit, file=DEF_file_soiloptics, status='old', action='read') + +! do i = 1, 211 +! read(unit,*) soil_alb(i) +! end do +! close(unit) +! end subroutine surface_albedo_single_init + + +SUBROUTINE get_water_optical_properties( ) + IMPLICIT NONE + INTEGER :: i, unit + + unit = 10 + open(unit=unit, file='/ddn_lustre/weiliren/data/CoLM_hires_params/water_params.txt', status='old') + + do i = 1, 211 + read(unit,*) kw(i), nw(i) + end do + close(unit) +END SUBROUTINE get_water_optical_properties + + +real function rad2deg(angle_in_rad) + real, intent(in) :: angle_in_rad + rad2deg = angle_in_rad * (180.0 / 3.14159265358979323846) +end function rad2deg + + +SUBROUTINE get_loc_params( fsds, idate, coszen, lat, lon, clr_frac_all, cld_frac_all, dir_frac, dif_frac ) + USE MOD_OrbCoszen + USE MOD_TimeManager + + implicit none + real(r8), intent(in) :: fsds + integer, INTENT(in) :: idate(3) + real(r8), intent(in) :: coszen + real(r8), intent(in) :: lat, lon + real(r8), intent(in) :: clr_frac_all( 211, 89, 5 ) + real(r8), intent(in) :: cld_frac_all( 211, 5 ) + + real, intent(out) :: dir_frac(211) + real, intent(out) :: dif_frac(211) + + INTEGER :: loc_index, sza + real(r8) :: lat_deg, sunang, cloud, difrat, vnrat, calday, a + + ! index = 1 - 90 + sza = int(rad2deg(acos(min(1._r8,max(-1._r8,coszen))))) + 1 + sza = max(1, min(ubound(clr_frac_all,2), sza)) ! 自动适配 + + ! combine cloud and clear sky fraction + a = max(0., fsds) + calday = calendarday(idate) + sunang = orb_coszen(calday, lon, lat) + + ! turn lat from radians to degrees + lat_deg = abs(rad2deg(lat)) + + ! check if the lat in tropical/temperate/polar + IF (lat_deg >= 0.0 .AND. lat_deg < 23.5) THEN + loc_index = 5 + + ELSE IF (lat_deg >= 23.5 .AND. lat_deg < 66.5) THEN + ! temperate summer + IF (calday > 91 .AND. calday < 274) THEN + loc_index = 4 + ELSE + loc_index = 3 + END IF + + ELSE IF (lat_deg >= 66.5 .AND. lat_deg <= 90.0) THEN + IF (calday > 91 .AND. calday < 274) THEN + loc_index = 2 + ELSE + loc_index = 1 + END IF + + ENDIF + + dir_frac = clr_frac_all(:, sza, loc_index) + dif_frac = cld_frac_all(:, loc_index) + +END SUBROUTINE get_loc_params + +! SUBROUTINE satellite_PROSPECT_init() +! USE NETCDF +! IMPLICIT NONE +! !------------------------------------------------------------------- +! INTEGER :: i, j, ncid, varid +! INTEGER, ALLOCATABLE :: dimids(:) +! !------------------------------------------------------------------- +! if (DEF_file_satellite_params == 'null') then +! write(*,*) "ERROR: DEF_file_satellite_params is not set" +! stop +! end if + +! ! 1. Open file +! CALL nccheck( nf90_open(trim(DEF_file_satellite_params), NF90_NOWRITE, ncid), trace=trim(DEF_file_satellite_params)//' cannot open' ) + +! ! 2. Read data: chl +! CALL nccheck( nf90_inq_varid(ncid, 'chl', varid), trace=trim(DEF_file_satellite_params)//' cannot find variable' ) +! CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids), trace=trim(DEF_file_satellite_params)//' cannot inquire variable' ) +! CALL nccheck( nf90_get_var(ncid, varid, chl_satellite), trace='chl cannot get variable' ) + +! ! 2. Read data: sla +! CALL nccheck( nf90_inq_varid(ncid, DEF_sla_varname, varid), trace=trim(DEF_file_satellite_params)//' cannot find variable' ) +! CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids), trace=trim(DEF_file_satellite_params)//' cannot inquire variable' ) +! CALL nccheck( nf90_get_var(ncid, varid, sla_satellite), trace=trim(DEF_sla_varname)//' cannot get variable' ) + +! ! 3. Close file +! call nccheck( nf90_close(ncid) ) +! END SUBROUTINE satellite_PROSPECT_init + + +! ======== Calculate Reflectance & Transmittance using PROSPECT ======== +SUBROUTINE update_params_PROSPECT(ipft, reflectance_in, transmittance_in,& + reflectance_p, transmittance_p ,& + soilmoisture ) + USE MOD_prospect_DB + USE MOD_dataSpec_PDB, only : nw + IMPLICIT NONE + !------------------------------------------------------------------- + REAL(r8), PARAMETER :: SLA(0: 15) & ! unit g/m^2 + = (/ 0.0 , 0.0100, 0.0100, 0.0202, 0.0190, 0.0190, 0.0308, 0.0308 & + , 0.0308, 0.0180, 0.0307, 0.0307, 0.0402, 0.0402, 0.0385, 0.0402 /) + + REAL(r8), PARAMETER :: vmax25_p(0: 15) & ! + = (/ 52.0, 55.0, 42.0, 29.0, 41.0, 51.0, 36.0, 30.0 & + , 40.0, 36.0, 30.0, 19.0, 21.0, 26.0, 25.0, 57.0 /) * 1.e-6 + + INTEGER , INTENT(IN) :: ipft + REAL(r8), INTENT(IN) :: reflectance_in(16, 211, 2), transmittance_in(16, 211, 2) + REAL(r8), INTENT(IN) :: soilmoisture + + REAL(r8), INTENT(OUT) :: reflectance_p(211, 2), transmittance_p(211, 2) + + ! Params for PROSPECT + REAL(r8) :: N ! leaf structure coefficient (n_layer) + REAL(r8) :: Cab ! Chlorophyll Content + REAL(r8) :: Car ! Carotenoid, unit [μg cm^−2] + REAL(r8) :: Anth ! Anthocyanin + REAL(r8) :: Cbrown ! Brown Pigment + REAL(r8) :: Cw ! Equivalent Water Thickness + REAL(r8) :: Cm ! Dry Matter Content (g cm^-2) + REAL(r8) :: RT(nw, 2) ! nw = 2101, defined in dataSpec_PDB + + ! temporary variables + REAL(r8) :: vmax25 ! maximum carboxylation rate at 25 C at canopy top, unit [mol m-2 s-1] + + INTEGER :: i, j + !------------------------------------------------------------------- + ! 1. Set Car, Cbrown, Anth + Car = 8.0 + Cbrown = 0.01 + Anth = 0.0 + + ! 2. Calculate N & Cm + ! SLA: Specific Leaf Area, unit [m^2 g-1] -> [cm^2 mg-1] + N = (0.9 * (SLA(ipft) * 10.) + 0.025) / ((SLA(ipft) * 10.) - 0.01) + ! Cm: Dry Matter Content, unit [g cm^-2] <- SLA [m^2 g-1] + Cm = 1.0 / (SLA(ipft) * 1.e4) + + ! 3. Calculate Cab + vmax25 = vmax25_p(ipft) + Cab = ((vmax25 * 1.e6) - 3.72) / 1.3 + + ! 4. Calculate Cw + Cw = 0.01 - (( 0.01 - 0. ) * exp( -5.5 * soilmoisture )) + + ! 5. Calculate reflectance & transmittance + CALL prospect_DB(N,Cab,Car,Anth,Cbrown,Cw,Cm,RT) + + j = 1 + do i = 1, nw, 10 + reflectance_p(j, 1) = RT(i, 1) + transmittance_p(j, 1) = RT(i, 2) + j = j + 1 + end do + + reflectance_p(:,2) = reflectance_in(ipft, :, 2) + transmittance_p(:,2) = transmittance_in(ipft, :, 2) +END SUBROUTINE update_params_PROSPECT +! ====================================================================== + +! SUBROUTINE satellite_PROSPECT(ipft, reflectance_in, transmittance_in,& +! reflectance_p, transmittance_p ,& +! soilmoisture, doy ) +! USE MOD_prospect_DB +! USE MOD_dataSpec_PDB, only : nw +! IMPLICIT NONE +! !------------------------------------------------------------------- + +! INTEGER , INTENT(IN) :: ipft +! REAL(r8), INTENT(IN) :: reflectance_in(16, 211, 2), transmittance_in(16, 211, 2) +! REAL(r8), INTENT(IN) :: soilmoisture +! INTEGER, INTENT(IN) :: doy + +! REAL(r8), INTENT(OUT) :: reflectance_p(211, 2), transmittance_p(211, 2) + +! ! Params for PROSPECT +! REAL(r8) :: N ! leaf structure coefficient (n_layer) +! REAL(r8) :: Cab ! Chlorophyll Content +! REAL(r8) :: Car ! Carotenoid, unit [μg cm^−2] +! REAL(r8) :: Anth ! Anthocyanin +! REAL(r8) :: Cbrown ! Brown Pigment +! REAL(r8) :: Cw ! Equivalent Water Thickness +! REAL(r8) :: Cm ! Dry Matter Content (g cm^-2) +! REAL(r8) :: RT(nw, 2) ! nw = 2101, defined in dataSpec_PDB +! INTEGER :: i, j + +! !NOTE: All from Wang 2025 NC +! ! 1. Set Car, Cbrown, Anth +! Cbrown = 0.0 +! Anth = 0.0 + +! ! 2. Calculate N & Cm +! ! SLA: Specific Leaf Area, unit [cm^2 mg-1] +! N = 1.4 +! ! N = (0.9 * sla_satellite + 0.025) / (sla_satellite - 0.01) +! ! Cm: Dry Matter Content, unit [g cm^-2] <- SLA [cm^2 mg-1] +! Cm = 1.0 / (sla_satellite * 1.e3) + +! ! 3. Calculate Cab +! Cab = chl_satellite(doy) +! Car = Cab / 7. + +! ! 4. Calculate Cw +! Cw = 0.009 ! cm +! ! Cw = 0.01 - (( 0.01 - 0. ) * exp( -5.5 * soilmoisture )) + +! ! 5. Calculate reflectance & transmittance +! CALL prospect_DB(N,Cab,Car,Anth,Cbrown,Cw,Cm,RT) + +! j = 1 +! do i = 1, nw, 10 +! reflectance_p(j, 1) = RT(i, 1) +! transmittance_p(j, 1) = RT(i, 2) +! j = j + 1 +! end do + +! reflectance_p(:,2) = reflectance_in(ipft, :, 2) +! transmittance_p(:,2) = transmittance_in(ipft, :, 2) + +! END SUBROUTINE satellite_PROSPECT + +SUBROUTINE readin_urban_albedo() + + USE NETCDF + IMPLICIT NONE + INTEGER :: ncid, ndims, dimids(3), dimlen(3) + INTEGER :: albedo_varid, mean_albedo_varid, & + lat_north_varid, lat_south_varid, & + lon_east_varid , lon_west_varid + CHARACTER(len=256) :: file_path + INTEGER :: i + + ! 设置文件路径 + file_path = DEF_HighResUrban_albedo + + ! 打开 NetCDF 文件 + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , & + trace=trim(file_path)//' cannot open' ) + + ! 获取变量 ID + CALL nccheck( nf90_inq_varid(ncid, 'urban_albedo', albedo_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'mean_albedo', mean_albedo_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lat_north', lat_north_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lat_south', lat_south_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lon_east', lon_east_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lon_west', lon_west_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + ! 获取变量维度信息 + CALL nccheck( nf90_inquire_variable(ncid, albedo_varid, ndims=ndims, dimids=dimids) , & + trace=trim(file_path)//' cannot get var dims' ) + + ! 获取各维度长度 + do i = 1, ndims + CALL nccheck( nf90_inquire_dimension(ncid, dimids(i), len=dimlen(i)) ) + end do + + ! 分配内存 + if (.not. allocated(urban_albedo)) then + allocate( urban_albedo(dimlen(1), dimlen(2), dimlen(3)) ) ! (cluster_id, season, wavelength) + end if + + if (.not. allocated(mean_albedo)) then + allocate( mean_albedo(dimlen(2), dimlen(3)) ) ! (season, wavelength) + end if + + if (.not. allocated(lat_north)) then + allocate( lat_north(dimlen(1)) ) ! (cluster_id) + end if + + if (.not. allocated(lat_south)) then + allocate( lat_south(dimlen(1)) ) ! (cluster_id) + end if + + if (.not. allocated(lon_east)) then + allocate( lon_east(dimlen(1)) ) ! (cluster_id) + end if + + if (.not. allocated(lon_west)) then + allocate( lon_west(dimlen(1)) ) ! (cluster_id) + end if + + ! 读取数据 + CALL nccheck( nf90_get_var(ncid, albedo_varid, urban_albedo) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, mean_albedo_varid, mean_albedo) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lat_north_varid, lat_north) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lat_south_varid, lat_south) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lon_east_varid, lon_east) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lon_west_varid, lon_west) , & + trace=trim(file_path)//' cannot get data' ) + + ! 关闭文件 + CALL nccheck( nf90_close(ncid) , & + trace=trim(file_path)//' cannot close' ) + +END SUBROUTINE readin_urban_albedo + +SUBROUTINE deallocate_urban_albedo() + IMPLICIT NONE + + IF (ALLOCATED(urban_albedo)) THEN + DEALLOCATE(urban_albedo) + END IF + + IF (ALLOCATED(mean_albedo)) THEN + DEALLOCATE(mean_albedo) + END IF + + IF (ALLOCATED(lat_north)) THEN + DEALLOCATE(lat_north) + END IF + + IF (ALLOCATED(lat_south)) THEN + DEALLOCATE(lat_south) + END IF + + IF (ALLOCATED(lon_east)) THEN + DEALLOCATE(lon_east) + END IF + + IF (ALLOCATED(lon_west)) THEN + DEALLOCATE(lon_west) + END IF + +END SUBROUTINE deallocate_urban_albedo + +END MODULE MOD_HighRes_Parameters diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 new file mode 100644 index 0000000000..bdaede3215 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 @@ -0,0 +1,5057 @@ +#include + +MODULE MOD_Hist + +!---------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Write out gridded model results to history files. +! +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +! +! !REVISIONS: +! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version +! +! TODO...(need complement) +!---------------------------------------------------------------------------- + + USE MOD_Vars_1DAccFluxes + USE MOD_Vars_Global, only: spval + USE MOD_NetCDFSerial + + USE MOD_HistGridded +#if (defined UNSTRUCTURED || defined CATCHMENT) + USE MOD_HistVector +#endif +#ifdef SinglePoint + USE MOD_HistSingle +#endif +#ifdef CatchLateralFlow + USE MOD_Catch_Hist +#endif +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeHist +#endif +#ifdef EXTERNAL_LAKE + USE MOD_Lake_Hist +#endif + + PUBLIC :: hist_init + PUBLIC :: hist_out + PUBLIC :: hist_final + + character(len=10) :: HistForm ! 'Gridded', 'Vector', 'Single' + + character(len=256) :: file_last = 'null' + +!-------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE hist_init (dir_hist, lulcc_call) + + IMPLICIT NONE + + character(len=*) , intent(in) :: dir_hist + logical, optional, intent(in) :: lulcc_call + + CALL allocate_acc_fluxes () + CALL FLUSH_acc_fluxes () + + HistForm = 'Gridded' +#if (defined UNSTRUCTURED || defined CATCHMENT) + IF (DEF_HISTORY_IN_VECTOR) THEN + HistForm = 'Vector' + ENDIF +#endif +#ifdef SinglePoint + HistForm = 'Single' +#endif + + IF (HistForm == 'Gridded') THEN + IF (present(lulcc_call)) THEN + CALL hist_gridded_init (dir_hist, lulcc_call) + ELSE + CALL hist_gridded_init (dir_hist) + ENDIF +#ifdef SinglePoint + ELSEIF (HistForm == 'Single') THEN + CALL hist_single_init () +#endif + ENDIF + +#ifdef CatchLateralFlow + CALL hist_basin_init () +#endif + +#ifdef GridRiverLakeFlow + CALL hist_grid_riverlake_init (HistForm) +#endif + + END SUBROUTINE hist_init + + + SUBROUTINE hist_final () + + IMPLICIT NONE + + CALL deallocate_acc_fluxes () + +#ifdef SinglePoint + CALL hist_single_final () +#endif + +#ifdef CatchLateralFlow + CALL hist_basin_final () +#endif + +#ifdef GridRiverLakeFlow + CALL hist_grid_riverlake_final () +#endif + + END SUBROUTINE hist_final + + + SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & + dir_hist, casename) + +!======================================================================= +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_SPMD_Task + USE MOD_Vars_1DAccFluxes, filter_dt_ => filter_dt + USE MOD_Vars_1DFluxes, only: nsensor + USE MOD_Vars_TimeVariables, only: wa, wat, wetwat, wdsrf + USE MOD_Block + USE MOD_DataType + USE MOD_LandPatch + USE MOD_SpatialMapping + USE MOD_Vars_TimeInvariants, only: patchtype, patchclass, patchmask +#ifdef URBAN_MODEL + USE MOD_LandUrban +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_LandPFT, only: patch_pft_s +#endif +#if (defined CaMa_Flood) + USE MOD_CaMa_Vars !definition of CaMa variables +#endif + USE MOD_Forcing, only: forcmask_pch +#ifdef DataAssimilation + USE MOD_DA_TWS, only: fslp_k_mon + USE MOD_Vars_Global + USE MOD_DA_Vars_TimeVariables + USE MOD_Const_Physical, only: denh2o +#endif + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + type(timestamp), intent(in) :: itstamp + type(timestamp), intent(in) :: etstamp + type(timestamp), intent(in) :: ptstamp + + character(len=*), intent(in) :: dir_hist + character(len=*), intent(in) :: casename + + ! Local variables + logical :: lwrite + character(len=256) :: file_hist + integer :: itime_in_file +#if (defined CaMa_Flood) + character(len=256) :: file_hist_cama + integer :: itime_in_file_cama +#endif + integer :: month, day + integer :: days_month(1:12) + character(len=10) :: cdate + + type(block_data_real8_2d) :: sumarea + type(block_data_real8_2d) :: sumarea_dt + type(block_data_real8_2d) :: sumarea_urb + type(block_data_real8_2d) :: sumarea_one + real(r8), allocatable :: vecacc (:) + real(r8), allocatable :: nac_one (:) + logical, allocatable :: filter (:) + logical, allocatable :: filter_dt (:) + +#ifdef CROP + type(block_data_real8_2d) :: sumarea_crop + type(block_data_real8_2d) :: sumarea_irrig + logical, allocatable :: filter_crop (:) + logical, allocatable :: filter_irrig (:) +#endif + + integer i, u +#ifdef URBAN_MODEL + logical, allocatable :: filter_urb (:) +#endif + +#ifdef DataAssimilation + integer :: np + real(r8), allocatable :: a_wliq_h2osoi_5cm (:) + real(r8), allocatable :: a_t_soisno_5cm (:) + real(r8), allocatable :: a_wliq_soisno_ens_mean (:,:) + real(r8), allocatable :: a_wliq_soisno_5cm_ens (:,:) + real(r8), allocatable :: a_wliq_h2osoi_5cm_a (:) + real(r8), allocatable :: a_t_soisno_ens_mean (:,:) + real(r8), allocatable :: a_t_soisno_5cm_ens (:,:) + real(r8), allocatable :: a_t_soisno_5cm_a (:) + real(r8), allocatable :: a_t_brt_smap_a (:,:) + real(r8), allocatable :: a_t_brt_fy3d_a (:,:) + real(r8), allocatable :: a_wliq_soisno_5cm_ens_std (:) + real(r8), allocatable :: a_t_soisno_5cm_ens_std (:) + real(r8), allocatable :: a_t_brt_smap_ens_std (:,:) + real(r8), allocatable :: a_t_brt_fy3d_ens_std (:,:) +#endif + + IF (itstamp <= ptstamp) THEN + CALL FLUSH_acc_fluxes () + RETURN + ELSE + CALL accumulate_fluxes () + ENDIF + + select CASE (trim(adjustl(DEF_HIST_FREQ))) + CASE ('TIMESTEP') + lwrite = .true. + CASE ('HOURLY') + lwrite = isendofhour (idate, deltim) .or. (.not. (itstamp < etstamp)) + CASE ('DAILY') + lwrite = isendofday (idate, deltim) .or. (.not. (itstamp < etstamp)) + CASE ('MONTHLY') + lwrite = isendofmonth(idate, deltim) .or. (.not. (itstamp < etstamp)) + CASE ('YEARLY') + lwrite = isendofyear (idate, deltim) .or. (.not. (itstamp < etstamp)) + CASE default + lwrite = .false. + write(*,*) & + 'Warning : Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.' + write(*,*) & + ' Set to FALSE by default. ' + END select + + IF (lwrite) THEN + + CALL julian2monthday(idate(1), idate(2), month, day) + + days_month = (/31,28,31,30,31,30,31,31,30,31,30,31/) + IF (isleapyear(idate(1))) days_month(2) = 29 + + IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN + write(cdate,'(i4.4)') idate(1) +#ifdef SinglePoint + IF (USE_SITE_HistWriteBack) THEN + memory_to_disk = isendofyear(idate,deltim) .or. (.not. (itstamp < etstamp)) + ENDIF +#endif + ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN + write(cdate,'(i4.4,"-",i2.2)') idate(1), month +#ifdef SinglePoint + IF (USE_SITE_HistWriteBack) THEN + memory_to_disk = isendofmonth(idate,deltim) .or. (.not. (itstamp < etstamp)) + ENDIF +#endif + ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN + write(cdate,'(i4.4,"-",i2.2,"-",i2.2)') idate(1), month, day +#ifdef SinglePoint + IF (USE_SITE_HistWriteBack) THEN + memory_to_disk = isendofday(idate,deltim) .or. (.not. (itstamp < etstamp)) + ENDIF +#endif + ELSE + write(*,*) 'Warning : Please USE one of DAY/MONTH/YEAR for history group.' + ENDIF + +#if (defined CaMa_Flood) + ! add variables to write cama-flood output. + ! file name of cama-flood output + file_hist_cama = trim(dir_hist) // '/' // trim(casename) //'_hist_cama_'//trim(cdate)//'.nc' + ! write CaMa-Flood output + CALL hist_write_cama_time (file_hist_cama, 'time', idate, itime_in_file_cama) +#endif + + file_hist = trim(dir_hist) // '/' // trim(casename) //'_hist_'//trim(cdate)//'.nc' + + CALL hist_write_time (file_hist, file_last, 'time', idate, itime_in_file) + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (filter (numpatch)) + allocate (filter_dt (numpatch)) + allocate (vecacc (numpatch)) + ENDIF +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + allocate (filter_urb (numurban)) + ENDIF +#endif +#ifdef CROP + IF (numpatch > 0) THEN + allocate (filter_crop (numpatch)) + allocate (filter_irrig (numpatch)) + ENDIF +#endif + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (p_is_io) THEN + CALL allocate_block_data (ghist, sumarea) + CALL allocate_block_data (ghist, sumarea_dt) +#ifdef URBAN_MODEL + CALL allocate_block_data (ghist, sumarea_urb) +#endif +#ifdef CROP + CALL allocate_block_data (ghist, sumarea_crop) + CALL allocate_block_data (ghist, sumarea_irrig) +#endif + ENDIF + ENDIF + + ! --------------------------------------------------- + ! Meteorological forcing and patch mask filter applying. + ! --------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype < 99 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + filter_dt = filter .and. patchmask .and. (nac_dt > 0) + + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + CALL mp2g_hist%get_sumarea (sumarea_dt, filter_dt) + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (trim(file_hist) /= trim(file_last)) THEN + CALL hist_write_var_real8_2d (file_hist, 'landarea', ghist, -1, sumarea, & + compress = 1, longname = 'land area', units = 'km2') + CALL hist_write_var_real8_2d (file_hist, 'landfraction', ghist, -1, landfraction, & + compress = 1, longname = 'land fraction', units = '-') + ENDIF + ENDIF + +#ifdef CROP + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + filter_crop(:) = patchtype < 99 + filter_crop(:) = patchclass == 12 + + IF (DEF_forcing%has_missing_value) THEN + filter_crop = filter_crop .and. forcmask_pch + ENDIF + + filter_crop = filter_crop .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea_crop, filter_crop) + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (trim(file_hist) /= trim(file_last)) THEN + CALL hist_write_var_real8_2d (file_hist, 'croparea', ghist, 1, sumarea_crop, & + compress = 1, longname = 'crop area', units = 'km2') + ENDIF + ENDIF + + IF (DEF_USE_IRRIGATION) THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF((pftclass(patch_pft_s(i)).GE.npcropmin).and.(MOD(pftclass(patch_pft_s(i)),2).EQ.0))THEN + filter_irrig(i) = .true. + ELSE + filter_irrig(i) = .false. + ENDIF + ELSE + filter_irrig(i) = .false. + ENDIF + ENDDO + IF (DEF_forcing%has_missing_value) THEN + filter_irrig = filter_irrig .and. forcmask_pch + ENDIF + filter_irrig = filter_irrig .and. patchmask + ENDIF + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea_irrig, filter_irrig) + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (trim(file_hist) /= trim(file_last)) THEN + CALL hist_write_var_real8_2d (file_hist, 'irrigarea', ghist, 1, sumarea_irrig, & + compress = 1, longname = 'irrigation area', units = 'km2') + ENDIF + ENDIF +#endif + + ! wind in eastward direction [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%xy_us, & + a_us, file_hist, 'f_xy_us', itime_in_file, sumarea, filter, & + 'wind in eastward direction', 'm/s') + + ! wind in northward direction [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%xy_vs, & + a_vs, file_hist, 'f_xy_vs', itime_in_file, sumarea, filter, & + 'wind in northward direction','m/s') + + ! temperature at reference height [kelvin] + CALL write_history_variable_2d ( DEF_hist_vars%xy_t, & + a_t, file_hist, 'f_xy_t', itime_in_file, sumarea, filter, & + 'temperature at reference height','kelvin') + + ! specific humidity at reference height [kg/kg] + CALL write_history_variable_2d ( DEF_hist_vars%xy_q, & + a_q, file_hist, 'f_xy_q', itime_in_file, sumarea, filter, & + 'specific humidity at reference height','kg/kg') + + ! convective precipitation [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xy_prc, & + a_prc, file_hist, 'f_xy_prc', itime_in_file, sumarea, filter, & + 'convective precipitation','mm/s') + + ! large scale precipitation [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xy_prl, & + a_prl, file_hist, 'f_xy_prl', itime_in_file, sumarea, filter, & + 'large scale precipitation','mm/s') + + ! atmospheric pressure at the surface [pa] + CALL write_history_variable_2d ( DEF_hist_vars%xy_pbot, & + a_pbot, file_hist, 'f_xy_pbot', itime_in_file, sumarea, filter, & + 'atmospheric pressure at the surface','pa') + + ! atmospheric infrared (longwave) radiation [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%xy_frl, & + a_frl, file_hist, 'f_xy_frl', itime_in_file, sumarea, filter, & + 'atmospheric infrared (longwave) radiation','W/m2') + + ! downward solar radiation at surface [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%xy_solarin, & + a_solarin, file_hist, 'f_xy_solarin', itime_in_file, sumarea, filter, & + 'downward solar radiation at surface','W/m2') + + ! rain [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xy_rain, & + a_rain, file_hist, 'f_xy_rain', itime_in_file, sumarea, filter, & + 'rain','mm/s') + + ! snow [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xy_snow, & + a_snow, file_hist, 'f_xy_snow', itime_in_file, sumarea, filter, & + 'snow','mm/s') + + IF (DEF_USE_CBL_HEIGHT) THEN + ! atmospheric boundary layer height [m] + CALL write_history_variable_2d ( DEF_hist_vars%xy_hpbl, & + a_hpbl, file_hist, 'f_xy_hpbl', itime_in_file, sumarea, filter, & + 'boundary layer height','m') + ENDIF + + IF (DEF_USE_OZONESTRESS)THEN + CALL write_history_variable_2d ( DEF_hist_vars%o3uptakesun, & + a_o3uptakesun, file_hist, 'f_o3uptakesun', itime_in_file, sumarea, filter, & + 'Accumulated ozone uptake by sunlit leaf','mmol O3 m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%o3uptakesha, & + a_o3uptakesha, file_hist, 'f_o3uptakesha', itime_in_file, sumarea, filter, & + 'Accumulated ozone uptake by shaded leaf','mmol O3 m-2') + ENDIF + + ! ------------------------------------------------------------------------------------------ + ! Mapping the fluxes and state variables at patch [numpatch] to grid + ! ------------------------------------------------------------------ + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype < 99 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! wind stress: E-W [kg/m/s2] + CALL write_history_variable_2d ( DEF_hist_vars%taux, & + a_taux, file_hist, 'f_taux', itime_in_file, sumarea, filter, & + 'wind stress: E-W','kg/m/s2') + + ! wind stress: N-S [kg/m/s2] + CALL write_history_variable_2d ( DEF_hist_vars%tauy, & + a_tauy, file_hist, 'f_tauy', itime_in_file, sumarea, filter, & + 'wind stress: N-S','kg/m/s2') + + ! sensible heat from canopy height to atmosphere [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%fsena, & + a_fsena, file_hist, 'f_fsena', itime_in_file, sumarea, filter, & + 'sensible heat from canopy height to atmosphere','W/m2') + + ! latent heat flux from canopy height to atmosphere [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%lfevpa, & + a_lfevpa, file_hist, 'f_lfevpa', itime_in_file, sumarea, filter, & + 'latent heat flux from canopy height to atmosphere','W/m2') + + ! evapotranspiration from canopy to atmosphere [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%fevpa, & + a_fevpa, file_hist, 'f_fevpa', itime_in_file, sumarea, filter, & + 'evapotranspiration from canopy height to atmosphere','mm/s') + + ! sensible heat from leaves [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%fsenl, & + a_fsenl, file_hist, 'f_fsenl', itime_in_file, sumarea, filter, & + 'sensible heat from leaves','W/m2') + + ! evaporation+transpiration from leaves [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%fevpl, & + a_fevpl, file_hist, 'f_fevpl', itime_in_file, sumarea, filter, & + 'evaporation+transpiration from leaves','mm/s') + + ! transpiration rate [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%etr, & + a_etr, file_hist, 'f_etr', itime_in_file, sumarea, filter, & + 'transpiration rate','mm/s') + + ! sensible heat flux from ground [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%fseng, & + a_fseng, file_hist, 'f_fseng', itime_in_file, sumarea, filter, & + 'sensible heat flux from ground','W/m2') + + ! evaporation heat flux from ground [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%fevpg, & + a_fevpg, file_hist, 'f_fevpg', itime_in_file, sumarea, filter, & + 'evaporation flux from ground','mm/s') + + ! ground heat flux [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%fgrnd, & + a_fgrnd, file_hist, 'f_fgrnd', itime_in_file, sumarea, filter, & + 'ground heat flux','W/m2') + + ! solar absorbed by sunlit canopy [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%sabvsun, & + a_sabvsun, file_hist, 'f_sabvsun', itime_in_file, sumarea, filter, & + 'solar absorbed by sunlit canopy','W/m2') + + ! solar absorbed by shaded [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%sabvsha, & + a_sabvsha, file_hist, 'f_sabvsha', itime_in_file, sumarea, filter, & + 'solar absorbed by shaded','W/m2') + + ! solar absorbed by ground [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%sabg, & + a_sabg, file_hist, 'f_sabg', itime_in_file, sumarea, filter, & + 'solar absorbed by ground','W/m2') + + ! outgoing long-wave radiation from ground+canopy [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%olrg, & + a_olrg, file_hist, 'f_olrg', itime_in_file, sumarea, filter, & + 'outgoing long-wave radiation from ground+canopy','W/m2') + + ! net radiation [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%rnet, & + a_rnet, file_hist, 'f_rnet', itime_in_file, sumarea, filter, & + 'net radiation','W/m2') + + ! the error of water balance [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xerr, & + a_xerr, file_hist, 'f_xerr', itime_in_file, sumarea, filter, & + 'the error of water banace','mm/s') + + ! the error of energy balance [W/m2] + CALL write_history_variable_2d ( DEF_hist_vars%zerr, & + a_zerr, file_hist, 'f_zerr', itime_in_file, sumarea, filter, & + 'the error of energy balance','W/m2') + + ! surface runoff [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%rsur, & + a_rsur, file_hist, 'f_rsur', itime_in_file, sumarea, filter, & + 'surface runoff','mm/s') + +#ifndef CatchLateralFlow + ! saturation excess surface runoff [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%rsur_se, & + a_rsur_se, file_hist, 'f_rsur_se', itime_in_file, sumarea, filter, & + 'saturation excess surface runoff','mm/s') + + ! infiltration excess surface runoff [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%rsur_ie, & + a_rsur_ie, file_hist, 'f_rsur_ie', itime_in_file, sumarea, filter, & + 'infiltration excess surface runoff','mm/s') +#endif + + ! subsurface runoff [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%rsub, & + a_rsub, file_hist, 'f_rsub', itime_in_file, sumarea, filter, & + 'subsurface runoff','mm/s') + + ! total runoff [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%rnof, & + a_rnof, file_hist, 'f_rnof', itime_in_file, sumarea, filter, & + 'total runoff','mm/s') + +#ifdef DataAssimilation + IF (DEF_DA_TWS_GRACE) THEN + ! slope factors for runoff [-] + IF (p_is_worker .and. (numpatch > 0)) THEN + vecacc = fslp_k_mon(month, :) + WHERE (vecacc /= spval) vecacc = vecacc*nac + ENDIF + CALL write_history_variable_2d(.true., & + vecacc, file_hist, 'f_slope_factor_k', itime_in_file, sumarea, filter, & + 'slope factor [k] for runoff', '-') + ENDIF +#endif + +#ifdef CatchLateralFlow + ! rate of surface water depth change [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xwsur, & + a_xwsur, file_hist, 'f_xwsur', itime_in_file, sumarea, filter, & + 'rate of surface water depth change','mm/s') + + ! rate of ground water change [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%xwsub, & + a_xwsub, file_hist, 'f_xwsub', itime_in_file, sumarea, filter, & + 'rate of ground water change','mm/s') + + ! fraction of flooded area [-] + CALL write_history_variable_2d ( DEF_hist_vars%fldarea, & + a_fldarea, file_hist, 'f_fldarea', itime_in_file, sumarea, filter, & + 'fraction of flooded area','-') +#endif + + ! interception [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%qintr, & + a_qintr, file_hist, 'f_qintr', itime_in_file, sumarea, filter, & + 'interception','mm/s') + + ! infiltration [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%qinfl, & + a_qinfl, file_hist, 'f_qinfl', itime_in_file, sumarea, filter, & + 'f_qinfl','mm/s') + + ! throughfall [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%qdrip, & + a_qdrip, file_hist, 'f_qdrip', itime_in_file, sumarea, filter, & + 'total throughfall','mm/s') + + ! total water storage [mm] + CALL write_history_variable_2d ( DEF_hist_vars%wat, & + a_wat, file_hist, 'f_wat', itime_in_file, sumarea, filter, & + 'total water storage','mm') + + ! instantaneous total water storage [mm] + IF (p_is_worker .and. (numpatch > 0)) THEN + vecacc = wat + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%wat_inst, & + vecacc, file_hist, 'f_wat_inst', itime_in_file, sumarea, filter, & + 'instantaneous total water storage','mm') + + ! canopy assimilation rate [mol m-2 s-1] + CALL write_history_variable_2d ( DEF_hist_vars%assim, & + a_assim, file_hist, 'f_assim', itime_in_file, sumarea, filter, & + 'canopy assimilation rate','mol m-2 s-1') + + ! respiration (plant+soil) [mol m-2 s-1] + CALL write_history_variable_2d ( DEF_hist_vars%respc, & + a_respc, file_hist, 'f_respc', itime_in_file, sumarea, filter, & + 'respiration (plant+soil)','mol m-2 s-1') + + ! groundwater recharge rate [mm/s] + CALL write_history_variable_2d ( DEF_hist_vars%qcharge & + .and. (.not.DEF_USE_VariablySaturatedFlow), & + a_qcharge, file_hist, 'f_qcharge', itime_in_file, sumarea, filter, & + 'groundwater recharge rate','mm/s') + + ! ground surface temperature [K] + CALL write_history_variable_2d ( DEF_hist_vars%t_grnd, & + a_t_grnd, file_hist, 'f_t_grnd', itime_in_file, sumarea, filter, & + 'ground surface temperature','K') + + ! leaf temperature [K] + CALL write_history_variable_2d ( DEF_hist_vars%tleaf, & + a_tleaf, file_hist, 'f_tleaf', itime_in_file, sumarea, filter, & + 'leaf temperature','K') + + ! depth of water on foliage [mm] + CALL write_history_variable_2d ( DEF_hist_vars%ldew, & + a_ldew, file_hist, 'f_ldew', itime_in_file, sumarea, filter, & + 'depth of water on foliage','mm') + + ! snow cover, water equivalent [mm] + CALL write_history_variable_2d ( DEF_hist_vars%scv, & + a_scv, file_hist, 'f_scv', itime_in_file, sumarea, filter, & + 'snow cover, water equivalent','mm') + + ! snow depth [meter] + CALL write_history_variable_2d ( DEF_hist_vars%snowdp, & + a_snowdp, file_hist, 'f_snowdp', itime_in_file, sumarea, filter, & + 'snow depth','meter') + + ! fraction of snow cover on ground + CALL write_history_variable_2d ( DEF_hist_vars%fsno, & + a_fsno, file_hist, 'f_fsno', itime_in_file, sumarea, filter, & + 'fraction of snow cover on ground','-') + + ! fraction of saturation area on ground + CALL write_history_variable_2d ( DEF_hist_vars%frcsat, & + a_frcsat, file_hist, 'f_frcsat', itime_in_file, sumarea, filter, & + 'fraction of saturation area on ground','-') + + ! fraction of veg cover, excluding snow-covered veg [-] + CALL write_history_variable_2d ( DEF_hist_vars%sigf, & + a_sigf, file_hist, 'f_sigf', itime_in_file, sumarea, filter, & + 'fraction of veg cover, excluding snow-covered veg','-') + + ! leaf greenness + CALL write_history_variable_2d ( DEF_hist_vars%green, & + a_green, file_hist, 'f_green', itime_in_file, sumarea, filter, & + 'leaf greenness','-') + + ! leaf area index + CALL write_history_variable_2d ( DEF_hist_vars%lai, & + a_lai, file_hist, 'f_lai', itime_in_file, sumarea, filter, & + 'leaf area index','m2/m2') + + ! leaf area index + CALL write_history_variable_2d ( DEF_hist_vars%laisun, & + a_laisun, file_hist, 'f_laisun', itime_in_file, sumarea, filter, & + 'sunlit leaf area index','m2/m2') + + ! leaf area index + CALL write_history_variable_2d ( DEF_hist_vars%laisha, & + a_laisha, file_hist, 'f_laisha', itime_in_file, sumarea, filter, & + 'shaded leaf area index','m2/m2') + + ! stem area index + CALL write_history_variable_2d ( DEF_hist_vars%sai, & + a_sai, file_hist, 'f_sai', itime_in_file, sumarea, filter, & + 'stem area index','m2/m2') + + ! averaged albedo [visible, direct; direct, diffuse] + CALL write_history_variable_4d ( DEF_hist_vars%alb, & + a_alb, file_hist, 'f_alb', itime_in_file, & + 'band', 1, 2, 'rtyp', 1, 2, sumarea_dt, filter_dt, & + 'averaged albedo','-',nac_dt) + + ! averaged bulk surface emissivity + CALL write_history_variable_2d ( DEF_hist_vars%emis, & + a_emis, file_hist, 'f_emis', itime_in_file, sumarea, filter, & + 'averaged bulk surface emissivity','-') + + ! effective roughness [m] + CALL write_history_variable_2d ( DEF_hist_vars%z0m, & + a_z0m, file_hist, 'f_z0m', itime_in_file, sumarea, filter, & + 'effective roughness','m') + + ! radiative temperature of surface [K] + CALL write_history_variable_2d ( DEF_hist_vars%trad, & + a_trad, file_hist, 'f_trad', itime_in_file, sumarea, filter, & + 'radiative temperature of surface','kelvin') + + ! 2 m height air temperature [kelvin] + CALL write_history_variable_2d ( DEF_hist_vars%tref, & + a_tref, file_hist, 'f_tref', itime_in_file, sumarea, filter, & + '2 m height air temperature','kelvin') + +IF (DEF_Output_2mWMO) THEN + ! 2 m WMO air temperature [kelvin] + CALL write_history_variable_2d ( DEF_hist_vars%t2m_wmo, & + a_t2m_wmo, file_hist, 'f_t2m_wmo', itime_in_file, sumarea, filter, & + '2 m WMO air temperature','kelvin') +ENDIF + + ! 2 m height air specific humidity [kg/kg] + CALL write_history_variable_2d ( DEF_hist_vars%qref, & + a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, & + '2 m height air specific humidity','kg/kg') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype == 2 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (trim(file_hist) /= trim(file_last)) THEN + CALL hist_write_var_real8_2d (file_hist, 'area_wetland', ghist, -1, sumarea, & + compress = 1, longname = 'area of wetland', units = 'km2') + ENDIF + ENDIF + + ! wetland water storage [mm] + IF (DEF_USE_Dynamic_Wetland) THEN + IF (p_is_worker .and. (numpatch > 0)) THEN + vecacc = a_wdsrf + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & + vecacc, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, & + 'wetland water storage','mm') + ELSE + CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & + a_wetwat, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, & + 'wetland water storage','mm') + ENDIF + + ! instantaneous wetland water storage [mm] + IF (p_is_worker .and. (numpatch > 0)) THEN + vecacc = wetwat + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%wetwat_inst, & + vecacc, file_hist, 'f_wetwat_inst', itime_in_file, sumarea, filter, & + 'instantaneous wetland water storage','mm') + + IF (p_is_worker .and. (numpatch > 0)) THEN + vecacc = a_zwt + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%wetzwt, & + vecacc, file_hist, 'f_wetzwt', itime_in_file, sumarea, filter, & + 'the depth to water table in wetland','m') + + ! ------------------------------------------------------------------ + ! Mapping the urban variables at patch [numurban] to grid + ! ------------------------------------------------------------------ + +#ifdef URBAN_MODEL + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i = 1, numpatch + IF (patchtype(i) == 1) THEN + u = patch2urban(i) + + filter_urb(u) = .true. + + IF (DEF_forcing%has_missing_value) THEN + filter_urb(u) = filter_urb(u) .and. forcmask_pch(i) + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist_urb%get_sumarea (sumarea_urb, filter_urb) + ENDIF + + ! sensible heat from building roof [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_roof, & + a_senroof, file_hist, 'f_fsenroof', itime_in_file, sumarea_urb, filter_urb, & + 'sensible heat from urban roof [W/m2]','W/m2') + + ! sensible heat from building sunlit wall [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsun, & + a_senwsun, file_hist, 'f_fsenwsun', itime_in_file, sumarea_urb, filter_urb, & + 'sensible heat from urban sunlit wall [W/m2]','W/m2') + + ! sensible heat from building shaded wall [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsha, & + a_senwsha, file_hist, 'f_fsenwsha', itime_in_file, sumarea_urb, filter_urb, & + 'sensible heat from urban shaded wall [W/m2]','W/m2') + + ! sensible heat from impervious ground [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gimp, & + a_sengimp, file_hist, 'f_fsengimp', itime_in_file, sumarea_urb, filter_urb, & + 'sensible heat from urban impervious ground [W/m2]','W/m2') + + ! sensible heat from pervious ground [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gper, & + a_sengper, file_hist, 'f_fsengper', itime_in_file, sumarea_urb, filter_urb, & + 'sensible heat from urban pervious ground [W/m2]','W/m2') + + ! sensible heat from urban tree [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_urbl, & + a_senurbl, file_hist, 'f_fsenurbl', itime_in_file, sumarea_urb, filter_urb, & + 'sensible heat from urban tree [W/m2]','W/m2') + + ! latent heat flux from building roof [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_roof, & + a_lfevproof, file_hist, 'f_lfevproof', itime_in_file, sumarea_urb, filter_urb, & + 'latent heat from urban roof [W/m2]','W/m2') + + ! latent heat flux from impervious ground [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gimp, & + a_lfevpgimp, file_hist, 'f_lfevpgimp', itime_in_file, sumarea_urb, filter_urb, & + 'latent heat from urban impervious ground [W/m2]','W/m2') + + ! latent heat flux from pervious ground [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gper, & + a_lfevpgper, file_hist, 'f_lfevpgper', itime_in_file, sumarea_urb, filter_urb, & + 'latent heat from urban pervious ground [W/m2]','W/m2') + + ! latent heat flux from urban tree [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_urbl, & + a_lfevpurbl, file_hist, 'f_lfevpurbl', itime_in_file, sumarea_urb, filter_urb, & + 'latent heat from urban tree [W/m2]','W/m2') + + ! sensible flux from heat or cool AC [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fhac, & + a_fhac, file_hist, 'f_fhac', itime_in_file, sumarea_urb, filter_urb, & + 'sensible flux from heat or cool AC [W/m2]','W/m2') + + ! waste heat flux from heat or cool AC [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fwst, & + a_fwst, file_hist, 'f_fwst', itime_in_file, sumarea_urb, filter_urb, & + 'waste heat flux from heat or cool AC [W/m2]','W/m2') + + ! flux from inner and outer air exchange [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fach, & + a_fach, file_hist, 'f_fach', itime_in_file, sumarea_urb, filter_urb, & + 'flux from inner and outter air exchange [W/m2]','W/m2') + + ! flux from total heating/cooling [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%fhah, & + a_fhah, file_hist, 'f_fhah', itime_in_file, sumarea_urb, filter_urb, & + 'flux from heating/cooling [W/m2]','W/m2') + + ! flux from metabolism [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%meta, & + a_meta, file_hist, 'f_fmeta', itime_in_file, sumarea_urb, filter_urb, & + 'flux from human metabolism [W/m2]','W/m2') + + ! flux from vehicle [W/m2] + CALL write_history_variable_urb_2d ( DEF_hist_vars%vehc, & + a_vehc, file_hist, 'f_fvehc', itime_in_file, sumarea_urb, filter_urb, & + 'flux from traffic [W/m2]','W/m2') + + ! temperature of inner building [K] + CALL write_history_variable_urb_2d ( DEF_hist_vars%t_room, & + a_t_room, file_hist, 'f_t_room', itime_in_file, sumarea_urb, filter_urb, & + 'temperature of inner building [K]','kelvin') + + ! temperature of outer building [K] + CALL write_history_variable_urb_2d ( DEF_hist_vars%tafu, & + a_tafu, file_hist, 'f_tafu', itime_in_file, sumarea_urb, filter_urb, & + 'temperature of outer building [K]','kelvin') + + ! temperature of building roof [K] + CALL write_history_variable_urb_2d ( DEF_hist_vars%t_roof, & + a_troof, file_hist, 'f_t_roof', itime_in_file, sumarea_urb, filter_urb, & + 'temperature of urban roof [K]','kelvin') + + ! temperature of building wall [K] + CALL write_history_variable_urb_2d ( DEF_hist_vars%t_wall, & + a_twall, file_hist, 'f_t_wall', itime_in_file, sumarea_urb, filter_urb, & + 'temperature of urban wall [K]','kelvin') +#endif + + ! ------------------------------------------------------------------ + ! Mapping the fluxes and state variables at patch [numpatch] to grid + ! ------------------------------------------------------------------ + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + filter(:) = patchtype < 99 + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! 1: assimsun enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%assimsun, & + a_assimsun, file_hist, 'f_assimsun', itime_in_file, sumarea, filter, & + 'Photosynthetic assimilation rate of sunlit leaf for needleleaf evergreen temperate tree',& + 'mol m-2 s-1') + + ! 1: assimsha enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%assimsha, & + a_assimsha, file_hist, 'f_assimsha', itime_in_file, sumarea, filter, & + 'Photosynthetic assimilation rate of shaded leaf for needleleaf evergreen temperate tree',& + 'mol m-2 s-1') + + ! 1: etrsun enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%etrsun, & + a_etrsun, file_hist, 'f_etrsun', itime_in_file, sumarea, filter, & + 'Transpiration rate of sunlit leaf for needleleaf evergreen temperate tree','mm s-1') + + ! 1: etrsha enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%etrsha, & + a_etrsha, file_hist, 'f_etrsha', itime_in_file, sumarea, filter, & + 'Transpiration rate of shaded leaf for needleleaf evergreen temperate tree','mm s-1') + + ! rstfacsun + CALL write_history_variable_2d ( DEF_hist_vars%rstfacsun, & + a_rstfacsun, file_hist, 'f_rstfacsun', itime_in_file, sumarea, filter, & + 'Ecosystem level Water stress factor on sunlit canopy','unitless') + + ! rstfacsha + CALL write_history_variable_2d ( DEF_hist_vars%rstfacsha, & + a_rstfacsha, file_hist, 'f_rstfacsha', itime_in_file, sumarea, filter, & + 'Ecosystem level Water stress factor on shaded canopy','unitless') + + ! gssun + CALL write_history_variable_2d ( DEF_hist_vars%gssun, & + a_gssun, file_hist, 'f_gssun', itime_in_file, sumarea, filter, & + 'Ecosystem level canopy conductance on sunlit canopy','mol m-2 s-1') + + ! gssha + CALL write_history_variable_2d ( DEF_hist_vars%gssha, & + a_gssha, file_hist, 'f_gssha', itime_in_file, sumarea, filter, & + 'Ecosystem level canopy conductance on shaded canopy','mol m-2 s-1') + + ! soil resistance [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%rss, & + a_rss, file_hist, 'f_rss', itime_in_file, sumarea, filter, & + 'soil surface resistance','s/m') + +#ifdef BGC + ! leaf carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%leafc, & + a_leafc, file_hist, 'f_leafc', itime_in_file, sumarea, filter, & + 'leaf carbon display pool','gC/m2') + + ! leaf carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%leafc_storage, & + a_leafc_storage, file_hist, 'f_leafc_storage', itime_in_file, sumarea, filter, & + 'leaf carbon storage pool','gC/m2') + + ! leaf carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%leafc_xfer, & + a_leafc_xfer, file_hist, 'f_leafc_xfer', itime_in_file, sumarea, filter, & + 'leaf carbon transfer pool','gC/m2') + + ! fine root carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%frootc, & + a_frootc, file_hist, 'f_frootc', itime_in_file, sumarea, filter, & + 'fine root carbon display pool','gC/m2') + + ! fine root carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%frootc_storage, & + a_frootc_storage, file_hist, 'f_frootc_storage', itime_in_file, sumarea, filter, & + 'fine root carbon storage pool','gC/m2') + + ! fine root carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%frootc_xfer, & + a_frootc_xfer, file_hist, 'f_frootc_xfer', itime_in_file, sumarea, filter, & + 'fine root carbon transfer pool','gC/m2') + + ! live stem carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemc, & + a_livestemc, file_hist, 'f_livestemc', itime_in_file, sumarea, filter, & + 'live stem carbon display pool','gC/m2') + + ! live stem carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storage, & + a_livestemc_storage, file_hist, 'f_livestemc_storage', itime_in_file, sumarea, filter,& + 'live stem carbon storage pool','gC/m2') + + ! live stem carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xfer, & + a_livestemc_xfer, file_hist, 'f_livestemc_xfer', itime_in_file, sumarea, filter, & + 'live stem carbon transfer pool','gC/m2') + + ! dead stem carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc, & + a_deadstemc, file_hist, 'f_deadstemc', itime_in_file, sumarea, filter, & + 'dead stem carbon display pool','gC/m2') + + ! dead stem carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storage, & + a_deadstemc_storage, file_hist, 'f_deadstemc_storage', itime_in_file, sumarea, filter,& + 'dead stem carbon storage pool','gC/m2') + + ! dead stem carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xfer, & + a_deadstemc_xfer, file_hist, 'f_deadstemc_xfer', itime_in_file, sumarea, filter, & + 'dead stem carbon transfer pool','gC/m2') + + ! live coarse root carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc, & + a_livecrootc, file_hist, 'f_livecrootc', itime_in_file, sumarea, filter, & + 'live coarse root carbon display pool','gC/m2') + + ! live coarse root carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storage, & + a_livecrootc_storage, file_hist, 'f_livecrootc_storage', & + itime_in_file, sumarea, filter, & + 'live coarse root carbon storage pool','gC/m2') + + ! live coarse root carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xfer, & + a_livecrootc_xfer, file_hist, 'f_livecrootc_xfer', itime_in_file, sumarea, filter, & + 'live coarse root carbon transfer pool','gC/m2') + + ! dead coarse root carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc, & + a_deadcrootc, file_hist, 'f_deadcrootc', itime_in_file, sumarea, filter, & + 'dead coarse root carbon display pool','gC/m2') + + ! dead coarse root carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storage, & + a_deadcrootc_storage, file_hist, 'f_deadcrootc_storage', & + itime_in_file, sumarea, filter, & + 'dead coarse root carbon storage pool','gC/m2') + + ! dead coarse root carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xfer, & + a_deadcrootc_xfer, file_hist, 'f_deadcrootc_xfer', itime_in_file, sumarea, filter, & + 'dead coarse root carbon transfer pool','gC/m2') + +#ifdef CROP + ! grain carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%grainc, & + a_grainc, file_hist, 'f_grainc', itime_in_file, sumarea, filter, & + 'grain carbon display pool','gC/m2') + + ! grain carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%grainc_storage, & + a_grainc_storage, file_hist, 'f_grainc_storage', itime_in_file, sumarea, filter, & + 'grain carbon storage pool','gC/m2') + + ! grain carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%grainc_xfer, & + a_grainc_xfer, file_hist, 'f_grainc_xfer', itime_in_file, sumarea, filter, & + 'grain carbon transfer pool','gC/m2') +#endif + + ! leaf nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%leafn, & + a_leafn, file_hist, 'f_leafn', itime_in_file, sumarea, filter, & + 'leaf nitrogen display pool','gN/m2') + + ! leaf nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%leafn_storage, & + a_leafn_storage, file_hist, 'f_leafn_storage', itime_in_file, sumarea, filter, & + 'leaf nitrogen storage pool','gN/m2') + + ! leaf nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%leafn_xfer, & + a_leafn_xfer, file_hist, 'f_leafn_xfer', itime_in_file, sumarea, filter, & + 'leaf nitrogen transfer pool','gN/m2') + + ! fine root nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%frootn, & + a_frootn, file_hist, 'f_frootn', itime_in_file, sumarea, filter, & + 'fine root nitrogen display pool','gN/m2') + + ! fine root nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%frootn_storage, & + a_frootn_storage, file_hist, 'f_frootn_storage', itime_in_file, sumarea, filter, & + 'fine root nitrogen storage pool','gN/m2') + + ! fine root nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%frootn_xfer, & + a_frootn_xfer, file_hist, 'f_frootn_xfer', itime_in_file, sumarea, filter, & + 'fine root nitrogen transfer pool','gN/m2') + + ! live stem nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemn, & + a_livestemn, file_hist, 'f_livestemn', itime_in_file, sumarea, filter, & + 'live stem nitrogen display pool','gN/m2') + + ! live stem nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storage, & + a_livestemn_storage, file_hist, 'f_livestemn_storage', & + itime_in_file, sumarea, filter, & + 'live stem nitrogen storage pool','gN/m2') + + ! live stem nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xfer, & + a_livestemn_xfer, file_hist, 'f_livestemn_xfer', itime_in_file, sumarea, filter, & + 'live stem nitrogen transfer pool','gN/m2') + + ! dead stem nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn, & + a_deadstemn, file_hist, 'f_deadstemn', itime_in_file, sumarea, filter, & + 'dead stem nitrogen display pool','gN/m2') + + ! dead stem nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storage, & + a_deadstemn_storage, file_hist, 'f_deadstemn_storage', & + itime_in_file, sumarea, filter, & + 'dead stem nitrogen storage pool','gN/m2') + + ! dead stem nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xfer, & + a_deadstemn_xfer, file_hist, 'f_deadstemn_xfer', itime_in_file, sumarea, filter, & + 'dead stem nitrogen transfer pool','gN/m2') + + ! live coarse root nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn, & + a_livecrootn, file_hist, 'f_livecrootn', itime_in_file, sumarea, filter, & + 'live coarse root nitrogen display pool','gN/m2') + + ! live coarse root nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storage, & + a_livecrootn_storage, file_hist, 'f_livecrootn_storage', & + itime_in_file, sumarea, filter, & + 'live coarse root nitrogen storage pool','gN/m2') + + ! live coarse root nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xfer, & + a_livecrootn_xfer, file_hist, 'f_livecrootn_xfer', itime_in_file, sumarea, filter, & + 'live coarse root nitrogen transfer pool','gN/m2') + + ! dead coarse root nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn, & + a_deadcrootn, file_hist, 'f_deadcrootn', itime_in_file, sumarea, filter, & + 'dead coarse root nitrogen display pool','gN/m2') + + ! dead coarse root nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storage, & + a_deadcrootn_storage, file_hist, 'f_deadcrootn_storage', & + itime_in_file, sumarea, filter, & + 'dead coarse root nitrogen storage pool','gN/m2') + + ! dead coarse root nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xfer, & + a_deadcrootn_xfer, file_hist, 'f_deadcrootn_xfer', itime_in_file, sumarea, filter, & + 'dead coarse root nitrogen transfer pool','gN/m2') + +#ifdef CROP + ! grain nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%grainn, & + a_grainn, file_hist, 'f_grainn', itime_in_file, sumarea, filter, & + 'grain nitrogen display pool','gN/m2') + + ! grain nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%grainn_storage, & + a_grainn_storage, file_hist, 'f_grainn_storage', itime_in_file, sumarea, filter, & + 'grain nitrogen storage pool','gN/m2') + + ! grain nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%grainn_xfer, & + a_grainn_xfer, file_hist, 'f_grainn_xfer', itime_in_file, sumarea, filter, & + 'grain nitrogen transfer pool','gN/m2') +#endif + + ! retranslocation nitrogen pool + CALL write_history_variable_2d ( DEF_hist_vars%retrasn, & + a_retransn, file_hist, 'f_retrasn', itime_in_file, sumarea, filter, & + 'retranslocation nitrogen pool','gN/m2') + + ! gross primary productivity + CALL write_history_variable_2d ( DEF_hist_vars%gpp, & + a_gpp, file_hist, 'f_gpp', itime_in_file, sumarea, filter, & + 'gross primary productivity','gC/m2/s') + + ! gross primary productivity + CALL write_history_variable_2d ( DEF_hist_vars%downreg, & + a_downreg, file_hist, 'f_downreg', itime_in_file, sumarea, filter, & + 'gpp downregulation due to N limitation','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%fpg, & + a_fpg, file_hist, 'f_fpg', itime_in_file, sumarea, filter, & + 'fraction of gpp potential','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%fpi, & + a_fpi, file_hist, 'f_fpi', itime_in_file, sumarea, filter, & + 'fraction of immobalization','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%totvegc, & + a_totvegc, file_hist, 'f_totvegc', itime_in_file, sumarea, filter, & + 'total vegetation carbon','gC m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totlitc, & + a_totlitc, file_hist, 'f_totlitc', itime_in_file, sumarea, filter, & + 'total litter carbon','gC m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totsomc, & + a_totsomc, file_hist, 'f_totsomc', itime_in_file, sumarea, filter, & + 'total soil organic carbon','gC m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totcwdc, & + a_totcwdc, file_hist, 'f_totcwdc', itime_in_file, sumarea, filter, & + 'total coarse woody debris carbon','gC m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totcolc, & + a_totcolc, file_hist, 'f_totcolc', itime_in_file, sumarea, filter, & + 'total ecosystem carbon','gC m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totvegn, & + a_totvegn, file_hist, 'f_totvegn', itime_in_file, sumarea, filter, & + 'total vegetation nitrogen','gN m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totlitn, & + a_totlitn, file_hist, 'f_totlitn', itime_in_file, sumarea, filter, & + 'total litter nitrogen','gN m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totsomn, & + a_totsomn, file_hist, 'f_totsomn', itime_in_file, sumarea, filter, & + 'total soil organic nitrogen','gN m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totcwdn, & + a_totcwdn, file_hist, 'f_totcwdn', itime_in_file, sumarea, filter, & + 'total coarse woody debris nitrogen','gN m-2') + + CALL write_history_variable_2d ( DEF_hist_vars%totcoln, & + a_totcoln, file_hist, 'f_totcoln', itime_in_file, sumarea, filter, & + 'total ecosystem nitrogen','gN m-2') + + ! autotrophic respiration + CALL write_history_variable_2d ( DEF_hist_vars%ar , & + a_ar, file_hist, 'f_ar', itime_in_file, sumarea, filter, & + 'autotrophic respiration','gC/m2/s') + +! ! CWD production +! CALL write_history_variable_2d ( DEF_hist_vars%cwdprod , & +! a_cwdprod, file_hist, 'f_cwdprod', itime_in_file, sumarea, filter, & +! 'CWD production','gC/m2/s') +! +! ! CWD decomposition +! CALL write_history_variable_2d ( DEF_hist_vars%cwddecomp , & +! a_cwddecomp, file_hist, 'f_cwddecomp', itime_in_file, sumarea, filter, & +! 'CWD decomposition','gC/m2/s') + + ! heterotrophic respiration + CALL write_history_variable_2d ( DEF_hist_vars%hr , & + a_hr, file_hist, 'f_hr', itime_in_file, sumarea, filter, & + 'heterotrophic respiration','gC/m2/s') + +#ifdef CROP + ! crop phase + CALL write_history_variable_2d ( DEF_hist_vars%cphase, & + a_cphase, file_hist, 'f_cphase', itime_in_file, sumarea, filter, & + 'crop phase','unitless') + + ! heat unit index + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_hui (:) + ENDIF + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%hui, & + vecacc, file_hist, 'f_hui', itime_in_file, sumarea, filter, & + 'heat unit index','unitless') + + ! gdd needed to harvest + CALL write_history_variable_2d ( DEF_hist_vars%gddmaturity, & + a_gddmaturity, file_hist, 'f_gddmaturity', itime_in_file, sumarea, filter, & + 'gdd needed to harvest','ddays') + + ! gdd past planting date for crop + CALL write_history_variable_2d ( DEF_hist_vars%gddplant, & + a_gddplant, file_hist, 'f_gddplant', itime_in_file, sumarea, filter, & + 'gdd past planting date for crop','ddays') + + ! vernalization response + CALL write_history_variable_2d ( DEF_hist_vars%vf, & + a_vf, file_hist, 'f_vf', itime_in_file, sumarea, filter, & + 'vernalization response', 'unitless') + + ! 1-yr crop production carbon + CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c, & + a_cropprod1c, file_hist, 'f_cropprod1c', itime_in_file, sumarea, filter, & + '1-yr crop production carbon','gC/m2') + + ! loss rate of 1-yr crop production carbon + CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c_loss, & + a_cropprod1c_loss, file_hist, 'f_cropprod1c_loss', itime_in_file, sumarea, filter, & + 'loss rate of 1-yr crop production carbon','gC/m2/s') + + ! crop seed deficit + CALL write_history_variable_2d ( DEF_hist_vars%cropseedc_deficit, & + a_cropseedc_deficit, file_hist, 'f_cropseedc_deficit', & + itime_in_file, sumarea, filter, & + 'crop seed deficit','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + ! grain to crop production carbon + CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_cropprodc, & + vecacc, file_hist, 'f_grainc_to_cropprodc', itime_in_file, sumarea, filter, & + 'grain to crop production carbon','gC/m2/s') + + ! grain to crop seed carbon + CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_seed, & + a_grainc_to_seed, file_hist, 'f_grainc_to_seed', itime_in_file, sumarea, filter, & + 'grain to crop seed carbon','gC/m2/s') + ! grain to crop seed carbon + CALL write_history_variable_2d ( DEF_hist_vars%fert_to_sminn, & + a_fert_to_sminn, file_hist, 'f_fert_to_sminn', itime_in_file, sumarea, filter, & + 'fertilization','gN/m2/s') + + IF (DEF_USE_IRRIGATION) THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF((pftclass(patch_pft_s(i)).GE.npcropmin).and.(MOD(pftclass(patch_pft_s(i)),2).EQ.0))THEN + filter_irrig(i) = .true. + ELSE + filter_irrig(i) = .false. + ENDIF + ELSE + filter_irrig(i) = .false. + ENDIF + ENDDO + IF (DEF_forcing%has_missing_value) THEN + filter_irrig = filter_irrig .and. forcmask_pch + ENDIF + filter_irrig = filter_irrig .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea_irrig, filter_irrig) + ENDIF + + ! total irrigation amounts at growing season + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_sum_irrig (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig, & + vecacc, file_hist, 'f_sum_irrig', itime_in_file, sumarea_irrig, filter_irrig, & + 'total irrigation amounts at growing season','kg/m2') + + ! total irrigation amounts demand at growing season + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_sum_deficit_irrig (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%sum_deficit_irrig, & + vecacc, file_hist, 'f_sum_deficit_irrig', itime_in_file, sumarea_irrig, filter_irrig, & + 'total irrigation amounts demand at growing season','kg/m2') + + ! total irrigation times at growing season + CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, & + a_sum_irrig_count, file_hist, 'f_sum_irrig_count', itime_in_file, sumarea_irrig, filter_irrig, & + 'total irrigation times at growing season','-') + + ! irrigation waterstorage [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_waterstorage (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%waterstorage, & + vecacc, file_hist, 'f_waterstorage', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation waterstorage','kg/m2') + + ! irrigation demand for ground water [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_groundwater_demand (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%groundwater_demand, & + vecacc, file_hist, 'f_groundwater_demand', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation demand for ground water','kg/m2') + + ! irrigation supply from ground water [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_groundwater_supply (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%groundwater_supply, & + vecacc, file_hist, 'f_groundwater_supply', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation supply from ground water','kg/m2') + + ! irrigation demand for reservoir or river [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_reservoirriver_demand (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_demand, & + vecacc, file_hist, 'f_reservoirriver_demand', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation demand for reservoir or river','kg/m2') + + ! irrigation supply from reservoir or river [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_reservoirriver_supply (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & + vecacc, file_hist, 'f_reservoirriver_supply', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation supply from reservoir or river','kg/m2') + + ! irrigation supply from reservoir [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_reservoir_supply (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & + vecacc, file_hist, 'f_reservoir_supply', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation supply from reservoir','kg/m2') + + ! irrigation supply from river [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_river_supply (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & + vecacc, file_hist, 'f_river_supply', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation supply from river','kg/m2') + + ! irrigation supply from runoff [kg/m2] + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_runoff_supply (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & + vecacc, file_hist, 'f_runoff_supply', itime_in_file, sumarea_irrig, filter_irrig, & + 'irrigation supply from runoff','kg/m2') + ENDIF +#endif + + ! grain to crop seed carbon + CALL write_history_variable_2d ( DEF_hist_vars%ndep_to_sminn, & + a_ndep_to_sminn, file_hist, 'f_ndep_to_sminn', itime_in_file, sumarea, filter, & + 'nitrogen deposition','gN/m2/s') + + IF(DEF_USE_DiagMatrix)THEN + ! leaf carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%leafcCap, & + a_leafcCap, file_hist, 'f_leafcCap', itime_in_file, sumarea, filter, & + 'leaf carbon display pool Capacity','gC/m2') + + ! leaf carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%leafc_storageCap, & + a_leafc_storageCap, file_hist, 'f_leafc_storageCap', & + itime_in_file, sumarea, filter, & + 'leaf carbon storage pool capacity','gC/m2') + + ! leaf carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%leafc_xferCap, & + a_leafc_xferCap, file_hist, 'f_leafc_xferCap', itime_in_file, sumarea, filter, & + 'leaf carbon transfer pool capacity','gC/m2') + + ! fine root carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%frootcCap, & + a_frootcCap, file_hist, 'f_frootcCap', itime_in_file, sumarea, filter, & + 'fine root carbon display pool Capacity','gC/m2') + + ! fine root carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%frootc_storageCap, & + a_frootc_storageCap, file_hist, 'f_frootc_storageCap', & + itime_in_file, sumarea, filter, & + 'fine root carbon storage pool capacity','gC/m2') + + ! fine root carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%frootc_xferCap, & + a_frootc_xferCap, file_hist, 'f_frootc_xferCap', itime_in_file, sumarea, filter, & + 'fine root carbon transfer pool capacity','gC/m2') + + ! live stem carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemcCap, & + a_livestemcCap, file_hist, 'f_livestemcCap', itime_in_file, sumarea, filter, & + 'live stem carbon display pool Capacity','gC/m2') + + ! live stem carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storageCap, & + a_livestemc_storageCap, file_hist, 'f_livestemc_storageCap', & + itime_in_file, sumarea, filter, & + 'live stem carbon storage pool capacity','gC/m2') + + ! live stem carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xferCap, & + a_livestemc_xferCap, file_hist, 'f_livestemc_xferCap', & + itime_in_file, sumarea, filter, & + 'live stem carbon transfer pool capacity','gC/m2') + + ! dead stem carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemcCap, & + a_deadstemcCap, file_hist, 'f_deadstemcCap', itime_in_file, sumarea, filter, & + 'dead stem carbon display pool Capacity','gC/m2') + + ! dead stem carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storageCap, & + a_deadstemc_storageCap, file_hist, 'f_deadstemc_storageCap', & + itime_in_file, sumarea, filter, & + 'dead stem carbon storage pool capacity','gC/m2') + + ! dead stem carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xferCap, & + a_deadstemc_xferCap, file_hist, 'f_deadstemc_xferCap', & + itime_in_file, sumarea, filter, & + 'dead stem carbon transfer pool capacity','gC/m2') + + ! live coarse root carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootcCap, & + a_livecrootcCap, file_hist, 'f_livecrootcCap', itime_in_file, sumarea, filter, & + 'live coarse root carbon display pool Capacity','gC/m2') + + ! live coarse root carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storageCap, & + a_livecrootc_storageCap, file_hist, 'f_livecrootc_storageCap', & + itime_in_file, sumarea, filter, & + 'live coarse root carbon storage pool capacity','gC/m2') + + ! live coarse root carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xferCap, & + a_livecrootc_xferCap, file_hist, 'f_livecrootc_xferCap', & + itime_in_file, sumarea, filter, & + 'live coarse root carbon transfer pool capacity','gC/m2') + + ! dead coarse root carbon display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootcCap, & + a_deadcrootcCap, file_hist, 'f_deadcrootcCap', itime_in_file, sumarea, filter, & + 'dead coarse root carbon display pool Capacity','gC/m2') + + ! dead coarse root carbon storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storageCap, & + a_deadcrootc_storageCap, file_hist, 'f_deadcrootc_storageCap', & + itime_in_file, sumarea, filter, & + 'dead coarse root carbon storage pool capacity','gC/m2') + + ! dead coarse root carbon transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xferCap, & + a_deadcrootc_xferCap, file_hist, 'f_deadcrootc_xferCap', & + itime_in_file, sumarea, filter, & + 'dead coarse root carbon transfer pool capacity','gC/m2') + + ! leaf nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%leafnCap, & + a_leafnCap, file_hist, 'f_leafnCap', itime_in_file, sumarea, filter, & + 'leaf nitrogen display pool Capacity','gC/m2') + + ! leaf nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%leafn_storageCap, & + a_leafn_storageCap, file_hist, 'f_leafn_storageCap', & + itime_in_file, sumarea, filter, & + 'leaf nitrogen storage pool capacity','gC/m2') + + ! leaf nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%leafn_xferCap, & + a_leafn_xferCap, file_hist, 'f_leafn_xferCap', itime_in_file, sumarea, filter, & + 'leaf nitrogen transfer pool capacity','gC/m2') + + ! fine root nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%frootnCap, & + a_frootnCap, file_hist, 'f_frootnCap', itime_in_file, sumarea, filter, & + 'fine root nitrogen display pool Capacity','gC/m2') + + ! fine root nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%frootn_storageCap, & + a_frootn_storageCap, file_hist, 'f_frootn_storageCap', & + itime_in_file, sumarea, filter, & + 'fine root nitrogen storage pool capacity','gC/m2') + + ! fine root nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%frootn_xferCap, & + a_frootn_xferCap, file_hist, 'f_frootn_xferCap', itime_in_file, sumarea, filter, & + 'fine root nitrogen transfer pool capacity','gC/m2') + + ! live stem nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemnCap, & + a_livestemnCap, file_hist, 'f_livestemnCap', itime_in_file, sumarea, filter, & + 'live stem nitrogen display pool Capacity','gC/m2') + + ! live stem nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storageCap, & + a_livestemn_storageCap, file_hist, 'f_livestemn_storageCap', & + itime_in_file, sumarea, filter, & + 'live stem nitrogen storage pool capacity','gC/m2') + + ! live stem nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xferCap, & + a_livestemn_xferCap, file_hist, 'f_livestemn_xferCap', & + itime_in_file, sumarea, filter, & + 'live stem nitrogen transfer pool capacity','gC/m2') + + ! dead stem nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemnCap, & + a_deadstemnCap, file_hist, 'f_deadstemnCap', itime_in_file, sumarea, filter, & + 'dead stem nitrogen display pool Capacity','gC/m2') + + ! dead stem nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storageCap, & + a_deadstemn_storageCap, file_hist, 'f_deadstemn_storageCap', & + itime_in_file, sumarea, filter, & + 'dead stem nitrogen storage pool capacity','gC/m2') + + ! dead stem nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xferCap, & + a_deadstemn_xferCap, file_hist, 'f_deadstemn_xferCap', & + itime_in_file, sumarea, filter, & + 'dead stem nitrogen transfer pool capacity','gC/m2') + + ! live coarse root nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootnCap, & + a_livecrootnCap, file_hist, 'f_livecrootnCap', itime_in_file, sumarea, filter, & + 'live coarse root nitrogen display pool Capacity','gC/m2') + + ! live coarse root nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storageCap, & + a_livecrootn_storageCap, file_hist, 'f_livecrootn_storageCap', & + itime_in_file, sumarea, filter, & + 'live coarse root nitrogen storage pool capacity','gC/m2') + + ! live coarse root nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xferCap, & + a_livecrootn_xferCap, file_hist, 'f_livecrootn_xferCap', & + itime_in_file, sumarea, filter, & + 'live coarse root nitrogen transfer pool capacity','gC/m2') + + ! dead coarse root nitrogen display pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootnCap, & + a_deadcrootnCap, file_hist, 'f_deadcrootnCap', itime_in_file, sumarea, filter, & + 'dead coarse root nitrogen display pool Capacity','gC/m2') + + ! dead coarse root nitrogen storage pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storageCap, & + a_deadcrootn_storageCap, file_hist, 'f_deadcrootn_storageCap', & + itime_in_file, sumarea, filter, & + 'dead coarse root nitrogen storage pool capacity','gC/m2') + + ! dead coarse root nitrogen transfer pool + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xferCap, & + a_deadcrootn_xferCap, file_hist, 'f_deadcrootn_xferCap', & + itime_in_file, sumarea, filter, & + 'dead coarse root nitrogen transfer pool capacity','gC/m2') + + ENDIF + + IF(DEF_USE_OZONESTRESS)THEN + ! ozone concentration + CALL write_history_variable_2d ( DEF_hist_vars%xy_ozone, & + a_ozone, file_hist, 'f_xy_ozone', itime_in_file, sumarea, filter, & + 'Ozone concentration','mol/mol') + ENDIF + + ! litter 1 carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr1c_vr, & + a_litr1c_vr, file_hist, 'f_litr1c_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 1 carbon density in soil layers','gC/m3') + + ! litter 2 carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr2c_vr, & + a_litr2c_vr, file_hist, 'f_litr2c_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 2 carbon density in soil layers','gC/m3') + + ! litter 3 carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr3c_vr, & + a_litr3c_vr, file_hist, 'f_litr3c_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 3 carbon density in soil layers','gC/m3') + + ! soil 1 carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil1c_vr, & + a_soil1c_vr, file_hist, 'f_soil1c_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 1 carbon density in soil layers','gC/m3') + + ! soil 2 carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil2c_vr, & + a_soil2c_vr, file_hist, 'f_soil2c_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 2 carbon density in soil layers','gC/m3') + + ! soil 3 carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil3c_vr, & + a_soil3c_vr, file_hist, 'f_soil3c_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 3 carbon density in soil layers','gC/m3') + + ! coarse woody debris carbon density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%cwdc_vr, & + a_cwdc_vr, file_hist, 'f_cwdc_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'coarse woody debris carbon density in soil layers','gC/m3') + + ! litter 1 nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr1n_vr, & + a_litr1n_vr, file_hist, 'f_litr1n_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 1 nitrogen density in soil layers','gN/m3') + + ! litter 2 nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr2n_vr, & + a_litr2n_vr, file_hist, 'f_litr2n_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 2 nitrogen density in soil layers','gN/m3') + + ! litter 3 nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr3n_vr, & + a_litr3n_vr, file_hist, 'f_litr3n_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 3 nitrogen density in soil layers','gN/m3') + + ! soil 1 nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil1n_vr, & + a_soil1n_vr, file_hist, 'f_soil1n_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 1 nitrogen density in soil layers','gN/m3') + + ! soil 2 nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil2n_vr, & + a_soil2n_vr, file_hist, 'f_soil2n_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 2 nitrogen density in soil layers','gN/m3') + + ! soil 3 nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil3n_vr, & + a_soil3n_vr, file_hist, 'f_soil3n_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 3 nitrogen density in soil layers','gN/m3') + + ! coarse woody debris nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%cwdn_vr, & + a_cwdn_vr, file_hist, 'f_cwdn_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'coarse woody debris nitrogen density in soil layers','gN/m3') + + ! mineral nitrogen density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%sminn_vr, & + a_sminn_vr, file_hist, 'f_sminn_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'mineral nitrogen density in soil layers','gN/m3') + + ! total nitrogen percentage in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%totsoiln_vr, & + a_totsoiln_vr, file_hist, 'f_totsoiln_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,& + 'Total nitrogen in soil layers, percentage of total soil nitrogen in total soil mass','%') + + ! bulk density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%BD_all, & + a_BD_all, file_hist, 'f_BD_all', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'bulk density in soil layers','kg/m3') + + ! field capacity in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%wfc, & + a_wfc, file_hist, 'f_wfc', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'field capacity in soil layers','m3/m3') + + ! organic matter density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%OM_density, & + a_OM_density, file_hist, 'f_OM_density', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'organic matter density in soil layers','kg/m3') + + IF (DEF_USE_NITRIF) THEN + ! O2 soil Concentration for non-inundated area + CALL write_history_variable_3d ( DEF_hist_vars%CONC_O2_UNSAT, & + a_conc_o2_unsat, file_hist, 'f_CONC_O2_UNSAT', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'O2 soil Concentration for non-inundated area','mol/m3') + + ! O2 consumption from HR and AR for non-inundated area + CALL write_history_variable_3d ( DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT, & + a_o2_decomp_depth_unsat, file_hist, 'f_O2_DECOMP_DEPTH_UNSAT', & + itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'O2 consumption from HR and AR for non-inundated area','mol/m3/s') + ENDIF + + IF (DEF_USE_FIRE) THEN + CALL write_history_variable_2d ( DEF_hist_vars%abm, & + vecacc, file_hist, 'f_abm', itime_in_file, sumarea, filter, & + 'peak crop fire month','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%gdp, & + vecacc, file_hist, 'f_gdp', itime_in_file, sumarea, filter, & + 'gdp','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%peatf, & + vecacc, file_hist, 'f_peatf', itime_in_file, sumarea, filter, & + 'peatf','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%hdm, & + vecacc, file_hist, 'f_hdm', itime_in_file, sumarea, filter, & + 'hdm','unitless') + + CALL write_history_variable_2d ( DEF_hist_vars%lnfm, & + vecacc, file_hist, 'f_lnfm', itime_in_file, sumarea, filter, & + 'lnfm','unitless') + ENDIF + + IF(DEF_USE_DiagMatrix)THEN + ! litter 1 carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr1cCap_vr, & + a_litr1cCap_vr, file_hist, 'f_litr1cCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 1 carbon capacity density in soil layers','gC/m3') + + ! litter 2 carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr2cCap_vr, & + a_litr2cCap_vr, file_hist, 'f_litr2cCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 2 carbon capacity density in soil layers','gC/m3') + + ! litter 3 carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr3cCap_vr, & + a_litr3cCap_vr, file_hist, 'f_litr3cCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 3 carbon capacity density in soil layers','gC/m3') + + ! soil 1 carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil1cCap_vr, & + a_soil1cCap_vr, file_hist, 'f_soil1cCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 1 carbon capacity density in soil layers','gC/m3') + + ! soil 2 carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil2cCap_vr, & + a_soil2cCap_vr, file_hist, 'f_soil2cCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 2 carbon capacity density in soil layers','gC/m3') + + ! soil 3 carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil3cCap_vr, & + a_soil3cCap_vr, file_hist, 'f_soil3cCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 3 carbon capacity density in soil layers','gC/m3') + + ! coarse woody debris carbon capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%cwdcCap_vr, & + a_cwdcCap_vr, file_hist, 'f_cwdcCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'coarse woody debris carbon capacity density in soil layers','gC/m3') + + ! litter 1 nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr1nCap_vr, & + a_litr1nCap_vr, file_hist, 'f_litr1nCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 1 nitrogen capacity density in soil layers','gN/m3') + + ! litter 2 nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr2nCap_vr, & + a_litr2nCap_vr, file_hist, 'f_litr2nCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 2 nitrogen capacity density in soil layers','gN/m3') + + ! litter 3 nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%litr3nCap_vr, & + a_litr3nCap_vr, file_hist, 'f_litr3nCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'litter 3 nitrogen capacity density in soil layers','gN/m3') + + ! soil 1 nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil1nCap_vr, & + a_soil1nCap_vr, file_hist, 'f_soil1nCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 1 nitrogen capacity density in soil layers','gN/m3') + + ! soil 2 nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil2nCap_vr, & + a_soil2nCap_vr, file_hist, 'f_soil2nCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 2 nitrogen capacity density in soil layers','gN/m3') + + ! soil 3 nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%soil3nCap_vr, & + a_soil3nCap_vr, file_hist, 'f_soil3nCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,'soil 3 nitrogen capacity density in soil layers','gN/m3') + + ! coarse woody debris nitrogen capacity density in soil layers + CALL write_history_variable_3d ( DEF_hist_vars%cwdnCap_vr, & + a_cwdnCap_vr, file_hist, 'f_cwdnCap_vr', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter,& + 'coarse woody debris nitrogen capacity density in soil layers','gN/m3') + + ! Temperature environmental scalar + CALL write_history_variable_3d ( DEF_hist_vars%t_scalar, & + a_t_scalar, file_hist, 'f_t_scalar', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter, 'Temperature environmental scalar','unitless') + + ! Water environmental scalar + CALL write_history_variable_3d ( DEF_hist_vars%w_scalar, & + a_w_scalar, file_hist, 'f_w_scalar', itime_in_file, 'soil', 1, nl_soil, & + sumarea, filter, 'Water environmental scalar','unitless') + + ENDIF + + + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) .ne. 12 .and. patchtype(i) .eq. 0)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! 1: gpp enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%gpp_enftemp, & + a_gpp_enftemp, file_hist, 'f_gpp_enftemp', itime_in_file, sumarea, filter, & + 'gross primary productivity for needleleaf evergreen temperate tree','gC/m2/s') + + ! 1: leaf carbon display pool enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%leafc_enftemp, & + a_leafc_enftemp, file_hist, 'f_leafc_enftemp', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for needleleaf evergreen temperate tree','gC/m2') + + ! 1: leaf area index enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%lai_enftemp, & + a_lai_enftemp, file_hist, 'f_lai_enftemp', itime_in_file, sumarea, filter, & + 'leaf area index for needleleaf evergreen temperate tree','m2/m2') + + ! 1: npp enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%npp_enftemp, & + a_npp_enftemp, file_hist, 'f_npp_enftemp', itime_in_file, sumarea, filter, & + 'npp for needleleaf evergreen temperate tree','m2/m2') + + ! 1: npp to leafc enf temperate + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_enftemp, & + a_npptoleafc_enftemp, file_hist, 'f_npptoleafc_enftemp', itime_in_file, sumarea, filter, & + 'npp to leafc for needleleaf evergreen temperate tree','m2/m2') + + ! 2: gpp enf boreal + CALL write_history_variable_2d ( DEF_hist_vars%gpp_enfboreal, & + a_gpp_enfboreal, file_hist, 'f_gpp_enfboreal', itime_in_file, sumarea, filter, & + 'gross primary productivity for needleleaf evergreen boreal tree','gC/m2/s') + + ! 2: leaf carbon display pool enf boreal + CALL write_history_variable_2d ( DEF_hist_vars%leafc_enfboreal, & + a_leafc_enfboreal, file_hist, 'f_leafc_enfboreal', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for needleleaf evergreen boreal tree','gC/m2') + + ! 2: leaf area index enf boreal + CALL write_history_variable_2d ( DEF_hist_vars%lai_enfboreal, & + a_lai_enfboreal, file_hist, 'f_lai_enfboreal', itime_in_file, sumarea, filter, & + 'leaf area index for needleleaf evergreen boreal tree','m2/m2') + + ! 2: npp enf boreal + CALL write_history_variable_2d ( DEF_hist_vars%npp_enfboreal, & + a_npp_enfboreal, file_hist, 'f_npp_enfboreal', itime_in_file, sumarea, filter, & + 'npp for needleleaf evergreen boreal tree','m2/m2') + + ! 2: npp to leafc enf boreal + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_enfboreal, & + a_npptoleafc_enfboreal, file_hist, 'f_npptoleafc_enfboreal', itime_in_file, sumarea, filter, & + 'npp to leafc for needleleaf evergreen boreal tree','m2/m2') + + ! 3: gpp dnf boreal + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dnfboreal, & + a_gpp_dnfboreal, file_hist, 'f_gpp_dnfboreal', itime_in_file, sumarea, filter, & + 'gross primary productivity for needleleaf deciduous boreal tree','gC/m2/s') + + ! 3: leaf carbon display pool dnf boreal + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dnfboreal, & + a_leafc_dnfboreal, file_hist, 'f_leafc_dnfboreal', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for needleleaf deciduous boreal tree','gC/m2') + + ! 3: leaf area index dnf boreal + CALL write_history_variable_2d ( DEF_hist_vars%lai_dnfboreal, & + a_lai_dnfboreal, file_hist, 'f_lai_dnfboreal', itime_in_file, sumarea, filter, & + 'leaf area index for needleleaf deciduous boreal tree','m2/m2') + + ! 3: npp dnf boreal + CALL write_history_variable_2d ( DEF_hist_vars%npp_dnfboreal, & + a_npp_dnfboreal, file_hist, 'f_npp_dnfboreal', itime_in_file, sumarea, filter, & + 'npp for needleleaf deciduous boreal tree','m2/m2') + + ! 3: npp to leafc dnf boreal + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dnfboreal, & + a_npptoleafc_dnfboreal, file_hist, 'f_npptoleafc_dnfboreal', itime_in_file, sumarea, filter, & + 'npp to leafc for needleleaf deciduous boreal tree','m2/m2') + + ! 4: gpp ebf trop + CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftrop, & + a_gpp_ebftrop, file_hist, 'f_gpp_ebftrop', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf evergreen tropical tree','gC/m2/s') + + ! 4: leaf carbon display pool ebf trop + CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftrop, & + a_leafc_ebftrop, file_hist, 'f_leafc_ebftrop', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf evergreen tropical tree','gC/m2') + + ! 4: leaf area index ebf trop + CALL write_history_variable_2d ( DEF_hist_vars%lai_ebftrop, & + a_lai_ebftrop, file_hist, 'f_lai_ebftrop', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf evergreen tropical tree','m2/m2') + + ! 4: npp ebf trop + CALL write_history_variable_2d ( DEF_hist_vars%npp_ebftrop, & + a_npp_ebftrop, file_hist, 'f_npp_ebftrop', itime_in_file, sumarea, filter, & + 'npp for broadleaf evergreen tropical tree','m2/m2') + + ! 4: npp to leafc ebf trop + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebftrop, & + a_npptoleafc_ebftrop, file_hist, 'f_npptoleafc_ebftrop', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf evergreen tropical tree','m2/m2') + + ! 5: gpp ebf temp + CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftemp, & + a_gpp_ebftemp, file_hist, 'f_gpp_ebftemp', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf evergreen temperate tree','gC/m2/s') + + ! 5: leaf carbon display pool ebf temp + CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftemp, & + a_leafc_ebftemp, file_hist, 'f_leafc_ebftemp', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf evergreen temperate tree','gC/m2') + + ! 5: leaf area index ebf temp + CALL write_history_variable_2d ( DEF_hist_vars%lai_ebftemp, & + a_lai_ebftemp, file_hist, 'f_lai_ebftemp', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf evergreen temperate tree','m2/m2') + + ! 5: npp ebf temp + CALL write_history_variable_2d ( DEF_hist_vars%npp_ebftemp, & + a_npp_ebftemp, file_hist, 'f_npp_ebftemp', itime_in_file, sumarea, filter, & + 'npp for broadleaf evergreen temperate tree','m2/m2') + + ! 5: npp to leafc ebf temp + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebftemp, & + a_npptoleafc_ebftemp, file_hist, 'f_npptoleafc_ebftemp', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf evergreen temperate tree','m2/m2') + + ! 6: gpp dbf trop + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftrop, & + a_gpp_dbftrop, file_hist, 'f_gpp_dbftrop', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf deciduous tropical tree','gC/m2/s') + + ! 6: leaf carbon display pool dbf trop + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftrop, & + a_leafc_dbftrop, file_hist, 'f_leafc_dbftrop', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf deciduous tropical tree','gC/m2') + + ! 6: leaf area index dbf trop + CALL write_history_variable_2d ( DEF_hist_vars%lai_dbftrop, & + a_lai_dbftrop, file_hist, 'f_lai_dbftrop', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf evergreen temperate tree','m2/m2') + + ! 6: npp dbf trop + CALL write_history_variable_2d ( DEF_hist_vars%npp_dbftrop, & + a_npp_dbftrop, file_hist, 'f_npp_dbftrop', itime_in_file, sumarea, filter, & + 'npp for broadleaf evergreen temperate tree','m2/m2') + + ! 6: npp to leafc dbf trop + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbftrop, & + a_npptoleafc_dbftrop, file_hist, 'f_npptoleafc_dbftrop', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf evergreen temperate tree','m2/m2') + + ! 7: gpp dbf temp + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftemp, & + a_gpp_dbftemp, file_hist, 'f_gpp_dbftemp', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf deciduous temperate tree','gC/m2/s') + + ! 7: leaf carbon display pool dbf temp + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftemp, & + a_leafc_dbftemp, file_hist, 'f_leafc_dbftemp', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf deciduous temperate tree','gC/m2') + + ! 7: leaf area index dbf temp + CALL write_history_variable_2d ( DEF_hist_vars%lai_dbftemp, & + a_lai_dbftemp, file_hist, 'f_lai_dbftemp', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf decidous temperate tree','m2/m2') + + ! 7: npp dbf temp + CALL write_history_variable_2d ( DEF_hist_vars%npp_dbftemp, & + a_npp_dbftemp, file_hist, 'f_npp_dbftemp', itime_in_file, sumarea, filter, & + 'npp for broadleaf decidous temperate tree','m2/m2') + + ! 7: npp to leafc dbf temp + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbftemp, & + a_npptoleafc_dbftemp, file_hist, 'f_npptoleafc_dbftemp', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf decidous temperate tree','m2/m2') + + ! 8: gpp dbf boreal + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbfboreal, & + a_gpp_dbfboreal, file_hist, 'f_gpp_dbfboreal', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf deciduous boreal tree','gC/m2/s') + + ! 8: leaf carbon display pool dbf boreal + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbfboreal, & + a_leafc_dbfboreal, file_hist, 'f_leafc_dbfboreal', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf deciduous boreal tree','gC/m2') + + ! 8: leaf area index dbf boreal + CALL write_history_variable_2d ( DEF_hist_vars%lai_dbfboreal, & + a_lai_dbfboreal, file_hist, 'f_lai_dbfboreal', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf decidous boreal tree','m2/m2') + + ! 8: npp dbf boreal + CALL write_history_variable_2d ( DEF_hist_vars%npp_dbfboreal, & + a_npp_dbfboreal, file_hist, 'f_npp_dbfboreal', itime_in_file, sumarea, filter, & + 'npp for broadleaf decidous boreal tree','m2/m2') + + ! 8: npp to leafc dbf boreal + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbfboreal, & + a_npptoleafc_dbfboreal, file_hist, 'f_npptoleafc_dbfboreal', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf decidous boreal tree','m2/m2') + + ! 9: gpp ebs temp + CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebstemp, & + a_gpp_ebstemp, file_hist, 'f_gpp_ebstemp', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf evergreen temperate shrub','gC/m2/s') + + ! 9: leaf carbon display pool ebs temp + CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebstemp, & + a_leafc_ebstemp, file_hist, 'f_leafc_ebstemp', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf evergreen temperate shrub','gC/m2') + + ! 9: leaf area index ebs temp + CALL write_history_variable_2d ( DEF_hist_vars%lai_ebstemp, & + a_lai_ebstemp, file_hist, 'f_lai_ebstemp', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf evergreen temperate shrub','m2/m2') + + ! 9: npp ebs temp + CALL write_history_variable_2d ( DEF_hist_vars%npp_ebstemp, & + a_npp_ebstemp, file_hist, 'f_npp_ebstemp', itime_in_file, sumarea, filter, & + 'npp for broadleaf evergreen temperate shrub','m2/m2') + + ! 9: npp to leafc ebs temp + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebstemp, & + a_npptoleafc_ebstemp, file_hist, 'f_npptoleafc_ebstemp', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf evergreen temperate shrub','m2/m2') + + ! 10: gpp dbs temp + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbstemp, & + a_gpp_dbstemp, file_hist, 'f_gpp_dbstemp', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf deciduous temperate shrub','gC/m2/s') + + ! 10: leaf carbon display pool dbs temp + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbstemp, & + a_leafc_dbstemp, file_hist, 'f_leafc_dbstemp', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf deciduous temperate shrub','gC/m2') + + ! 10: leaf area index dbs temp + CALL write_history_variable_2d ( DEF_hist_vars%lai_dbstemp, & + a_lai_dbstemp, file_hist, 'f_lai_dbstemp', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf deciduous temperate shrub','m2/m2') + + ! 10: npp dbs temp + CALL write_history_variable_2d ( DEF_hist_vars%npp_dbstemp, & + a_npp_dbstemp, file_hist, 'f_npp_dbstemp', itime_in_file, sumarea, filter, & + 'npp for broadleaf deciduous temperate shrub','m2/m2') + + ! 10: npp to leafc dbs temp + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbstemp, & + a_npptoleafc_dbstemp, file_hist, 'f_npptoleafc_dbstemp', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf deciduous temperate shrub','m2/m2') + + ! 11: gpp dbs boreal + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbsboreal, & + a_gpp_dbsboreal, file_hist, 'f_gpp_dbsboreal', itime_in_file, sumarea, filter, & + 'gross primary productivity for broadleaf deciduous boreal shrub','gC/m2/s') + + ! 11: leaf carbon display pool dbs boreal + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbsboreal, & + a_leafc_dbsboreal, file_hist, 'f_leafc_dbsboreal', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for broadleaf deciduous boreal shrub','gC/m2') + + ! 11: leaf area index dbs boreal + CALL write_history_variable_2d ( DEF_hist_vars%lai_dbsboreal, & + a_lai_dbsboreal, file_hist, 'f_lai_dbsboreal', itime_in_file, sumarea, filter, & + 'leaf area index for broadleaf deciduous boreal shrub','m2/m2') + + ! 11: npp dbs boreal + CALL write_history_variable_2d ( DEF_hist_vars%npp_dbsboreal, & + a_npp_dbsboreal, file_hist, 'f_npp_dbsboreal', itime_in_file, sumarea, filter, & + 'npp for broadleaf deciduous boreal shrub','m2/m2') + + ! 11: npp to leafc dbs boreal + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbsboreal, & + a_npptoleafc_dbsboreal, file_hist, 'f_npptoleafc_dbsboreal', itime_in_file, sumarea, filter, & + 'npp to leafc for broadleaf deciduous boreal shrub','m2/m2') + + ! 12: gpp arctic c3 grass + CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3arcgrass, & + a_gpp_c3arcgrass, file_hist, 'f_gpp_c3arcgrass', itime_in_file, sumarea, filter, & + 'gross primary productivity for c3 arctic grass','gC/m2/s') + + ! 12: leaf carbon display pool c3 arctic grass + CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3arcgrass, & + a_leafc_c3arcgrass, file_hist, 'f_leafc_c3arcgrass', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for c3 arctic grass','gC/m2') + + ! 12: leaf area index c3 arctic grass + CALL write_history_variable_2d ( DEF_hist_vars%lai_c3arcgrass, & + a_lai_c3arcgrass, file_hist, 'f_lai_c3arcgrass', itime_in_file, sumarea, filter, & + 'leaf area index for c3 arctic grass','gC/m2') + + ! 12: npp c3 arctic grass + CALL write_history_variable_2d ( DEF_hist_vars%npp_c3arcgrass, & + a_npp_c3arcgrass, file_hist, 'f_npp_c3arcgrass', itime_in_file, sumarea, filter, & + 'npp for c3 arctic grass','gC/m2') + + ! 12: npp to leafc c3 arctic grass + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c3arcgrass, & + a_npptoleafc_c3arcgrass, file_hist, 'f_npptoleafc_c3arcgrass', itime_in_file, sumarea, filter, & + 'npp to leafc for c3 arctic grass','gC/m2') + + ! 13: gpp c3 grass + CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3grass, & + a_gpp_c3grass, file_hist, 'f_gpp_c3grass', itime_in_file, sumarea, filter, & + 'gross primary productivity for c3 grass','gC/m2/s') + + ! 13: leaf carbon display pool arctic c3 grass + CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, & + a_leafc_c3grass, file_hist, 'f_leafc_c3grass', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for c3 arctic grass','gC/m2') + + ! 13: leaf area index arctic c3 grass + CALL write_history_variable_2d ( DEF_hist_vars%lai_c3grass, & + a_lai_c3grass, file_hist, 'f_lai_c3grass', itime_in_file, sumarea, filter, & + 'leaf area index for c3 arctic grass','gC/m2') + + ! 13: npp arctic c3 grass + CALL write_history_variable_2d ( DEF_hist_vars%npp_c3grass, & + a_npp_c3grass, file_hist, 'f_npp_c3grass', itime_in_file, sumarea, filter, & + 'npp for c3 arctic grass','gC/m2') + + ! 13: npp to leafc arctic c3 grass + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c3grass, & + a_npptoleafc_c3grass, file_hist, 'f_npptoleafc_c3grass', itime_in_file, sumarea, filter, & + 'npp to leafc for c3 arctic grass','gC/m2') + + ! 14: gpp c4 grass + CALL write_history_variable_2d ( DEF_hist_vars%gpp_c4grass, & + a_gpp_c4grass, file_hist, 'f_gpp_c4grass', itime_in_file, sumarea, filter, & + 'gross primary productivity for c4 grass','gC/m2/s') + + ! 14: leaf carbon display pool arctic c4 grass + CALL write_history_variable_2d ( DEF_hist_vars%leafc_c4grass, & + a_leafc_c4grass, file_hist, 'f_leafc_c4grass', itime_in_file, sumarea, filter, & + 'leaf carbon display pool for c4 arctic grass','gC/m2') + + ! 14: leaf area index arctic c4 grass + CALL write_history_variable_2d ( DEF_hist_vars%lai_c4grass, & + a_lai_c4grass, file_hist, 'f_lai_c4grass', itime_in_file, sumarea, filter, & + 'leaf area index for c4 arctic grass','gC/m2') + + ! 14: npp arctic c4 grass + CALL write_history_variable_2d ( DEF_hist_vars%npp_c4grass, & + a_npp_c4grass, file_hist, 'f_npp_c4grass', itime_in_file, sumarea, filter, & + 'npp for c4 arctic grass','gC/m2') + + ! 14: npp to leafc arctic c4 grass + CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c4grass, & + a_npptoleafc_c4grass, file_hist, 'f_npptoleafc_c4grass', itime_in_file, sumarea, filter, & + 'npp to leafc for c4 arctic grass','gC/m2') + +#ifdef CROP +!***************************************** + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_manunitro (:) + ENDIF + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%manunitro, & + vecacc, file_hist, 'f_manunitro', itime_in_file, sumarea, filter, & + 'nitrogen in manure','gN/m2/yr') + + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_hui (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%huiswheat, & + vecacc, file_hist, 'f_huiswheat', itime_in_file, sumarea, filter, & + 'heat unit index (rainfed spring wheat)','unitless') + +!************************************************************ +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & +! .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdcorn, & +! a_pdcorn, file_hist, 'f_pdcorn', & +! itime_in_file, sumarea, filter, 'planting date of corn', 'day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdswheat, & +! a_pdswheat, file_hist, 'f_pdswheat', & +! itime_in_file, sumarea, filter,'planting date of spring wheat','day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdwwheat, & +! a_pdwwheat, file_hist, 'f_pdwwheat', & +! itime_in_file, sumarea, filter,'planting date of winter wheat','day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & +! .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdsoybean, & +! a_pdsoybean, file_hist, 'f_pdsoybean', & +! itime_in_file, sumarea, filter,'planting date of soybean','day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdcotton, & +! a_pdcotton, file_hist, 'f_pdcotton', & +! itime_in_file, sumarea, filter,'planting date of cotton','day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdrice1, & +! a_pdrice1, file_hist, 'f_pdrice1', & +! itime_in_file, sumarea, filter,'planting date of rice1','day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdrice2, & +! a_pdrice2, file_hist, 'f_pdrice2', & +! itime_in_file, sumarea, filter,'planting date of rice2','day') +! +! IF (p_is_worker) THEN +! IF (numpatch > 0) THEN +! DO i=1,numpatch +! IF(patchclass(i) == 12)THEN +! IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN +! filter(i) = .true. +! ELSE +! filter(i) = .false. +! ENDIF +! ELSE +! filter(i) = .false. +! ENDIF +! ENDDO +! ENDIF +! ENDIF +! +! IF (HistForm == 'Gridded') THEN +! CALL mp2g_hist%get_sumarea (sumarea, filter) +! ENDIF +! +! CALL write_history_variable_2d ( DEF_hist_vars%pdsugarcane, & +! a_pdsugarcane, file_hist, 'f_pdsugarcane', & +! itime_in_file, sumarea, filter,'planting date of sugarcane','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & + .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_corn, & + a_fertnitro_corn, file_hist, 'f_fertnitro_corn', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for corn','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_swheat, & + a_fertnitro_swheat, file_hist, 'f_fertnitro_swheat', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for spring wheat','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_wwheat, & + a_fertnitro_wwheat, file_hist, 'f_fertnitro_wwheat', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for winter wheat','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & + .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_soybean, & + a_fertnitro_soybean, file_hist, 'f_fertnitro_soybean', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for soybean','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_cotton, & + a_fertnitro_cotton, file_hist, 'f_fertnitro_cotton', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for cotton','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice1, & + a_fertnitro_rice1, file_hist, 'f_fertnitro_rice1', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for rice1','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice2, & + a_fertnitro_rice2, file_hist, 'f_fertnitro_rice2', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for rice2','gN/m2/yr') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_sugarcane, & + a_fertnitro_sugarcane, file_hist, 'f_fertnitro_sugarcane', & + itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr') + + IF(DEF_USE_IRRIGATION)THEN + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, & + a_irrig_method_corn, file_hist, 'f_irrig_method_corn', & + itime_in_file, sumarea, filter,'irrigation method for corn','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.19 .or. pftclass(patch_pft_s(i)).eq.20)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, & + a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', & + itime_in_file, sumarea, filter,'irrigation method for spring wheat','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.21 .or. pftclass(patch_pft_s(i)).eq.22)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, & + a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', & + itime_in_file, sumarea, filter,'irrigation method for winter wheat','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.23 .or. pftclass(patch_pft_s(i)).eq.24 & + .or. pftclass(patch_pft_s(i)).eq.77 .or. pftclass(patch_pft_s(i)).eq.78)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, & + a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', & + itime_in_file, sumarea, filter,'irrigation method for soybean','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.41 .or. pftclass(patch_pft_s(i)).eq.42)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, & + a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', & + itime_in_file, sumarea, filter,'irrigation method for cotton','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.61 .or. pftclass(patch_pft_s(i)).eq.62)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, & + a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', & + itime_in_file, sumarea, filter,'irrigation method for rice1','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.61 .or. pftclass(patch_pft_s(i)).eq.62)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, & + a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', & + itime_in_file, sumarea, filter,'irrigation method for rice2','-') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)).eq.67 .or. pftclass(patch_pft_s(i)).eq.68)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, & + a_irrig_method_sugarcane, file_hist, 'f_irrig_method_sugarcane', & + itime_in_file, sumarea, filter,'irrigation method for sugarcane','-') + + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed temperate corn + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, & + vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed temperate corn)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 18)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated temperate corn + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, & + vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated temperate corn)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed spring wheat + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, & + vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed spring wheat)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 20)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated spring wheat + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, & + vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated spring wheat)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed winter wheat + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, & + vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed winter wheat)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 22)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated winter wheat + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, & + vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated winter wheat)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed temperate soybean + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, & + vecacc, file_hist, 'f_plantdate_rainfed_temp_soybean', & + itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed temperate soybean)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 24)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated temperate soybean + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, & + vecacc, file_hist, 'f_plantdate_irrigated_temp_soybean', & + itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated temperate soybean)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed cotton + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, & + vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed cotton)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 42)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated cotton + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, & + vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated cotton)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed rice + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, & + vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed rice)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 62)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated rice + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, & + vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated rice)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed sugarcane + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, & + vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed sugarcane)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 68)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated sugarcane + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, & + vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated sugarcane)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 75)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed trop corn + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, & + vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed trop corn)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 76)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated trop corn + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, & + vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated trop corn)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 77)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of rainfed trop soybean + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, & + vecacc, file_hist, 'f_plantdate_rainfed_trop_soybean', & + itime_in_file, sumarea, filter, & + 'Crop planting date (rainfed trop soybean)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 78)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of irrigated trop soybean + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, & + vecacc, file_hist, 'f_plantdate_irrigated_trop_soybean', & + itime_in_file, sumarea, filter, & + 'Crop planting date (irrigated trop soybean)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 15)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! planting date of unmanaged crop production + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_plantdate (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, & + vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, & + 'Crop planting date (unmanaged crop production)','day') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 17)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to corn production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_corn, & + vecacc, file_hist, 'f_cropprodc_rainfed_temp_corn', itime_in_file, sumarea, filter, & + 'Crop production (rainfed temperate corn)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 18)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to corn production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_corn, & + vecacc, file_hist, 'f_cropprodc_irrigated_temp_corn', itime_in_file, sumarea, filter, & + 'Crop production (irrigated temperate corn)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 19)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to spring wheat production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_spwheat, & + vecacc, file_hist, 'f_cropprodc_rainfed_spwheat', itime_in_file, sumarea, filter, & + 'Crop production (rainfed spring wheat)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 20)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to spring wheat production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_spwheat, & + vecacc, file_hist, 'f_cropprodc_irrigated_spwheat', itime_in_file, sumarea, filter, & + 'Crop production (irrigated spring wheat)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 21)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to winter wheat production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_wtwheat, & + vecacc, file_hist, 'f_cropprodc_rainfed_wtwheat', itime_in_file, sumarea, filter, & + 'Crop production (rainfed winter wheat)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 22)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to winter wheat production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_wtwheat, & + vecacc, file_hist, 'f_cropprodc_irrigated_wtwheat', itime_in_file, sumarea, filter, & + 'Crop production (irrigated winter wheat)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 23)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to soybean production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_soybean, & + vecacc, file_hist, 'f_cropprodc_rainfed_temp_soybean', & + itime_in_file, sumarea, filter, & + 'Crop production (rainfed temperate soybean)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 24)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to soybean production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_soybean, & + vecacc, file_hist, 'f_cropprodc_irrigated_temp_soybean', & + itime_in_file, sumarea, filter, & + 'Crop production (irrigated temperate soybean)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 41)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to cotton production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_cotton, & + vecacc, file_hist, 'f_cropprodc_rainfed_cotton', itime_in_file, sumarea, filter, & + 'Crop production (rainfed cotton)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 42)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to cotton production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_cotton, & + vecacc, file_hist, 'f_cropprodc_irrigated_cotton', itime_in_file, sumarea, filter, & + 'Crop production (irrigated cotton)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 61)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to rice production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_rice, & + vecacc, file_hist, 'f_cropprodc_rainfed_rice', itime_in_file, sumarea, filter, & + 'Crop production (rainfed rice)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 62)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to rice production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_rice, & + vecacc, file_hist, 'f_cropprodc_irrigated_rice', itime_in_file, sumarea, filter, & + 'Crop production (irrigated rice)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 67)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to sugarcane production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_sugarcane, & + vecacc, file_hist, 'f_cropprodc_rainfed_sugarcane', itime_in_file, sumarea, filter, & + 'Crop production (rainfed sugarcane)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 68)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to sugarcane production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_sugarcane, & + vecacc, file_hist, 'f_cropprodc_irrigated_sugarcane', itime_in_file, sumarea, filter, & + 'Crop production (irrigated sugarcane)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 75)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to sugarcane production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_corn, & + vecacc, file_hist, 'f_cropprodc_rainfed_trop_corn', itime_in_file, sumarea, filter, & + 'Crop production (rainfed_trop_corn)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 76)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to sugarcane production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_corn, & + vecacc, file_hist, 'f_cropprodc_irrigated_trop_corn', itime_in_file, sumarea, filter, & + 'Crop production (irrigated_trop_corn)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 77)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to sugarcane production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_soybean, & + vecacc, file_hist, 'f_cropprodc_rainfed_trop_soybean', & + itime_in_file, sumarea, filter, & + 'Crop production (rainfed trop soybean)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 78)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to sugarcane production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_soybean, & + vecacc, file_hist, 'f_cropprodc_irrigated_trop_soybean', & + itime_in_file, sumarea, filter, & + 'Crop production (irrigated trop soybean)','gC/m2/s') + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO i=1,numpatch + IF(patchclass(i) == 12)THEN + IF(pftclass(patch_pft_s(i)) .eq. 15)THEN + filter(i) = .true. + ELSE + filter(i) = .false. + ENDIF + ELSE + filter(i) = .false. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! grain to unmanaged crop production carbon + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vecacc (:) = a_grainc_to_cropprodc (:) + ENDIF + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_unmanagedcrop, & + vecacc, file_hist, 'f_cropprodc_unmanagedcrop', itime_in_file, sumarea, filter, & + 'Crop production (unmanaged crop production)','gC/m2/s') +#endif +#endif + ! -------------------------------------------------------------------- + ! Temperature and water (excluding land water bodies and ocean patches) + ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; + ! land water bodies => 4; ocean => 99] + ! -------------------------------------------------------------------- + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype <= 3 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! soil temperature [K] + CALL write_history_variable_3d ( DEF_hist_vars%t_soisno, & + a_t_soisno, file_hist, 'f_t_soisno', & + itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & + sumarea, filter, 'soil temperature','K') + + ! liquid water in soil layers [kg/m2] + CALL write_history_variable_3d ( DEF_hist_vars%wliq_soisno, & + a_wliq_soisno, file_hist, 'f_wliq_soisno', & + itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & + sumarea, filter,'liquid water in soil layers','kg/m2') + + ! ice lens in soil layers [kg/m2] + CALL write_history_variable_3d ( DEF_hist_vars%wice_soisno, & + a_wice_soisno, file_hist, 'f_wice_soisno', & + itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & + sumarea, filter, 'ice lens in soil layers', 'kg/m2') + + +#ifdef DataAssimilation + IF (p_is_worker) THEN + allocate (a_wliq_h2osoi_5cm (numpatch )); a_wliq_h2osoi_5cm = spval + allocate (a_t_soisno_5cm (numpatch )); a_t_soisno_5cm = spval + + allocate (a_wliq_soisno_ens_mean(maxsnl+1:nl_soil,numpatch)); a_wliq_soisno_ens_mean = spval + allocate (a_wliq_soisno_5cm_ens (DEF_DA_ENS_NUM,numpatch )); a_wliq_soisno_5cm_ens = spval + allocate (a_wliq_h2osoi_5cm_a (numpatch )); a_wliq_h2osoi_5cm_a = spval + + allocate (a_t_soisno_ens_mean (maxsnl+1:nl_soil,numpatch)); a_t_soisno_ens_mean = spval + allocate (a_t_soisno_5cm_ens (DEF_DA_ENS_NUM,numpatch )); a_t_soisno_5cm_ens = spval + allocate (a_t_soisno_5cm_a (numpatch )); a_t_soisno_5cm_a = spval + + allocate (a_t_brt_smap_a (2,numpatch )); a_t_brt_smap_a = spval + allocate (a_t_brt_fy3d_a (2,numpatch )); a_t_brt_fy3d_a = spval + + allocate (a_wliq_soisno_5cm_ens_std(numpatch )); a_wliq_soisno_5cm_ens_std = spval + allocate (a_t_soisno_5cm_ens_std (numpatch )); a_t_soisno_5cm_ens_std = spval + allocate (a_t_brt_smap_ens_std (2,numpatch )); a_t_brt_smap_ens_std = spval + allocate (a_t_brt_fy3d_ens_std (2,numpatch )); a_t_brt_fy3d_ens_std = spval + END IF + + IF (p_is_worker) THEN +!############################################################################# +! States before DA +!############################################################################# + ! calculate surface liquid soil moisture (0-5cm) before DA + a_wliq_h2osoi_5cm = (a_wliq_soisno(1,:) + a_wliq_soisno(2,:) + & + a_wliq_soisno(3, :)*(0.05 - 0.0451)/(0.0906 - 0.0451))/(0.05*denh2o) + + ! calculate surface liquid soil moisture (0-5cm) before DA + a_t_soisno_5cm = (a_t_soisno(1,:)*0.0175 + a_t_soisno(2,:)*(0.0451 - 0.0175))/(0.0451) + +!############################################################################# +! States after DA +!############################################################################# + ! calculate surface liquid soil moisture (0-5cm) after DA + a_wliq_soisno_ens_mean = sum(a_wliq_soisno_ens, dim=2) / DEF_DA_ENS_NUM + a_wliq_soisno_5cm_ens = (a_wliq_soisno_ens(1,:,:) + a_wliq_soisno_ens(2,:,:) + & + a_wliq_soisno_ens(3,:,:)*(0.05-0.0451)/(0.0906-0.0451))/(0.05*denh2o) + a_wliq_h2osoi_5cm_a = (a_wliq_soisno_ens_mean(1,:) + a_wliq_soisno_ens_mean(2,:) + & + a_wliq_soisno_ens_mean(3,:)*(0.05 - 0.0451)/(0.0906 - 0.0451))/(0.05*denh2o) + + ! calculate surface soil temperature (0-5cm) before DA & after DA + a_t_soisno_ens_mean = sum(a_t_soisno_ens, dim=2) / DEF_DA_ENS_NUM + a_t_soisno_5cm_ens = (a_t_soisno_ens(1,:,:)*0.0175 + a_t_soisno_ens(2,:,:)*(0.0451 - 0.0175))/(0.0451) + a_t_soisno_5cm_a = (a_t_soisno_ens_mean(1,:)*0.0175 + a_t_soisno_ens_mean(2,:)*(0.0451 - 0.0175))/(0.0451) + +!############################################################################# +! brightness temperature after DA +!############################################################################# + a_t_brt_smap_a = sum(a_t_brt_smap_ens, dim=2) / DEF_DA_ENS_NUM + a_t_brt_fy3d_a = sum(a_t_brt_fy3d_ens, dim=2) / DEF_DA_ENS_NUM + +!############################################################################# +! Standard deviation of states and brightness temperature +!############################################################################# + ! calculate standard deviation of surface soil moisture, temperature and brightness temperature + DO np = 1, numpatch + a_wliq_soisno_5cm_ens_std(np) = & + sqrt(sum((a_wliq_soisno_5cm_ens(:,np)-a_wliq_h2osoi_5cm_a(np))**2)/real(DEF_DA_ENS_NUM-1)) + a_t_soisno_5cm_ens_std(np) = & + sqrt(sum((a_t_soisno_5cm_ens(:,np)-a_t_soisno_5cm_a(np))**2)/real(DEF_DA_ENS_NUM-1)) + IF (DEF_DA_SM_SMAP) THEN + IF (patchtype(np) >= 3) cycle + a_t_brt_smap_ens_std(1,np) = & + sqrt(sum((a_t_brt_smap_ens(1,:,np)-a_t_brt_smap_a(1,np))**2)/real(DEF_DA_ENS_NUM-1)) + a_t_brt_smap_ens_std(2,np) = & + sqrt(sum((a_t_brt_smap_ens(2,:,np)-a_t_brt_smap_a(2,np))**2)/real(DEF_DA_ENS_NUM-1)) + ENDIF + IF (DEF_DA_SM_FY) THEN + IF (patchtype(np) >= 3) cycle + a_t_brt_fy3d_ens_std(1,np) = & + sqrt(sum((a_t_brt_fy3d_ens(1,:,np)-a_t_brt_fy3d_a(1,np))**2)/real(DEF_DA_ENS_NUM-1)) + a_t_brt_fy3d_ens_std(2,np) = & + sqrt(sum((a_t_brt_fy3d_ens(2,:,np)-a_t_brt_fy3d_a(2,np))**2)/real(DEF_DA_ENS_NUM-1)) + ENDIF + ENDDO + ENDIF + + ! surface soil moisture (0-5cm) before and after DA + CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_h2osoi_5cm, & + a_wliq_h2osoi_5cm, file_hist, 'f_wliq_h2osoi_5cm', itime_in_file, & + sumarea, filter, 'Volumetric liquid water content in 0-5cm', 'm3/m3') + CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_h2osoi_5cm_a, & + a_wliq_h2osoi_5cm_a, file_hist, 'f_wliq_h2osoi_5cm_a', itime_in_file, & + sumarea, filter, 'Analysis volumetric liquid water content in 0-5cm', 'm3/m3') + + ! surface soil temperature (0-5cm) before and after DA + CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm, & + a_t_soisno_5cm, file_hist, 'f_t_soisno_5cm', itime_in_file, & + sumarea, filter, 'Soil temperature in 0-5cm', 'K') + CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm_a, & + a_t_soisno_5cm_a, file_hist, 'f_t_soisno_5cm_a', itime_in_file, & + sumarea, filter, 'Analysis soil temperature in 0-5cm', 'K') + + ! ensemble soil moisture & temperature in soil layers [kg/m2] + IF (DEF_DA_ENS_NUM > 1) THEN + CALL write_history_variable_4d(DEF_hist_vars%DA_wliq_soisno_ens, & + a_wliq_soisno_ens, file_hist, 'f_wliq_soisno_ens', itime_in_file, 'soilsnow', maxsnl + 1, nl_soil - maxsnl, & + 'ens', 1, DEF_DA_ENS_NUM, sumarea, filter, 'ensemble liquid water in soil layers', 'kg/m2') + CALL write_history_variable_4d(DEF_hist_vars%DA_t_soisno_ens, & + a_t_soisno_ens, file_hist, 'f_t_soisno_ens', itime_in_file, 'soilsnow', maxsnl + 1, nl_soil - maxsnl, & + 'ens', 1, DEF_DA_ENS_NUM, sumarea, filter, 'ensemble soil temperature', 'K') + ENDIF + + ! standard deviation of ensemble surface soil moisture and temperature (0-5cm) + CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_soisno_5cm_ens_std, & + a_wliq_soisno_5cm_ens_std, file_hist, 'f_wliq_soisno_ens_5cm_ens_std', itime_in_file, & + sumarea, filter, 'Standard deviation of ensemble volumetric liquid water content in 0-5cm', 'm3/m3') + CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm_ens_std, & + a_t_soisno_5cm_ens_std, file_hist, 'f_t_soisno_ens_5cm_ens_std', itime_in_file, & + sumarea, filter, 'Standard deviation of ensemble soil temperature in 0-5cm', 'K') + + ! -------------------------------------------------------------------- + ! brightness temperature (excluding land ice, land water bodies and ocean patches) + ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; + ! land water bodies => 4; ocean => 99] + ! -------------------------------------------------------------------- + + IF (HistForm == 'Gridded') THEN + IF (p_is_io) THEN + CALL allocate_block_data(ghist, sumarea) + END IF + END IF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype <= 2 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + END IF + + filter = filter .and. patchmask + END IF + END IF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea(sumarea, filter) + END IF + + ! brightness temperature for SMAP and FY satellites + IF (DEF_DA_SM_SMAP) THEN + CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap, & + a_t_brt_smap, file_hist, 'f_t_brt_smap', itime_in_file, 'band', 1, 2, sumarea, filter, & + 'H- & V- polarized brightness temperature for SMAP satellite (L-band, 1.4GHz)', 'K') + CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap_a, & + a_t_brt_smap_a, file_hist, 'f_t_brt_smap_a', itime_in_file, 'band', 1, 2, sumarea, filter, & + 'Analysis H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K') + IF (DEF_DA_ENS_NUM > 1) THEN + CALL write_history_variable_4d(DEF_hist_vars%DA_t_brt_smap_ens, & + a_t_brt_smap_ens, file_hist, 'f_t_brt_smap_ens', itime_in_file, 'band', 1, 2, 'ens', 1, DEF_DA_ENS_NUM, & + sumarea, filter, 'ensemble H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K') + END IF + CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap_ens_std, & + a_t_brt_smap_ens_std, file_hist, 'f_t_brt_smap_ens_std', itime_in_file, 'band', 1, 2, & + sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K') + ENDIF + + IF (DEF_DA_SM_FY) THEN + CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d, & + a_t_brt_fy3d, file_hist, 'f_t_brt_fy3d', itime_in_file, 'band', 1, 2, sumarea, filter, & + 'H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') + CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d_a, & + a_t_brt_fy3d_a, file_hist, 'f_t_brt_fy3d_a', itime_in_file, 'band', 1, 2, sumarea, filter, & + 'Analysis H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') + IF (DEF_DA_ENS_NUM > 1) THEN + CALL write_history_variable_4d(DEF_hist_vars%DA_t_brt_fy3d_ens, & + a_t_brt_fy3d_ens, file_hist, 'f_t_brt_fy3d_ens', itime_in_file, 'band', 1, 2, 'ens', 1, DEF_DA_ENS_NUM, & + sumarea, filter, 'ensemble H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') + END IF + CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d_ens_std, & + a_t_brt_fy3d_ens_std, file_hist, 'f_t_brt_fy3d_ens_std', itime_in_file, 'band', 1, 2, & + sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') + ENDIF + + IF (p_is_worker) THEN + deallocate (a_wliq_h2osoi_5cm) + deallocate (a_t_soisno_5cm) + deallocate (a_wliq_soisno_ens_mean) + deallocate (a_wliq_soisno_5cm_ens) + deallocate (a_wliq_h2osoi_5cm_a) + deallocate (a_t_soisno_ens_mean) + deallocate (a_t_soisno_5cm_ens) + deallocate (a_t_soisno_5cm_a) + deallocate (a_t_brt_smap_a) + deallocate (a_t_brt_fy3d_a) + deallocate (a_wliq_soisno_5cm_ens_std) + deallocate (a_t_soisno_5cm_ens_std) + deallocate (a_t_brt_smap_ens_std) + deallocate (a_t_brt_fy3d_ens_std) + END IF + +#endif + + ! -------------------------------------------------------------------- + ! additional diagnostic variables for output (vegetated land only <=2) + ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; + ! land water bodies => 4; ocean => 99] + ! -------------------------------------------------------------------- + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype <= 2 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! volumetric soil water in layers [m3/m3] + CALL write_history_variable_3d ( DEF_hist_vars%h2osoi, & + a_h2osoi, file_hist, 'f_h2osoi', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & + 'volumetric water in soil layers','m3/m3') + + IF (DEF_USE_VariablySaturatedFlow) THEN + ! water flux between water layers [mm h2o/s] + CALL write_history_variable_3d ( DEF_hist_vars%qlayer, & + a_qlayer, file_hist, 'f_qlayer', itime_in_file, 'soilinterface', 0, nl_soil+1, & + sumarea, filter, 'water flux between soil layers','mm/s') + ENDIF + + ! fraction of root water uptake from each soil layer, all layers add to 1, + ! when PHS is not defined water exchange between soil layers and root. + ! Positive: soil->root [mm h2o/s], when PHS is defined + CALL write_history_variable_3d ( DEF_hist_vars%rootr, & + a_rootr, file_hist, 'f_rootr', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & + 'root water uptake', 'mm h2o/s') + + IF (DEF_USE_PLANTHYDRAULICS) THEN + ! vegetation water potential [mm] + CALL write_history_variable_3d ( DEF_hist_vars%vegwp, & + a_vegwp, file_hist, 'f_vegwp', & + itime_in_file, 'vegnodes', 1, nvegwcs, sumarea, filter, & + 'vegetation water potential', 'mm') + ENDIF + + ! water table depth [m] + CALL write_history_variable_2d ( DEF_hist_vars%zwt, & + a_zwt, file_hist, 'f_zwt', itime_in_file, sumarea, filter, & + 'the depth to water table','m') + + ! -------------------------------------------------------------------- + ! depth of surface water (including land ice and ocean patches) + ! -------------------------------------------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = (patchtype <= 4) + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! water storage in aquifer [mm] + CALL write_history_variable_2d ( DEF_hist_vars%wa, & + a_wa, file_hist, 'f_wa', itime_in_file, sumarea, filter, & + 'water storage in aquifer','mm') + + ! instantaneous water storage in aquifer [mm] + IF (p_is_worker) THEN + vecacc = wa + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%wa_inst, & + vecacc, file_hist, 'f_wa_inst', itime_in_file, sumarea, filter, & + 'instantaneous water storage in aquifer','mm') + + ! depth of surface water [mm] + CALL write_history_variable_2d ( DEF_hist_vars%wdsrf, & + a_wdsrf, file_hist, 'f_wdsrf', itime_in_file, sumarea, filter, & + 'depth of surface water','mm') + + ! instantaneous depth of surface water [mm] + IF (p_is_worker) THEN + vecacc = wdsrf + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + CALL write_history_variable_2d ( DEF_hist_vars%wdsrf_inst, & + vecacc, file_hist, 'f_wdsrf_inst', itime_in_file, sumarea, filter, & + 'instantaneous depth of surface water','mm') + + ! ----------------------------------------------- + ! Land water bodies' ice fraction and temperature + ! ----------------------------------------------- + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + filter(:) = patchtype == 4 + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (trim(file_hist) /= trim(file_last)) THEN + CALL hist_write_var_real8_2d (file_hist, 'area_lake', ghist, -1, sumarea, & + compress = 1, longname = 'area of lake', units = 'km2') + ENDIF + ENDIF + + ! lake layer depth [m] + CALL write_history_variable_3d ( DEF_hist_vars%dz_lake .and. DEF_USE_Dynamic_Lake, & + a_dz_lake, file_hist, 'f_dz_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, & + 'lake layer thickness','m') + + ! lake temperature [K] + CALL write_history_variable_3d ( DEF_hist_vars%t_lake, & + a_t_lake, file_hist, 'f_t_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, & + 'lake temperature','K') + + ! lake ice fraction cover [0-1] + CALL write_history_variable_3d ( DEF_hist_vars%lake_icefrac, & + a_lake_icefrac, file_hist, 'f_lake_icefrac', itime_in_file, 'lake', 1, nl_lake, & + sumarea, filter, 'lake ice fraction cover','0-1') + + ! lake water deficit due to evaporation [mm/s] + IF (.not. DEF_USE_Dynamic_Lake) THEN + CALL write_history_variable_2d ( DEF_hist_vars%lake_deficit, & + a_lake_deficit, file_hist, 'f_lake_deficit', itime_in_file, sumarea, filter, & + 'lake water deficit due to evaporation','mm/s') + ENDIF + +#ifdef EXTERNAL_LAKE + CALL LakeVarsSaveHist (nl_lake, file_hist, HistForm, itime_in_file, sumarea, filter) +#endif + + ! -------------------------------- + ! Retrieve through averaged fluxes + ! -------------------------------- + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + filter(:) = patchtype < 99 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + + filter = filter .and. patchmask + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! u* in similarity theory [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%ustar, & + a_ustar, file_hist, 'f_ustar', itime_in_file, sumarea, filter, & + 'u* in similarity theory based on patch','m/s') + + ! u* in similarity theory [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%ustar2, & + a_ustar2, file_hist, 'f_ustar2', itime_in_file, sumarea, filter, & + 'u* in similarity theory based on grid','m/s') + + ! t* in similarity theory [K] + CALL write_history_variable_2d ( DEF_hist_vars%tstar, & + a_tstar, file_hist, 'f_tstar', itime_in_file, sumarea, filter, & + 't* in similarity theory','K') + + ! q* in similarity theory [kg/kg] + CALL write_history_variable_2d ( DEF_hist_vars%qstar, & + a_qstar, file_hist, 'f_qstar', itime_in_file, sumarea, filter, & + 'q* in similarity theory', 'kg/kg') + + ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL write_history_variable_2d ( DEF_hist_vars%zol, & + a_zol, file_hist, 'f_zol', itime_in_file, sumarea, filter, & + 'dimensionless height (z/L) used in Monin-Obukhov theory','-') + + ! bulk Richardson number in surface layer + CALL write_history_variable_2d ( DEF_hist_vars%rib, & + a_rib, file_hist, 'f_rib', itime_in_file, sumarea, filter, & + 'bulk Richardson number in surface layer','-') + + ! integral of profile FUNCTION for momentum + CALL write_history_variable_2d ( DEF_hist_vars%fm, & + a_fm, file_hist, 'f_fm', itime_in_file, sumarea, filter, & + 'integral of profile FUNCTION for momentum','-') + + ! integral of profile FUNCTION for heat + CALL write_history_variable_2d ( DEF_hist_vars%fh, & + a_fh, file_hist, 'f_fh', itime_in_file, sumarea, filter, & + 'integral of profile FUNCTION for heat','-') + + ! integral of profile FUNCTION for moisture + CALL write_history_variable_2d ( DEF_hist_vars%fq, & + a_fq, file_hist, 'f_fq', itime_in_file, sumarea, filter, & + 'integral of profile FUNCTION for moisture','-') + + ! 10m u-velocity [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%us10m, & + a_us10m, file_hist, 'f_us10m', itime_in_file, sumarea, filter, & + '10m u-velocity','m/s') + + ! 10m v-velocity [m/s] + CALL write_history_variable_2d ( DEF_hist_vars%vs10m, & + a_vs10m, file_hist, 'f_vs10m', itime_in_file, sumarea, filter, & + '10m v-velocity','m/s') + + ! integral of profile FUNCTION for momentum at 10m [-] + CALL write_history_variable_2d ( DEF_hist_vars%fm10m, & + a_fm10m, file_hist, 'f_fm10m', itime_in_file, sumarea, filter, & + 'integral of profile FUNCTION for momentum at 10m','-') + + ! total reflected solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%sr, & + a_sr, file_hist, 'f_sr', itime_in_file, sumarea, filter, & + 'reflected solar radiation at surface [W/m2]','W/m2') + + ! incident direct beam vis solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solvd, & + a_solvd, file_hist, 'f_solvd', itime_in_file, sumarea, filter, & + 'incident direct beam vis solar radiation (W/m2)','W/m2') + + ! incident diffuse beam vis solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solvi, & + a_solvi, file_hist, 'f_solvi', itime_in_file, sumarea, filter, & + 'incident diffuse beam vis solar radiation (W/m2)','W/m2') + + ! incident direct beam nir solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solnd, & + a_solnd, file_hist, 'f_solnd', itime_in_file, sumarea, filter, & + 'incident direct beam nir solar radiation (W/m2)','W/m2') + + ! incident diffuse beam nir solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solni, & + a_solni, file_hist, 'f_solni', itime_in_file, sumarea, filter, & + 'incident diffuse beam nir solar radiation (W/m2)','W/m2') + + ! reflected direct beam vis solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srvd, & + a_srvd, file_hist, 'f_srvd', itime_in_file, sumarea, filter, & + 'reflected direct beam vis solar radiation (W/m2)','W/m2') + + ! reflected diffuse beam vis solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srvi, & + a_srvi, file_hist, 'f_srvi', itime_in_file, sumarea, filter, & + 'reflected diffuse beam vis solar radiation (W/m2)','W/m2') + + ! reflected direct beam nir solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srnd, & + a_srnd, file_hist, 'f_srnd', itime_in_file, sumarea, filter, & + 'reflected direct beam nir solar radiation (W/m2)','W/m2') + + ! reflected diffuse beam nir solar radiation (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srni, & + a_srni, file_hist, 'f_srni', itime_in_file, sumarea, filter, & + 'reflected diffuse beam nir solar radiation (W/m2)','W/m2') + + ! local noon fluxes + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + filter(:) = nac_ln > 0 + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask_pch + ENDIF + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + ! incident direct beam vis solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solvdln, & + a_solvdln, file_hist, 'f_solvdln', itime_in_file, sumarea, filter, & + 'incident direct beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! incident diffuse beam vis solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solviln, & + a_solviln, file_hist, 'f_solviln', itime_in_file, sumarea, filter, & + 'incident diffuse beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! incident direct beam nir solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solndln, & + a_solndln, file_hist, 'f_solndln', itime_in_file, sumarea, filter, & + 'incident direct beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! incident diffuse beam nir solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%solniln, & + a_solniln, file_hist, 'f_solniln', itime_in_file, sumarea, filter, & + 'incident diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! reflected direct beam vis solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srvdln, & + a_srvdln, file_hist, 'f_srvdln', itime_in_file, sumarea, filter, & + 'reflected direct beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! reflected diffuse beam vis solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srviln, & + a_srviln, file_hist, 'f_srviln', itime_in_file, sumarea, filter, & + 'reflected diffuse beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! reflected direct beam nir solar radiation at local noon (W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srndln, & + a_srndln, file_hist, 'f_srndln', itime_in_file, sumarea, filter, & + 'reflected direct beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) + + ! reflected diffuse beam nir solar radiation at local noon(W/m2) + CALL write_history_variable_2d ( DEF_hist_vars%srniln, & + a_srniln, file_hist, 'f_srniln', itime_in_file, sumarea, filter, & + 'reflected diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) + + + IF ((p_is_worker) .and. (numpatch > 0)) THEN + filter = (patchtype == 0) .and. patchmask + IF (DEF_forcing%has_missing_value) filter = filter .and. forcmask_pch + ENDIF + IF (HistForm == 'Gridded') THEN + CALL mp2g_hist%get_sumarea (sumarea, filter) + ENDIF + + CALL write_history_variable_3d ( DEF_hist_vars%sensors, & + a_sensors, file_hist, 'f_sensors', itime_in_file, 'sensor', 1, nsensor, & + sumarea, filter, 'variable sensors','user defined') + +#if (defined CaMa_Flood) +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + CALL hist_out_cama (file_hist_cama, itime_in_file_cama) + ENDIF +#endif + +#ifdef CatchLateralFlow + CALL hist_basin_out (file_hist, idate) +#endif + +#ifdef GridRiverLakeFlow + CALL hist_grid_riverlake_out (file_hist, HistForm, idate, & + itime_in_file, trim(file_hist)/=trim(file_last)) + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (nac_one (numpatch)) + nac_one = 1. + ENDIF + ENDIF + + IF (HistForm == 'Gridded') THEN + IF (p_is_io) CALL allocate_block_data (ghist, sumarea_one) + IF (p_is_io) CALL flush_block_data (sumarea_one, 1.) + ENDIF + + CALL write_history_variable_2d ( DEF_hist_vars%riv_height, a_wdsrf_ucat_pch, & + file_hist, 'f_wdpth_ucat_regrid', itime_in_file, sumarea_ucat, filter_ucat, & + 'regridded deepest water depth in river and flood plain', 'm', nac_one) + + CALL write_history_variable_2d ( DEF_hist_vars%riv_veloct, a_veloc_riv_pch, & + file_hist, 'f_veloc_riv_regrid', itime_in_file, sumarea_ucat, filter_ucat, & + 'regridded water velocity in river', 'm/s', nac_one) + + CALL write_history_variable_2d ( DEF_hist_vars%discharge, a_discharge_pch, & + file_hist, 'f_discharge', itime_in_file, sumarea_one, filter_ucat, & + 'regridded discharge in river and flood plain', 'm^3/s', & + nac_one, input_mode = 'total') + + CALL write_history_variable_2d ( DEF_hist_vars%discharge, a_dis_rmth_pch, & + file_hist, 'f_discharge_rivermouth_regrid', itime_in_file, sumarea_one, & + filter_ucat, 'regridded river mouth discharge into ocean', 'm^3/s', & + nac_one, input_mode = 'total') + + CALL write_history_variable_2d ( DEF_hist_vars%floodfrc, a_floodfrc_pch, & + file_hist, 'f_floodfrc', itime_in_file, sumarea_inpm, filter_inpm, & + 'flooded area fraction', '100%', nac_one) + + IF (trim(HistForm) == 'Gridded') THEN + CALL write_history_variable_2d ( DEF_hist_vars%floodarea, a_floodfrc_pch, & + file_hist, 'f_floodarea', itime_in_file, sumarea_one, filter_inpm, & + 'flooded area', 'km^2', nac_one) + ENDIF + + IF (allocated(nac_one )) deallocate (nac_one ) +#endif + + IF (allocated(filter )) deallocate (filter ) + IF (allocated(filter_dt )) deallocate (filter_dt ) +#ifdef URBAN_MODEL + IF (allocated(filter_urb)) deallocate (filter_urb) +#endif + + CALL FLUSH_acc_fluxes () + +#ifdef SinglePoint + IF (USE_SITE_HistWriteBack .and. memory_to_disk) THEN + itime_mem = 0 + ENDIF +#endif + + file_last = file_hist + + ENDIF + + END SUBROUTINE hist_out + + + SUBROUTINE write_history_variable_2d ( is_hist, & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & + longname, units, acc_num, input_mode) + + USE MOD_Vars_1DAccFluxes, only: nac + + IMPLICIT NONE + + logical, intent(in) :: is_hist + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + real(r8), intent(in), optional :: acc_num(:) + + character(len=*), intent(in), optional :: input_mode + + IF (.not. is_hist) RETURN + +#ifndef SinglePoint + IF ( .not. present(acc_num) ) THEN + IF (p_is_worker) & + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + ELSE + IF (p_is_worker) & + WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num + ENDIF +#else + IF ( .not. present(acc_num) ) THEN + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + ELSE + WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num + ENDIF +#endif + + select CASE (HistForm) + CASE ('Gridded') + IF (present(input_mode)) THEN + CALL flux_map_and_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units, input_mode) + ELSE + CALL flux_map_and_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) + ENDIF +#if (defined UNSTRUCTURED || defined CATCHMENT) + CASE ('Vector') + IF (present(input_mode)) THEN + CALL aggregate_to_vector_and_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, filter, longname, units, input_mode) + ELSE + CALL aggregate_to_vector_and_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, filter, longname, units) + ENDIF +#endif +#ifdef SinglePoint + CASE ('Single') + CALL single_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, longname, units) +#endif + END select + + END SUBROUTINE write_history_variable_2d + + +#ifdef URBAN_MODEL + SUBROUTINE write_history_variable_urb_2d ( is_hist, & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & + longname, units) + + IMPLICIT NONE + + logical, intent(in) :: is_hist + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + + IF (.not. is_hist) RETURN + + select CASE (HistForm) + CASE ('Gridded') + CALL flux_map_and_write_urb_2d ( & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) +#if (defined UNSTRUCTURED || defined CATCHMENT) + CASE ('Vector') + !TODO: currently, it is not applicable to urban variables + CALL aggregate_to_vector_and_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, filter, longname, units) +#endif +#ifdef SinglePoint + CASE ('Single') + CALL single_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, longname, units) +#endif + END select + + END SUBROUTINE write_history_variable_urb_2d +#endif + + + SUBROUTINE write_history_variable_3d ( is_hist, & + acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & + sumarea, filter, longname, units) + + IMPLICIT NONE + + logical, intent(in) :: is_hist + + real(r8), intent(inout) :: acc_vec(:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name + integer, intent(in) :: lb1, ndim1 + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in) :: longname + character (len=*), intent(in) :: units + + ! Local variables + integer :: iblkme, xblk, yblk, xloc, yloc, i1 + integer :: compress + + IF (.not. is_hist) RETURN + + select CASE (HistForm) + CASE ('Gridded') + CALL flux_map_and_write_3d ( & + acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & + sumarea, filter, longname, units) +#if (defined UNSTRUCTURED || defined CATCHMENT) + CASE ('Vector') + CALL aggregate_to_vector_and_write_3d ( & + acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & + filter, longname, units) +#endif +#ifdef SinglePoint + CASE ('Single') + CALL single_write_3d (acc_vec, file_hist, varname, itime_in_file, & + dim1name, ndim1, longname, units) +#endif + END select + + END SUBROUTINE write_history_variable_3d + + + SUBROUTINE write_history_variable_4d ( is_hist, & + acc_vec, file_hist, varname, itime_in_file, & + dim1name, lb1, ndim1, dim2name, lb2, ndim2, & + sumarea, filter, longname, units, acc_num) + + IMPLICIT NONE + + logical, intent(in) :: is_hist + + real(r8), intent(inout) :: acc_vec(:,:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name, dim2name + integer, intent(in) :: lb1, ndim1, lb2, ndim2 + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in) :: longname + character (len=*), intent(in) :: units + real(r8), intent(in), optional:: acc_num(:) + + ! Local variables + integer :: i1, i2 + + IF (.not. is_hist) RETURN + +#ifndef SinglePoint + IF ( .not. present(acc_num) ) THEN + IF (p_is_worker) & + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + ELSE + IF (p_is_worker) THEN + DO i1 = lbound(acc_vec,1), ubound(acc_vec,1) + DO i2 = lbound(acc_vec,2), ubound(acc_vec,2) + WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) & + acc_vec(i1,i2,:) = acc_vec(i1,i2,:) / acc_num + ENDDO + ENDDO + ENDIF + ENDIF +#else + IF ( .not. present(acc_num) ) THEN + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + ELSE + DO i1 = lbound(acc_vec,1), ubound(acc_vec,1) + DO i2 = lbound(acc_vec,2), ubound(acc_vec,2) + WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) & + acc_vec(i1,i2,:) = acc_vec(i1,i2,:) / acc_num + ENDDO + ENDDO + ENDIF +#endif + + select CASE (HistForm) + CASE ('Gridded') + CALL flux_map_and_write_4d ( & + acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & + dim2name, lb2, ndim2, sumarea, filter, longname, units) +#if (defined UNSTRUCTURED || defined CATCHMENT) + CASE ('Vector') + CALL aggregate_to_vector_and_write_4d ( & + acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & + dim2name, lb2, ndim2, filter, longname, units) +#endif +#ifdef SinglePoint + CASE ('Single') + CALL single_write_4d (acc_vec, file_hist, varname, itime_in_file, & + dim1name, ndim1, dim2name, ndim2, longname, units) +#endif + END select + + END SUBROUTINE write_history_variable_4d + + + SUBROUTINE hist_write_time (filename, filelast, dataname, time, itime) + + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: filelast + character (len=*), intent(in) :: dataname + integer, intent(in) :: time(3) + integer, intent(out) :: itime + + select CASE (HistForm) + CASE ('Gridded') + CALL hist_gridded_write_time (filename, filelast, dataname, time, itime) +#if (defined UNSTRUCTURED || defined CATCHMENT) + CASE ('Vector') + CALL hist_vector_write_time (filename, filelast, dataname, time, itime) +#endif +#ifdef SinglePoint + CASE ('Single') + CALL hist_single_write_time (filename, filelast, dataname, time, itime) +#endif + END select + + END SUBROUTINE hist_write_time + +END MODULE MOD_Hist diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 new file mode 100644 index 0000000000..8b3083c58b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 @@ -0,0 +1,1074 @@ +#include + +MODULE MOD_HistGridded + +!---------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Write out gridded model results to history files. +! +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +! +! !REVISIONS: +! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version +! +! TODO...(need complement) +!---------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_SPMD_Task +#ifdef USEMPI + USE MOD_HistWriteBack +#endif + + type(grid_type), target :: ghist + type(spatial_mapping_type) :: mp2g_hist + type(spatial_mapping_type) :: mp2g_hist_urb + + type(block_data_real8_2d) :: landfraction + + type(grid_concat_type) :: hist_concat + + integer :: hist_data_id + +!-------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE hist_gridded_init (dir_hist, lulcc_call) + + USE MOD_SPMD_Task + USE MOD_Vars_Global + USE MOD_Block + USE MOD_LandPatch +#ifdef URBAN_MODEL + USE MOD_LandUrban +#endif + USE MOD_Vars_1DAccFluxes + USE MOD_Forcing, only: gforc +#ifdef SinglePoint + USE MOD_SingleSrfData +#endif + USE MOD_Utils + IMPLICIT NONE + + character(len=*) , intent(in) :: dir_hist + logical, optional, intent(in) :: lulcc_call + + ! Local Variables + type(block_data_real8_2d) :: gridarea + integer :: iblkme, xblk, yblk, xloc, yloc, xglb, yglb + + IF (DEF_hist_grid_as_forcing) THEN + CALL ghist%define_by_copy (gforc) + ELSE + CALL ghist%define_by_res (DEF_hist_lon_res, DEF_hist_lat_res) + ENDIF + + IF (present(lulcc_call)) CALL mp2g_hist%forc_free_mem + CALL mp2g_hist%build_arealweighted (ghist, landpatch) + +#ifdef URBAN_MODEL + IF (present(lulcc_call)) CALL mp2g_hist_urb%forc_free_mem + CALL mp2g_hist_urb%build_arealweighted (ghist, landurban) +#endif + + IF (p_is_io) THEN + CALL allocate_block_data (ghist, landfraction) + CALL allocate_block_data (ghist, gridarea) + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) + xglb = ghist%xdsp(xblk) + xloc + yglb = ghist%ydsp(yblk) + yloc + gridarea%blk(xblk,yblk)%val(xloc,yloc) = areaquad ( & + ghist%lat_s(yglb), ghist%lat_n(yglb), ghist%lon_w(xglb), ghist%lon_e(xglb)) + ENDDO + ENDDO + ENDDO + ENDIF + + CALL mp2g_hist%get_sumarea (landfraction) + CALL block_data_division (landfraction, gridarea) + + CALL hist_concat%set (ghist) +#ifdef SinglePoint + hist_concat%ginfo%lat_c(:) = SITE_lat_location + hist_concat%ginfo%lon_c(:) = SITE_lon_location +#endif + + IF (trim(DEF_HIST_mode) == 'one') THEN + hist_data_id = 10001 + ENDIF + + END SUBROUTINE hist_gridded_init + + + SUBROUTINE flux_map_and_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & + longname, units, input_mode) + + USE MOD_Block + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character(len=*), intent(in), optional :: input_mode + + ! Local variables + type(block_data_real8_2d) :: flux_xy_2d + integer :: iblkme, xblk, yblk, xloc, yloc + integer :: compress + + IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) + + IF (present(input_mode)) THEN + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter, input_mode = input_mode) + ELSE + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) + ENDIF + + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) + + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN + IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN + flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & + = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & + / sumarea%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + ELSE + flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval + ENDIF + + ENDDO + ENDDO + + ENDDO + ENDIF + + compress = DEF_HIST_CompressLevel + CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, & + flux_xy_2d, compress, longname, units) + + END SUBROUTINE flux_map_and_write_2d + + + SUBROUTINE flux_map_and_write_urb_2d ( & + acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & + longname, units) + + USE MOD_Block + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + + ! Local variables + type(block_data_real8_2d) :: flux_xy_2d + integer :: iblkme, xblk, yblk, xloc, yloc + integer :: compress + + IF (p_is_worker) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) + + CALL mp2g_hist_urb%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) + + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) + + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN + IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN + flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & + = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & + / sumarea%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + ELSE + flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval + ENDIF + + ENDDO + ENDDO + + ENDDO + ENDIF + + compress = DEF_HIST_CompressLevel + CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & + compress, longname, units) + + END SUBROUTINE flux_map_and_write_urb_2d + + + SUBROUTINE flux_map_and_write_3d ( & + acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, sumarea, filter, & + longname, units) + + USE MOD_Block + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name + integer, intent(in) :: lb1, ndim1 + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in) :: longname + character (len=*), intent(in) :: units + + ! Local variables + type(block_data_real8_3d) :: flux_xy_3d + integer :: iblkme, xblk, yblk, xloc, yloc, i1 + integer :: compress + + IF (p_is_worker) THEN + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + ENDIF + IF (p_is_io) THEN + CALL allocate_block_data (ghist, flux_xy_3d, ndim1, lb1) + ENDIF + + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_3d, spv = spval, msk = filter) + + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) + + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN + DO i1 = flux_xy_3d%lb1, flux_xy_3d%ub1 + IF (flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) /= spval) THEN + flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) & + = flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) & + / sumarea%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + ENDDO + ELSE + flux_xy_3d%blk(xblk,yblk)%val(:,xloc,yloc) = spval + ENDIF + + ENDDO + ENDDO + + ENDDO + ENDIF + + compress = DEF_HIST_CompressLevel + CALL hist_write_var_real8_3d (file_hist, varname, dim1name, ghist, & + itime_in_file, flux_xy_3d, compress, longname, units) + + END SUBROUTINE flux_map_and_write_3d + + + SUBROUTINE flux_map_and_write_4d ( & + acc_vec, file_hist, varname, itime_in_file, & + dim1name, lb1, ndim1, dim2name, lb2, ndim2, & + sumarea, filter, longname, units) + + USE MOD_Block + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:,:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name, dim2name + integer, intent(in) :: lb1, ndim1, lb2, ndim2 + + type(block_data_real8_2d), intent(in) :: sumarea + logical, intent(in) :: filter(:) + character (len=*), intent(in) :: longname + character (len=*), intent(in) :: units + + ! Local variables + type(block_data_real8_4d) :: flux_xy_4d + integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2 + integer :: compress + + IF (p_is_io) THEN + CALL allocate_block_data (ghist, flux_xy_4d, ndim1, ndim2, lb1 = lb1, lb2 = lb2) + ENDIF + + CALL mp2g_hist%pset2grid (acc_vec, flux_xy_4d, spv = spval, msk = filter) + + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + DO yloc = 1, ghist%ycnt(yblk) + DO xloc = 1, ghist%xcnt(xblk) + + IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN + DO i1 = flux_xy_4d%lb1, flux_xy_4d%ub1 + DO i2 = flux_xy_4d%lb2, flux_xy_4d%ub2 + IF (flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spval) THEN + flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) & + = flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) & + / sumarea%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + ENDDO + ENDDO + ELSE + flux_xy_4d%blk(xblk,yblk)%val(:,:,xloc,yloc) = spval + ENDIF + + ENDDO + ENDDO + + ENDDO + ENDIF + + compress = DEF_HIST_CompressLevel + CALL hist_write_var_real8_4d (file_hist, varname, dim1name, dim2name, & + ghist, itime_in_file, flux_xy_4d, compress, longname, units) + + END SUBROUTINE flux_map_and_write_4d + + + SUBROUTINE hist_gridded_write_time ( & + filename, filelast, dataname, time, itime) + + USE MOD_Block + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: filelast + character (len=*), intent(in) :: dataname + + integer, intent(in) :: time(3) + integer, intent(out) :: itime + + ! Local variables + character(len=256) :: fileblock + integer :: iblkme, iblk, jblk + logical :: fexists + + IF (trim(DEF_HIST_mode) == 'one') THEN + IF (p_is_master) THEN +#ifdef USEMPI + IF (DEF_HIST_WriteBack) THEN + CALL hist_writeback_latlon_time (filename, filelast, dataname, time, hist_concat) + itime = 1 + ELSE +#endif + inquire (file=filename, exist=fexists) + IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN + + CALL ncio_create_file (trim(filename)) + CALL ncio_define_dimension(filename, 'time', 0) + CALL ncio_define_dimension(filename, 'lat' , hist_concat%ginfo%nlat) + CALL ncio_define_dimension(filename, 'lon' , hist_concat%ginfo%nlon) + + CALL ncio_write_serial (filename, 'lat', hist_concat%ginfo%lat_c, 'lat') + CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') + CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') + + CALL ncio_write_serial (filename, 'lon', hist_concat%ginfo%lon_c, 'lon') + CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') + CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') + +#ifndef SinglePoint + CALL ncio_write_serial (filename, 'lat_s', hist_concat%ginfo%lat_s, 'lat') + CALL ncio_write_serial (filename, 'lat_n', hist_concat%ginfo%lat_n, 'lat') + CALL ncio_write_serial (filename, 'lon_w', hist_concat%ginfo%lon_w, 'lon') + CALL ncio_write_serial (filename, 'lon_e', hist_concat%ginfo%lon_e, 'lon') +#endif + + CALL ncio_write_colm_dimension (filename) + + ENDIF + + CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) + +#ifdef USEMPI + ENDIF +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (itime, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#endif + + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (ghist%ycnt(jblk) <= 0) CYCLE + IF (ghist%xcnt(iblk) <= 0) CYCLE + + CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file=fileblock, exist=fexists) + IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN + CALL ncio_create_file (trim(fileblock)) + CALL ncio_define_dimension (fileblock, 'time', 0) + CALL hist_write_grid_info (fileblock, ghist, iblk, jblk) + ENDIF + + CALL ncio_write_time (fileblock, dataname, time, itime, DEF_HIST_FREQ) + + ENDDO + + ENDIF +#ifdef USEMPI + IF (.not. p_is_master) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) +#endif + + ENDIF + + END SUBROUTINE hist_gridded_write_time + + + SUBROUTINE hist_write_var_real8_2d ( & + filename, dataname, grid, itime, wdata, compress, longname, units) + + USE MOD_Block + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_2d), intent(in) :: wdata + + integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp + integer :: rmesg(3), smesg(3), isrc + character(len=256) :: fileblock + real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) + + IF (trim(DEF_HIST_mode) == 'one') THEN + + IF (p_is_master) THEN + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN + + allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) + vdata(:,:) = spval + + DO idata = 1, hist_concat%ndatablk + CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & + hist_data_id, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + allocate (rbuf(xcnt,ycnt)) + + CALL mpi_recv (rbuf, xcnt*ycnt, MPI_REAL8, & + isrc, hist_data_id, p_comm_glb, p_stat, p_err) + + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf + deallocate (rbuf) + + ENDDO + + ELSE + IF (itime == -1) THEN + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 2, 'lon', 'lat', '', '', '', compress, longname, units) + ELSE + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 3, 'lon', 'lat', 'time', '', '', compress, longname, units) + ENDIF + ENDIF +#else + allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) + vdata(:,:) = spval + + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg + iblk = hist_concat%xsegs(ixseg)%blk + jblk = hist_concat%ysegs(iyseg)%blk + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + xbdsp = hist_concat%xsegs(ixseg)%bdsp + ybdsp = hist_concat%ysegs(iyseg)%bdsp + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & + wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + ENDIF + ENDDO + ENDDO +#endif + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN +#endif + IF (itime >= 1) THEN + + CALL ncio_write_serial_time (filename, dataname, itime, vdata, & + 'lon', 'lat', 'time', compress) + + ELSEIF (itime == -1) THEN + CALL ncio_write_serial (filename, dataname, vdata, 'lon', 'lat', compress) + ENDIF + + IF (itime <= 1) THEN + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + deallocate (vdata) +#ifdef USEMPI + ENDIF +#endif + + ENDIF + +#ifdef USEMPI + IF (p_is_io) THEN + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg + + iblk = hist_concat%xsegs(ixseg)%blk + jblk = hist_concat%ysegs(iyseg)%blk + + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + xbdsp = hist_concat%xsegs(ixseg)%bdsp + ybdsp = hist_concat%ysegs(iyseg)%bdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + allocate (sbuf (xcnt,ycnt)) + sbuf = wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + + IF (.not. DEF_HIST_WriteBack) THEN + smesg = (/p_iam_glb, ixseg, iyseg/) + CALL mpi_send (smesg, 3, MPI_INTEGER, & + p_address_master, hist_data_id, p_comm_glb, p_err) + CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, & + p_address_master, hist_data_id, p_comm_glb, p_err) + ELSE + CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata2d = sbuf) + ENDIF + + deallocate (sbuf) + + ENDIF + ENDDO + ENDDO + ENDIF +#endif + + hist_data_id = mod(hist_data_id-10000,10000) + 100001 + + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE + + CALL get_filename_block (filename, iblk, jblk, fileblock) + + IF (itime >= 1) THEN + + CALL ncio_write_serial_time (fileblock, dataname, itime, & + wdata%blk(iblk,jblk)%val, 'lon', 'lat', 'time', compress) + + ELSEIF (itime == -1) THEN + CALL ncio_write_serial (fileblock, dataname, & + wdata%blk(iblk,jblk)%val, 'lon', 'lat', compress) + ENDIF + + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE hist_write_var_real8_2d + + + SUBROUTINE hist_write_var_real8_3d ( & + filename, dataname, dim1name, grid, itime, wdata, compress, longname, units) + + USE MOD_Block + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + character (len=*), intent(in) :: dim1name + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_3d), intent(in) :: wdata + + integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: xcnt, ycnt, ndim1, xbdsp, ybdsp, xgdsp, ygdsp, idim1 + integer :: rmesg(4), smesg(4), isrc + character(len=256) :: fileblock + real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) + + IF (trim(DEF_HIST_mode) == 'one') THEN + + IF (p_is_master) THEN + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN + + DO idata = 1, hist_concat%ndatablk + + CALL mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, & + hist_data_id, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + ndim1 = rmesg(4) + + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + allocate (rbuf (ndim1,xcnt,ycnt)) + + CALL mpi_recv (rbuf, ndim1*xcnt*ycnt, MPI_REAL8, & + isrc, hist_data_id, p_comm_glb, p_stat, p_err) + + IF (idata == 1) THEN + allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat, ndim1)) + vdata(:,:,:) = spval + ENDIF + + DO idim1 = 1, ndim1 + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1) = rbuf(idim1,:,:) + ENDDO + + deallocate (rbuf) + ENDDO + + ELSE + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 4, 'lon', 'lat', dim1name, 'time', '', compress, longname, units) + ENDIF +#else + ndim1 = wdata%ub1 - wdata%lb1 + 1 + allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat, ndim1)) + vdata(:,:,:) = spval + + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg + iblk = hist_concat%xsegs(ixseg)%blk + jblk = hist_concat%ysegs(iyseg)%blk + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + xbdsp = hist_concat%xsegs(ixseg)%bdsp + ybdsp = hist_concat%ysegs(iyseg)%bdsp + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + DO idim1 = 1, ndim1 + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt,idim1) = & + wdata%blk(iblk,jblk)%val(wdata%lb1+idim1-1,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + ENDDO + ENDIF + ENDDO + ENDDO +#endif + + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN +#endif + CALL ncio_define_dimension (filename, dim1name, ndim1) + + CALL ncio_write_serial_time (filename, dataname, itime, & + vdata, 'lon', 'lat', dim1name, 'time', compress) + + IF (itime == 1) THEN + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + deallocate (vdata) +#ifdef USEMPI + ENDIF +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_io) THEN + + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg + + iblk = hist_concat%xsegs(ixseg)%blk + jblk = hist_concat%ysegs(iyseg)%blk + + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + xbdsp = hist_concat%xsegs(ixseg)%bdsp + ybdsp = hist_concat%ysegs(iyseg)%bdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + ndim1 = size(wdata%blk(iblk,jblk)%val,1) + + allocate (sbuf (ndim1,xcnt,ycnt)) + sbuf = wdata%blk(iblk,jblk)%val(:, xbdsp+1:xbdsp+xcnt, ybdsp+1:ybdsp+ycnt) + + IF (.not. DEF_HIST_WriteBack) THEN + smesg = (/p_iam_glb, ixseg, iyseg, ndim1/) + CALL mpi_send (smesg, 4, MPI_INTEGER, & + p_address_master, hist_data_id, p_comm_glb, p_err) + CALL mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_REAL8, & + p_address_master, hist_data_id, p_comm_glb, p_err) + ELSE + CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata3d = sbuf) + ENDIF + + deallocate (sbuf) + ENDIF + ENDDO + ENDDO + ENDIF +#endif + + hist_data_id = mod(hist_data_id-10000,10000) + 100001 + + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE + + CALL get_filename_block (filename, iblk, jblk, fileblock) + + CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) + + CALL ncio_write_serial_time (fileblock, dataname, itime, & + wdata%blk(iblk,jblk)%val, dim1name, 'lon', 'lat', 'time', compress) + + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE hist_write_var_real8_3d + + + SUBROUTINE hist_write_var_real8_4d ( & + filename, dataname, dim1name, dim2name, grid, itime, wdata, compress, longname, units) + + USE MOD_Block + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + character (len=*), intent(in) :: dim1name, dim2name + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_4d), intent(in) :: wdata + + integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: iblkme, iblk, jblk, idata, ixseg, iyseg + integer :: xcnt, ycnt, ndim1, ndim2, xbdsp, ybdsp, xgdsp, ygdsp, idim1, idim2 + integer :: rmesg(5), smesg(5), isrc + character(len=256) :: fileblock + real(r8), allocatable :: rbuf(:,:,:,:), sbuf(:,:,:,:), vdata(:,:,:,:) + + IF (trim(DEF_HIST_mode) == 'one') THEN + + IF (p_is_master) THEN + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN + + DO idata = 1, hist_concat%ndatablk + + CALL mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, & + hist_data_id, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + ndim1 = rmesg(4) + ndim2 = rmesg(5) + + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + allocate (rbuf (ndim1,ndim2,xcnt,ycnt)) + + CALL mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & + isrc, hist_data_id, p_comm_glb, p_stat, p_err) + + IF (idata == 1) THEN + allocate (vdata (hist_concat%ginfo%nlon,hist_concat%ginfo%nlat,ndim1,ndim2)) + vdata(:,:,:,:) = spval + ENDIF + + DO idim1 = 1, ndim1 + DO idim2 = 1, ndim2 + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1, idim2) = rbuf(idim1,idim2,:,:) + ENDDO + ENDDO + + deallocate (rbuf) + ENDDO + + ELSE + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 5, 'lon', 'lat', dim1name, dim2name, 'time', compress, longname, units) + ENDIF +#else + ndim1 = wdata%ub1 - wdata%lb1 + 1 + ndim2 = wdata%ub2 - wdata%lb2 + 1 + allocate (vdata (hist_concat%ginfo%nlon,hist_concat%ginfo%nlat,ndim1,ndim2)) + vdata(:,:,:,:) = spval + + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg + iblk = hist_concat%xsegs(ixseg)%blk + jblk = hist_concat%ysegs(iyseg)%blk + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + xbdsp = hist_concat%xsegs(ixseg)%bdsp + ybdsp = hist_concat%ysegs(iyseg)%bdsp + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + DO idim1 = 1, ndim1 + DO idim2 = 1, ndim2 + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1, idim2) = & + wdata%blk(iblk,jblk)%val(idim1,idim2,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + ENDDO + ENDDO + ENDIF + ENDDO + ENDDO + +#endif + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN +#endif + CALL ncio_define_dimension (filename, dim1name, ndim1) + CALL ncio_define_dimension (filename, dim2name, ndim2) + + CALL ncio_write_serial_time (filename, dataname, itime, vdata, & + 'lon', 'lat', dim1name, dim2name, 'time', compress) + + IF (itime == 1) THEN + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + deallocate (vdata) +#ifdef USEMPI + ENDIF +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_io) THEN + + DO iyseg = 1, hist_concat%nyseg + DO ixseg = 1, hist_concat%nxseg + + iblk = hist_concat%xsegs(ixseg)%blk + jblk = hist_concat%ysegs(iyseg)%blk + + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + xbdsp = hist_concat%xsegs(ixseg)%bdsp + ybdsp = hist_concat%ysegs(iyseg)%bdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt + + ndim1 = size(wdata%blk(iblk,jblk)%val,1) + ndim2 = size(wdata%blk(iblk,jblk)%val,2) + allocate (sbuf (ndim1,ndim2,xcnt,ycnt)) + sbuf = wdata%blk(iblk,jblk)%val(:,:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + + IF (.not. DEF_HIST_WriteBack) THEN + smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/) + CALL mpi_send (smesg, 5, MPI_INTEGER, & + p_address_master, hist_data_id, p_comm_glb, p_err) + CALL mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & + p_address_master, hist_data_id, p_comm_glb, p_err) + ELSE + CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata4d = sbuf) + ENDIF + + deallocate (sbuf) + ENDIF + ENDDO + ENDDO + ENDIF +#endif + + hist_data_id = mod(hist_data_id-10000,10000) + 100001 + + ELSEIF (trim(DEF_HIST_mode) == 'block') THEN + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE + + CALL get_filename_block (filename, iblk, jblk, fileblock) + + CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) + CALL ncio_define_dimension (fileblock, dim2name, wdata%ub2-wdata%lb2+1) + + CALL ncio_write_serial_time (fileblock, dataname, itime, & + wdata%blk(iblk,jblk)%val, dim1name, dim2name, 'lon', 'lat', 'time', compress) + + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE hist_write_var_real8_4d + + + SUBROUTINE hist_write_grid_info (fileblock, grid, iblk, jblk) + + USE MOD_Block + IMPLICIT NONE + + character(len=*), intent(in) :: fileblock + type (grid_type), intent(in) :: grid + integer, intent(in) :: iblk, jblk + + ! Local variable + integer :: yl, yu, xl, xu, nx + real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:) + + allocate (lon_w (grid%xcnt(iblk))) + allocate (lon_e (grid%xcnt(iblk))) + allocate (lat_s (grid%ycnt(jblk))) + allocate (lat_n (grid%ycnt(jblk))) + + yl = grid%ydsp(jblk) + 1 + yu = grid%ydsp(jblk) + grid%ycnt(jblk) + + lat_s = grid%lat_s(yl:yu) + lat_n = grid%lat_n(yl:yu) + + IF (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) THEN + xl = grid%xdsp(iblk) + 1 + xu = grid%nlon + nx = grid%nlon - grid%xdsp(iblk) + lon_w(1:nx) = grid%lon_w(xl:xu) + lon_e(1:nx) = grid%lon_e(xl:xu) + + xl = 1 + xu = grid%xcnt(iblk) - nx + lon_w(nx+1:grid%xcnt(iblk)) = grid%lon_w(xl:xu) + lon_e(nx+1:grid%xcnt(iblk)) = grid%lon_e(xl:xu) + ELSE + xl = grid%xdsp(iblk) + 1 + xu = grid%xdsp(iblk) + grid%xcnt(iblk) + lon_w = grid%lon_w(xl:xu) + lon_e = grid%lon_e(xl:xu) + ENDIF + + CALL ncio_define_dimension (fileblock, 'lat', grid%ycnt(jblk)) + CALL ncio_define_dimension (fileblock, 'lon', grid%xcnt(iblk)) + CALL ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat') + CALL ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat') + CALL ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon') + CALL ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon') + + CALL ncio_write_colm_dimension (fileblock) + + END SUBROUTINE hist_write_grid_info + +END MODULE MOD_HistGridded diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 new file mode 100644 index 0000000000..2c1b748491 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 @@ -0,0 +1,370 @@ +#include + +#ifdef SinglePoint +MODULE MOD_HistSingle + +!---------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Write out model results at sites to history files. +! +! Created by Shupeng Zhang, July 2023 +! +! TODO...(need complement) +!---------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Namelist, only: USE_SITE_HistWriteBack + USE MOD_SPMD_Task + + logical :: memory_to_disk + + integer :: ntime_mem + integer :: itime_mem + integer, allocatable :: time_memory (:) + + ! -- data type -- + type hist_memory_type + character(len=256) :: varname + real(r8), allocatable :: v2d (:,:) + real(r8), allocatable :: v3d (:,:,:) + real(r8), allocatable :: v4d (:,:,:,:) + type(hist_memory_type), pointer :: next + END type hist_memory_type + + type(hist_memory_type), target :: hist_memory + type(hist_memory_type), pointer :: thisvar, nextvar + +CONTAINS + + ! -- initialize history IO -- + SUBROUTINE hist_single_init () + + USE MOD_Namelist + IMPLICIT NONE + + ! Local Variables + real(r8) :: secs_group, secs_write + + IF (USE_SITE_HistWriteBack) THEN + + IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN + secs_group = 366*24*3600 + ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN + secs_group = 31*24*3600 + ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN + secs_group = 24*3600 + ENDIF + + select CASE (trim(adjustl(DEF_HIST_FREQ))) + CASE ('TIMESTEP') + secs_write = DEF_simulation_time%timestep + CASE ('HOURLY') + secs_write = 3600 + CASE ('DAILY') + secs_write = 24*3600 + CASE ('MONTHLY') + secs_write = 31*24*3600 + CASE ('YEARLY') + secs_write = 366*24*3600 + END select + + ntime_mem = ceiling(secs_group / secs_write) + 2 + + allocate (time_memory (ntime_mem)) + + itime_mem = 0 + + hist_memory%next => null() + hist_memory%varname = '' + + thisvar => hist_memory + + ENDIF + + END SUBROUTINE hist_single_init + + ! -- finalize history IO -- + SUBROUTINE hist_single_final () + + IMPLICIT NONE + + IF (USE_SITE_HistWriteBack) THEN + + thisvar => hist_memory%next + DO WHILE (associated(thisvar)) + nextvar => thisvar%next + IF (allocated(thisvar%v2d)) deallocate(thisvar%v2d) + IF (allocated(thisvar%v3d)) deallocate(thisvar%v3d) + IF (allocated(thisvar%v4d)) deallocate(thisvar%v4d) + deallocate(thisvar) + thisvar => nextvar + ENDDO + + deallocate (time_memory) + + ENDIF + + END SUBROUTINE hist_single_final + + ! -- write history time -- + SUBROUTINE hist_single_write_time (filename, filelast, dataname, time, itime) + + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_SingleSrfData + USE MOD_NetCDFSerial + USE MOD_Landpatch, only: numpatch +#ifdef URBAN_MODEL + USE MOD_Landurban, only: numurban +#endif + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: filelast + character (len=*), intent(in) :: dataname + + integer, intent(in) :: time(3) + integer, intent(out) :: itime + + ! Local variables + integer :: minutes + logical :: fexists + + inquire (file=filename, exist=fexists) + IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN + CALL ncio_create_file (trim(filename)) + CALL ncio_define_dimension(filename, 'patch', numpatch) + + CALL ncio_write_serial (filename, 'lat', SITE_lat_location) + CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') + CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') + + CALL ncio_write_serial (filename, 'lon', SITE_lon_location) + CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') + CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') + + CALL ncio_write_colm_dimension (filename) + + IF (.not. USE_SITE_HistWriteBack) THEN + CALL ncio_define_dimension(filename, 'time', 0) + ENDIF + + ENDIF + + IF (USE_SITE_HistWriteBack) THEN + + minutes = minutes_since_1900 (time(1), time(2), time(3)) + + select CASE (trim(adjustl(DEF_HIST_FREQ))) + CASE ('HOURLY') + minutes = minutes - 30 + CASE ('DAILY') + minutes = minutes - 720 + CASE ('MONTHLY') + minutes = minutes - 21600 + CASE ('YEARLY') + minutes = minutes - 262800 + END select + + itime_mem = itime_mem + 1 + time_memory(itime_mem) = minutes + + IF (memory_to_disk) THEN + CALL ncio_define_dimension(filename, 'time', itime_mem) + CALL ncio_write_serial (filename, dataname, time_memory(1:itime_mem), 'time') + CALL ncio_put_attr (filename, dataname, 'long_name', 'time') + CALL ncio_put_attr (filename, dataname, 'units', 'minutes since 1900-1-1 0:0:0') + ENDIF + + thisvar => hist_memory + + ELSE + CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) + ENDIF + + END SUBROUTINE hist_single_write_time + + ! -- write 2D data -- + SUBROUTINE single_write_2d ( & + acc_vec, file_hist, varname, itime_in_file, longname, units) + + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + IF (USE_SITE_HistWriteBack) THEN + + IF (.not. associated(thisvar%next)) THEN + allocate (thisvar%next) + thisvar => thisvar%next + + thisvar%next => null() + thisvar%varname = varname + allocate(thisvar%v2d (size(acc_vec),ntime_mem)) + ELSE + thisvar => thisvar%next + ENDIF + + IF (thisvar%varname /= varname) THEN + write(*,*) 'Warning: history variable in memory is wrong: ' & + // trim(thisvar%varname) // ' should be ' // trim(varname) + CALL CoLM_stop () + ENDIF + + thisvar%v2d(:,itime_mem) = acc_vec(:) + + IF (memory_to_disk) THEN + CALL ncio_write_serial (file_hist, varname, & + thisvar%v2d(:,1:itime_mem), 'patch', 'time') + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + + ELSE + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + 'patch', 'time') + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + ENDIF + + END SUBROUTINE single_write_2d + + ! -- write 3D data -- + SUBROUTINE single_write_3d ( & + acc_vec, file_hist, varname, itime_in_file, dim1name, ndim1, longname, units) + + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name + integer, intent(in) :: ndim1 + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + + IF (USE_SITE_HistWriteBack) THEN + + IF (.not. associated(thisvar%next)) THEN + allocate (thisvar%next) + thisvar => thisvar%next + + thisvar%next => null() + thisvar%varname = varname + allocate(thisvar%v3d (ndim1,size(acc_vec,2),ntime_mem)) + ELSE + thisvar => thisvar%next + ENDIF + + IF (thisvar%varname /= varname) THEN + write(*,*) 'Warning: history variable in memory is wrong: ' & + // trim(thisvar%varname) // ' should be ' // trim(varname) + CALL CoLM_stop () + ENDIF + + thisvar%v3d(:,:,itime_mem) = acc_vec + + IF (memory_to_disk) THEN + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_write_serial (file_hist, varname, thisvar%v3d(:,:,1:itime_mem), & + dim1name, 'patch', 'time') + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + + ELSE + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + dim1name, 'patch', 'time') + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + ENDIF + + END SUBROUTINE single_write_3d + + ! -- write 4D data -- + SUBROUTINE single_write_4d ( & + acc_vec, file_hist, varname, itime_in_file, & + dim1name, ndim1, dim2name, ndim2, longname, units) + + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(inout) :: acc_vec(:,:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name + integer, intent(in) :: ndim1 + character(len=*), intent(in) :: dim2name + integer, intent(in) :: ndim2 + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + IF (USE_SITE_HistWriteBack) THEN + + IF (.not. associated(thisvar%next)) THEN + allocate (thisvar%next) + thisvar => thisvar%next + + thisvar%next => null() + thisvar%varname = varname + allocate(thisvar%v4d (ndim1,ndim2,size(acc_vec,3),ntime_mem)) + ELSE + thisvar => thisvar%next + ENDIF + + IF (thisvar%varname /= varname) THEN + write(*,*) 'Warning: history variable in memory is wrong: ' & + // trim(thisvar%varname) // ' should be ' // trim(varname) + CALL CoLM_stop () + ENDIF + + thisvar%v4d(:,:,:,itime_mem) = acc_vec + + IF (memory_to_disk) THEN + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_define_dimension (file_hist, dim2name, ndim2) + CALL ncio_write_serial (file_hist, varname, thisvar%v4d(:,:,:,1:itime_mem), & + dim1name, dim2name, 'patch', 'time') + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + + ELSE + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_define_dimension (file_hist, dim2name, ndim2) + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + dim1name, dim2name, 'patch', 'time') + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + ENDIF + + END SUBROUTINE single_write_4d + +END MODULE MOD_HistSingle +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 new file mode 100644 index 0000000000..e1e48adf9f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 @@ -0,0 +1,623 @@ +#include + +#if (defined UNSTRUCTURED || defined CATCHMENT) +MODULE MOD_HistVector + +!---------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Write out vectorized model results to history files. +! +! Created by Shupeng Zhang, May 2023 +! +! TODO...(need complement) +!---------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Vars_Global, only: spval + USE MOD_Mesh + USE MOD_LandElm +#ifdef CATCHMENT + USE MOD_LandHRU +#endif + USE MOD_Pixelset + USE MOD_NetCDFSerial +#ifdef CATCHMENT + USE MOD_HRUVector +#else + USE MOD_ElmVector +#endif + +CONTAINS + + ! -- write history time -- + SUBROUTINE hist_vector_write_time (filename, filelast, dataname, time, itime_in_file) + + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: filelast + character (len=*), intent(in) :: dataname + integer, intent(in) :: time(3) + integer, intent(out) :: itime_in_file + + ! Local Variables + logical :: fexists + + IF (p_is_master) THEN + + inquire (file=filename, exist=fexists) + IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN + CALL ncio_create_file (trim(filename)) + CALL ncio_define_dimension(filename, 'time', 0) + +#ifdef CATCHMENT + CALL ncio_define_dimension(filename, 'hydrounit', totalnumhru) + + CALL ncio_write_serial (filename, 'bsn_hru', eindx_hru, 'hydrounit') + CALL ncio_put_attr (filename, 'bsn_hru', 'long_name', & + 'basin index of hydrological units in mesh') + + CALL ncio_write_serial (filename, 'typ_hru' , htype_hru, 'hydrounit') + CALL ncio_put_attr (filename, 'typ_hru' , 'long_name', & + 'index of hydrological units inside basin') +#else + CALL ncio_define_dimension(filename, 'element', totalnumelm) + CALL ncio_write_serial (filename, 'elmindex', eindex_glb, 'element') + CALL ncio_put_attr (filename, 'elmindex', 'long_name', & + 'element index in mesh') +#endif + + CALL ncio_write_colm_dimension (filename) + + ENDIF + + CALL ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) + + ENDIF + + END SUBROUTINE hist_vector_write_time + + + SUBROUTINE aggregate_to_vector_and_write_2d ( & + acc_vec_patch, file_hist, varname, itime_in_file, filter, & + longname, units, input_mode) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_LandPatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(in) :: acc_vec_patch (:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + logical, intent(in) :: filter(:) + + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + character(len=*), intent(in), optional :: input_mode + + ! Local variables + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:), rcache(:) + real(r8) :: sumwt + character(len=256) :: inmode + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN +#ifdef CATCHMENT + numset = numhru +#else + numset = numelm +#endif + + inmode = 'average' + IF (present(input_mode)) inmode = trim(input_mode) + + IF (numset > 0) THEN + + allocate (acc_vec (numset)) + acc_vec(:) = spval + + DO iset = 1, numset +#ifdef CATCHMENT + istt = hru_patch%substt(iset) + iend = hru_patch%subend(iset) +#else + istt = elm_patch%substt(iset) + iend = elm_patch%subend(iset) +#endif + + IF ((istt > 0) .and. (iend >= istt)) THEN + allocate (mask(istt:iend)) + allocate (frac(istt:iend)) + mask = (acc_vec_patch(istt:iend) /= spval) .and. filter(istt:iend) + IF (any(mask)) THEN + IF (trim(inmode) == 'average') THEN +#ifdef CATCHMENT + frac = hru_patch%subfrc(istt:iend) +#else + frac = elm_patch%subfrc(istt:iend) +#endif + sumwt = sum(frac, mask = mask) + acc_vec(iset) = sum(frac * acc_vec_patch(istt:iend), mask = mask) + acc_vec(iset) = acc_vec(iset) / sumwt + ELSE + acc_vec(iset) = sum(acc_vec_patch(istt:iend), mask = mask) + ENDIF + ENDIF + deallocate(mask) + deallocate(frac) + ENDIF + ENDDO + ENDIF + +#ifdef USEMPI + mesg = (/p_iam_glb, numset/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numset > 0) THEN + CALL mpi_send (acc_vec, numset, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#endif + ENDIF + + IF (p_is_master) THEN + +#ifdef CATCHMENT + totalnumset = totalnumhru +#else + totalnumset = totalnumelm +#endif + + IF (.not. allocated(acc_vec)) THEN + allocate (acc_vec (totalnumset)) + ENDIF + +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate(rcache (ndata)) + CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + +#ifdef CATCHMENT + acc_vec(hru_data_address(p_itis_worker(isrc))%val) = rcache +#else + acc_vec(elm_data_address(p_itis_worker(isrc))%val) = rcache +#endif + + deallocate (rcache) + ENDIF + ENDDO +#else +#ifdef CATCHMENT + acc_vec(hru_data_address(0)%val) = acc_vec +#else + acc_vec(elm_data_address(0)%val) = acc_vec +#endif +#endif + ENDIF + + IF (p_is_master) THEN + + compress = DEF_HIST_CompressLevel + + IF (itime_in_file >= 1) THEN +#ifdef CATCHMENT + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + 'hydrounit', 'time', compress) +#else + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + 'element', 'time', compress) +#endif + ELSE +#ifdef CATCHMENT + CALL ncio_write_serial (file_hist, varname, acc_vec, 'hydrounit', compress) +#else + CALL ncio_write_serial (file_hist, varname, acc_vec, 'element', compress) +#endif + ENDIF + + IF (itime_in_file <= 1) THEN + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + + ENDIF + + IF (allocated(acc_vec)) deallocate (acc_vec) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE aggregate_to_vector_and_write_2d + + + SUBROUTINE aggregate_to_vector_and_write_3d ( & + acc_vec_patch, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, filter, & + longname, units) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_LandPatch + USE MOD_Vars_1DAccFluxes, only: nac + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(in) :: acc_vec_patch (lb1:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name + integer, intent(in) :: lb1, ndim1 + + logical, intent(in) :: filter(:) + + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + integer :: ub1, i1 + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:,:), rcache(:,:) + real(r8) :: sumwt + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ub1 = lb1 + ndim1 - 1 + + IF (p_is_worker) THEN +#ifdef CATCHMENT + numset = numhru +#else + numset = numelm +#endif + + IF (numset > 0) THEN + + allocate (acc_vec (lb1:ub1,numset)) + + acc_vec(:,:) = spval + + DO iset = 1, numset +#ifdef CATCHMENT + istt = hru_patch%substt(iset) + iend = hru_patch%subend(iset) +#else + istt = elm_patch%substt(iset) + iend = elm_patch%subend(iset) +#endif + + IF ((istt > 0) .and. (iend >= istt)) THEN + allocate (mask(istt:iend)) + allocate (frac(istt:iend)) + DO i1 = lb1, ub1 + mask = (acc_vec_patch(i1,istt:iend) /= spval) .and. filter(istt:iend) + IF (any(mask)) THEN +#ifdef CATCHMENT + frac = hru_patch%subfrc(istt:iend) +#else + frac = elm_patch%subfrc(istt:iend) +#endif + sumwt = sum(frac, mask = mask) + acc_vec(i1,iset) = sum(frac * acc_vec_patch(i1,istt:iend), mask = mask) + acc_vec(i1,iset) = acc_vec(i1,iset) / sumwt / nac + ENDIF + ENDDO + deallocate(mask) + deallocate(frac) + ENDIF + ENDDO + ENDIF + +#ifdef USEMPI + mesg = (/p_iam_glb, numset/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numset > 0) THEN + CALL mpi_send (acc_vec, ndim1 * numset, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#endif + ENDIF + + IF (p_is_master) THEN + +#ifdef CATCHMENT + totalnumset = totalnumhru +#else + totalnumset = totalnumelm +#endif + + IF (.not. allocated(acc_vec)) THEN + allocate (acc_vec (ndim1,totalnumset)) + ENDIF + +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate(rcache (ndim1,ndata)) + CALL mpi_recv (rcache, ndim1*ndata, MPI_REAL8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + DO i1 = 1, ndim1 +#ifdef CATCHMENT + acc_vec(i1,hru_data_address(p_itis_worker(isrc))%val) = rcache(i1,:) +#else + acc_vec(i1,elm_data_address(p_itis_worker(isrc))%val) = rcache(i1,:) +#endif + + ENDDO + + deallocate (rcache) + ENDIF + ENDDO +#else + DO i1 = lb1, ub1 +#ifdef CATCHMENT + acc_vec(i1,hru_data_address(0)%val) = acc_vec(i1,:) +#else + acc_vec(i1,elm_data_address(0)%val) = acc_vec(i1,:) +#endif + ENDDO +#endif + ENDIF + + IF (p_is_master) THEN + + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + + compress = DEF_HIST_CompressLevel + + IF (itime_in_file >= 1) THEN +#ifdef CATCHMENT + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + dim1name, 'hydrounit', 'time', compress) +#else + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + dim1name, 'element', 'time', compress) +#endif + ELSE +#ifdef CATCHMENT + CALL ncio_write_serial (file_hist, varname, acc_vec, & + dim1name, 'hydrounit', compress) +#else + CALL ncio_write_serial (file_hist, varname, acc_vec, & + dim1name, 'element', compress) +#endif + ENDIF + + IF (itime_in_file <= 1) THEN + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + + ENDIF + + IF (allocated(acc_vec)) deallocate (acc_vec) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE aggregate_to_vector_and_write_3d + + + SUBROUTINE aggregate_to_vector_and_write_4d ( & + acc_vec_patch, file_hist, varname, itime_in_file, & + dim1name, lb1, ndim1, dim2name, lb2, ndim2, filter, & + longname, units) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_LandPatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), intent(in) :: acc_vec_patch (lb1:,lb2:,:) + character(len=*), intent(in) :: file_hist + character(len=*), intent(in) :: varname + integer, intent(in) :: itime_in_file + character(len=*), intent(in) :: dim1name, dim2name + integer, intent(in) :: lb1, ndim1, lb2, ndim2 + + logical, intent(in) :: filter(:) + + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units + + ! Local variables + integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress + integer :: ub1, i1, ub2, i2 + logical, allocatable :: mask(:) + real(r8), allocatable :: frac(:) + real(r8), allocatable :: acc_vec(:,:,:), rcache(:,:,:) + real(r8) :: sumwt + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ub1 = lb1 + ndim1 - 1 + ub2 = lb2 + ndim2 - 1 + + IF (p_is_worker) THEN +#ifdef CATCHMENT + numset = numhru +#else + numset = numelm +#endif + + IF (numset > 0) THEN + + allocate (acc_vec (lb1:ub1,lb2:ub2,numset)) + + acc_vec(:,:,:) = spval + + DO iset = 1, numset +#ifdef CATCHMENT + istt = hru_patch%substt(iset) + iend = hru_patch%subend(iset) +#else + istt = elm_patch%substt(iset) + iend = elm_patch%subend(iset) +#endif + + IF ((istt > 0) .and. (iend >= istt)) THEN + allocate (mask(istt:iend)) + allocate (frac(istt:iend)) + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + mask = (acc_vec_patch(i1,i2,istt:iend) /= spval) .and. filter(istt:iend) + IF (any(mask)) THEN +#ifdef CATCHMENT + frac = hru_patch%subfrc(istt:iend) +#else + frac = elm_patch%subfrc(istt:iend) +#endif + sumwt = sum(frac, mask = mask) + acc_vec(i1,i2,iset) = sum(frac * acc_vec_patch(i1,i2,istt:iend), mask = mask) + acc_vec(i1,i2,iset) = acc_vec(i1,i2,iset) / sumwt + ENDIF + ENDDO + ENDDO + deallocate(mask) + deallocate(frac) + ENDIF + ENDDO + ENDIF + +#ifdef USEMPI + mesg = (/p_iam_glb, numset/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numset > 0) THEN + CALL mpi_send (acc_vec, ndim1 * ndim2 * numset, MPI_REAL8, & + p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#endif + ENDIF + + IF (p_is_master) THEN + +#ifdef CATCHMENT + totalnumset = totalnumhru +#else + totalnumset = totalnumelm +#endif + + IF (.not. allocated(acc_vec)) THEN + allocate (acc_vec (ndim1,ndim2,totalnumset)) + ENDIF + +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate(rcache (ndim1,ndim2,ndata)) + CALL mpi_recv (rcache, ndim1 * ndim2 * ndata, MPI_REAL8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + DO i1 = 1, ndim1 + DO i2 = 1, ndim2 +#ifdef CATCHMENT + acc_vec(i1,i2,hru_data_address(p_itis_worker(isrc))%val) = rcache(i1,i2,:) +#else + acc_vec(i1,i2,elm_data_address(p_itis_worker(isrc))%val) = rcache(i1,i2,:) +#endif + ENDDO + ENDDO + + deallocate (rcache) + ENDIF + ENDDO +#else + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 +#ifdef CATCHMENT + acc_vec(i1,i2,hru_data_address(0)%val) = acc_vec(i1,i2,:) +#else + acc_vec(i1,i2,elm_data_address(0)%val) = acc_vec(i1,i2,:) +#endif + ENDDO + ENDDO +#endif + ENDIF + + IF (p_is_master) THEN + + CALL ncio_define_dimension (file_hist, dim1name, ndim1) + CALL ncio_define_dimension (file_hist, dim2name, ndim2) + + compress = DEF_HIST_CompressLevel + + IF (itime_in_file >= 1) THEN +#ifdef CATCHMENT + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + dim1name, dim2name, 'hydrounit', 'time', compress) +#else + CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & + dim1name, dim2name, 'element', 'time', compress) +#endif + ELSE +#ifdef CATCHMENT + CALL ncio_write_serial (file_hist, varname, acc_vec, & + dim1name, dim2name, 'hydrounit', compress) +#else + CALL ncio_write_serial (file_hist, varname, acc_vec, & + dim1name, dim2name, 'element', compress) +#endif + ENDIF + + IF (itime_in_file <= 1) THEN + CALL ncio_put_attr (file_hist, varname, 'long_name', longname) + CALL ncio_put_attr (file_hist, varname, 'units', units) + CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) + ENDIF + + ENDIF + + IF (allocated(acc_vec)) deallocate (acc_vec) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE aggregate_to_vector_and_write_4d + + +END MODULE MOD_HistVector +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 new file mode 100644 index 0000000000..9721ad25a9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 @@ -0,0 +1,743 @@ +#include + +#ifdef USEMPI +MODULE MOD_HistWriteBack +!---------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Write out data to history files by a dedicated process. +! +! Author: Shupeng Zhang, 11/2023 +!---------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + + ! type of send buffer + type :: HistSendBufferType + integer :: dataid + integer :: datatag + integer :: sendreqs (3) + integer :: sendint4 (5) + character(len=256) :: sendchar (9) + real(r8), allocatable :: senddata (:) + type(HistSendBufferType), pointer :: next + END type HistSendBufferType + + ! Sending Variables + type(HistSendBufferType), pointer :: HistSendBuffer + type(HistSendBufferType), pointer :: LastSendBuffer + + ! type of times + type :: timenodetype + character(len=256) :: filename + character(len=256) :: filelast + character(len=256) :: timename + integer :: time(3) + integer :: req (4) + type(timenodetype), pointer :: next + END type timenodetype + + ! time nodes + integer :: dataid_zero = 0 + integer :: req_zero + type(timenodetype), pointer :: timenodes, lasttime + + ! dimension information + logical :: SDimInited = .false. + + ! 1: grid-based + integer :: nGridData, nxGridSeg, nyGridSeg + integer, allocatable :: xGridDsp(:), xGridCnt(:) + integer, allocatable :: yGridDsp(:), yGridCnt(:) + + integer :: nlat, nlon + real(r8), allocatable :: lat_c(:), lat_s(:), lat_n(:) + real(r8), allocatable :: lon_c(:), lon_w(:), lon_e(:) + + ! Memory limits + integer*8, parameter :: MaxHistMemSize = 1073741824_8 ! 1024^3 + integer*8 :: TotalMemSize = 0 + + integer :: itime_in_file_wb + + ! tags + integer, parameter :: tag_next = 1 + integer, parameter :: tag_time = 2 + integer, parameter :: tag_dims = 3 + +CONTAINS + + SUBROUTINE hist_writeback_daemon () + + USE MOD_Namelist, only: DEF_HIST_FREQ + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + ! Local Variables + integer :: dataid, tag + integer :: time(3), ndims, ndim1, ndim2, dimlens(4), compress + integer :: i, idata, isrc, ixseg, iyseg, xdsp, ydsp, xcnt, ycnt, idim1, idim2 + + integer :: recvint4 (5) + character(len=256) :: recvchar (9) + real(r8), allocatable :: datathis (:) + + character(len=256) :: filename, filelast, dataname, longname, units + character(len=256) :: dim1name, dim2name, dim3name, dim4name, dim5name + logical :: fexists + + real(r8), allocatable :: wdata1d(:), wdata2d(:,:), wdata3d(:,:,:), wdata4d(:,:,:,:) + real(r8), allocatable :: tmp3d(:,:,:), tmp4d(:,:,:,:) + + + DO WHILE (.true.) + + CALL mpi_recv (dataid, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_next, p_comm_glb_plus, p_stat, p_err) + + IF (dataid < 0) THEN + + EXIT + + ELSEIF (dataid == 0) THEN + + CALL mpi_recv (filename, 256, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (filelast, 256, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (dataname, 256, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (time, 3, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + IF (.not. SDimInited) THEN + + CALL mpi_recv (nGridData, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (nxGridSeg, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (nyGridSeg, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + allocate (xGridDsp (nxGridSeg)) + allocate (xGridCnt (nxGridSeg)) + allocate (yGridDsp (nyGridSeg)) + allocate (yGridCnt (nyGridSeg)) + + CALL mpi_recv (xGridDsp, nxGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (xGridCnt, nxGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (yGridDsp, nyGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (yGridCnt, nyGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (nlat, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + allocate(lat_c(nlat)) + allocate(lat_s(nlat)) + allocate(lat_n(nlat)) + + CALL mpi_recv (lat_c, nlat, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lat_s, nlat, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lat_n, nlat, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (nlon, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + allocate(lon_c(nlon)) + allocate(lon_w(nlon)) + allocate(lon_e(nlon)) + + CALL mpi_recv (lon_c, nlon, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lon_w, nlon, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lon_e, nlon, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + SDimInited = .true. + + ENDIF + + inquire (file=filename, exist=fexists) + IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN + + CALL ncio_create_file (trim(filename)) + + CALL ncio_define_dimension(filename, 'time', 0) + + CALL ncio_define_dimension(filename, 'lat', nlat) + CALL ncio_define_dimension(filename, 'lon', nlon) + + CALL ncio_write_serial (filename, 'lat', lat_c, 'lat') + CALL ncio_write_serial (filename, 'lon', lon_c, 'lon') + CALL ncio_write_serial (filename, 'lat_s', lat_s, 'lat') + CALL ncio_write_serial (filename, 'lat_n', lat_n, 'lat') + CALL ncio_write_serial (filename, 'lon_w', lon_w, 'lon') + CALL ncio_write_serial (filename, 'lon_e', lon_e, 'lon') + + CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') + CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') + CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') + CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') + + CALL ncio_write_colm_dimension (filename) + + ENDIF + + CALL ncio_write_time (filename, dataname, time, itime_in_file_wb, DEF_HIST_FREQ) + + ELSE + + !-------------------------------- + ! receive and write history data. + !-------------------------------- + + ! (1) data header + tag = dataid*10 + CALL mpi_recv (recvint4(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err) + + ndims = recvint4(1) + compress = recvint4(2) + + CALL mpi_recv (recvchar(1:9), 256*9, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err) + + filename = recvchar(1) + dataname = recvchar(2) + dim1name = recvchar(3) + dim2name = recvchar(4) + dim3name = recvchar(5) + dim4name = recvchar(6) + dim5name = recvchar(7) + longname = recvchar(8) + units = recvchar(9) + + ! (2) data + tag = dataid*10+1 + + DO idata = 1, nGridData + + CALL mpi_recv (recvint4(1:5), 5, MPI_INTEGER, MPI_ANY_SOURCE, & + tag, p_comm_glb_plus, p_stat, p_err) + + isrc = recvint4(1) + ixseg = recvint4(2) + iyseg = recvint4(3) + ndim1 = recvint4(4) + ndim2 = recvint4(5) + + xdsp = xGridDsp(ixseg) + ydsp = yGridDsp(iyseg) + xcnt = xGridCnt(ixseg) + ycnt = yGridCnt(iyseg) + + SELECTCASE (ndims) + CASE (2:3) + + dimlens = (/nlon, nlat, 0, 0/) + + IF (.not. allocated(wdata2d)) THEN + allocate (wdata2d (nlon,nlat)) + ENDIF + + allocate (datathis(xcnt*ycnt)) + CALL mpi_recv (datathis, xcnt*ycnt, MPI_REAL8, & + isrc, tag, p_comm_glb_plus, p_stat, p_err) + + wdata2d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt) = & + reshape(datathis,(/xcnt,ycnt/)) + + CASE (4) + + dimlens = (/ndim1, nlon, nlat, 0/) + + IF (.not. allocated(wdata3d)) THEN + allocate (wdata3d (nlon,nlat,ndim1)) + allocate (tmp3d (ndim1,nlon,nlat)) + ENDIF + + allocate (datathis(ndim1*xcnt*ycnt)) + CALL mpi_recv (datathis, ndim1*xcnt*ycnt, MPI_REAL8, & + isrc, tag, p_comm_glb_plus, p_stat, p_err) + + tmp3d = reshape(datathis,(/ndim1,xcnt,ycnt/)) + DO idim1 = 1, ndim1 + wdata3d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt, idim1) = tmp3d(idim1, :, :) + ENDDO + + CASE (5) + + dimlens = (/ndim1, ndim2, nlon, nlat/) + + IF (.not. allocated(wdata4d)) THEN + allocate (wdata4d (nlon,nlat,ndim1,ndim2)) + allocate (tmp4d (ndim1,ndim2,nlon,nlat)) + ENDIF + + allocate (datathis(ndim1*ndim2*xcnt*ycnt)) + CALL mpi_recv (datathis, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & + isrc, tag, p_comm_glb_plus, p_stat, p_err) + + tmp4d = reshape(datathis,(/ndim1, ndim2, xcnt, ycnt/)) + + DO idim1 = 1, ndim1 + DO idim2 = 1, ndim2 + wdata4d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt, idim1, idim2) = & + tmp4d(idim1, idim2, :, :) + ENDDO + ENDDO + + ENDSELECT + + deallocate (datathis) + + ENDDO + + + IF (ndims >= 4) CALL ncio_define_dimension (filename, dim3name, dimlens(1)) + IF (ndims >= 5) CALL ncio_define_dimension (filename, dim4name, dimlens(2)) + + SELECTCASE (ndims) + CASE (2) ! for variables with [lon,lat] + + CALL ncio_write_serial (filename, dataname, wdata2d, dim1name, dim2name, compress) + + deallocate(wdata2d) + CASE (3) ! for variables with [lon,lat,time] + + CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata2d, & + dim1name, dim2name, dim3name, compress) + + deallocate(wdata2d) + CASE (4) ! for variables with [lon,lat,dim3,time] + + CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata3d, & + dim1name, dim2name, dim3name, dim4name, compress) + + deallocate(tmp3d ) + deallocate(wdata3d) + CASE (5) ! for variables with [lon,lat,dim3,dim4,time] + + CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata4d, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress) + + deallocate(tmp4d ) + deallocate(wdata4d) + ENDSELECT + + IF (itime_in_file_wb <= 1) THEN + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + write(*,'(3A,I0,2A)') 'HIST WriteBack: ', trim(basename(filename)), & + ' (time ', itime_in_file_wb, '): ', trim(dataname) + + ENDIF + + ENDDO + + END SUBROUTINE hist_writeback_daemon + + ! ----- + SUBROUTINE hist_writeback_latlon_time (filename, filelast, timename, time, HistConcat) + + USE MOD_Namelist + USE MOD_Grid + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: filelast + character (len=*), intent(in) :: timename + integer, intent(in) :: time(3) + type(grid_concat_type), intent(in) :: HistConcat + + ! Local Variables + integer :: i + logical :: senddone + integer :: sendstat(MPI_STATUS_SIZE,4) + type(timenodetype), pointer :: tempnode + + IF (.not. associated(timenodes)) THEN + allocate (timenodes) + lasttime => timenodes + ELSE + allocate (lasttime%next) + lasttime => lasttime%next + ENDIF + + lasttime%filename = filename + lasttime%filelast = filelast + lasttime%timename = timename + lasttime%time = time + lasttime%next => null() + + CALL mpi_isend (dataid_zero, 1, MPI_INTEGER, & + p_address_writeback, tag_next, p_comm_glb_plus, req_zero, p_err) + + CALL mpi_isend (lasttime%filename, 256, MPI_CHARACTER, & + p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(1), p_err) + + CALL mpi_isend (lasttime%filelast, 256, MPI_CHARACTER, & + p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(2), p_err) + + CALL mpi_isend (lasttime%timename, 256, MPI_CHARACTER, & + p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(3), p_err) + + CALL mpi_isend (lasttime%time, 3, MPI_INTEGER, & + p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(4), p_err) + + + IF (.not. SDimInited) THEN + + nGridData = HistConcat%ndatablk + nxGridSeg = HistConcat%nxseg + nyGridSeg = HistConcat%nyseg + + allocate (xGridDsp (nxGridSeg)) + allocate (xGridCnt (nxGridSeg)) + allocate (yGridDsp (nyGridSeg)) + allocate (yGridCnt (nyGridSeg)) + + DO i = 1, nxGridSeg + xGridDsp(i) = HistConcat%xsegs(i)%gdsp + xGridCnt(i) = HistConcat%xsegs(i)%cnt + ENDDO + + DO i = 1, nyGridSeg + yGridDsp(i) = HistConcat%ysegs(i)%gdsp + yGridCnt(i) = HistConcat%ysegs(i)%cnt + ENDDO + + CALL mpi_send (nGridData, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (nxGridSeg, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (nyGridSeg, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + + CALL mpi_send (xGridDsp, nxGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (xGridCnt, nxGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (yGridDsp, nyGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (yGridCnt, nyGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + + nlat = HistConcat%ginfo%nlat + nlon = HistConcat%ginfo%nlon + allocate(lat_c(nlat)); lat_c = HistConcat%ginfo%lat_c + allocate(lat_s(nlat)); lat_s = HistConcat%ginfo%lat_s + allocate(lat_n(nlat)); lat_n = HistConcat%ginfo%lat_n + allocate(lon_c(nlon)); lon_c = HistConcat%ginfo%lon_c + allocate(lon_w(nlon)); lon_w = HistConcat%ginfo%lon_w + allocate(lon_e(nlon)); lon_e = HistConcat%ginfo%lon_e + + CALL mpi_send (nlat, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (lat_c, nlat, MPI_REAL8, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (lat_s, nlat, MPI_REAL8, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (lat_n, nlat, MPI_REAL8, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (nlon, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (lon_c, nlon, MPI_REAL8, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (lon_w, nlon, MPI_REAL8, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + CALL mpi_send (lon_e, nlon, MPI_REAL8, p_address_writeback, tag_dims, & + p_comm_glb_plus, p_err) + + SDimInited = .true. + + ENDIF + + DO WHILE (associated(timenodes%next)) + + CALL MPI_TestAll (4, timenodes%req, senddone, sendstat(:,1:4), p_err) + + IF (senddone) THEN + tempnode => timenodes + timenodes => timenodes%next + deallocate(tempnode) + ELSE + EXIT + ENDIF + ENDDO + + END SUBROUTINE hist_writeback_latlon_time + + ! ----- + SUBROUTINE hist_writeback_var_header (dataid, filename, dataname, & + ndims, dim1name, dim2name, dim3name, dim4name, dim5name, & + compress, longname, units) + + IMPLICIT NONE + + integer, intent(in) :: dataid + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndims + character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name, dim5name + integer, intent(in) :: compress + character(len=*), intent(in) :: longname, units + + ! Local Variables + logical :: senddone + integer :: sendstat(MPI_STATUS_SIZE,3) + type(HistSendBufferType), pointer :: TempSendBuffer + + ! append sending buffer + IF (.not. associated(HistSendBuffer)) THEN + allocate (HistSendBuffer) + LastSendBuffer => HistSendBuffer + ELSE + allocate (LastSendBuffer%next) + LastSendBuffer => LastSendBuffer%next + ENDIF + + LastSendBuffer%next => null() + + ! clean sending buffer and free memory + DO WHILE (associated(HistSendBuffer%next)) + + CALL MPI_Testall (3, HistSendBuffer%sendreqs, senddone, sendstat(:,1:3), p_err) + + IF (senddone) THEN + + TempSendBuffer => HistSendBuffer + HistSendBuffer => HistSendBuffer%next + + IF (allocated(TempSendBuffer%senddata)) THEN + deallocate (TempSendBuffer%senddata) + ENDIF + deallocate (TempSendBuffer) + ELSE + EXIT + ENDIF + ENDDO + + LastSendBuffer%dataid = dataid + LastSendBuffer%datatag = dataid*10 + + LastSendBuffer%sendint4(1:2) = (/ndims, compress/) + + LastSendBuffer%sendchar(1) = filename + LastSendBuffer%sendchar(2) = dataname + LastSendBuffer%sendchar(3) = dim1name + LastSendBuffer%sendchar(4) = dim2name + LastSendBuffer%sendchar(5) = dim3name + LastSendBuffer%sendchar(6) = dim4name + LastSendBuffer%sendchar(7) = dim5name + LastSendBuffer%sendchar(8) = longname + LastSendBuffer%sendchar(9) = units + + CALL mpi_isend (LastSendBuffer%dataid, 1, MPI_INTEGER, & + p_address_writeback, tag_next, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) + + CALL mpi_isend (LastSendBuffer%sendint4(1:2), 2, MPI_INTEGER, & + p_address_writeback, LastSendBuffer%datatag, & + p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) + + CALL mpi_isend (LastSendBuffer%sendchar, 256*9, MPI_CHARACTER, & + p_address_writeback, LastSendBuffer%datatag, & + p_comm_glb_plus, LastSendBuffer%sendreqs(3), p_err) + + END SUBROUTINE hist_writeback_var_header + + ! ----- + SUBROUTINE hist_writeback_var ( dataid, ixseg, iyseg, & + wdata1d, wdata2d, wdata3d, wdata4d) + + IMPLICIT NONE + + integer, intent(in) :: dataid, ixseg, iyseg + + real(r8), intent(in), optional :: wdata1d(:) + real(r8), intent(in), optional :: wdata2d(:,:) + real(r8), intent(in), optional :: wdata3d(:,:,:) + real(r8), intent(in), optional :: wdata4d(:,:,:,:) + + ! Local Variables + integer :: totalsize, ndim1, ndim2 + logical :: senddone + integer :: sendstat(MPI_STATUS_SIZE,2) + type(HistSendBufferType), pointer :: TempSendBuffer + + ! append sending buffer + IF (.not. associated(HistSendBuffer)) THEN + allocate (HistSendBuffer) + LastSendBuffer => HistSendBuffer + TotalMemSize = 0 + ELSE + allocate (LastSendBuffer%next) + LastSendBuffer => LastSendBuffer%next + ENDIF + + LastSendBuffer%next => null() + + ! clean sending buffer and free memory + DO WHILE (associated(HistSendBuffer%next)) + + IF (TotalMemSize > MaxHistMemSize) THEN + CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), sendstat(:,1:2), p_err) + ELSE + CALL MPI_Testall (2, HistSendBuffer%sendreqs(1:2), senddone, sendstat(:,1:2), p_err) + IF (.not. senddone) EXIT + ENDIF + + TotalMemSize = TotalMemSize - size(HistSendBuffer%senddata) + + TempSendBuffer => HistSendBuffer + HistSendBuffer => HistSendBuffer%next + deallocate(TempSendBuffer%senddata) + deallocate(TempSendBuffer) + + ENDDO + + LastSendBuffer%datatag = dataid*10+1 + + ndim1 = 0 + ndim2 = 0 + + IF (present(wdata2d)) THEN + + totalsize = size(wdata2d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = reshape(wdata2d, (/totalsize/)) + + ELSEIF (present(wdata3d)) THEN + + ndim1 = size(wdata3d,1) + totalsize = size(wdata3d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = reshape(wdata3d, (/totalsize/)) + + ELSEIF (present(wdata4d)) THEN + + ndim1 = size(wdata4d,1) + ndim2 = size(wdata4d,2) + totalsize = size(wdata4d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = reshape(wdata4d, (/totalsize/)) + + ENDIF + + TotalMemSize = TotalMemSize + totalsize + + LastSendBuffer%sendint4(1:5) = (/p_iam_glb_plus, ixseg, iyseg, ndim1, ndim2/) + + CALL mpi_isend (LastSendBuffer%sendint4(1:5), 5, MPI_INTEGER, & + p_address_writeback, LastSendBuffer%datatag, & + p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) + + CALL mpi_isend (LastSendBuffer%senddata, totalsize, MPI_REAL8, & + p_address_writeback, LastSendBuffer%datatag, & + p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) + + END SUBROUTINE hist_writeback_var + + ! ----- + SUBROUTINE hist_writeback_exit () + + IMPLICIT NONE + + ! Local Variables + integer :: dataid, nreq + integer :: sendstat(MPI_STATUS_SIZE,4) + type(timenodetype), pointer :: tempnode + type(HistSendBufferType), pointer :: TempSendBuffer + + lasttime => null() + DO WHILE (associated(timenodes)) + + CALL MPI_WaitAll (4, timenodes%req, sendstat(:,1:4), p_err) + + tempnode => timenodes + timenodes => timenodes%next + deallocate(tempnode) + ENDDO + + LastSendBuffer => null() + DO WHILE (associated(HistSendBuffer)) + + IF (allocated(HistSendBuffer%senddata)) THEN + CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), sendstat(:,1:2), p_err) + deallocate(HistSendBuffer%senddata) + ELSE + CALL MPI_Waitall (3, HistSendBuffer%sendreqs(1:3), sendstat(:,1:3), p_err) + ENDIF + + TempSendBuffer => HistSendBuffer + HistSendBuffer => HistSendBuffer%next + deallocate (TempSendBuffer) + + ENDDO + + IF (allocated(xGridDsp)) deallocate(xGridDsp) + IF (allocated(yGridDsp)) deallocate(yGridDsp) + IF (allocated(xGridCnt)) deallocate(xGridCnt) + IF (allocated(yGridCnt)) deallocate(yGridCnt) + IF (allocated(lat_c )) deallocate(lat_c ) + IF (allocated(lat_s )) deallocate(lat_s ) + IF (allocated(lat_n )) deallocate(lat_n ) + IF (allocated(lon_c )) deallocate(lon_c ) + IF (allocated(lon_w )) deallocate(lon_w ) + IF (allocated(lon_e )) deallocate(lon_e ) + + + IF (.not. p_is_writeback) THEN + CALL mpi_barrier (p_comm_glb, p_err) + ENDIF + + IF (p_is_master) THEN + dataid = -1 + CALL mpi_send (dataid, 1, MPI_INTEGER, p_address_writeback, & + tag_next, p_comm_glb_plus, p_err) + ENDIF + + CALL mpi_barrier (p_comm_glb_plus, p_err) + + END SUBROUTINE hist_writeback_exit + + ! ---- + character(len=256) FUNCTION basename (fullname) + + IMPLICIT NONE + character(len=*), intent(in) :: fullname + + ! Local variables + integer :: i, n + + i = len_trim (fullname) + DO WHILE (i > 0) + IF (fullname(i:i) == '/') EXIT + i = i - 1 + ENDDO + + IF (i > 0) THEN + basename = fullname(i+1:) + ELSE + basename = fullname + ENDIF + + END FUNCTION basename + +END MODULE MOD_HistWriteBack +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 new file mode 100644 index 0000000000..8c11982acd --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 @@ -0,0 +1,569 @@ +#include +#ifdef CROP +MODULE MOD_Irrigation + +! DESCRIPTION: +! This MODULE has all irrigation related subroutines for irrigated crop at either IGBP/USGS or PFT Land type classification and even in the C and N cycle. + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_simulation_time, DEF_IRRIGATION_ALLOCATION, DEF_USE_VariablySaturatedFlow + USE MOD_Const_Physical, only: tfrz, denice, denh2o + USE MOD_Const_PFT, only: irrig_crop + USE MOD_LandPFT, only : patch_pft_s, patch_pft_e + USE MOD_Vars_Global, only: irrig_start_time, irrig_max_depth, irrig_threshold_fraction, irrig_supply_fraction, irrig_min_cphase, irrig_max_cphase, irrig_time_per_day, & + irrig_method_drip, irrig_method_sprinkler, irrig_method_flood, irrig_method_paddy + USE MOD_Qsadv, only: qsadv + USE MOD_Vars_TimeInvariants, only: pondmx, & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, fc_vgm, sc_vgm,& +#endif + porsl, psi0, bsw + USE MOD_Vars_TimeVariables, only: tref, t_soisno, wliq_soisno, wice_soisno, zwt, wa, & + irrig_rate, sum_irrig, sum_deficit_irrig, sum_irrig_count, n_irrig_steps_left, & + tairday, usday, vsday, pairday, rnetday, fgrndday, potential_evapotranspiration,& + groundwater_demand, groundwater_supply, reservoirriver_demand, reservoirriver_supply, & + reservoir_supply, river_supply, runoff_supply, & + waterstorage, deficit_irrig, actual_irrig, irrig_gw_alloc, irrig_sw_alloc, zwt_stand + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_PFTimeVariables, only: irrig_method_p + USE MOD_BGC_Vars_PFTimeVariables, only: cphase_p + USE MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs + USE MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd + USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi +#ifdef CaMa_Flood + USE MOD_CaMa_Vars, only: withdrawal_cama, withdrawal_dam_cama, withdrawal_riv_cama, withdrawal_rof_cama +#endif + USE MOD_SPMD_Task + IMPLICIT NONE + + PUBLIC :: CalIrrigationNeeded + PUBLIC :: CalIrrigationApplicationFluxes + +CONTAINS + + SUBROUTINE CalIrrigationNeeded(i,idate,nl_soil,nbedrock,z_soi,zi_soi,dz_soi,deltim,dlon,npcropmin) + + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate how much irrigation needed in each irrigated crop patch + integer , intent(in) :: i + integer , intent(in) :: idate(3) + integer , intent(in) :: nl_soil + integer , intent(in) :: nbedrock + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: zi_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + + ! local + integer :: ps, pe, m + integer :: irrig_nsteps_per_day + logical :: check_for_irrig + ps = patch_pft_s(i) + pe = patch_pft_e(i) + + ! initialize irrigation + deficit_irrig(i) = 0._r8 + actual_irrig(i) = 0._r8 + groundwater_demand(i) = 0._r8 + groundwater_supply(i) = 0._r8 + reservoirriver_demand(i) = 0._r8 + reservoirriver_supply(i) = 0._r8 + reservoir_supply(i) = 0._r8 + river_supply(i) = 0._r8 + runoff_supply(i) = 0._r8 + + ! zero irrigation at the begin of the new year + if (idate(2) == 1 .and. idate(3) == deltim)then + sum_irrig(i) = 0._r8 + sum_deficit_irrig(i) = 0._r8 + sum_irrig_count(i) = 0._r8 + zwt_stand(i) = zwt(i) + 1._r8 + zwt_stand(i) = max(0., zwt_stand(i)) + zwt_stand(i) = min(80., zwt_stand(i)) + end if + +#ifdef CaMa_Flood + ! irrigation withdraw from reservoir and river + reservoirriver_supply(i) = withdrawal_cama(i) + reservoir_supply(i) = withdrawal_dam_cama(i) + river_supply(i) = withdrawal_riv_cama(i) + runoff_supply(i) = withdrawal_rof_cama(i) + waterstorage(i) = waterstorage(i) + max(0._r8, reservoirriver_supply(i)) + withdrawal_cama(i) = 0._r8 + withdrawal_dam_cama(i) = 0._r8 + withdrawal_riv_cama(i) = 0._r8 + withdrawal_rof_cama(i) = 0._r8 + + ! IF (reservoirriver_supply(i) > 0) THEN + ! WRITE(*,*) "LHB debug line98 runoff error: p_iam_glb, ipatch, reservoirriver_supply ---> ", & + ! p_iam_glb, i, reservoirriver_supply(i) + ! ENDIF +#endif + + ! ! calculate last day potential evapotranspiration + ! CALL CalPotentialEvapotranspiration(i,idate,dlon,deltim) + + ! calculate whether irrigation needed + CALL PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + + ! calculate irrigation needed + IF (check_for_irrig) THEN + CALL CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + call CalIrrigationLimitedSupply(i,nl_soil,deltim,dz_soi,zi_soi) + ENDIF + + ! calculate irrigation rate kg/m2->mm/s + IF ((check_for_irrig) .and. (deficit_irrig(i) > 0)) THEN + sum_deficit_irrig(i) = sum_deficit_irrig(i) + deficit_irrig(i) + ENDIF + IF ((check_for_irrig) .and. (actual_irrig(i) > 0)) THEN + irrig_nsteps_per_day = nint(irrig_time_per_day/deltim) + irrig_rate(i) = actual_irrig(i)/deltim/irrig_nsteps_per_day + n_irrig_steps_left(i) = irrig_nsteps_per_day + sum_irrig(i) = sum_irrig(i) + actual_irrig(i) + sum_irrig_count(i) = sum_irrig_count(i) + 1._r8 + ENDIF + END SUBROUTINE CalIrrigationNeeded + + SUBROUTINE CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate how much irrigation needed in each irrigated crop patch without water supply restriction + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: nbedrock + integer , intent(in) :: nl_soil + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + + ! local variables + integer :: j + integer :: m + logical :: reached_max_depth + real(r8) :: h2osoi_liq_tot + real(r8) :: h2osoi_liq_target_tot + real(r8) :: h2osoi_liq_wilting_point_tot + real(r8) :: h2osoi_liq_field_capacity_tot + real(r8) :: h2osoi_liq_saturation_capacity_tot + real(r8) :: h2osoi_liq_wilting_point(1:nl_soil) + real(r8) :: h2osoi_liq_field_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_saturation_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_at_threshold + + real(r8) :: smpswc = -1.5e5 + real(r8) :: smpsfc = -3.3e3 + + ! initialize local variables + reached_max_depth = .false. + h2osoi_liq_tot = 0._r8 + h2osoi_liq_target_tot = 0._r8 + h2osoi_liq_wilting_point_tot = 0._r8 + h2osoi_liq_field_capacity_tot = 0._r8 + h2osoi_liq_saturation_capacity_tot = 0._r8 + + ! calculate wilting point and field capacity + DO j = 1, nl_soil + IF (t_soisno(j,i) > tfrz .and. porsl(j,i) >= 1.e-6) THEN +#ifdef Campbell_SOIL_MODEL + h2osoi_liq_wilting_point(j) = denh2o*dz_soi(j)*porsl(j,i)*((smpswc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_field_capacity(j) = denh2o*dz_soi(j)*porsl(j,i)*((smpsfc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_saturation_capacity(j) = denh2o*dz_soi(j)*porsl(j,i) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + h2osoi_liq_wilting_point(j) = soil_vliq_from_psi(smpswc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_wilting_point(j) = denh2o*dz_soi(j)*h2osoi_liq_wilting_point(j) + h2osoi_liq_field_capacity(j) = soil_vliq_from_psi(smpsfc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_field_capacity(j) = denh2o*dz_soi(j)*h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity(j) = denh2o*dz_soi(j)*porsl(j,i) +#endif + ENDIF + ENDDO + + ! calculate total irrigation needed in all soil layers + DO m = ps, pe + DO j = 1, nl_soil + IF (.not. reached_max_depth) THEN + IF (z_soi(j) > irrig_max_depth) THEN + reached_max_depth = .true. + ELSEIF (j > nbedrock) THEN + reached_max_depth = .true. + ELSEIF (t_soisno(j,i) <= tfrz) THEN + reached_max_depth = .true. + ELSE + h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) + h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) + h2osoi_liq_field_capacity_tot = h2osoi_liq_field_capacity_tot + h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) + ENDIF + ENDIF + ENDDO + IF (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler .or. & + irrig_method_p(m) == irrig_method_flood) THEN + ! flood irrigation threshold at field capacity, but irrigation amount at saturation capacity + h2osoi_liq_target_tot = h2osoi_liq_field_capacity_tot + ELSEIF (irrig_method_p(m) == irrig_method_paddy) THEN + h2osoi_liq_target_tot = h2osoi_liq_saturation_capacity_tot + ELSE + ! default irrigation is sprinkler irrigation + h2osoi_liq_target_tot = h2osoi_liq_field_capacity_tot + ENDIF + ENDDO + + ! calculate irrigation threshold + deficit_irrig(i) = 0._r8 + h2osoi_liq_at_threshold = h2osoi_liq_wilting_point_tot + irrig_threshold_fraction * (h2osoi_liq_target_tot - h2osoi_liq_wilting_point_tot) + + ! calculate total irrigation + DO m = ps, pe + IF (h2osoi_liq_tot < h2osoi_liq_at_threshold) THEN + IF (irrig_method_p(m) == irrig_method_sprinkler) THEN + deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_field_capacity_tot - h2osoi_liq_tot) + ! deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_field_capacity_tot - h2osoi_liq_tot + potential_evapotranspiration(i)) + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot) + ELSE + deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_field_capacity_tot - h2osoi_liq_tot) + ENDIF + ELSE + deficit_irrig(i) = 0 + ENDIF + ENDDO + + END SUBROUTINE CalIrrigationPotentialNeeded + + SUBROUTINE CalIrrigationApplicationFluxes(i,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy) + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate irrigation application fluxes for each irrigated crop patch + integer , intent(in) :: i + real(r8), intent(in) :: deltim + real(r8), intent(out):: qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy + + integer :: ps, pe, m + + ps = patch_pft_s(i) + pe = patch_pft_e(i) + + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 + + ! add irrigation fluxes to precipitation or land surface + DO m = ps, pe + IF (n_irrig_steps_left(i) > 0) THEN + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + IF (waterstorage(i) - irrig_rate(i)*deltim < 0._r8) irrig_rate(i) = waterstorage(i)/deltim + waterstorage(i) = max(waterstorage(i) - irrig_rate(i)*deltim, 0._r8) + IF (irrig_method_p(m) == irrig_method_drip) THEN + qflx_irrig_drip = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_sprinkler) THEN + qflx_irrig_sprinkler = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + qflx_irrig_flood = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_paddy) THEN + qflx_irrig_paddy = irrig_rate(i) + ELSE + qflx_irrig_sprinkler = irrig_rate(i) + ENDIF + ELSE + irrig_rate(i) = 0._r8 + ENDIF + ENDDO + END SUBROUTINE CalIrrigationApplicationFluxes + + SUBROUTINE PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate whether irrigation needed in each patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: idate(3) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + logical , intent(out):: check_for_irrig + + ! local variable + integer :: m, ivt + real(r8):: ldate(3) + real(r8):: seconds_since_irrig_start_time + + ! adjust flood irrigation in rice to paddy irrigaiton + DO m = ps, pe + ivt = pftclass(m) + IF ((ivt == 62) .and. (irrig_method_p(m) == irrig_method_flood)) THEN + irrig_method_p(m) = irrig_method_paddy + ENDIF + ENDDO + + DO m = ps, pe + ivt = pftclass(m) + IF ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & + (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) THEN + check_for_irrig = .true. + ELSE + check_for_irrig = .false. + ENDIF + ELSE + check_for_irrig = .false. + ENDIF + ENDDO + + END SUBROUTINE PointNeedsCheckForIrrig + + ! SUBROUTINE CalPotentialEvapotranspiration(i,idate,dlon,deltim) + ! ! DESCRIPTION: + ! ! This SUBROUTINE is used to calculate daily potential evapotranspiration + ! integer , intent(in) :: i + ! integer , intent(in) :: idate(3) + ! real(r8), intent(in) :: dlon + ! real(r8), intent(in) :: deltim + ! ! local variable + ! real(r8):: ldate(3) + ! real(r8):: seconds_since_irrig_start_time + ! real(r8) :: es,esdT,qs,qsdT ! saturation vapour pressure + ! real(r8) :: evsat ! vapour pressure + ! real(r8) :: ur ! wind speed + ! real(r8) :: delta ! slope of saturation vapour pressure curve + ! real(r8) :: gamma ! Psychrometric constant + + ! IF (DEF_simulation_time%greenwich) THEN + ! CALL gmt2local(idate, dlon, ldate) + ! seconds_since_irrig_start_time = ldate(3) - irrig_start_time + deltim + ! ELSE + ! seconds_since_irrig_start_time = idate(3) - irrig_start_time + deltim + ! ENDIF + + ! IF (((seconds_since_irrig_start_time-deltim) >= 0) .and. ((seconds_since_irrig_start_time-deltim) < deltim)) THEN + ! tairday(i) = (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = forc_us(i)*deltim/86400 + ! vsday(i) = forc_vs(i)*deltim/86400 + ! pairday(i) = forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrnd(i)*deltim/1000000 + ! ELSE + ! tairday(i) = tairday(i) + (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = usday(i) + forc_us(i)*deltim/86400 + ! vsday(i) = vsday(i) + forc_vs(i)*deltim/86400 + ! pairday(i) = pairday(i) + forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = rnetday(i) + (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrndday(i) + fgrnd(i)*deltim/1000000 + ! ENDIF + + ! IF ((seconds_since_irrig_start_time >= 0) .and. (seconds_since_irrig_start_time < deltim)) THEN + ! CALL qsadv(tairday(i),pairday(i),es,esdT,qs,qsdT) + ! IF (tairday(i) > 0)THEN + ! evsat = 0.611*EXP(17.27*tairday(i)/(tairday(i)+237.3)) + ! ELSE + ! evsat = 0.611*EXP(21.87*tairday(i)/(tairday(i)+265.5)) + ! ENDIF + ! ur = max(0.1,sqrt(usday(i)*usday(i)+vsday(i)*vsday(i))) + ! delta = 4098*evsat/((tairday(i)+237.3)*(tairday(i)+237.3)) + ! gamma = 0.665*0.001*pairday(i) + ! potential_evapotranspiration(i) = (0.408*delta*(rnetday(i)-fgrndday(i))+gamma*(900/(tairday(i)+273))*ur* & + ! (evsat-es))/(delta+(gamma*(1+0.34*ur))) + ! ENDIF + ! END SUBROUTINE CalPotentialEvapotranspiration + + SUBROUTINE CalIrrigationLimitedSupply(i,nl_soil,deltim,dz_soi,zi_soi) + ! DESCRIPTION: + ! This subroutine is used to calculate how much irrigation supplied in each irrigated crop patch with water supply restriction + integer, intent(in) :: i + integer, intent(in) :: nl_soil + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: zi_soi(1:nl_soil) + + real(r8) :: waterstorage_supply + + IF (deficit_irrig(i) > 0._r8) THEN + IF (DEF_IRRIGATION_ALLOCATION == 1) THEN + actual_irrig(i) = deficit_irrig(i) + waterstorage(i) = waterstorage(i) + actual_irrig(i) + ELSEIF (DEF_IRRIGATION_ALLOCATION == 2) THEN + waterstorage_supply = min(waterstorage(i), deficit_irrig(i)) + waterstorage_supply = max(waterstorage_supply, 0._r8) + actual_irrig(i) = actual_irrig(i) + waterstorage_supply +#ifdef CaMa_Flood + IF (deficit_irrig(i) > actual_irrig(i)) THEN + reservoirriver_demand(i) = max(deficit_irrig(i) - actual_irrig(i), 0._r8) + ENDIF +#endif + ! irrigation withdraw from ground water (unconfined and confined) + IF (deficit_irrig(i) > actual_irrig(i)) THEN + groundwater_demand(i) = max(deficit_irrig(i) - actual_irrig(i), 0._r8) + CALL CalGroudwaterWithdrawal(i,nl_soil,deltim,dz_soi,zi_soi) + actual_irrig(i) = actual_irrig(i) + groundwater_supply(i) + waterstorage(i) = waterstorage(i) + groundwater_supply(i) + ENDIF + ELSEIF (DEF_IRRIGATION_ALLOCATION == 3) THEN + waterstorage_supply = min(waterstorage(i), deficit_irrig(i)) + waterstorage_supply = max(waterstorage_supply, 0._r8) + actual_irrig(i) = actual_irrig(i) + waterstorage_supply +#ifdef CaMa_Flood + IF (deficit_irrig(i) > actual_irrig(i)) THEN + reservoirriver_demand(i) = max((deficit_irrig(i) - actual_irrig(i))*(1.-irrig_gw_alloc(i)), 0._r8) + ENDIF +#endif + ! irrigation withdraw from ground water (unconfined and confined) + IF (deficit_irrig(i) > actual_irrig(i)) THEN + groundwater_demand(i) = max((deficit_irrig(i) - actual_irrig(i))*irrig_gw_alloc(i), 0._r8) + CALL CalGroudwaterWithdrawal(i,nl_soil,deltim,dz_soi,zi_soi) + actual_irrig(i) = actual_irrig(i) + groundwater_supply(i) + waterstorage(i) = waterstorage(i) + groundwater_supply(i) + ENDIF + ENDIF + ENDIF + END SUBROUTINE CalIrrigationLimitedSupply + + + SUBROUTINE CalGroudwaterWithdrawal(i,nl_soil,deltim,dz_soi,zi_soi) + ! DESCRIPTION: + ! This subroutine is used to calculate irrigation withdrawals for groudwater + integer, intent(in) :: i + integer, intent(in) :: nl_soil + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: zi_soi(1:nl_soil) + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + CALL CalWithdrawalWATER(i,nl_soil,deltim,dz_soi,zi_soi) + ELSE + groundwater_supply(i) = groundwater_demand(i) + ENDIF + END SUBROUTINE CalGroudwaterWithdrawal + + + + subroutine CalWithdrawalWATER(i,nl_soil,deltim,dz_soi,zi_soi) + ! DESCRIPTION: + ! This subroutine is used to calculate how much irrigation supplied in each irrigated crop patch with groundwater supply restriction + IMPLICIT NONE + integer, INTENT(in) :: i + integer, INTENT(in) :: nl_soil + real(r8), INTENT(in) :: deltim ! land model time step (sec) + real(r8), INTENT(in) :: dz_soi (1:nl_soil) ! layer depth (m) + real(r8), INTENT(in) :: zi_soi (1:nl_soil) ! interface level below a "z" level (m) + + ! LOCAL ARGUMENTS + integer :: j ! indices + integer :: jwt ! index of the soil layer right above the water table (-) + real(r8) :: dzmm(1:nl_soil) ! layer thickness (mm) + real(r8) :: vol_ice(1:nl_soil)! partitial volume of ice lens in layer + real(r8) :: eff_porosity(1:nl_soil)! effective porosity = porosity - vol_ice + real(r8) :: xs ! water needed to bring soil moisture to watmin (mm) + real(r8) :: xsi ! excess soil water above saturation at layer i (mm) + real(r8) :: xs1 ! excess soil water above saturation at layer 1 (mm) + real(r8) :: pump_total + real(r8) :: pump_layer + real(r8) :: max_groundwater_supply + real(r8) :: s_y + real(r8) :: rous ! specific yield [-] + ! ------------------------------------------------------------------------- + + do j = 1, nl_soil + vol_ice(j) = min(porsl(j,i), wice_soisno(j,i)/(dz_soi(j)*denice)) + eff_porosity(j) = max(0.01, porsl(j,i)-vol_ice(j)) + end do + + ! Convert layer thicknesses from m to mm + DO j = 1,nl_soil + dzmm(j) = dz_soi(j)*1000. + ENDDO + + ! The layer index of the first unsaturated layer, + ! i.e., the layer right above the water table + jwt = nl_soil + ! allow jwt to equal zero when zwt is in top layer + DO j = 1, nl_soil + IF(zwt(i) <= zi_soi(j)) THEN + jwt = j-1 + exit + ENDIF + ENDDO + + rous = porsl(nl_soil,i)*(1.-(1.-1.e3*zwt(i)/psi0(nl_soil,i))**(-1./bsw(nl_soil,i))) + rous = max(rous,0.02) + + !-- Water table is below the soil column ---------------------------------------- + IF (jwt == nl_soil) THEN + max_groundwater_supply = max(1.e3*(zwt_stand(i)-zwt(i))*rous, 0._r8) + groundwater_supply(i) = min(groundwater_demand(i), max_groundwater_supply) + wa(i) = wa(i) - groundwater_supply(i) + zwt(i) = max(0., zwt(i) + groundwater_supply(i)/1000./rous) + wliq_soisno(nl_soil,i) = wliq_soisno(nl_soil,i) + max(0.,(wa(i)-5000.)) + wa(i) = min(wa(i), 5000.) + ELSE + !-- Water table within soil layers 1-9 ------------------------------------------ + !============================== RSUB_TOP ========================================= + !-- Now remove water via pump + pump_total = - groundwater_demand(i) + DO j = jwt+1, nl_soil + ! use analytical expression for specific yield + s_y = porsl(j,i) * ( 1. - (1.-1.e3*zwt(i)/psi0(j,i))**(-1./bsw(j,i))) + s_y = max(s_y,0.02) + + pump_layer = max(pump_total, -(s_y*(zi_soi(j)-zwt(i))*1.e3)) + pump_layer = min(pump_layer, 0.) + wliq_soisno(j,i) = wliq_soisno(j,i) + pump_layer + + pump_total = pump_total - pump_layer + groundwater_supply(i) = groundwater_supply(i) - pump_layer + + IF (pump_total >= 0.) THEN + zwt(i) = max(0.,zwt(i) - pump_layer/s_y/1000.) + exit + ELSE + zwt(i) = zi_soi(j) + ENDIF + ENDDO + !-- Remove residual drainage ------------------------------------------------ + max_groundwater_supply = max(1.e3*(zwt_stand(i)-zwt(i))*rous, 0._r8) + pump_total = min(-pump_total, max_groundwater_supply) + pump_total = max(pump_total, 0._r8) + groundwater_supply(i) = groundwater_supply(i) + pump_total + zwt(i) = max(0., zwt(i) + pump_total/1000./rous) + wa(i) = wa(i) - pump_total + + !-- Recompute jwt --------------------------------------------------------------- + ! allow jwt to equal zero when zwt is in top layer + jwt = nl_soil + DO j = 1, nl_soil + IF (zwt(i) <= zi_soi(j)) THEN + jwt = j-1 + exit + ENDIF + ENDDO + ENDIF ! end of jwt if construct + + zwt(i) = max(0.0,zwt(i)) + zwt(i) = min(80.,zwt(i)) + + + ! Correction [2] + ! NON-physically based corection on wliq_soisno + ! Limit wliq_soisno to be greater than or equal to watmin. + ! Get water needed to bring wliq_soisno equal watmin from lower layer. + ! If insufficient water in soil layers, get from aquifer water + xs = 0. + DO j = 1, nl_soil + IF (wliq_soisno(j,i) < 0.) THEN + xs = xs + wliq_soisno(j,i) + wliq_soisno(j,i) = 0. + ENDIF + ENDDO + wa(i) = wa(i) + xs + END SUBROUTINE CalWithdrawalWATER + +END MODULE MOD_Irrigation +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 new file mode 100644 index 0000000000..93ac924bf9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 @@ -0,0 +1,139 @@ +#include + +MODULE MOD_LAIEmpirical + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LAI_empirical + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE LAI_empirical(ivt,nl_soil,rootfr,t,lai,sai,fveg,green) + +!----------------------------------------------------------------------- +! provides leaf and stem area parameters +! Original author: Yongjiu Dai, 08/31/2002 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ivt !land cover type + integer, intent(in) :: nl_soil !number of soil layers + + real(r8), intent(in) :: rootfr(1:nl_soil) !root fraction + real(r8), intent(in) :: t(1:nl_soil) !soil temperature + real(r8), intent(out) :: lai !leaf area index + real(r8), intent(out) :: sai !Stem area index + real(r8), intent(out) :: fveg !fractional cover of vegetation + real(r8), intent(out) :: green !greenness + +!-------------------------- Local Variables ---------------------------- + real(r8) f ! + real(r8) roota !accumulates root fraction + integer jrt !number of soil layers with 90% root fraction + integer j !number of soil layers + +!----------------------------------------------------------------------- +#if (defined LULC_USGS) +! Maximum fractional cover of vegetation [-] + real(r8), dimension(24), parameter :: & + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, & + 1.0, 1.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0 /) +! Maximum leaf area index, the numbers are based on the data of +! "worldwide historical estimates of leaf area index, 1932-2000" : +! http://www.daac.ornl.gov/global_vegetation/HistoricalLai/data" + real(r8), dimension(24), parameter :: & + xla=(/1.50, 3.29, 4.18, 3.50, 2.50, 3.60, 2.02, 1.53, & + 2.00, 0.85, 4.43, 4.42, 4.56, 3.95, 4.50, 0.00, & + 4.00, 3.63, 0.00, 0.64, 1.60, 1.00, 0.00, 0.00 /) +! Minimum leaf area index + real(r8), dimension(24), parameter :: & + xla0=(/1.00, 0.50, 0.50, 0.50, 1.00, 0.50, 0.50, 0.50, & + 0.50, 0.30, 0.50, 0.50, 4.00, 4.00, 4.00, 0.00, & + 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) +! Stem area index [-] + real(r8), dimension(24), parameter :: & + sai0=(/0.20, 0.20, 0.30, 0.30, 0.50, 0.50, 1.00, 0.50, & + 1.00, 0.50, 2.00, 2.00, 2.00, 2.00, 2.00, 0.00, & + 2.00, 2.00, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00 /) +#elif (defined SIB2_CLASSIFICATION) + real(r8), dimension(11), parameter :: & + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + real(r8), dimension(11), parameter :: & + xla =(/4.8, 3.9, 5.6, 5.5, 4.6, 1.7, 1.3, 2.1, 3.6, 0.0, 0.0/) + real(r8), dimension(11), parameter :: & + xla0=(/4.0, 0.6, 0.5, 5.0, 0.5, 0.3, 0.6, 0.4, 0.2, 0.0, 0.0/) + real(r8), dimension(11), parameter :: & + sai0=(/1.6, 1.8, 1.6, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.0, 0.0/) +#elif (defined BATS_CLASSIFICATION) + real(r8), dimension(19), parameter :: & + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 1.0, 1.0,& + 1.0, 0.0, 1.0, 0.0, 0.0, 1.0, 1.0, 1.0, 1.0/) + real(r8), dimension(19), parameter :: & + xla =(/5.1, 1.6, 4.8, 4.8, 4.8, 5.4, 4.8, 0.0, 3.6, 4.8,& + 0.6, 0.0, 4.8, 0.0, 0.0, 4.8, 4.8, 4.8, 4.8/) + real(r8), dimension(19), parameter :: & + xla0=(/0.425, 0.4, 4.0, 0.8, 0.8, 4.5, 0.4, 0.0, 0.3, 0.4,& + 0.05, 0.0, 0.4, 0.0, 0.0, 4.0, 0.8, 2.4, 2.4/) + real(r8), dimension(19), parameter :: & + sai0=(/0.425, 3.2, 1.6, 1.6, 1.6, 1.8, 1.6, 0.0, 0.3, 0.4,& + 0.2, 0.0, 1.6, 0.0, 0.0, 1.6, 1.6, 1.6, 1.6/) +#elif (defined OGE_CLASSIFICATION) + +#else +!#elif(defined LULC_IGBP) + real(r8), dimension(17), parameter :: & + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,& + 1.0, 1.0, 1.0, 1.0, 0.0, 1.0, 0.0/) + real(r8), dimension(17), parameter :: & + xla =(/4.8, 5.4, 4.8, 4.8, 4.7, 4.7, 1.6, 4.7, 4.8, 1.7,& + 4.6, 4.9, 3.8, 4.8, 0.0, 0.06, 0.0/) + real(r8), dimension(17), parameter :: & + xla0=(/4.0, 4.5, 0.8, 0.8, 2.2, 1.6, 0.15, 1.8, 0.9, 0.4,& + 0.4, 0.4, 0.9, 2.0, 0.0, 0.006, 0.0/) + real(r8), dimension(17), parameter :: & + sai0=(/1.6, 1.8, 1.6, 1.6, 1.5, 1.5, 0.45, 1.4, 1.6, 3.1,& + 1.6, 0.4, 1.1, 1.3, 0.0, 0.14, 0.0/) +#endif + +!----------------------------------------------------------------------- + roota = 0. + jrt = 1 + DO j = 1, nl_soil + roota = roota + rootfr(j) + IF(roota>0.9)THEN + jrt = j + EXIT + ENDIF + ENDDO + +! Adjust leaf area index for seasonal variation + + f = max(0.0,1.-0.0016*max(298.-t(jrt),0.0)**2) + lai = xla(ivt) + (xla0(ivt)-xla(ivt))*(1.-f) + +! Sum leaf area index and stem area index + sai = sai0(ivt) + +! Fractional vegetation cover + fveg = vegc(ivt) + + green = 0.0 + IF(fveg > 0.) green = 1.0 + + END SUBROUTINE LAI_empirical + +END MODULE MOD_LAIEmpirical diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 new file mode 100644 index 0000000000..26703c90c0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 @@ -0,0 +1,219 @@ +#include + +MODULE MOD_LAIReadin + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LAI_readin + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE LAI_readin (year, time, dir_landdata) +!======================================================================= +! Read in the LAI, the LAI dataset was created by Yuan et al. (2011) +! http://globalchange.bnu.edu.cn +! +! Created by Yongjiu Dai, March, 2014 +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_UserDefFun + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + + USE MOD_Vars_Global + USE MOD_Const_LC +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeVariables +#endif +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: year, time + character(len=256), intent(in) :: dir_landdata + + ! Local variables + integer :: iyear, itime + character(len=256) :: cyear, ctime + character(len=256) :: landdir, lndname + integer :: m, npatch, pc + +#ifdef LULC_USGS + real(r8), dimension(24), parameter :: & ! Maximum fractional cover of vegetation [-] + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, & + 1.0, 1.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0 /) +#endif + + ! READ in Leaf area index and stem area index + + landdir = trim(dir_landdata) // '/LAI' + +#ifdef SinglePoint +#ifndef URBAN_MODEL + IF (USE_SITE_LAI) THEN + iyear = minloc(abs(SITE_LAI_year-year), dim=1) + ELSE + iyear = findloc_ud(SITE_LAI_year == min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year))) + ENDIF + + IF (.not. DEF_LAI_MONTHLY) THEN + itime = (time-1)/8 + 1 + ENDIF +#endif +#endif + +#if (defined LULC_USGS || defined LULC_IGBP) + +#ifdef SinglePoint +#ifndef URBAN_MODEL + IF (DEF_LAI_MONTHLY) THEN + tlai(:) = SITE_LAI_monthly(time,iyear) + tsai(:) = SITE_SAI_monthly(time,iyear) + ELSE + tlai(:) = SITE_LAI_8day(itime,iyear) + ENDIF +#endif +#else + IF (DEF_LAI_MONTHLY) THEN + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + write(ctime,'(i2.2)') time + + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) + + lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai) + ELSE + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + write(ctime,'(i3.3)') time + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) + ENDIF +#endif + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + DO npatch = 1, numpatch + m = patchclass(npatch) +#ifdef URBAN_MODEL + IF(m == URBAN) CYCLE +#endif + IF(m == 0 .or. m == WATERBODY)THEN + fveg(npatch) = 0. + tlai(npatch) = 0. + tsai(npatch) = 0. + green(npatch) = 0. + ELSE + fveg(npatch) = fveg0(m) !fraction of veg. cover + IF (fveg0(m) > 0) THEN + tlai(npatch) = tlai(npatch)/fveg0(m) !leaf area index + IF (DEF_LAI_MONTHLY) THEN + tsai(npatch) = tsai(npatch)/fveg0(m) !stem are index + ELSE + tsai(npatch) = sai0(m) !stem are index + ENDIF + green(npatch) = 1. !fraction of green leaf + ELSE + tlai(npatch) = 0. + tsai(npatch) = 0. + green(npatch) = 0. + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +#ifdef SinglePoint + +#ifndef URBAN_MODEL + IF (.not. DEF_USE_LAIFEEDBACK)THEN + IF (patchtypes(SITE_landtype) == 0) THEN + tlai_p(:) = pack(SITE_LAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) + tsai_p(:) = pack(SITE_SAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) + tlai(:) = sum (SITE_LAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) + tsai(:) = sum (SITE_SAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) + ELSE + tlai(:) = SITE_LAI_monthly(time,iyear) + tsai(:) = SITE_SAI_monthly(time,iyear) + ENDIF + ELSE + IF (patchtypes(SITE_landtype) == 0) THEN + tsai_p(:) = pack(SITE_SAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) + tsai(:) = sum (SITE_SAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) + ELSE + tsai(:) = SITE_SAI_monthly(time,iyear) + ENDIF + ENDIF +#endif +#else + + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + write(ctime,'(i2.2)') time + IF (.not. DEF_USE_LAIFEEDBACK)THEN + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai ) + ENDIF + lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai ) + IF (.not. DEF_USE_LAIFEEDBACK)THEN + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_pfts'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_pfts', landpft, tlai_p ) + ENDIF + lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_pfts'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'SAI_pfts', landpft, tsai_p ) + +#endif + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + +#ifdef URBAN_MODEL + IF (m == URBAN) CYCLE +#endif + !TODO@yuan: may need to revise patch LAI/SAI + green(npatch) = 1. + fveg (npatch) = fveg0(m) + + IF (m == WATERBODY) THEN + fveg(npatch) = 0. + tlai(npatch) = 0. + tsai(npatch) = 0. + green(npatch) = 0. + ENDIF + + ENDDO + ENDIF + ENDIF + +#endif + + END SUBROUTINE LAI_readin + +END MODULE MOD_LAIReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 new file mode 100644 index 0000000000..98305452ad --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 @@ -0,0 +1,2186 @@ +#include + +MODULE MOD_Lake + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Simulating energy balance processes of land water body +! +! !REFERENCES: +! Dai et al, 2018, The lake scheme of the common land model and its performance evaluation. +! Chinese Science Bulletin, 63(28-29), 3002-3021, https://doi.org/10.1360/N972018-00609 +! +! Original author: Yongjiu Dai 04/2014/ +! +! !REVISIONS: +! Nan Wei, 01/2018: interaction btw prec and lake surface including phase change of prec and water body +! Nan Wei, 06/2018: update heat conductivity of water body and soil below and snow hydrology +! Hua Yuan, 01/2023: added snow layer absorption in melting calculation +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: newsnow_lake + PUBLIC :: laketem + PUBLIC :: snowwater_lake + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: roughness_lake + PRIVATE :: hConductivity_lake + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE newsnow_lake ( USE_Dynamic_Lake, & + ! "in" arguments + ! --------------- + maxsnl , nl_lake , deltim , dz_lake ,& + pg_rain , pg_snow , t_precip , bifall ,& + + ! "inout" arguments + ! ------------------ + t_lake , zi_soisno , z_soisno ,& + dz_soisno , t_soisno , wliq_soisno , wice_soisno ,& + fiold , snl , sag , scv ,& + snowdp , lake_icefrac ) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Add new snow nodes and interaction btw prec and lake surface including phase +! change of prec and water body +! +! Original author: Yongjiu Dai, 04/2014 +! +! !REVISIONS: +! Nan Wei, 01/2018: update interaction btw prec and lake surface +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, denh2o, cpliq, cpice, hfus + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + logical, intent(in) :: USE_Dynamic_Lake + + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_lake ! number of soil layers + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(inout) :: pg_rain ! liquid water onto ground [kg/(m2 s)] + real(r8), intent(inout) :: pg_snow ! ice onto ground [kg/(m2 s)] + real(r8), intent(in) :: t_precip ! snowfall/rainfall temperature [kelvin] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + real(r8), intent(inout) :: dz_lake(1:nl_lake) ! lake layer thickness (m) + real(r8), intent(inout) :: zi_soisno(maxsnl:0) ! interface level below a "z" level (m) + real(r8), intent(inout) :: z_soisno(maxsnl+1:0) ! snow layer depth (m) + real(r8), intent(inout) :: dz_soisno(maxsnl+1:0) ! snow layer thickness (m) + real(r8), intent(inout) :: t_soisno(maxsnl+1:0) ! snow layer temperature [K] + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:0) ! snow layer liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:0) ! snow layer ice lens (kg/m2) + real(r8), intent(inout) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water + integer, intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + real(r8), intent(inout) :: scv ! snow mass (kg/m2) + real(r8), intent(inout) :: snowdp ! snow depth (m) + real(r8), intent(inout) :: lake_icefrac(1:nl_lake) ! mass fraction of lake layer that is frozen + real(r8), intent(inout) :: t_lake(1:nl_lake) ! lake layer temperature (m) + +!-------------------------- Local Variables ---------------------------- + + integer lb + integer newnode ! signification when new snow node is set, (1=yes, 0=non) + real(r8) dz_snowf ! layer thickness rate change due to precipitation [m/s] + real(r8) a, b, c, d, e, f, g, h + real(r8) wice_lake(1:nl_lake), wliq_lake(1:nl_lake), tw + +!----------------------------------------------------------------------- + + newnode = 0 + dz_snowf = pg_snow/bifall + snowdp = snowdp + dz_snowf*deltim + scv = scv + pg_snow*deltim ! snow water equivalent (mm) + + + zi_soisno(0) = 0. + + IF (snl==0 .and. snowdp < 0.01) THEN ! no snow layer, energy exchange between prec and lake surface + + a = cpliq*pg_rain*deltim*(t_precip-tfrz) !cool down rainfall to tfrz + b = pg_rain*deltim*hfus !all rainfall frozen + c = cpice*denh2o*dz_lake(1)*lake_icefrac(1)*(tfrz-t_lake(1)) !warm up lake surface ice to tfrz + d = denh2o*dz_lake(1)*lake_icefrac(1)*hfus !all lake surface ice melt + e = cpice*pg_snow*deltim*(tfrz-t_precip) !warm up snowfall to tfrz + f = pg_snow*deltim*hfus !all snowfall melt + g = cpliq*denh2o*dz_lake(1)*(1-lake_icefrac(1))*(t_lake(1)-tfrz) !cool down lake surface water to tfrz + h = denh2o*dz_lake(1)*(1-lake_icefrac(1))*hfus !all lake surface water frozen + sag = 0.0 + + IF (lake_icefrac(1) > 0.999) THEN + ! all rainfall frozen, release heat to warm up frozen lake surface + IF (a+b<=c) THEN + tw=min(tfrz,t_precip) + t_lake(1)=(a+b+cpice*(pg_rain+pg_snow)*deltim*tw+cpice*denh2o*dz_lake(1)*t_lake(1)*lake_icefrac(1))/& + (cpice*denh2o*dz_lake(1)*lake_icefrac(1)+cpice*(pg_rain+pg_snow)*deltim) + scv = scv+pg_rain*deltim + snowdp = snowdp + pg_rain*deltim/bifall + pg_snow = pg_snow+pg_rain + pg_rain = 0.0 + ! prec tem at tfrz, partial rainfall frozen ->release heat -> warm up lake surface to tfrz (no latent heat) + ELSEIF (a<=c) THEN + t_lake(1)=tfrz + scv = scv + (c-a)/hfus + snowdp = snowdp + (c-a)/(hfus*bifall) + pg_snow = pg_snow + min(pg_rain,(c-a)/(hfus*deltim)) + pg_rain = max(0.0,pg_rain - (c-a)/(hfus*deltim)) + ! lake surface tem at tfrz, partial lake surface melt -> absorb heat -> cool down rainfall to tfrz (no latent heat) + ELSEIF (a<=c+d) THEN + t_lake(1)=tfrz + wice_lake(1) = denh2o*dz_lake(1) - (a-c)/hfus + wliq_lake(1) = (a-c)/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ! all lake surface melt, absorb heat to cool down rainfall + ELSE !(a>c+d) + t_lake(1)=(cpliq*pg_rain*deltim*t_precip+cpliq*denh2o*dz_lake(1)*tfrz-c-d)/& + (cpliq*denh2o*dz_lake(1)+cpliq*pg_rain*deltim) + lake_icefrac(1) = 0.0 + ENDIF + + IF (snowdp>=0.01) THEN !frozen rain may make new snow layer + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + sag = 0. ! snow age + + t_soisno (0) = t_lake(1) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + ENDIF + + ELSEIF (lake_icefrac(1) >= 0.001) THEN + IF (pg_rain > 0.0 .and. pg_snow > 0.0) THEN + t_lake(1)=tfrz + ELSEIF (pg_rain > 0.0) THEN + IF (a>=d) THEN + t_lake(1)=(cpliq*pg_rain*deltim*t_precip+cpliq*denh2o*dz_lake(1)*tfrz-d)/& + (cpliq*denh2o*dz_lake(1)+cpliq*pg_rain*deltim) + lake_icefrac(1) = 0.0 + ELSE + t_lake(1)=tfrz + wice_lake(1) = denh2o*dz_lake(1)*lake_icefrac(1) - a/hfus + wliq_lake(1) = denh2o*dz_lake(1)*(1-lake_icefrac(1)) + a/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ENDIF + ELSEIF (pg_snow > 0.0) THEN + IF (e>=h) THEN + t_lake(1)=(h+cpice*denh2o*dz_lake(1)*tfrz+cpice*pg_snow*deltim*t_precip)/& + (cpice*pg_snow*deltim+cpice*denh2o*dz_lake(1)) + lake_icefrac(1) = 1.0 + ELSE + t_lake(1)=tfrz + wice_lake(1) = denh2o*dz_lake(1)*lake_icefrac(1) + e/hfus + wliq_lake(1) = denh2o*dz_lake(1)*(1-lake_icefrac(1)) - e/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ENDIF + ENDIF + + ELSE + ! all snowfall melt, absorb heat to cool down lake surface water + IF (e+f<=g) THEN + tw=max(tfrz,t_precip) + t_lake(1)=(cpliq*denh2o*dz_lake(1)*t_lake(1)*(1-lake_icefrac(1))+cpliq*(pg_rain+pg_snow)*deltim*tw-e-f)/& + (cpliq*(pg_rain+pg_snow)*deltim+cpliq*denh2o*dz_lake(1)*(1-lake_icefrac(1))) + scv = scv - pg_snow*deltim + snowdp = snowdp - dz_snowf*deltim + pg_rain = pg_rain + pg_snow + pg_snow = 0.0 + ! prec tem at tfrz, partial snowfall melt ->absorb heat -> cool down lake surface to tfrz (no latent heat) + ELSEIF (e<=g) THEN + t_lake(1) = tfrz + scv = scv - (g-e)/hfus + snowdp = snowdp - (g-e)/(hfus*bifall) + pg_rain = pg_rain + min(pg_snow, (g-e)/(hfus*deltim)) + pg_snow = max(0.0, pg_snow - (g-e)/(hfus*deltim)) + ! lake surface tem at tfrz, partial lake surface frozen -> release heat -> warm up snowfall to tfrz (no latent heat) + ELSEIF (e<=g+h) THEN + t_lake(1) = tfrz + wice_lake(1) = (e-g)/hfus + wliq_lake(1) = denh2o*dz_lake(1) - (e-g)/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ! all lake surface frozen, release heat to warm up snowfall + ELSE !(e>g+h) + t_lake(1) = (g+h+cpice*denh2o*dz_lake(1)*tfrz+cpice*pg_snow*deltim*t_precip)/& + (cpice*pg_snow*deltim+cpice*denh2o*dz_lake(1)) + lake_icefrac(1) = 1.0 + ENDIF + ENDIF + + IF (USE_Dynamic_Lake .and. (snl == 0)) THEN + + wliq_lake(1) = dz_lake(1) * (1-lake_icefrac(1)) + pg_rain*deltim*1.e-3 + wice_lake(1) = dz_lake(1) * lake_icefrac(1) + dz_lake(1) = wliq_lake(1) + wice_lake(1) + lake_icefrac(1) = wice_lake(1) / dz_lake(1) + + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + + ENDIF + + ELSEIF (snl==0 .and. snowdp >= 0.01) THEN + + ! only ice part of snowfall is added here, the liquid part will be added later + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + sag = 0. ! snow age + + t_soisno (0) = min(tfrz, t_precip) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + + ELSE ! ( snl<0 .and. newnode ==0 ) + + lb = snl + 1 + t_soisno(lb) = ( (wice_soisno(lb)*cpice+wliq_soisno(lb)*cpliq)*t_soisno(lb) & + + (pg_rain*cpliq + pg_snow*cpice)*deltim*t_precip ) & + / ( wice_soisno(lb)*cpice + wliq_soisno(lb)*cpliq & + + pg_rain*deltim*cpliq + pg_snow*deltim*cpice ) + + t_soisno(lb) = min(tfrz, t_soisno(lb)) + wice_soisno(lb) = wice_soisno(lb)+deltim*pg_snow + dz_soisno(lb) = dz_soisno(lb)+dz_snowf*deltim + z_soisno(lb) = zi_soisno(lb) - 0.5*dz_soisno(lb) + zi_soisno(lb-1) = zi_soisno(lb) - dz_soisno(lb) + + ENDIF + + END SUBROUTINE newsnow_lake + + + + SUBROUTINE laketem (& + ! "in" arguments + ! ------------------- + patchtype , maxsnl , nl_soil , nl_lake ,& + dlat , deltim , forc_hgt_u , forc_hgt_t,& + forc_hgt_q , forc_us , forc_vs , forc_t ,& + forc_q , forc_rhoair , forc_psrf , forc_sols ,& + forc_soll , forc_solsd , forc_solld , sabg ,& + forc_frl , dz_soisno , z_soisno , zi_soisno ,& + dz_lake , lakedepth , vf_quartz , vf_gravels,& + vf_om , vf_sand , wf_gravels , wf_sand ,& + porsl , csol , k_solids , & + dksatu , dksatf , dkdry , & + BA_alpha , BA_beta , hpbl , & + + ! "inout" arguments + ! ------------------- + t_grnd , scv , snowdp , t_soisno ,& + wliq_soisno , wice_soisno , imelt_soisno , t_lake ,& + lake_icefrac , savedtke1 , & + +! SNICAR model variables + snofrz ,sabg_snow_lyr, & +! END SNICAR model variables + + ! "out" arguments + ! ------------------- + taux , tauy , fsena ,& + fevpa , lfevpa , fseng , fevpg ,& + qseva , qsubl , qsdew , qfros ,& + olrg , fgrnd , tref , qref ,& + trad , emis , z0m , zol ,& + rib , ustar , qstar , tstar ,& + fm , fh , fq , sm ,& + urban_call) + +! ------------------------ code history --------------------------- +! purpose: lake temperature and snow on frozen lake +! initial Yongjiu Dai, 2000 +! Zack Subin, 2009 +! Yongjiu Dai, /12/2012/, /04/2014/, 06/2018 +! Nan Wei, /06/2018/ +! +! ------------------------ notes ---------------------------------- +! Lakes have variable depth, possible snow layers above, freezing & +! thawing of lake water, and soil layers with active temperature and +! gas diffusion below. +! +! Calculates temperatures in the 25-30 layer column of (possible) snow, +! lake water, soil, and bedrock beneath lake. Snow and soil +! temperatures are determined as in SoilTemperature, except for +! appropriate boundary conditions at the top of the snow (the flux is +! fixed to be the ground heat flux), the bottom of the snow (adjacent +! to top lake layer), and the top of the soil (adjacent to the bottom +! lake layer). Also, the soil is kept fully saturated. The whole +! column is solved simultaneously as one tridiagonal matrix. +! +! calculate lake temperatures from one-dimensional thermal +! stratification model based on eddy diffusion concepts to represent +! vertical mixing of heat +! +! d ts d d ts 1 ds +! ---- = -- [(km + ke) ----] + -- -- +! dt dz dz cw dz +! where: ts = temperature (kelvin) +! t = time (s) +! z = depth (m) +! km = molecular diffusion coefficient (m**2/s) +! ke = eddy diffusion coefficient (m**2/s) +! cw = heat capacity (j/m**3/kelvin) +! s = heat source term (w/m**2) +! +! use crank-nicholson method to set up tridiagonal system of equations to +! solve for ts at time n+1, where the temperature equation for layer i is +! r_i = a_i [ts_i-1] n+1 + b_i [ts_i] n+1 + c_i [ts_i+1] n+1 +! the solution conserves energy as +! cw*([ts( 1)] n+1 - [ts( 1)] n)*dz( 1)/dt + ... + +! cw*([ts(nl_lake)] n+1 - [ts(nl_lake)] n)*dz(nl_lake)/dt = fin +! where +! [ts] n = old temperature (kelvin) +! [ts] n+1 = new temperature (kelvin) +! fin = heat flux into lake (w/m**2) +! = beta*sabg_snow_lyr(1)+forc_frl-olrg-fsena-lfevpa-hm + phi(1) + ... + phi(nl_lake) +! +! !REVISIONS: +! Yongjiu Dai and Hua Yuan, 01/2023: added SNICAR for layer solar absorption, ground heat +! flux, temperature and freezing mass calculations +! Shaofeng Liu, 05/2023: add option to call moninobuk_leddy, the LargeEddy +! surface turbulence scheme (LZD2022); +! make a proper update of um. +! +! ----------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz,hvap,hfus,hsub,tkwat,tkice,tkair,stefnc,& + vonkar,grav,cpliq,cpice,cpair,denh2o,denice,rgas + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_SNICAR + USE MOD_TurbulenceLEddy + USE MOD_Qsadv + USE MOD_SoilThermalParameters + USE MOD_Utils + + IMPLICIT NONE +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: patchtype ! land patch type (4=deep lake, 5=shallow lake) + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_soil ! number of soil layers + integer, intent(in) :: nl_lake ! number of lake layers + + real(r8), intent(in) :: dlat ! latitude (radians) + real(r8), intent(in) :: deltim ! seconds in a time step (s) + real(r8), intent(in) :: forc_hgt_u ! observational height of wind [m] + real(r8), intent(in) :: forc_hgt_t ! observational height of temperature [m] + real(r8), intent(in) :: forc_hgt_q ! observational height of humidity [m] + real(r8), intent(in) :: forc_us ! wind component in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind component in northward direction [m/s] + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: forc_rhoair ! density air [kg/m3] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + real(r8), intent(in) :: forc_sols ! atm vis direct beam solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_soll ! atm nir direct beam solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_solsd ! atm vis diffuse solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_frl ! atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: sabg ! solar radiation absorbed by ground [W/m2] + + real(r8), intent(in) :: dz_soisno(maxsnl+1:nl_soil) ! soil/snow layer thickness (m) + real(r8), intent(in) :: z_soisno(maxsnl+1:nl_soil) ! soil/snow node depth [m] + real(r8), intent(in) :: zi_soisno(maxsnl:nl_soil) ! soil/snow depth of layer interface [m] + + real(r8), intent(in) :: dz_lake(nl_lake) ! lake layer thickness (m) + real(r8), intent(in) :: lakedepth ! column lake depth (m) + + real(r8), intent(in) :: vf_quartz (1:nl_soil) ! volumetric fraction of quartz within mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) ! volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) ! volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) ! volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) ! gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) ! gravimetric fraction of sand + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] + + real(r8), intent(in) :: csol(1:nl_soil) ! heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids(1:nl_soil) ! thermal conductivity of mineralssoil [W/m-K] + real(r8), intent(in) :: dksatu(1:nl_soil) ! thermal conductivity of saturated unfrozen soil [W/m-K] + real(r8), intent(in) :: dksatf(1:nl_soil) ! thermal conductivity of saturated frozen soil [W/m-K] + real(r8), intent(in) :: dkdry(1:nl_soil) ! thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: BA_alpha(1:nl_soil) ! alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta(1:nl_soil) ! beta in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(inout) :: t_grnd ! surface temperature (kelvin) + real(r8), intent(inout) :: scv ! snow water equivalent [mm] + real(r8), intent(inout) :: snowdp ! snow depth [mm] + + real(r8), intent(inout) :: t_soisno (maxsnl+1:nl_soil) ! soil/snow temperature [K] + real(r8), intent(inout) :: wliq_soisno (maxsnl+1:nl_soil) ! soil/snow liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno (maxsnl+1:nl_soil) ! soil/snow ice lens (kg/m2) + integer, intent(inout) :: imelt_soisno(maxsnl+1:nl_soil) ! soil/snow flag for melting (=1), freezing (=2), Not=0 (new) + + real(r8), intent(inout) :: t_lake(nl_lake) ! lake temperature (kelvin) + real(r8), intent(inout) :: lake_icefrac(nl_lake) ! lake mass fraction of lake layer that is frozen + real(r8), intent(inout) :: savedtke1 ! top level eddy conductivity (W/m K) + +! SNICAR model variables + real(r8), intent(out) :: snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8), intent(in) :: sabg_snow_lyr(maxsnl+1:1) ! solar radiation absorbed by ground [W/m2] +! END SNICAR model variables + + real(r8), intent(out) :: taux ! wind stress: E-W [kg/m/s**2] + real(r8), intent(out) :: tauy ! wind stress: N-S [kg/m/s**2] + real(r8), intent(out) :: fsena ! sensible heat from canopy height to atmosphere [W/m2] + real(r8), intent(out) :: fevpa ! evapotranspiration from canopy height to atmosphere [mm/s] + real(r8), intent(out) :: lfevpa ! latent heat flux from canopy height to atmosphere [W/m2] + + real(r8), intent(out) :: fseng ! sensible heat flux from ground [W/m2] + real(r8), intent(out) :: fevpg ! evaporation heat flux from ground [mm/s] + + real(r8), intent(out) :: qseva ! ground surface evaporation rate (mm h2o/s) + real(r8), intent(out) :: qsubl ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), intent(out) :: qsdew ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), intent(out) :: qfros ! ground surface frosting formation (mm H2O /s) [+] + + real(r8), intent(out) :: olrg ! outgoing long-wave radiation from ground+canopy + real(r8), intent(out) :: fgrnd ! ground heat flux [W/m2] + + real(r8), intent(out) :: tref ! 2 m height air temperature [kelvin] + real(r8), intent(out) :: qref ! 2 m height air specific humidity + real(r8), intent(out) :: trad ! radiative temperature [K] + + real(r8), intent(out) :: emis ! averaged bulk surface emissivity + real(r8), intent(out) :: z0m ! effective roughness [m] + real(r8), intent(out) :: zol ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), intent(out) :: rib ! bulk Richardson number in surface layer + real(r8), intent(out) :: ustar ! u* in similarity theory [m/s] + real(r8), intent(out) :: qstar ! q* in similarity theory [kg/kg] + real(r8), intent(out) :: tstar ! t* in similarity theory [K] + real(r8), intent(out) :: fm ! integral of profile function for momentum + real(r8), intent(out) :: fh ! integral of profile function for heat + real(r8), intent(out) :: fq ! integral of profile function for moisture + real(r8), intent(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] + logical, optional, intent(in) :: urban_call ! whether it is a urban CALL + +!-------------------------- Local Variables ---------------------------- +! ---------------- local variables in surface temp and fluxes calculation ----------------- + integer idlak ! index of lake, 1 = deep lake, 2 = shallow lake + real(r8) z_lake (nl_lake) ! lake node depth (middle point of layer) (m) + + real(r8) ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) + real(r8) bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) + real(r8) beta1 ! coefficient of conective velocity [-] + real(r8) degdT ! d(eg)/dT + real(r8) displax ! zero- displacement height [m] + real(r8) dqh ! diff of humidity between ref. height and surface + real(r8) dth ! diff of virtual temp. between ref. height and surface + real(r8) dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8) dzsur ! 1/2 the top layer thickness (m) + real(r8) tsur ! top layer temperature + real(r8) rhosnow ! partial density of water (ice + liquid) + real(r8) eg ! water vapor pressure at temperature T [pa] + real(r8) emg ! ground emissivity (0.97 for snow, + real(r8) errore ! lake temperature energy conservation error (w/m**2) + real(r8) hm ! energy residual [W/m2] + real(r8) htvp ! latent heat of vapor of water (or sublimation) [j/kg] + real(r8) obu ! monin-obukhov length (m) + real(r8) obuold ! monin-obukhov length of previous iteration + real(r8) qsatg ! saturated humidity [kg/kg] + real(r8) qsatgdT ! d(qsatg)/dT + + real(r8) ram ! aerodynamical resistance [s/m] + real(r8) rah ! thermal resistance [s/m] + real(r8) raw ! moisture resistance [s/m] + real(r8) stftg3 ! emg*sb*t_grnd*t_grnd*t_grnd + real(r8) fh2m ! relation for temperature at 2m + real(r8) fq2m ! relation for specific humidity at 2m + real(r8) fm10m ! integral of profile function for momentum at 10m + real(r8) t_grnd_bef0 ! initial ground temperature + real(r8) t_grnd_bef ! initial ground temperature + real(r8) thm ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(r8) th ! potential temperature (kelvin) + real(r8) thv ! virtual potential temperature (kelvin) + real(r8) thvstar ! virtual potential temperature scaling parameter + real(r8) tksur ! thermal conductivity of snow/soil (w/m/kelvin) + real(r8) um ! wind speed including the stability effect [m/s] + real(r8) ur ! wind speed at reference height [m/s] + real(r8) visa ! kinematic viscosity of dry air [m2/s] + real(r8) wc ! convective velocity [m/s] + real(r8) wc2 ! wc*wc + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zii ! convective boundary height [m] + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) z0mg ! roughness length over ground, momentum [m] + real(r8) z0hg ! roughness length over ground, sensible heat [m] + real(r8) z0qg ! roughness length over ground, latent heat [m] + + real(r8) wliq_lake(nl_lake) ! lake liquid water (kg/m2) + real(r8) wice_lake(nl_lake) ! lake ice lens (kg/m2) + real(r8) vf_water(1:nl_soil) ! volumetric fraction liquid water within underlying soil + real(r8) vf_ice(1:nl_soil) ! volumetric fraction ice lens within underlying soil + + real(r8) fgrnd1 ! ground heat flux into the first snow/lake layer [W/m2] + +! ---------------- local variables in lake/snow/soil temperature calculation -------------- + real(r8), parameter :: cur0 = 0.01 ! min. Charnock parameter + real(r8), parameter :: curm = 0.1 ! maximum Charnock parameter + real(r8), parameter :: fcrit = 22. ! critical dimensionless fetch for Charnock parameter (Vickers & Mahrt 1997) + ! but converted to USE u instead of u* (Subin et al. 2011) + real(r8), parameter :: mixfact = 5. ! Mixing enhancement factor. + real(r8), parameter :: depthcrit = 25. ! (m) Depth beneath which to enhance mixing + real(r8), parameter :: fangmult = 5. ! Multiplier for unfrozen diffusivity + real(r8), parameter :: minmultdepth = 20. ! (m) Minimum depth for imposing fangmult + real(r8), parameter :: cnfac = 0.5 ! Crank Nicholson factor between 0 and 1 + + !-------------------- + real(r8) fetch ! lake fetch (m) + real(r8) cur ! Charnock parameter (-) + real(r8) betavis ! + real(r8) betaprime ! Effective beta + real(r8) tdmax ! temperature of maximum water density + real(r8) cfus ! effective heat of fusion per unit volume + real(r8) tkice_eff ! effective conductivity since layer depth is constant + real(r8) cice_eff ! effective heat capacity of ice (using density of + ! water because layer depth is not adjusted when freezing + real(r8) cwat ! specific heat capacity of water (j/m**3/kelvin) + + !-------------------- + real(r8) rhow(nl_lake) ! density of water (kg/m**3) + real(r8) fin ! heat flux into lake - flux out of lake (w/m**2) + real(r8) phi(nl_lake) ! solar radiation absorbed by layer (w/m**2) + real(r8) phi_soil ! solar radiation into top soil layer (W/m^2) + real(r8) phidum ! temporary value of phi + + integer imelt_lake(1:nl_lake) ! lake flag for melting or freezing snow and soil layer [-] + real(r8) cv_lake(1:nl_lake) ! heat capacity [J/(m2 K)] + real(r8) tk_lake(1:nl_lake) ! thermal conductivity at layer node [W/(m K)] + real(r8) cv_soisno(maxsnl+1:nl_soil) ! heat capacity of soil/snow [J/(m2 K)] + real(r8) tk_soisno(maxsnl+1:nl_soil) ! thermal conductivity of soil/snow [W/(m K)] (at interface below, except for j=0) + real(r8) hcap(1:nl_soil) ! J/(m3 K) + real(r8) thk(maxsnl+1:nl_soil) ! W/(m K) + real(r8) tktopsoil ! thermal conductivity of the top soil layer [W/(m K)] + + real(r8) t_soisno_bef(maxsnl+1:nl_soil) ! beginning soil/snow temp for E cons. check [K] + real(r8) t_lake_bef(1:nl_lake) ! beginning lake temp for energy conservation check [K] + real(r8) wice_soisno_bef(maxsnl+1:0) ! ice lens [kg/m2] + + real(r8) cvx (maxsnl+1:nl_lake+nl_soil) ! heat capacity for whole column [J/(m2 K)] + real(r8) tkix (maxsnl+1:nl_lake+nl_soil) ! thermal conductivity at layer interfaces for whole column [W/(m K)] + real(r8) phix (maxsnl+1:nl_lake+nl_soil) ! solar source term for whole column [W/m**2] + real(r8) zx (maxsnl+1:nl_lake+nl_soil) ! interface depth (+ below surface) for whole column [m] + real(r8) tx (maxsnl+1:nl_lake+nl_soil) ! temperature of whole column [K] + real(r8) tx_bef (maxsnl+1:nl_lake+nl_soil) ! beginning lake/snow/soil temp for energy conservation check [K] + real(r8) factx (maxsnl+1:nl_lake+nl_soil) ! coefficient used in computing tridiagonal matrix + real(r8) fnx (maxsnl+1:nl_lake+nl_soil) ! heat diffusion through the layer interface below [W/m2] + real(r8) a (maxsnl+1:nl_lake+nl_soil) ! "a" vector for tridiagonal matrix + real(r8) b (maxsnl+1:nl_lake+nl_soil) ! "b" vector for tridiagonal matrix + real(r8) c (maxsnl+1:nl_lake+nl_soil) ! "c" vector for tridiagonal matrix + real(r8) r (maxsnl+1:nl_lake+nl_soil) ! "r" vector for tridiagonal solution + real(r8) fn1 (maxsnl+1:nl_lake+nl_soil) ! heat diffusion through the layer interface below [W/m2] + real(r8) brr (maxsnl+1:nl_lake+nl_soil) ! + integer imelt_x(maxsnl+1:nl_lake+nl_soil) ! flag for melting (=1), freezing (=2), Not=0 (new) + + real(r8) dzm ! used in computing tridiagonal matrix [m] + real(r8) dzp ! used in computing tridiagonal matrix [m] + real(r8) zin ! depth at top of layer (m) + real(r8) zout ! depth at bottom of layer (m) + real(r8) rsfin ! relative flux of solar radiation into layer + real(r8) rsfout ! relative flux of solar radiation out of layer + real(r8) eta ! light extinction coefficient (/m): depends on lake type + real(r8) za(2) ! base of surface absorption layer (m): depends on lake type + !-------------------- + + real(r8) hs ! net ground heat flux into the surface + real(r8) dhsdT ! temperature derivative of "hs" + real(r8) heatavail ! available energy for melting or freezing (J/m^2) + real(r8) heatrem ! energy residual or loss after melting or freezing + real(r8) melt ! actual melting (+) or freezing (-) [kg/m2] + real(r8) xmf ! total per-column latent heat abs. from phase change (J/m^2) + !-------------------- + + real(r8) ocvts ! (cwat*(t_lake[n ])*dz_lake + real(r8) ncvts ! (cwat*(t_lake[n+1])*dz_lake + real(r8) esum1 ! temp for checking energy (J/m^2) + real(r8) esum2 ! "" + real(r8) zsum ! temp for putting ice at the top during convection (m) + real(r8) errsoi ! soil/lake energy conservation error (W/m^2) + + real(r8) iceav ! used in calc aver ice for convectively mixed layers + real(r8) qav ! used in calc aver heat content for conv. mixed layers + real(r8) tav ! used in aver temp for convectively mixed layers + real(r8) tav_froz ! used in aver temp for convectively mixed layers (C) + real(r8) tav_unfr ! " + real(r8) nav ! used in aver temp for convectively mixed layers + + real(r8) fevpg_lim ! temporary evap_soi limited by top snow layer content [mm/s] + real(r8) scv_temp ! temporary h2osno [kg/m^2] + real(r8) tmp ! + real(r8) h_fin ! + real(r8) h_finDT ! + real(r8) del_T_grnd! + !real(r8) savedtke1 + + integer iter ! iteration index + integer convernum ! number of time when del_T_grnd < 0.01 + integer nmozsgn ! number of times moz changes sign + +! assign iteration parameters + integer, parameter :: itmax = 40 ! maximum number of iteration + integer, parameter :: itmin = 6 ! minimum number of iteration + real(r8),parameter :: delmax = 3.0 ! maximum change in lake temperature [K] + real(r8),parameter :: dtmin = 0.01 ! max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 ! max limit for energy flux convergence [w/m2] + + !-------------------- + + integer nl_sls ! abs(snl)+nl_lake+nl_soil + integer snl ! number of snow layers (minimum -5) + integer lb ! lower bound of arrays + integer jprime ! j - nl_lake + + integer i,j ! do loop or array index + +! ====================================================================== +!*[1] constants and model parameters +! ====================================================================== + + +! constants for lake temperature model + za = (/0.5, 0.6/) + cwat = cpliq*denh2o ! water heat capacity per unit volume + cice_eff = cpice*denh2o ! use water density because layer depth is not adjusted for freezing + cfus = hfus*denh2o ! latent heat per unit volume + tkice_eff = tkice * denice/denh2o ! effective conductivity since layer depth is constant + emg = 0.97 ! surface emissivity + +! define snow layer on ice lake + snl = 0 + DO j=maxsnl+1,0 + IF(wliq_soisno(j)+wice_soisno(j)>0.) snl=snl-1 + ENDDO + lb = snl + 1 + +! latent heat + IF (t_grnd > tfrz )THEN + htvp = hvap + ELSE + htvp = hsub + ENDIF + +! define levels + z_lake(1) = dz_lake(1) / 2. + DO j = 2, nl_lake + z_lake(j) = z_lake(j-1) + (dz_lake(j-1) + dz_lake(j))/2. + ENDDO + +! Base on lake depth, assuming that small lakes are likely to be shallower +! Estimate crudely based on lake depth + IF (z_lake(nl_lake) < 4.) THEN + idlak = 1 + fetch = 100. ! shallow lake + ELSE + idlak = 2 + fetch = 25.*z_lake(nl_lake) ! deep lake + ENDIF + + +! ====================================================================== +!*[2] pre-processing for the calculation of the surface temperature and fluxes +! ====================================================================== + + IF (.not. DEF_USE_SNICAR .or. present(urban_call)) THEN + IF (snl == 0) THEN + ! calculate the nir fraction of absorbed solar. + betaprime = (forc_soll+forc_solld)/max(1.e-5,forc_sols+forc_soll+forc_solsd+forc_solld) + betavis = 0. ! The fraction of the visible (e.g. vis not nir from atm) sunlight + ! absorbed in ~1 m of water (the surface layer za_lake). + ! This is roughly the fraction over 700 nm but may depend on the details + ! of atmospheric radiative transfer. + ! As long as NIR = 700 nm and up, this can be zero. + betaprime = betaprime + (1.0-betaprime)*betavis + ELSE + ! or frozen but no snow layers or + ! currently ignore the transmission of solar in snow and ice layers + ! to be updated in the future version + betaprime = 1.0 + ENDIF + + ELSE + ! calculate the nir fraction of absorbed solar. + betaprime = (forc_soll+forc_solld)/max(1.e-5,forc_sols+forc_soll+forc_solsd+forc_solld) + betavis = 0. ! The fraction of the visible (e.g. vis not nir from atm) sunlight + ! absorbed in ~1 m of water (the surface layer za_lake). + ! This is roughly the fraction over 700 nm but may depend on the details + ! of atmospheric radiative transfer. + ! As long as NIR = 700 nm and up, this can be zero. + betaprime = betaprime + (1.0-betaprime)*betavis + ENDIF + + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) +! potential temperature at the reference height + beta1=1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + thm = forc_t + 0.0098*forc_hgt_t ! intermediate variable equivalent to + ! forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) ! potential T + thv = th*(1.+0.61*forc_q) ! virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) ! limit set to 0.1 + +! Initialization variables + nmozsgn = 0 + obuold = 0. + dth = thm-t_grnd + dqh = forc_q-qsatg + dthv = dth*(1.+0.61*forc_q)+0.61*th*dqh + zldis = forc_hgt_u-0. + +! Roughness lengths, allow all roughness lengths to be prognostic + ustar=0.06 + wc=0.5 + + ! Kinematic viscosity of dry air (m2/s)- Andreas (1989) CRREL Rep. 89-11 + visa=1.326e-5*(1.+6.542e-3*(forc_t-tfrz) & + + 8.301e-6*(forc_t-tfrz)**2 - 4.84e-9*(forc_t-tfrz)**3) + + cur = cur0 + curm * exp( max( -(fetch*grav/ur/ur)**(1./3.)/fcrit, & ! Fetch-limited + -(z_lake(nl_lake)*grav)**0.5/ur ) ) ! depth-limited + + IF(dthv.ge.0.) THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF + + DO i=1,5 + z0mg=0.013*ustar*ustar/grav+0.11*visa/ustar + ustar=vonkar*um/log(zldis/z0mg) + ENDDO + + CALL roughness_lake (snl,t_grnd,t_lake(1),lake_icefrac(1),forc_psrf,& + cur,ustar,z0mg,z0hg,z0qg) + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + + IF (snl == 0) THEN + dzsur = dz_lake(1)/2. + ELSE + dzsur = z_soisno(lb)-zi_soisno(lb-1) + ENDIF + + + iter = 1 + del_T_grnd = 1.0 ! t_grnd diff + convernum = 0 ! number of time when del_T_grnd <= 0.01 + + +! ====================================================================== +!*[3] Begin stability iteration and temperature and fluxes calculation +! ====================================================================== + + + ! ===================================== + ITERATION : DO WHILE (iter <= itmax) + ! ===================================== + + t_grnd_bef = t_grnd + + IF (t_grnd_bef > tfrz .and. t_lake(1) > tfrz .and. snl == 0) THEN + tksur = savedtke1 !water molecular conductivity + tsur = t_lake(1) + htvp = hvap + ELSEIF (snl == 0) THEN !frozen but no snow layers + tksur = tkice ! This is an approximation because the whole layer may not be frozen, and it is not + ! accounting for the physical (but not nominal) expansion of the frozen layer. + tsur = t_lake(1) + htvp = hsub + ELSE + ! need to calculate thermal conductivity of the top snow layer + rhosnow = (wice_soisno(lb)+wliq_soisno(lb))/dz_soisno(lb) + tksur = tkair + (7.75e-5*rhosnow + 1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + tsur = t_soisno(lb) + htvp = hsub + ENDIF + +! Evaluated stability-dependent variables using moz from prior iteration + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(forc_hgt_u,forc_hgt_t,forc_hgt_q,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(forc_hgt_u,forc_hgt_t,forc_hgt_q,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + stftg3 = emg*stefnc*t_grnd_bef*t_grnd_bef*t_grnd_bef + + ax = betaprime*sabg + emg*forc_frl + 3.*stftg3*t_grnd_bef & + + forc_rhoair*cpair/rah*thm & + - htvp*forc_rhoair/raw*(qsatg-qsatgdT*t_grnd_bef - forc_q) & + + tksur*tsur/dzsur + + bx = 4.*stftg3 + forc_rhoair*cpair/rah & + + htvp*forc_rhoair/raw*qsatgdT + tksur/dzsur + + t_grnd = ax/bx + + !----------------------------------------------------------------- + ! h_fin = betaprime*sabg + emg*forc_frl + 3.*stftg3*t_grnd_bef & ! + ! + forc_rhoair*cpair/rah*thm & ! + ! - htvp*forc_rhoair/raw*(qsatg-qsatgdT*t_grnd_bef - forc_q) ! + ! h_finDT = 4.*stftg3 + forc_rhoair*cpair/rah & ! + ! + htvp*forc_rhoair/raw*qsatgdT ! + ! del_T_grnd = t_grnd - t_grnd_bef ! + !----------------------------------------------------------------! + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + + fseng = forc_rhoair*cpair*(t_grnd-thm)/rah + fevpg = forc_rhoair*(qsatg+qsatgdT*(t_grnd-t_grnd_bef)-forc_q)/raw + + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + dth = thm-t_grnd + dqh = forc_q-qsatg + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + thvstar = tstar*(1.+0.61*forc_q)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + IF(zeta >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*forc_hgt_u,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta1*beta1*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + CALL roughness_lake (snl,t_grnd,t_lake(1),lake_icefrac(1),forc_psrf,& + cur,ustar,z0mg,z0hg,z0qg) + + iter = iter + 1 + del_T_grnd = abs(t_grnd - t_grnd_bef) + + IF(iter .gt. itmin) THEN + IF(del_T_grnd <= dtmin) THEN + convernum = convernum + 1 + ENDIF + IF(convernum >= 4) EXIT + ENDIF + + ! =============================================== + ENDDO ITERATION ! end of stability iteration + ! =============================================== + +!*---------------------------------------------------------------------- +!*Zack Subin, 3/27/09 +!*Since they are now a function of whatever t_grnd was before cooling +!*to freezing temperature, then this value should be used in the derivative correction term. +!*Allow convection if ground temp is colder than lake but warmer than 4C, or warmer than +!*lake which is warmer than freezing but less than 4C. + tdmax = tfrz + 4.0 + IF ( (snl < 0 .or. t_lake(1) <= tfrz) .and. t_grnd > tfrz) THEN + t_grnd_bef = t_grnd + t_grnd = tfrz + fseng = forc_rhoair*cpair*(t_grnd-thm)/rah + fevpg = forc_rhoair*(qsatg+qsatgdT*(t_grnd-t_grnd_bef)-forc_q)/raw + ELSEIF ( (t_lake(1) > t_grnd .and. t_grnd > tdmax) .or. & + (t_lake(1) < t_grnd .and. t_lake(1) > tfrz .and. t_grnd < tdmax) ) THEN + ! Convective mixing will occur at surface + t_grnd_bef = t_grnd + t_grnd = t_lake(1) + fseng = forc_rhoair*cpair*(t_grnd-thm)/rah + fevpg = forc_rhoair*(qsatg+qsatgdT*(t_grnd-t_grnd_bef)-forc_q)/raw + ENDIF +!*---------------------------------------------------------------------- + +! net longwave from ground to atmosphere + stftg3 = emg*stefnc*t_grnd_bef*t_grnd_bef*t_grnd_bef + olrg = (1.-emg)*forc_frl + emg*stefnc*t_grnd_bef**4 + 4.*stftg3*(t_grnd - t_grnd_bef) + IF (t_grnd > tfrz )THEN + htvp = hvap + ELSE + htvp = hsub + ENDIF + +!The actual heat flux from the ground interface into the lake, not including the light that penetrates the surface. + fgrnd1 = betaprime*sabg + forc_frl - olrg - fseng - htvp*fevpg + + ! January 12, 2023 by Yongjiu Dai + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + hs = sabg_snow_lyr(lb) + forc_frl - olrg - fseng - htvp*fevpg + dhsdT = 0.0 + ENDIF + +!------------------------------------------------------------ +! Set up vector r and vectors a, b, c that define tridiagonal matrix +! snow and lake and soil layer temperature +!------------------------------------------------------------ + +!------------------------------------------------------------ +! Lake density +!------------------------------------------------------------ + + DO j = 1, nl_lake + rhow(j) = (1.-lake_icefrac(j))*denh2o*(1.0-1.9549e-05*(abs(t_lake(j)-277.))**1.68) & + + lake_icefrac(j)*denice + ! allow for ice fraction; assume constant ice density. + ! this is not the correct average-weighting but that's OK because the density will only + ! be used for convection for lakes with ice, and the ice fraction will dominate the + ! density differences between layers. + ! using this average will make sure that surface ice is treated properly during + ! convective mixing. + ENDDO + +!------------------------------------------------------------ +! Diffusivity and implied thermal "conductivity" = diffusivity * cwat +!------------------------------------------------------------ + + DO j = 1, nl_lake + cv_lake(j) = dz_lake(j) * (cwat*(1.-lake_icefrac(j)) + cice_eff*lake_icefrac(j)) + ENDDO + + CALL hConductivity_lake(nl_lake,snl,t_grnd,& + z_lake,t_lake,lake_icefrac,rhow,& + dlat,ustar,z0mg,lakedepth,depthcrit,tk_lake,savedtke1) + +!------------------------------------------------------------ +! Set the thermal properties of the snow above frozen lake and underlying soil +! and check initial energy content. +!------------------------------------------------------------ + + lb = snl+1 + DO i = 1, nl_soil + vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) + vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv_soisno(i) = hcap(i)*dz_soisno(i) + ENDDO + +! Snow heat capacity and conductivity + IF(lb <=0 )THEN + DO j = lb, 0 + cv_soisno(j) = cpliq*wliq_soisno(j) + cpice*wice_soisno(j) + rhosnow = (wice_soisno(j)+wliq_soisno(j))/dz_soisno(j) + thk(j) = tkair + (7.75e-5*rhosnow + 1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + +! modified by Nan Wei, 08/25/2014 + IF (i /= 0) THEN + tk_soisno(i) = thk(i)*thk(i+1)*(z_soisno(i+1)-z_soisno(i)) & + /(thk(i)*(z_soisno(i+1)-zi_soisno(i))+thk(i+1)*(zi_soisno(i)-z_soisno(i))) + ELSE + tk_soisno(i) = thk(i) + ENDIF + ENDDO + tk_soisno(nl_soil) = 0. + tktopsoil = thk(1) + +! Sum cv_lake*t_lake for energy check +! Include latent heat term, and use tfrz as reference temperature +! to prevent abrupt change in heat content due to changing heat capacity with phase change. + + ! This will need to be over all soil / lake / snow layers. Lake is below. + ocvts = 0. + DO j = 1, nl_lake + ocvts = ocvts + cv_lake(j)*(t_lake(j)-tfrz) + cfus*dz_lake(j)*(1.-lake_icefrac(j)) + ENDDO + + ! Now DO for soil / snow layers + DO j = lb, nl_soil + ocvts = ocvts + cv_soisno(j)*(t_soisno(j)-tfrz) + hfus*wliq_soisno(j) + IF (j == 1 .and. scv > 0. .and. j == lb) THEN + ocvts = ocvts - scv*hfus + ENDIF + ENDDO + + ! Set up solar source terms (phix) + ! Modified January 12, 2023 by Yongjiu Dai + IF (.not. DEF_USE_SNICAR .or. present(urban_call)) THEN + IF ((t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0)) THEN !no snow cover, unfrozen layer lakes + DO j = 1, nl_lake + ! extinction coefficient from surface data (1/m), if no eta from surface data, + ! set eta, the extinction coefficient, according to L Hakanson, Aquatic Sciences, 1995 + ! (regression of secchi depth with lake depth for small glacial basin lakes), and the + ! Poole & Atkins expression for extinction coefficient of 1.7 / secchi Depth (m). + + eta = 1.1925*max(lakedepth,1.)**(-0.424) + zin = z_lake(j) - 0.5*dz_lake(j) + zout = z_lake(j) + 0.5*dz_lake(j) + rsfin = exp( -eta*max( zin-za(idlak),0. ) ) ! the radiation within surface layer (z= 0.0) THEN + IF(lb <= 0)THEN + qseva = min(wliq_soisno(lb)/deltim, fevpg) + qsubl = fevpg - qseva + ELSE + qseva = min((1.-lake_icefrac(1))*1000.*dz_lake(1)/deltim, fevpg) + qsubl = fevpg - qseva + ENDIF + ELSE + IF (t_grnd < tfrz) THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF + ENDIF + + +#if (defined CoLMDEBUG) + ! sum energy content and total energy into lake for energy check. any errors will be from the + ! tridiagonal solution. + esum1 = 0.0 + esum2 = 0.0 + DO j = lb, nl_lake + nl_soil + esum1 = esum1 + (tx(j)-tx_bef(j))*cvx(j) + esum2 = esum2 + (tx(j)-tfrz)*cvx(j) + ENDDO + ! fgrnd includes all the solar radiation absorbed in the lake, + errsoi = esum1/deltim - fgrnd + IF(abs(errsoi) > 0.1) THEN + write(6,*)'energy conservation error in LAND WATER COLUMN during tridiagonal solution,', & + 'error (W/m^2):', errsoi, fgrnd + ENDIF +#endif + + +!------------------------------------------------------------ +!*[4] Phase change +!------------------------------------------------------------ + + sm = 0.0 + xmf = 0.0 + imelt_soisno(:) = 0 + imelt_lake(:) = 0 + + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + wice_soisno_bef(lb:0) = wice_soisno(lb:0) + ENDIF + + ! Check for case of snow without snow layers and top lake layer temp above freezing. + + IF (snl == 0 .and. scv > 0. .and. t_lake(1) > tfrz) THEN + heatavail = (t_lake(1) - tfrz) * cv_lake(1) + melt = min(scv, heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0.) !catch small negative value to keep t at tfrz + t_lake(1) = tfrz + heatrem/(cv_lake(1)) + + snowdp = max(0., snowdp*(1. - melt/scv)) + scv = scv - melt + + IF (scv < 1.e-12) scv = 0. ! prevent tiny residuals + IF (snowdp < 1.e-12) snowdp = 0. ! prevent tiny residuals + sm = sm + melt/deltim + xmf = xmf + melt*hfus + ENDIF + + ! Lake phase change + DO j = 1,nl_lake + IF (t_lake(j) > tfrz .and. lake_icefrac(j) > 0.) THEN ! melting + imelt_lake(j) = 1 + heatavail = (t_lake(j) - tfrz) * cv_lake(j) + melt = min(lake_icefrac(j)*denh2o*dz_lake(j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = max(heatavail - melt*hfus, 0.) !catch small negative value to keep t at tfrz + ELSEIF (t_lake(j) < tfrz .and. lake_icefrac(j) < 1.) THEN !freezing + imelt_lake(j) = 2 + heatavail = (t_lake(j) - tfrz) * cv_lake(j) + melt = max(-(1.-lake_icefrac(j))*denh2o*dz_lake(j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = min(heatavail - melt*hfus, 0.) !catch small positive value to keep t at tfrz + ENDIF + ! Update temperature and ice fraction. + IF (imelt_lake(j) > 0) THEN + lake_icefrac(j) = lake_icefrac(j) - melt/(denh2o*dz_lake(j)) + IF (lake_icefrac(j) > 1.-1.e-12) lake_icefrac(j) = 1. ! prevent tiny residuals + IF (lake_icefrac(j) < 1.e-12) lake_icefrac(j) = 0. ! prevent tiny residuals + cv_lake(j) = cv_lake(j) + melt*(cpliq-cpice) ! update heat capacity + t_lake(j) = tfrz + heatrem/cv_lake(j) + xmf = xmf + melt*hfus + ENDIF + ENDDO + + ! snow & soil phase change. currently, does not DO freezing point depression. + DO j = snl+1,nl_soil + IF (t_soisno(j) > tfrz .and. wice_soisno(j) > 0.) THEN ! melting + imelt_soisno(j) = 1 + heatavail = (t_soisno(j) - tfrz) * cv_soisno(j) + melt = min(wice_soisno(j), heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0.) !catch small negative value to keep t at tfrz + IF (j <= 0) sm = sm + melt/deltim + ELSEIF (t_soisno(j) < tfrz .and. wliq_soisno(j) > 0.) THEN !freezing + imelt_soisno(j) = 2 + heatavail = (t_soisno(j) - tfrz) * cv_soisno(j) + melt = max(-wliq_soisno(j), heatavail/hfus) + heatrem = min(heatavail - melt*hfus, 0.) !catch small positive value to keep t at tfrz + ENDIF + + ! Update temperature and soil components. + IF (imelt_soisno(j) > 0) THEN + wice_soisno(j) = wice_soisno(j) - melt + wliq_soisno(j) = wliq_soisno(j) + melt + IF (wice_soisno(j) < 1.e-12) wice_soisno(j) = 0. ! prevent tiny residuals + IF (wliq_soisno(j) < 1.e-12) wliq_soisno(j) = 0. ! prevent tiny residuals + cv_soisno(j) = cv_soisno(j) + melt*(cpliq-cpice) ! update heat capacity + t_soisno(j) = tfrz + heatrem/cv_soisno(j) + xmf = xmf + melt*hfus + ENDIF + ENDDO + !------------------------------------------------------------ + + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + !for SNICAR: layer freezing mass flux (positive): + DO j = lb, 0 + IF (imelt_soisno(j)==2 .and. j<1) THEN + snofrz(j) = max(0._r8,(wice_soisno(j)-wice_soisno_bef(j)))/deltim + ENDIF + ENDDO + ENDIF + +#if (defined CoLMDEBUG) + ! second energy check and water check. now check energy balance before and after phase + ! change, considering the possibility of changed heat capacity during phase change, by + ! using initial heat capacity in the first step, final heat capacity in the second step, + ! and differences from tfrz only to avoid enthalpy correction for (cpliq-cpice)*melt*tfrz. + ! also check soil water sum. + DO j = 1, nl_lake + esum2 = esum2 - (t_lake(j)-tfrz)*cv_lake(j) + ENDDO + + DO j = lb, nl_soil + esum2 = esum2 - (t_soisno(j)-tfrz)*cv_soisno(j) + ENDDO + + esum2 = esum2 - xmf + errsoi = esum2/deltim + + IF(abs(errsoi) > 0.1) THEN + write(6,*) 'energy conservation error in LAND WATER COLUMN during phase change, error (W/m^2):', errsoi + ENDIF + +#endif + +!------------------------------------------------------------ +!*[5] Convective mixing: make sure fracice*dz is conserved, heat content c*dz*T is conserved, and +! all ice ends up at the top. Done over all lakes even IF frozen. +! Either an unstable density profile or ice in a layer below an incompletely frozen layer will trigger. +!------------------------------------------------------------ + + ! recalculate density + DO j = 1, nl_lake + rhow(j) = (1.-lake_icefrac(j))*1000.*(1.0-1.9549e-05*(abs(t_lake(j)-277.))**1.68) & + + lake_icefrac(j)*denice + ENDDO + + DO j = 1, nl_lake-1 + qav = 0. + nav = 0. + iceav = 0. + + IF (rhow(j)>rhow(j+1) .or. (lake_icefrac(j)<1.0 .and. lake_icefrac(j+1)>0.)) THEN + DO i = 1, j+1 + qav = qav + dz_lake(i)*(t_lake(i)-tfrz) * & + ((1. - lake_icefrac(i))*cwat + lake_icefrac(i)*cice_eff) + iceav = iceav + lake_icefrac(i)*dz_lake(i) + nav = nav + dz_lake(i) + ENDDO + + qav = qav/nav + iceav = iceav/nav + !IF the average temperature is above freezing, put the extra energy into the water. + !IF it is below freezing, take it away from the ice. + IF (qav > 0.) THEN + tav_froz = 0. !Celsius + tav_unfr = qav / ((1. - iceav)*cwat) + ELSEIF (qav < 0.) THEN + tav_froz = qav / (iceav*cice_eff) + tav_unfr = 0. !Celsius + ELSE + tav_froz = 0. + tav_unfr = 0. + ENDIF + ENDIF + + IF (nav > 0.) THEN + DO i = 1, j+1 + + !put all the ice at the top. + !if the average temperature is above freezing, put the extra energy into the water. + !if it is below freezing, take it away from the ice. + !for the layer with both ice & water, be careful to use the average temperature + !that preserves the correct total heat content given what the heat capacity of that + !layer will actually be. + + IF (i == 1) zsum = 0. + IF ((zsum+dz_lake(i))/nav <= iceav) THEN + lake_icefrac(i) = 1. + t_lake(i) = tav_froz + tfrz + ELSEIF (zsum/nav < iceav) THEN + lake_icefrac(i) = (iceav*nav - zsum) / dz_lake(i) + ! Find average value that preserves correct heat content. + t_lake(i) = ( lake_icefrac(i)*tav_froz*cice_eff & + + (1. - lake_icefrac(i))*tav_unfr*cwat ) & + / ( lake_icefrac(i)*cice_eff + (1-lake_icefrac(i))*cwat ) + tfrz + ELSE + lake_icefrac(i) = 0. + t_lake(i) = tav_unfr + tfrz + ENDIF + zsum = zsum + dz_lake(i) + + rhow(i) = (1.-lake_icefrac(i))*1000.*(1.-1.9549e-05*(abs(t_lake(i)-277.))**1.68) & + + lake_icefrac(i)*denice + ENDDO + ENDIF + ENDDO + +!------------------------------------------------------------ +!*[6] Re-evaluate thermal properties and sum energy content. +!------------------------------------------------------------ + ! for lake + DO j = 1, nl_lake + cv_lake(j) = dz_lake(j) * (cwat*(1.-lake_icefrac(j)) + cice_eff*lake_icefrac(j)) + ENDDO + + ! do as above to sum energy content + ncvts = 0. + DO j = 1, nl_lake + ncvts = ncvts + cv_lake(j)*(t_lake(j)-tfrz) + cfus*dz_lake(j)*(1.-lake_icefrac(j)) + ENDDO + + DO j = lb, nl_soil + ncvts = ncvts + cv_soisno(j)*(t_soisno(j)-tfrz) + hfus*wliq_soisno(j) + IF (j == 1 .and. scv > 0. .and. j == lb) THEN + ncvts = ncvts - scv*hfus + ENDIF + ENDDO + + ! check energy conservation. + errsoi = (ncvts-ocvts)/deltim - fgrnd + IF (abs(errsoi) < 0.10) THEN + fseng = fseng - errsoi + fsena = fseng + fgrnd = fgrnd + errsoi + errsoi = 0. + ELSE + print*, "energy conservation error in LAND WATER COLUMN during convective mixing", errsoi,fgrnd,ncvts,ocvts + ENDIF + + + END SUBROUTINE laketem + + + + SUBROUTINE snowwater_lake ( USE_Dynamic_Lake, & + ! "in" arguments + ! --------------------------- + maxsnl , nl_soil , nl_lake , deltim ,& + ssi , wimp , porsl , pg_rain ,& + pg_snow , dz_lake , imelt , fiold ,& + qseva , qsubl , qsdew , qfros ,& + + ! "inout" arguments + ! --------------------------- + z_soisno , dz_soisno , zi_soisno , t_soisno ,& + wice_soisno , wliq_soisno , t_lake , lake_icefrac ,& + qout_snowb , & + fseng , fgrnd , snl , scv ,& + snowdp , sm , forc_us , forc_vs ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho , mss_bcphi , mss_ocpho , mss_ocphi ,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ,& +! END SNICAR model variables + urban_call ) + +!----------------------------------------------------------------------------------------------- +! Calculation of Lake Hydrology. Lake water mass is kept constant. The +! soil is simply maintained at volumetric saturation if ice melting +! frees up pore space. +! +! Called: +! -> snowwater: change of snow mass and snow water onto soil +! -> snowcompaction: compaction of snow layers +! -> combinesnowlayers: combine snow layers that are thinner than minimum +! -> dividesnowlayers: subdivide snow layers that are thicker than maximum +! +! Initial: Yongjiu Dai, December, 2012 +! April, 2014 +! !REVISIONS: +! Nan Wei, 06/2018: update snow hydrology above lake +! Yongjiu Dai, 01/2023: added for SNICAR model effects for snowwater, +! combinesnowlayers, dividesnowlayers processes by calling snowwater_snicar(), +! SnowLayersCombine_snicar, SnowLayersDivide_snicar() +!----------------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: denh2o, denice, hfus, tfrz, cpliq, cpice + USE MOD_SoilSnowHydrology + USE MOD_SnowLayersCombineDivide + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + logical, intent(in) :: USE_Dynamic_Lake + + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_soil ! number of soil layers + integer, intent(in) :: nl_lake ! number of soil layers + + real(r8), intent(in) :: deltim ! seconds in a time step (sec) + real(r8), intent(in) :: ssi ! irreducible water saturation of snow + real(r8), intent(in) :: wimp ! water impermeable if porosity less than wimp + real(r8), intent(in) :: porsl(1:nl_soil) ! volumetric soil water at saturation (porosity) + + real(r8), intent(in) :: pg_rain ! rainfall incident on ground [mm/s] + real(r8), intent(in) :: pg_snow ! snowfall incident on ground [mm/s] + + real(r8), intent(inout) :: dz_lake(1:nl_lake) ! layer thickness for lake (m) + + integer, intent(in) :: imelt(maxsnl+1:0) ! signifies if node in melting (imelt = 1) + real(r8), intent(in) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water content at the previous time step + real(r8), intent(in) :: qseva ! ground surface evaporation rate (mm h2o/s) + real(r8), intent(in) :: qsubl ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), intent(in) :: qsdew ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), intent(in) :: qfros ! ground surface frosting formation (mm H2O /s) [+] + + real(r8), intent(inout) :: z_soisno (maxsnl+1:nl_soil) ! layer depth (m) + real(r8), intent(inout) :: dz_soisno (maxsnl+1:nl_soil) ! layer thickness depth (m) + real(r8), intent(inout) :: zi_soisno (maxsnl:nl_soil) ! interface depth (m) + real(r8), intent(inout) :: t_soisno (maxsnl+1:nl_soil) ! snow temperature (Kelvin) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:nl_soil) ! ice lens (kg/m2) + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:nl_soil) ! liquid water (kg/m2) + real(r8), intent(inout) :: t_lake (1:nl_lake) ! lake temperature (Kelvin) + real(r8), intent(inout) :: lake_icefrac(1:nl_lake) ! mass fraction of lake layer that is frozen + real(r8), intent(inout) :: qout_snowb ! rate of water out of snow bottom (mm/s) + + real(r8), intent(inout) :: fseng ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), intent(inout) :: fgrnd ! heat flux into snow / lake (W/m**2) [+ = into soil] + + integer , intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: scv ! snow water (mm H2O) + real(r8), intent(inout) :: snowdp ! snow height (m) + real(r8), intent(inout) :: sm ! rate of snow melt (mm H2O /s) + + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023 by Yongjiu Dai) + real(r8), intent(in) :: forc_aer ( 14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + logical, optional, intent(in) :: urban_call ! whether it is a urban CALL + + real(r8), intent(inout) :: & + mss_bcpho (maxsnl+1:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (maxsnl+1:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (maxsnl+1:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (maxsnl+1:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (maxsnl+1:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (maxsnl+1:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (maxsnl+1:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (maxsnl+1:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +!-------------------------- Local Variables ---------------------------- + logical has_snow_bef + integer j ! indices + integer lb ! lower bound of array + + real(r8) xmf ! snow melt heat flux (W/m**2) + + real(r8) sumsnowice ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + real(r8) sumsnowliq ! sum of snow liquid if snow layers found above unfrozen lake [kg/m&2] + logical unfrozen ! true if top lake layer is unfrozen with snow layers above + real(r8) heatsum ! used in case above [J/m^2] + real(r8) heatrem ! used in case above [J/m^2] + real(r8) dw_soil + + real(r8) a, b, c, d + real(r8) wice_lake(1:nl_lake) ! ice lens (kg/m2) + real(r8) wliq_lake(1:nl_lake) ! liquid water (kg/m2) + real(r8) t_ave, frac_ +!----------------------------------------------------------------------- + + ! for runoff calculation (assumed no mass change in the land water bodies) + lb = snl + 1 + qout_snowb = 0.0 + + IF (USE_Dynamic_Lake) THEN + has_snow_bef = (snl < 0) + ENDIF + + ! ---------------------------------------------------------- + !*[1] snow layer on frozen lake + ! ---------------------------------------------------------- + IF (snl < 0) THEN + lb = snl + 1 + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + CALL snowwater_SNICAR (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),qout_snowb, & + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ELSE + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),qout_snowb) + ENDIF + + ! Natural compaction and metamorphosis. + lb = snl + 1 + CALL snowcompaction (lb,deltim, & + imelt(lb:0),fiold(lb:0),t_soisno(lb:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),forc_us,forc_vs,dz_soisno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + CALL snowlayerscombine_SNICAR (lb, snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:0),& + wliq_soisno(lb:1),wice_soisno(lb:1), t_soisno(lb:1),scv,snowdp, & + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0)) + ELSE + CALL snowlayerscombine (lb, snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:0),& + wliq_soisno(lb:1),wice_soisno(lb:1),& + t_soisno(lb:1),scv,snowdp) + ENDIF + + ! Divide thick snow elements + IF (snl < 0) THEN + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + CALL snowlayersdivide_SNICAR (lb,snl,z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0) ,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ELSE + CALL snowlayersdivide (lb,snl,z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0)) + ENDIF + ENDIF + + ! ---------------------------------------------------------- + !*[2] check for single completely unfrozen snow layer over lake. + ! Modeling this ponding is unnecessary and can cause instability after the timestep + ! when melt is completed, as the temperature after melt can be excessive + ! because the fluxes were calculated with a fixed ground temperature of freezing, but the + ! phase change was unable to restore the temperature to freezing. (Zack Subnin 05/2010) + ! ---------------------------------------------------------- + + IF (snl == -1 .and. wice_soisno(0) == 0.) THEN + ! Remove layer + ! Take extra heat of layer and release to sensible heat in order to maintain energy conservation. + heatrem = cpliq*wliq_soisno(0)*(t_soisno(0) - tfrz) + fseng = fseng + heatrem/deltim + fgrnd = fgrnd - heatrem/deltim + + snl = 0 + scv = 0. + snowdp = 0. + qout_snowb = qout_snowb + wliq_soisno(0)/deltim + wliq_soisno(0) = 0. + ENDIF + + ENDIF + + ! ---------------------------------------------------------- + !*[3] check for snow layers above lake with unfrozen top layer. Mechanically, + ! the snow will fall into the lake and melt or turn to ice. IF the top layer has + ! sufficient heat to melt the snow without freezing, THEN that will be done. + ! Otherwise, the top layer will undergo freezing, but only IF the top layer will + ! not freeze completely. Otherwise, let the snow layers persist and melt by diffusion. + ! ---------------------------------------------------------- + + IF (t_lake(1) > tfrz .and. snl < 0 .and. lake_icefrac(1) < 0.001) THEN ! for unfrozen lake + unfrozen = .true. + ELSE + unfrozen = .false. + ENDIF + + sumsnowice = 0. + sumsnowliq = 0. + heatsum = 0.0 + DO j = snl+1,0 + IF (unfrozen) THEN + sumsnowice = sumsnowice + wice_soisno(j) + sumsnowliq = sumsnowliq + wliq_soisno(j) + heatsum = heatsum + wice_soisno(j)*cpice*(tfrz-t_soisno(j)) & + + wliq_soisno(j)*cpliq*(tfrz-t_soisno(j)) + ENDIF + ENDDO + + IF (unfrozen) THEN + ! changed by weinan as the subroutine newsnow_lake + ! Remove snow and subtract the latent heat from the top layer. + + t_ave = tfrz - heatsum/(sumsnowice*cpice + sumsnowliq*cpliq) + + a = heatsum + b = sumsnowice*hfus + c = (t_lake(1) - tfrz)*cpliq*denh2o*dz_lake(1) + d = denh2o*dz_lake(1)*hfus + + ! all snow melt + IF (c>=a+b)THEN + t_lake(1) = (cpliq*(denh2o*dz_lake(1)*t_lake(1) + (sumsnowice+sumsnowliq)*tfrz) - a - b) / & + (cpliq*(denh2o*dz_lake(1) + sumsnowice + sumsnowliq)) + sm = sm + scv/deltim + qout_snowb = qout_snowb + scv/deltim + scv = 0. + snowdp = 0. + snl = 0 + ! lake partially freezing to melt all snow + ELSEIF(c+d >= a+b)THEN + t_lake(1) = tfrz + sm = sm + scv/deltim + qout_snowb = qout_snowb + scv/deltim + scv = 0. + snowdp = 0. + snl = 0 + lake_icefrac(1) = (a+b-c)/d + + ! snow do not melt while all lake freezing + ! ELSEIF(c+d < a) THEN + ! t_lake(1) = (c+d + cpice*(sumsnowice*t_ave+denh2o*dz_lake(1)*tfrz) + cpliq*sumsnowliq*t_ave)/& + ! (cpice*(sumsnowice+denh2o*dz_lake(1))+cpliq*sumsnowliq) + ! lake_icefrac(1) = 1.0 + ENDIF + ENDIF + + + ! ---------------------------------------------------------- + !*[4] Soil water and ending water balance + ! ---------------------------------------------------------- + ! Here this consists only of making sure that soil is saturated even as it melts and + ! pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the + ! saturation value, then remove water. + + dw_soil = 0. + + DO j = 1, nl_soil + dw_soil = dw_soil + wliq_soisno(j) + wice_soisno(j) + + a = wliq_soisno(j)/(dz_soisno(j)*denh2o) + wice_soisno(j)/(dz_soisno(j)*denice) + + IF (a < porsl(j)) THEN + wliq_soisno(j) = max(0., (porsl(j)*dz_soisno(j) - wice_soisno(j)/denice)*denh2o ) + wice_soisno(j) = max(0., (porsl(j)*dz_soisno(j) - wliq_soisno(j)/denh2o)*denice ) + ELSE + wliq_soisno(j) = max(0., wliq_soisno(j) - (a - porsl(j))*denh2o*dz_soisno(j) ) + wice_soisno(j) = max(0., (porsl(j)*dz_soisno(j) - wliq_soisno(j)/denh2o)*denice ) + ENDIF + + IF (wliq_soisno(j) > porsl(j)*denh2o*dz_soisno(j)) THEN + wliq_soisno(j) = porsl(j)*denh2o*dz_soisno(j) + wice_soisno(j) = 0.0 + ENDIF + + dw_soil = dw_soil - wliq_soisno(j) - wice_soisno(j) + ENDDO + + IF (USE_Dynamic_Lake) THEN + + IF (has_snow_bef) THEN + wliq_lake(1) = dz_lake(1) * (1-lake_icefrac(1)) + qout_snowb*deltim*1.e-3 + wice_lake(1) = dz_lake(1) * lake_icefrac(1) + ELSE + wliq_lake(1) = dz_lake(1) * (1-lake_icefrac(1)) + (sm + qsdew - qseva)*deltim*1.e-3 + wice_lake(1) = dz_lake(1) * lake_icefrac(1) + (qfros - qsubl)*deltim*1.e-3 + IF (wliq_lake(1) < 0.) THEN + wice_lake(1) = wice_lake(1) + wliq_lake(1) + wliq_lake(1) = 0. + ENDIF + IF (wice_lake(1) < 0.) THEN + wliq_lake(1) = wliq_lake(1) + wice_lake(1) + wice_lake(1) = 0. + ENDIF + ENDIF + + dz_lake(1) = wliq_lake(1) + wice_lake(1) + dz_lake(1) = max(dz_lake(1), 1.e-6) + lake_icefrac(1) = wice_lake(1) / dz_lake(1) + lake_icefrac(1) = min(max(lake_icefrac(1), 0.), 1.) + + dz_lake(nl_lake) = dz_lake(nl_lake) + dw_soil/1.e3 + + IF (dz_lake(nl_lake) < 0.) THEN + j = nl_lake + DO WHILE (dz_lake(j) < 0.) + IF (j > 1) dz_lake(j-1) = dz_lake(j-1) + dz_lake(j) + dz_lake(j) = 0. + j = j - 1 + IF (j == 0) EXIT + ENDDO + ENDIF + + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + + ENDIF + + END SUBROUTINE snowwater_lake + + + + SUBROUTINE roughness_lake (snl,t_grnd,t_lake,lake_icefrac,forc_psrf,& + cur,ustar,z0mg,z0hg,z0qg) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate lake surface roughness +! +! Original: +! The Community Land Model version 4.5 (CLM4.5) +! +! !REVISIONS: +! Yongjiu Dai, Nan Wei, 01/2018 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz,vonkar,grav + + IMPLICIT NONE + + integer, intent(in) :: snl ! number of snow layers + real(r8), intent(in) :: t_grnd ! ground temperature + real(r8), intent(in) :: t_lake(1) ! surface lake layer temperature [K] + real(r8), intent(in) :: lake_icefrac(1) ! surface lake layer ice mass fraction [0-1] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + + real(r8), intent(in) :: cur ! Charnock parameter (-) + real(r8), intent(in) :: ustar ! u* in similarity theory [m/s] + + real(r8), intent(out) :: z0mg ! roughness length over ground, momentum [m] + real(r8), intent(out) :: z0hg ! roughness length over ground, sensible heat [m] + real(r8), intent(out) :: z0qg ! roughness length over ground, latent heat [m] + + real(r8), parameter :: cus = 0.1 ! empirical constant for roughness under smooth flow + real(r8), parameter :: kva0 = 1.51e-5 ! kinematic viscosity of air (m^2/s) at 20C and 1.013e5 Pa + real(r8), parameter :: prn = 0.713 ! Prandtl # for air at neutral stability + real(r8), parameter :: sch = 0.66 ! Schmidt # for water in air at neutral stability + + real(r8) kva ! kinematic viscosity of air at ground temperature and forcing pressure + real(r8) sqre0 ! root of roughness Reynolds number +!----------------------------------------------------------------------- + + IF (t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0) THEN + kva = kva0 * (t_grnd/293.15)**1.5 * 1.013e5/forc_psrf ! kinematic viscosity of air + z0mg = max(cus*kva/max(ustar,1.e-4),cur*ustar*ustar/grav) ! momentum roughness length + z0mg = max(z0mg, 1.0e-5) ! This limit is redundant with current values. + sqre0 = (max(z0mg*ustar/kva,0.1))**0.5 ! square root of roughness Reynolds number + z0hg = z0mg * exp( -vonkar/prn*( 4.*sqre0 - 3.2) ) ! SH roughness length + z0qg = z0mg * exp( -vonkar/sch*( 4.*sqre0 - 4.2) ) ! LH roughness length + z0qg = max(z0qg, 1.0e-5) ! Minimum allowed roughness length for unfrozen lakes + z0hg = max(z0hg, 1.0e-5) ! set low so it is only to avoid floating point exceptions + ELSEIF (snl == 0) THEN ! frozen lake with ice, and no snow cover + z0mg = 0.001 ! z0mg won't have changed + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + ELSE ! use roughness over snow + z0mg = 0.0024 ! z0mg won't have changed + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + ENDIF + + END SUBROUTINE roughness_lake + + + + SUBROUTINE hConductivity_lake(nl_lake,snl,t_grnd,& + z_lake,t_lake,lake_icefrac,rhow,& + dlat,ustar,z0mg,lakedepth,depthcrit,tk_lake, savedtke1) + +!----------------------------------------------------------------------- +! Diffusivity and implied thermal "conductivity" = diffusivity * cwat +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz,tkwat,tkice,tkair,& + vonkar,grav,cpliq,cpice,cpair,denh2o,denice + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: nl_lake ! number of soil layers + integer, intent(in) :: snl ! number of snow layers + real(r8), intent(in) :: t_grnd ! ground surface temperature [k] + real(r8), intent(in) :: z_lake(nl_lake) ! lake node depth (middle point of layer) (m) + real(r8), intent(in) :: t_lake(nl_lake) ! lake temperature (kelvin) + real(r8), intent(in) :: lake_icefrac(nl_lake) ! lake mass fraction of lake layer that is frozen + real(r8), intent(in) :: rhow(nl_lake) ! density of water (kg/m**3) + + real(r8), intent(in) :: dlat ! latitude (radians) + real(r8), intent(in) :: ustar ! u* in similarity theory [m/s] + real(r8), intent(in) :: z0mg ! roughness length over ground, momentum [m] + real(r8), intent(in) :: lakedepth ! column lake depth (m) + real(r8), intent(in) :: depthcrit ! (m) Depth beneath which to enhance mixing + + + real(r8), intent(out) :: tk_lake(nl_lake) ! thermal conductivity at layer node [W/(m K)] + real(r8), intent(out) :: savedtke1 ! top level eddy conductivity (W/mK) + +!-------------------------- Local Variables ---------------------------- + real(r8) kme(nl_lake) ! molecular + eddy diffusion coefficient (m**2/s) + real(r8) cwat ! specific heat capacity of water (j/m**3/kelvin) + real(r8) den ! used in calculating ri + real(r8) drhodz ! d [rhow] /dz (kg/m**4) + real(r8) fangkm ! (m^2/s) extra diffusivity based on Fang & Stefan 1996 + real(r8) ke ! eddy diffusion coefficient (m**2/s) + real(r8) km ! molecular diffusion coefficient (m**2/s) + real(r8) ks ! coefficient for calculation of decay of eddy diffusivity with depth + real(r8) n2 ! brunt-vaisala frequency (/s**2) + real(r8) num ! used in calculating ri + real(r8) ri ! richardson number + real(r8) tkice_eff ! effective conductivity since layer depth is constant + real(r8) tmp ! + real(r8) u2m ! 2 m wind speed (m/s + real(r8) ws ! surface friction velocity (m/s) + + real(r8), parameter :: mixfact = 5. ! Mixing enhancement factor. + real(r8), parameter :: p0 = 1. ! neutral value of turbulent prandtl number + + + integer j + +! ------------------------------------------------------------------- + + cwat = cpliq*denh2o + tkice_eff = tkice * denice/denh2o ! effective conductivity since layer depth is constant + km = tkwat/cwat ! a constant (molecular diffusivity) + u2m = max(0.1,ustar/vonkar*log(2./z0mg)) + ws = 1.2e-03 * u2m + ks = 6.6 * sqrt( abs(sin(dlat)) ) * (u2m**(-1.84)) + + DO j = 1, nl_lake-1 + drhodz = (rhow(j+1)-rhow(j)) / (z_lake(j+1)-z_lake(j)) + n2 = max(7.5e-5, grav / rhow(j) * drhodz) + num = 40. * n2 * (vonkar*z_lake(j))**2 + tmp = -2.*ks*z_lake(j) ! to avoid underflow computing + IF(tmp < -40.) tmp = -40. ! + den = max( (ws**2) * exp(tmp), 1.e-10 ) + ri = ( -1. + sqrt( max(1.+num/den, 0.) ) ) / 20. + + IF ((t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0) ) THEN + tmp = -ks*z_lake(j) ! to avoid underflow computing + IF(tmp < -40.) tmp = -40. ! + ke = vonkar*ws*z_lake(j)/p0 * exp(tmp) / (1.+37.*ri*ri) + kme(j) = km + ke + + fangkm = 1.039e-8_r8 * max(n2,7.5e-5)**(-0.43) ! Fang & Stefan 1996, citing Ellis et al 1991 + kme(j) = kme(j) + fangkm + + IF (lakedepth >= depthcrit) THEN + kme(j) = kme(j) * mixfact ! Mixing enhancement factor for lake deep than 25m. + ENDIF + tk_lake(j) = kme(j)*cwat + ELSE + kme(j) = km + fangkm = 1.039e-8 * max(n2,7.5e-5)**(-0.43) + kme(j) = kme(j) + fangkm + IF (lakedepth >= depthcrit) THEN + kme(j) = kme(j) * mixfact + ENDIF + tk_lake(j) = kme(j)*cwat*tkice_eff / ((1.-lake_icefrac(j))*tkice_eff & + + kme(j)*cwat*lake_icefrac(j)) + ENDIF + ENDDO + + kme(nl_lake) = kme(nl_lake-1) + savedtke1 = kme(1)*cwat + + IF ((t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0) ) THEN + tk_lake(nl_lake) = tk_lake(nl_lake-1) + ELSE + tk_lake(nl_lake) = kme(nl_lake)*cwat*tkice_eff / ( (1.-lake_icefrac(nl_lake))*tkice_eff & + + kme(nl_lake)*cwat*lake_icefrac(nl_lake) ) + ENDIF + + END SUBROUTINE hConductivity_lake + + + SUBROUTINE adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + + USE MOD_Const_Physical + IMPLICIT NONE + + integer, intent(in) :: nl_lake + real(r8), intent(inout) :: dz_lake (nl_lake) ! lake layer thickness (m) + real(r8), intent(inout) :: t_lake (nl_lake) ! lake temperature (kelvin) + real(r8), intent(inout) :: lake_icefrac(nl_lake) ! lake mass fraction of lake layer that is frozen + + ! Local Variables + integer :: i, j + real(r8) :: wdsrfm, depthratio, resi, resj + real(r8) :: ticesum, tliqsum, wicesum, wliqsum, olp, tliq, tice, a, b, c, d + real(r8) :: dz_lake_new (nl_lake) + real(r8) :: t_lake_new (nl_lake) + real(r8) :: lake_icefrac_new (nl_lake) + real(r8), parameter :: dzlak(10) = (/0.1, 1., 2., 3., 4., 5., 7., 7., 10.45, 10.45/) ! m + + wdsrfm = sum(dz_lake) + + IF(wdsrfm > 1.)THEN + depthratio = wdsrfm / sum(dzlak(1:nl_lake)) + dz_lake_new(1) = dzlak(1) + dz_lake_new(2:nl_lake-1) = dzlak(2:nl_lake-1)*depthratio + dz_lake_new(nl_lake) = dzlak(nl_lake)*depthratio - (dz_lake_new(1) - dzlak(1)*depthratio) + ELSEIF(wdsrfm > 0. .and. wdsrfm <= 1.)THEN + dz_lake_new(:) = wdsrfm / nl_lake + ENDIF + + j = 1 + resj = dz_lake(j) + + DO i = 1, nl_lake + + ticesum = 0. + tliqsum = 0. + wicesum = 0. + wliqsum = 0. + + resi = dz_lake_new(i) + DO WHILE (resi > 1.e-8) + + olp = min(resi, resj) + ticesum = ticesum + olp * lake_icefrac(j) * t_lake(j) + wicesum = wicesum + olp * lake_icefrac(j) + tliqsum = tliqsum + olp * (1-lake_icefrac(j)) * t_lake(j) + wliqsum = wliqsum + olp * (1-lake_icefrac(j)) + + resi = resi - olp + resj = resj - olp + + IF (resj == 0.) THEN + IF (j == nl_lake) THEN + EXIT + ELSE + j = j + 1 + resj = dz_lake(j) + ENDIF + ENDIF + + ENDDO + + IF (wicesum > 0.) tice = ticesum / wicesum + IF (wliqsum > 0.) tliq = tliqsum / wliqsum + + IF ((wliqsum > 0.) .and. (wicesum > 0.)) THEN + + a = cpliq*wliqsum*(tliq-tfrz) + b = cpice*wicesum*(tfrz-tice) + c = wicesum*hfus + d = wliqsum*hfus + + IF (a >= b + c) THEN + wicesum = 0. + wliqsum = dz_lake_new(i) + t_lake_new(i) = tfrz + (a-b-c)/(wliqsum*cpliq) + ELSEIF (a >= b) THEN + wicesum = wicesum - (a-b)/hfus + t_lake_new(i) = tfrz + ELSEIF (a + d < b) THEN + wicesum = dz_lake_new(i) + t_lake_new(i) = tfrz - (b-a-d)/(wicesum*cpice) + ELSE ! (b-d <= a < b) + wicesum = wicesum + (b-a)/hfus + t_lake_new(i) = tfrz + ENDIF + + ELSEIF (wliqsum > 0.) THEN + t_lake_new(i) = tliq + ELSEIF (wicesum > 0.) THEN + t_lake_new(i) = tice + ENDIF + + lake_icefrac_new(i) = wicesum / dz_lake_new(i) + + ENDDO + + dz_lake = dz_lake_new + lake_icefrac = lake_icefrac_new + t_lake = t_lake_new + + END SUBROUTINE adjust_lake_layer + + +END MODULE MOD_Lake diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 new file mode 100644 index 0000000000..94e0ebc91c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 @@ -0,0 +1,2458 @@ +#include +MODULE MOD_LeafInterception +! ----------------------------------------------------------------- +! !DESCRIPTION: +! For calculating vegetation canopy precipitation interception. +! +! This MODULE is the coupler for the colm and CaMa-Flood model. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + !* :SUBROUTINE:"LEAF_interception_CoLM2014" : Leaf interception and drainage schemes based on colm2014 version + !* :SUBROUTINE:"LEAF_interception_CoLM202x" : Leaf interception and drainage schemes besed on new colm version (under development) + !* :SUBROUTINE:"LEAF_interception_CLM4" : Leaf interception and drainage schemes modified from CLM4 + !* :SUBROUTINE:"LEAF_interception_CLM5" : Leaf interception and drainage schemes modified from CLM5 + !* :SUBROUTINE:"LEAF_interception_NOAHMP" : Leaf interception and drainage schemes modified from Noah-MP + !* :SUBROUTINE:"LEAF_interception_MATSIRO" : Leaf interception and drainage schemes modified from MATSIRO 2021 version + !* :SUBROUTINE:"LEAF_interception_VIC" : Leaf interception and drainage schemes modified from VIC + !* :SUBROUTINE:"LEAF_interception_JULES" : Leaf interception and drainage schemes modified from JULES + !* :SUBROUTINE:"LEAF_interception_pftwrap" : wrapper for pft land use classification + +!REVISION HISTORY: +!---------------- + ! 2026.01 Zhongwang Wei: Fully revise CLM4,5,Noah-MP,MATSIRO,VIC and JULES schemes. + ! 2024.04 Hua Yuan: add option to account for vegetation snow process based on Niu et al., 2004 + ! 2023.07 Hua Yuan: remove wrapper PC by using PFT leaf interception + ! 2023.06 Shupeng Zhang @ SYSU + ! 2023.02.23 Zhongwang Wei @ SYSU + ! 2021.12.12 Zhongwang Wei @ SYSU + ! 2020.10.21 Zhongwang Wei @ SYSU + ! 2019.06 Hua Yuan: 1) add wrapper for PFT and PC, and 2) remove sigf by using lai+sai + ! 2014.04 Yongjiu Dai + ! 2002.08.31 Yongjiu Dai + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice, hfus + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_VEG_SNOW + + IMPLICIT NONE + + real(r8), parameter :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + real(r8), parameter :: bp = 20. + real(r8), parameter :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + real(r8), parameter :: pcoefs(2,2) = reshape((/20.0_r8, 0.206e-8_r8, 0.0001_r8, 0.9999_r8/), (/2,2/)) + + ! Minimum significant precipitation rate threshold [mm/s] + ! Used across all schemes for numerical stability + real(r8), parameter :: PRECIP_THRESHOLD = 1.0e-8_r8 + + ! Tolerance for interception water balance checks [mm] + ! Used by check_interception_balance subroutine under CoLMDEBUG + real(r8), parameter :: INTERCEPTION_BALANCE_TOL = 1.0e-5_r8 + + !----------------------- Dummy argument -------------------------------- + real(r8) :: satcap ! maximum allowed water on canopy [mm] + real(r8) :: satcap_rain ! maximum allowed rain on canopy [mm] + real(r8) :: satcap_snow ! maximum allowed snow on canopy [mm] + real(r8) :: lsai ! sum of leaf area index and stem area index [-] + real(r8) :: chiv ! leaf angle distribution factor + real(r8) :: ppc ! convective precipitation in time-step [mm] + real(r8) :: ppl ! large-scale precipitation in time-step [mm] + real(r8) :: p0 ! precipitation in time-step [mm] + real(r8) :: fpi ! coefficient of interception + real(r8) :: fpi_rain ! coefficient of interception of rain + real(r8) :: fpi_snow ! coefficient of interception of snow + real(r8) :: alpha_rain ! coefficient of interception of rain + real(r8) :: alpha_snow ! coefficient of interception of snow + real(r8) :: pinf ! interception of precipitation in time step [mm] + real(r8) :: tti_rain ! direct rain throughfall in time step [mm] + real(r8) :: tti_snow ! direct snow throughfall in time step [mm] + real(r8) :: tex_rain ! canopy rain drainage in time step [mm] + real(r8) :: tex_snow ! canopy snow drainage in time step [mm] + real(r8) :: vegt ! sigf*lsai + real(r8) :: xs ! proportion of the grid area where the intercepted rainfall + ! plus the preexisting canopy water storage + real(r8) :: unl_snow_temp,U10,unl_snow_wind,unl_snow + real(r8) :: ap, cp, aa1, bb1, exrain, arg, w + real(r8) :: thru_rain, thru_snow + real(r8) :: xsc_rain, xsc_snow + + real(r8) :: fvegc ! vegetation fraction + real(r8) :: FT ! the temperature factor for snow unloading + real(r8) :: FV ! the wind factor for snow unloading + real(r8) :: ICEDRIP ! snow unloading + + real(r8) :: ldew_smelt + real(r8) :: ldew_frzc + real(r8) :: FP + real(r8) :: int_rain + real(r8) :: int_snow + +CONTAINS + + SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Calculation of interception and drainage of precipitation + ! the treatment are based on Sellers et al. (1996) + +!Original Author: +!------------------- + !canopy interception scheme modified by Yongjiu Dai based on Sellers et al. (1996) + +!References: +!------------------- + !---Dai, Y., Zeng, X., Dickinson, R.E., Baker, I., Bonan, G.B., BosiloVICh, + ! M.G., Denning, A.S., Dirmeyer, P.A., Houser, P.R., Niu, G. and Oleson, + ! K.W., 2003. The common land model. Bulletin of the American + ! Meteorological Society, 84(8), pp.1013-1024. + + !---Lawrence, D.M., Thornton, P.E., Oleson, K.W. and Bonan, G.B., 2007. The + ! partitioning of evapotranspiration into transpiration, soil evaporation, + ! and canopy evaporation in a GCM: Impacts on land-atmosphere interaction. + ! Journal of Hydrometeorology, 8(4), pp.862-880. + + !---Oleson, K., Dai, Y., Bonan, B., BosiloVIChm, M., Dickinson, R., + ! Dirmeyer, P., Hoffman, F., Houser, P., Levis, S., Niu, G.Y. and + ! Thornton, P., 2004. Technical description of the community land model + ! (CLM). + + !---Sellers, P.J., Randall, D.A., Collatz, G.J., Berry, J.A., Field, C.B., + ! Dazlich, D.A., Zhang, C., Collelo, G.D. and Bounoua, L., 1996. A revised + ! land surface parameterization (SiB2) for atmospheric GCMs. Part I: + ! Model formulation. Journal of climate, 9(4), pp.676-705. + + !---Sellers, P.J., Tucker, C.J., Collatz, G.J., Los, S.O., Justice, C.O., + ! Dazlich, D.A. and Randall, D.A., 1996. A revised land surface + ! parameterization (SiB2) for atmospheric GCMs. Part II: The generation of + ! global fields of terrestrial biophysical parameters from satellite data. + ! Journal of climate, 9(4), pp.706-737. + + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + !---2024.04.16 Hua Yuan: add option to account for vegetation snow process based on Niu et al., 2004 + !---2023.02.21 Zhongwang Wei @ SYSU : Snow and rain interception + !---2021.12.08 Zhongwang Wei @ SYSU + !---2019.06 Hua Yuan: remove sigf and USE lai+sai for judgement. + !---2014.04 Yongjiu Dai + !---2002.08.31 Yongjiu Dai +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler ! irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: bifall !bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + +!----------------------------------------------------------------------- + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + satcap = dewmx*vegt + satcap_rain = satcap + satcap_snow = 6.6*(0.27+46./bifall)*vegt ! Niu et al., 2004 + satcap_snow = 48.*satcap ! Simple one without snow density input + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain + prc_snow)*deltim + ppl = (prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + IF (tleaf > tfrz) THEN + xsc_rain = max(0., ldew-satcap) + xsc_snow = 0. + ELSE + xsc_rain = 0. + xsc_snow = max(0., ldew-satcap) + ENDIF + + ldew = ldew - (xsc_rain + xsc_snow) + + !TODO-done: account for vegetation snow + IF ( DEF_VEG_SNOW ) THEN + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + ldew_rain = ldew_rain - xsc_rain + ldew_snow = ldew_snow - xsc_snow + ldew = ldew_rain + ldew_snow + ENDIF + + ap = pcoefs(2,1) + cp = pcoefs(2,2) + + IF (p0 > 1.e-8) THEN + ap = ppc/p0 * pcoefs(1,1) + ppl/p0 * pcoefs(2,1) + cp = ppc/p0 * pcoefs(1,2) + ppl/p0 * pcoefs(2,2) + + !---------------------------------------------------------------------- + ! proportional saturated area (xs) and leaf drainage(tex) + !----------------------------------------------------------------------- + chiv = chil + IF ( abs(chiv) .le. 0.01 ) chiv = 0.01 + aa1 = 0.5 - 0.633 * chiv - 0.33 * chiv * chiv + bb1 = 0.877 * ( 1. - 2. * aa1 ) + exrain = aa1 + bb1 + + ! coefficient of interception + ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) + ! assume alpha_rain = alpha_snow + alpha_rain = 0.25 + fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) + + xs = 1. + IF (p0*fpi>1.e-9) THEN + arg = (satcap-ldew)/(p0*fpi*ap) - cp/ap + IF (arg>1.e-9) THEN + xs = -1./bp * log( arg ) + xs = min( xs, 1. ) + xs = max( xs, 0. ) + ENDIF + ENDIF + + ! assume no fall down of the intercepted snowfall in a time step + ! drainage + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + - max(0., (satcap-ldew)) * xs + tex_rain = max( tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + tex_snow = 0. + + ! 04/11/2024, yuan: + !TODO-done: account for snow on vegetation, + IF ( DEF_VEG_SNOW ) THEN + + ! re-calculate leaf rain drainage using ldew_rain + + xs = 1. + IF (p0*fpi>1.e-9) THEN + arg = (satcap_rain-ldew_rain)/(p0*fpi*ap) - cp/ap + IF (arg>1.e-9) THEN + xs = -1./bp * log( arg ) + xs = min( xs, 1. ) + xs = max( xs, 0. ) + ENDIF + ENDIF + + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + - max(0., (satcap_rain-ldew_rain)) * xs + tex_rain = max( tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + + ! re-calculate the snow loading rate + + fvegc = 1. - exp(-0.52*lsai) + FP = (ppc + ppl) / (10.*ppc + ppl) + qintr_snow = fvegc * (prc_snow+prl_snow) * FP + qintr_snow = min (qintr_snow, (satcap_snow-ldew_snow)/deltim * (1.-exp(-(prc_snow+prl_snow)*deltim/satcap_snow)) ) + qintr_snow = max (qintr_snow, 0.) + + ! snow unloading rate + + FT = max(0.0, (tleaf - tfrz) / 1.87e5) + FV = sqrt(forc_us*forc_us + forc_vs*forc_vs) / 1.56e5 + tex_snow = max(0., ldew_snow/deltim) * (FV+FT) + tti_snow = (1.0-fvegc)*(prc_snow+prl_snow) + (fvegc*(prc_snow+prl_snow) - qintr_snow) + + ! rate -> mass + + tti_snow = tti_snow * deltim + tex_snow = tex_snow * deltim + ENDIF + +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10 .and. .not.DEF_VEG_SNOW) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ',ldew,tex_rain,tex_snow,tti_rain,tti_snow,p0 + ENDIF +#endif + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + !TODO-done: IF DEF_VEG_SNOW, update ldew_rain, ldew_snow + IF ( DEF_VEG_SNOW ) THEN + ldew_rain = ldew_rain + (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - thru_rain + ldew_snow = ldew_snow + (prc_snow+prl_snow)*deltim - thru_snow + ldew = ldew_rain + ldew_snow + ENDIF + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code: ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap + CALL abort + ENDIF + + IF (DEF_VEG_SNOW .and. abs(ldew-ldew_rain-ldew_snow) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code when DEF_VEG_SNOW: ' + write(6,*) ldew, ldew_rain, ldew_snow + CALL abort + ENDIF +#endif + + ELSE + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + + ENDIF + + END SUBROUTINE LEAF_interception_CoLM2014 + + SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,& + qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Calculation of interception and drainage of precipitation (under development) + ! the scheme developed by Zhongwang wei @ SYSU (not finished yet) + +!Original Author: +!------------------- + !---Zhongwang Wei @ SYSU + +!References: +!------------------- + !---Zhong, F., Jiang, S., van Dijk, A.I., Ren, L., Schellekens, J. and Miralles, D.G., 2022. + ! Revisiting large-scale interception patterns constrained by a synthesis of global experimental + ! data. Hydrology and Earth System Sciences, 26(21), pp.5647-5667. + !--- + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + !---2023.04.30 Zhongwang Wei @ SYSU : Snow and rain interception +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler ! irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + satcap = dewmx*vegt + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + + IF (tleaf > tfrz) THEN + xsc_rain = max(0., ldew-satcap) + xsc_snow = 0. + ELSE + xsc_rain = 0. + xsc_snow = max(0., ldew-satcap) + ENDIF + ldew = ldew - (xsc_rain + xsc_snow) + + ap = pcoefs(2,1) + cp = pcoefs(2,2) + + IF (p0 > 1.e-8) THEN + ap = ppc/p0 * pcoefs(1,1) + ppl/p0 * pcoefs(2,1) + cp = ppc/p0 * pcoefs(1,2) + ppl/p0 * pcoefs(2,2) + !---------------------------------------------------------------------- + ! proportional saturated area (xs) and leaf drainage(tex) + !----------------------------------------------------------------------- + chiv = chil + IF ( abs(chiv) .le. 0.01 ) chiv = 0.01 + aa1 = 0.5 - 0.633 * chiv - 0.33 * chiv * chiv + bb1 = 0.877 * ( 1. - 2. * aa1 ) + exrain = aa1 + bb1 + + ! coefficient of interception + ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) + alpha_rain = 0.25 + fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) + + xs = 1. + IF (p0*fpi>1.e-9) THEN + arg = (satcap-ldew)/(p0*fpi*ap) - cp/ap + IF (arg>1.e-9) THEN + xs = -1./bp * log( arg ) + xs = min( xs, 1. ) + xs = max( xs, 0. ) + ENDIF + ENDIF + + ! assume no fall down of the intercepted snowfall in a time step drainage + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + - max(0., (satcap-ldew)) * xs + tex_rain = max( tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + tex_snow = 0. + +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + + ELSE + ! all intercepted by canopy leves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap + CALL abort + ENDIF + + CALL check_interception_balance('CoLM202x', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! 07/15/2023, Hua Yuan: bug found for ldew value reset when vegetation disappears + ! Yuan's fix: Release canopy water based on temperature + ! Note: CoLM202x doesn't separate rain/snow storage, so temperature-based + ! release is appropriate (no phase conservation issue for unified storage) + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_CoLM202x + + SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Canopy interception following CLM4.5 official implementation + ! - Interception efficiency: fpi = 0.25*(1-exp(-0.5*LSAI)) + ! - Drainage method: Simple bucket overflow (when storage exceeds capacity) + ! - Verified against CLM4.5 source code: CTSM-clm4_5_18_r272/src_clm40/biogeophys/Hydrology1Mod.F90 + ! + ! Key features: + ! - No pre-drainage step (unlike some earlier CoLM versions) + ! - No spatial heterogeneity consideration (uniform canopy capacity) + ! - Immediate overflow drainage when capacity is exceeded + +!Original Author: +!------------------- + !Lawrence, D.M. + +!References: +!------------------- + !---Lawrence, D.M., Thornton, P.E., Oleson, K.W. and Bonan, G.B., 2007. + ! The partitioning of evapotranspiration into transpiration, soil evaporation, + ! and canopy evaporation in a GCM: Impacts on land-atmosphere interaction. Journal of Hydrometeorology, 8(4), pp.862-880. + !---Oleson, K.W., Lawrence, D.M., Bonan, G.B., Drewniak, B., Huang, M., Koven, C.D., Levis, S., Li, F., Riley, W.J., Subin, Z.M. and Swenson, S.C., 2013. + ! Technical description of version 4.5 of the Community Land Model (CLM). NCAR Technical Note NCAR/TN-503+ STR. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2023.02.21 Zhongwang Wei @ SYSU : Snow and rain interception + ! 2021.12.08 Zhongwang Wei @ SYSU + ! 2014.04 Yongjiu Dai + ! 2002.08.31 Yongjiu Dai +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + satcap = dewmx*vegt + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + + IF (tleaf > tfrz) THEN + xsc_rain = max(0., ldew-satcap) + xsc_snow = 0. + ELSE + xsc_rain = 0. + xsc_snow = max(0., ldew-satcap) + ENDIF + + ldew = ldew - (xsc_rain + xsc_snow) + + IF (p0 > 1.e-8) THEN + exrain =0.5 + ! coefficient of interception + ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) + alpha_rain = 0.25 + fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) + + ! assume no fall down of the intercepted snowfall in a time step + ! drainage + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi + ldew - satcap + tex_rain = max(tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + tex_snow = 0. + +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap + CALL abort + ENDIF +#endif + + ELSE + ! 07/15/2023, yuan: #bug found for ldew value reset. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + + END SUBROUTINE LEAF_interception_CLM4 + + SUBROUTINE LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,& + qintr,qintr_rain,qintr_snow) + +!DESCRIPTION +!=========== + ! Canopy interception following CLM5.0 official implementation + ! - Separate treatment for rain and snow interception + ! - Rain interception: fpi = tanh(LSAI) [or 0.25*(1-exp(-0.5*LSAI))] + ! - Snow interception: fpi = 1-exp(-0.5*LSAI) + ! - Liquid water capacity: 0.1*(LAI+SAI) mm + ! - Snow capacity: 6.0*(LAI+SAI) mm + ! - Simple bucket overflow drainage based on temperature + ! - Snow unloading due to wind and temperature + ! - Verified against CLM5 source: CanopyHydrologyMod.F90 + ! + ! Key features: + ! - No pre-drainage step (fixed from earlier version) + ! - Drainage based on storage, not interception (critical fix) + ! - Temperature-dependent rain/snow drainage + ! - Physics-based snow unloading + +!Original Author: +!------------------- + !Lawrence, D.M. + +!References: +!------------------- + !---Lawrence, D.M., Thornton, P.E., Oleson, K.W. and Bonan, G.B., 2007. + ! The partitioning of evapotranspiration into transpiration, soil evaporation, + ! and canopy evaporation in a GCM: Impacts on land-atmosphere interaction. Journal of Hydrometeorology, 8(4), pp.862-880. + !---Lawrence, D.M., Fisher, R.A., Koven, C.D., Oleson, K.W., Swenson, S.C., Bonan, G., Collier, N., Ghimire, B., + ! van Kampenhout, L., Kennedy, D. and Kluzek, E., 2019. The Community Land Model version 5: + ! Description of new features, benchmarking, and impact of forcing uncertainty. + ! Journal of Advances in Modeling Earth Systems, 11(12), pp.4245-4287. + !---Fan, Y., Meijide, A., Lawrence, D.M., Roupsard, O., Carlson, K.M., Chen, H.Y., + ! Röll, A., Niu, F. and Knohl, A., 2019. Reconciling canopy interception parameterization + ! and rainfall forcing frequency in the Community Land Model for simulating evapotranspiration + ! of rainforests and oil palm plantations in Indonesia. Journal of Advances in Modeling Earth Systems, 11(3), pp.732-751. + + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + real(r8) :: xsnorun, xliqrun,qflx_prec_intr_rain,qflx_prec_intr_snow + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + + ! Ensure ldew is consistent with components at entry + ! CLM5 operates on ldew_rain/ldew_snow and sets ldew = ldew_rain + ldew_snow at exit + ! At entry from initialization or restart, ldew may be inconsistent + ldew = ldew_rain + ldew_snow + + w = ldew+p0 ! For mass balance check + + ! Canopy capacity - CLM5 official values + ! Verified against CanopyHydrologyMod.F90 lines 320, 329-330 + satcap_rain = dewmx*vegt ! liquid water capacity = 0.1*(LAI+SAI) + satcap_snow = satcap_rain*60.0 ! snow capacity = 6.0*(LAI+SAI) + + IF(p0 > 1.e-8) THEN + ! Interception efficiency - CLM5 formulas + ! Rain: CLM5 line 323 (tanh option) or line 325 (exponential option) + ! Snow: CLM5 line 332 + ! Note: CoLM uses tanh for rain; CLM5 default is exponential (CLM4.5) + alpha_rain = 1.0 + alpha_snow = 1.0 + fpi_rain = alpha_rain * tanh(lsai) + fpi_snow = alpha_snow * ( 1.-exp(-0.5*lsai) ) + + ! Direct throughfall - CLM5 lines 334, 337, 341 + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi_rain ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi_snow ) + + ! Intercepted precipitation - CLM5 line 345 + qflx_prec_intr_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi_rain + qflx_prec_intr_snow = (prc_snow+prl_snow)*deltim * fpi_snow + + ! Water storage of intercepted precipitation - CLM5 lines 347-348 + ! Add interception to storage BEFORE calculating drainage + ldew_rain = max(0., ldew_rain + qflx_prec_intr_rain) + ldew_snow = max(0., ldew_snow + qflx_prec_intr_snow) + + ! Initialize drainage + tex_rain = 0. + tex_snow = 0. + unl_snow = 0. + + ! Snow unloading due to wind and temperature - CLM5 lines ~420-450 + ! (in CLM5 this is in separate unloading section, but physics is same) + IF(ldew_snow > 1.e-8) THEN + U10 = sqrt(forc_us*forc_us+forc_vs*forc_vs) + unl_snow_temp = ldew_snow*(tleaf-tfrz)/(1.87*1.e5) + unl_snow_temp = max(unl_snow_temp,0.0) + unl_snow_wind = U10*ldew_snow/(1.56*1.e5) + unl_snow_wind = max(unl_snow_wind,0.0) + unl_snow = unl_snow_temp+unl_snow_wind + unl_snow = min(unl_snow,ldew_snow) + ldew_snow = ldew_snow - unl_snow + ENDIF + + ! Simple bucket overflow drainage - CLM5 lines 367-379 + ! Separate handling for rain and snow based on temperature + IF (tleaf > tfrz) THEN + ! Above freezing: liquid water drainage + xliqrun = max(0., (ldew_rain - satcap_rain)/deltim) + IF (xliqrun > 0.) THEN + tex_rain = xliqrun * deltim + ldew_rain = satcap_rain + ENDIF + ELSE + ! Below freezing: snow falling off canopy + xsnorun = max(0., (ldew_snow - satcap_snow)/deltim) + IF (xsnorun > 0.) THEN + tex_snow = xsnorun * deltim + ldew_snow = satcap_snow + ENDIF + ENDIF + + ELSE + ! No precipitation - no interception or drainage + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + unl_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! Total water reaching ground and interception + !---------------------------------------------------------------------- + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + unl_snow + ldew = ldew_rain + ldew_snow + + pg_rain = thru_rain / deltim + pg_snow = thru_snow / deltim + qintr = (p0 - thru_rain - thru_snow) / deltim + qintr_rain = (prc_rain + prl_rain + qflx_irrig_sprinkler) - thru_rain / deltim + qintr_snow = (prc_snow + prl_snow) - thru_snow / deltim + +#if (defined CoLMDEBUG) + ! Mass balance check + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Mass balance error in CLM5 interception:' + write(6,*) 'Error:', w, 'ldew:', ldew, 'outflow:', (pg_rain+pg_snow)*deltim + write(6,*) 'satcap_rain:', satcap_rain, 'satcap_snow:', satcap_snow + CALL abort + ENDIF + + CALL check_interception_balance('CLM5', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! 07/15/2023, Hua Yuan: bug found for ldew value reset when vegetation disappears + ! 2026-01-16 improvement: Maintain phase conservation for rain/snow separated schemes + ! Yuan's original fix released water based on temperature, which violates phase conservation + ! for schemes that separate rain and snow storage (ldew_rain vs ldew_snow) + ! + ! Yuan's original code (2023-07-15): + ! IF (ldew > 0.) THEN + ! IF (tleaf > tfrz) THEN + ! pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + ! pg_snow = prc_snow + prl_snow + ! ELSE + ! pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ! pg_snow = prc_snow + prl_snow + ldew/deltim + ! ENDIF + ! ELSE + ! pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ! pg_snow = prc_snow + prl_snow + ! ENDIF + ! + ! Improved version: Release liquid and solid water separately to preserve phase states + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + + END SUBROUTINE LEAF_interception_CLM5 + + SUBROUTINE LEAF_interception_NOAHMP(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Interception and drainage of precipitation + ! the treatment are modified from Noah-MP 5.0 + +!Original Author: +!------------------- + !---Guo-Yue Niu + +!References: +!------------------- + !---Yang, M., Zuo, R., Li, X. and Wang, L., 2019. Improvement test for the canopy interception parameterization scheme + ! in the community land model. Sola, 15, pp.166-171. + !---Niu, G.Y., Yang, Z.L., Mitchell, K.E., Chen, F., Ek, M.B., Barlage, M., Kumar, A., + ! Manning, K., Niyogi, D., Rosero, E. and Tewari, M., 2011. The community Noah land + ! surface model with multiparameterization options (Noah‐MP): 1. Model description and evaluation + ! with local‐scale measurements. Journal of Geophysical Research: Atmospheres, 116(D12). + !---He, C., Valayamkunnath, P., Barlage, M., Chen, F., Gochis, D., Cabell, R., Schneider, T., + ! Rasmussen, R., Niu, G.Y., Yang, Z.L. and Niyogi, D., 2023. Modernizing the open-source + ! community Noah-MP land surface model (version 5.0) with enhanced modularity, + ! interoperability, and applicability. EGUsphere, 2023, pp.1-31. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added input clamping, comment fixes + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid (frozen) on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + ! Local variables + real(r8) :: PrecipAreaFrac !fraction of gridcell receiving precipitation [-] + real(r8) :: BDFALL + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + ! Calculate vegetation fraction from LAI (alternative to input VegFrac) + fvegc=max(0.05,1.0-exp(-0.52*lsai)) + + ! Maximum canopy water - Noah-MP lines 82, 105 + ! Note: Official Noah-MP uses VegFrac as input variable + ! CoLM uses fvegc calculated from LAI, which is also physically reasonable + satcap_rain = fvegc * dewmx*vegt + BDFALL = 67.92+51.25*EXP(MIN(2.5,(tleaf-273.15))/2.59) + satcap_snow = fvegc * 6.6*(0.27+46./BDFALL) * lsai + satcap_snow = max(0.0,satcap_snow) + + ! Input clamping: prevent negative precipitation (numerical noise) + ! from causing mass balance failures + p0 = MAX(0.0_r8, prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler) * deltim + ppc = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl = MAX(0.0_r8, p0 - ppc) + + ! Estimate PrecipAreaFrac based on precipitation type - Noah-MP line 47 + ! Convective precipitation typically covers ~10% of gridcell + ! Stratiform precipitation typically covers ~100% of gridcell + IF (p0 > 1.e-8) THEN + PrecipAreaFrac = (0.1*ppc + 1.0*ppl) / p0 + PrecipAreaFrac = max(0.1, min(1.0, PrecipAreaFrac)) ! constrain to [0.1, 1.0] + ELSE + PrecipAreaFrac = 1.0 + ENDIF + + ! Ensure ldew is consistent with components at entry + ! NoahMP modifies ldew in-place; if ldew != ldew_rain + ldew_snow + ! at entry (e.g., from initialization or restart), mass balance drifts + ldew = ldew_rain + ldew_snow + + w = ldew+p0 + + ! Initialize excess water variables + xsc_rain = 0.0 + xsc_snow = 0.0 + + !snow unloading - Noah-MP lines 113-120 + IF (ldew_snow>1.e-8) THEN + FT = MAX(0.0,(tair - 270.15) / 1.87E5) + FV = SQRT(forc_us*forc_us + forc_vs*forc_vs) / 1.56E5 + ICEDRIP = MAX(0.,ldew_snow) * (FV+FT) !MB: removed /DT + ICEDRIP = MIN(ICEDRIP,ldew_snow) + xsc_snow = xsc_snow+ICEDRIP + ldew_snow = ldew_snow - ICEDRIP + ENDIF + + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + ! Resync ldew with components after phase change (CoLM2014 pattern) + ldew = ldew_rain + ldew_snow + + IF (p0 > 1.e-8) THEN + + ! Throughfall: direct precipitation through vegetation gaps - Noah-MP lines 91, 119 + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fvegc ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fvegc ) + + ! Interception and drip calculation - Noah-MP lines 86-90, 109-118 + ! Interception rate [mm/s] + int_rain = fvegc * (prc_rain+prl_rain+qflx_irrig_sprinkler) * PrecipAreaFrac ! max interception capability + int_rain = min(int_rain, (satcap_rain-ldew_rain)/deltim * & + (1.0-exp(-(prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim/satcap_rain))) + int_rain = max(0., int_rain) + + int_snow = fvegc * (prc_snow+prl_snow) * PrecipAreaFrac ! max interception capability + int_snow = min(int_snow, (satcap_snow-ldew_snow)/deltim * & + (1.0-exp(-(prc_snow+prl_snow)*deltim/satcap_snow))) + int_snow = max(0., int_snow) + + ! Drip: excess precipitation on vegetation that cannot be intercepted + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*fvegc*deltim - int_rain*deltim + tex_snow = (prc_snow+prl_snow)*fvegc*deltim - int_snow*deltim +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !BDFALL = 67.92+51.25*EXP(MIN(2.5,(SFCTMP-TFRZ))/2.59) + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + + ! Update rain/snow components following CoLM2014 pattern (lines 322-324) + ldew_rain = ldew_rain + (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - thru_rain + ldew_snow = ldew_snow + (prc_snow+prl_snow)*deltim - thru_snow + ldew = ldew_rain + ldew_snow + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL abort + ENDIF + + CALL check_interception_balance('NoahMP', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! 07/15/2023, Hua Yuan: bug found for ldew value reset when vegetation disappears + ! Release canopy water separately by phase to preserve phase conservation + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + + ENDIF + + END SUBROUTINE LEAF_interception_NOAHMP + + + SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,& + qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Interception and drainage of precipitation + ! the treatment are modified from MATSIRO 6 (under development) + +!Original Author: +!------------------- + !---MATSIRO6 document writing team∗ + +!References: +!------------------- + !---Tatebe, H., Ogura, T., Nitta, T., Komuro, Y., Ogochi, K., Takemura, T., Sudo, K., Sekiguchi, M., + ! Abe, M., Saito, F. and Chikira, M., 2019. Description and basic evaluation of simulated mean state, + ! internal variability, and climate sensitivity in MIROC6. Geoscientific Model Development, 12(7), pp.2727-2765. 116(D12). + !---Takata, K., Emori, S. and Watanabe, T., 2003. Development of the minimal advanced treatments of surface interaction and + ! runoff. Global and planetary Change, 38(1-2), pp.209-222. + !---Guo, Q., Kino, K., Li, S., Nitta, T., Takeshima, A., Suzuki, K.T., Yoshida, N. and Yoshimura, K., 2021. + ! Description of MATSIRO6. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added input clamping, comment fixes + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid (frozen) on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + !local + real(r8) :: fint, Ac, dewmx_MATSIRO,ldew_rain_s, ldew_snow_s,ldew_rain_n, ldew_snow_n + real(r8) :: tex_rain_n,tex_rain_s,tex_snow_n,tex_snow_s,tti_rain_n,tti_rain_s,tti_snow_n,tti_snow_s + + !the canopy water capacity per leaf area index is set to 0.2mm + dewmx_MATSIRO = 0.2 + !the fraction of the convective precipitation area is assumed to be uniform (0.1) + Ac = 0.1 + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + ! Input clamping: prevent negative precipitation (numerical noise) + ! from causing mass balance failures + p0 = MAX(0.0_r8, prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler) * deltim + ppc = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl = MAX(0.0_r8, p0 - ppc) + + satcap_rain = dewmx_MATSIRO*vegt + satcap_snow = dewmx_MATSIRO*vegt + + ! Ensure ldew is consistent with components at entry + ! MATSIRO modifies ldew in-place; inconsistency at entry propagates to output + ldew = ldew_rain + ldew_snow + + w = ldew+p0 + + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + ! Resync ldew with components after phase change (CoLM2014 pattern) + ldew = ldew_rain + ldew_snow + + IF (p0 > 1.e-8) THEN + ! Interception efficiency - MATSIRO formulation + ! MATSIRO uses simple linear saturation following Takata et al. (2003) + ! Reference: Takata, K., Emori, S., and Watanabe, T. (2003). "Development of the + ! minimal advanced treatments of surface interaction and runoff", Global and + ! Planetary Change, 38, 209-222, doi:10.1016/S0921-8181(03)00030-4 + ! Verified against official MATSIRO source code (matsiro.f90): + ! fctint = min(grlai(ud), 1.d0) + ! When LAI+SAI ≤ 1: efficiency equals LAI+SAI + ! When LAI+SAI > 1: efficiency saturates at 100% + fpi_rain = min(1.0, lai+sai) + fpi_snow = min(1.0, lai+sai) + + !----------------------------------------------------------------------- + ! Storm area + !----------------------------------------------------------------------- + ldew_rain_s = ldew_rain + ((prl_rain+qflx_irrig_sprinkler) * fpi_rain + prc_rain * fpi_rain / Ac) * deltim + ldew_snow_s = ldew_snow + (prl_snow * fpi_snow + prc_snow * fpi_snow / Ac) * deltim + ! + tti_rain_s = (prl_rain+qflx_irrig_sprinkler + prc_rain/Ac) * (1.d0-fpi_rain) * deltim + tti_snow_s = (prl_snow + prc_snow/Ac) * (1.d0-fpi_snow) * deltim + + ! + ! Rutter exponential drainage formula (Rutter et al. 1975) + ! tex = overflow + k1 * exp(k2 * storage) + ! + ! Physical constants from Rutter et al. (1975): + ! - cwb_adrp1 = 1.14e-11 [m/s]: Base dripping coefficient + ! Represents minimum drainage rate when canopy is near saturation + ! - cwb_adrp2 = 3.7e3 [1/m]: Exponential saturation factor + ! Controls how rapidly drainage increases with storage + ! Higher values = more sensitive to storage amount + ! - min(50.0, ...): Overflow protection to prevent EXP(large_number) + ! Caps exponent at 50 to avoid numerical overflow + ! (exp(50) ≈ 5e21, near double precision limit) + ! + ! Unit conversion: 1.14e-11 [m/s] × 1000 [mm/m] = 1.14e-8 [mm/s] + ! + tex_rain_s = max(ldew_rain_s - satcap_rain, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_rain_s,satcap_rain)/1000.* 3.7d3)) + tex_rain_s = min(tex_rain_s, ldew_rain_s) + ldew_rain_s = ldew_rain_s - tex_rain_s + + ! Snow drainage using same Rutter formula (see rain drainage comments above) + tex_snow_s = max(ldew_snow_s - satcap_snow, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_snow_s,satcap_snow)/1000.0* 3.7d3)) + tex_snow_s = min(tex_snow_s, ldew_snow_s) + ldew_snow_s = ldew_snow_s - tex_snow_s + + !------------------------------------------------------------------------- + ! Non-storm area + !------------------------------------------------------------------------- + ldew_rain_n = ldew_rain + (prl_rain+qflx_irrig_sprinkler) * fpi_rain * deltim + ldew_snow_n = ldew_snow + prl_snow * fpi_snow * deltim + + ! + tti_rain_n = (prl_rain+qflx_irrig_sprinkler) * (1.d0-fpi_rain) * deltim + tti_snow_n = (prl_snow) * (1.d0-fpi_snow) * deltim + + ! Rutter drainage for non-storm area (same formula as storm area) + tex_rain_n = max(ldew_rain_n - satcap_rain, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_rain_n,satcap_rain)/1000.* 3.7d3)) + tex_rain_n = min(tex_rain_n, ldew_rain_n) + ldew_rain_n = ldew_rain_n - tex_rain_n + + ! Snow drainage for non-storm area (same Rutter formula) + tex_snow_n = max(ldew_snow_n - satcap_snow, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_snow_n,satcap_snow)/1000.* 3.7d3)) + tex_snow_n = min(tex_snow_n, ldew_snow_n) + ldew_snow_n = ldew_snow_n - tex_snow_n + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! Average + !------------------------------------------------------------------------- + ldew_rain = ldew_rain_n + (ldew_rain_s - ldew_rain_n) * Ac + ldew_snow = ldew_snow_n + (ldew_snow_s - ldew_snow_n) * Ac + ldew_rain = max(0.0,ldew_rain) + ldew_snow = max(0.0,ldew_snow) + + tti_rain = tti_rain_n*(1-Ac)+tti_rain_s*Ac + tti_snow = tti_snow_n+(tti_snow_s-tti_snow_n) * Ac + tti_rain = max(0.0,tti_rain) + tti_snow = max(0.0,tti_snow) + + tex_rain = tex_rain_n+(tex_rain_s-tex_rain_n)*Ac + tex_snow = tex_snow_n+(tex_snow_s-tex_snow_n)*Ac + tex_rain = max(0.0,tex_rain) + tex_snow = max(0.0,tex_snow) + !------------------------------------------------------------------------- + +! NOTE: The check "tex+tti > p0" is not applicable to MATSIRO scheme. +! Rutter exponential drainage drains pre-existing canopy water (ldew), +! so tex+tti can legitimately exceed p0. The real mass balance check +! is performed below (w residual check with abort). + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !BDFALL = 67.92+51.25*EXP(MIN(2.5,(SFCTMP-TFRZ))/2.59) + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + + ! Resync ldew with components following CoLM2014 pattern (line 324) + ! In the precip case, ldew_rain/ldew_snow were updated via weighted average + ! In the no-precip case, they remain at post-phase-change values (tiny p0 < 1e-8 ignored) + ldew = ldew_rain + ldew_snow + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL abort + ENDIF + + CALL check_interception_balance('MATSIRO', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! No vegetation: all precipitation passes through, release any stored water + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_MATSIRO + + SUBROUTINE LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Calculation of interception and drainage of precipitation + ! the treatment are based on VIC 5.0 (under development) + +!Original Author: +!------------------- + !---Hamman, J.J. AND Liang X. + +!References: +!------------------- + !---Hamman, J.J., Nijssen, B., Bohn, T.J., Gergel, D.R. and Mao, Y., 2018. + ! The Variable Infiltration Capacity model version 5 (VIC-5): Infrastructure + ! improvements for new applications and reproducibility. Geoscientific Model Development, + ! 11(8), pp.3481-3496. + !---Liang, X., Lettenmaier, D.P., Wood, E.F. and Burges, S.J., 1994. + ! A simple hydrologically based model of land surface water and energy fluxes + ! for general circulation models. Journal of Geophysical Research: Atmospheres, 99(D7), + ! pp.14415-14428. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added input clamping, comment fixes + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid (frozen) on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + real(r8) :: Imax1,Lr,Snow,Rain,DeltaSnowInt,Wind,BlownSnow,sigf_safe + real(r8) :: MaxInt,Overload,IntRainFract,IntSnowFract,ldew_smelt,MaxWaterInt + + IF (lai+sai > 1e-6 .and. sigf > 1.e-6) THEN + lsai = lai + sai + vegt = lsai + + ! Ensure ldew is consistent with components at entry (grid-scale) + ! VIC sets ldew = ldew_rain + ldew_snow at exit; inconsistency at entry + ! from initialization or restart causes mass balance check to fail + ldew = ldew_rain + ldew_snow + + ! VIC vegetation fraction handling (snow_intercept.c line 132-133) + ! Convert grid-scale storage to per-vegetation values + ! Physical meaning: Storage variables represent water on vegetated fraction only + IF (sigf > 1.e-6) THEN + sigf_safe = max(sigf, 0.01) + ldew_rain = ldew_rain / sigf_safe + ldew_snow = ldew_snow / sigf_safe + ENDIF + + !the maximum bearing capacity of the tree regardless of air temp (Imax1) + Imax1=4.0*lsai*0.0005 *1000.0 ! in mm + MaxInt=0.1*lsai + IF (tair>-272.15) THEN + Lr=4.0 + ELSEIF (tair<=-272.15 .and. tair>=-270.15) THEN + Lr=1.5*(tair-273.15)+5.5 + ELSE + Lr=1.0 + ENDIF + + satcap_snow=0.0005 *Lr *lsai * 1000.0 ! in mm !!! + !/* Calculate total liquid water capacity on branches and in intercepted snow */ + ! VIC physical design: Total liquid water capacity includes two components: + ! 1. Liquid water held in snow matrix (mature/ripe snow at 0°C) + ! 2. Liquid water on leaf surfaces + ! + ! Physical basis: Intercepted snow is a porous medium that can retain liquid water + ! in its interstitial spaces when it reaches 0°C (mature/ripe snow state). + ! This is a fundamental concept in snow hydrology (Colbeck 1972, Jordan 1991). + ! + ! Formula: satcap_rain = SNOW_LIQUID_WATER_CAPACITY * ldew_snow + MaxInt + ! - Term 1 (0.035*ldew_snow): Irreducible liquid water content in snow matrix + ! The 0.035 coefficient represents typical irreducible water saturation (~3.5% by mass) + ! This same parameter is used for ground snowpack in VIC (snow_melt.c, ice_melt.c) + ! - Term 2 (MaxInt=0.1*lsai): Liquid water on leaf/branch surfaces + ! + ! Physical meaning: When intercepted snow becomes ripe (0°C), it can simultaneously hold: + ! - Solid ice framework (ldew_snow) + ! - Liquid water in pore spaces (up to 3.5% of snow mass) + ! - Additional liquid water on vegetation surfaces (MaxInt) + ! When snow completely melts (ldew_snow=0), capacity reverts to leaf-only (MaxInt) + ! + ! Reference: Andreadis et al. (2009) "Modeling snow accumulation and ablation + ! processes in forested environments", WRR, doi:10.1029/2008WR007042 + ! + ! Rain capacity = snow matrix water retention + leaf surface capacity + ! When snow melts completely (ldew_snow→0), capacity reverts to just MaxInt + satcap_rain = 0.035 * ldew_snow + MaxInt ! in mm + + ! Input clamping: prevent negative precipitation (numerical noise) + ! from causing mass balance failures + p0 = MAX(0.0_r8, prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler) * deltim + ppc = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl = MAX(0.0_r8, p0 - ppc) + w = ldew+p0 + + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + + ! Note: ldew will be resynced as ldew = ldew_rain + ldew_snow at output (line ~1806) + ! No in-place ldew update needed here (CoLM2014 pattern: resync at end) + + IF (p0 > 1.e-8) THEN + ! VIC physical interception algorithm (snow_intercept.c lines 165-176, 224-236) + ! Snow: Dynamic capacity-based model + ! Rain: Empirical efficiency (CLM5 formulation retained for liquid phase) + + ! Snow interception: VIC physical algorithm + ! Interception efficiency decreases as canopy snow load approaches capacity + ! This prevents unphysical continuous interception when branches are saturated + Snow = (prc_snow+prl_snow)*deltim + IF (satcap_snow > 1.e-6 .and. Snow > 1.e-8) THEN + ! DeltaSnowInt = (1 - IntSnow/MaxSnowInt) * SnowFall + ! Physical meaning: Interception efficiency = available capacity / max capacity + DeltaSnowInt = (1.0 - ldew_snow/satcap_snow) * Snow + + ! Ensure intercepted amount doesn't exceed available capacity + IF (DeltaSnowInt + ldew_snow > satcap_snow) THEN + DeltaSnowInt = satcap_snow - ldew_snow + ENDIF + + ! Ensure non-negative + IF (DeltaSnowInt < 0.0) THEN + DeltaSnowInt = 0.0 + ENDIF + ELSE + DeltaSnowInt = 0.0 + ENDIF + + ! VIC throughfall calculation (snow_intercept.c line 204) + ! Throughfall = vegetation area unintercepted + bare area all + ! Physical meaning: + ! - In vegetated fraction (sigf): only non-intercepted part passes through + ! - In bare fraction (1-sigf): all precipitation passes through + ! + ! Use sigf_safe consistently with the storage scaling above. Mixing sigf_safe + ! for state variables with raw sigf for throughfall creates small residuals + ! in the debug mass-balance check when sigf is very small. + tti_snow = (Snow - DeltaSnowInt) * sigf_safe + Snow * (1.0 - sigf_safe) + ldew_snow = ldew_snow + DeltaSnowInt + + ! Rain interception: Original VIC capacity-based algorithm + ! Physical mechanism: Rain is intercepted based on available canopy storage capacity, + ! not a fixed efficiency function. When capacity is available, rain is intercepted; + ! when saturated, excess drains as throughfall. + ! Reference: Andreadis et al. (2009) WRR, VIC snow_intercept.c lines 218-236 + ! This differs from CLM5's empirical efficiency approach (tanh function) + Rain = (prc_rain+prl_rain+ qflx_irrig_sprinkler)*deltim + MaxWaterInt = satcap_rain ! Capacity already computed at line 1538 + + ! Capacity-based interception (VIC original algorithm) + ! If there is available capacity, intercept rain; otherwise it becomes throughfall + IF (ldew_rain + Rain <= MaxWaterInt) THEN + ! All rain can be intercepted (capacity not exceeded) + ldew_rain = ldew_rain + Rain + ! Throughfall: only bare area contribution + tti_rain = Rain * (1.0 - sigf_safe) + ELSE + ! Capacity exceeded: excess becomes throughfall + ! Throughfall = vegetated area excess + bare area all + tti_rain = (ldew_rain + Rain - MaxWaterInt) * sigf_safe + Rain * (1.0 - sigf_safe) + ! Storage saturated at maximum capacity + ldew_rain = MaxWaterInt + ENDIF + + tex_rain = max(0.0,ldew_rain-satcap_rain) + tex_snow = max(0.0,ldew_snow-satcap_snow) + + ldew_rain = ldew_rain - tex_rain + ldew_snow = ldew_snow - tex_snow + + !unload of snow + !* Reduce the amount of intercepted snow if windy and cold. + !Ringyo Shikenjo Tokyo, #54, 1952. + !Bulletin of the Govt. Forest Exp. Station, + !Govt. Forest Exp. Station, Meguro, Tokyo, Japan. + !FORSTX 634.9072 R475r #54. + !Page 146, Figure 10. + + !Reduce the amount of intercepted snow if snowing, windy, and + !cold (< -3 to -5 C). + !Schmidt and Troendle 1992 western snow conference paper. */ + !Note: Use tair (air temperature) instead of tleaf to match + !the original observations by Storck et al. (2002) + Wind= SQRT(forc_us*forc_us + forc_vs*forc_vs) + IF (tair-273.15<-3.0 .and. Wind> 1.0) THEN + BlownSnow=(0.2*Wind -0.2)* ldew_snow + BlownSnow = min(ldew_snow,BlownSnow) + tex_snow = tex_snow + BlownSnow + ldew_snow = ldew_snow - BlownSnow + ENDIF + !/* at this point we have calculated the amount of snowfall intercepted and + !/* the amount of rainfall intercepted. These values have been + !/* appropriately subtracted from SnowFall and RainFall to determine + !/* SnowThroughfall and RainThroughfall. However, we can end up with the + !/* condition that the total intercepted rain plus intercepted snow is + !/* greater than the maximum bearing capacity of the tree regardless of air + !/* temp (Imax1). The following routine will adjust ldew_rain and ldew_snow + !/* by triggering mass release due to overloading. Of course since ldew_rain + !/* and ldew_snow are mixed, we need to slough them of as fixed fractions */ + IF (ldew_rain + ldew_snow > Imax1) THEN + ! /*THEN trigger structural unloading*/ + Overload = (ldew_snow + ldew_rain) - Imax1 + ! Prevent division by zero in extreme low LAI conditions + IF (ldew_rain + ldew_snow > 1.e-10) THEN + IntRainFract = ldew_rain / (ldew_rain + ldew_snow) + IntSnowFract = 1.0 - IntRainFract + ELSE + ! Default to equal partition when total is negligible + IntRainFract = 0.5 + IntSnowFract = 0.5 + ENDIF + ldew_rain = ldew_rain - Overload * IntRainFract + ldew_snow = ldew_snow - Overload * IntSnowFract + tex_rain = tex_rain + Overload*IntRainFract + tex_snow = tex_snow + Overload*IntSnowFract + ENDIF + +! NOTE: The check "tex+tti > p0" is not applicable to VIC scheme. +! VIC's tex includes drainage of pre-existing canopy water (ldew) from +! capacity overflow, wind unloading, and structural overloading. +! Additionally, tti includes bare-fraction precipitation. +! The real mass balance check is performed below (w residual check with abort). + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + + ! tex_rain/tex_snow are per-vegetation quantities, must scale by sigf_safe + ! to convert to grid-scale before adding to grid-scale tti_rain/tti_snow + thru_rain = tti_rain + tex_rain * sigf_safe + thru_snow = tti_snow + tex_snow * sigf_safe + + ! VIC safety check: When snow completely melts, liquid water capacity + ! reverts from (0.035*ldew_snow + MaxInt) to just (MaxInt) + ! Must drain excess water that can no longer be held + ! Reference: VIC snow_intercept.c lines 522-526 + IF (ldew_snow < 1.e-6 .and. ldew_rain > MaxInt) THEN + thru_rain = thru_rain + (ldew_rain - MaxInt) * sigf_safe + ldew_rain = MaxInt + ENDIF + + ! VIC vegetation fraction handling (snow_intercept.c line 515-520) + ! Convert per-vegetation storage back to grid-scale values + ! Use sigf_safe consistently with the division at entry (line 1534-1535) + IF (sigf > 1.e-6) THEN + ldew_rain = ldew_rain * sigf_safe + ldew_snow = ldew_snow * sigf_safe + ENDIF + + ! Update total canopy water storage (grid-scale) + ldew = ldew_rain + ldew_snow + pinf = p0 - (thru_rain + thru_snow) + + ! xsc_rain/xsc_snow are per-vegetation, scale to grid-scale + pg_rain = (xsc_rain * sigf_safe + thru_rain) / deltim + pg_snow = (xsc_snow * sigf_safe + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL abort + ENDIF + + CALL check_interception_balance('VIC', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! No vegetation: all precipitation passes through, release any stored water + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_VIC + + SUBROUTINE LEAF_interception_JULES(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) + !DESCRIPTION + !=========== + ! Official JULES canopy interception scheme + ! Rain: Rutter (1971) penetration model (sieve_jls_mod.F90) + ! Snow: Exponential saturation model with unloading (canopysnow_mod.F90) + ! + ! 2026-02 Fixes: + ! - Added vegetation fraction (sigf) scaling: interception occurs on vegetated area only. + ! - Added non-negative clamping for precipitation inputs to ensure mass balance. + ! - Fixed mass balance check: ldew resync before sigf division (VIC pattern). + + !Original Author: + !------------------- + !---Rutter et al. (1971, 1975) - Rain interception model + !---JULES team (Best et al. 2011) - Snow interception model + !---Zhongwang Wei @ SYSU - CoLM implementation + + !References: + !------------------- + !---Rutter et al. (1971): A predictive model of rainfall interception in forests, 1. + ! Derivation of the model from observations in a plantation of Corsican pine. + ! Agricultural Meteorology, 9, 367-384. + !---Rutter et al. (1975): A predictive model of rainfall interception in forests, 2. + ! Generalization of the model and comparison with observations in some coniferous + ! and hardwood stands. Journal of Applied Ecology, 12, 367-380. + !---Best et al. (2011): The Joint UK Land Environment Simulator (JULES), model description - + ! Part 1: Energy and water fluxes. Geosci. Model Dev. 4:677-699. + !---Clark et al. (2011): The Joint UK Land Environment Simulator (JULES), model description - + ! Part 2: Carbon fluxes and vegetation dynamics. Geosci. Model Dev. 4:701-722. + + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !REVISION HISTORY + !---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added wind-dependent snow unloading (JULES fidelity D3) + ! 2026.02.11 Zhongwang Wei @ SYSU - Added sigf scaling, input clamping, mass balance fix + ! 2026.01.16 Zhongwang Wei @ SYSU - Converted to official JULES Rutter model + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU + !======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] (unused in JULES; retained for interface compatibility) + real(r8), intent(in) :: forc_us !wind speed [m/s] + real(r8), intent(in) :: forc_vs !wind speed [m/s] + real(r8), intent(in) :: chil !leaf angle distribution factor (unused in JULES) + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] (read-only in JULES) + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid on foliage [mm] + real(r8), intent(in) :: z0m !roughness length (unused in JULES) + real(r8), intent(in) :: hu !forcing height of U (unused in JULES) + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) [NOTE: can be negative during canopy release] + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) [NOTE: can be negative during canopy release] + + ! Local variables + real(r8) :: snowinterceptfact ! Snow interception efficiency (0.7) + real(r8) :: snowunloadfact ! Snow unloading factor due to melt (0.4) + real(r8) :: unload_rate_cnst ! Constant background unloading rate [s⁻¹] + real(r8) :: unload_rate_u ! Wind-dependent unloading rate [s⁻¹/(m/s)] + real(r8) :: unload_backgrnd ! Total background unloading rate [s⁻¹] + real(r8) :: Wind ! Wind speed [m/s] + real(r8) :: area ! Precipitation area fraction + real(r8) :: can_cpy_rain ! Canopy capacity for rain [mm] + real(r8) :: can_cpy_snow ! Canopy capacity for snow [mm] + real(r8) :: r_rain ! Rain rate [mm/s] (clamped, non-negative) + real(r8) :: r_snow ! Snow rate [mm/s] (clamped, non-negative) + real(r8) :: can_ratio ! Canopy saturation ratio (can_wcnt/can_cpy) + real(r8) :: aexp ! Exponential term in Rutter model + real(r8) :: tfall_rain ! Rain throughfall [mm/s] + real(r8) :: tfall_snow ! Snow throughfall [mm/s] + real(r8) :: intercept_rain ! Rain interception in timestep [mm] + real(r8) :: intercept_snow ! Snow interception in timestep [mm] + real(r8) :: unload_snow ! Snow unloading in timestep [mm] + real(r8) :: melt_rate ! Canopy snow melt rate [mm/s] + real(r8) :: melt_factor ! Dimensionless melt energy ratio: CICE/(DENICE*HFUS) + real(r8) :: frz_factor ! Dimensionless freeze energy ratio: CWAT/(DENH2O*HFUS) + real(r8) :: smallp ! Small positive number + real(r8) :: lsai_l ! total LAI+SAI (local) + real(r8) :: p0_l, ppc_l, ppl_l ! precipitation sums (local) + real(r8) :: w_l ! mass balance check variable (local) + real(r8) :: ldew_frzc ! freezing water amount + real(r8) :: xsc_rain, xsc_snow ! excess water drained after phase change + real(r8) :: sigf_safe ! safe vegetation fraction (>= 0.01) + real(r8) :: thru_rain, thru_snow ! grid-scale throughfall [mm] + + IF (lai+sai > 1e-6 .AND. sigf > 1.e-6) THEN + lsai_l = lai + sai + + !====================================================================== + ! Input Clamping (Mass Balance Safety) + !====================================================================== + ! Negative precipitation inputs (numerical noise) cause mass balance failures. + ! Clamp all inputs to 0.0 before any calculations. + r_rain = MAX(0.0_r8, prc_rain + prl_rain + qflx_irrig_sprinkler) + r_snow = MAX(0.0_r8, prc_snow + prl_snow) + + ! Clamp canopy state: negative values from restart or upstream bugs + ! would be amplified by sigf division and cause mass balance abort + ldew_rain = MAX(0.0_r8, ldew_rain) + ldew_snow = MAX(0.0_r8, ldew_snow) + + !====================================================================== + ! JULES Parameters - Official values from JULES source code + !====================================================================== + snowinterceptfact = 0.7 ! Snow interception efficiency (jules_snow_mod.F90) + snowunloadfact = 0.4 ! Snow unloading factor (canopysnow_mod.F90) + unload_rate_cnst = 2.31e-6 ! Constant background unloading rate [s⁻¹] + unload_rate_u = 5.56e-7 ! Wind-dependent unloading rate [s⁻¹/(m/s)] + Wind = SQRT(forc_us**2 + forc_vs**2) + unload_backgrnd = unload_rate_cnst + unload_rate_u * Wind + can_cpy_snow = 4.4 * lsai_l ! Snow capacity [mm] (snowloadlai parameter) + can_cpy_rain = 0.1 * lsai_l ! Rain capacity [mm] (JULES PFT parameter) + smallp = EPSILON(1.0_r8) ! Machine epsilon for numerical stability + + !====================================================================== + ! Precipitation totals and mass balance reference (GRID-SCALE) + !====================================================================== + ! Use clamped rates for consistency + p0_l = (r_rain + r_snow) * deltim + ppc_l = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl_l = p0_l - ppc_l + ! Clamp ppl_l to avoid negative from clamping differences + ppl_l = MAX(0.0_r8, ppl_l) + + IF (p0_l > 1.e-8) THEN + ! Convective precip ~10% of grid, stratiform ~100% of grid + area = (0.1*ppc_l + 1.0*ppl_l) / p0_l + area = max(0.1, min(1.0, area)) + ELSE + area = 1.0 + ENDIF + + ! Ensure ldew is consistent with components at entry (GRID-SCALE) + ! Must be done BEFORE sigf division to keep w_l in grid-scale units + ldew = ldew_rain + ldew_snow + + ! Mass balance reference: grid-scale storage + grid-scale precipitation + w_l = ldew + p0_l + + !====================================================================== + ! Vegetation Fraction Scaling (sigf) + !====================================================================== + ! JULES physics operates on the vegetated area only. + ! Convert grid-averaged storage to per-vegetation values. + ! (Matching VIC pattern: divide before physics, multiply after) + ! Note: outer guard guarantees sigf > 1e-6; floor at 0.01 prevents + ! extreme amplification when sigf is very small but positive. + sigf_safe = max(sigf, 0.01_r8) + ldew_rain = ldew_rain / sigf_safe + ldew_snow = ldew_snow / sigf_safe + + !====================================================================== + ! Phase change (melting/freezing) - Do BEFORE interception + !====================================================================== + ! Pre-compute dimensionless energy ratios to avoid large intermediate + ! products (e.g. CICE*ldew_snow ~1e8) that can trap under -ffpe-trap. + ! melt_factor = CICE / (DENICE * HFUS) ≈ 0.00684 [K⁻¹] + ! frz_factor = CWAT / (DENH2O * HFUS) ≈ 0.01256 [K⁻¹] + melt_factor = CICE / (DENICE * HFUS) + frz_factor = CWAT / (DENH2O * HFUS) + + IF (tleaf > tfrz) THEN + ! Canopy snow melting + IF (ldew_snow > 1.e-8) THEN + melt_rate = MIN(ldew_snow/deltim, & + (tleaf - tfrz) * melt_factor * ldew_snow / deltim) + melt_rate = MAX(melt_rate, 0.0_r8) + ldew_snow = ldew_snow - melt_rate * deltim + ldew_snow = MAX(ldew_snow, 0.0_r8) ! prevent -eps from FP rounding + ldew_rain = ldew_rain + melt_rate * deltim + ELSE + melt_rate = 0.0_r8 + ENDIF + ELSE + ! Canopy rain freezing + IF (ldew_rain > 1.e-8) THEN + ldew_frzc = MIN(ldew_rain, & + (tfrz - tleaf) * frz_factor * ldew_rain) + ldew_frzc = MAX(ldew_frzc, 0.0_r8) + ldew_snow = ldew_snow + ldew_frzc + ldew_rain = ldew_rain - ldew_frzc + ldew_rain = MAX(ldew_rain, 0.0_r8) ! prevent -eps from FP rounding + ENDIF + melt_rate = 0.0_r8 + ENDIF + + !====================================================================== + ! Drain excess water after phase change + ! When snow melts to rain, ldew_rain can greatly exceed can_cpy_rain + ! When rain freezes to snow, ldew_snow can exceed can_cpy_snow + !====================================================================== + xsc_rain = 0.0 + xsc_snow = 0.0 + IF (ldew_rain > can_cpy_rain) THEN + xsc_rain = ldew_rain - can_cpy_rain + ldew_rain = can_cpy_rain + ENDIF + IF (ldew_snow > can_cpy_snow) THEN + xsc_snow = ldew_snow - can_cpy_snow + ldew_snow = can_cpy_snow + ENDIF + + !====================================================================== + ! RAIN INTERCEPTION: Rutter (1971) Penetration Model + ! From JULES sieve_jls_mod.F90 lines 125-142 + !====================================================================== + IF (can_cpy_rain > 0.0 .AND. r_rain > smallp) THEN + ! Exponential term (JULES lines 126-132) + aexp = exp(max(-50.0_r8, -area * can_cpy_rain / (r_rain * deltim))) + + ! Canopy saturation ratio (JULES lines 134-136) + can_ratio = ldew_rain / can_cpy_rain + can_ratio = MAX(0.0, MIN(can_ratio, 1.0)) + + ! Rutter throughfall formula (JULES line 137) + tfall_rain = r_rain * ((1.0 - can_ratio) * aexp + can_ratio) + ELSE + tfall_rain = r_rain + ENDIF + + ! Update canopy water content (JULES line 142) + intercept_rain = (r_rain - tfall_rain) * deltim + ldew_rain = ldew_rain + intercept_rain + + ! Post-Rutter drainage: discrete timestep can overshoot capacity + IF (ldew_rain > can_cpy_rain) THEN + tfall_rain = tfall_rain + (ldew_rain - can_cpy_rain) / deltim + ldew_rain = can_cpy_rain + ENDIF + + !====================================================================== + ! SNOW INTERCEPTION: Exponential Saturation Model with Unloading + ! From JULES canopysnow_mod.F90 lines 131-145 + !====================================================================== + ! Snow unloading occurs regardless of snowfall (continuous process) + unload_snow = snowunloadfact * melt_rate * deltim & + + unload_backgrnd * ldew_snow * deltim + unload_snow = MAX(MIN(unload_snow, ldew_snow), 0.0) + ldew_snow = ldew_snow - unload_snow + + IF (r_snow > smallp) THEN + ! Snow interception (JULES lines 131-132) + intercept_snow = snowinterceptfact * (can_cpy_snow - ldew_snow) * & + (1.0 - EXP(MAX(-50.0_r8, -r_snow * deltim / can_cpy_snow))) + intercept_snow = MAX(0.0, intercept_snow) + + ! Update canopy snow + ldew_snow = ldew_snow + intercept_snow + + ! Snowfall to ground = snowfall - intercepted + unloaded + tfall_snow = r_snow - intercept_snow / deltim + unload_snow / deltim + + ! Post-interception drainage + IF (ldew_snow > can_cpy_snow) THEN + tfall_snow = tfall_snow + (ldew_snow - can_cpy_snow) / deltim + ldew_snow = can_cpy_snow + ENDIF + ELSE + intercept_snow = 0.0 + ! No snowfall, but unloaded snow still reaches ground + tfall_snow = r_snow + unload_snow / deltim + ENDIF + + !====================================================================== + ! Output fluxes: Per-vegetation → Grid-scale (VIC pattern) + !====================================================================== + ! tfall_rain/tfall_snow are per-vegetation throughfall rates [mm/s] + ! xsc_rain/xsc_snow are per-vegetation excess [mm] + ! Combine: vegetated area throughfall + bare ground direct precipitation + + ! Grid-scale throughfall [mm] (for mass balance check) + ! IMPORTANT: Use sigf_safe consistently (not sigf) to ensure exact mass balance + ! When sigf < 0.01, sigf_safe = 0.01 != sigf, mixing them creates a residual + thru_rain = (tfall_rain * deltim + xsc_rain) * sigf_safe + r_rain * deltim * (1.0 - sigf_safe) + thru_snow = (tfall_snow * deltim + xsc_snow) * sigf_safe + r_snow * deltim * (1.0 - sigf_safe) + + ! Convert throughfall to rate [mm/s] + pg_rain = thru_rain / deltim + pg_snow = thru_snow / deltim + + ! Rescale state variables back to grid-averaged + ldew_rain = ldew_rain * sigf_safe + ldew_snow = ldew_snow * sigf_safe + + ! Update total canopy water (grid-scale) + ldew = ldew_rain + ldew_snow + + ! Interception = total input - total output - storage change + ! Using the VIC approach: qintr = (p0 - thru) / deltim + qintr = (p0_l - thru_rain - thru_snow) / deltim + + ! Phase-separated interception rates + ! NOTE: These can be NEGATIVE when pre-existing canopy storage drains + ! (e.g., excess from phase change or prior timestep). Negative values + ! represent net canopy release, not a mass balance error. + ! Algebraic identity: qintr_rain + qintr_snow == qintr (exact). + qintr_rain = r_rain - pg_rain + qintr_snow = r_snow - pg_snow + +#if (defined CoLMDEBUG) + ! Mass balance check: w_l (grid-scale old storage + precip) should equal + ! new grid-scale storage + grid-scale ground flux + w_l = w_l - ldew - (pg_rain + pg_snow) * deltim + IF (abs(w_l) > 1.e-6) THEN + write(6,*) 'JULES interception mass balance error: ', w_l + write(6,*) 'ldew=', ldew, ' pg*dt=', (pg_rain+pg_snow)*deltim + CALL abort + ENDIF + + CALL check_interception_balance('JULES', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + ELSE + ! No vegetation: all precipitation passes through, release any stored water + ! Clamp raw precipitation to prevent negative pg (matching vegetated branch) + pg_rain = MAX(0.0_r8, prc_rain + prl_rain + qflx_irrig_sprinkler) + ldew_rain/deltim + pg_snow = MAX(0.0_r8, prc_snow + prl_snow) + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_JULES + + SUBROUTINE LEAF_interception_wrap(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall, & + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain, & + pg_snow,qintr,qintr_rain,qintr_snow ) +!DESCRIPTION +!=========== + !wrapper for calculation of canopy interception using USGS or IGBP land cover classification + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!Original Author: +!------------------- + !---Shupeng Zhang + +!References: + + +!REVISION HISTORY +!---------------- + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water [mm/s] + real(r8), intent(in) :: bifall !bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of liquid on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + IF (DEF_Interception_scheme==1) THEN + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==2) THEN + CALL LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==3) THEN + CALL LEAF_interception_CLM5(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==4) THEN + CALL LEAF_interception_NoahMP (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==5) THEN + CALL LEAF_interception_matsiro (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + + ELSEIF (DEF_Interception_scheme==6) THEN + CALL LEAF_interception_vic (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + + ELSEIF (DEF_Interception_scheme==7) THEN + CALL LEAF_interception_JULES (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + + ELSEIF (DEF_Interception_scheme==8) THEN + CALL LEAF_interception_colm202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ENDIF + + END SUBROUTINE LEAF_interception_wrap + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) + +! ----------------------------------------------------------------- +! !DESCRIPTION: +! wrapper for calculation of canopy interception for PFTs within a land cover type. +! +! Created by Hua Yuan, 06/2019 +! +! !REVISION HISTORY: +! 2023.02.21 Zhongwang Wei @ SYSU: add different options of canopy interception for PFTs +! +! ----------------------------------------------------------------- + + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_Physical, only: tfrz + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes + USE MOD_Const_PFT + IMPLICIT NONE + + integer, intent(in) :: ipatch !patch index + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: forc_t !air temperature + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: prc_rain !convective ranfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water [mm/s] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + integer i, p, ps, pe +#ifdef CROP + integer :: irrig_flag ! 1 if sprinker, 2 if others +#endif + real(r8) pg_rain_tmp, pg_snow_tmp + + pg_rain_tmp = 0. + pg_snow_tmp = 0. + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + IF (DEF_Interception_scheme==1) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==2) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_clm4 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==3) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_clm5 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==4) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_NoahMP (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==5) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==6) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==7) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_JULES (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==8) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ENDIF + + pg_rain = pg_rain_tmp + pg_snow = pg_snow_tmp + ldew = sum( ldew_p(ps:pe) * pftfrac(ps:pe)) + ldew_rain = sum( ldew_rain_p(ps:pe) * pftfrac(ps:pe)) + ldew_snow = sum( ldew_snow_p(ps:pe) * pftfrac(ps:pe)) + qintr = sum(qintr_p(ps:pe) * pftfrac(ps:pe)) + qintr_rain = sum(qintr_rain_p(ps:pe) * pftfrac(ps:pe)) + qintr_snow = sum(qintr_snow_p(ps:pe) * pftfrac(ps:pe)) + + END SUBROUTINE LEAF_interception_pftwrap +#endif + + SUBROUTINE check_interception_balance(scheme_name, & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) + + ! Validates interception water balance consistency. + ! Called from CoLMDEBUG blocks after each scheme completes. + + character(len=*), intent(in) :: scheme_name + real(r8), intent(in) :: ldew, ldew_rain, ldew_snow + real(r8), intent(in) :: pg_rain, pg_snow + real(r8), intent(in) :: qintr, qintr_rain, qintr_snow + + ! Check A: component consistency (ldew == ldew_rain + ldew_snow) + IF (abs(ldew - (ldew_rain + ldew_snow)) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Component consistency error in ', scheme_name, ':' + write(6,*) 'ldew=', ldew, ' ldew_rain+ldew_snow=', ldew_rain+ldew_snow + write(6,*) 'diff=', ldew - (ldew_rain + ldew_snow) + CALL abort + ENDIF + + ! Check B: non-negativity + IF (ldew < -INTERCEPTION_BALANCE_TOL .or. & + ldew_rain < -INTERCEPTION_BALANCE_TOL .or. & + ldew_snow < -INTERCEPTION_BALANCE_TOL .or. & + pg_rain < -INTERCEPTION_BALANCE_TOL .or. & + pg_snow < -INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Negative value error in ', scheme_name, ':' + write(6,*) 'ldew=', ldew, ' ldew_rain=', ldew_rain, ' ldew_snow=', ldew_snow + write(6,*) 'pg_rain=', pg_rain, ' pg_snow=', pg_snow + CALL abort + ENDIF + + ! Check C: flux consistency (qintr == qintr_rain + qintr_snow) + IF (abs(qintr - (qintr_rain + qintr_snow)) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Flux consistency error in ', scheme_name, ':' + write(6,*) 'qintr=', qintr, ' qintr_rain+qintr_snow=', qintr_rain+qintr_snow + write(6,*) 'diff=', qintr - (qintr_rain + qintr_snow) + CALL abort + ENDIF + + END SUBROUTINE check_interception_balance + +END MODULE MOD_LeafInterception diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 new file mode 100644 index 0000000000..48a3f61941 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 @@ -0,0 +1,1568 @@ +#include + +MODULE MOD_LeafTemperature + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW, & + DEF_VEG_SNOW + USE MOD_SPMD_Task + + IMPLICIT NONE + + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LeafTemperature + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: dewfraction +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE LeafTemperature ( & + ipatch ,ivt ,deltim ,csoilc ,dewmx ,htvp ,& + lai ,sai ,htop ,hbot ,sqrtdi ,effcon ,& + vmax25 ,c3c4 ,slti ,hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,gradm ,binter ,& + extkn ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,thm ,th ,thv ,qm ,& + psrf ,rhoair ,parsun ,parsha ,sabv ,frl ,& + fsun ,thermk ,rstfacsun ,rstfacsha ,gssun ,gssha ,& + po2m ,pco2m ,z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno ,sigf ,etrc ,tg ,qg ,& + rss ,t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& + emg ,tl ,ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + taux ,tauy ,fseng ,fseng_soil ,fseng_snow ,fevpg ,& + fevpg_soil ,fevpg_snow ,cgrnd ,cgrndl ,cgrnds ,tref ,& + qref ,rst ,assim ,respc ,fsenl ,fevpl ,& + etr ,dlrad ,ulrad ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,fh ,fq ,& + rootfr ,& +!Plant Hydraulic variables + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,psi50_sha ,& + psi50_xyl ,psi50_root ,ck ,vegwp ,gs0sun ,gs0sha ,& + assimsun ,etrsun ,assimsha ,etrsha ,& +!Ozone stress variables + o3coefv_sun,o3coefv_sha,o3coefg_sun,o3coefg_sha,& + lai_old ,o3uptakesun,o3uptakesha,forc_ozone ,& +!End ozone stress variables +!WUE stomata model parameter + lambda ,& +!End WUE stomata model parameter + hpbl ,& + qintr_rain ,qintr_snow ,t_precip ,hprl ,dheatl ,smp ,& + hk ,hksati ,rootflux ) + +!======================================================================= +! !DESCRIPTION: +! Foliage energy conservation is given by foliage energy budget equation +! Rnet - Hf - LEf = 0 +! The equation is solved by Newton-Raphson iteration, in which this +! iteration includes the calculation of the photosynthesis and stomatal +! resistance, and the integration of turbulent flux profiles. The +! sensible and latent heat transfer between foliage and atmosphere and +! ground is linked by the equations: +! Ha = Hf + Hg and Ea = Ef + Eg +! +! Original author: Yongjiu Dai, August 15, 2001 +! +! !REVISIONS: +! +! 09/2014, Hua Yuan: imbalanced energy due to T/q adjustment is +! allocated to sensible heat flux. +! +! 10/2017, Hua Yuan: added options for z0, displa, rb and rd +! calculation (Dai, Y., Yuan, H., Xin, Q., Wang, D., +! Shangguan, W., Zhang, S., et al. (2019). Different +! representations of canopy structure—A large source of +! uncertainty in global land surface modeling. Agricultural +! and Forest Meteorology, 269-270, 119-135. +! https://doi.org/10.1016/j.agrformet.2019.02.006 +! +! 10/2019, Hua Yuan: change only the leaf temperature from two-leaf +! to one-leaf (due to large differences may exist between +! sunlit/shaded leaf temperature. +! +! 01/2021, Xingjie Lu and Nan Wei: added plant hydraulic process +! interface. +! +! 01/2021, Nan Wei: added interaction btw prec and canopy. +! +! 05/2023, Shaofeng Liu: add option to call moninobuk_leddy, the +! LargeEddy surface turbulence scheme (LZD2022); make a proper +! update of um. +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: vonkar, grav, hvap, hsub, cpair, stefnc, cpliq, cpice, & + hfus, tfrz, denice, denh2o + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_TurbulenceLEddy + USE MOD_AssimStomataConductance + USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Const_LC, only: z0mr, displar + USE MOD_PlantHydraulic, only:PlantHydraulicStress_twoleaf, getvegwp_twoleaf + USE MOD_Ozone, only: CalcOzoneStress + USE MOD_Qsadv + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: ipatch,ivt + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + htvp ! latent heat of evaporation (/sublimation) [J/kg] + +! vegetation parameters + real(r8), intent(inout) :: & + sai ! stem area index [-] + real(r8), intent(in) :: & + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + htop, &! PFT crown top height [m] + hbot, &! PFT crown bot height [m] + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept +!Ozone WUE stomata model parameter + lambda, &! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + extkn ! coefficient of leaf nitrogen allocation + integer , intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + real(r8), intent(in) :: & ! for plant hydraulic scheme + kmax_sun, &! Plant Hydraulics Parameters + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) + real(r8), intent(inout) :: & + vegwp(1:nvegwcs),&! vegetation water potential + gs0sun, &! maximum stomata conductance of sunlit leaf + gs0sha ! maximum stomata conductance of shaded leaf + +! input variables + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + lai, &! adjusted leaf area index for seasonal variation [-] + parsun, &! par absorbed per unit lai [w/m**2] + parsha, &! par absorbed per unit lai [w/m**2] + sabv, &! solar radiation absorbed by vegetation [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + fsun, &! sunlit fraction of canopy + + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + thermk, &! canopy gap fraction for tir radiation + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + z0h_g, &! bare soil roughness length, sensible heat [m] + obug, &! bare soil obu + ustarg, &! bare soil ustar + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno, &! fraction of snow cover on ground + + sigf, &! fraction of veg cover, excluding snow-covered veg [-] + etrc, &! maximum possible transpiration rate (mm/s) + tg, &! ground surface temperature [K] + t_soil, &! ground surface soil temperature [K] + t_snow, &! ground surface snow temperature [K] + qg, &! specific humidity at ground surface [kg/kg] + q_soil, &! specific humidity at ground soil surface [kg/kg] + q_snow, &! specific humidity at ground snow surface [kg/kg] + dqgdT, &! temperature derivative of "qg" + rss, &! soil surface resistance [s/m] + emg ! vegetation emissivity + + real(r8), intent(in) :: & + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain, &! rainfall interception (mm h2o/s) + qintr_snow, &! snowfall interception (mm h2o/s) + smp (1:nl_soil), &! soil matrix potential + rootfr (1:nl_soil), &! root fraction + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + hk (1:nl_soil) ! soil hydraulic conductance + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow ! depth of snow on foliage [mm] + + real(r8), intent(out) :: & + fwet_snow ! vegetation snow fractional cover [-] + + real(r8), intent(inout) :: & +!Ozone stress variables + lai_old ,&! lai in last time step + o3uptakesun,&! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha,&! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone +!End ozone stress variables + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil, &! sensible heat flux from ground soil [W/m2] + fseng_snow, &! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil, &! evaporation heat flux from ground soil [mm/s] + fevpg_snow, &! evaporation heat flux from ground snow [mm/s] + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + tref, &! 2 m height air temperature (kelvin) + qref, &! 2 m height air specific humidity + rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf + rstfacsha, &! factor of soil water stress to transpiration on shaded leaf + gssun, &! stomata conductance of sunlit leaf + gssha, &! stomata conductance of shaded leaf + rootflux(1:nl_soil) ! root water uptake from different layers + + real(r8), intent(inout) :: & + assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsun, &! transpiration rate of sunlit leaf [mm/s] + assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsha ! transpiration rate of shaded leaf [mm/s] + + real(r8), intent(out) :: & + rst, &! stomatal resistance + assim, &! rate of assimilation + respc, &! rate of respiration + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + dlrad, &! downward longwave radiation blow the canopy [W/m2] + ulrad, &! upward longwave radiation above the canopy [W/m2] + hprl, &! precipitation sensible heat from canopy + dheatl, &! vegetation heat change [W/m2] + + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + + real(r8), intent(inout) :: & +!Ozone stress variables + o3coefv_sun,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun,&! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ! Ozone stress factor for stomata on shaded leaf +!End ozone stress variables + +!-------------------------- Local Variables ---------------------------- +! assign iteration parameters + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + + real(r8) dtl(0:itmax+1) !difference of tl between two iterative step + + real(r8) :: & + displa, &! displacement height [m] + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + zldis, &! reference height "minus" zero displacement height [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length, momentum [m] + z0hv, &! roughness length, sensible heat [m] + z0qv, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of convective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + fdry, &! fraction of foliage that is green and dry [-] + fwet, &! fraction of foliage covered by water [-] + cf, &! heat transfer coefficient from leaves [-] + rb, &! leaf boundary layer resistance [s/m] + rbsun, &! Sunlit leaf boundary layer resistance [s/m] + rbsha, &! Shaded leaf boundary layer resistance [s/m] + rd, &! aerodynamical resistance between ground and canopy air + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + clai, &! canopy heat capacity [Jm-2K-1] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + cfh, &! heat conductance for leaf [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + cfw, &! latent heat conductance for leaf [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wta0, &! normalized heat conductance for air [-] + wtg0, &! normalized heat conductance for ground [-] + wtl0, &! normalized heat conductance for air and leaf [-] + wtaq0, &! normalized latent heat conductance for air [-] + wtgq0, &! normalized heat conductance for ground [-] + wtlq0, &! normalized latent heat cond. for air and leaf [-] + + ei, &! vapor pressure on leaf surface [pa] + deidT, &! derivative of "ei" on "tl" [pa/K] + qsatl, &! leaf specific humidity [kg/kg] + qsatldT, &! derivative of "qsatl" on "tlef" + + del, &! absolute change in leaf temp in current iteration [K] + del2, &! change in leaf temperature in previous iteration [K] + dele, &! change in heat fluxes from leaf [W/m2] + dele2, &! change in heat fluxes from leaf in previous iteration [W/m2] + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf heat fluxes change in two consecutive iter [W/m2] + + obuold, &! monin-obukhov length from previous iteration + tlbef, &! leaf temperature from previous iteration [K] + ecidif, &! excess energies [W/m2] + err, &! balance error + + rssun, &! sunlit leaf stomatal resistance [s/m] + rssha, &! shaded leaf stomatal resistance [s/m] + fsha, &! shaded fraction of canopy + laisun, &! sunlit leaf area index, one-sided + laisha, &! shaded leaf area index, one-sided + respcsun, &! sunlit leaf respiration rate [umol co2 /m**2/ s] [+] + respcsha, &! shaded leaf respiration rate [umol co2 /m**2/ s] [+] + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor ! tf*psur*100./1.013e5 + + integer it, nmozsgn + + real(r8) delta, fac + real(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif, etr0, sumrootr + real(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8) w, csoilcn, z0mg, cintsun(3), cintsha(3) + real(r8) fevpl_bef, fevpl_noadj, dtl_noadj, htvpl, erre + real(r8) qevpl, qdewl, qsubl, qfrol, qmelt, qfrz + + real(r8) lt, egvf + + real(r8) :: sqrtdragc !sqrt(drag coefficient) + real(r8) :: fai !canopy frontal area index + real(r8) :: a_k71 !exponential extinction factor for u/k decline within canopy (Kondo 1971) + real(r8) :: fqt, fht, fmtop + real(r8) :: utop, ueff, ktop + real(r8) :: phih, z0qg, z0hg + real(r8) :: hsink, displasink + real(r8) gb_mol + real(r8),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),dimension(nl_soil) :: k_ax_root ! axial root conductance + + integer, parameter :: zd_opt = 3 ! z0 and d with vertical profile consideration + integer, parameter :: rb_opt = 3 ! rb with vertical profile consideration + integer, parameter :: rd_opt = 3 ! rd with vertical profile consideration + +!----------------------------------------------------------------------- + +! initialization of errors and iteration parameters + it = 1 !counter for leaf temperature iteration + del = 0.0 !change in leaf temperature from previous iteration + dele = 0.0 !latent head flux from leaf for previous iteration + + dtl(0) = 0. + fevpl_bef = 0. + + fht = 0. !integral of profile function for heat + fqt = 0. !integral of profile function for moisture + +!----------------------------------------------------------------------- +! scaling-up coefficients from leaf to canopy +!----------------------------------------------------------------------- + + fsha = 1. -fsun + laisun = lai*fsun + laisha = lai*fsha + +! scaling-up coefficients from leaf to canopy + cintsun(1) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) + cintsun(2) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) + cintsun(3) = (1.-exp(-extkb*lai))/extkb + + cintsha(1) = (1.-exp(-0.110*lai))/0.110 - cintsun(1) + cintsha(2) = (1.-exp(-extkd*lai))/extkd - cintsun(2) + cintsha(3) = lai - cintsun(3) + +!----------------------------------------------------------------------- +! get fraction of wet and dry canopy surface (fwet & fdry) +! initial saturated vapor pressure and humidity and their derivation +!----------------------------------------------------------------------- + + !clai = 4.2 * 1000. * 0.2 + clai = 0.0 + + ! 0.2mm*LSAI, account for leaf (plus dew) heat capacity + IF ( DEF_VEG_SNOW ) THEN + clai = 0.2*(lai+sai)*cpliq + ldew_rain*cpliq + ldew_snow*cpice + ENDIF + + CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg + + z0m = htop * z0mr(patchclass(ipatch)) + displa = htop * displar(patchclass(ipatch)) + + z0mv = z0m; z0hv = z0m; z0qv = z0m + + ! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng) + lt = min(lai+sai, 2.) + egvf = (1._r8 - exp(-lt)) / (1._r8 - exp(-2.)) + displa = egvf * displa + z0mv = exp(egvf * log(z0mv) + (1._r8 - egvf) * log(z0mg)) + + z0hv = z0mv + z0qv = z0mv + +! 10/17/2017, yuan: z0m and displa with vertical profile solution + IF (zd_opt == 3) THEN + + CALL cal_z0_displa(lai+sai, htop, 1., z0mv, displa) + + ! NOTE: adjusted for small displa + displasink = max(htop/2., displa) + hsink = z0mv + displasink + + z0hv = z0mv + z0qv = z0mv + + ENDIF + + fai = 1. - exp(-0.5*(lai+sai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + + a_k71 = htop/(htop-displa)/(vonkar/sqrtdragc) + + taf = 0.5 * (tg + thm) + qaf = 0.5 * (qm + qg) + + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) +! rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) +! rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 +! rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 + + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf + dqh = qm - qaf + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (trim(HEIGHT_mode) == 'absolute') THEN + + IF (hu <= htop+1) THEN + hu_ = htop + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than htop+1, set it to htop+1.' + ENDIF + + IF (ht <= htop+1) THEN + ht_ = htop + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than htop+1, set it to htop+1.' + ENDIF + + IF (hq <= htop+1) THEN + hq_ = htop + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than htop+1, set it to htop+1.' + ENDIF + + ELSE ! relative height + hu_ = htop + hu + ht_ = htop + ht + hq_ = htop + hq + ENDIF + + zldis = hu_ - displa + + IF(zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL abort + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,um,obu) + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + DO WHILE (it .le. itmax) + + tlbef = tl + + del2 = del + dele2 = dele + + IF (tl > tfrz) THEN + htvpl = hvap + ELSE + htvpl = hsub + ENDIF + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + IF (rd_opt == 3) THEN + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,hpbl,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um,hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + ENDIF + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + +! Bulk boundary layer resistance of leaves + uaf = ustar + cf = 0.01*sqrtdi/sqrt(uaf) + rb = 1/(cf*uaf) + +! 11/17/2017, yuan: 3D rb calculation (with vertical profile consideration) +! 03/13/2020, yuan: added analytical solution + IF (rb_opt == 3) THEN + utop = ustar/vonkar * fmtop + ueff = ueffect(utop, htop, z0mg, z0mg, a_k71, 1._r8, 1._r8) + cf = 0.01*sqrtdi*sqrt(ueff) + rb = 1./cf + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction + +! modified by Xubin Zeng's suggestion at 08-07-2002 + w = exp(-(lai+sai)) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd = 1./(csoilcn*uaf) + +! 11/17/2017, yuan: 3D rd calculation with vertical profile solution +! 03/13/2020, yuan: added analytical solution + IF (rd_opt == 3) THEN + ktop = vonkar * (htop-displa) * ustar / phih + rd = frd(ktop, htop, z0qg, hsink, z0qg, displa/htop, & + z0qg, obug, ustar, z0mg, a_k71, 1._r8, 1._r8) + ENDIF + +!----------------------------------------------------------------------- +! stomatal resistances +!----------------------------------------------------------------------- + + IF(lai .gt. 0.001) THEN + + eah = qaf * psrf / ( 0.622 + 0.378 * qaf ) !pa + + ! If use PHS, calculate maximum stomata conductance (minimum stomata resistance) + ! by setting rstfac = 1. (no water stress). When use PHS, stomata only calculate + ! non-stress stomata conductance, assimilation rate and leaf respiration + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun = 1. + rstfacsha = 1. + ENDIF + + ! leaf to canopy level + rbsun = rb / laisun + rbsha = rb / laisha + + ! Sunlit leaves + CALL stomata (vmax25 ,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsun ,& + !Ozone stress variables + o3coefv_sun ,o3coefg_sun ,& + !End ozone stress variables + !Ozone WUE stomata model parameter + lambda ,& + !End WUE stomata model parameter + rbsun ,raw ,rstfacsun,cintsun ,& + assimsun ,respcsun ,rssun ) + + ! Shaded leaves + CALL stomata (vmax25 ,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsha ,& + ! Ozone stress variables + o3coefv_sha ,o3coefg_sha ,& + ! End ozone stress variables + ! Ozone WUE stomata model parameter + lambda ,& + ! End WUE stomata model parameter + rbsha ,raw ,rstfacsha,cintsha ,& + assimsha ,respcsha ,rssha ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun = min( 1.e6, 1./(rssun*tl/tprcor) )/ laisun * 1.e6 * o3coefg_sun + gs0sha = min( 1.e6, 1./(rssha*tl/tprcor) )/ laisha * 1.e6 * o3coefg_sha + + sai = amax1(sai,0.1) + ! PHS update actual stomata conductance (resistance), assimilation rate + ! and leaf respiration. above stomatal resistances are for the canopy, + ! the stomatal resistances and the "rb" in the following calculations are + ! the average for single leaf. thus, + CALL PlantHydraulicStress_twoleaf ( nl_soil ,nvegwcs ,& + z_soi ,dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss ,raw ,& + rd ,rstfacsun ,rstfacsha ,cintsun ,cintsha ,& + laisun ,laisha ,rhoair ,fwet ,sai ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& + psi50_sha ,psi50_xyl ,psi50_root ,htop ,ck ,& + smp ,hk ,hksati ,vegwp ,etrsun ,& + etrsha ,rootflux ,qg ,qm ,gs0sun ,& + gs0sha ,k_soil_root,k_ax_root ,gssun ,gssha ) + + etr = etrsun + etrsha + gssun = gssun * laisun + gssha = gssha * laisha + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsun, psrf, rstfacsun, rb, gssun, & + effcon, vmax25, c3c4, gradm, trop, slti, hlti, shti, hhti, trda, & + trdm, cintsun, assimsun, respcsun) + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsha, psrf, rstfacsha, rb, gssha, & + effcon, vmax25, c3c4, gradm, trop, slti, hlti, shti, hhti, trda, & + trdm, cintsha, assimsha, respcsha) + + rssun = tprcor/tl * 1.e6 / gssun + rssha = tprcor/tl * 1.e6 / gssha + ENDIF + + ELSE + rssun = 2.e20; assimsun = 0.; respcsun = 0. + rssha = 2.e20; assimsha = 0.; respcsha = 0. + gssun = 0._r8 + gssha = 0._r8 + + ! 07/2023, yuan: a bug for imbalanced water, rootflux only change + ! in DEF_USE_PLANTHYDRAULICS case in this routine. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr = 0. + etrsun = 0._r8 + etrsha = 0._r8 + rootflux = 0. + ENDIF + ENDIF + +! above stomatal resistances are for the canopy, the stomatal resistances +! and the "rb" in the following calculations are the average for single leaf. thus, + rssun = rssun * laisun + rssha = rssha * laisha + +!----------------------------------------------------------------------- +! dimensional and non-dimensional sensible and latent heat conductances +! for canopy and soil flux calculations. +!----------------------------------------------------------------------- + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + cah = 1. / rah + cgh = 1. / rd + cfh = (lai + sai) / rb + + caw = 1. / raw + IF (qg < qaf) THEN + cgw = 1. / rd !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet))*(lai+sai)/rb + (1.-fwet)*delta* & + ( laisun/(rb+rssun) + laisha/(rb+rssha) ) + + wtshi = 1. / ( cah + cgh + cfh ) + wtsqi = 1. / ( caw + cgw + cfw ) + + wta0 = cah * wtshi + wtg0 = cgh * wtshi + wtl0 = cfh * wtshi + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi + +!----------------------------------------------------------------------- +! IR radiation, sensible and latent heat fluxes and their derivatives +!----------------------------------------------------------------------- +! the partial derivatives of areodynamical resistance are ignored +! which cannot be determined analytically + fac = 1. - thermk + +! longwave absorption and their derivatives + ! 10/16/2017, yuan: added reflected longwave by the ground + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + irab = (frl - 2. * stefnc * tl**4 + emg*stefnc*tg**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 +ELSE + irab = (frl - 2. * stefnc * tl**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 +ENDIF + dirab_dtl = - 8. * stefnc * tl**3 * fac & + + 4.*(1-emg)*(1-thermk)*fac*stefnc*tl**3 + +! sensible heat fluxes and their derivatives + fsenl = rhoair * cpair * cfh * ( (wta0 + wtg0)*tl - wta0*thm - wtg0*tg ) + fsenl_dtl = rhoair * cpair * cfh * (wta0 + wtg0) + +! latent heat fluxes and their derivatives + + etr = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etrsun = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + etrsha = rhoair * (1.-fwet) * delta & + * ( laisha/(rb+rssha) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etr_dtl = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * (wtaq0 + wtgq0)*qsatlDT + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr.ge.etrc)THEN + etr = etrc + etr_dtl = 0. + ENDIF + ELSE + IF(rstfacsun .lt. 1.e-2 .or. etrsun .le. 0.)etrsun = 0._r8 + IF(rstfacsha .lt. 1.e-2 .or. etrsha .le. 0.)etrsha = 0._r8 + etr = etrsun + etrsha + IF(abs(etr - sum(rootflux)) .gt. 1.e-7)THEN + write(6,*) 'Warning: water balance violation in vegetation PHS', & + ipatch,p_iam_glb, etr, sum(rootflux), abs(etr-sum(rootflux)) + CALL CoLM_stop() + ENDIF + ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * (wtaq0 + wtgq0)*qsatlDT + + IF(evplwet.ge.ldew/deltim)THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + ! 07/09/2014, yuan: added for energy balance + erre = 0. + fevpl_noadj = fevpl + IF ( fevpl*fevpl_bef < 0. ) THEN + erre = -0.9*fevpl + fevpl = 0.1*fevpl + ENDIF + +!----------------------------------------------------------------------- +! difference of temperatures by quasi-newton-raphson method for the non-linear system equations +! MARK#dtl +!----------------------------------------------------------------------- + + dtl(it) = (sabv + irab - fsenl - hvap*fevpl & + + cpliq*qintr_rain*(t_precip-tl) + cpice*qintr_snow*(t_precip-tl)) & + / (clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq*qintr_rain + cpice*qintr_snow) + + dtl_noadj = dtl(it) + + ! check magnitude of change in leaf temperature limit to maximum allowed value + + ! 06/12/2014, yuan: .lt. -> .le. + IF(it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF(abs(dtl(it)).gt.delmax)THEN + dtl(it) = delmax*dtl(it)/abs(dtl(it)) + ENDIF + + ! 06/12/2014, yuan: .lt. -> .le. + ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le + IF((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.))THEN + dtl(it) = 0.5*(dtl(it-1) + dtl(it)) + ENDIF + + ENDIF + + tl = tlbef + dtl(it) + +!----------------------------------------------------------------------- +! square roots differences of temperatures and fluxes for use as the condition of convergences +!----------------------------------------------------------------------- + + del = sqrt( dtl(it)*dtl(it) ) + dele = dtl(it) * dtl(it) * ( dirab_dtl**2 + fsenl_dtl**2 + (hvap*fevpl_dtl)**2 ) + dele = sqrt(dele) + +!----------------------------------------------------------------------- +! saturated vapor pressures and canopy air temperature, canopy air humidity +!----------------------------------------------------------------------- +! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature +! and adjust specific humidity (qsatl_) proportionately + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + +! update vegetation/ground surface temperature, canopy air temperature, +! canopy air humidity + taf = wta0*thm + wtg0*tg + wtl0*tl + qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + +! update co2 partial pressure within canopy air + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assimsun + assimsha - respcsun -respcsha - rsoil) + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + dth = thm - taf + dqh = qm - qaf + + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF(zeta .ge. 0.)THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta .ge. 0.)THEN + um = max(ur,.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu_,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF(obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu + +!----------------------------------------------------------------------- +! Test for convergence +!----------------------------------------------------------------------- + + it = it+1 + + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = max(dele,dele2) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + + IF(DEF_USE_OZONESTRESS)THEN + CALL CalcOzoneStress(o3coefv_sun,o3coefg_sun,forc_ozone,psrf,th,ram,& + rssun,rb,lai,lai_old,ivt,o3uptakesun,sabv,deltim) + CALL CalcOzoneStress(o3coefv_sha,o3coefg_sha,forc_ozone,psrf,th,ram,& + rssha,rb,lai,lai_old,ivt,o3uptakesha,sabv,deltim) + lai_old = lai + assimsun = assimsun * o3coefv_sun + assimsha = assimsha * o3coefv_sha +! rssun = rssun / o3coefg_sun +! rssha = rssha / o3coefg_sha + ELSE + o3coefv_sun = 1.0_r8 + o3coefg_sun = 1.0_r8 + o3coefv_sha = 1.0_r8 + o3coefg_sha = 1.0_r8 + ENDIF + +! ====================================================================== +! END stability iteration +! ====================================================================== + + z0m = z0mv + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! canopy fluxes and total assimilation amd respiration + + IF(lai .gt. 0.001) THEN + rst = 1./(laisun/rssun + laisha/rssha) + ELSE + rssun = 2.0e4 ; rssha = 2.0e4 + assimsun = 0. ; assimsha = 0. + respcsun = 0. ; respcsha = 0. + rst = 2.0e4 + ENDIF + assim = assimsun + assimsha + respc = respcsun + respcsha! + rsoil + +! canopy fluxes and total assimilation amd respiration + fsenl = fsenl + fsenl_dtl*dtl(it-1) & + ! yuan: add the imbalanced energy below due to T adjustment to sensible heat + + (dtl_noadj-dtl(it-1)) * (clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq * qintr_rain + cpice * qintr_snow) & + ! yuan: add the imbalanced energy below due to q adjustment to sensible heat + + hvap*erre + + etr0 = etr + etr = etr + etr_dtl*dtl(it-1) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF (abs(etr0) .ge. 1.e-15) THEN + rootflux = rootflux * etr / etr0 + ELSE + rootflux = rootflux + dz_soi / sum(dz_soi) * etr_dtl* dtl(it-1) + ENDIF + +! !NOTE: temporal solution to make etr and rootflux consistent. +! !TODO: need double check +! sumrootr = sum(rootr(:), rootr(:)>0.) +! IF (abs(sumrootr) > 0.) THEN +! rootr(:) = max(rootr(:),0.) * (etr/sumrootr) +! ELSE +! rootr(:) = etr*rootfr(:) +! ENDIF + ENDIF + + evplwet = evplwet + evplwet_dtl*dtl(it-1) + fevpl = fevpl_noadj + fevpl = fevpl + fevpl_dtl*dtl(it-1) + + elwmax = ldew/deltim + elwdif = max(0., evplwet-elwmax) + evplwet = min(evplwet, elwmax) + + fevpl = fevpl - elwdif + fsenl = fsenl + hvap*elwdif + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from ground to canopy space +!----------------------------------------------------------------------- + + fseng = cpair*rhoair*cgh*(tg-taf) +! 03/07/2020, yuan: calculate fseng_soil/snow + !NOTE: taf = wta0*thm + wtg0*tg + wtl0*tl + fseng_soil = cpair*rhoair*cgh*((1.-wtg0)*t_soil - wta0*thm - wtl0*tl) + fseng_snow = cpair*rhoair*cgh*((1.-wtg0)*t_snow - wta0*thm - wtl0*tl) + +! 03/07/2020, yuan: calculate fevpg_soil/snow + !NOTE: qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + fevpg = rhoair*cgw*(qg-qaf) + fevpg_soil = rhoair*cgw*((1.-wtgq0)*q_soil - wtaq0*qm - wtlq0*qsatl) + fevpg_snow = rhoair*cgw*((1.-wtgq0)*q_snow - wtaq0*qm - wtlq0*qsatl) + +!----------------------------------------------------------------------- +! downward (upward) longwave radiation below (above) the canopy and prec. sensible heat +!----------------------------------------------------------------------- + + ! 10/16/2017, yuan: added reflected longwave by the ground + dlrad = thermk * frl & + + stefnc * fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + thermk*emg*tg**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) +ELSE + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + (1.-fsno)*thermk*emg*t_soil**4 & + + fsno*thermk*emg*t_snow**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) +ENDIF + ! precipitation sensible heat from canopy + hprl = cpliq * qintr_rain*(t_precip-tl) + cpice * qintr_snow*(t_precip-tl) + + ! vegetation heat change + dheatl = clai/deltim*dtl(it-1) + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature (cgrnd) +!----------------------------------------------------------------------- + + cgrnds = cpair*rhoair*cgh*(1.-wtg0) + cgrndl = rhoair*cgw*(1.-wtgq0)*dqgdT + cgrnd = cgrnds + cgrndl*htvp + +!----------------------------------------------------------------------- +! balance check +! (the computational error was created by the assumed 'dtl' in MARK#dtl) +!----------------------------------------------------------------------- + + err = sabv + irab + dirab_dtl*dtl(it-1) - fsenl - hvap*fevpl + hprl & + ! account for vegetation heat change + - dheatl + +#if (defined CoLMDEBUG) + IF(abs(err) .gt. .2) & + write(6,*) 'energy imbalance in LeafTemperature.F90',it-1,& + err,sabv,irab,fsenl,hvap*fevpl,hprl,dheatl +#endif + +!----------------------------------------------------------------------- +! Update dew accumulation (kg/m2) +!----------------------------------------------------------------------- + IF (DEF_Interception_scheme .eq. 1) THEN + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 2) THEN !CLM4.5 + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 8) THEN !CoLM202X + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + ELSE + CALL abort + ENDIF + + ! Bug fix: When DEF_VEG_SNOW is false, only ldew is updated above + ! (via ldew = max(0., ldew - evplwet*deltim)), but ldew_rain/ldew_snow + ! remain unchanged. Downstream interception routines (schemes 1, 3-8) + ! resync ldew = ldew_rain + ldew_snow at entry, which would silently + ! revert the evaporation adjustment. Fix by scaling components proportionally. + IF (.not. DEF_VEG_SNOW) THEN + IF (ldew_rain + ldew_snow > 1.e-10) THEN + ldew_rain = ldew * (ldew_rain / (ldew_rain + ldew_snow)) + ldew_snow = ldew - ldew_rain + ELSEIF (ldew > 0.) THEN + ! Components were zero but ldew > 0 (condensation case) + IF (tl > tfrz) THEN + ldew_rain = ldew + ldew_snow = 0. + ELSE + ldew_rain = 0. + ldew_snow = ldew + ENDIF + ELSE + ldew_rain = 0. + ldew_snow = 0. + ENDIF + ENDIF + + IF ( DEF_VEG_SNOW ) THEN + ! update fwet_snow + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((10./(48.*(lai+sai)))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + ! phase change + + qmelt = 0. + qfrz = 0. + + !TODO: double check below + IF (ldew_snow.gt.1.e-6 .and. tl.gt.tfrz) THEN + qmelt = min(ldew_snow/deltim,(tl-tfrz)*cpice*ldew_snow/(deltim*hfus)) + ldew_snow = max(0.,ldew_snow - qmelt*deltim) + ldew_rain = max(0.,ldew_rain + qmelt*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + + IF (ldew_rain.gt.1.e-6 .and. tl.lt.tfrz) THEN + qfrz = min(ldew_rain/deltim,(tfrz-tl)*cpliq*ldew_rain/(deltim*hfus)) + ldew_rain = max(0.,ldew_rain - qfrz*deltim) + ldew_snow = max(0.,ldew_snow + qfrz*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + ENDIF + +!----------------------------------------------------------------------- +! 2 m height air temperature +!----------------------------------------------------------------------- + tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE LeafTemperature +!---------------------------------------------------------------------- + + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + !DESCRIPTION + !=========== + ! determine fraction of foliage covered by water and + ! fraction of foliage that is dry and transpiring + + !Original Author: + !------------------- + !---Yongjiu Dai + + !References: + !------------------- + !---Dai, Y., Zeng, X., Dickinson, R.E., Baker, I., Bonan, G.B., BosiloVICh, M.G., Denning, + ! A.S., Dirmeyer, P.A., Houser, P.R., Niu, G. and Oleson, K.W., 2003. The common land + ! model. Bulletin of the American Meteorological Society, 84(8), pp.1013-1024. + + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !REVISION HISTORY + !---------------- + !---2024.04.16 Hua Yuan: add option to account for vegetation snow process + !---2021.12.08 Zhongwang Wei @ SYSU + !---2018.06 Hua Yuan: remove sigf, to compatible with PFT + !---1999.09.15 Yongjiu Dai + !======================================================================= + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water&snow [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) :: lsai !lai + sai + real(r8) :: dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) :: vegt !sigf*lsai, NOTE: remove sigf + real(r8) :: satcap_rain !saturation capacity of foliage for rain [kg/m2] + real(r8) :: satcap_snow !saturation capacity of foliage for snow [kg/m2] + real(r8) :: fwet_rain !fraction of foliage covered by water [-] + real(r8) :: fwet_snow !fraction of foliage covered by snow [-] + + !----------------------------------------------------------------------- + ! Fwet is the fraction of all vegetation surfaces which are wet + ! including stem area which contribute to evaporation + lsai = lai + sai ! effective leaf area index + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 + ! Check for maximum limit of fwet + fwet = min(fwet,1.0) + ENDIF + + ! account for vegetation snow + ! calculate fwet_rain, fwet_snow, fwet + IF ( DEF_VEG_SNOW ) THEN + + fwet_rain = 0 + IF(ldew_rain > 0.) THEN + fwet_rain = ((dewmxi/vegt)*ldew_rain)**.666666666666 + ! Check for maximum limit of fwet_rain + fwet_rain = min(fwet_rain,1.0) + ENDIF + + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((dewmxi/(48.*vegt))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + fwet = fwet_rain + fwet_snow - fwet_rain*fwet_snow + fwet = min(fwet,1.0) + ENDIF + + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai + + END SUBROUTINE dewfraction + +END MODULE MOD_LeafTemperature diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 new file mode 100644 index 0000000000..df68a494b7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 @@ -0,0 +1,2145 @@ +#include + +MODULE MOD_LeafTemperaturePC + +!----------------------------------------------------------------------- +! +! --- Leaf Temperature and Turbulence Modeling --- +! for Plant Community (PC) Simulation +! +! o Reference hight +! | +! | +! _____ tree | _____ --- Layer3 +! ||||||| | ||||||| +! |||||||||--\/\/\/o ||||||||| +! \|||||/ | \|||||/ +! | | | --- Layer2 +! | | | shrub /xx\ +! | grass -/\/-o--------|---\/\/\--\xx/ +! ____________|_____\\//____________|___________||__ --- Layer1 +! ///////////////////////////////////////////////////////////////////// +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW, & + DEF_VEG_SNOW + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LeafTemperaturePC + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: dewfraction + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE LeafTemperaturePC ( & + ipatch ,ps ,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass ,fcover ,htop ,hbot ,lai ,& + sai ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,forc_t ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,parsun ,parsha ,fsun ,& + sabv ,frl ,thermk ,fshade ,rstfacsun ,rstfacsha ,& + gssun ,gssha ,po2m ,pco2m ,z0h_g ,obug ,& + ustarg ,zlnd ,zsno ,fsno ,sigf ,etrc ,& + tg ,qg ,rss ,dqgdT ,emg ,t_soil ,& + t_snow ,q_soil ,q_snow ,z0mpc ,tl ,ldew ,& + ldew_rain ,ldew_snow ,fwet_snow ,taux ,tauy ,fseng ,& + fseng_soil ,fseng_snow ,fevpg ,fevpg_soil ,fevpg_snow ,cgrnd ,& + cgrndl ,cgrnds ,tref ,qref ,rst ,assim ,& + respc ,fsenl ,fevpl ,etr ,dlrad ,ulrad ,& + z0m ,zol ,rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,vegwp ,gs0sun ,gs0sha ,& + assimsun ,etrsun ,assimsha ,etrsha ,& +!Ozone stress variables + o3coefv_sun,o3coefv_sha,o3coefg_sun,o3coefg_sha,& + lai_old ,o3uptakesun,o3uptakesha,forc_ozone ,& +!End ozone stress variables + hpbl, & + qintr_rain ,qintr_snow ,t_precip ,hprl ,& + dheatl ,smp ,hk ,hksati ,& + rootflux ) + +!======================================================================= +! +! !DESCRIPTION: +! Leaf temperature resolved for Plant Community (3D) case Foliage +! energy conservation for each PFT is given by foliage energy budget +! equation: +! Rnet - Hf - LEf = 0 +! The equation is solved by Newton-Raphson iteration, in which this +! iteration includes the calculation of the photosynthesis and stomatal +! resistance, and the integration of turbulent flux profiles. The +! sensible and latent heat transfer between foliage and atmosphere and +! ground is linked by the equations: +! Ha = Hf + Hg and Ea = Ef + Eg +! +! Original author: Hua Yuan and Yongjiu Dai, September, 2017 +! +! +! !REFERENCES: +! 1) Dai, Y., Yuan, H., Xin, Q., Wang, D., Shangguan, W., Zhang, S., et +! al. (2019). Different representations of canopy structure—A large +! source of uncertainty in global land surface modeling. Agricultural +! and Forest Meteorology, 269-270, 119-135. +! https://doi.org/10.1016/j.agrformet.2019.02.006 +! +! !REVISIONS: +! +! 01/2021, Xingjie Lu and Nan Wei: added plant hydraulic process +! interface. +! +! 01/2021, Nan Wei: added interaction btw prec and canopy. +! +! 05/2023, Shaofeng Liu: add option to call moninobuk_leddy, the +! LargeEddy surface turbulence scheme (LZD2022); make a proper +! update of um. +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: vonkar, grav, hvap, hsub, cpair, stefnc, & + cpliq, cpice, hfus, tfrz, denice, denh2o + USE MOD_Const_PFT + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_TurbulenceLEddy + USE MOD_Qsadv + USE MOD_AssimStomataConductance + USE MOD_PlantHydraulic, only: PlantHydraulicStress_twoleaf + USE MOD_Ozone, only: CalcOzoneStress + USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: ipatch + integer, intent(in) :: & + ps, &! start PFT index in a patch + pe ! end PFT index in a patch + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + htvp ! latent heat of evaporation (/sublimation) [J/kg] + +! vegetation parameters + integer, dimension(ps:pe), intent(in) :: & + pftclass ! PFT class + + real(r8), dimension(ps:pe), intent(in) :: & + fcover, &! PFT fractional coverage [-] + htop, &! PFT crown top height [m] + hbot, &! PFT crown bottom height [m] + lai, &! adjusted leaf area index for seasonal variation [-] + sai ! stem area index [-] + + real(r8), intent(inout) :: & + vegwp(1:nvegwcs,ps:pe), &! vegetation water potential + gs0sun(ps:pe), &! maximum stomata conductance of sunlit leaf + gs0sha(ps:pe) ! maximum stomata conductance of shaded leaf + +! input variables + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + parsun(ps:pe), &! par absorbed per unit sunlit lai [w/m**2] + parsha(ps:pe), &! par absorbed per unit shaded lai [w/m**2] + fsun (ps:pe), &! sunlit fraction of canopy + sabv (ps:pe), &! solar radiation absorbed by vegetation [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + + extkb (ps:pe), &! (k, g(mu)/mu) direct solar extinction coefficient + extkd (ps:pe), &! diffuse and scattered diffuse PAR extinction coefficient + thermk(ps:pe), &! canopy gap fraction for tir radiation + fshade(ps:pe), &! shadow for each PFT + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + z0h_g, &! bare soil roughness length, sensible heat [m] + obug, &! bare soil obu + ustarg, &! bare soil ustar + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno, &! fraction of snow cover on ground + + sigf (ps:pe), &! fraction of veg cover, excluding snow-covered veg [-] + etrc (ps:pe), &! maximum possible transpiration rate (mm/s) + tg, &! ground surface temperature [K] + t_soil, &! ground surface soil temperature [K] + t_snow, &! ground surface snow temperature [K] + qg, &! specific humidity at ground surface [kg/kg] + q_soil, &! specific humidity at ground surface soil [kg/kg] + q_snow, &! specific humidity at ground surface snow [kg/kg] + dqgdT, &! temperature derivative of "qg" + rss, &! soil surface resistance [s/m] + emg ! vegetation emissivity + + real(r8), intent(in) :: & + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain(ps:pe), &! rainfall interception (mm h2o/s) + qintr_snow(ps:pe), &! snowfall interception (mm h2o/s) + smp (1:nl_soil), &! precipitation sensible heat from canopy + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + hk (1:nl_soil) ! soil hydraulic conductance + + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] + + real(r8), dimension(ps:pe), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow, &! depth of snow on foliage [mm] + fwet_snow, &! vegetation snow fractional cover [-] +!Ozone stress variables + lai_old , &! lai in last time step + o3uptakesun, &! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha, &! Ozone does, shaded leaf (mmol O3/m^2) + o3coefv_sun, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun, &! Ozone stress factor for stomata on shaded leaf + o3coefg_sha, &! Ozone stress factor for stomata on shaded leaf +!End ozone stress variables + rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf + rstfacsha, &! factor of soil water stress to transpiration on shaded leaf + gssun, &! stomata conductance of sunlit leaf + gssha ! stomata conductance of shaded leaf + + real(r8), dimension(ps:pe), intent(inout) :: & + assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsun, &! transpiration rate of sunlit leaf [mm/s] + assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsha ! transpiration rate of shaded leaf [mm/s] + +!Ozone stress variables + real(r8), intent(inout) :: forc_ozone +!End ozone stress variables + + real(r8), intent(inout) :: & + dlrad, &! downward longwave radiation blow the canopy [W/m2] + ulrad, &! upward longwave radiation above the canopy [W/m2] + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil, &! sensible heat flux from ground soil [W/m2] + fseng_snow, &! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil, &! evaporation heat flux from ground soil [mm/s] + fevpg_snow, &! evaporation heat flux from ground snow [mm/s] + tref, &! 2 m height air temperature (kelvin) + qref, &! 2 m height air specific humidity + rootflux(nl_soil,ps:pe) ! root water uptake from different layers + + real(r8), dimension(ps:pe), intent(out) :: & + z0mpc, &! z0m for individual PFT + rst, &! stomatal resistance + assim, &! rate of assimilation + respc, &! rate of respiration + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + hprl, &! precipitation sensible heat from canopy + dheatl ! vegetation heat change [W/m2] + + real(r8), intent(inout) :: & + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + + real(r8), intent(inout) :: & + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil latent heat flux wrt soil temp [w/m2/k] + cgrnds ! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] + +!-------------------------- Local Variables ---------------------------- +! assign iteration parameters + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + + real(r8) dtl(0:itmax+1,ps:pe) !difference of tl between two iterative step + + !TODO: read from mod_const_pft.F90 + real(r8), dimension(ps:pe) :: & + canlay, &! PFT canopy layer number + sqrtdi ! inverse sqrt of leaf dimension [m**-0.5] + + !TODO: read from mod_const_pft.F90 file + real(r8), dimension(ps:pe) :: & + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + lambda, &! marginal water cost of carbon gain + extkn ! coefficient of leaf nitrogen allocation + + integer, dimension(ps:pe) :: & + c3c4 ! C3/C4 plant type + + real(r8), dimension(ps:pe) :: & + kmax_sun, &! Plant Hydraulics Parameters + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) + + real(r8) :: & + rootfr(nl_soil,ps:pe) ! root fraction + + real(r8) :: & + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + zldis, &! reference height "minus" zero displacement height [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length, momentum [m] + z0hv, &! roughness length, sensible heat [m] + z0qv, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of convective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + cf, &! heat transfer coefficient from leaves [-] + rbsun, &! bulk boundary layer resistance of sunlit fraction of canopy + rbsha, &! bulk boundary layer resistance of shaded fraction of canopy + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf heat fluxes change in two consecutive iter [W/m2] + obuold, &! monin-obukhov length from previous iteration + err, &! balance error + + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor, &! tf*psur*100./1.013e5 + + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + phih, &! phi(h), similarity function for sensible heat + + clai (ps:pe), &! canopy heat capacity [Jm-2K-1] + fdry (ps:pe), &! fraction of foliage that is green and dry [-] + fwet (ps:pe), &! fraction of foliage covered by water [-] + rb (ps:pe), &! leaf boundary layer resistance [s/m] + cfh (ps:pe), &! heat conductance for leaf [m/s] + cfw (ps:pe), &! latent heat conductance for leaf [m/s] + wlh (ps:pe), &! normalized heat conductance for air and leaf [-] + wlq (ps:pe), &! normalized latent heat cond. for air and leaf [-] + + ei (ps:pe), &! vapor pressure on leaf surface [pa] + deidT (ps:pe), &! derivative of "ei" on "tl" [pa/K] + qsatl (ps:pe), &! leaf specific humidity [kg/kg] + qsatldT (ps:pe), &! derivative of "qsatl" on "tlef" + + del (ps:pe), &! absolute change in leaf temp in current iteration [K] + del2 (ps:pe), &! change in leaf temperature in previous iteration [K] + dele (ps:pe), &! change in heat fluxes from leaf [W/m2] + dele2 (ps:pe), &! change in heat fluxes from leaf in previous iteration [W/m2] + + tlbef (ps:pe), &! leaf temperature from previous iteration [K] + fsha (ps:pe), &! shaded fraction of canopy + laisun (ps:pe), &! sunlit leaf area index, one-sided + laisha (ps:pe), &! shaded leaf area index, one-sided + rssun (ps:pe), &! sunlit leaf stomatal resistance [s/m] + rssha (ps:pe), &! shaded leaf stomatal resistance [s/m] + respcsun (ps:pe), &! sunlit leaf respiration rate [umol co2 /m**2/ s] [+] + respcsha (ps:pe) ! shaded leaf respiration rate [umol co2 /m**2/ s] [+] + + integer it, nmozsgn + + real(r8) w, csoilcn, z0mg, z0hg, z0qg, elwmax, elwdif, sumrootflux + real(r8) cintsun(3, ps:pe), cintsha(3, ps:pe) + real(r8),dimension(ps:pe) :: delta, fac, etr0 + real(r8),dimension(ps:pe) :: irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8),dimension(ps:pe) :: evplwet, evplwet_dtl, etr_dtl + real(r8),dimension(ps:pe) :: fevpl_bef, fevpl_noadj, dtl_noadj, htvpl, erre + real(r8),dimension(ps:pe) :: qevpl, qdewl, qsubl, qfrol, qmelt, qfrz + real(r8),dimension(ps:pe) :: gb_mol_sun,gb_mol_sha + real(r8),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),dimension(nl_soil) :: k_ax_root ! axial root conductance + + ! ................................................................. + ! definition for 3d run + ! ................................................................. + + integer , parameter :: nlay = 3 + + real(r8), parameter :: & + c1 = 0.320, &! parameter to calculate drag coefficients of Massman's method + c2 = 0.264, &! parameter to calculate drag coefficients of Massman's method + c3 = 15.1, &! parameter to calculate drag coefficients of Massman's method + iw = 0.5, &! parameter to calculate alpha of Goudriaa's method + Cd = 0.2, &! leaf drag coefficient + cd1 = 7.5, &! a free parameter for d/h calculation, Raupach 1992, 1994 + psih = 0.193 ! psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 + + real(r8) :: sqrtdragc! sqrt(drag coefficient) + real(r8) :: lm ! mix length within canopy + real(r8) :: fai ! canopy frontal area index + + real(r8), dimension(0:nlay) :: & + z0m_lays, &! roughness length for momentum for the layer and below + z0h_lays, &! roughness length for SH for the layer and below + z0q_lays, &! roughness length for LH for the layer and below + displa_lays, &! displacement height for the layer and below + fcover_lays ! vegetation fractional cover for this layer and above + + real(r8), dimension(ps:pe) :: & + lsai ! lai + sai + + real(r8), dimension(nlay) :: & + htop_lay, &! canopy crown top for each layer + hbot_lay, &! canopy crown bottom for each layer + fcover_lay, &! vegetation fractional coverage for each layer + lsai_lay, &! (lai+sai) for each layer + a_lay, &! exp. extinction factor for u/k decline within canopy + a_lay_i63, &! exp. extinction factor for u/k decline within canopy (Inoue 1963) + a_lay_k71, &! exp. extinction factor for u/k decline within canopy (Kondo 1971) + a_lay_g77, &! exp. extinction factor for u/k decline within canopy (Groudrian 1977) + a_lay_m97, &! exp extinction factor for u/k decline within canopy (Massman 1997) + utop_lay, &! wind speed at layer top [m/s] + ubot_lay, &! wind speed at layer bottom [m/s] + ueff_lay, &! effective wind speed within canopy layer [m/s] + ueff_lay_, &! effective wind speed within canopy layer [m/s] + ueff_lay_norm, &! normalized effective wind speed within canopy layer [m/s] + ktop_lay, &! eddy coefficient at layer top + kbot_lay, &! eddy coefficient at layer bottom + z0m_lay, &! roughness length for the vegetation covered area + displa_lay, &! displacement height for the vegetation covered area + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + rd, &! aerodynamic resistance between layers [s/m] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wah, &! normalized heat conductance for air [-] + wgh, &! normalized heat conductance for ground [-] + waq, &! normalized latent heat conductance for air [-] + wgq, &! normalized heat conductance for ground [-] + wlhl, &! sum of normalized heat conductance for air and leaf + wlql ! sum of normalized heat conductance for air and leaf + + real(r8) :: ktop, utop, fmtop, bee, tmpw1, tmpw2, fact, facq + + logical is_vegetated_patch + integer i, p, clev + integer toplay, botlay, upplay, numlay + integer d_opt, rb_opt, rd_opt + + real(r8) :: displa, ttaf, tqaf + + ! variables for longwave transfer calculation + ! ................................................................. + real(r8) :: tdn(0:4,0:4) !downward transfer coefficient matrix for LW + real(r8) :: tup(0:4,0:4) !upward transfer coefficient matrix for LW + real(r8) :: thermk_lay(nlay) !transmittance of longwave radiation for each layer + real(r8) :: fshade_lay(nlay) !shadow of each layer + real(r8) :: L(nlay) !longwave radiation emitted by canopy layer + real(r8) :: Ltd(nlay) !transmitted downward longwave radiation from canopy layer + real(r8) :: Ltu(nlay) !transmitted upward longwave radiation from canopy layer + real(r8) :: Lin(0:4) !incoming longwave radiation for each layer + real(r8) :: Ld(0:4) !total downward longwave radiation for each layer + real(r8) :: Lu(0:4) !total upward longwave radiation for each layer + real(r8) :: Lg !emitted longwave radiation from ground + real(r8) :: Lv(ps:pe) !absorbed longwave radiation for each pft + real(r8) :: dLv(ps:pe) !LW change due to temperature change + real(r8) :: dLvpar(nlay) !temporal variable for calculating dLv + +!----------------------------------------------------------------------- + +! only process with vegetated patches + + lsai(:) = lai(:) + sai(:) + is_vegetated_patch = .false. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + is_vegetated_patch = .true. + ELSE + tl(i) = forc_t + ENDIF + ENDDO + + ! When there is no vegetation in this Plant Community Patch, RETURN + IF (.not. is_vegetated_patch) THEN + RETURN + ENDIF + +! initialization of errors and iteration parameters + it = 1 !counter for leaf temperature iteration + del(:) = 0.0 !change in leaf temperature from previous iteration + dele(:) = 0.0 !latent head flux from leaf for previous iteration + + dtl(:,:) = 0. + fevpl_bef(:) = 0. + + d_opt = 2 + rd_opt = 3 + rb_opt = 3 + +! initial values for z0hg, z0qg + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg + +! initialization of PFT constants + DO i = ps, pe + p = pftclass(i) + + canlay (i) = canlay_p (p) + sqrtdi (i) = sqrtdi_p (p) + + effcon (i) = effcon_p (p) + vmax25 (i) = vmax25_p (p) + c3c4 (i) = c3c4_p (p) + shti (i) = shti_p (p) + hhti (i) = hhti_p (p) + slti (i) = slti_p (p) + hlti (i) = hlti_p (p) + trda (i) = trda_p (p) + trdm (i) = trdm_p (p) + trop (i) = trop_p (p) + g1 (i) = g1_p (p) + g0 (i) = g0_p (p) + gradm (i) = gradm_p (p) + binter (i) = binter_p (p) + lambda (i) = lambda_p (p) + extkn (i) = extkn_p (p) + + kmax_sun (i) = kmax_sun_p (p) + kmax_sha (i) = kmax_sha_p (p) + kmax_xyl (i) = kmax_xyl_p (p) + kmax_root (i) = kmax_root_p (p) + psi50_sun (i) = psi50_sun_p (p) + psi50_sha (i) = psi50_sha_p (p) + psi50_xyl (i) = psi50_xyl_p (p) + psi50_root (i) = psi50_root_p (p) + ck (i) = ck_p (p) + + rootfr (:,i) = rootfr_p (:,p) + ENDDO + +!----------------------------------------------------------------------- +! scaling-up coefficients from leaf to canopy +!----------------------------------------------------------------------- + +! note: need to separate to sunlit/shaded pars +!----------------------------------------------------------------------- + +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves + fsha(:) = 1. - fsun(:) + laisun(:) = lai(:)*fsun(:) + laisha(:) = lai(:)*fsha(:) + + cintsun(1,:) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) + cintsun(2,:) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) + cintsun(3,:) = (1.-exp(-extkb*lai))/extkb + + cintsha(1,:) = (1.-exp(-0.110*lai))/0.110 - cintsun(1,:) + cintsha(2,:) = (1.-exp(-extkd*lai))/extkd - cintsun(2,:) + cintsha(3,:) = lai(:) - cintsun(3,:) + +!----------------------------------------------------------------------- +! get fraction of wet and dry canopy surface (fwet & fdry) +! initial saturated vapor pressure and humidity and their derivation +!----------------------------------------------------------------------- + + DO i = ps, pe + + clai(i) = 0.0 + + ! 0.2mm*LSAI, account for leaf (plus dew) heat capacity + IF ( DEF_VEG_SNOW ) THEN + clai(i) = 0.2*lsai(i)*cpliq + ldew_rain(i)*cpliq + ldew_snow(i)*cpice + ENDIF + + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + CALL dewfraction (sigf(i),lai(i),sai(i),dewmx,& + ldew(i),ldew_rain(i),ldew_snow(i),fwet(i),fdry(i)) + CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + +!----------------------------------------------------------------------- +! calculate layer average properties: height (htop_lay, hbot_lay), lsai_lay, ... +! !!NOTE: adjustment may needed for htop_lay/hbot_lay +!----------------------------------------------------------------------- + htop_lay(:) = 0 + hbot_lay(:) = 0 + lsai_lay(:) = 0 + fcover_lay(:) = 0 + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + htop_lay(clev) = htop_lay(clev) + htop(i) * fcover(i) + hbot_lay(clev) = hbot_lay(clev) + hbot(i) * fcover(i) + lsai_lay(clev) = lsai_lay(clev) + lsai(i) * fcover(i) + fcover_lay(clev) = fcover_lay(clev) + fcover(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fcover_lay(i) > 0) THEN + htop_lay(i) = htop_lay(i) / fcover_lay(i) + hbot_lay(i) = hbot_lay(i) / fcover_lay(i) + lsai_lay(i) = lsai_lay(i) / fcover_lay(i) + ENDIF + ENDDO + + ! calculate fcover_lays +! 03/16/2020, yuan: determine to set fc=0 or fcover above for +! gaps between layers, 0 maybe more consistent + fcover_lays(0) = sum(fcover_lay(:)) + fcover_lays(1) = sum(fcover_lay(1:3)) + fcover_lays(2) = sum(fcover_lay(2:3)) + fcover_lays(3) = sum(fcover_lay(3:3)) + fcover_lays(:) = 0. + +!----------------------------------------------------------------------- +! scaling factor bee +!----------------------------------------------------------------------- +! 09/26/2017, yuan: NOTE! bee value, the default is 1 + bee = 1. + +!----------------------------------------------------------------------- +! calculate z0m and displa for PFTs +!----------------------------------------------------------------------- + DO i = ps, pe + IF (lsai(i) > 1.e-6) THEN + CALL cal_z0_displa(lsai(i), htop(i), 1., z0mpc(i), displa) + ELSE + z0mpc(i) = z0mg + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate z0m and displa for layers +!----------------------------------------------------------------------- + + displa_lay (:) = 0. + displa_lays(:) = 0. + z0m_lay (:) = 0. + z0m_lays (:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + CALL cal_z0_displa(lsai_lay(i), htop_lay(i), 1., z0m_lay(i), displa_lay(i)) + CALL cal_z0_displa(lsai_lay(i), htop_lay(i), fcover_lay(i), z0m_lays(i), displa_lays(i)) + ENDIF + ENDDO + + ! ground + z0m_lays (0) = z0mg + displa_lays(0) = 0. + + ! 10/05/2017: robust check + WHERE (z0m_lays(:) < z0mg) z0m_lays(:) = z0mg + WHERE (z0m_lay (:) < z0mg) z0m_lay (:) = z0mg + + ! maximum assumption + z0m_lays(1) = maxval(z0m_lays(0:1)) + z0m_lays(2) = maxval(z0m_lays(0:2)) + z0m_lays(3) = maxval(z0m_lays(0:3)) + + displa_lays(1) = maxval(displa_lays(0:1)) + displa_lays(2) = maxval(displa_lays(0:2)) + displa_lays(3) = maxval(displa_lays(0:3)) + + ! roughness length and displacement height for sensible + ! and latent heat transfer + z0h_lays(:) = z0m_lays(:) + z0q_lays(:) = z0m_lays(:) + +!----------------------------------------------------------------------- +! calculate layer a_lay +!----------------------------------------------------------------------- + ! initialization + a_lay (:) = 0. + a_lay_i63(:) = 0. + a_lay_k71(:) = 0. + a_lay_g77(:) = 0. + a_lay_m97(:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + ! mixing length and sqrt(drag coefficient) + lm = vonkar*(htop_lay(i) - displa_lay(i)) + + ! Raupach, 1992 + fai = 1. - exp(-0.5*lsai_lay(i)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + + ! Inoue, 1963 + a_lay_i63(i) = htop_lay(i) * & + (Cd*lsai_lay(i)/(2.*htop_lay(i)*lm**2))**(1./3.) + + ! Kondo, 1971 + a_lay_k71(i) = htop_lay(i)/(htop_lay(i)-displa_lay(i))/ & + (vonkar/sqrtdragc) + + ! Goudriaan, 1977 + a_lay_g77(i) = (Cd*lsai_lay(i)*htop_lay(i)/lm)**0.5 + + ! Massman, 1997 + a_lay_m97(i) = Cd*lsai_lay(i) / (2.*sqrtdragc**2) + + a_lay(i) = a_lay_k71(i) + + displa_lay(i) = max(htop_lay(i)/2., displa_lay(i)) + + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate layer info +! how may layers, top layer and bottom layer number +!----------------------------------------------------------------------- + + toplay = 0 + botlay = 0 + numlay = 0 + + DO i = nlay, 1, -1 + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + ! to count the layer number + numlay = numlay + 1 + IF (toplay .eq. 0) THEN + ! set the top layer to current layer + toplay = i + ENDIF + + ! set this layer to be the bottom layer + botlay = i + + displa_lay(i) = max(displa_lay(i), hbot_lay(i)) + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate transmittance of longwave radiation for each layer +! diffuse case +!----------------------------------------------------------------------- + + thermk_lay(:) = 0. + fshade_lay(:) = 0. + + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + thermk_lay(clev) = thermk_lay(clev) + fshade(i) * thermk(i) + fshade_lay(clev) = fshade_lay(clev) + fshade(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fshade_lay(i) > 0) THEN + thermk_lay(i) = thermk_lay(i) / fshade_lay(i) + ELSE + thermk_lay(i) = 1. + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate the transfer matrix for long-wave radiation transfer +! direct case +! NOTE: don't need to calculate at each step +!----------------------------------------------------------------------- + + tdn(:,:) = 0. + tup(:,:) = 0. + + tdn(1,0) = 1. + tdn(2,0) = 1 - fshade_lay(1) + tdn(3,0) = 1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2) + tdn(4,0) = 1 - fshade_lay(1) - fshade_lay(2) - fshade_lay(3) & + + fshade_lay(1)*fshade_lay(2) & + + fshade_lay(1)*fshade_lay(3) & + + fshade_lay(2)*fshade_lay(3) & + - fshade_lay(1)*fshade_lay(2)*fshade_lay(3) + + tdn(2,1) = fshade_lay(1) + tdn(3,1) = (1 - fshade_lay(2))*fshade_lay(1) + tdn(4,1) = (1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3))*fshade_lay(1) + + tdn(3,2) = fshade_lay(2) + tdn(4,2) = (1 - fshade_lay(3))*fshade_lay(2) + tdn(4,3) = fshade_lay(3) + + tup(0,1) = fshade_lay(1) + tup(0,2) = (1 - fshade_lay(1))*fshade_lay(2) + tup(1,2) = fshade_lay(2) + + tup(0,3) = (1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2))*fshade_lay(3) + tup(1,3) = (1 - fshade_lay(2))*fshade_lay(3) + tup(2,3) = fshade_lay(3) + + tup(0,4) = tdn(4,0) + tup(1,4) = 1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3) + tup(2,4) = 1 - fshade_lay(3) + tup(3,4) = 1. + +!----------------------------------------------------------------------- +! calculate parameters for delta(Lv) for LW radiation transfer +!----------------------------------------------------------------------- + dLvpar(1) = 1. + dLvpar(2) = ( (1-fshade_lay(1)) + thermk_lay(1)*fshade_lay(1) )**2 + dLvpar(3) = ( tdn(3,0) & + + thermk_lay(2)*fshade_lay(2)*(1-fshade_lay(1)+thermk_lay(1)*fshade_lay(1)) & + + (1-fshade_lay(2))*thermk_lay(1)*fshade_lay(1) )**2 + +!----------------------------------------------------------------------- +! first guess for taf and qaf for each layer +! a large difference from previous schemes +!----------------------------------------------------------------------- + taf(:) = 0. + qaf(:) = 0. + + ! 05/02/2016: set taf/qaf according to layer number + IF (numlay .eq. 1) THEN + taf(toplay) = 0.5 * (tg + thm) + qaf(toplay) = 0.5 * (qm + qg ) + ENDIF + + IF (numlay .eq. 2) THEN + taf(botlay) = (2.*tg + thm)/3. + qaf(botlay) = (2.*qg + qm )/3. + taf(toplay) = (tg + 2.*thm)/3. + qaf(toplay) = (qg + 2.*qm )/3. + ENDIF + + IF (numlay .eq. 3) THEN + taf(1) = (3.*tg + thm)/4. + qaf(1) = (3.*qg + qm )/4. + taf(2) = (tg + thm )/2. + qaf(2) = (qg + qm )/2. + taf(3) = (tg + 3.*thm)/4. + qaf(3) = (qg + 3.*qm )/4. + ENDIF + +!----------------------------------------------------------------------- +! some environment variables +! how to calculate rsoil and what is its usage? +!----------------------------------------------------------------------- + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) +! rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) +! rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 +! rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 + +! initialization and input values for Monin-Obukhov + ! have been set before + z0mv = z0m_lays(3); z0hv = z0m_lays(3); z0qv = z0m_lays(3) + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (trim(HEIGHT_mode) == 'absolute') THEN + + IF (hu <= htop_lay(toplay)+1) THEN + hu_ = htop_lay(toplay) + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than htop+1, set it to htop+1.' + ENDIF + + IF (ht <= htop_lay(toplay)+1) THEN + ht_ = htop_lay(toplay) + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than htop+1, set it to htop+1.' + ENDIF + + IF (hq <= htop_lay(toplay)+1) THEN + hq_ = htop_lay(toplay) + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than htop+1, set it to htop+1.' + ENDIF + + ELSE ! relative height + hu_ = htop_lay(toplay) + hu + ht_ = htop_lay(toplay) + ht + hq_ = htop_lay(toplay) + hq + ENDIF + + zldis = hu_ - displa_lays(3) + + IF(zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL abort + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,um,obu) + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + DO WHILE (it .le. itmax) + + tlbef = tl + + del2 = del + dele2 = dele + + DO i = ps, pe + IF (tl(i) > tfrz) THEN + htvpl(i) = hvap + ELSE + htvpl(i) = hsub + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu_,ht_,hq_,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & + displa_lay(toplay),z0m_lay(toplay),hpbl,ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu_,ht_,hq_,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & + displa_lay(toplay),z0m_lay(toplay),ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF + +! Aerodynamic resistance + ! 09/16/2017: + ! note that for ram, it is the resistance from Href to z0mv+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! so rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective exchange + ! height) to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + +! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + z0h_lays(0) = z0hg + z0q_lays(0) = z0qg + + z0h_lays(1) = maxval(z0h_lays(0:1)) + z0h_lays(2) = maxval(z0h_lays(0:2)) + z0h_lays(3) = maxval(z0h_lays(0:3)) + + z0q_lays(:) = z0h_lays(:) + z0hv = z0h_lays(3) + z0qv = z0q_lays(3) + +! ...................................................................... +! new method to calculate rd and ueffect +! the kernel part of 3d model +! ...................................................................... + + ! initialization + rd(:) = 0. + upplay = 0 + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (htop_lay(toplay)-displa_lays(toplay)) * ustar / phih + + ! start layer loop + DO i = toplay, 1, -1 + + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + IF (i .eq. toplay) THEN + utop_lay(i) = utop + ktop_lay(i) = ktop + ELSE + ! calculate utop of this layer + utop_lay(i) = uprofile(ubot_lay(upplay), fcover_lays(upplay), bee, 0., & + z0mg, hbot_lay(upplay), htop_lay(i), htop_lay(i)) + + ! calculate ktop of this layer + ktop_lay(i) = kprofile(kbot_lay(upplay), fcover_lays(upplay), bee, 0., & + displa_lays(toplay)/htop_lay(toplay), & + hbot_lay(upplay), htop_lay(i), obug, ustarg, htop_lay(i)) + + ! areodynamic resistance between this layer top and above layer bottom + ! 03/15/2020, yuan: vertical gaps between layers + ! fc = fcover_lays(upplay) or just 0? + rd(upplay) = rd(upplay) + frd(kbot_lay(upplay), hbot_lay(upplay), htop_lay(i), & + hbot_lay(upplay), htop_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(upplay)) + + ENDIF + + ! for robust check + hbot_lay(i) = max(hbot_lay(i), displa_lays(i-1)+z0m_lays(i-1)) + + ! wind speed at layer bottom + ubot_lay(i) = uprofile(utop_lay(i), fcover_lay(i), bee, a_lay(i), & + z0mg, htop_lay(i), hbot_lay(i), hbot_lay(i)) + + IF (it == 1) THEN + ueff_lay_norm(i) = ueffect(1., htop_lay(i), hbot_lay(i), & + z0mg, a_lay(i), bee, fcover_lay(i)) + ENDIF + ueff_lay(i) = utop_lay(i)*ueff_lay_norm(i) + + ! normalized eddy coefficient (K) at layer bottom + kbot_lay(i) = kprofile(ktop_lay(i), fcover_lay(i), bee, a_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + htop_lay(i), hbot_lay(i), obug, ustarg, hbot_lay(i)) + + ! areodynamic resistance from effective fluxes exchange height of + ! of this layer to the top of this layer + IF (upplay > 0) THEN + rd(upplay) = rd(upplay) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & + htop_lay(i), displa_lay(i)+z0m_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, a_lay(i), bee, fcover_lay(i)) + ENDIF + + rd(i) = rd(i) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & + displa_lay(i)+z0m_lay(i), max(z0qg,hbot_lay(i)), & + displa_lays(toplay)/htop_lay(toplay), z0h_g, obug, ustarg, & + z0mg, a_lay(i), bee, fcover_lay(i)) + + upplay = i + + ENDIF + ENDDO + +! ...................................................................... +! areodynamic resistance between ground and the upper layer bottom +! ...................................................................... + + ! uncomment the below when the upper codes change to hbot_lay + !rd(botlay) = rd(botlay) + kintegral(kbot_lay(botlay), fcover_lays(botlay), bee, 0., & + ! z0mg, displa_lays(toplay)/htop_lay(toplay), & + ! hbot_lay(botlay), z0qg, obug, ustarg, hbot_lay(botlay), z0qg ) + + rd(botlay) = rd(botlay) + frd(kbot_lay(botlay), hbot_lay(botlay), z0qg, & + hbot_lay(botlay), z0qg, displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(botlay)) + +! ...................................................................... +! Bulk boundary layer resistance of leaves +! ...................................................................... + rb(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + cf = 0.01*sqrtdi(i)*sqrt(ueff_lay(clev)) + rb(i) = 1./cf + ENDIF + ENDDO + + ! 10/01/2017, back to 1D case + IF (rb_opt == 1) THEN + uaf = ustar + cf = 0.01*sqrtdi(2)/sqrt(uaf) + rb(:) = 1/(cf*uaf) + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction + + ! 10/01/2017, back to 1D case + IF (rd_opt == 1 ) THEN +! modified by Xubin Zeng's suggestion at 08-07-2002 + uaf = ustar + w = exp(-(lai(2)+sai(2))) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd(:) = 1./(csoilcn*uaf) + ENDIF + +!----------------------------------------------------------------------- +! stomatal resistances +!----------------------------------------------------------------------- + + DO i = ps, pe + p = pftclass(i) + IF(fcover(i)>0 .and. lai(i)>0.001) THEN + + rbsun = rb(i) / laisun(i) + rbsha = rb(i) / laisha(i) + + clev = canlay(i) + eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa + + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun(i) = 1. + rstfacsha(i) = 1. + ENDIF + +! note: calculate resistance for sunlit/shaded leaves +!----------------------------------------------------------------------- + CALL stomata ( vmax25(i) ,effcon(i) ,c3c4(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsun(i) ,& +!Ozone stress variables + o3coefv_sun(i), o3coefg_sun(i),& +!End ozone stress variables + lambda(i), & + rbsun ,raw ,rstfacsun(i),cintsun(:,i),& + assimsun(i),respcsun(i),rssun(i) ) + + CALL stomata ( vmax25(i) ,effcon(i) ,c3c4(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsha(i) ,& +!Ozone stress variables + o3coefv_sha(i), o3coefg_sha(i),& +!End ozone stress variables +!WUE stomata model parameter + lambda(i) ,& +!WUE stomata model parameter + rbsha ,raw ,rstfacsha(i),cintsha(:,i),& + assimsha(i),respcsha(i),rssha(i) ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun(i) = min( 1.e6, 1./(rssun(i)*tl(i)/tprcor) )/ laisun(i) * 1.e6 * o3coefg_sun(i) + gs0sha(i) = min( 1.e6, 1./(rssha(i)*tl(i)/tprcor) )/ laisha(i) * 1.e6 * o3coefg_sha(i) + + CALL PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr(:,i) ,psrf ,qsatl(i) ,qaf(clev) ,& + tl(i) ,rbsun ,rss ,raw ,sum(rd(1:clev)),& + rstfacsun(i) ,rstfacsha(i) ,cintsun(:,i) ,cintsha(:,i) ,laisun(i) ,& + laisha(i) ,rhoair ,fwet(i) ,sai(i) ,kmax_sun(i) ,& + kmax_sha(i) ,kmax_xyl(i) ,kmax_root(i) ,psi50_sun(i) ,psi50_sha(i) ,& + psi50_xyl(i) ,psi50_root(i),htop(i) ,ck(i) ,smp ,& + hk ,hksati ,vegwp(:,i) ,etrsun(i) ,etrsha(i) ,& + rootflux(:,i),qg ,qm ,gs0sun(i) ,gs0sha(i) ,& + k_soil_root ,k_ax_root ,gssun(i) ,gssha(i) ) + + etr(i) = etrsun(i) + etrsha(i) + gssun(i) = gssun(i) * laisun(i) * 1.e-6 + gssha(i) = gssha(i) * laisha(i) * 1.e-6 + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsun(i), psrf, rstfacsun(i), & + rb(i), gssun(i), effcon(i), vmax25(i), c3c4(i), gradm(i), trop(i), slti(i), hlti(i), & + shti(i), hhti(i), trda(i), trdm(i), cintsun(:,i), assimsun(i), respcsun(i)) + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsha(i), psrf, rstfacsha(i), & + rb(i), gssha(i), effcon(i), vmax25(i), c3c4(i), gradm(i), trop(i), slti(i), hlti(i), & + shti(i), hhti(i), trda(i), trdm(i), cintsha(:,i), assimsha(i), respcsha(i)) + + ! leaf scale stomata resistance + rssun(i) = tprcor / tl(i) / gssun(i) + rssha(i) = tprcor / tl(i) / gssha(i) + + ENDIF + + ELSE + rssun(i) = 2.e4; assimsun(i) = 0.; respcsun(i) = 0. + rssha(i) = 2.e4; assimsha(i) = 0.; respcsha(i) = 0. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr(i) = 0. + rootflux(:,i) = 0. + ENDIF + ENDIF + ENDDO + +! above stomatal resistances are for the canopy, the stomatal resistances +! and the "rb" in the following calculations are the average for single leaf. thus, + rssun = rssun * laisun + rssha = rssha * laisha + +!----------------------------------------------------------------------- +! dimensional and non-dimensional sensible and latent heat conductances +! for canopy and soil flux calculations. +!----------------------------------------------------------------------- + + cfh(:) = 0. + cfw(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + + clev = canlay(i) + delta(i) = 0.0 + IF(qsatl(i)-qaf(clev) .gt. 0.) delta(i) = 1.0 + + cfh(i) = lsai(i) / rb(i) + +! note: combine sunlit and shaded leaves +!----------------------------------------------------------------------- + cfw(i) = (1.-delta(i)*(1.-fwet(i)))*lsai(i)/rb(i) + & + (1.-fwet(i))*delta(i)* & + ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) + ENDIF + ENDDO + + ! initialization + cah(:) = 0. + caw(:) = 0. + cgh(:) = 0. + cgw(:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + IF (i == toplay) THEN + cah(i) = 1. / rah + caw(i) = 1. / raw + ELSE + cah(i) = 1. / rd(i+1) + caw(i) = 1. / rd(i+1) + ENDIF + + cgh(i) = 1. / rd(i) + IF (i == botlay) THEN + IF (qg < qaf(botlay)) THEN + cgw(i) = 1. / rd(i) !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw(i) = rss/ rd(i) + ELSE + cgw(i) = 1. / (rd(i) + rss) + ENDIF + ENDIF + ELSE + cgw(i) = 1. / rd(i) + ENDIF + ENDIF + ENDDO + + ! calculate wtshi, wtsqi + wtshi(:) = cah(:) + cgh(:) + wtsqi(:) = caw(:) + cgw(:) + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + wtshi(clev) = wtshi(clev) + fcover(i)*cfh(i) + wtsqi(clev) = wtsqi(clev) + fcover(i)*cfw(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + wtshi(i) = 1./wtshi(i) + wtsqi(i) = 1./wtsqi(i) + ENDIF + ENDDO + + wah(:) = cah(:) * wtshi(:) + wgh(:) = cgh(:) * wtshi(:) + + waq(:) = caw(:) * wtsqi(:) + wgq(:) = cgw(:) * wtsqi(:) + + ! calculate wlh, wlhl, wlq, wlql + wlhl(:) = 0. + wlql(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + + wlh(i) = cfh(i) * wtshi(clev) * fcover(i) + wlhl(clev) = wlhl(clev) + wlh(i)*tl(i) + + wlq(i) = cfw(i) * wtsqi(clev) * fcover(i) + wlql(clev) = wlql(clev) + wlq(i)*qsatl(i) + ENDIF + ENDDO + + ! to solve taf(:) and qaf(:) + IF (numlay .eq. 1) THEN + + taf(toplay) = wah(toplay)*thm + wgh(toplay)*tg + wlhl(toplay) + qaf(toplay) = waq(toplay)*qm + wgq(toplay)*qg + wlql(toplay) + fact = 1. + facq = 1. + + ENDIF + + IF (numlay .eq. 2) THEN + + tmpw1 = wgh(botlay)*tg + wlhl(botlay) + fact = 1. - wgh(toplay)*wah(botlay) + taf(toplay) = ( wah(toplay)*thm + wgh(toplay)*tmpw1 + wlhl(toplay) ) / fact + + tmpw1 = wgq(botlay)*qg + wlql(botlay) + facq = 1. - wgq(toplay)*waq(botlay) + qaf(toplay) = ( waq(toplay)*qm + wgq(toplay)*tmpw1 + wlql(toplay) ) / facq + + taf(botlay) = wah(botlay)*taf(toplay) + wgh(botlay)*tg + wlhl(botlay) + qaf(botlay) = waq(botlay)*qaf(toplay) + wgq(botlay)*qg + wlql(botlay) + + ENDIF + + IF (numlay .eq. 3) THEN + + tmpw1 = wah(3)*thm + wlhl(3) + tmpw2 = wgh(1)*tg + wlhl(1) + fact = 1. - wah(2)*wgh(3) - wgh(2)*wah(1) + taf(2) = ( wah(2)*tmpw1 + wgh(2)*tmpw2 + wlhl(2) ) / fact + + tmpw1 = waq(3)*qm + wlql(3) + tmpw2 = wgq(1)*qg + wlql(1) + facq = 1. - waq(2)*wgq(3) - wgq(2)*waq(1) + qaf(2) = ( waq(2)*tmpw1 + wgq(2)*tmpw2 + wlql(2) ) / facq + + taf(1) = wah(1)*taf(2) + wgh(1)*tg + wlhl(1) + qaf(1) = waq(1)*qaf(2) + wgq(1)*qg + wlql(1) + + taf(3) = wah(3)*thm + wgh(3)*taf(2) + wlhl(3) + qaf(3) = waq(3)*qm + wgq(3)*qaf(2) + wlql(3) + + ENDIF + +!----------------------------------------------------------------------- +! IR radiation, sensible and latent heat fluxes and their derivatives +!----------------------------------------------------------------------- +! the partial derivatives of areodynamical resistance are ignored +! which cannot be determined analytically + +! calculate L for each canopy layer + L(:) = 0. + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + ! according to absorption = emissivity, fcover -> fshade + L(clev) = L(clev) + fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 + ENDIF + ENDDO + +! calculate Ltd + Ltd(:) = 0. + Ltd(3) = thermk_lay(3) * tdn(4,3) * frl + Ltd(2) = thermk_lay(2) * ( tdn(4,2)*frl + tdn(3,2)*(Ltd(3) + L(3)) ) + Ltd(1) = thermk_lay(1) * ( tdn(4,1)*frl + tdn(3,1)*(Ltd(3) + L(3)) + & + tdn(2,1)*(Ltd(2) + L(2)) ) + +! calculate Ld = Ltd + L + Ld(0) = 0. + Ld(4) = frl + Ld(1:3) = Ltd + L + +! calculate Lin = Ld * tdn + Lin(:) = matmul(Ld(:), tdn(:,:)) + +! calculate Lg = (1-emg)*dlrad + emg*stefnc*tg**4 +! dlrad = Lin(0) +IF (.not.DEF_SPLIT_SOILSNOW) THEN + Lg = (1 - emg)*Lin(0) + emg*stefnc*tg**4 +ELSE + Lg = (1 - emg)*Lin(0) & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 +ENDIF + +! calculate Ltu + Ltu(1) = thermk_lay(1) * tup(0,1) * Lg + Ltu(2) = thermk_lay(2) * ( tup(0,2)*Lg + tup(1,2)*(Ltu(1) + L(1)) ) + Ltu(3) = thermk_lay(3) * ( tup(0,3)*Lg + tup(1,3)*(Ltu(1) + L(1)) + & + tup(2,3)*(Ltu(2) + L(2)) ) + +! calculate Lu = Ltu + L + Lu(0) = Lg + Lu(4) = 0. + Lu(1:3) = Ltu + L + +! calculate Lin = Lin + Lu*tup + Lin(:) = Lin(:) + matmul(Lu(:), tup(:,:)) + +! calculate Lv + Lv(:) = 0. + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + Lv(i) = fshade(i)/fshade_lay(clev) * (1-thermk(i)) * Lin(clev) / fcover(i) & + - 2. * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 / fcover(i) + ENDIF + ENDDO + +! calculate delta(Lv) + dLv(:) = 0. + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + dLv(i) = (4.*dLvpar(clev)*(1-emg)*fshade(i)*(1-thermk(i)) - 8.) & + * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**3 / fcover(i) + ENDIF + ENDDO + +!----------------------------------------------------------------------- + + irab(:) = Lv(:) + dirab_dtl(:) = dLv(:) + + DO i = ps, pe + + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + + clev = canlay(i) + fac(i) = 1. - thermk(i) + +! sensible heat fluxes and their derivatives + fsenl(i) = rhoair * cpair * cfh(i) * (tl(i) - taf(clev)) + + ! 09/25/2017: re-written, check it carefully + ! When numlay<3, no matter how to calculate, /fact is consistent + IF (numlay < 3 .or. clev == 2) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) * (1. - wlh(i)/fact) + ELSE + IF (clev == 1) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) & + !* (1. - (1.-wah(2)*wgh(3))*wlh(i)/fact) or + * (1. - wah(1)*wgh(2)*wlh(i)/fact - wlh(i)) + ENDIF + IF (clev == 3) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) & + !* (1. - (1.-wgh(2)*wah(1))*wlh(i)/fact) or + * (1. - wgh(3)*wah(2)*wlh(i)/fact - wlh(i)) + ENDIF + ENDIF + +! latent heat fluxes and their derivatives + + etr(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + * ( qsatl(i) - qaf(clev) ) + + ! 09/25/2017: re-written + IF (numlay < 3 .or. clev == 2) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + * (1. - wlq(i)/facq)*qsatlDT(i) + ELSE + IF (clev == 1) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + !* (1. - (1.-waq(2)*wgq(3))*wlq(i)/facq)*qsatlDT(i) or + * (1. - waq(1)*wgq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + IF (clev == 3) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + !* (1. - (1.-wgq(2)*waq(1))*wlq(i)/facq)*qsatlDT(i) or + * (1. - wgq(3)*waq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + ENDIF + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr(i).ge.etrc(i))THEN + etr(i) = etrc(i) + etr_dtl(i) = 0. + ENDIF + ENDIF + + evplwet(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + * ( qsatl(i) - qaf(clev) ) + + ! 09/25/2017: re-written + IF (numlay < 3 .or. clev == 2) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + * (1. - wlq(i)/facq)*qsatlDT(i) + ELSE + IF (clev == 1) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + !* (1. - (1-waq(2)*wgq(3))*wlq(i)/facq)*qsatlDT(i) or + * (1. - waq(1)*wgq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + IF (clev == 3) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + !* (1. - (1.-wgq(2)*waq(1))*wlq(i)/facq)*qsatlDT(i) or + * (1. - wgq(3)*waq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + ENDIF + + ! 03/02/2018: convert evplwet from fc to whole area + ! because ldew right now is for the whole area + ! 09/05/2019: back to fc area + IF(evplwet(i).ge.ldew(i)/deltim)THEN + evplwet(i) = ldew(i)/deltim + evplwet_dtl(i) = 0. + ENDIF + + fevpl(i) = etr(i) + evplwet(i) + fevpl_dtl(i) = etr_dtl(i) + evplwet_dtl(i) + + erre(i) = 0. + fevpl_noadj(i) = fevpl(i) + IF ( fevpl(i)*fevpl_bef(i) < 0. ) THEN + erre(i) = -0.9*fevpl(i) + fevpl(i) = 0.1*fevpl(i) + ENDIF + +!----------------------------------------------------------------------- +! difference of temperatures by quasi-newton-raphson method for the non-linear system equations +! MARK#dtl +!----------------------------------------------------------------------- + + dtl(it,i) = (sabv(i) + irab(i) - fsenl(i) - hvap*fevpl(i) & + + cpliq*qintr_rain(i)*(t_precip-tl(i)) & + + cpice*qintr_snow(i)*(t_precip-tl(i))) & + / (clai(i)/deltim - dirab_dtl(i) + fsenl_dtl(i) + hvap*fevpl_dtl(i) & + + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) + + dtl_noadj(i) = dtl(it,i) + + ! check magnitude of change in leaf temperature limit to maximum allowed value + + IF (it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF(abs(dtl(it,i)).gt.delmax)THEN + dtl(it,i) = delmax*dtl(it,i)/abs(dtl(it,i)) + ENDIF + + ! NOTE: could be a bug if dtl*dtl==0, changed from lt->le + IF((it.ge.2) .and. (dtl(it-1,i)*dtl(it,i).le.0.))THEN + dtl(it,i) = 0.5*(dtl(it-1,i) + dtl(it,i)) + ENDIF + + ENDIF + + tl(i) = tlbef(i) + dtl(it,i) + +!----------------------------------------------------------------------- +! square roots differences of temperatures and fluxes for USE as the condition of convergences +!----------------------------------------------------------------------- + + del(i) = sqrt( dtl(it,i)*dtl(it,i) ) + dele(i) = dtl(it,i) * dtl(it,i) * & + ( dirab_dtl(i)**2 + fsenl_dtl(i)**2 + (hvap*fevpl_dtl(i))**2 ) + dele(i) = sqrt(dele(i)) + +!----------------------------------------------------------------------- +! saturated vapor pressures and canopy air temperature, canopy air humidity +!----------------------------------------------------------------------- +! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature +! and adjust specific humidity (qsatl_) proportionately + CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) + + ENDIF + ENDDO !END pft loop + +! update vegetation/ground surface temperature, canopy air temperature, +! canopy air humidity + + ! calculate wlhl, wlql + wlhl(:) = 0. + wlql(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + wlhl(clev) = wlhl(clev) + wlh(i)*tl(i) + wlql(clev) = wlql(clev) + wlq(i)*qsatl(i) + ENDIF + ENDDO + + IF (numlay .eq. 1) THEN + + taf(toplay) = wah(toplay)*thm + wgh(toplay)*tg + wlhl(toplay) + qaf(toplay) = waq(toplay)*qm + wgq(toplay)*qg + wlql(toplay) + fact = 1. + facq = 1. + + ENDIF + + IF (numlay .eq. 2) THEN + + tmpw1 = wgh(botlay)*tg + wlhl(botlay) + fact = 1. - wgh(toplay)*wah(botlay) + taf(toplay) = (wah(toplay)*thm + wgh(toplay)*tmpw1 + wlhl(toplay)) / fact + + tmpw1 = wgq(botlay)*qg + wlql(botlay) + facq = 1. - wgq(toplay)*waq(botlay) + qaf(toplay) = (waq(toplay)*qm + wgq(toplay)*tmpw1 + wlql(toplay)) / facq + + taf(botlay) = wah(botlay)*taf(toplay) + wgh(botlay)*tg + wlhl(botlay) + qaf(botlay) = waq(botlay)*qaf(toplay) + wgq(botlay)*qg + wlql(botlay) + + ENDIF + + IF (numlay .eq. 3) THEN + + tmpw1 = wah(3)*thm + wlhl(3) + tmpw2 = wgh(1)*tg + wlhl(1) + fact = 1. - wah(2)*wgh(3) - wgh(2)*wah(1) + taf(2) = (wah(2)*tmpw1 + wgh(2)*tmpw2 + wlhl(2)) / fact + + tmpw1 = waq(3)*qm + wlql(3) + tmpw2 = wgq(1)*qg + wlql(1) + facq = 1. - waq(2)*wgq(3) - wgq(2)*waq(1) + qaf(2) = (waq(2)*tmpw1 + wgq(2)*tmpw2 + wlql(2)) / facq + + taf(1) = wah(1)*taf(2) + wgh(1)*tg + wlhl(1) + qaf(1) = waq(1)*qaf(2) + wgq(1)*qg + wlql(1) + + taf(3) = wah(3)*thm + wgh(3)*taf(2) + wlhl(3) + qaf(3) = waq(3)*qm + wgq(3)*qaf(2) + wlql(3) + + ENDIF + +! update co2 partial pressure within canopy air + ! 05/02/2016: may have some problem with gdh2o, however, + ! this variable seems never used here. Different height + ! level vegetation should have different gdh2o, i.e., + ! different rd(layer) values. + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd(botlay) * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd(botlay)+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + sum(fcover*(assimsun + assimsha - respcsun - respcsha - rsoil)) + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) + + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF(zeta .ge. 0.)THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta .ge. 0.)THEN + um = max(ur,.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu_,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF(obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu + +!----------------------------------------------------------------------- +! Test for convergence +!----------------------------------------------------------------------- + + it = it+1 + + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = maxval(max(del,del2)) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = maxval(max(dele,dele2)) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + +! ====================================================================== +! END stability iteration +! ====================================================================== + + IF(DEF_USE_OZONESTRESS)THEN + DO i = ps, pe + p = pftclass(i) + CALL CalcOzoneStress(o3coefv_sun(i),o3coefg_sun(i),forc_ozone,psrf,th,ram,& + rssun(i),rb(i),lai(i),lai_old(i),p,o3uptakesun(i),sabv(i),deltim) + CALL CalcOzoneStress(o3coefv_sha(i),o3coefg_sha(i),forc_ozone,psrf,th,ram,& + rssha(i),rb(i),lai(i),lai_old(i),p,o3uptakesha(i),sabv(i),deltim) + lai_old(i) = lai(i) + assimsun(i) = assimsun(i) * o3coefv_sun(i) + assimsha(i) = assimsha(i) * o3coefv_sha(i) +! rssun (i) = rssun (i) / o3coefg_sun(i) +! rssha (i) = rssha (i) / o3coefg_sha(i) + ENDDO + ELSE + DO i = ps, pe + o3coefv_sun(i) = 1.0_r8 + o3coefg_sun(i) = 1.0_r8 + o3coefv_sha(i) = 1.0_r8 + o3coefg_sha(i) = 1.0_r8 + ENDDO + ENDIF + + z0m = z0mv + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! canopy fluxes and total assimilation and respiration + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + + IF(lai(i) .gt. 0.001) THEN + rst(i) = 1./(laisun(i)/rssun(i) + laisha(i)/rssha(i)) + ELSE + rssun(i) = 2.0e4 ; rssha(i) = 2.0e4 + assimsun(i) = 0. ; assimsha(i) = 0. + respcsun(i) = 0. ; respcsha(i) = 0. + rst(i) = 2.0e4 + ENDIF + assim(i) = assimsun(i) + assimsha(i) + respc(i) = respcsun(i) + respcsha(i) + rsoil + +! canopy fluxes and total assimilation and respiration + fsenl(i) = fsenl(i) + fsenl_dtl(i)*dtl(it-1,i) & + ! add the imbalanced energy below due to T adjustment to sensible heat + + (dtl_noadj(i)-dtl(it-1,i)) * (clai(i)/deltim - dirab_dtl(i) & + + fsenl_dtl(i) + hvap*fevpl_dtl(i) & + + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) & + ! add the imbalanced energy below due to q adjustment to sensible heat + + hvap*erre(i) + + etr0(i) = etr(i) + etr (i) = etr(i) + etr_dtl(i)*dtl(it-1,i) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF(abs(etr0(i)) .ge. 1.e-15)THEN + rootflux(:,i) = rootflux(:,i) * etr(i) / etr0(i) + ELSE + rootflux(:,i) = rootflux(:,i) + dz_soi / sum(dz_soi) * etr_dtl(i)* dtl(it-1,i) + ENDIF + + !NOTE: temporal solution to make etr and rootflux consistent. + !TODO: need double check + sumrootflux = sum(rootflux(:,i), rootflux(:,i)>0.) + IF (abs(sumrootflux) > 0.) THEN + rootflux(:,i) = max(rootflux(:,i),0.) * (etr(i)/sumrootflux) + ELSE + rootflux(:,i) = etr(i)*rootfr(:,i) + ENDIF + ENDIF + + evplwet(i) = evplwet(i) + evplwet_dtl(i)*dtl(it-1,i) + fevpl (i) = fevpl_noadj(i) + fevpl (i) = fevpl(i) + fevpl_dtl(i)*dtl(it-1,i) + + elwmax = ldew(i)/deltim + + ! 03/02/2018, yuan: convert fc to whole area + ! because ldew now is for the whole area + ! may need to change to canopy covered area + ! 09/14/2019, yuan: change back to canopy area + elwdif = max(0., evplwet(i)-elwmax) + evplwet(i) = min(evplwet(i), elwmax) + + fevpl(i) = fevpl(i) - elwdif + fsenl(i) = fsenl(i) + hvap*elwdif + + ! precipitation sensible heat from canopy + hprl (i) = cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i)) + + ! vegetation heat change + dheatl(i) = clai(i)/deltim*dtl(it-1,i) + +!----------------------------------------------------------------------- +! Update dew accumulation (kg/m2) +!----------------------------------------------------------------------- + IF (DEF_Interception_scheme .eq. 1) THEN !colm2014 + + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl(i) > tfrz) THEN + qevpl(i) = max (evplwet(i), 0.) + qdewl(i) = abs (min (evplwet(i), 0.) ) + qsubl(i) = 0. + qfrol(i) = 0. + + IF (qevpl(i) > ldew_rain(i)/deltim) THEN + qsubl(i) = qevpl(i) - ldew_rain(i)/deltim + qevpl(i) = ldew_rain(i)/deltim + ENDIF + ELSE + qevpl(i) = 0. + qdewl(i) = 0. + qsubl(i) = max (evplwet(i), 0.) + qfrol(i) = abs (min (evplwet(i), 0.) ) + + IF (qsubl(i) > ldew_snow(i)/deltim) THEN + qevpl(i) = qsubl(i) - ldew_snow(i)/deltim + qsubl(i) = ldew_snow(i)/deltim + ENDIF + ENDIF + + ldew_rain(i) = ldew_rain(i) + (qdewl(i)-qevpl(i))*deltim + ldew_snow(i) = ldew_snow(i) + (qfrol(i)-qsubl(i))*deltim + + ldew(i) = ldew_rain(i) + ldew_snow(i) + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 8) THEN !CoLM202x + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSE + CALL abort + ENDIF + + IF ( DEF_VEG_SNOW ) THEN + ! update fwet_snow + fwet_snow(i) = 0 + IF(ldew_snow(i) > 0.) THEN + fwet_snow(i) = ((10./(48.*lsai(i)))*ldew_snow(i))**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow(i) = min(fwet_snow(i),1.0) + ENDIF + + ! phase change + + qmelt(i) = 0. + qfrz(i) = 0. + + IF (ldew_snow(i).gt.1.e-6 .and. tl(i).gt.tfrz) THEN + qmelt(i) = min(ldew_snow(i)/deltim,(tl(i)-tfrz)*cpice*ldew_snow(i)/(deltim*hfus)) + ldew_snow(i) = max(0.,ldew_snow(i) - qmelt(i)*deltim) + ldew_rain(i) = max(0.,ldew_rain(i) + qmelt(i)*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl(i) = fwet_snow(i)*tfrz + (1.-fwet_snow(i))*tl(i) !Niu et al., 2004 + ENDIF + + IF (ldew_rain(i).gt.1.e-6 .and. tl(i).lt.tfrz) THEN + qfrz(i) = min(ldew_rain(i)/deltim,(tfrz-tl(i))*cpliq*ldew_rain(i)/(deltim*hfus)) + ldew_rain(i) = max(0.,ldew_rain(i) - qfrz(i)*deltim) + ldew_snow(i) = max(0.,ldew_snow(i) + qfrz(i)*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl(i) = fwet_snow(i)*tfrz + (1.-fwet_snow(i))*tl(i) !Niu et al., 2004 + ENDIF + ENDIF + +!----------------------------------------------------------------------- +! balance check +! (the computational error was created by the assumed 'dtl' in MARK#dtl) +!----------------------------------------------------------------------- + + err = sabv(i) + irab(i) + dirab_dtl(i)*dtl(it-1,i) & + - fsenl(i) - hvap*fevpl(i) + hprl(i) & + ! account for vegetation heat change + - dheatl(i) + +#if (defined CoLMDEBUG) + IF(abs(err) .gt. .2) & + write(6,*) 'energy imbalance in LeafTemperaturePC.F90', & + i,it-1,err,sabv(i),irab(i),fsenl(i),hvap*fevpl(i),hprl(i),dheatl(i) +#endif + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! downward (upward) longwave radiation below (above) the canopy +!----------------------------------------------------------------------- + dlrad = Lin(0) & + + sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + + ulrad = Lin(4) - sum( fcover * dLv * dtl(it-1,:) ) & + - emg * sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + +!----------------------------------------------------------------------- +! wind stresses +!----------------------------------------------------------------------- + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from ground to canopy space +!----------------------------------------------------------------------- + +! 03/07/2020, yuan: TODO-done, calculate fseng_soil/snow, fevpg_soil/snow + IF (numlay .eq. 1) THEN + ttaf = thm + tqaf = qm + ENDIF + + IF (numlay .eq. 2) THEN + ttaf = taf(toplay) + tqaf = qaf(toplay) + ENDIF + + IF (numlay .eq. 3) THEN + ttaf = taf(2) + tqaf = qaf(2) + ENDIF + + !NOTE: the below EQs for check purpose only + ! taf = wah*thm + wgh*tg + wlh*tl + ! taf(1) = wah(1)*taf(2) + wgh(1)*tg + wlhl(1) + ! qaf(1) = waq(1)*qaf(2) + wgq(1)*qg + wlql(1) + ! taf(botlay) = wah(botlay)*taf(toplay) + wgh(botlay)*tg + wlhl(botlay) + ! qaf(botlay) = waq(botlay)*qaf(toplay) + wgq(botlay)*qg + wlql(botlay) + ! taf(toplay) = wah(toplay)*thm + wgh(toplay)*tg + wlhl(toplay) + ! qaf(toplay) = waq(toplay)*qm + wgq(toplay)*qg + wlql(toplay) + + fseng = cpair*rhoair*cgh(botlay)*(tg-taf(botlay)) + fseng_soil = cpair*rhoair*cgh(botlay)*((1.-wgh(botlay))*t_soil-wah(botlay)*ttaf-wlhl(botlay)) + fseng_snow = cpair*rhoair*cgh(botlay)*((1.-wgh(botlay))*t_snow-wah(botlay)*ttaf-wlhl(botlay)) + + fevpg = rhoair*cgw(botlay)*(qg-qaf(botlay)) + fevpg_soil = rhoair*cgw(botlay)*((1.-wgq(botlay))*q_soil-waq(botlay)*tqaf-wlql(botlay)) + fevpg_snow = rhoair*cgw(botlay)*((1.-wgq(botlay))*q_snow-waq(botlay)*tqaf-wlql(botlay)) + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature (cgrnd) +!----------------------------------------------------------------------- + + !NOTE: When numlay<3, no matter how to get the solution, /fact is consistent + IF (numlay < 3) THEN + cgrnds = cpair*rhoair*cgh(botlay)*(1.-wgh(botlay)/fact) + cgrndl = rhoair*cgw(botlay)*(1.-wgq(botlay)/facq)*dqgdT + ELSE + cgrnds = cpair*rhoair*cgh(botlay)*(1.-wah(1)*wgh(2)*wgh(1)/fact-wgh(1)) + cgrndl = rhoair*cgw(botlay)*(1.-waq(1)*wgq(2)*wgq(1)/facq-wgq(1))*dqgdT + ENDIF + + cgrnd = cgrnds + cgrndl*htvp + +!----------------------------------------------------------------------- +! 2 m height air temperature +!----------------------------------------------------------------------- + + tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE LeafTemperaturePC +!---------------------------------------------------------------------- + + + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! determine fraction of foliage covered by water and +! fraction of foliage that is dry and transpiring +! +! !REVISIONS: +! 2024.04.16, Hua Yuan: add option to account for vegetation snow process +! 2018.06 , Hua Yuan: remove sigf, to compatible with PFT +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water&snow [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) :: lsai !lai + sai + real(r8) :: dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) :: vegt !sigf*lsai, NOTE: remove sigf + real(r8) :: fwet_rain !fraction of foliage covered by water [-] + real(r8) :: fwet_snow !fraction of foliage covered by snow [-] + +!----------------------------------------------------------------------- +! Fwet is the fraction of all vegetation surfaces which are wet +! including stem area which contribute to evaporation + lsai = lai + sai + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 + ! Check for maximum limit of fwet + fwet = min(fwet,1.0) + ENDIF + + ! account for vegetation snow + ! calculate fwet_rain, fwet_snow, fwet + IF ( DEF_VEG_SNOW ) THEN + + fwet_rain = 0 + IF(ldew_rain > 0.) THEN + fwet_rain = ((dewmxi/vegt)*ldew_rain)**.666666666666 + ! Check for maximum limit of fwet_rain + fwet_rain = min(fwet_rain,1.0) + ENDIF + + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((dewmxi/(48.*vegt))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + fwet = fwet_rain + fwet_snow - fwet_rain*fwet_snow + fwet = min(fwet,1.0) + ENDIF + + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai + + END SUBROUTINE dewfraction + +END MODULE MOD_LeafTemperaturePC diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 new file mode 100644 index 0000000000..365fd4e68c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 @@ -0,0 +1,116 @@ +#include + +#ifdef BGC +MODULE MOD_LightningData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in lightning data for fire subroutine +! +! !ORIGINAL: +! Zhang Shupeng, 2022, prepare the original version of the lightning data module. +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_BGC_Vars_TimeVariables, only: lnfm + IMPLICIT NONE + + character(len=256) :: file_lightning + type(grid_type) :: grid_lightning + + type(block_data_real8_2d) :: f_lnfm + + type (spatial_mapping_type) :: mg2p_lnfm + +CONTAINS + + SUBROUTINE init_lightning_data (idate) + +!----------------------------------------------------------------------- +! !DESCTIPTION: +! open lightning netcdf file from DEF_dir_rawdata, read latitude and longitude info. +! Initialize lightning data read in. +!----------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + integer :: itime + + file_lightning = trim(DEF_dir_runtime) // & + '/fire/clmforc.Li_2012_climo1995-2011.T62.lnfm_Total_c140423.nc' + + CALL ncio_read_bcast_serial (file_lightning, 'lat', lat) + CALL ncio_read_bcast_serial (file_lightning, 'lon', lon) + + CALL grid_lightning%define_by_center (lat, lon) + + CALL allocate_block_data (grid_lightning, f_lnfm) + + CALL mg2p_lnfm%build_arealweighted (grid_lightning, landpatch) + + itime = (idate(2)-1)*8 + min(idate(3)/10800+1,8) + IF (itime .gt. 2920)itime = itime - 8 ! for the leap year + + CALL ncio_read_block_time (file_lightning, 'lnfm', grid_lightning, itime, f_lnfm) +#ifdef RangeCheck + CALL check_block_data ('lightning', f_lnfm) +#endif + + END SUBROUTINE init_lightning_data + + + SUBROUTINE update_lightning_data (time, deltim) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! read lightning data during simulation +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + type(timestamp), intent(in) :: time + real(r8), intent(in) :: deltim + + ! Local Variables + type(timestamp) :: time_next + integer :: itime, itime_next + + itime = (time%day-1)*8 + min(time%sec/10800+1,8) + IF (mod(time%sec,10800) == 0) itime = itime - 1 + + time_next = time + int(deltim) + itime_next = (time_next%day-1)*8 + max(0,time_next%sec-1)/10800+1 + + IF (itime_next /= itime) THEN + itime_next = min(itime_next,2920) + CALL ncio_read_block_time (file_lightning, 'lnfm', grid_lightning, itime_next, f_lnfm) +#ifdef RangeCheck + CALL check_block_data ('lightning', f_lnfm) +#endif + + CALL mg2p_lnfm%grid2pset (f_lnfm, lnfm) +#ifdef RangeCheck + CALL check_vector_data ('lightning', lnfm) +#endif + ENDIF + + END SUBROUTINE update_lightning_data + +END MODULE MOD_LightningData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 new file mode 100644 index 0000000000..22899d863e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 @@ -0,0 +1,746 @@ +#include + +!"-------------------------------------------------------------------------------------------" +!" Atmospheric CO2 concentrations (ppm) derived from in situ air measurements " +!" at Mauna Loa, Observatory, Hawaii: Latitude 19.5°N Longitude 155.6°W Elevation 3397m " +!" " +!" Source: R. F. Keeling, S. J. Walker, S. C. Piper and A. F. Bollenbacher " +!" Scripps CO2 Program ( http://scrippsco2.ucsd.edu ) " +!" Scripps Institution of Oceanography (SIO) " +!" University of California " +!" La Jolla, California USA 92093-0244 " +!" " +!" Status of data and correspondence: " +!" " +!" These data are subject to revision based on recalibration of standard gases. Questions " +!" about the data should be directed to Dr. Ralph Keeling (rkeeling@ucsd.edu), Stephen Walker" +!" (sjwalker@ucsd.edu) and Stephen Piper (scpiper@ucsd.edu), Scripps CO2 Program. " +!" " +!" Baseline data in this file through 03-May-2022 from archive dated 04-May-2022 09:22:14 " +!" " +!"-------------------------------------------------------------------------------------------" +!" " +!" Please cite as: " +!" " +!" C. D. Keeling, S. C. Piper, R. B. Bacastow, M. Wahlen, T. P. Whorf, M. Heimann, and " +!" H. A. Meijer, Exchanges of atmospheric CO2 and 13CO2 with the terrestrial biosphere and " +!" oceans from 1978 to 2000. I. Global aspects, SIO Reference Series, No. 01-06, Scripps " +!" Institution of Oceanography, San Diego, 88 pages, 2001. " +!" " +!" If it is necessary to cite a peer-reviewed article, please cite as: " +!" " +!" C. D. Keeling, S. C. Piper, R. B. Bacastow, M. Wahlen, T. P. Whorf, M. Heimann, and " +!" H. A. Meijer, Atmospheric CO2 and 13CO2 exchange with the terrestrial biosphere and " +!" oceans from 1978 to 2000: observations and carbon cycle implications, pages 83-113, " +!" in "A History of Atmospheric CO2 and its effects on Plants, Animals, and Ecosystems", " +!" editors, Ehleringer, J.R., T. E. Cerling, M. D. Dearing, Springer Verlag, " +!" New York, 2005. " +!" " +!"-------------------------------------------------------------------------------------------" + +MODULE MOD_MonthlyinSituCO2MaunaLoa +! ------------------------------- +! +! !DESCRIPTION: +! Monthly atmospheric CO2 concentrations (ppm) for model input derived from +! in situ air measurements at Mauna Loa, Observatory, Hawaii +! +! Created by Hua Yuan, 05/2022 +! +! !REVISIONS: +! !---2023.02.23 Zhongwang Wei @ SYSU: Added CO2 data (TODO:details?@zhongwang) +! in init_monthly_co2_mlo() +! !---2022.12.12 Zhongwang Wei @ SYSU: Added history and SSP CO2 data in init_monthly_co2_mlo() +! ------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_SSP + IMPLICIT NONE + SAVE + + ! define the CO2 data time range + integer, parameter :: syear = 1849 + integer, parameter :: eyear = 2100 + integer, parameter :: smonth = 1 + integer, parameter :: emonth = 12 + + real(r8), dimension(syear:eyear, 12) :: co2mlo + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: init_monthly_co2_mlo + PUBLIC :: get_monthly_co2_mlo + +CONTAINS + + SUBROUTINE init_monthly_co2_mlo + !DESCRIPTION + !=========== + !---This MODULE is used for initialize the CO2 concentration. + + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !Original Author: + !------------------- + !Hua Yuan @ SYSU 2021.05.05 + + !References: + !------------------- + !---1850-1957 obtained from + ! https://data.isimip.org/datasets/0497b2a7-fd37-4fe0-8d05-ea3057272731/ Matthias Büchner, + ! Christopher Reyer (2022): ISIMIP3b atmospheric composition input data (v1.1). ISIMIP + ! Repository. https://doi.org/10.48364/ISIMIP.482153.1 + !---1958-2022 obtained from https://www.esrl.noaa.gov/gmd/ccgg/trends/data.html + !---!May 2022 ~ Dec 2022 data obtained from + ! https://gml.noaa.gov/webdata/ccgg/trends/co2/co2_mm_mlo.txt (Mauna Loa, Hawaii) + !---Due to the eruption of the Mauna Loa Volcano, measurements from Mauna Loa Observatory were + ! suspended as of Nov. 29. 2022 New Observations starting in December 2022 are from a site + ! at the Maunakea Observatories, approximately 21 miles north of the Mauna Loa Observatory. + !---CMIP6 co2 data is obtainted from : + ! Matthias Büchner, Christopher Reyer (2022): ISIMIP3b atmospheric composition input data + ! (v1.1). ISIMIP Repository. https://doi.org/10.48364/ISIMIP.482153.1 + + !REVISION HISTORY + !---------------- + !---2023.02.23 Zhongwang Wei @ SYSU + !---2022.12.12 Zhongwang Wei @ SYSU + !---2021.05.05 Hua Yuan @ SYSU + + IMPLICIT NONE + + ! fillvalue + co2mlo(:,:) = -99.99 !monthly mean CO2 concentration in ppm + !1850-1957 obtained from + !https://data.isimip.org/datasets/0497b2a7-fd37-4fe0-8d05-ea3057272731/ Matthias Büchner, + !Christopher Reyer (2022): ISIMIP3b atmospheric composition input data (v1.1). ISIMIP + !Repository. https://doi.org/10.48364/ISIMIP.482153.1 + !added by Zhongwang Wei @ SYSU 2022.12.12 + co2mlo( 1849 ,:) = (/ 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 /) + co2mlo( 1850 ,:) = (/ 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 /) + co2mlo( 1851 ,:) = (/ 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 /) + co2mlo( 1852 ,:) = (/ 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 /) + co2mlo( 1853 ,:) = (/ 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 /) + co2mlo( 1854 ,:) = (/ 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 /) + co2mlo( 1855 ,:) = (/ 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 /) + co2mlo( 1856 ,:) = (/ 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 /) + co2mlo( 1857 ,:) = (/ 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 /) + co2mlo( 1858 ,:) = (/ 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 /) + co2mlo( 1859 ,:) = (/ 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 /) + co2mlo( 1860 ,:) = (/ 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 /) + co2mlo( 1861 ,:) = (/ 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 /) + co2mlo( 1862 ,:) = (/ 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 /) + co2mlo( 1863 ,:) = (/ 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 /) + co2mlo( 1864 ,:) = (/ 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 /) + co2mlo( 1865 ,:) = (/ 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 /) + co2mlo( 1866 ,:) = (/ 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 /) + co2mlo( 1867 ,:) = (/ 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 /) + co2mlo( 1868 ,:) = (/ 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 /) + co2mlo( 1869 ,:) = (/ 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 /) + co2mlo( 1870 ,:) = (/ 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 /) + co2mlo( 1871 ,:) = (/ 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 /) + co2mlo( 1872 ,:) = (/ 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 /) + co2mlo( 1873 ,:) = (/ 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 /) + co2mlo( 1874 ,:) = (/ 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 /) + co2mlo( 1875 ,:) = (/ 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 /) + co2mlo( 1876 ,:) = (/ 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 /) + co2mlo( 1877 ,:) = (/ 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 /) + co2mlo( 1878 ,:) = (/ 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 /) + co2mlo( 1879 ,:) = (/ 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 /) + co2mlo( 1880 ,:) = (/ 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 /) + co2mlo( 1881 ,:) = (/ 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 /) + co2mlo( 1882 ,:) = (/ 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 /) + co2mlo( 1883 ,:) = (/ 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 /) + co2mlo( 1884 ,:) = (/ 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 /) + co2mlo( 1885 ,:) = (/ 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 /) + co2mlo( 1886 ,:) = (/ 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 /) + co2mlo( 1887 ,:) = (/ 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 /) + co2mlo( 1888 ,:) = (/ 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 /) + co2mlo( 1889 ,:) = (/ 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 /) + co2mlo( 1890 ,:) = (/ 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 /) + co2mlo( 1891 ,:) = (/ 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 /) + co2mlo( 1892 ,:) = (/ 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 /) + co2mlo( 1893 ,:) = (/ 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 /) + co2mlo( 1894 ,:) = (/ 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 /) + co2mlo( 1895 ,:) = (/ 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 /) + co2mlo( 1896 ,:) = (/ 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 /) + co2mlo( 1897 ,:) = (/ 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 /) + co2mlo( 1898 ,:) = (/ 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 /) + co2mlo( 1899 ,:) = (/ 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 /) + co2mlo( 1900 ,:) = (/ 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 /) + co2mlo( 1901 ,:) = (/ 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 /) + co2mlo( 1902 ,:) = (/ 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 /) + co2mlo( 1903 ,:) = (/ 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 /) + co2mlo( 1904 ,:) = (/ 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 /) + co2mlo( 1905 ,:) = (/ 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 /) + co2mlo( 1906 ,:) = (/ 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 /) + co2mlo( 1907 ,:) = (/ 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 /) + co2mlo( 1908 ,:) = (/ 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 /) + co2mlo( 1909 ,:) = (/ 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 /) + co2mlo( 1910 ,:) = (/ 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 /) + co2mlo( 1911 ,:) = (/ 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 /) + co2mlo( 1912 ,:) = (/ 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 /) + co2mlo( 1913 ,:) = (/ 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 /) + co2mlo( 1914 ,:) = (/ 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 /) + co2mlo( 1915 ,:) = (/ 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 /) + co2mlo( 1916 ,:) = (/ 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 /) + co2mlo( 1917 ,:) = (/ 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 /) + co2mlo( 1918 ,:) = (/ 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 /) + co2mlo( 1919 ,:) = (/ 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 /) + co2mlo( 1920 ,:) = (/ 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 /) + co2mlo( 1921 ,:) = (/ 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 /) + co2mlo( 1922 ,:) = (/ 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 /) + co2mlo( 1923 ,:) = (/ 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 /) + co2mlo( 1924 ,:) = (/ 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 /) + co2mlo( 1925 ,:) = (/ 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 /) + co2mlo( 1926 ,:) = (/ 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 /) + co2mlo( 1927 ,:) = (/ 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 /) + co2mlo( 1928 ,:) = (/ 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 /) + co2mlo( 1929 ,:) = (/ 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 /) + co2mlo( 1930 ,:) = (/ 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 /) + co2mlo( 1931 ,:) = (/ 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 /) + co2mlo( 1932 ,:) = (/ 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 /) + co2mlo( 1933 ,:) = (/ 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 /) + co2mlo( 1934 ,:) = (/ 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 /) + co2mlo( 1935 ,:) = (/ 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 /) + co2mlo( 1936 ,:) = (/ 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 /) + co2mlo( 1937 ,:) = (/ 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 /) + co2mlo( 1938 ,:) = (/ 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 /) + co2mlo( 1939 ,:) = (/ 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 /) + co2mlo( 1940 ,:) = (/ 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 /) + co2mlo( 1941 ,:) = (/ 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 /) + co2mlo( 1942 ,:) = (/ 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 /) + co2mlo( 1943 ,:) = (/ 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 /) + co2mlo( 1944 ,:) = (/ 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 /) + co2mlo( 1945 ,:) = (/ 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 /) + co2mlo( 1946 ,:) = (/ 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 /) + co2mlo( 1947 ,:) = (/ 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 /) + co2mlo( 1948 ,:) = (/ 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 /) + co2mlo( 1949 ,:) = (/ 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 /) + co2mlo( 1950 ,:) = (/ 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 /) + co2mlo( 1951 ,:) = (/ 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 /) + co2mlo( 1952 ,:) = (/ 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 /) + co2mlo( 1953 ,:) = (/ 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 /) + co2mlo( 1954 ,:) = (/ 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 /) + co2mlo( 1955 ,:) = (/ 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 /) + co2mlo( 1956 ,:) = (/ 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 /) + co2mlo( 1957 ,:) = (/ 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 /) + !co2mlo( 1958 ,:) = (/ 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 /) + !co2mlo( 1959 ,:) = (/ 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 /) + !co2mlo( 1960 ,:) = (/ 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 /) + !co2mlo( 1961 ,:) = (/ 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 /) + !co2mlo( 1962 ,:) = (/ 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 /) + !co2mlo( 1963 ,:) = (/ 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 /) + !co2mlo( 1964 ,:) = (/ 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 /) + !co2mlo( 1965 ,:) = (/ 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 /) + !co2mlo( 1966 ,:) = (/ 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 /) + !co2mlo( 1967 ,:) = (/ 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 /) + !co2mlo( 1968 ,:) = (/ 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 /) + !co2mlo( 1969 ,:) = (/ 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 /) + !co2mlo( 1970 ,:) = (/ 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 /) + !co2mlo( 1971 ,:) = (/ 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 /) + !co2mlo( 1972 ,:) = (/ 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 /) + !co2mlo( 1973 ,:) = (/ 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 /) + !co2mlo( 1974 ,:) = (/ 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 /) + !co2mlo( 1975 ,:) = (/ 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 /) + !co2mlo( 1976 ,:) = (/ 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 /) + !co2mlo( 1977 ,:) = (/ 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 /) + !co2mlo( 1978 ,:) = (/ 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 /) + !co2mlo( 1979 ,:) = (/ 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 /) + !co2mlo( 1980 ,:) = (/ 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 /) + !co2mlo( 1981 ,:) = (/ 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 /) + !co2mlo( 1982 ,:) = (/ 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 /) + !co2mlo( 1983 ,:) = (/ 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 /) + !co2mlo( 1984 ,:) = (/ 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 /) + !co2mlo( 1985 ,:) = (/ 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 /) + !co2mlo( 1986 ,:) = (/ 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 /) + !co2mlo( 1987 ,:) = (/ 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 /) + !co2mlo( 1988 ,:) = (/ 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 /) + !co2mlo( 1989 ,:) = (/ 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 /) + !co2mlo( 1990 ,:) = (/ 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 /) + !co2mlo( 1991 ,:) = (/ 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 /) + !co2mlo( 1992 ,:) = (/ 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 /) + !co2mlo( 1993 ,:) = (/ 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 /) + !co2mlo( 1994 ,:) = (/ 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 /) + !co2mlo( 1995 ,:) = (/ 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 /) + !co2mlo( 1996 ,:) = (/ 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 /) + !co2mlo( 1997 ,:) = (/ 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 /) + !co2mlo( 1998 ,:) = (/ 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 /) + !co2mlo( 1999 ,:) = (/ 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 /) + !co2mlo( 2000 ,:) = (/ 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 /) + !co2mlo( 2001 ,:) = (/ 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 /) + !co2mlo( 2002 ,:) = (/ 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 /) + !co2mlo( 2003 ,:) = (/ 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 /) + !co2mlo( 2004 ,:) = (/ 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 /) + !co2mlo( 2005 ,:) = (/ 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 /) + !co2mlo( 2006 ,:) = (/ 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 /) + !co2mlo( 2007 ,:) = (/ 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 /) + !co2mlo( 2008 ,:) = (/ 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 /) + !co2mlo( 2009 ,:) = (/ 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 /) + !co2mlo( 2010 ,:) = (/ 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 /) + !co2mlo( 2011 ,:) = (/ 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 /) + !co2mlo( 2012 ,:) = (/ 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 /) + !co2mlo( 2013 ,:) = (/ 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 /) + !co2mlo( 2014 ,:) = (/ 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 /) + + !NOTE: the below numbers can be manually updated IF new records are available [Unit: ppm] + co2mlo(1958,:) = (/ 314.85, 314.85, 315.71, 317.45, 317.51, 317.25, 315.86, 314.93, 313.21, 312.43, 313.33, 314.67 /) + co2mlo(1959,:) = (/ 315.58, 316.49, 316.65, 317.72, 318.29, 318.15, 316.54, 314.80, 313.84, 313.33, 314.81, 315.58 /) + co2mlo(1960,:) = (/ 316.43, 316.98, 317.58, 319.03, 320.03, 319.58, 318.18, 315.90, 314.17, 313.83, 315.00, 316.19 /) + co2mlo(1961,:) = (/ 316.89, 317.70, 318.54, 319.48, 320.58, 319.77, 318.56, 316.79, 314.99, 315.31, 316.10, 317.01 /) + co2mlo(1962,:) = (/ 317.94, 318.55, 319.68, 320.57, 321.02, 320.62, 319.61, 317.40, 316.24, 315.42, 316.69, 317.70 /) + co2mlo(1963,:) = (/ 318.74, 319.07, 319.86, 321.38, 322.25, 321.48, 319.74, 317.77, 316.21, 315.99, 317.07, 318.35 /) + co2mlo(1964,:) = (/ 319.57, 320.03, 320.74, 321.83, 322.25, 321.89, 320.44, 318.69, 316.71, 316.87, 317.68, 318.71 /) + co2mlo(1965,:) = (/ 319.44, 320.44, 320.89, 322.14, 322.17, 321.87, 321.21, 318.87, 317.82, 317.30, 318.87, 319.42 /) + co2mlo(1966,:) = (/ 320.62, 321.60, 322.39, 323.70, 324.08, 323.75, 322.38, 320.36, 318.64, 318.10, 319.78, 321.02 /) + co2mlo(1967,:) = (/ 322.33, 322.50, 323.03, 324.41, 325.00, 324.09, 322.54, 320.92, 319.25, 319.39, 320.73, 321.95 /) + co2mlo(1968,:) = (/ 322.57, 323.15, 323.89, 325.02, 325.57, 325.36, 324.14, 322.11, 320.33, 320.25, 321.32, 322.89 /) + co2mlo(1969,:) = (/ 324.00, 324.41, 325.63, 326.66, 327.38, 326.71, 325.88, 323.66, 322.38, 321.78, 322.85, 324.11 /) + co2mlo(1970,:) = (/ 325.06, 325.99, 326.93, 328.13, 328.08, 327.67, 326.34, 324.68, 323.10, 323.07, 324.01, 325.13 /) + co2mlo(1971,:) = (/ 326.17, 326.68, 327.18, 327.79, 328.93, 328.57, 327.36, 325.43, 323.36, 323.56, 324.80, 326.01 /) + co2mlo(1972,:) = (/ 326.77, 327.63, 327.75, 329.72, 330.07, 329.09, 328.04, 326.32, 324.84, 325.20, 326.50, 327.55 /) + co2mlo(1973,:) = (/ 328.55, 329.56, 330.30, 331.50, 332.48, 332.07, 330.87, 329.31, 327.52, 327.19, 328.17, 328.65 /) + co2mlo(1974,:) = (/ 329.36, 330.71, 331.49, 332.65, 333.10, 332.26, 331.18, 329.40, 327.44, 327.38, 328.46, 329.58 /) + co2mlo(1975,:) = (/ 330.41, 331.41, 332.04, 333.32, 333.98, 333.61, 331.91, 330.06, 328.56, 328.35, 329.50, 330.77 /) + co2mlo(1976,:) = (/ 331.76, 332.58, 333.50, 334.59, 334.89, 334.34, 333.06, 330.95, 329.31, 328.95, 330.32, 331.69 /) + co2mlo(1977,:) = (/ 332.94, 333.43, 334.71, 336.08, 336.76, 336.28, 334.93, 332.76, 331.60, 331.17, 332.41, 333.86 /) + co2mlo(1978,:) = (/ 334.98, 335.40, 336.65, 337.76, 338.02, 337.91, 336.55, 334.69, 332.77, 332.56, 333.93, 334.96 /) + co2mlo(1979,:) = (/ 336.24, 336.77, 337.97, 338.89, 339.48, 339.30, 337.74, 336.10, 333.93, 333.87, 335.30, 336.74 /) + co2mlo(1980,:) = (/ 338.03, 338.37, 340.09, 340.78, 341.48, 341.19, 339.57, 337.61, 335.90, 336.03, 337.12, 338.23 /) + co2mlo(1981,:) = (/ 339.25, 340.50, 341.40, 342.52, 342.93, 342.27, 340.50, 338.45, 336.71, 336.88, 338.38, 339.63 /) + co2mlo(1982,:) = (/ 340.77, 341.63, 342.72, 343.59, 344.16, 343.37, 342.07, 339.83, 338.00, 337.88, 339.28, 340.51 /) + co2mlo(1983,:) = (/ 341.40, 342.54, 343.12, 344.96, 345.78, 345.34, 344.00, 342.40, 339.88, 340.01, 341.16, 342.98 /) + co2mlo(1984,:) = (/ 343.82, 344.62, 345.38, 347.15, 347.52, 346.88, 345.47, 343.34, 341.13, 341.40, 343.02, 344.25 /) + co2mlo(1985,:) = (/ 344.99, 346.01, 347.43, 348.34, 348.92, 348.24, 346.54, 344.64, 343.06, 342.78, 344.21, 345.53 /) + co2mlo(1986,:) = (/ 346.28, 346.93, 347.83, 349.53, 350.19, 349.53, 347.92, 345.88, 344.83, 344.16, 345.64, 346.88 /) + co2mlo(1987,:) = (/ 348.00, 348.47, 349.40, 350.97, 351.84, 351.25, 349.50, 348.09, 346.44, 346.09, 347.54, 348.69 /) + co2mlo(1988,:) = (/ 350.16, 351.47, 351.96, 353.33, 353.97, 353.55, 352.14, 350.19, 348.50, 348.66, 349.85, 351.12 /) + co2mlo(1989,:) = (/ 352.55, 352.86, 353.48, 355.21, 355.47, 354.92, 353.70, 351.47, 349.61, 349.79, 351.10, 352.32 /) + co2mlo(1990,:) = (/ 353.46, 354.50, 355.19, 356.00, 356.96, 356.04, 354.62, 352.71, 350.77, 350.99, 352.64, 354.02 /) + co2mlo(1991,:) = (/ 354.53, 355.55, 356.96, 358.40, 359.14, 358.04, 355.98, 353.81, 351.95, 352.02, 353.55, 354.79 /) + co2mlo(1992,:) = (/ 355.79, 356.52, 357.61, 358.95, 359.46, 359.05, 356.82, 354.80, 352.81, 353.11, 353.96, 355.20 /) + co2mlo(1993,:) = (/ 356.50, 356.97, 358.18, 359.26, 360.08, 359.40, 357.38, 355.33, 353.50, 353.80, 355.15, 356.62 /) + co2mlo(1994,:) = (/ 358.19, 358.73, 359.79, 361.09, 361.52, 360.77, 359.38, 357.31, 355.68, 355.83, 357.42, 358.87 /) + co2mlo(1995,:) = (/ 359.81, 360.84, 361.48, 363.30, 363.64, 363.11, 361.75, 359.31, 357.91, 357.62, 359.42, 360.56 /) + co2mlo(1996,:) = (/ 361.91, 363.11, 363.88, 364.58, 365.29, 364.84, 363.52, 361.35, 359.32, 359.48, 360.64, 362.21 /) + co2mlo(1997,:) = (/ 363.07, 363.87, 364.44, 366.23, 366.68, 365.52, 364.36, 362.39, 360.08, 360.67, 362.32, 364.16 /) + co2mlo(1998,:) = (/ 365.22, 366.04, 367.20, 368.50, 369.19, 368.77, 367.53, 365.67, 363.80, 364.13, 365.36, 366.87 /) + co2mlo(1999,:) = (/ 368.05, 368.77, 369.49, 371.04, 370.90, 370.25, 369.17, 366.83, 364.54, 365.04, 366.58, 367.92 /) + co2mlo(2000,:) = (/ 369.05, 369.37, 370.42, 371.57, 371.74, 371.60, 370.02, 368.03, 366.53, 366.64, 368.20, 369.44 /) + co2mlo(2001,:) = (/ 370.20, 371.42, 372.04, 372.78, 373.94, 373.23, 371.54, 369.47, 367.88, 368.01, 369.60, 371.15 /) + co2mlo(2002,:) = (/ 372.36, 373.00, 373.44, 374.77, 375.48, 375.33, 373.95, 371.41, 370.63, 370.18, 372.01, 373.71 /) + co2mlo(2003,:) = (/ 374.61, 375.55, 376.04, 377.58, 378.28, 378.07, 376.54, 374.42, 372.92, 372.94, 374.29, 375.63 /) + co2mlo(2004,:) = (/ 376.73, 377.31, 378.33, 380.44, 380.56, 379.49, 377.71, 375.77, 373.99, 374.17, 375.79, 377.39 /) + co2mlo(2005,:) = (/ 378.29, 379.56, 380.06, 382.01, 382.21, 382.05, 380.63, 378.64, 376.38, 376.77, 378.27, 379.92 /) + co2mlo(2006,:) = (/ 381.33, 381.98, 382.53, 384.33, 384.89, 383.99, 382.25, 380.44, 378.77, 379.03, 380.11, 381.62 /) + co2mlo(2007,:) = (/ 382.55, 383.68, 384.31, 386.20, 386.38, 385.85, 384.42, 381.81, 380.83, 380.83, 382.32, 383.58 /) + co2mlo(2008,:) = (/ 385.04, 385.81, 385.80, 386.74, 388.49, 388.02, 386.22, 384.05, 383.05, 382.75, 383.98, 385.08 /) + co2mlo(2009,:) = (/ 386.63, 387.10, 388.50, 389.54, 390.15, 389.60, 388.05, 386.06, 384.64, 384.32, 386.05, 387.48 /) + co2mlo(2010,:) = (/ 388.55, 390.08, 391.02, 392.39, 393.24, 392.26, 390.35, 388.53, 386.85, 387.18, 388.69, 389.83 /) + co2mlo(2011,:) = (/ 391.33, 391.96, 392.49, 393.40, 394.33, 393.75, 392.64, 390.25, 389.05, 388.98, 390.30, 391.86 /) + co2mlo(2012,:) = (/ 393.13, 393.42, 394.43, 396.51, 396.96, 395.97, 394.60, 392.61, 391.20, 391.09, 393.03, 394.42 /) + co2mlo(2013,:) = (/ 395.69, 396.94, 397.35, 398.44, 400.06, 398.95, 397.45, 395.49, 393.47, 393.77, 395.27, 396.90 /) + co2mlo(2014,:) = (/ 398.01, 398.18, 399.56, 401.44, 401.98, 401.41, 399.17, 397.30, 395.49, 395.74, 397.32, 398.88 /) + co2mlo(2015,:) = (/ 399.94, 400.40, 401.60, 403.53, 404.04, 402.81, 401.54, 398.93, 397.43, 398.22, 400.17, 401.82 /) + co2mlo(2016,:) = (/ 402.58, 404.09, 404.79, 407.50, 407.59, 406.94, 404.43, 402.17, 400.95, 401.43, 403.57, 404.48 /) + co2mlo(2017,:) = (/ 406.00, 406.57, 406.99, 408.88, 409.84, 409.05, 407.13, 405.17, 403.20, 403.57, 405.10, 406.68 /) + co2mlo(2018,:) = (/ 407.98, 408.36, 409.21, 410.24, 411.23, 410.81, 408.83, 407.02, 405.52, 405.93, 408.04, 409.17 /) + co2mlo(2019,:) = (/ 410.85, 411.59, 411.91, 413.46, 414.76, 413.89, 411.78, 410.01, 408.48, 408.40, 410.16, 411.81 /) + co2mlo(2020,:) = (/ 413.30, 414.05, 414.45, 416.11, 417.15, 416.29, 414.42, 412.52, 411.18, 411.12, 412.88, 413.89 /) + co2mlo(2021,:) = (/ 415.15, 416.47, 417.16, 418.24, 418.95, 418.70, 416.65, 414.34, 412.90, 413.55, 414.82, 416.43 /) + co2mlo(2022,:) = (/ 418.01, 418.99, 418.45, 420.02, 420.99, 420.99, 418.90, 417.19, 415.95, 415.78, 417.51, 418.95 /) + !noted by Zhongwang Wei + !May 2022 ~ Dec 2022 data obtained from + !https://gml.noaa.gov/webdata/ccgg/trends/co2/co2_mm_mlo.txt (Mauna Loa, Hawaii) Due to the + !eruption of the Mauna Loa Volcano, measurements from Mauna Loa Observatory were suspended as + !of Nov. 29. 2022 New Observations starting in December 2022 are from a site at the Maunakea + !Observatories, approximately 21 miles north of the Mauna Loa Observatory. + !CMIP6 co2 data is obtainted from : + !Matthias Büchner, Christopher Reyer (2022): ISIMIP3b atmospheric composition input data + !(v1.1). ISIMIP Repository. https://doi.org/10.48364/ISIMIP.482153.1 + !added by Zhongwang Wei @ SYSU 2022.12.12 + select CASE (trim(DEF_SSP)) + CASE ('126') + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75 /) + !co2mlo(2018,:) = (/ 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59 /) + !co2mlo(2019,:) = (/ 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42 /) + !co2mlo(2020,:) = (/ 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23 /) + !co2mlo(2021,:) = (/ 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04 /) + !co2mlo(2022,:) = (/ 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81 /) + co2mlo(2023,:) = (/ 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50 /) + co2mlo(2024,:) = (/ 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12 /) + co2mlo(2025,:) = (/ 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67 /) + co2mlo(2026,:) = (/ 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17 /) + co2mlo(2027,:) = (/ 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60 /) + co2mlo(2028,:) = (/ 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97 /) + co2mlo(2029,:) = (/ 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29 /) + co2mlo(2030,:) = (/ 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56 /) + co2mlo(2031,:) = (/ 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78 /) + co2mlo(2032,:) = (/ 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93 /) + co2mlo(2033,:) = (/ 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99 /) + co2mlo(2034,:) = (/ 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97 /) + co2mlo(2035,:) = (/ 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87 /) + co2mlo(2036,:) = (/ 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68 /) + co2mlo(2037,:) = (/ 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43 /) + co2mlo(2038,:) = (/ 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09 /) + co2mlo(2039,:) = (/ 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68 /) + co2mlo(2040,:) = (/ 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20 /) + co2mlo(2041,:) = (/ 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65 /) + co2mlo(2042,:) = (/ 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02 /) + co2mlo(2043,:) = (/ 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31 /) + co2mlo(2044,:) = (/ 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54 /) + co2mlo(2045,:) = (/ 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68 /) + co2mlo(2046,:) = (/ 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75 /) + co2mlo(2047,:) = (/ 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75 /) + co2mlo(2048,:) = (/ 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68 /) + co2mlo(2049,:) = (/ 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53 /) + co2mlo(2050,:) = (/ 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31 /) + co2mlo(2051,:) = (/ 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02 /) + co2mlo(2052,:) = (/ 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66 /) + co2mlo(2053,:) = (/ 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25 /) + co2mlo(2054,:) = (/ 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78 /) + co2mlo(2055,:) = (/ 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25 /) + co2mlo(2056,:) = (/ 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66 /) + co2mlo(2057,:) = (/ 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02 /) + co2mlo(2058,:) = (/ 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32 /) + co2mlo(2059,:) = (/ 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56 /) + co2mlo(2060,:) = (/ 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75 /) + co2mlo(2061,:) = (/ 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88 /) + co2mlo(2062,:) = (/ 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96 /) + co2mlo(2063,:) = (/ 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00 /) + co2mlo(2064,:) = (/ 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00 /) + co2mlo(2065,:) = (/ 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96 /) + co2mlo(2066,:) = (/ 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87 /) + co2mlo(2067,:) = (/ 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75 /) + co2mlo(2068,:) = (/ 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58 /) + co2mlo(2069,:) = (/ 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36 /) + co2mlo(2070,:) = (/ 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11 /) + co2mlo(2071,:) = (/ 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81 /) + co2mlo(2072,:) = (/ 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46 /) + co2mlo(2073,:) = (/ 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04 /) + co2mlo(2074,:) = (/ 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56 /) + co2mlo(2075,:) = (/ 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02 /) + co2mlo(2076,:) = (/ 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41 /) + co2mlo(2077,:) = (/ 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75 /) + co2mlo(2078,:) = (/ 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02 /) + co2mlo(2079,:) = (/ 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24 /) + co2mlo(2080,:) = (/ 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39 /) + co2mlo(2081,:) = (/ 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48 /) + co2mlo(2082,:) = (/ 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54 /) + co2mlo(2083,:) = (/ 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56 /) + co2mlo(2084,:) = (/ 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56 /) + co2mlo(2085,:) = (/ 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53 /) + co2mlo(2086,:) = (/ 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47 /) + co2mlo(2087,:) = (/ 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38 /) + co2mlo(2088,:) = (/ 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26 /) + co2mlo(2089,:) = (/ 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10 /) + co2mlo(2090,:) = (/ 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92 /) + co2mlo(2091,:) = (/ 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71 /) + co2mlo(2092,:) = (/ 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50 /) + co2mlo(2093,:) = (/ 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32 /) + co2mlo(2094,:) = (/ 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16 /) + co2mlo(2095,:) = (/ 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02 /) + co2mlo(2096,:) = (/ 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91 /) + co2mlo(2097,:) = (/ 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81 /) + co2mlo(2098,:) = (/ 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73 /) + co2mlo(2099,:) = (/ 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67 /) + co2mlo(2100,:) = (/ 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62 /) + !added by Zhongwang Wei @ SYSU 2022.12.12 + CASE ('245') + print *,'245' + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.81, 405.81 /) + !co2mlo(2018,:) = (/ 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.83, 408.83 /) + !co2mlo(2019,:) = (/ 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.95, 411.95 /) + !co2mlo(2020,:) = (/ 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 415.15, 415.15 /) + !co2mlo(2021,:) = (/ 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 418.46, 418.46 /) + !co2mlo(2022,:) = (/ 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 421.84, 421.84 /) + co2mlo(2023,:) = (/ 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 425.28, 425.28 /) + co2mlo(2024,:) = (/ 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 428.78, 428.78 /) + co2mlo(2025,:) = (/ 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 432.35, 432.35 /) + co2mlo(2026,:) = (/ 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 435.97, 435.97 /) + co2mlo(2027,:) = (/ 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 439.67, 439.67 /) + co2mlo(2028,:) = (/ 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 443.43, 443.43 /) + co2mlo(2029,:) = (/ 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 447.26, 447.26 /) + co2mlo(2030,:) = (/ 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 451.16, 451.16 /) + co2mlo(2031,:) = (/ 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 455.14, 455.14 /) + co2mlo(2032,:) = (/ 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 459.17, 459.17 /) + co2mlo(2033,:) = (/ 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 463.24, 463.24 /) + co2mlo(2034,:) = (/ 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 467.36, 467.36 /) + co2mlo(2035,:) = (/ 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 471.54, 471.54 /) + co2mlo(2036,:) = (/ 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 475.76, 475.76 /) + co2mlo(2037,:) = (/ 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 480.04, 480.04 /) + co2mlo(2038,:) = (/ 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 484.38, 484.38 /) + co2mlo(2039,:) = (/ 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 488.77, 488.77 /) + co2mlo(2040,:) = (/ 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 493.22, 493.22 /) + co2mlo(2041,:) = (/ 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 497.73, 497.73 /) + co2mlo(2042,:) = (/ 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 502.29, 502.29 /) + co2mlo(2043,:) = (/ 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 506.90, 506.90 /) + co2mlo(2044,:) = (/ 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 511.56, 511.56 /) + co2mlo(2045,:) = (/ 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 516.26, 516.26 /) + co2mlo(2046,:) = (/ 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 521.02, 521.02 /) + co2mlo(2047,:) = (/ 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 525.83, 525.83 /) + co2mlo(2048,:) = (/ 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 530.69, 530.69 /) + co2mlo(2049,:) = (/ 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 535.61, 535.61 /) + co2mlo(2050,:) = (/ 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 540.58, 540.58 /) + co2mlo(2051,:) = (/ 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 545.61, 545.61 /) + co2mlo(2052,:) = (/ 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 550.69, 550.69 /) + co2mlo(2053,:) = (/ 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 555.82, 555.82 /) + co2mlo(2054,:) = (/ 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 561.00, 561.00 /) + co2mlo(2055,:) = (/ 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 566.24, 566.24 /) + co2mlo(2056,:) = (/ 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 571.53, 571.53 /) + co2mlo(2057,:) = (/ 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 576.87, 576.87 /) + co2mlo(2058,:) = (/ 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 582.27, 582.27 /) + co2mlo(2059,:) = (/ 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 587.72, 587.72 /) + co2mlo(2060,:) = (/ 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 593.23, 593.23 /) + co2mlo(2061,:) = (/ 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 598.80, 598.80 /) + co2mlo(2062,:) = (/ 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 604.42, 604.42 /) + co2mlo(2063,:) = (/ 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 610.11, 610.11 /) + co2mlo(2064,:) = (/ 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 615.85, 615.85 /) + co2mlo(2065,:) = (/ 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 621.65, 621.65 /) + co2mlo(2066,:) = (/ 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 627.50, 627.50 /) + co2mlo(2067,:) = (/ 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 633.42, 633.42 /) + co2mlo(2068,:) = (/ 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 639.40, 639.40 /) + co2mlo(2069,:) = (/ 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 645.44, 645.44 /) + co2mlo(2070,:) = (/ 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 651.54, 651.54 /) + co2mlo(2071,:) = (/ 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 657.71, 657.71 /) + co2mlo(2072,:) = (/ 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 663.93, 663.93 /) + co2mlo(2073,:) = (/ 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 670.22, 670.22 /) + co2mlo(2074,:) = (/ 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 676.57, 676.57 /) + co2mlo(2075,:) = (/ 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 682.98, 682.98 /) + co2mlo(2076,:) = (/ 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 689.46, 689.46 /) + co2mlo(2077,:) = (/ 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 696.00, 696.00 /) + co2mlo(2078,:) = (/ 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 702.61, 702.61 /) + co2mlo(2079,:) = (/ 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 709.27, 709.27 /) + co2mlo(2080,:) = (/ 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 716.01, 716.01 /) + co2mlo(2081,:) = (/ 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 722.81, 722.81 /) + co2mlo(2082,:) = (/ 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 729.68, 729.68 /) + co2mlo(2083,:) = (/ 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 736.63, 736.63 /) + co2mlo(2084,:) = (/ 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 743.66, 743.66 /) + co2mlo(2085,:) = (/ 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 750.76, 750.76 /) + co2mlo(2086,:) = (/ 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 757.95, 757.95 /) + co2mlo(2087,:) = (/ 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 765.22, 765.22 /) + co2mlo(2088,:) = (/ 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 772.56, 772.56 /) + co2mlo(2089,:) = (/ 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 779.98, 779.98 /) + co2mlo(2090,:) = (/ 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 787.49, 787.49 /) + co2mlo(2091,:) = (/ 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 795.07, 795.07 /) + co2mlo(2092,:) = (/ 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 802.74, 802.74 /) + co2mlo(2093,:) = (/ 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 810.49, 810.49 /) + co2mlo(2094,:) = (/ 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 818.33, 818.33 /) + co2mlo(2095,:) = (/ 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 826.25, 826.25 /) + co2mlo(2096,:) = (/ 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 834.27, 834.27 /) + co2mlo(2097,:) = (/ 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 842.37, 842.37 /) + co2mlo(2098,:) = (/ 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 850.55, 850.55 /) + co2mlo(2099,:) = (/ 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 858.83, 858.83 /) + co2mlo(2100,:) = (/ 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 867.19, 867.19 /) + !added by Zhongwang Wei @ SYSU 2022.12.12 + CASE ('370') + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81 /) + !co2mlo(2018,:) = (/ 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83 /) + !co2mlo(2019,:) = (/ 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95 /) + !co2mlo(2020,:) = (/ 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15 /) + !co2mlo(2021,:) = (/ 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46 /) + !co2mlo(2022,:) = (/ 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84 /) + co2mlo(2023,:) = (/ 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28 /) + co2mlo(2024,:) = (/ 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78 /) + co2mlo(2025,:) = (/ 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35 /) + co2mlo(2026,:) = (/ 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97 /) + co2mlo(2027,:) = (/ 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67 /) + co2mlo(2028,:) = (/ 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43 /) + co2mlo(2029,:) = (/ 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26 /) + co2mlo(2030,:) = (/ 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16 /) + co2mlo(2031,:) = (/ 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14 /) + co2mlo(2032,:) = (/ 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17 /) + co2mlo(2033,:) = (/ 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24 /) + co2mlo(2034,:) = (/ 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36 /) + co2mlo(2035,:) = (/ 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54 /) + co2mlo(2036,:) = (/ 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76 /) + co2mlo(2037,:) = (/ 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04 /) + co2mlo(2038,:) = (/ 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38 /) + co2mlo(2039,:) = (/ 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77 /) + co2mlo(2040,:) = (/ 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22 /) + co2mlo(2041,:) = (/ 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73 /) + co2mlo(2042,:) = (/ 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29 /) + co2mlo(2043,:) = (/ 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90 /) + co2mlo(2044,:) = (/ 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56 /) + co2mlo(2045,:) = (/ 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26 /) + co2mlo(2046,:) = (/ 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02 /) + co2mlo(2047,:) = (/ 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83 /) + co2mlo(2048,:) = (/ 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69 /) + co2mlo(2049,:) = (/ 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61 /) + co2mlo(2050,:) = (/ 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58 /) + co2mlo(2051,:) = (/ 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61 /) + co2mlo(2052,:) = (/ 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69 /) + co2mlo(2053,:) = (/ 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82 /) + co2mlo(2054,:) = (/ 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00 /) + co2mlo(2055,:) = (/ 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24 /) + co2mlo(2056,:) = (/ 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53 /) + co2mlo(2057,:) = (/ 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87 /) + co2mlo(2058,:) = (/ 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27 /) + co2mlo(2059,:) = (/ 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72 /) + co2mlo(2060,:) = (/ 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23 /) + co2mlo(2061,:) = (/ 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80 /) + co2mlo(2062,:) = (/ 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42 /) + co2mlo(2063,:) = (/ 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11 /) + co2mlo(2064,:) = (/ 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85 /) + co2mlo(2065,:) = (/ 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65 /) + co2mlo(2066,:) = (/ 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50 /) + co2mlo(2067,:) = (/ 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42 /) + co2mlo(2068,:) = (/ 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40 /) + co2mlo(2069,:) = (/ 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44 /) + co2mlo(2070,:) = (/ 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54 /) + co2mlo(2071,:) = (/ 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71 /) + co2mlo(2072,:) = (/ 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93 /) + co2mlo(2073,:) = (/ 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22 /) + co2mlo(2074,:) = (/ 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57 /) + co2mlo(2075,:) = (/ 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98 /) + co2mlo(2076,:) = (/ 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46 /) + co2mlo(2077,:) = (/ 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00 /) + co2mlo(2078,:) = (/ 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61 /) + co2mlo(2079,:) = (/ 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27 /) + co2mlo(2080,:) = (/ 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01 /) + co2mlo(2081,:) = (/ 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81 /) + co2mlo(2082,:) = (/ 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68 /) + co2mlo(2083,:) = (/ 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63 /) + co2mlo(2084,:) = (/ 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66 /) + co2mlo(2085,:) = (/ 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76 /) + co2mlo(2086,:) = (/ 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95 /) + co2mlo(2087,:) = (/ 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22 /) + co2mlo(2088,:) = (/ 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56 /) + co2mlo(2089,:) = (/ 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98 /) + co2mlo(2090,:) = (/ 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49 /) + co2mlo(2091,:) = (/ 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07 /) + co2mlo(2092,:) = (/ 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74 /) + co2mlo(2093,:) = (/ 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49 /) + co2mlo(2094,:) = (/ 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33 /) + co2mlo(2095,:) = (/ 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25 /) + co2mlo(2096,:) = (/ 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27 /) + co2mlo(2097,:) = (/ 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37 /) + co2mlo(2098,:) = (/ 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55 /) + co2mlo(2099,:) = (/ 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83 /) + co2mlo(2100,:) = (/ 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19 /) + !added by Zhongwang Wei @ SYSU 2022.12.12 + CASE ('585') + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79 /) + !co2mlo(2018,:) = (/ 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76 /) + !co2mlo(2019,:) = (/ 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79 /) + !co2mlo(2020,:) = (/ 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89 /) + !co2mlo(2021,:) = (/ 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06 /) + !co2mlo(2022,:) = (/ 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33 /) + co2mlo(2023,:) = (/ 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72 /) + co2mlo(2024,:) = (/ 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22 /) + co2mlo(2025,:) = (/ 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83 /) + co2mlo(2026,:) = (/ 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55 /) + co2mlo(2027,:) = (/ 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38 /) + co2mlo(2028,:) = (/ 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31 /) + co2mlo(2029,:) = (/ 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36 /) + co2mlo(2030,:) = (/ 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51 /) + co2mlo(2031,:) = (/ 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78 /) + co2mlo(2032,:) = (/ 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16 /) + co2mlo(2033,:) = (/ 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68 /) + co2mlo(2034,:) = (/ 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33 /) + co2mlo(2035,:) = (/ 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11 /) + co2mlo(2036,:) = (/ 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02 /) + co2mlo(2037,:) = (/ 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07 /) + co2mlo(2038,:) = (/ 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25 /) + co2mlo(2039,:) = (/ 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57 /) + co2mlo(2040,:) = (/ 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02 /) + co2mlo(2041,:) = (/ 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61 /) + co2mlo(2042,:) = (/ 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34 /) + co2mlo(2043,:) = (/ 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23 /) + co2mlo(2044,:) = (/ 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27 /) + co2mlo(2045,:) = (/ 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46 /) + co2mlo(2046,:) = (/ 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81 /) + co2mlo(2047,:) = (/ 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31 /) + co2mlo(2048,:) = (/ 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98 /) + co2mlo(2049,:) = (/ 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80 /) + co2mlo(2050,:) = (/ 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78 /) + co2mlo(2051,:) = (/ 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93 /) + co2mlo(2052,:) = (/ 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26 /) + co2mlo(2053,:) = (/ 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78 /) + co2mlo(2054,:) = (/ 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51 /) + co2mlo(2055,:) = (/ 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43 /) + co2mlo(2056,:) = (/ 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55 /) + co2mlo(2057,:) = (/ 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87 /) + co2mlo(2058,:) = (/ 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39 /) + co2mlo(2059,:) = (/ 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11 /) + co2mlo(2060,:) = (/ 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04 /) + co2mlo(2061,:) = (/ 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17 /) + co2mlo(2062,:) = (/ 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51 /) + co2mlo(2063,:) = (/ 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04 /) + co2mlo(2064,:) = (/ 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79 /) + co2mlo(2065,:) = (/ 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74 /) + co2mlo(2066,:) = (/ 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90 /) + co2mlo(2067,:) = (/ 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27 /) + co2mlo(2068,:) = (/ 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85 /) + co2mlo(2069,:) = (/ 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65 /) + co2mlo(2070,:) = (/ 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66 /) + co2mlo(2071,:) = (/ 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89 /) + co2mlo(2072,:) = (/ 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32 /) + co2mlo(2073,:) = (/ 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93 /) + co2mlo(2074,:) = (/ 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72 /) + co2mlo(2075,:) = (/ 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69 /) + co2mlo(2076,:) = (/ 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85 /) + co2mlo(2077,:) = (/ 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19 /) + co2mlo(2078,:) = (/ 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73 /) + co2mlo(2079,:) = (/ 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45 /) + co2mlo(2080,:) = (/ 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37 /) + co2mlo(2081,:) = (/ 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48 /) + co2mlo(2082,:) = (/ 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71 /) + co2mlo(2083,:) = (/ 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98 /) + co2mlo(2084,:) = (/ 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30 /) + co2mlo(2085,:) = (/ 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67 /) + co2mlo(2086,:) = (/ 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09 /) + co2mlo(2087,:) = (/ 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57 /) + co2mlo(2088,:) = (/ 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10 /) + co2mlo(2089,:) = (/ 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68 /) + co2mlo(2090,:) = (/ 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32 /) + co2mlo(2091,:) = (/ 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02 /) + co2mlo(2092,:) = (/ 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74 /) + co2mlo(2093,:) = (/ 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45 /) + co2mlo(2094,:) = (/ 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15 /) + co2mlo(2095,:) = (/ 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85 /) + co2mlo(2096,:) = (/ 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53 /) + co2mlo(2097,:) = (/ 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21 /) + co2mlo(2098,:) = (/ 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89 /) + co2mlo(2099,:) = (/ 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55 /) + co2mlo(2100,:) = (/ 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21 /) + END select + + END SUBROUTINE init_monthly_co2_mlo + + real(r8) FUNCTION get_monthly_co2_mlo (year, month) + + IMPLICIT NONE + + integer, intent(in) :: year + integer, intent(in) :: month + + IF (yeareyear .or. year==eyear.and.month>4) THEN + print *, "Warning: Requested CO2 data beyond the latest record!" + print *, "Set to the latest one..." + get_monthly_co2_mlo = co2mlo(eyear, emonth) + RETURN + ENDIF + + get_monthly_co2_mlo = co2mlo(year, month) + !print *, "Set CO2 value [ppm,year,month]:",get_monthly_co2_mlo,year,month + RETURN + + END FUNCTION get_monthly_co2_mlo + +END MODULE MOD_MonthlyinSituCO2MaunaLoa +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 new file mode 100644 index 0000000000..ba27853eb1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 @@ -0,0 +1,230 @@ +#include + +#ifdef BGC +MODULE MOD_NdepData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in ndep data. +! +! !ORIGINAL: +! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of +! the ndep data module. +! +! !REVISIONS: +! 08/2023, Shang Fang: add year and month input for reading Nitrogen deposition +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_BGC_Vars_TimeVariables, only: ndep + USE MOD_BGC_Vars_1DFluxes, only: ndep_to_sminn + IMPLICIT NONE + + character(len=256) :: file_ndep + + type(grid_type) :: grid_ndep + type(spatial_mapping_type) :: mg2p_ndep + +CONTAINS + + SUBROUTINE init_ndep_data_annually (YY) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open ndep netcdf file from DEF_dir_runtime, read latitude and longitude info. +! Initialize ndep data read in. +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + integer, intent(in) :: YY + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + + file_ndep = trim(DEF_dir_runtime) // & + '/ndep/fndep_colm_hist_simyr1849-2006_1.9x2.5_c100428.nc' + + CALL ncio_read_bcast_serial (file_ndep, 'lat', lat) + CALL ncio_read_bcast_serial (file_ndep, 'lon', lon) + + CALL grid_ndep%define_by_center (lat, lon) + + CALL mg2p_ndep%build_arealweighted (grid_ndep, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL update_ndep_data_annually (YY, iswrite = .true.) + + END SUBROUTINE init_ndep_data_annually + + SUBROUTINE init_ndep_data_monthly (YY,MM) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open ndep netcdf file from DEF_dir_runtime, read latitude and +! longitude info. Initialize ndep data read in. +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + integer, intent(in) :: YY,MM + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + + file_ndep = trim(DEF_dir_runtime) // '/ndep/fndep_colm_monthly.nc' + + CALL ncio_read_bcast_serial (file_ndep, 'lat', lat) + CALL ncio_read_bcast_serial (file_ndep, 'lon', lon) + + CALL grid_ndep%define_by_center (lat, lon) + + CALL mg2p_ndep%build_arealweighted (grid_ndep, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL update_ndep_data_monthly (YY, MM ,iswrite = .true.) + + END SUBROUTINE init_ndep_data_monthly + + SUBROUTINE update_ndep_data_annually (YY, iswrite) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Nitrogen deposition data from CLM5. +! +! !REFERENCES: +! Galloway, J.N., et al. 2004. Nitrogen cycles: past, present, and +! future. Biogeochem. 70:153-226. +! +! !ORIGINAL: +! Created by Xingjie Lu and Shupeng Zhang, 2022 +!----------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_USE_PN + USE MOD_DataType + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY + logical, intent(in) :: iswrite + + ! Local Variables + type(block_data_real8_2d) :: f_xy_ndep + integer :: itime, npatch, m + + itime = max(min(YY,2006),1849) - 1848 + + IF (p_is_io) THEN + CALL allocate_block_data (grid_ndep, f_xy_ndep) + CALL ncio_read_block_time (file_ndep, 'NDEP_year', grid_ndep, itime, f_xy_ndep) + ENDIF + + CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) + + IF (p_is_worker .and. iswrite) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF(m == 0)THEN + ndep_to_sminn(npatch) = 0. + ELSE + IF(DEF_USE_PN)THEN + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 + ELSE + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('ndep', ndep) +#endif + + END SUBROUTINE update_ndep_data_annually + + SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Nitrogen deposition data from CLM5. +! +! !REFERENCES: +! Galloway, J.N., et al. 2004. Nitrogen cycles: past, present, and +! future. Biogeochem. 70:153-226. +! +! !ORIGINAL: +! Created by Xingjie Lu and Shupeng Zhang, 2022 +! +!----------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_USE_PN + USE MOD_DataType + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY,MM + logical, intent(in) :: iswrite + + ! Local Variables + type(block_data_real8_2d) :: f_xy_ndep + integer :: itime, npatch, m + + itime = (max(min(YY,2006),1849) - 1849)*12 + MM + + IF (p_is_io) THEN + CALL allocate_block_data (grid_ndep, f_xy_ndep) + CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) + ENDIF + + CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) + + IF (p_is_worker .and. iswrite) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF(m == 0)THEN + ndep_to_sminn(npatch) = 0. + ELSE + IF(DEF_USE_PN)THEN + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 + ELSE + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('ndep', ndep) +#endif + + END SUBROUTINE update_ndep_data_monthly + +END MODULE MOD_NdepData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 new file mode 100644 index 0000000000..68a54de178 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 @@ -0,0 +1,323 @@ +#include + +MODULE MOD_NetSolar + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: netsolar + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Net solar absorbed by surface +! +! Original author: Yongjiu Dai, 09/15/1999; 09/11/2001 +! +! !REVISIONS: +! 05/2014, Hua Yuan: added for solar radiation output [vars: so*, sr*] +! +! 08/2014, Hua Yuan: added for local noon calculation +! +! 08/2020, Hua Yuan: added for PFT and PC calculation +! +! 12/2022, Hua Yuan: calculated snow layer absorption by SNICAR model +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_TimeManager, only: isgreenwich +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch !patch index + integer, intent(in) :: idate(3) !model time + integer, intent(in) :: patchtype !land patch type (99-sea) + + real(r8), intent(in) :: dlon !longitude in radians + real(r8), intent(in) :: deltim !seconds in a time step [second] + + real(r8), intent(in) :: & + forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] + forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + + real(r8), dimension(1:2,1:2), intent(in) :: & + alb ! averaged albedo [-] + + real(r8), dimension(1:2,1:2), intent(inout) :: & + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + ssoi, &! ground soil absorption [-] + ssno ! ground snow absorption [-] + + real(r8), dimension(1:2,1:2,maxsnl+1:1), intent(inout) :: & + ssno_lyr ! snow layer absorption + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), intent(in) :: & + fsno ! snow fractional cover + + real(r8), intent(out) :: & + parsun, &! PAR absorbed by sunlit vegetation [W/m2] + parsha, &! PAR absorbed by shaded vegetation [W/m2] + sabvsun, &! solar absorbed by sunlit vegetation [W/m2] + sabvsha, &! solar absorbed by shaded vegetation [W/m2] + sabg, &! solar absorbed by ground [W/m2] +! 03/06/2020, yuan: + sabg_soil, &! solar absorbed by ground soil [W/m2] + sabg_snow, &! solar absorbed by ground snow [W/m2] + sr, &! total reflected solar radiation (W/m2) + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + + real(r8), intent(out) :: & + sabg_snow_lyr(maxsnl+1:1) ! solar absorbed by snow layers [W/m2] + +!-------------------------- Local Variables ---------------------------- + integer :: local_secs + real(r8) :: radpsec, sabvg, sabg_noadj + + integer ps, pe, p + +!----------------------------------------------------------------------- + + sabvsun = 0. + sabvsha = 0. + parsun = 0. + parsha = 0. + + IF (lai+sai <= 1.e-6) THEN + ssun(:,:) = 0. + ssha(:,:) = 0. + ENDIF + + sabg = 0. + sabg_soil = 0. + sabg_snow = 0. + sabg_snow_lyr(:) = 0. + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + sabvsun_p(ps:pe) = 0. + sabvsha_p(ps:pe) = 0. + parsun_p (ps:pe) = 0. + parsha_p (ps:pe) = 0. + + DO p = ps, pe + IF (lai_p(p)+sai_p(p) <= 1.e-6) THEN + ssun_p(:,:,p) = 0. + ssha_p(:,:,p) = 0. + ENDIF + ENDDO + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) +#endif + ENDIF + + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + IF (patchtype < 4) THEN !non lake and ocean + ! Radiative fluxes onto surface + parsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) + parsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) + sabvsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) & + + forc_soll*ssun(2,1) + forc_solld*ssun(2,2) + sabvsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) & + + forc_soll*ssha(2,1) + forc_solld*ssha(2,2) + sabvg = forc_sols *(1.-alb(1,1)) + forc_solsd*(1.-alb(1,2)) & + + forc_soll *(1.-alb(2,1)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg - sabvsun - sabvsha + + IF (patchtype == 0) THEN + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + parsun_p (ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) + parsha_p (ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) + sabvsun_p(ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) & + + forc_soll*ssun_p(2,1,ps:pe) + forc_solld*ssun_p(2,2,ps:pe) + sabvsha_p(ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) & + + forc_soll*ssha_p(2,1,ps:pe) + forc_solld*ssha_p(2,2,ps:pe) +#endif + ENDIF + + ELSE !lake and ocean + sabvg = forc_sols *(1.-alb(1,1)) + forc_soll *(1.-alb(2,1)) & + + forc_solsd*(1.-alb(1,2)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg + ENDIF + + ! calculate soil and snow solar absorption + sabg_soil = forc_sols*ssoi(1,1) + forc_solsd*ssoi(1,2) & + + forc_soll*ssoi(2,1) + forc_solld*ssoi(2,2) + sabg_snow = forc_sols*ssno(1,1) + forc_solsd*ssno(1,2) & + + forc_soll*ssno(2,1) + forc_solld*ssno(2,2) + + sabg_soil = sabg_soil * (1.-fsno) + sabg_snow = sabg_snow * fsno + + ! balance check and adjustment for soil and snow absorption + ! this could happen when there is adjustment to ssun,ssha + IF (abs(sabg_soil+sabg_snow-sabg)>1.e-6) THEN + IF (.not. (idate(2)==1 .and. idate(3)==int(deltim))) THEN + print *, "MOD_NetSolar.F90: NOTE imbalance in spliting soil and snow surface!", & + sabg_soil+sabg_snow-sabg + print *, "Patchtype = ", patchtype + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow, "fsno:", fsno + ENDIF + + sabg_noadj = sabg_soil + sabg_snow + + IF (sabg_noadj > 0.) THEN + sabg_soil = sabg_soil * sabg/sabg_noadj + sabg_snow = sabg_snow * sabg/sabg_noadj + ssoi(:,:) = ssoi(:,:) * sabg/sabg_noadj + ssno(:,:) = ssno(:,:) * sabg/sabg_noadj + ENDIF + ENDIF + + ! snow layer absorption calculation and adjustment for SNICAR model + IF (DEF_USE_SNICAR) THEN + ! adjust snow layer absorption due to multiple reflection between ground and canopy + IF(sum(ssno_lyr(1,1,:))>0.) THEN + ssno_lyr(1,1,:) = ssno(1,1) * ssno_lyr(1,1,:)/sum(ssno_lyr(1,1,:)) + ELSE + ssno_lyr(1,1,1) = ssno(1,1) + ENDIF + + IF(sum(ssno_lyr(1,2,:))>0.) THEN + ssno_lyr(1,2,:) = ssno(1,2) * ssno_lyr(1,2,:)/sum(ssno_lyr(1,2,:)) + ELSE + ssno_lyr(1,2,1) = ssno(1,2) + ENDIF + + IF(sum(ssno_lyr(2,1,:))>0.) THEN + ssno_lyr(2,1,:) = ssno(2,1) * ssno_lyr(2,1,:)/sum(ssno_lyr(2,1,:)) + ELSE + ssno_lyr(2,1,1) = ssno(2,1) + ENDIF + + IF(sum(ssno_lyr(2,2,:))>0.) THEN + ssno_lyr(2,2,:) = ssno(2,2) * ssno_lyr(2,2,:)/sum(ssno_lyr(2,2,:)) + ELSE + ssno_lyr(2,2,1) = ssno(2,2) + ENDIF + + ! snow layer absorption + sabg_snow_lyr(:) = forc_sols*ssno_lyr(1,1,:) + forc_solsd*ssno_lyr(1,2,:) & + + forc_soll*ssno_lyr(2,1,:) + forc_solld*ssno_lyr(2,2,:) + + ! convert to the whole area multiplied by snow fractional cover + sabg_snow_lyr(:) = sabg_snow_lyr(:)*fsno + + ! attribute the first layer absorption to soil absorption + sabg_soil = sabg_soil + sabg_snow_lyr(1) + sabg_snow = sabg_snow - sabg_snow_lyr(1) + + ! make the soil absorption consistent + sabg_snow_lyr(1) = sabg_soil + ENDIF + + ENDIF + + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni + + ! calculate the local secs + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + ENDIF + + END SUBROUTINE netsolar + +END MODULE MOD_NetSolar +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 new file mode 100644 index 0000000000..7cf6d7d780 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 @@ -0,0 +1,356 @@ +#include + +MODULE MOD_NetSolar_Hyper + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: netsolar_hyper + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE netsolar_hyper (ipatch,idate,deltim,dlon,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln,& + dir_frac, dif_frac, alb_hires,& + sol_dir_ln_hires,sol_dif_ln_hires,& + sr_dir_ln_hires ,sr_dif_ln_hires ) +! +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Net solar absorbed by surface +! +! Original author: Yongjiu Dai, 09/15/1999; 09/11/2001 +! +! !REVISIONS: +! 05/2014, Hua Yuan: added for solar radiation output [vars: so*, sr*] +! +! 08/2014, Hua Yuan: added for local noon calculation +! +! 08/2020, Hua Yuan: added for PFT and PC calculation +! +! 12/2022, Hua Yuan: calculated snow layer absorption by SNICAR model +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_TimeManager, only: isgreenwich +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch !patch index + integer, intent(in) :: idate(3) !model time + integer, intent(in) :: patchtype !land patch type (99-sea) + + real(r8), intent(in) :: dlon !longitude in radians + real(r8), intent(in) :: deltim !seconds in a time step [second] + + real(r8), intent(in) :: & + forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] + forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + + real(r8), dimension(1:2,1:2), intent(in) :: & + alb ! averaged albedo [-] + + real(r8), dimension(1:2,1:2), intent(inout) :: & + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + ssoi, &! ground soil absorption [-] + ssno ! ground snow absorption [-] + + real(r8), dimension(1:2,1:2,maxsnl+1:1), intent(inout) :: & + ssno_lyr ! snow layer absorption + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), intent(in) :: & + fsno ! snow fractional cover + + real(r8), intent(out) :: & + parsun, &! PAR absorbed by sunlit vegetation [W/m2] + parsha, &! PAR absorbed by shaded vegetation [W/m2] + sabvsun, &! solar absorbed by sunlit vegetation [W/m2] + sabvsha, &! solar absorbed by shaded vegetation [W/m2] + sabg, &! solar absorbed by ground [W/m2] +! 03/06/2020, yuan: + sabg_soil, &! solar absorbed by ground soil [W/m2] + sabg_snow, &! solar absorbed by ground snow [W/m2] + sr, &! total reflected solar radiation (W/m2) + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + + real(r8), intent(out) :: & + sabg_snow_lyr(maxsnl+1:1) ! solar absorbed by snow layers [W/m2] + + ! variables for high resolution + real(r8), intent(in) :: & + dir_frac (211) ,& + dif_frac (211) ,& + alb_hires(211, 2) + + real(r8), intent(out) :: & + sol_dir_ln_hires(211) ,& + sol_dif_ln_hires(211) ,& + sr_dir_ln_hires (211) ,& + sr_dif_ln_hires (211) + + +! ----------------local variables --------------------------------- + integer :: local_secs + real(r8) :: radpsec, sabvg, sabg_noadj + + integer ps, pe, p + +!----------------------------------------------------------------------- + + sabvsun = 0. + sabvsha = 0. + parsun = 0. + parsha = 0. + + IF (lai+sai <= 1.e-6) THEN + ssun(:,:) = 0. + ssha(:,:) = 0. + ENDIF + + sabg = 0. + sabg_soil = 0. + sabg_snow = 0. + sabg_snow_lyr(:) = 0. + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + sabvsun_p(ps:pe) = 0. + sabvsha_p(ps:pe) = 0. + parsun_p (ps:pe) = 0. + parsha_p (ps:pe) = 0. + + DO p = ps, pe + IF (lai_p(p)+sai_p(p) <= 1.e-6) THEN + ssun_p(:,:,p) = 0. + ssha_p(:,:,p) = 0. + ENDIF + ENDDO + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) +#endif + ENDIF + + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + IF (patchtype < 4) THEN !non lake and ocean + ! Radiative fluxes onto surface + parsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) + parsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) + sabvsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) & + + forc_soll*ssun(2,1) + forc_solld*ssun(2,2) + sabvsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) & + + forc_soll*ssha(2,1) + forc_solld*ssha(2,2) + sabvg = forc_sols *(1.-alb(1,1)) + forc_solsd*(1.-alb(1,2)) & + + forc_soll *(1.-alb(2,1)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg - sabvsun - sabvsha + + IF (patchtype == 0) THEN + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + parsun_p (ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) + parsha_p (ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) + sabvsun_p(ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) & + + forc_soll*ssun_p(2,1,ps:pe) + forc_solld*ssun_p(2,2,ps:pe) + sabvsha_p(ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) & + + forc_soll*ssha_p(2,1,ps:pe) + forc_solld*ssha_p(2,2,ps:pe) +#endif + ENDIF + + ELSE !lake and ocean + sabvg = forc_sols *(1.-alb(1,1)) + forc_soll *(1.-alb(2,1)) & + + forc_solsd*(1.-alb(1,2)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg + ENDIF + + ! calculate soil and snow solar absorption + sabg_soil = forc_sols*ssoi(1,1) + forc_solsd*ssoi(1,2) & + + forc_soll*ssoi(2,1) + forc_solld*ssoi(2,2) + sabg_snow = forc_sols*ssno(1,1) + forc_solsd*ssno(1,2) & + + forc_soll*ssno(2,1) + forc_solld*ssno(2,2) + + sabg_soil = sabg_soil * (1.-fsno) + sabg_snow = sabg_snow * fsno + + ! balance check and adjustment for soil and snow absorption + ! this could happen when there is adjustment to ssun,ssha + !NOTE: some times the imbalance may occur in URBAN patch + IF (abs(sabg_soil+sabg_snow-sabg)>1.e-6) THEN + ! IF (.not. (idate(2)==1 .and. idate(3)==int(deltim))) THEN + ! print *, "Patchtype = ", patchtype + ! print *, "MOD_NetSolar.F90: NOTE imbalance in spliting soil and snow surface!", & + ! sabg_soil+sabg_snow-sabg + ! print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + ! print *, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow, "fsno:", fsno + ! print *, "sabvg=",sabvg," sabvsun=",sabvsun," sabvsha=",sabvsha + ! print *, "alb=",alb + ! print *, "forc_sols=",forc_sols," forc_solsd=",forc_solsd + ! print *, "ssoi=",ssoi + ! ENDIF + + sabg_noadj = sabg_soil + sabg_snow + + IF (sabg_noadj > 0.) THEN + sabg_soil = sabg_soil * sabg/sabg_noadj + sabg_snow = sabg_snow * sabg/sabg_noadj + ssoi(:,:) = ssoi(:,:) * sabg/sabg_noadj + ssno(:,:) = ssno(:,:) * sabg/sabg_noadj + ENDIF + ENDIF + + ! snow layer absorption calculation and adjustment for SNICAR model + IF (DEF_USE_SNICAR) THEN + ! adjust snow layer absorption due to multiple reflection between ground and canopy + IF(sum(ssno_lyr(1,1,:))>0.) THEN + ssno_lyr(1,1,:) = ssno(1,1) * ssno_lyr(1,1,:)/sum(ssno_lyr(1,1,:)) + ELSE + ssno_lyr(1,1,1) = ssno(1,1) + ENDIF + + IF(sum(ssno_lyr(1,2,:))>0.) THEN + ssno_lyr(1,2,:) = ssno(1,2) * ssno_lyr(1,2,:)/sum(ssno_lyr(1,2,:)) + ELSE + ssno_lyr(1,2,1) = ssno(1,2) + ENDIF + + IF(sum(ssno_lyr(2,1,:))>0.) THEN + ssno_lyr(2,1,:) = ssno(2,1) * ssno_lyr(2,1,:)/sum(ssno_lyr(2,1,:)) + ELSE + ssno_lyr(2,1,1) = ssno(2,1) + ENDIF + + IF(sum(ssno_lyr(2,2,:))>0.) THEN + ssno_lyr(2,2,:) = ssno(2,2) * ssno_lyr(2,2,:)/sum(ssno_lyr(2,2,:)) + ELSE + ssno_lyr(2,2,1) = ssno(2,2) + ENDIF + + ! snow layer absorption + sabg_snow_lyr(:) = forc_sols*ssno_lyr(1,1,:) + forc_solsd*ssno_lyr(1,2,:) & + + forc_soll*ssno_lyr(2,1,:) + forc_solld*ssno_lyr(2,2,:) + + ! convert to the whole area multiplied by snow fractional cover + sabg_snow_lyr(:) = sabg_snow_lyr(:)*fsno + + ! attribute the first layer absorption to soil absorption + sabg_soil = sabg_soil + sabg_snow_lyr(1) + sabg_snow = sabg_snow - sabg_snow_lyr(1) + + ! make the soil absorption consistent + sabg_snow_lyr(1) = sabg_soil + ENDIF + + ENDIF + + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni + + ! calculate the local secs + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + + ! calculate the high resolution solar radiation, maybe not called "_ln" + sol_dir_ln_hires = (forc_sols + forc_soll ) * dir_frac(:) + sol_dif_ln_hires = (forc_solsd + forc_solld) * dif_frac(:) + sr_dir_ln_hires = sol_dir_ln_hires(:) * alb_hires(:,1) + sr_dif_ln_hires = sol_dif_ln_hires(:) * alb_hires(:,2) + + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + + sol_dir_ln_hires = spval + sol_dif_ln_hires = spval + sr_dir_ln_hires = spval + sr_dif_ln_hires = spval + ENDIF + + END SUBROUTINE netsolar_hyper + +END MODULE MOD_NetSolar_Hyper +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 new file mode 100644 index 0000000000..d5bea0a205 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 @@ -0,0 +1,125 @@ +MODULE MOD_NewSnow + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: newsnow + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + t_precip,zi_soisno,z_soisno,dz_soisno,t_soisno,& + wliq_soisno,wice_soisno,fiold,snl,sag,scv,snowdp,fsno,wetwat) + +!======================================================================= +! add new snow nodes. +! Original author: Yongjiu Dai, 09/15/1999; 08/31/2002, 07/2013, 04/2014 +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_VariablySaturatedFlow + USE MOD_Const_Physical, only: tfrz, cpliq, cpice + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99=ocean) + real(r8), intent(in) :: deltim ! model time step [second] + real(r8), intent(in) :: t_grnd ! ground surface temperature [k] + real(r8), intent(in) :: pg_rain ! rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: t_precip ! snowfall/rainfall temperature [kelvin] + + real(r8), intent(inout) :: zi_soisno(maxsnl:0) ! interface level below a "z" level (m) + real(r8), intent(inout) :: z_soisno(maxsnl+1:0) ! layer depth (m) + real(r8), intent(inout) :: dz_soisno(maxsnl+1:0) ! layer thickness (m) + real(r8), intent(inout) :: t_soisno(maxsnl+1:0) ! soil + snow layer temperature [K] + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:0) ! liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:0) ! ice lens (kg/m2) + real(r8), intent(inout) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water + integer , intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + real(r8), intent(inout) :: scv ! snow mass (kg/m2) + real(r8), intent(inout) :: snowdp ! snow depth (m) + real(r8), intent(inout) :: fsno ! fraction of soil covered by snow [-] + + real(r8), intent(inout), optional :: wetwat ! wetland water [mm] + +!-------------------------- Local Variables ---------------------------- + + real(r8) dz_snowf ! layer thickness rate change due to precipitation [mm/s] + integer newnode ! signification when new snow node is set, (1=yes, 0=no) + integer lb + +!----------------------------------------------------------------------- + + newnode = 0 + + dz_snowf = pg_snow/bifall + snowdp = snowdp + dz_snowf*deltim + scv = scv + pg_snow*deltim ! snow water equivalent (mm) + + IF(patchtype==2 .and. t_grnd>tfrz)THEN ! snowfall on warmer wetland + IF (present(wetwat) .and. DEF_USE_VariablySaturatedFlow) THEN + wetwat = wetwat + scv + ENDIF + scv=0.; snowdp=0.; sag=0.; fsno = 0. + ENDIF + + zi_soisno(0) = 0. + +! when the snow accumulation exceeds 10 mm, initialize a snow layer + + IF(snl==0 .and. pg_snow>0.0 .and. snowdp>=0.01)THEN + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + + sag = 0. ! snow age + t_soisno (0) = min(tfrz, t_precip) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + fsno = min(1.,tanh(0.1*pg_snow*deltim)) + ENDIF + + ! -------------------------------------------------- + ! snowfall on snow pack + ! -------------------------------------------------- + ! the change of ice partial density of surface node due to precipitation + ! only ice part of snowfall is added here, the liquid part will be added latter + + IF(snl<0 .and. newnode==0)THEN + lb = snl + 1 + + wice_soisno(lb) = wice_soisno(lb)+deltim*pg_snow + dz_soisno(lb) = dz_soisno(lb)+dz_snowf*deltim + z_soisno(lb) = zi_soisno(lb) - 0.5*dz_soisno(lb) + zi_soisno(lb-1) = zi_soisno(lb) - dz_soisno(lb) + + ! update fsno by new snow event, add to previous fsno + ! shape factor for accumulation of snow = 0.1 + fsno = 1. - (1. - tanh(0.1*pg_snow*deltim))*(1. - fsno) + fsno = min(1., fsno) + + ENDIF + + END SUBROUTINE newsnow + +END MODULE MOD_NewSnow +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 new file mode 100644 index 0000000000..d6e73fed5b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 @@ -0,0 +1,171 @@ +#include + +#ifdef BGC +MODULE MOD_NitrifData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in nitrif data. +! +! !ORIGINAL: +! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the nitrif data module. +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_BGC_Vars_TimeVariables, only: tCONC_O2_UNSAT, tO2_DECOMP_DEPTH_UNSAT + IMPLICIT NONE + + type(grid_type) :: grid_nitrif + type(spatial_mapping_type) :: mg2p_nitrif + +CONTAINS + + SUBROUTINE init_nitrif_data (time) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open nitrif netcdf file from DEF_dir_runtime, read latitude and +! longitude info. Initialize nitrif data read in. +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + type(timestamp), intent(in) :: time + + ! Local Variables + character(len=256) :: file_nitrif + real(r8), allocatable :: lat(:), lon(:) + integer :: month, mday + + file_nitrif = trim(DEF_dir_runtime)//'/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l01.nc' + + CALL ncio_read_bcast_serial (file_nitrif, 'lat', lat) + CALL ncio_read_bcast_serial (file_nitrif, 'lon', lon) + + CALL grid_nitrif%define_by_center (lat, lon) + + CALL mg2p_nitrif%build_arealweighted (grid_nitrif, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL julian2monthday (time%year, time%day, month, mday) + + CALL update_nitrif_data (month) + + END SUBROUTINE init_nitrif_data + + ! ---------- + SUBROUTINE update_nitrif_data (month) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Vars_Global, only: nl_soil + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: month + + ! Local Variables + character(len=256) :: file_nitrif + type(block_data_real8_2d) :: f_xy_nitrif + real(r8), allocatable :: tCONC_O2_UNSAT_tmp(:) + real(r8), allocatable :: tO2_DECOMP_DEPTH_UNSAT_tmp(:) + character(len=2) :: cx + integer :: nsl, npatch, m + + IF (p_is_worker) THEN + allocate(tCONC_O2_UNSAT_tmp (numpatch)) + allocate(tO2_DECOMP_DEPTH_UNSAT_tmp(numpatch)) + ENDIF + + IF (p_is_io) THEN + CALL allocate_block_data (grid_nitrif, f_xy_nitrif) + ENDIF + + DO nsl = 1, nl_soil + + write(cx,'(i2.2)') nsl + file_nitrif = trim(DEF_dir_runtime)//& + '/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l'//trim(cx)//'.nc' + IF (p_is_io) THEN + CALL ncio_read_block_time (file_nitrif, & + 'CONC_O2_UNSAT', grid_nitrif, month, f_xy_nitrif) + ENDIF + + CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tCONC_O2_UNSAT_tmp) + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF( m == 0 )THEN + tCONC_O2_UNSAT(nsl,npatch) = 0. + ELSE + tCONC_O2_UNSAT(nsl,npatch) = tCONC_O2_UNSAT_tmp(npatch) + ENDIF + IF (tCONC_O2_UNSAT(nsl,npatch) < 1E-10) THEN + tCONC_O2_UNSAT(nsl,npatch)=0.0 + ENDIF + ENDDO + + ENDIF + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('CONC_O2_UNSAT', tCONC_O2_UNSAT) +#endif + + DO nsl = 1, nl_soil + + write(cx,'(i2.2)') nsl + file_nitrif = trim(DEF_dir_runtime)//& + '/nitrif/O2_DECOMP_DEPTH_UNSAT/O2_DECOMP_DEPTH_UNSAT_l'//trim(cx)//'.nc' + IF (p_is_io) THEN + CALL ncio_read_block_time (file_nitrif, & + 'O2_DECOMP_DEPTH_UNSAT', grid_nitrif, month, f_xy_nitrif) + ENDIF + + CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF( m == 0 )THEN + tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) = 0. + ELSE + tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) = tO2_DECOMP_DEPTH_UNSAT_tmp(npatch) + ENDIF + IF (tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) < 1E-10) THEN + tO2_DECOMP_DEPTH_UNSAT(nsl,npatch)=0.0 + ENDIF + ENDDO + + ENDIF + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('O2_DECOMP_DEPTH_UNSAT', tO2_DECOMP_DEPTH_UNSAT) +#endif + + IF (p_is_worker) THEN + deallocate (tCONC_O2_UNSAT_tmp) + deallocate (tO2_DECOMP_DEPTH_UNSAT_tmp) + ENDIF + + END SUBROUTINE update_nitrif_data + +END MODULE MOD_NitrifData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 new file mode 100644 index 0000000000..5f8288c7d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 @@ -0,0 +1,70 @@ +#include + +MODULE MOD_OrbCosazi + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: orb_cosazi +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + FUNCTION orb_cosazi(calday, dlon, dlat, coszen) + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: calday !Julian cal day (1.xx to 365.xx) + real(r8), intent(in) :: dlat !Centered latitude (radians) + real(r8), intent(in) :: dlon !Centered longitude (radians) + real(r8), intent(in) :: coszen !cosine of sun zenith angle + real(r8) :: orb_cosazi !cosine of sun azimuth angle + +!-------------------------- Local Variables ---------------------------- + real(r8) declin !Solar declination (radians) + real(r8) eccf !Earth-sun distance factor (ie. (1/r)**2) + real(r8) lambm !Lambda m, mean long of perihelion (rad) + real(r8) lmm !Intermediate argument involving lambm + real(r8) lamb !Lambda, the earths long of perihelion + real(r8) invrho !Inverse normalized sun/earth distance + real(r8) sinl !Sine of lmm + real(r8) pi !3.14159265358979323846... + real(r8), parameter :: & + dayspy=365.0, &!days per year + ve=80.5, &!Calday of vernal equinox assumes Jan 1 = calday 1 + eccen=1.672393084E-2, &!Eccentricity + obliqr=0.409214646, &!Earths obliquity in radians + lambm0=-3.2625366E-2, &!Mean long of perihelion at the vernal equinox (radians) + mvelpp=4.92251015 !moving vernal equinox longitude of + !perihelion plus pi (radians) +!----------------------------------------------------------------------- + + pi = 4.*atan(1.) + lambm = lambm0 + (calday - ve)*2.*pi/dayspy + lmm = lambm - mvelpp + + sinl = sin(lmm) + lamb = lambm + eccen*(2.*sinl + eccen*(1.25*sin(2.*lmm) & + + eccen*((13.0/12.0)*sin(3.*lmm) - 0.25*sinl))) + invrho = (1. + eccen*cos(lamb - mvelpp)) / (1. - eccen*eccen) + + declin = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho + + orb_cosazi = (-1*cos(declin)*cos(calday*2.0*pi+dlon) - & + coszen*cos(dlat))/(sin(dlat)*sqrt(1-coszen*coszen)) + + IF (orb_cosazi<-1) orb_cosazi = -1 + IF (orb_cosazi>1 ) orb_cosazi = 1 + + END FUNCTION orb_cosazi + +END MODULE MOD_OrbCosazi +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 new file mode 100644 index 0000000000..ab8ced757f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 @@ -0,0 +1,84 @@ +#include + +MODULE MOD_OrbCoszen + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: orb_coszen + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + FUNCTION orb_coszen(calday,dlon,dlat) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! FUNCTION to return the cosine of the solar zenith angle. Assumes +! 365.0 days/year. Compute earth/orbit parameters using formula +! suggested by Duane Thresher. Use formulas from Berger, Andre 1978: +! Long-Term Variations of Daily Insolation and Quaternary Climatic +! Changes. J. of the Atmo. Sci. 35:2362-2367. +! +! Original version: Erik Kluzek, Oct/1997, Brian Kauffman, Jan/98 +! CCSM2.0 standard +! Yongjiu Dai (07/23/2002) +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: calday !Julian cal day (1.xx to 365.xx) + real(r8), intent(in) :: dlat !Centered latitude (radians) + real(r8), intent(in) :: dlon !Centered longitude (radians) + real(r8) :: orb_coszen + +!-------------------------- Local Variables ---------------------------- + real(r8) declin !Solar declination (radians) + real(r8) eccf !Earth-sun distance factor (ie. (1/r)**2) + real(r8) lambm !Lambda m, mean long of perihelion (rad) + real(r8) lmm !Intermediate argument involving lambm + real(r8) lamb !Lambda, the earths long of perihelion + real(r8) invrho !Inverse normalized sun/earth distance + real(r8) sinl !Sine of lmm + real(r8) pi !3.14159265358979323846... + real(r8), parameter :: & + dayspy=365.0, &!days per year + ve=80.5, &!Calday of vernal equinox assumes Jan 1 = calday 1 + eccen=1.672393084E-2, &!Eccentricity + obliqr=0.409214646, &!Earths obliquity in radians + lambm0=-3.2625366E-2, &!Mean long of perihelion at the vernal equinox (radians) + mvelpp=4.92251015 !moving vernal equinox longitude of + !perihelion plus pi (radians) +!----------------------------------------------------------------------- + + pi = 4.*atan(1.) + lambm = lambm0 + (calday - ve)*2.*pi/dayspy + lmm = lambm - mvelpp + + sinl = sin(lmm) + lamb = lambm + eccen*(2.*sinl + eccen*(1.25*sin(2.*lmm) & + + eccen*((13.0/12.0)*sin(3.*lmm) - 0.25*sinl))) + invrho = (1. + eccen*cos(lamb - mvelpp)) / (1. - eccen*eccen) + + declin = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho + + orb_coszen = sin(dlat)*sin(declin) & + - cos(dlat)*cos(declin)*cos(calday*2.0*pi+dlon) + + END FUNCTION orb_coszen + +END MODULE MOD_OrbCoszen +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 new file mode 100644 index 0000000000..20904245a8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 @@ -0,0 +1,275 @@ +#include + +Module MOD_Ozone + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module hold the plant physiological response to the ozone, +! including vcmax response and stomata response. Ozone concentration +! can be either readin through Mod_OzoneData module or set to constant. +! +! Original: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISIONS: +! 2022, Xingjie Lu: revised the CLM5 code to be compatible with CoLM +! code structure. +! 2024, Fang Li : used the new ozone stress parameterization scheme +! based on Li et al. (2024; GMD) +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: rgas + USE MOD_Const_PFT, only: isevg, leaf_long, woody + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Vars_1DForcing, only: forc_ozone + USE MOD_Namelist, only: DEF_USE_OZONEDATA + IMPLICIT NONE + + character(len=256) :: file_ozone + + type(grid_type) :: grid_ozone + + type(block_data_real8_2d) :: f_ozone + + type(spatial_mapping_type) :: mg2p_ozone + + SAVE + + PUBLIC :: CalcOzoneStress + PUBLIC :: init_ozone_data + PUBLIC :: update_ozone_data + +CONTAINS + + SUBROUTINE CalcOzoneStress (o3coefv,o3coefg, forc_ozone, forc_psrf, th, ram, & + rs, rb, lai, lai_old, ivt, o3uptake, sabv, deltim) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate Ozone Stress on both vcmax and stomata conductance. +! +! convert o3 from mol/mol to nmol m^-3 +!----------------------------------------------------------------------- + real(r8), intent(out) :: o3coefv + real(r8), intent(out) :: o3coefg + real(r8), intent(inout) :: forc_ozone !ozone concentration (ppbv) + real(r8), intent(in) :: forc_psrf + real(r8), intent(in) :: th + real(r8), intent(in) :: ram + real(r8), intent(in) :: rs + real(r8), intent(in) :: rb + real(r8), intent(in) :: lai + real(r8), intent(in) :: lai_old + integer , intent(in) :: ivt + real(r8), intent(inout) :: o3uptake + real(r8), intent(in) :: deltim + real(r8), intent(in) :: sabv !solar radiation absorbed by vegetation (W/m**2) + + real(r8) :: o3concnmolm3 ! o3 concentration (nmol/m^3) + real(r8) :: o3flux ! instantaneous o3 flux (nmol m^-2 s^-1) + real(r8) :: o3fluxcrit ! instantaneous o3 flux beyond threshold (nmol m^-2 s^-1) + real(r8) :: o3fluxperdt ! o3 flux per timestep (mmol m^-2) + real(r8) :: leafturn ! leaf turnover time / mortality rate (per hour) + real(r8) :: decay ! o3uptake decay rate based on leaf lifetime (mmol m^-2) + real(r8) :: lai_thresh ! LAI threshold for LAIs that asymptote and don't + real(r8) :: o3_flux_threshold !threshold below which o3flux is set to 0 (nmol m^-2 s^-1) + + real(r8), parameter :: ko3 = 1.51_r8 !F. Li + + + IF(.not. DEF_USE_OZONEDATA)THEN + forc_ozone = 100._r8 ! ozone partial pressure [ppbv] + ENDIF + + o3concnmolm3 = forc_ozone * (forc_psrf/(th * 8.314 )) + + ! calculate instantaneous flux + o3flux = o3concnmolm3/ (ko3*rs+ rb + ram) + + ! set lai_thresh + IF (isevg(ivt)) THEN + lai_thresh=0._r8 !so evergreens grow year-round + ELSE ! for deciduous vegetation + IF(ivt == 10)THEN !temperate shrub + lai_thresh=0.3_r8 + ELSE + lai_thresh=0.5_r8 + end if + end if + + + ! set o3 flux threshold + o3_flux_threshold=10._r8 + IF(ivt >= 1 .and. ivt <= 3)THEN !Needleleaf tree + o3_flux_threshold=0.8_r8 + ENDIF + IF(ivt >= 4 .and. ivt <= 8)THEN !Broadleaf tree + o3_flux_threshold=1.0_r8 + ENDIF + IF(ivt >= 9 .and. ivt <= 11)THEN !Shrub + o3_flux_threshold=6.0_r8 + ENDIF + IF(ivt >= 12 .and. ivt <= 14)THEN !Grass + o3_flux_threshold = 1.6_r8 + ENDIF + IF(ivt >= 15)THEN !Crop + o3_flux_threshold = 0.5_r8 + ENDIF + + + IF (o3flux < o3_flux_threshold) THEN + o3fluxcrit = 0._r8 + ELSE + o3fluxcrit = o3flux - o3_flux_threshold + ENDIF + + ! calculate o3 flux per timestep + IF(sabv > 0._r8)THEN !daytime + o3fluxperdt = o3fluxcrit * deltim * 0.000001_r8 + ELSE + o3fluxperdt = 0._r8 + ENDIF + + IF (lai > lai_thresh) THEN + ! o3 uptake decay + IF (isevg(ivt)) THEN + leafturn = 2._r8/(leaf_long(ivt)*365._r8*24._r8) + decay = o3uptake * leafturn * deltim/3600._r8 + ELSE + decay = o3uptake * max(0._r8,(1._r8-lai_old/lai)) + ENDIF + + !cumulative uptake (mmol m^-2) + o3uptake = min(90._r8, max(0._r8, o3uptake + o3fluxperdt - decay)) + + ELSE + o3uptake = 0._r8 + ENDIF + + IF (o3uptake == 0._r8) THEN + ! No o3 damage IF no o3 uptake + o3coefv = 1._r8 + o3coefg = 1._r8 + ELSE + ! Determine parameter values for this pft + IF(ivt >= 1 .and. ivt <= 3)THEN !Needleleaf tree + o3coefv = max(0._r8, min(1._r8, 1.005_r8 - 0.0064_r8 * o3uptake)) + o3coefg = max(0._r8, min(1._r8, 0.965_r8 * o3uptake ** (-0.041))) + ENDIF + IF(ivt >= 4 .and. ivt <= 8)THEN !Broadleaf tree + o3coefv = max(0._r8, min(1._r8, 0.943_r8 * exp(-0.0085*o3uptake))) + o3coefg = max(0._r8, min(1._r8, 0.943_r8 * exp(-0.0058*o3uptake))) + ENDIF + IF(ivt >= 9 .and. ivt <= 11)THEN !Shrub + o3coefv = max(0._r8, min(1._r8, 1.000_r8-0.074_r8 * log(o3uptake))) + o3coefg = max(0._r8, min(1._r8, 0.991_r8-0.060_r8 * log(o3uptake))) + ENDIF + IF(ivt >= 12 .and. ivt <= 14)THEN !Grass + o3coefv = max(0._r8, min(1._r8, 0.997_r8 - 0.016_r8 * o3uptake)) + o3coefg = max(0._r8, min(1._r8, 0.989_r8 - 0.045_r8 * log(o3uptake))) + ENDIF + IF(ivt >= 15)THEN !Crop + o3coefv = max(0._r8, min(1._r8, 0.909_r8 - 0.028_r8 * log(o3uptake))) + o3coefg = max(0._r8, min(1._r8, 1.005_r8 - 0.169_r8 * tanh(o3uptake))) + ENDIF + ENDIF + + END SUBROUTINE CalcOzoneStress + + + SUBROUTINE init_ozone_data (idate) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open ozone netcdf file from DEF_dir_rawdata, read latitude and +! longitude info. Initialize Ozone data read in. +!----------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + integer :: itime + integer :: iyear, month, mday + character(len=8) :: syear, smonth + +! CALL julian2monthday(idate(1),idate(2),month,mday) +! iyear = idate(1) +! IF(idate(1) .lt. 2013)iyear = 2013 +! IF(idate(1) .gt. 2021)iyear = 2021 +! write(syear,"(I4.4)") iyear +! write(smonth,"(I2.2)") month + file_ozone = trim(DEF_dir_runtime) // '/Ozone//Global/OZONE-setgrid.nc' +! file_ozone = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime/Ozone//Global/OZONE-setgrid.nc' + + CALL ncio_read_bcast_serial (file_ozone, 'lat', lat) + CALL ncio_read_bcast_serial (file_ozone, 'lon', lon) + + CALL grid_ozone%define_by_center (lat, lon) + + CALL allocate_block_data (grid_ozone, f_ozone) + + CALL mg2p_ozone%build_arealweighted (grid_ozone, landpatch) + + itime = (idate(3) - 1800) / 10800 + (min(idate(2),365) - 1) * 8 + 1 + + CALL ncio_read_block_time (file_ozone, 'OZONE', grid_ozone, itime, f_ozone) +#ifdef RangeCheck + CALL check_block_data ('Ozone', f_ozone) +#endif + + END SUBROUTINE init_ozone_data + + SUBROUTINE update_ozone_data (time, deltim) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! read ozone data during simulation +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + type(timestamp), intent(in) :: time + real(r8), intent(in) :: deltim + + ! Local Variables + type(timestamp) :: time_next + integer :: month, mday + integer :: iyear, itime + character(len=8) :: syear, smonth + + file_ozone = trim(DEF_dir_runtime) // '/Ozone/Global/OZONE-setgrid.nc' +! file_ozone = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime/Ozone/Global/OZONE-setgrid.nc' + IF(time%sec/10800 .ne. (time%sec+int(deltim))/10800)then + itime = (time%sec - int(deltim)) / 10800 + (min(time%day,365) - 1) * 8 + 1 + CALL ncio_read_block_time (file_ozone, 'OZONE', grid_ozone, itime, f_ozone) +#ifdef RangeCheck + CALL check_block_data ('Ozone', f_ozone) +#endif + + CALL mg2p_ozone%grid2pset (f_ozone, forc_ozone) +#ifdef RangeCheck + CALL check_vector_data ('Ozone', forc_ozone) +#endif + ENDIF + + END SUBROUTINE update_ozone_data + +END MODULE MOD_Ozone +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 new file mode 100644 index 0000000000..a7127f8c58 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 @@ -0,0 +1,823 @@ +#include + +MODULE MOD_PhaseChange + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: meltf + PUBLIC :: meltf_snicar + PUBLIC :: meltf_urban + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE meltf (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact,brr,hs,hs_soil,hs_snow,fsno,dhsdT, & + t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculation of the phase change within snow and soil layers: +! (1) check the conditions which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e., melting), +! or layer temperature is less than the freezing point +! and the liquid water mass is not equal to zero (i.e., freezing); +! (2) assess the rate of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point; +! (3) re-adjust the ice and liquid mass, and the layer temperature +! +! Original author: Yongjiu Dai, /09/1999/, /03/2014/ +! +! !REVISIONS: +! 08/2020, Hua Yuan: separate soil/snow heat flux, exclude glacier (3) +! 04/2023, Nan Wei: supercooled soil water is included IF supercool is defined. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Hydro_SoilFunction + USE MOD_Const_Physical, only: tfrz, hfus, grav + USE MOD_Namelist + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + logical, intent(in) :: is_dry_lake + integer, intent(in) :: nl_soil !upper bound of array (i.e., soil layers) + integer, intent(in) :: lb !lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim !time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) !temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) !temporary variables + real(r8), intent(in) :: hs !net ground heat flux into the surface + real(r8), intent(in) :: hs_soil !net ground heat flux into the surface soil + real(r8), intent(in) :: hs_snow !net ground heat flux into the surface snow + real(r8), intent(in) :: fsno !snow fractional cover + real(r8), intent(in) :: dhsdT !temperature derivative of "hs" + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil), & + alpha_vgm(1:nl_soil), & + n_vgm (1:nl_soil), & + L_vgm (1:nl_soil), & + sc_vgm (1:nl_soil), & + fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: dz(1:nl_soil) !soil layer thickness [m] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow mass [kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: hm(lb:nl_soil) !energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) !melting or freezing within a time step [kg/m2] + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: temp2 !temporary variables [kg/m2] + real(r8) :: smp + real(r8) :: supercool(1:nl_soil) !the maximum liquid water when soil T below the tfrz [mm3/mm3] + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j + +!----------------------------------------------------------------------- + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + +! supercooling water + IF (DEF_USE_SUPERCOOL_WATER) THEN + DO j = 1, nl_soil + supercool(j) = 0.0 + IF(t_soisno(j) < tfrz .and. ((patchtype <=2) .or. is_dry_lake)) THEN + smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm + IF (porsl(j) > 0.) THEN +#ifdef Campbell_SOIL_MODEL + supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) +#else + supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & + (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) +#endif + ELSE + supercool(j) = 0. + ENDIF + supercool(j) = supercool(j)*dz(j)*1000. ! mm + ENDIF + ENDDO + ENDIF + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(j <= 0)THEN + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDIF + ENDIF + ENDDO + +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF + +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3) .or. is_dry_lake)) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + hm(j) = brr(j) - tinc/fact(j) + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO + +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + IF(j <= 0) THEN ! snow + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wmass0(j) < supercool(j)) THEN + wice_soisno(j) = 0. + ELSE + wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) + ENDIF + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ENDIF + ENDIF + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3) .or. is_dry_lake)) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF + ENDIF + + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(j <= 0 .or. patchtype == 3)THEN !snow + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO + + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + CALL CoLM_stop() + ENDIF + ENDIF + + END SUBROUTINE meltf + + + SUBROUTINE meltf_snicar (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact,brr,hs,hs_soil,hs_snow,fsno,sabg_snow_lyr,dhsdT, & + t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculation of the phase change within snow and soil layers: +! (1) check the conditions which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e., melting), +! or layer temperature is less than the freezing point +! and the liquid water mass is not equal to zero (i.e., freezing); +! (2) assess the rate of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point; +! (3) re-adjust the ice and liquid mass, and the layer temperature +! +! Original author: Yongjiu Dai, /09/1999/, /03/2014/ +! +! !REVISIONS: +! 08/2020, Hua Yuan: separate soil/snow heat flux, exclude glacier (3) +! 01/2023, Hua Yuan: added snow layer absorption in melting calculation +! 04/2023, Nan Wei: supercooled soil water is included IF supercool is defined. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Hydro_SoilFunction + USE MOD_Const_Physical, only: tfrz, hfus, grav + USE MOD_Namelist + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + logical, intent(in) :: is_dry_lake + integer, intent(in) :: nl_soil !upper bound of array (i.e., soil layers) + integer, intent(in) :: lb !lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim !time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) !temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) !temporary variables + real(r8), intent(in) :: hs !net ground heat flux into the surface + real(r8), intent(in) :: hs_soil !net ground heat flux into the surface soil + real(r8), intent(in) :: hs_snow !net ground heat flux into the surface snow + real(r8), intent(in) :: fsno !snow fractional cover + real(r8), intent(in) :: dhsdT !temperature derivative of "hs" + real(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil), & + alpha_vgm(1:nl_soil), & + n_vgm (1:nl_soil), & + L_vgm (1:nl_soil), & + sc_vgm (1:nl_soil), & + fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: dz(1:nl_soil) !soil layer thickness [m] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow mass [kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: hm(lb:nl_soil) !energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) !melting or freezing within a time step [kg/m2] + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: temp2 !temporary variables [kg/m2] + real(r8) :: smp + real(r8) :: supercool(1:nl_soil) !the maximum liquid water when soil T below the tfrz [mm3/mm3] + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j + +!----------------------------------------------------------------------- + + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + +! supercooling water + IF (DEF_USE_SUPERCOOL_WATER) THEN + DO j = 1, nl_soil + supercool(j) = 0.0 + IF(t_soisno(j) < tfrz .and. ((patchtype <= 2) .or. is_dry_lake)) THEN + smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm + IF (porsl(j) > 0.) THEN +#ifdef Campbell_SOIL_MODEL + supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) +#else + supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & + (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) +#endif + ELSE + supercool(j) = 0. + ENDIF + supercool(j) = supercool(j)*dz(j)*1000. ! mm + ENDIF + ENDDO + ENDIF + + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(j <= 0)THEN + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDIF + ENDIF + ENDDO + +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF + +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3).or.is_dry_lake)) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + IF (j<1 .or. (j==1 .and. patchtype==3)) THEN + hm(j) = brr(j) - tinc/fact(j) + sabg_snow_lyr(j) + ELSE + hm(j) = brr(j) - tinc/fact(j) + ENDIF + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO + +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + IF(j <= 0) THEN ! snow + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wmass0(j) < supercool(j)) THEN + wice_soisno(j) = 0. + ELSE + wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) + ENDIF + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ENDIF + ENDIF + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3).or.is_dry_lake)) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF + ENDIF + + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(j <= 0 .or. patchtype == 3)THEN !snow + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO + + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + CALL CoLM_stop() + ENDIF + ENDIF + + END SUBROUTINE meltf_snicar + + SUBROUTINE meltf_urban (lb,nl_soil,deltim, & + fact,brr,hs,dhsdT, & + t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & + scv,snowdp,sm,xmf) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! calculation of the phase change within snow and soil layers: +! +! (1) check the conditions which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e., melting), +! or layer temperature is less than the freezing point +! and the liquid water mass is not equal to zero (i.e., freezing); +! (2) assess the rate of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point; +! (3) re-adjust the ice and liquid mass, and the layer temperature +! +! Original author: Yongjiu Dai, /09/1999/, /03/2014/ +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Const_Physical, only: tfrz, hfus + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: nl_soil !upper bound of array (i.e., soil layers) + integer, intent(in) :: lb !lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim !time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) !temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) !temporary variables + real(r8), intent(in) :: hs !net ground heat flux into the surface + real(r8), intent(in) :: dhsdT !temperature derivative of "hs" + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow mass [kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: hm(lb:nl_soil) !energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) !melting or freezing within a time step [kg/m2] + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: temp2 !temporary variables [kg/m2] + + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j + +!----------------------------------------------------------------------- + + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDDO + +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF + +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + IF(j > lb)THEN + hm(j) = brr(j) - tinc/fact(j) + ELSE + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO + +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ELSE + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ENDIF + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO + + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + CALL CoLM_stop() + ENDIF + ENDIF + + END SUBROUTINE meltf_urban + +END MODULE MOD_PhaseChange +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 new file mode 100644 index 0000000000..f85365c619 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 @@ -0,0 +1,1096 @@ + +MODULE MOD_PlantHydraulic + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_RSS_SCHEME + USE MOD_SPMD_Task + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: PlantHydraulicStress_twoleaf + PUBLIC :: getvegwp_twoleaf + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: calcstress_twoleaf + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss ,& + ra ,rd ,rstfacsun ,rstfacsha ,cintsun ,& + cintsha ,laisun ,laisha ,rhoair ,fwet ,& + sai ,kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,htop ,& + ck ,smp ,hk ,hksati ,vegwp ,& + etrsun ,etrsha ,rootflux ,qg ,& + qm ,gs0sun ,gs0sha ,k_soil_root,k_ax_root ,& + gssun ,gssha) + +!======================================================================= +! +! calculation of plant hydraulic stress +! +! Author: Xingjie Lu, 16/01/2019, modified from CLM5 plant_hydraulic_stress module +! +!---------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer ,intent(in) :: nl_soil ! upper bound of array + integer ,intent(in) :: nvegwcs ! upper bound of array + real(r8),intent(in), dimension(nl_soil) :: & + z_soi, &! soil node depth (m) + dz_soi ! soil layer thicknesses (m) + real(r8),intent(inout), dimension(nvegwcs) :: & + vegwp ! vegetation water potential + real(r8),intent(inout):: & + gs0sun, & ! maximum stomata conductance of sunlit leaf + gs0sha ! maximum stomata conductance of shaded leaf + + real(r8),intent(in) :: & + rss, &! soil surface resistance [s/m] + psrf, &! surface atmospheric pressure (pa) + qg, &! specific humidity at ground surface [kg/kg] + qm ! specific humidity at reference height [kg/kg] + + real(r8),intent(in) :: & + qsatl, &! leaf specific humidity [kg/kg] + qaf, &! humidity of canopy air [kg/kg] + tl, &! leaf temperature (K) + + rb, &! boundary resistance from canopy to cas (s m-1) + rd, &! aerodynamical resistance between ground and canopy air + ra ! aerodynamic resistance from cas to reference height (s m-1) + + real(r8),intent(inout) :: & + rstfacsun, &! canopy resistance stress factors to soil moisture for sunlit leaf + rstfacsha ! canopy resistance stress factors to soil moisture for shaded leaf + + real(r8),intent(in) :: & + laisun, &! sunlit leaf area index, one-sided + laisha, &! shaded leaf area index, one-sided + sai, &! stem area index + kmax_sun, & + kmax_sha, & + kmax_xyl, & + kmax_root, & + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + htop, &! canopy top [m] + ck, &! shape-fitting parameter for vulnerability curve (-) + rhoair, &! density [kg/m**3] + fwet ! fraction of foliage that is wet [-] + + real(r8),intent(in), dimension(3) :: & + cintsun, &! scaling up from sunlit leaf to canopy + cintsha ! scaling up from shaded leaf to canopy + + real(r8),intent(in), dimension(nl_soil) :: & + smp, &! soil matrix potential + rootfr, &! root fraction + hksati, &! hydraulic conductivity at saturation [mm h2o/s] + hk ! soil hydraulic conductance [mm h2o/s] + + + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + etrsun, &! transpiration from sunlit leaf (mm/s) + etrsha ! transpiration from shaded leaf (mm/s) + + real(r8),intent(out),dimension(nl_soil) :: & + rootflux ! root water uptake from different layers + + real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance + real(r8),intent(inout) :: gssun ! sunlit leaf conductance + real(r8),intent(inout) :: gssha ! shaded leaf conductance + +!-------------------------- Local Variables ---------------------------- + + integer, parameter :: iterationtotal = 6 + + real(r8) c3, &! c3 vegetation : 1; 0 for c4 + + tprcor, &! coefficient for unit transfer + gb_mol ! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) + + real(r8), dimension(nl_soil) :: & + fs !root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) + real(r8), dimension(nl_soil) :: & + rai ! soil-root interface conductance [mm/s] + + real(r8) soilflux ! soil-root interface conductance [mm/s] + real(r8) soil_conductance ! soil conductance + real(r8) root_conductance ! root conductance + real(r8) r_soil ! root spacing [m] + real(r8) root_biomass_density ! root biomass density [g/m3] + real(r8) root_cross_sec_area ! root cross sectional area [m2] + real(r8) root_length_density ! root length density [m/m3] + real(r8) croot_average_length ! average coarse root length [m] + real(r8) rs_resis ! combined soil-root resistance [s] + real(r8) cf ! s m**2/umol -> s/m + + real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] + real(r8), parameter :: c_to_b = 2.0_r8 ! (g biomass /g C) + real(r8), parameter :: rpi = 3.14159265358979_r8 + integer , parameter :: root = 4 + real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution + real(r8), parameter :: K_axs = 2.0e-1 + + ! temporary input + real(r8), parameter :: froot_carbon = 288.392056287006_r8 + real(r8), parameter :: root_radius = 2.9e-4_r8 + real(r8), parameter :: root_density = 310000._r8 + real(r8), parameter :: froot_leaf = 1.5_r8 + real(r8), parameter :: krmax = 3.981071705534969e-009_r8 + + real(r8),dimension(nvegwcs) :: x ! vegetation water potential + + integer j + +!----------------calculate root-soil interface conductance----------------- + DO j = 1,nl_soil + + ! calculate conversion from conductivity to conductance + root_biomass_density = c_to_b * froot_carbon * rootfr(j) / dz_soi(j) + ! ensure minimum root biomass (using 1gC/m2) + root_biomass_density = max(c_to_b*1._r8,root_biomass_density) + + ! Root length density: m root per m3 soil + root_cross_sec_area = rpi*root_radius**2 + root_length_density = root_biomass_density / (root_density * root_cross_sec_area) + + ! Root-area index (RAI) + rai(j) = (sai+laisun+laisha) * froot_leaf * rootfr(j) + + ! fix coarse root_average_length to specified length + croot_average_length = croot_lateral_length + + ! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) + r_soil = sqrt(1./(rpi*root_length_density)) + + ! length scale approach + soil_conductance = min(hksati(j),hk(j))/(1.e3*r_soil) + + ! USE vegetation plc function to adjust root conductance + fs(j)= plc(amax1(smp(j),-1._r8),psi50_root,ck) + + ! krmax is root conductance per area per length + root_conductance = (fs(j)*rai(j)*krmax)/(croot_average_length + z_soi(j)) + soil_conductance = max(soil_conductance, 1.e-16_r8) + root_conductance = max(root_conductance, 1.e-16_r8) + + ! sum resistances in soil and root + rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance + + ! conductance is inverse resistance + ! explicitly set conductance to zero for top soil layer + IF(rai(j)*rootfr(j) > 0._r8) THEN + k_soil_root(j) = 1._r8/rs_resis + ELSE + k_soil_root(j) = 0. + ENDIF + k_ax_root(j) = (rootfr(j)/(dz_soi(j)*1000))*K_axs*0.6 + ENDDO +!======================================================================= + + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + ! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] + ! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for + ! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tl " + gb_mol = 1./rb * cf ! resistance to conductance (s/m -> umol/m**2/s) + + x = vegwp(1:nvegwcs) + + CALL calcstress_twoleaf(x, nvegwcs, rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm, rhoair, & + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, & + kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, & + nl_soil, z_soi, rss, ra, rd, smp, k_soil_root, k_ax_root, gssun, gssha) + + vegwp(1:nvegwcs) = x + + END SUBROUTINE PlantHydraulicStress_twoleaf + + SUBROUTINE calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm,rhoair,& + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, kmax_sha, kmax_xyl, kmax_root, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, nl_soil, z_soi, rss, raw, rd, smp, & + k_soil_root, k_ax_root, gssun, gssha) + ! + ! DESCRIPTIONS + ! compute the transpiration stress using a plant hydraulics approach + ! calls spacF, spacA, and getvegwp + ! + ! !ARGUMENTS: + integer, intent(in) :: nvegwcs + real(r8), intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8), intent(out) :: rstfacsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(out) :: rstfacsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) + real(r8), intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) + real(r8), intent(out) :: rootflux(nl_soil) ! root water uptake from different layers + + integer, intent(in) :: nl_soil + real(r8), intent(in) :: z_soi(nl_soil) + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: gs0sun ! sunlit Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: gs0sha ! shaded Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density [kg/m**3] + real(r8), intent(in) :: psrf ! atmospheric pressure [Pa] + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8), intent(in) :: laisun ! Sunlit leaf area index + real(r8), intent(in) :: laisha ! Shaded leaf area index + real(r8), intent(in) :: sai ! stem area index + real(r8), intent(in) :: htop ! canopy top [m] + real(r8), intent(in) :: tl ! leaf temperature + real(r8), intent(in) :: kmax_sun + real(r8), intent(in) :: kmax_sha + real(r8), intent(in) :: kmax_xyl + real(r8), intent(in) :: kmax_root + real(r8), intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), intent(in) :: ck ! + real(r8), intent(in) :: smp(nl_soil) ! soil matrix potential + real(r8), intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] + real(r8), intent(out) :: gssun ! sunlit leaf conductance + real(r8), intent(out) :: gssha ! shaded leaf conductance + + + real(r8) :: wtl ! water conductance for leaf [m/s] + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f + real(r8) :: f(nvegwcs) ! flux divergence (mm/s) + real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] + real(r8) :: qflx_sun ! [kg/m2/s] + real(r8) :: qflx_sha ! [kg/m2/s] + real(r8) :: qeroot,dqeroot + real(r8),dimension(nl_soil) :: xroot ! local gs_mol copies + integer :: i,j ! index + real(r8) :: cf ! s m**2/umol -> s/m + integer :: iter,iterqflx ! newton's method iteration number + logical :: flag ! signal that matrix was not invertible + logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called + integer, parameter :: itmax=50 ! EXIT newton's method IF iters>itmax + real(r8),parameter :: toldx=1.e-9 !tolerances for a satisfactory solution + real(r8),parameter :: tolf = 1.e-6_r8 + real(r8),parameter :: tolf_leafxyl = 1.e-16_r8 + real(r8),parameter :: tolf_root = 1.e-14_r8 !tolerances for a satisfactory solution + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8) :: x_root_top + real(r8) :: x_root_top1 + real(r8) :: x_root_top2 + real(r8) :: dxsoiltop + real(r8) :: maxscale + real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai WHERE transpiration is calc'd + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + real(r8) fsto1,fsto2,fx,fr,grav1 + real(r8) tprcor + !------------------------------------------------------------------------------ + + !temporary flag for night time vegwp(sun)>0 + + gssun=gs0sun + gssha=gs0sha + CALL getqflx_gs2qflx_twoleaf(gb_mol,gssun,gssha,qflx_sun,qflx_sha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + x_root_top = x(root) + + IF(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)THEN + CALL getrootqflx_x2qe(nl_soil,smp,x_root_top ,z_soi,k_soil_root,k_ax_root,qeroot,dqeroot) + + CALL spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& + qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& + psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) + + IF ( maxval(abs(dx)) > 200000._r8) THEN + maxscale = min(maxval(abs(dx)),maxval(abs(x))) / 2 + dx = maxscale * dx / maxval(abs(dx))! * log(maxval(abs(dx))/maxscale) !rescale step to max of 50000 + ENDIF + + x=x+dx + + ! this is a catch to force spac gradient to atmosphere + IF ( x(xyl) > x(root) ) x(xyl) = x(root) + IF ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) + IF ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) + + ! compute attenuated flux; the actual transpiration + etrsun=qflx_sun*plc(x(leafsun),psi50_sun,ck) + etrsha=qflx_sha*plc(x(leafsha),psi50_sha,ck) + + ! retrieve stressed stomatal conductance + CALL getqflx_qflx2gs_twoleaf(gb_mol,gssun,gssha,etrsun,etrsha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + + tprcor = 44.6*273.16*psrf/1.013e5 + ! compute water stress + ! .. generally -> B= gs_stressed / gs_unstressed + ! .. when gs=0 -> B= plc( x ) + rstfacsun = amax1(gssun/gs0sun,1.e-2_r8) + rstfacsha = amax1(gssha/gs0sha,1.e-2_r8) + qeroot = etrsun + etrsha + CALL getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top + DO j = 1,nl_soil + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) + ENDDO + ELSE + IF ( x(xyl) > x(root) ) x(xyl) = x(root) + IF ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) + IF ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) + etrsun = 0._r8 + etrsha = 0._r8 + rstfacsun = amax1(plc(x(leafsun),psi50_sun,ck),1.e-2_r8) + rstfacsha = amax1(plc(x(leafsha),psi50_sha,ck),1.e-2_r8) + gssun = gs0sun * rstfacsun + gssha = gs0sha * rstfacsha + rootflux = 0._r8 + ENDIF + + soilflux = sum(rootflux(:)) + + END SUBROUTINE calcstress_twoleaf + + !------------------------------------------------------------------------------ + SUBROUTINE spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& + qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& + psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) +!----------------------------------------------------------------------- +! !DESCRIPTION +! Returns invA, the inverse matrix relating delta(vegwp) to f +! d(vegwp)=invA*f +! evaluated at vegwp(p) +! +! The methodology is currently hardcoded for linear algebra assuming the +! number of vegetation segments is four. Thus the matrix A and it's inverse +! invA are both 4x4 matrices. A more general method could be done using for +! example a LINPACK linear algebra solver. +! +!----------------------------------------------------------------------- +! !ARGUMENTS: + integer , intent(in) :: nvegwcs + real(r8), intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8), intent(out) :: dx(nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f + integer , intent(in) :: nl_soil + real(r8), intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8), intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8), intent(in) :: laisun ! Sunlit leaf area index + real(r8), intent(in) :: laisha ! Shaded leaf area index + real(r8), intent(in) :: sai ! Stem area index + real(r8), intent(in) :: htop ! Canopy top [m] + real(r8), intent(in) :: qeroot ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: dqeroot ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: kmax_sun + real(r8), intent(in) :: kmax_sha + real(r8), intent(in) :: kmax_xyl + real(r8), intent(in) :: kmax_root + real(r8), intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), intent(in) :: ck + ! + ! !LOCAL VARIABLES: + real(r8) wtl ! heat conductance for leaf [m/s] + real(r8) fsto1 ! sunlit transpiration reduction function [-] + real(r8) fsto2 ! shaded transpiration reduction function [-] + real(r8) fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) dfsto1 ! 1st derivative of fsto1 w.r.t. change in vegwp + real(r8) dfsto2 ! 1st derivative of fsto2 w.r.t. change in vegwp + real(r8) dfx ! 1st derivative of fx w.r.t. change in vegwp + real(r8) dfr ! 1st derivative of fr w.r.t. change in vegwp + real(r8) A11, A13, A22, A23, A31, A32, A33, A34, A43, A44 ! matrix relating vegwp to flux divergence f=A*d(vegwp) + real(r8) leading ! inverse of determiniant + real(r8) determ ! determinant of matrix + real(r8) grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) invfactor ! + real(r8) f(nvegwcs) + real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai WHERE transpiration is calc'd + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + integer :: j ! index + !------------------------------------------------------------------------------ + + grav1 = htop*1000._r8 + + !compute conductance attenuation for each segment + fsto1 = plc(x(leafsun),psi50_sun,ck) + fsto2 = plc(x(leafsha),psi50_sha,ck) + fx = plc(x(xyl),psi50_xyl,ck) + fr = plc(x(root),psi50_root,ck) + + !compute 1st deriv of conductance attenuation for each segment + dfsto1 = d1plc(x(leafsun),psi50_sun,ck) + dfsto2 = d1plc(x(leafsha),psi50_sha,ck) + dfx = d1plc(x(xyl),psi50_xyl,ck) + dfr = d1plc(x(root),psi50_root,ck) + + + A11 = - laisun * kmax_sun * fx - qflx_sun * dfsto1 + A13 = laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) + laisun * kmax_sun * fx + A22 = - laisha * kmax_sha * fx - qflx_sha * dfsto2 + A23 = laisha * kmax_sha * dfx * (x(xyl)-x(leafsha)) + laisha * kmax_sha * fx + A31 = laisun * kmax_sun * fx + A32 = laisha * kmax_sha * fx + A33 = - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx& + - laisha * kmax_sha * dfx * (x(xyl)-x(leafsha)) - laisha * kmax_sha * fx& + - sai * kmax_xyl / htop * fr + A34 = sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1) + sai * kmax_xyl / htop * fr + A43 = sai * kmax_xyl / htop * fr + A44 = - sai * kmax_xyl / htop * fr& + - sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1) + dqeroot + + !compute flux divergence across each plant segment + f(leafsun) = qflx_sun * fsto1 - laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) + f(leafsha) = qflx_sha * fsto2 - laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) + f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun))& + + laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) & + - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) + f(root) = sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - qeroot + + IF(qflx_sha > 0 )THEN + determ=A44*A22*A33*A11-A44*A22*A31*A13-A44*A32*A23*A11-A43*A11*A22*A34 + + IF(determ .ne. 0)THEN + dx(leafsun) = ((A22*A33*A44 - A22*A34*A43 - A23*A32*A44)*f(leafsun) + A13*A32*A44*f(leafsha) & + - A13*A22*A44*f(xyl) + A13*A22*A34*f(root)) / determ + dx(leafsha) = ( A23*A31*A44*f(leafsun) + (A11*A33*A44 - A11*A34*A43 - A13*A31*A44)*f(leafsha) & + - A11*A23*A44*f(xyl) + A11*A23*A34*f(root)) / determ + dx(xyl) = (-A22*A31*A44*f(leafsun) - A11*A32*A44*f(leafsha) & + + A11*A22*A44*f(xyl) - A11*A22*A34*f(root)) / determ + dx(root) = ( A22*A31*A43*f(leafsun) + A11*A32*A43*f(leafsha) & + - A11*A22*A43*f(xyl) +(A11*A22*A33 - A11*A23*A32 - A13*A22*A31)*f(root)) / determ + ELSE + dx = 0._r8 + ENDIF + ELSE + A33 = - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx - sai * kmax_xyl / htop * fr + f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) + determ=A11*A33*A44-A34*A11*A43-A13*A31*A44 + IF(determ .ne. 0)THEN + dx(leafsun) = (- A13*A44*f(xyl) + A13*A34*f(root) + (A33*A44 - A34*A43)*f(leafsun)) / determ + dx(xyl) = ( A11*A44*f(xyl) - A11*A34*f(root) - A31*A44*f(leafsun)) / determ + dx(root) = (- A11*A43*f(xyl) + (A11*A33 - A13*A31)*f(root) + A31*A43*f(leafsun)) / determ + + dx(leafsha) = x(leafsun) - x(leafsha) + dx(leafsun) + ELSE + dx = 0._r8 + ENDIF + ENDIF + + END SUBROUTINE spacAF_twoleaf + + SUBROUTINE getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol_sun, gs_mol_sha, & + qsatl, qaf,qg,qm,rhoair, psrf, fwet, laisun, laisha, htop, sai, tl, rss, & + raw, rd, smp, k_soil_root, k_ax_root, kmax_xyl, kmax_root, rstfacsun, rstfacsha, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, rootflux, etrsun, etrsha) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculates transpiration and returns corresponding vegwp in x +! +! !USES: +! calls getqflx +!----------------------------------------------------------------------- + USE MOD_Const_Physical, only: tfrz + IMPLICIT NONE + ! + ! !ARGUMENTS: + integer, intent(in) :: nvegwcs + real(r8), intent(out) :: x(nvegwcs) ! working copy of veg water potential for patch p + integer, intent(in) :: nl_soil ! number of soil layers + real(r8), intent(in) :: z_soi(nl_soil) ! node depth [m] + real(r8), intent(in) :: gb_mol ! Leaf boundary layer conductance [umol H2O/m**2/s] + real(r8), intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance [umol H2O/m**2/s] + real(r8), intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance [umol H2O/m**2/s] + real(r8), intent(in) :: qsatl ! Sunlit leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density [kg/m**3] + real(r8), intent(in) :: psrf ! atmospheric pressure [Pa] + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: laisun ! Sunlit leaf area index + real(r8), intent(in) :: laisha ! Shaded leaf area index + real(r8), intent(in) :: htop ! canopy top [m] + real(r8), intent(in) :: sai ! stem area index + real(r8), intent(in) :: tl ! leaf temperature + real(r8), intent(in) :: kmax_xyl + real(r8), intent(in) :: kmax_root + real(r8), intent(in) :: rstfacsun + real(r8), intent(in) :: rstfacsha + real(r8), intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), intent(in) :: ck ! + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8), intent(in) :: smp(nl_soil) ! soil matrix potential + real(r8), intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] + real(r8), intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) + real(r8), intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) + real(r8), intent(out) :: rootflux(nl_soil) ! root water uptake from different layers + ! + ! !LOCAL VARIABLES: +! real(r8) qflx_sun ! Sunlit leaf transpiration [kg/m2/s] +! real(r8) qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) qeroot + real(r8) dummy + real(r8) fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) x_root_top + real(r8) xroot(nl_soil) + real(r8) grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) grav2(nl_soil) ! soil layer gravitational potential relative to surface (mm H2O) + integer j ! index + logical havegs ! signals direction of calculation gs->qflx or qflx->gs + logical haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + real(r8) :: soilflux ! total soil column transpiration [mm/s] + + !---------------------------------------------------------------------- + grav1 = 1000._r8 * htop + grav2(1:nl_soil) = 1000._r8 * z_soi(1:nl_soil) + + !compute transpiration demand + havegs=.true. + CALL getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,etrsun,etrsha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) + + !calculate root water potential + qeroot = etrsun + etrsha + + CALL getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top + + !calculate xylem water potential + fr = plc(x(root),psi50_root,ck) + x(xyl) = x(root) - grav1 - (etrsun+etrsha)/(fr*kmax_root/htop*sai) + + !calculate sun/sha leaf water potential + fx = plc(x(xyl),psi50_xyl,ck) + x(leafsha) = x(xyl) - (etrsha/(fx*kmax_xyl*laisha)) + x(leafsun) = x(xyl) - (etrsun/(fx*kmax_xyl*laisun)) + + + !calculate soil flux + DO j = 1,nl_soil + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) + ENDDO + + soilflux = sum(rootflux(:)) + + END SUBROUTINE getvegwp_twoleaf + + SUBROUTINE getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL +! +!----------------------------------------------------------------------- + IMPLICIT NONE + + ! !ARGUMENTS: + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8), intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density (kg/m**3) + real(r8), intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8), intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8), intent(in) :: laisha ! shaded leaf area index (m2/m2) + real(r8), intent(in) :: sai ! stem area index (m2/m2) + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: tl ! shaded leaf temperature + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8),optional, intent(in) :: rstfacsun + real(r8),optional, intent(in) :: rstfacsha + + ! + ! !LOCAL VARIABLES: + real(r8) cf ! (umol/m**3) r = cf./g gmol(umol/m**2/s) -> r(s/m) + real(r8) tprcor ! tf*psur*100./1.013e5 + + real(r8) wtaq0 ! normalized latent heat conductance for air [-] + real(r8) wtgq0 ! normalized latent heat conductance for ground [-] + real(r8) wtlq0 ! normalized latent heat cond. for air and sunlit leaf [-] + real(r8) wtsqi ! latent heat resistance for air, grd and leaf [-] + + real(r8) delta + real(r8) caw ! latent heat conductance for air [m/s] + real(r8) cgw ! latent heat conductance for ground [m/s] + real(r8) cfw ! latent heat conductance for leaf [m/s] + + !---------------------------------------------------------------------- + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet)) * (laisun+laisha+sai)*gb_mol/cf + (1.-fwet)*delta*& + (laisun/(1._r8/gb_mol+1._r8/gs_mol_sun)/cf+laisha/(1._r8/gb_mol+1._r8/gs_mol_sha)/cf) + wtsqi = 1. / ( caw + cgw + cfw ) + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi + + qflx_sun = rhoair * (1.-fwet) * delta & + * laisun / (1./gb_mol+1./gs_mol_sun)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! IF(qflx_sun < 1.e-7_r8)THEN +! qflx_sun = 0._r8 +! ENDIF + IF(present(rstfacsun))THEN + IF(rstfacsun .le. 1.e-2)qflx_sun = 0._r8 + ENDIF + qflx_sha = rhoair * (1.-fwet) * delta & + * laisha / (1./gb_mol+1./gs_mol_sha)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! IF(qflx_sha < 1.e-7)THEN +! qflx_sha = 0._r8 +! ENDIF + IF(present(rstfacsha))THEN + IF(rstfacsha .le. 1.e-2)qflx_sha = 0._r8 + ENDIF + + END SUBROUTINE getqflx_gs2qflx_twoleaf + + SUBROUTINE getqflx_qflx2gs_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL +!----------------------------------------------------------------------- + IMPLICIT NONE + + ! !ARGUMENTS: + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8), intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density (kg/m**3) + real(r8), intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8), intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8), intent(in) :: laisha ! shaded leaf area index (m2/m2) + real(r8), intent(in) :: sai ! stem area index (m2/m2) + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: tl ! leaf temperature + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + + ! + ! !LOCAL VARIABLES: + real(r8) wtlsun ! heat conductance for sunlit leaf boundary [m/s] + real(r8) wtlsha ! heat conductance for shaded leaf boundary [m/s] + real(r8) cf ! s m**2/umol -> s/m + real(r8) tprcor !tf*psur*100./1.013e5 + + real(r8) wtaq0 ! normalized latent heat conductance for air [-] + real(r8) wtgq0 ! normalized latent heat conductance for ground [-] + real(r8) wtlsunq0 ! normalized latent heat cond. for air and sunlit leaf [-] + real(r8) wtlshaq0 ! normalized latent heat cond. for air and shaded leaf [-] + + real(r8) delta + real(r8) caw ! latent heat conductance for air [m/s] + real(r8) cgw ! latent heat conductance for ground [m/s] + real(r8) cwet ! latent heat conductance for wet leaf [m/s] + real(r8) csunw_dry ! latent heat conductance for sunlit dry leaf [m/s] + real(r8) cshaw_dry ! latent heat conductance for shaded dry leaf [m/s] + real(r8) cqi_wet ! latent heat conductance for air, grd and wet leaf [-] + real(r8) cqi_leaf ! (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg [m/s] + real(r8) A1,B1,C1,A2,B2,C2 ! in binary quadratic equations + + !---------------------------------------------------------------------- + IF(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)THEN + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cwet = (1.-delta*(1.-fwet)) * (laisun + laisha + sai) * gb_mol / cf + cqi_wet = caw + cgw + cwet + cqi_leaf = caw * (qsatl - qm) + cgw * (qsatl - qg) + + ! Solve equations: + ! A1 * csunw_dry + B1 * cfshaw_dry = C1 + ! A2 * csunw_dry + B2 * cfshaw_dry = C2 + + A1 = cqi_leaf - qflx_sun / rhoair + B1 = - qflx_sun / rhoair + C1 = qflx_sun * cqi_wet / rhoair + A2 = - qflx_sha / rhoair + B2 = cqi_leaf - qflx_sha / rhoair + C2 = qflx_sha * cqi_wet / rhoair + + csunw_dry = (B1*C2 - B2*C1)/(B1*A2 - B2*A1) + cshaw_dry = (A1*C2 - A2*C1)/(A1*B2 - B1*A2) + + IF (qflx_sun > 0._r8) THEN + gs_mol_sun = 1._r8 / ((1. - fwet) * delta * laisun / csunw_dry / cf - 1._r8 / gb_mol) + ENDIF + IF (qflx_sha > 0._r8) THEN + gs_mol_sha = 1._r8 / ((1. - fwet) * delta * laisha / cshaw_dry / cf - 1._r8 / gb_mol) + ENDIF + ENDIF + + END SUBROUTINE getqflx_qflx2gs_twoleaf + + SUBROUTINE getrootqflx_x2qe(nl_soil,smp,x_root_top,z_soisno,krad,kax,qeroot,dqeroot) + + USE MOD_Utils +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return root water potential at top soil node. Return soil-root water flux. +! +!----------------------------------------------------------------------- + + integer , intent(in) :: nl_soil + real(r8), intent(in) :: smp (nl_soil) + real(r8), intent(in) :: x_root_top + real(r8), intent(in) :: z_soisno (nl_soil) + real(r8), intent(in) :: krad (nl_soil) + real(r8), intent(in) :: kax (nl_soil) + real(r8), intent(out) :: qeroot + real(r8), intent(out) :: dqeroot + +! Local variables + real(r8) den_AHR,den1,den2 ! used in calculating HR(Amenu model) + real(r8) amx_hr(nl_soil-1) ! "a" left off diagonal of tridiagonal matrix + real(r8) bmx_hr(nl_soil-1) ! "b" diagonal column for tridiagonal matrix + real(r8) cmx_hr(nl_soil-1) ! "c" right off diagonal tridiagonal matrix + real(r8) rmx_hr(nl_soil-1) ! "r" forcing term of tridiagonal matrix + real(r8) drmx_hr(nl_soil-1) ! "dr" forcing term of tridiagonal matrix for d/dxroot(1) + real(r8) x(nl_soil-1) ! root water potential from layer 2 to nl_soil + real(r8) dx(nl_soil-1) ! derivate of root water potential from layer 2 to nl_soil (dxroot(:)/dxroot(1)) + real(r8) xroot(nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) zmm(1:nl_soil) ! layer depth [mm] + real(r8) qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) dxroot2 ! dxroot(2)/dxroot(1) + integer j + + ! Because the depths in this routine are in mm, USE local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + ENDDO + + xroot(1) = x_root_top + zmm(1) + ! For the 2nd soil layer + j = 2 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr(j-1) = 0 + bmx_hr(j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr(j-1) = -kax(j)/den2 + rmx_hr(j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + kax(j-1)/den1*xroot(1) + drmx_hr(j-1) = kax(j-1)/den1 + + ! For the middile soil layers + DO j = 3, nl_soil - 1 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr (j-1) = -kax(j-1)/den1 + bmx_hr (j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr (j-1) = -kax(j)/den2 + rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + drmx_hr(j-1) = 0._r8 + ENDDO + + ! For the bottom soil layer + j = nl_soil + den_AHR = zmm(j) - zmm(j-1) + amx_hr (j-1) = -kax(j-1)/den_AHR + bmx_hr (j-1) = kax(j-1)/den_AHR + krad(j) + cmx_hr (j-1) = 0 + rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) + drmx_hr(j-1) = 0._r8 + + ! Solve for root pressure potential using tridiagonal matric solver x = A^-1 * r + CALL tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) + + DO j = 2,nl_soil + xroot(j) = x(j-1) + ENDDO + + ! Solve the dx(:)/dxroot(1) = A^-1 * dr + CALL tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,drmx_hr, dx) + + dxroot2 = dx(1) + + ! calculate the water flux + j = 1 + den2 = zmm(j+1) - zmm(j) + qeroot = krad(j) * (smp(1) - xroot(1)) + (xroot(2) - xroot(1)) * kax(j)/den2 - kax(j) + + ! calculate the dqeroot/dx_root_top; + dqeroot = - krad(j) + (dxroot2 - 1) * kax(j)/den2 + DO j = 1,nl_soil + qeroot_nl(j) = krad(j)*(smp(j) - xroot(j)) + ENDDO + + END SUBROUTINE getrootqflx_x2qe + + SUBROUTINE getrootqflx_qe2x(nl_soil,smp,z_soisno,krad,kax,qeroot,xroot,x_root_top) + + USE MOD_Utils +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return root water potential at top soil node. Return soil-root water flux. +!----------------------------------------------------------------------- + + integer, intent(in) :: nl_soil + real(r8), intent(in) :: smp (nl_soil) + real(r8), intent(in) :: z_soisno (nl_soil) + real(r8), intent(in) :: krad (nl_soil) + real(r8), intent(in) :: kax (nl_soil) + real(r8), intent(in) :: qeroot + real(r8), intent(out) :: xroot (nl_soil) + real(r8), intent(out) :: x_root_top + +! Local variables + real(r8) den_AHR,den1,den2 ! used in calculating HR(Amenu model) + real(r8) amx_hr(nl_soil) ! "a" left off diagonal of tridiagonal matrix + real(r8) bmx_hr(nl_soil) ! "b" diagonal column for tridiagonal matrix + real(r8) cmx_hr(nl_soil) ! "c" right off diagonal tridiagonal matrix + real(r8) rmx_hr(nl_soil) ! "r" forcing term of tridiagonal matrix + real(r8) x(nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) zmm(1:nl_soil) ! layer depth [mm] + real(r8) qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil + integer j + + ! Because the depths in this routine are in mm, USE local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + ENDDO + + j = 1 + den2 = zmm(j+1) - zmm(j) + amx_hr(j) = 0 + bmx_hr(j) = kax(j)/den2 + krad(j) + cmx_hr(j) = -kax(j)/den2 + rmx_hr(j) = krad(j)*smp(j) - qeroot - kax(j) + + ! For the middile soil layers + DO j = 2, nl_soil - 1 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr(j) = -kax(j-1)/den1 + bmx_hr(j) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr(j) = -kax(j)/den2 + rmx_hr(j) = krad(j)*smp(j) + kax(j-1) - kax(j) + ENDDO + + ! For the bottom soil layer + j = nl_soil + den_AHR = zmm(j) - zmm(j-1) + amx_hr(j) = -kax(j-1)/den_AHR + bmx_hr(j) = kax(j-1)/den_AHR + krad(j) + cmx_hr(j) = 0 + rmx_hr(j) = krad(j)*smp(j) + kax(j-1) + + ! Solve for root pressure potential using tridiagonal matric solver + CALL tridia (nl_soil ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) + + xroot(1:nl_soil) = x(1:nl_soil) + x_root_top = xroot(1) - zmm(1) + + END SUBROUTINE getrootqflx_qe2x + + FUNCTION plc(x,psi50,ck) +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return value of vulnerability curve at x +! +!----------------------------------------------------------------------- + +! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input +! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) +! integer , intent(in) :: plc_method ! + real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + real(r8) :: plc ! attenuated conductance [0:1] 0=no flow + ! + ! !PARAMETERS +! integer , parameter :: vegetation_weibull=0 ! case number +! integer , parameter :: leafsun = 1 ! index for sunlit leaf +! integer , parameter :: leafsha = 2 ! index for shaded leaf +! integer , parameter :: xyl = 3 ! index for xylem +! integer , parameter :: root = 4 ! index for root + + ! !LOCAL VARIABLES + !real(r8) psi50,tmp + real(r8) tmp + integer i + + !------------------------------------------------------------------------------ +! select CASE(level) +! CASE (leafsun) +! psi50 = psi50_sun +! CASE (leafsha) +! psi50 = psi50_sha +! CASE (xyl) +! psi50 = psi50_xyl +! CASE (root) +! psi50 = psi50_root +! CASE default +! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' +! END select + +! select CASE (plc_method) + !possible to add other methods later +! CASE (vegetation_weibull) + tmp = amax1(-(x/psi50)**ck,-500._r8) +! IF(tmp .lt. -500._r8)THEN +! plc = 0._r8 +! ELSE + plc=2._r8**tmp +! ENDIF + IF ( plc < 0.00001_r8) plc = 1.e-5_r8 +! CASE default +! write(*,*),'must choose plc method' +! END select + + END FUNCTION plc + !-------------------------------------------------------------------------------- + + FUNCTION d1plc(x,psi50,ck) +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return 1st derivative of vulnerability curve at x +!----------------------------------------------------------------------- + +! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input +! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) +! integer , intent(in) :: plc_method ! 0 for vegetation, 1 for soil + real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + real(r8) :: d1plc ! first deriv of plc curve at x + ! + ! !PARAMETERS +! integer , parameter :: vegetation_weibull=0 ! CASE number +! integer , parameter :: leafsun = 1 ! index for sunlit leaf +! integer , parameter :: leafsha = 2 ! index for shaded leaf +! integer , parameter :: xyl = 3 ! index for xylem +! integer , parameter :: root = 4 ! index for root + + ! !LOCAL VARIABLES +! real(r8) psi50,tmp + real(r8) tmp + !------------------------------------------------------------------------------ +! select CASE(level) +! CASE (leafsun) +! psi50 = psi50_sun +! CASE (leafsha) +! psi50 = psi50_sha +! CASE (xyl) +! psi50 = psi50_xyl +! CASE (root) +! psi50 = psi50_root +! CASE default +! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' +! END select + +! select CASE (plc_method) + !possible to add other methods later +! CASE (vegetation_weibull) + tmp = amax1(-(x/psi50)**ck,-500._r8) +! IF(tmp .lt. -500._r8)THEN +! d1plc = 0._r8 +! ELSE + d1plc= ck * log(2._r8) * (2._r8**tmp) * tmp / x +! ENDIF +! CASE default +! write(*,*),'must choose plc method' +! END select + + END FUNCTION d1plc + + +END MODULE MOD_PlantHydraulic +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 new file mode 100644 index 0000000000..efc004e67c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 @@ -0,0 +1,108 @@ +MODULE MOD_Qsadv + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: qsadv + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE qsadv(T,p,es,esdT,qs,qsdT) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! Description: computes saturation mixing ratio and change in saturation +! mixing ratio with respect to temperature +! +! Reference: polynomial approximations from: +! Piotr J. Flatau,et al,1992: polynomial fits to saturation +! vapor pressure. Journal of Applied meteorology,31,1507-1513. +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: T ! temperature (K) + real(r8), intent(in) :: p ! surface atmospheric pressure (pa) + + real(r8), intent(out) :: es ! vapor pressure (pa) + real(r8), intent(out) :: esdT ! d(es)/d(T) + real(r8), intent(out) :: qs ! humidity (kg/kg) + real(r8), intent(out) :: qsdT ! d(qs)/d(T) + +!-------------------------- Local Variables ---------------------------- + real(r8) td,vp,vp1,vp2 + real(r8) a0,a1,a2,a3,a4,a5,a6,a7,a8 + real(r8) b0,b1,b2,b3,b4,b5,b6,b7,b8 + + real(r8) c0,c1,c2,c3,c4,c5,c6,c7,c8 + real(r8) d0,d1,d2,d3,d4,d5,d6,d7,d8 + +! for water vapor (temperature range 0C-100C) + data a0/6.11213476 /,a1/ 0.444007856 /,a2/0.143064234e-01/ & + ,a3/0.264461437e-03/,a4/ 0.305903558e-05/,a5/0.196237241e-07/ & + ,a6/0.892344772e-10/,a7/-0.373208410e-12/,a8/0.209339997e-15/ + +! for derivative:water vapor + data b0/0.444017302 /,b1/ 0.286064092e-01/,b2/ 0.794683137e-03/ & + ,b3/ 0.121211669e-04/,b4/ 0.103354611e-06/,b5/ 0.404125005e-09/ & + ,b6/-0.788037859e-12/,b7/-0.114596802e-13/,b8/ 0.381294516e-16/ + +! for ice (temperature range -75C-0C) + data c0/6.11123516 /,c1/0.503109514 /,c2/0.188369801e-01/ & + ,c3/0.420547422e-03/,c4/0.614396778e-05/,c5/0.602780717e-07/ & + ,c6/0.387940929e-09/,c7/0.149436277e-11/,c8/0.262655803e-14/ + +! for derivative:ice + data d0/0.503277922 /,d1/0.377289173e-01/,d2/0.126801703e-02/ & + ,d3/0.249468427e-04/,d4/0.313703411e-06/,d5/0.257180651e-08/ & + ,d6/0.133268878e-10/,d7/0.394116744e-13/,d8/0.498070196e-16/ + +!----------------------------------------------------------------------- + + td = T-273.16 + +! IF (td < -75.0 .or. td > 75.0) THEN + !* print *, "qsadv: abnormal temperature", T +! ENDIF + + IF (td < -75.0) td = -75.0 + IF (td > 75.0) td = 75.0 + + IF (td >= 0.0)THEN + es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + ELSE + es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + ENDIF + + es = es * 100. ! pa + esdT = esdT * 100. ! pa/K + + vp = 1.0 / (p - 0.378*es) + vp1 = 0.622 * vp + vp2 = vp1 * vp + + qs = es * vp1 ! kg/kg + qsdT = esdT * vp2 * p ! 1 / K + + END SUBROUTINE qsadv + +END MODULE MOD_Qsadv +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 new file mode 100644 index 0000000000..b47a49573e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 @@ -0,0 +1,308 @@ +#include + +MODULE MOD_RainSnowTemp + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: rain_snow_temp + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE rain_snow_temp (patchtype,& + forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,tcrit,& + prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) + +!======================================================================= +! define the rate of rainfall and snowfall and precipitation water temp +! Original author: Yongjiu Dai, 09/1999; 08/31/2002, 04/2014, 01/2023 +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + USE MOD_WetBulb + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: patchtype ! land patch type (3=glaciers) + + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + real(r8), intent(in) :: forc_prc ! convective precipitation [mm/s] + real(r8), intent(in) :: forc_prl ! large scale precipitation [mm/s] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] + + real(r8), intent(in) :: tcrit ! critical temp. to determine rain or snow + + real(r8), intent(out) :: prc_rain ! convective rainfall [kg/(m2 s)] + real(r8), intent(out) :: prc_snow ! convective snowfall [kg/(m2 s)] + real(r8), intent(out) :: prl_rain ! large scale rainfall [kg/(m2 s)] + real(r8), intent(out) :: prl_snow ! large scale snowfall [kg/(m2 s)] + real(r8), intent(out) :: t_precip ! snowfall/rainfall temperature [kelvin] + real(r8), intent(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: flfall ! fraction of liquid water within falling precip. + + real(r8) :: all_snow_t ! temperature at which all precip falls entirely as snow (K) + real(r8) :: frac_rain_slope ! slope of the frac_rain vs. temperature relationship + real(r8) :: all_snow_t_c ! Temperature at which precip falls entirely as rain (deg C) + real(r8) :: all_rain_t_c ! Temperature at which precip falls entirely as snow (deg C) + + logical :: glaciers ! true: glacier column + real(r8) :: t_for_bifall_degC ! temperature to USE in bifall equation (deg C) + real(r8) :: forc_wind ! wind speed [m/s] + real(r8) :: t_hydro ! temperature of falling hydrometeor [deg C] +!----------------------------------------------------------------------- + +! wet-bulb temperature + CALL wetbulb(forc_t,forc_psrf,forc_q,t_precip) + + IF (trim(DEF_precip_phase_discrimination_scheme) == 'I') THEN + ! Wang, Y.H., Broxton, P., Fang, Y., Behrangi, A., Barlage, M., Zeng, X., & Niu, G.Y. (2019). + ! A Wet-Bulb Temperature Based Rain-Snow Partitioning Scheme Improves Snowpack Prediction + ! Over the Drier Western United States. Geophysical Research Letters, 46, 13,825-13,835. + ! + ! Behrangi et al. (2018) On distinguishing snowfall from rainfall + ! using near-surface atmospheric information: Comparative analysis, + ! uncertainties and hydrologic importance. Q J R Meteorol Soc. 144 (Suppl. 1):89-102 + + IF(t_precip - tfrz > 3.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip + ELSEIF (t_precip - tfrz >= -2.0)THEN + !Figure 5c of Behrangi et al. (2018) + flfall = max(0.0, 1.0 - 1.0/(1.0+5.00e-5*exp(2.0*(t_precip-tfrz+4.)))) + !Equation 1 of Wang et al. (2019) + !* flfall = max(0.0, 1.0 - 1.0/(1.0+6.99e-5*exp(2.0*(t_precip-tfrz+3.97)))) + ELSE + flfall = 0.0 + ENDIF + + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'II') THEN + glaciers = .false. + IF (patchtype == 3) glaciers = .true. + + IF(glaciers) THEN + all_snow_t_c = -2.0 + all_rain_t_c = 0.0 + ELSE + all_snow_t_c = 0.0 + all_rain_t_c = 2.0 + ENDIF + + all_snow_t = all_snow_t_c + tfrz + frac_rain_slope = 1._r8 / (all_rain_t_c - all_snow_t_c) + + ! Re-partition precipitation into rain/snow for a single column. + ! Rain and snow variables should be set initially, and are updated here + + flfall = min(1.0_r8, max(0.0_r8,(forc_t - all_snow_t)*frac_rain_slope)) + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'III') THEN + ! Phillip Harder and John Pomeroy (2013) + ! Estimating precipitation phase using a psychrometric energy + ! balance method . Hydrol Process, 27, 1901-1914 + ! Hydromet_Temp [K] + CALL hydromet_temp(forc_psrf,(forc_t-273.15),forc_q,t_hydro) + + IF(t_hydro > 3.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip + ELSEIF ((t_hydro >= -3.0).and.(t_hydro <= 3.0))THEN + flfall = max(0.0, 1.0/(1.0+2.50286*0.125006**t_hydro)) + ELSE + flfall = 0.0 + ENDIF + + ELSE + ! the upper limit of air temperature is set for snowfall, this cut-off + ! was selected based on Fig. 1, Plate 3-1, of Snow Hydrology (1956). + ! the percentage of liquid water by mass, which is arbitrarily set to + ! vary linearly with air temp, from 0% at 273.16 to 40% max at 275.16. + + IF(forc_t>tfrz+2.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip. + ELSE + flfall = max(0.0, -54.632+0.2*forc_t) + ENDIF + + ENDIF + + ! new scheme for "bifall" from CLM5.0 + CALL NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) + + prc_rain = forc_prc*flfall ! convective rainfall (mm/s) + prl_rain = forc_prl*flfall ! large scale rainfall (mm/s) + prc_snow = forc_prc*(1.-flfall) ! convective snowfall (mm/s) + prl_snow = forc_prl*(1.-flfall) ! large scale snowfall (mm/s) + + ! ------------------------------------------------------------- + ! temperature of rainfall or snowfall + ! ------------------------------------------------------------- + + IF (forc_t > 275.65) THEN + IF (t_precip < tfrz) t_precip = tfrz + ELSE + t_precip = min(tfrz,t_precip) + IF(flfall > 1.e-6)THEN + t_precip = tfrz - sqrt((1.0/flfall)-1.0)/100.0 + ENDIF + ENDIF + + END SUBROUTINE rain_snow_temp + + + SUBROUTINE NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) +!======================================================================= +! Scheme for bulk density of newly fallen dry snow +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] + + real(r8), intent(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + real(r8) :: t_for_bifall_degC ! temperature to USE in bifall equation (deg C) + real(r8) :: forc_wind ! wind speed [m/s] + + !----------------------------------------------------------------------- + + IF (forc_t > tfrz + 2.0) THEN + bifall = 50.0 + 1.7*(17.0)**1.5 + ELSEIF (forc_t > tfrz - 15.0) THEN + bifall = 50.0 + 1.7*(forc_t - tfrz + 15.0)**1.5 + ELSE + ! Andrew Slater: A temp of about -15C gives the nicest + ! "blower" powder, but as you get colder the flake size decreases so + ! density goes up. e.g. the smaller snow crystals from the Arctic and Antarctic winters + IF (forc_t > tfrz - 57.55) THEN + t_for_bifall_degC = (forc_t-tfrz) + ELSE + ! Below -57.55 deg C, the following function starts to decrease with + ! decreasing temperatures. Limit the function to avoid this turning over. + t_for_bifall_degC = -57.55 + ENDIF + bifall = -(50.0/15.0 + 0.0333*15.0)*t_for_bifall_degC - 0.0333*t_for_bifall_degC**2 + ENDIF + + forc_wind = sqrt(forc_us**2 + forc_vs**2) + IF (forc_wind > 0.1) THEN + ! Density offset for wind-driven compaction, initial ideas based on Liston et. al (2007) J. + ! Glaciology, 53(181), 241-255. Modified for a continuous wind impact and slightly more + ! sensitive to wind - Andrew Slater, 2016 + bifall = bifall + (266.861 * ((1.0 + TANH(forc_wind/5.0))/2.0)**8.8) + ENDIF + + END SUBROUTINE NewSnowBulkDensity + + !!============================================== + + SUBROUTINE hydromet_temp(ppa, pta, pqa, pti) +!----------------------------------------------------------------------------- +! !DESCRIPTION +! Computes the temperature of a falling hydrometeor based on Harder, P., Pomeroy, J. (2013). +! +! Original Author: +! ---------------- +! V. Vionnet (11/2020) +! +! !REFERENCES: +! Harder, P., Pomeroy, J. (2013). +! Estimating precipitation phase using a psychrometric energy balance method +! Hydrological Processes 27(13), 1901-1914. https://dx.doi.org/10.1002/hyp.9799 + +! !REVISIONS: +! 2023.07.30 Aobo Tan & Zhongwang Wei @ SYSU +! +!----------------------------------------------------------------------------- + + real(r8), intent(in) :: ppa ! Air pressure (Pa) + real(r8), intent(in) :: pta ! Air temperature (deg C) + real(r8), intent(in) :: pqa ! Air specific humidity (kg/kg) + real(r8), intent(out) :: pti ! Hydrometeor temperature in deg C + + real(r8) :: zd ! Diffusivity of water vapour in air [m^2 s^-1] + real(r8) :: zlambda ! Thermal conductivity of air [J m^-1 s^-1 K^-1] + real(r8) :: zl ! Latent heat of sublimation or vaporization [J kg^-1] + real(r8) :: zrhoda ! Density of dry air [kg m^-3] + real(r8) :: zrh ! Relative humidity [-] + real(r8) :: rho_vast_diff, esat, rho_vast + real(r8) :: zt, ztint, zf, zfdiff, evsat + integer :: JITER + integer :: JJ, I, NN + + ! 1. Compute diffusivity of water vapour in air [m^2 s^-1] (Thorpe and Mason, 1966) + zd = 2.063e-5 * ((pta + 273.15) / 273.15) ** 1.75 + + ! 2. Compute thermal conductivity of air [J m^-1 s^-1 K^-1] + zlambda = 0.000063 * (pta + 273.15) + 0.00673 + + ! 3. Compute latent heat of sublimation or vaporization (depending on air temperature) + IF (pta < 0.) THEN + zl = 1000.0 * (2834.1 - 0.29 * pta - 0.004 * pta ** 2.) + + ELSE + zl = 1000.0 * (2501.0 - (2.361 * pta)) + ENDIF + + ! 4. Compute density of dry air [kg m^-3] + zrhoda = ppa / (287.04 * (pta + 273.15)) + + ! 5. Compute saturated water vapour pressure [Pa] + IF (pta > 0) THEN + evsat = 611.0 * EXP(17.27 * pta / (pta + 237.3)) + ELSE + evsat = 611.0 * EXP(21.87 * pta / (pta + 265.5)) + ENDIF + + ! 6. Solve iteratively to get Ti in Harder and Pomeroy (2013) using a Newton-Raphson approach + ! Set the first guess to pta + zt = pta + + ! Loop until convergence + DO JITER = 1, 10 + ztint = zt + + IF (zt > 0) THEN + esat = 611.0 * EXP(17.27 * zt / (zt + 237.3)) + ELSE + esat = 611.0 * EXP(21.87 * zt / (zt + 265.5)) + ENDIF + + rho_vast = esat / (461.5 * (zt + 273.15)) ! Saturated water vapour density + + zf = zt - pta - zd * zl / zlambda * (pqa * zrhoda - rho_vast) + + IF (zt > 0) THEN + rho_vast_diff = 611.0 / (461.5 * (zt + 273.15)) * EXP(17.27 * zt / (zt + 237.3)) * & + (-1 / (zt + 273.15) + 17.27 * 237.3 / ((zt + 237.3) ** 2.)) + ELSE + rho_vast_diff = 611.0 / (461.5 * (zt + 273.15)) * EXP(21.87 * zt / (zt + 265.5)) * & + (-1 / (zt + 273.15) + 21.87 * 265.5 / ((zt + 265.5) ** 2.)) + ENDIF + + zfdiff = 1 + zd * zl / zlambda * rho_vast_diff + zt = ztint - zf / zfdiff + IF (ABS(zt - ztint) .lt. 0.01) EXIT + ENDDO + + pti = zt + + END SUBROUTINE hydromet_temp + +END MODULE MOD_RainSnowTemp diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 new file mode 100644 index 0000000000..32c623c28d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 @@ -0,0 +1,440 @@ +#include + +MODULE MOD_Runoff + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SurfaceRunoff_TOPMOD + PUBLIC :: SubsurfaceRunoff_TOPMOD + PUBLIC :: Runoff_XinAnJiang + PUBLIC :: Runoff_SimpleVIC + PUBLIC :: SubsurfaceRunoff_SimpleVIC + + +!----------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,& + fsatmax,fsatdcf,& + z_soisno,dz_soisno,zi_soisno,& + eff_porosity,icefrac,zwt,gwat,& + rsur,rsur_se,rsur_ie,& + topoweti,alp_twi,chi_twi,mu_twi,frcsat,eta_out) + +!======================================================================= +! the original code was provide by Robert E. Dickinson based on +! following clues: a water table level determination level added +! including highland and lowland levels and fractional area of wetland +! (water table above the surface. Runoff is parametrized from the +! lowlands in terms of precip incident on wet areas and a base flow, +! where these are estimated using ideas from TOPMODEL. +! +! Author : Yongjiu Dai, 07/29/2002, Guoyue Niu, 06/2012 +!======================================================================= + + USE MOD_Namelist, only: DEF_TOPMOD_method + USE MOD_IncompleteGamma, only: GRATIO + USE MOD_SPMD_Task + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: nl_soil ! number of soil layers + real(r8), intent(in) :: & + ! wtfact, &! (updated to gridded 'fsatmax' data) + ! fraction of model area with high water table + wimp, &! water impermeable if porosity less than wimp + porsl(1:nl_soil), &! saturated volumetric soil water content(porosity) + psi0(1:nl_soil), &! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil), &! hydraulic conductivity at saturation (mm h2o/s) + fsatmax, &! maximum fraction of saturation area [-] + fsatdcf, &! decay factor in calc of fraction of saturation area [1/m] + z_soisno(1:nl_soil), &! layer depth (m) + dz_soisno(1:nl_soil), &! layer thickness (m) + zi_soisno(0:nl_soil), &! interface level below a "z" level (m) + eff_porosity(1:nl_soil), &! effective porosity = porosity - vol_ice + icefrac(1:nl_soil), &! ice fraction (-) + gwat, &! net water input from top + zwt ! the depth from ground (soil) surface to water table [m] + + real(r8), intent(out) :: rsur ! surface runoff (mm h2o/s) + real(r8), intent(out), optional :: rsur_se! saturation excess surface runoff (mm h2o/s) + real(r8), intent(out), optional :: rsur_ie! infiltration excess surface runoff (mm h2o/s) + + real(r8), intent(in), optional :: topoweti + real(r8), intent(in), optional :: alp_twi, chi_twi, mu_twi + real(r8), intent(out), optional :: frcsat + real(r8), intent(out), optional :: eta_out + +!-------------------------- Local Variables ---------------------------- + + real(r8), parameter :: vdcf = 2.0 + + real(r8) qinmax ! maximum infiltration capability + real(r8) fsat ! fractional area with water table at surface + + real(r8) eta, pgr0, pgr1, qgr, gfun + integer niter + + ! updated to gridded 'fsatdcf' (by Shupeng Zhang) + ! real(r8), parameter :: fff = 0.5 ! runoff decay factor (m-1) + +!----------------------------------------------------------------------- + +! fraction of saturated area (updated to gridded 'fsatmax' and 'fsatdcf') + !fsat = wtfact*min(1.0,exp(-0.5*fff*zwt)) + IF ((DEF_TOPMOD_method == 0) .or. (DEF_TOPMOD_method == 1)) THEN + + fsat = fsatmax * exp(- fsatdcf * vdcf * zwt) + + ELSE + + IF (zwt <= 0.) THEN + + fsat = 1. + eta = mu_twi + + ELSE + + eta = topoweti + niter = 0 + DO WHILE (niter < 20) + niter = niter + 1 + CALL GRATIO (alp_twi+1, (eta-mu_twi)/chi_twi, pgr1, qgr, 0) + CALL GRATIO (alp_twi, (eta-mu_twi)/chi_twi, pgr0, qgr, 0) + gfun = ((eta-mu_twi)*pgr0 - chi_twi*alp_twi*pgr1)/vdcf - zwt + + IF (abs(gfun) > 1.e-6) THEN + eta = mu_twi + (chi_twi * alp_twi * pgr1 + vdcf*zwt) / pgr0 + ELSE + EXIT + ENDIF + ENDDO + + IF (abs(gfun) > 1.e-6) THEN + write(*,*) 'Fail to converge in TOPModel: (alp,chi,mu,twi,zwt,gfun) = ', & + alp_twi, chi_twi, mu_twi, topoweti, zwt, gfun + ENDIF + + CALL GRATIO (alp_twi, (eta-mu_twi)/chi_twi, pgr0, qgr, 0) + + fsat = qgr + + ENDIF + + IF (present(eta_out)) THEN + eta_out = eta + ENDIF + + ENDIF + + IF (present(frcsat)) THEN + frcsat = fsat + ENDIF + +! Maximum infiltration capacity + qinmax = minval(10.**(-6.0*icefrac(1:min(3,nl_soil)))*hksati(1:min(3,nl_soil))) + IF(eff_porosity(1) WaterDepthMax ) then + !RunoffSurface = (WaterDepthInit + w_int) - WaterDepthMax + RunoffSurface = watin - wsat_int + w_int + ELSE + InfilVarTmp = 1.0 - ((WaterDepthInit +watin ) / WaterDepthMax) + RunoffSurface =watin - wsat_int + w_int + wsat_int * (InfilVarTmp**(1.0+BVIC)) + ENDIF + + IF ( RunoffSurface < 0.0 ) RunoffSurface = 0.0 + IF ( RunoffSurface > watin) RunoffSurface = watin + + infil = watin - RunoffSurface + rsur= RunoffSurface * 1000. / deltim + rsubst = 0. + ENDIF + + END SUBROUTINE Runoff_SimpleVIC + + ! ------------------------------------------------------------------------- + SUBROUTINE SubsurfaceRunoff_SimpleVIC ( & + nl_soil, z_soisno, dz_soisno, wice_soisno, porsl, psi0, hksati, theta_r, & + nprms, prms, zwt, rsubst) + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o + USE MOD_Vars_TimeInvariants, only: smpmax + USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi + IMPLICIT NONE + + integer, intent(in) :: nl_soil ! number of soil layers + + real(r8), intent(in) :: & + z_soisno (1:nl_soil), & ! layer depth (m) + dz_soisno (1:nl_soil), & ! layer thickness (m) + wice_soisno(1:nl_soil), & ! ice lens (kg/m2) + porsl (1:nl_soil), & ! saturated volumetric soil water content(porosity) + psi0 (1:nl_soil), & ! saturated soil suction (mm) (NEGATIVE) + hksati (1:nl_soil), & ! hydraulic conductivity at saturation (mm h2o/s) + theta_r (1:nl_soil) ! residual moisture content [-] + + integer, intent(in) :: nprms + real(r8), intent(in) :: prms(nprms, 1:nl_soil) + + real(r8), intent(in) :: zwt ! [m] + + real(r8), intent(out) :: rsubst ! subsurface runoff (mm h2o/s) + + ! Local Variables + real(r8), parameter :: Ds = 0.061 ! a fraction of Dsmax + real(r8), parameter :: Ws = 0.646 ! a fraction of the potential water storage as Wmb-Wwb + real(r8) :: Dsmax ! maximum subsurface flow + real(r8) :: Wwb ! (layer 8+9, from 0.83m to 2.30m) water storage at wilting point + real(r8) :: Wmb ! (layer 8+9, from 0.83m to 2.30m) maximum water storage + real(r8) :: Wlb ! (layer 8+9, from 0.83m to 2.30m) liquid water storage + real(r8) :: Wab ! (layer 8+9, from 0.83m to 2.30m) relative water storage + + real(r8) :: vol_ice, icefrac, eff_porosity, imped, hk + real(r8), parameter :: e_ice=6.0 ! soil ice impedance factor + integer :: ilev + + Wwb = 0. + Wmb = 0. + Wlb = 0. + Dsmax = 0. + DO ilev = 8, 9 + vol_ice = max(min(porsl(ilev), wice_soisno(ilev)/(dz_soisno(ilev)*denice)), 0.) + eff_porosity = porsl(ilev) - vol_ice + + Wwb = Wwb + dz_soisno(ilev) * denh2o * & + soil_vliq_from_psi (smpmax, eff_porosity, theta_r(ilev), psi0(ilev), nprms, prms(:,ilev)) + + Wmb = Wmb + eff_porosity*dz_soisno(ilev)*denh2o + + Wlb = Wlb + dz_soisno(ilev) * denh2o * & + soil_vliq_from_psi ( psi0(ilev)-max((zwt-z_soisno(ilev))*1.e3, 0.), & + eff_porosity, theta_r(ilev), psi0(ilev), nprms, prms(:,ilev)) + + icefrac = vol_ice/porsl(ilev) + imped = 10.**(-e_ice*icefrac) + hk = imped * hksati(ilev) + Dsmax = max(Dsmax, hk) + ENDDO + + Wab = (Wlb-Wwb) / (Wmb-Wwb) + Wab = min(max(Wab, 0.), 1.) + + IF (Wab <= Ws) THEN + rsubst = Dsmax * Ds * (Wab/Ws) + ELSE + rsubst = Dsmax * Ds * (Wab/Ws) + Dsmax * (1-Ds/Ws) * ((Wab-Ws)/(1-Ws))**2 + ENDIF + + END SUBROUTINE SubsurfaceRunoff_SimpleVIC + +END MODULE MOD_Runoff +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 new file mode 100644 index 0000000000..85c9ac548b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 @@ -0,0 +1,680 @@ +#include + +MODULE MOD_SimpleOcean + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: socean + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: seafluxes + PRIVATE :: srftsb + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE socean (dosst,deltim,oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,sabg,frl,tssea,tssub,scv,& + taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,emis,olrg) +!----------------------------------------------------------------------- +! Simple Ocean Model +! 1. calculate sea surface fluxes, based on CLM +! 2. calculate sea surface albedos and seaice/snow temperatures +! as in NCAR CCM3.6.16 +! Original authors : Yongjiu Dai and Xin-Zhong Liang (08/30/2001) +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, hvap, hsub, stefnc, vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, parameter :: psrfty=7 ! Number of surface types + integer, parameter :: plsice=4 ! number of seaice levels + + logical, intent(in) :: dosst ! true to update sst/ice/snow before calculation + real(r8), intent(in) :: deltim ! seconds in a time-step (s) + real(r8), intent(in) :: hu ! agcm reference height of wind [m] + real(r8), intent(in) :: ht ! agcm reference height of temperature [m] + real(r8), intent(in) :: hq ! agcm reference height of humidity [m] + real(r8), intent(in) :: us ! wind component in eastward direction [m/s] + real(r8), intent(in) :: vs ! wind component in northward direction [m/s] + real(r8), intent(in) :: tm ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: qm ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density air [kg/m3] + real(r8), intent(in) :: psrf ! atmosphere pressure at the surface [pa] [not used] + real(r8), intent(in) :: sabg ! surface solar absorbed flux [W/m2] + real(r8), intent(in) :: frl ! downward longwave radiation [W/m2] + + real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag + real(r8), intent(inout) :: scv ! snow water equivalent depth (mm) + real(r8), intent(inout) :: tssub(plsice) ! surface/sub-surface temperatures [K] + real(r8), intent(out) :: tssea ! sea surface temperature [K] + + real(r8), intent(out) :: taux ! wind stress: E-W [kg/m/s**2] + real(r8), intent(out) :: tauy ! wind stress: N-S [kg/m/s**2] + real(r8), intent(out) :: fsena ! sensible heat from reference height to atmosphere [W/m2] + real(r8), intent(out) :: fevpa ! evaporation from reference height to atmosphere [mm/s] + real(r8), intent(out) :: lfevpa ! latent heat from reference height to atmosphere [W/m2] + real(r8), intent(out) :: fseng ! sensible heat flux from ground [W/m2] + real(r8), intent(out) :: fevpg ! evaporation heat flux from ground [mm/s] + + real(r8), intent(out) :: tref ! 2 m height air temperature [kelvin] + real(r8), intent(out) :: qref ! 2 m height air humidity + real(r8), intent(out) :: z0m ! effective roughness [m] + real(r8), intent(out) :: zol ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), intent(out) :: rib ! bulk Richardson number in surface layer + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: tstar ! temperature scaling parameter + real(r8), intent(out) :: qstar ! moisture scaling parameter + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: emis ! averaged bulk surface emissivity + real(r8), intent(out) :: olrg ! longwave up flux at surface [W/m2] + +!-------------------------- Local Variables ---------------------------- + integer isrfty ! surface type index (1-7) + real(r8) cgrndl ! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + real(r8) cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + real(r8) dshf ! Ts partial derivative for sensible heat flux + real(r8) dlhf ! Ts partial derivative for latent heat flux + real(r8) fnt ! net surface flux for input conditions [W/m2] + real(r8) dfntdt ! net surface flux ts partial derivative [W/m2] + real(r8) tsbsf(plsice) ! Non-adjusted srfc/sub-srfc temperatures + real(r8) snowh ! snow depth (liquid water equivalent) [m] + real(r8) sicthk ! sea-ice thickness [m] + + real(r8), parameter :: emisi = 1.0 ! (0.97) surface emissivity for ice or snow [-] + real(r8), parameter :: emisw = 1.0 ! (0.97) surface emissivity for water [-] + real(r8), parameter :: tsice = 271.36 ! freezing point of sea ice [K] + real(r8), parameter :: thsice = 2.0 ! initial thickness of sea ice [m] + real(r8), parameter :: snsice = 0.005 ! initial snow water equivalent over sea ice [m] + + integer j + +!----------------------------------------------------------------------- + + snowh = scv/1000. + + IF(dosst)THEN +! update sea temperatures and sea ice distribution +! as well as snow cover over sea ice + IF(nint(oro).eq.2 .and. tssea.gt.tsice) THEN + oro = 0.0 ! old sea ice melt out + snowh = 0. + scv = 0. + sicthk = 0. + DO j = 1,plsice + tssub(j) = tssea + ENDDO + ELSEIF(nint(oro).eq.0 .and. tssea.le.tsice) THEN + oro = 2.0 ! new sea ice formed + snowh = snsice + scv = snowh*1000. + sicthk = thsice + DO j = 1,plsice + tssub(j) = tssea + ENDDO + ENDIF + ENDIF + + tssea = tssub(1) + +! compute surface fluxes, derivatives, and exchange coefficients + CALL seafluxes (oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,tssea,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) + + IF(nint(oro).eq.0)THEN ! ocean + lfevpa = fevpa*hvap + olrg = stefnc*emisw*tssea**4 + (1.-emisw)*frl + emis = emisw + + ELSEIF(nint(oro).eq.2)THEN ! sea ice + lfevpa = fevpa*hsub + + ! net surface flux and derivate at current surface temperature + dshf = cgrnds + dlhf = hsub*cgrndl + olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl + + fnt = sabg + frl - olrg - fsena - lfevpa + dfntdt = -(dshf + dlhf) - stefnc*emisi*4.*tssea**3 + + ! initialize surface/subsurface temperatures for srftsb + DO j=1,plsice + tsbsf(j) = tssub(j) + ENDDO + + ! set sea ice surface type + isrfty = 2 + + ! diffusion calculation for temperature + CALL srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) + + DO j=1,plsice + tsbsf(j) = min(tsbsf(j),tfrz) + tssub(j) = tsbsf(j) + ENDDO + tssea = tssub(1) + + olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl + emis = emisi + + ENDIF + + END SUBROUTINE socean + + + + SUBROUTINE seafluxes (oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,tssea,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of thermal processes +! and surface fluxes +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002 +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,rgas,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_Qsadv + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: & + oro, &! ocean(0)/seaice(2)/ flag + + ! atmospherical variables and agcm reference height + hu, &! agcm reference height of wind [m] + ht, &! agcm reference height of temperature [m] + hq, &! agcm reference height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + tssea ! sea surface temperature [K] + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat from agcm reference height to atmosphere [W/m2] + fevpa, &! evaporation from agcm reference height to atmosphere [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq, &! integral of profile FUNCTION for moisture + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + +!-------------------------- Local Variables ---------------------------- + integer i + integer niters,&! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + eg, &! water vapor pressure at temperature T [Pa] + degdT, &! d(eg)/dT + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + qsatg, &! ground saturated specific humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile FUNCTION for momentum at 10m + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stablity effect [m/s] + ur, &! wind speed at reference height [m/s] + visa, &! kinematic viscosity of dry air [m2/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + xt, &! + xq, &! + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0hg, &! roughness length over ground, sensible heat [m] + z0qg ! roughness length over ground, latent heat [m] + + real, parameter :: zsice = 0.04 ! sea ice aerodynamic roughness length [m] + +!----------------------------------------------------------------------- +! potential temperature at the reference height + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + CALL qsadv(tssea,psrf,eg,degdT,qsatg,qsatgdT) + +! potential temperature at the reference height + thm = tm + 0.0098*ht ! intermediate variable equivalent to + ! tm*(pgcm/psrf)**(rgas/cpair) + th = tm*(100000./psrf)**(rgas/cpair) ! potential T + thv = th*(1.+0.61*qm) ! virtual potential T + ur = max(0.1,sqrt(us*us+vs*vs)) ! limit set to 0.1 + + dth = thm-tssea + dqh = qm-qsatg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + IF(nint(oro).eq.0)THEN ! ocean + ! Kinematic viscosity of dry air (m2/s)- Andreas (1989) CRREL Rep. 89-11 + visa=1.326e-5*(1.+6.542e-3*tm + 8.301e-6*tm**2 - 4.84e-9*tm**3) + + ! loop to obtain initial and good ustar and zo + ustar=0.06 + wc=0.5 + IF(dthv.ge.0.) THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF + + DO i=1,5 + z0mg=0.013*ustar*ustar/grav+0.11*visa/ustar + ustar=vonkar*um/log(zldis/z0mg) + ENDDO + + ELSEIF(nint(oro).eq.2)THEN ! sea ice + z0mg = zsice + z0qg = z0mg + z0hg = z0mg + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=10 + displax = 0. + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + + IF(nint(oro).eq.0)THEN ! ocean + z0mg=0.013*ustar*ustar/grav + 0.11*visa/ustar + xq=2.67*(ustar*z0mg/visa)**0.25 - 2.57 + xt= xq + z0qg=z0mg/exp(xq) + z0hg=z0mg/exp(xt) + ENDIF + + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zol=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zol >= 0.) THEN ! stable + zol = min(2.,max(zol,1.e-6)) + ELSE ! unstable + zol = max(-100.,min(zol,-1.e-6)) + ENDIF + obu = zldis/zol + + IF(zol >= 0.)THEN + um = max(ur,0.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + raiw = rhoair/raw + cgrnds = raih + cgrndl = raiw*qsatgdT + + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + + fseng = -raih*dth + fevpg = -raiw*dqh + fsena = fseng + fevpa = fevpg + +! 2 m height air temperature + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + z0m = z0mg + + END SUBROUTINE seafluxes + + + + SUBROUTINE srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) + +!----------------------------------------------------------------------- +! Compute surface and subsurface temperatures over sea-ice surfaces. +! +! Sea ice temperatures are specified in 'plsice' layers of fixed +! thickness and thermal properties. The forecast temperatures are +! determined from a backward/IMPLICIT diffusion calculation using +! linearized sensible/latent heat fluxes. The bottom ocean temperature +! is fixed at -2C, allowing heat flux exchange with underlying ocean. +! +! Sub-surface layers are indexed 1 at the surface, increasing downwards +! to plsice. Layers have mid-points and interfaces between layers. +! +! Temperatures are defined at mid-points, WHILE fluxes between layers +! and the top/bottom media are defined at layer interfaces. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tkice, tkair + USE MOD_Utils + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, parameter :: psrfty = 7 ! Number of surface types + integer, parameter :: plsice = 4 ! number of seaice levels + + integer, intent(in) :: isrfty ! surface type index (1 - 7) + real(r8), intent(in) :: deltim ! seconds i a time step (s) + real(r8), intent(in) :: fnt ! top surface/atmosphere net energy flux + real(r8), intent(in) :: dfntdt ! ts partial derivative of net sfc flux + real(r8), intent(in) :: snowh ! snow depth (liquid water equivalent) [m] + + real(r8), intent(inout) :: tsbsf(1:plsice) ! surface/sub-surface tmps + +!-------------------------- Local Variables ---------------------------- + + integer :: j, jndx ! sub-surface layer index + + real(r8) cmass (1:plsice) ! specific heat of soil (J/kg/K) + real(r8) rho (1:plsice) ! mass densty of sub-sfc mat (kg/m3) + real(r8) tk (1:plsice) ! thermal conductivity (watts/m/K) + real(r8) diag (1:plsice) ! diagonal matrix elements + real(r8) htsrc (1:plsice) ! external heat source (W/m3) + real(r8) rhs (1:plsice) ! rhs of tri-diagonal matrix equation + real(r8) sbdiag(1:plsice) ! sub-diagonal matrix elements + real(r8) spdiag(1:plsice) ! super-diagonal matrix elements + real(r8) tin (1:plsice) ! initial sub-surface temperatures + real(r8) z (0:plsice) ! interface geometrical depth (m) + real(r8) ws (1:plsice) ! working storage for mtdlss + + real(r8) cmty ! layer mass heat capacity + real(r8) fbt ! ocean heat flux into sea-ice + real(r8) rhty ! layer mass density + real(r8) thck ! layer thickness + real(r8) tkty ! layer thermal conductivity + real(r8) cmsnow ! Snow mass heat capacity + real(r8) crt ! cmass*rho*rdtime + real(r8) delz ! layer thickness + real(r8) delzmn ! thick from mid-point to lyr above mid-point + real(r8) delzpl ! thick from mid-point to lyr below mid-point + real(r8) fmns ! 1/(delz*delzmn) + real(r8) fpls ! 1/(delz*delzpl) + real(r8) msnow ! mass path of snow + real(r8) mlice ! mass path of ice + real(r8) rdtime ! inverse model time step + real(r8) rhsnow ! snow mass density + real(r8) rztop ! 1/ztop + real(r8) tkbot ! bottom layer top interf thermal conduct + real(r8) tkmns ! layer bottom interface thermal conduct + real(r8) tkpls ! layer top interface thermal conductivity + real(r8) tksnow ! snow thermal conductivity + real(r8) tktop ! top layer bottom interface thermal conduct + real(r8) tmp ! crt - dfntdt(i)*rztop + real(r8) zbot ! bottom layer thickness + real(r8) zm ! present layer mid-point depth + real(r8) zmmn ! layer above mid-point depth + real(r8) zmpl ! layer below mid-point depth + real(r8) zsnow ! snow geometric depth + real(r8) ztop ! top layer thickness + logical scvr ! true IF surface snow covered + +!--------------------------Data Statements------------------------------ +! specified (and invariant) thermal properties for surface types + + real, parameter :: cmair = 1.00e3 ! mass specific heat of air [J/kg/K] + real, parameter :: cmice = 2.07e3 ! mass specific heat of ice [J/kg/K] + real, parameter :: frcair = 0.90 ! fraction of air assumed in mix of ice + real, parameter :: rhair = 1.25 ! mass density of surface air [kg/m3] + real, parameter :: rhice = 9.20e2 ! mass density of ice [kg/m3] + real, parameter :: snwedp = 10.0 ! snow:water equivalent depth factor [-] + + real(r8),parameter,dimension(psrfty,plsice) :: &!mass specific heat (J/kg/K) + cmtype = reshape(& + (/4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2/), (/7,4/)) + + real(r8),parameter,dimension(psrfty,plsice) :: &! mass density (kg/m3) + rhtype = reshape(& + (/1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3/),(/7,4/)) + + real(r8),parameter,dimension(psrfty,plsice) :: &!layer thicknesses (m) + thckly = reshape(& + (/ 2., .500, .250, .050, .090, .080, .120, & + 5., .500, .500, .366, .390, .435, .492, & + 10., .500, .500,1.369,1.459,1.628,1.841, & + 33., .500,8.500,6.990,7.450,8.310,9.400/), (/7,4/)) + + real(r8),parameter,dimension(psrfty,plsice) :: &!thermal conductivity (W/m/K) + tktype = reshape(& + (/15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 /), (/7,4/)) + +!----------------------------------------------------------------------- + + rdtime = 1./deltim + +! calculate snow properties + cmsnow = (1.-frcair)*cmice + frcair*cmair + rhsnow = (1.-frcair)*rhice + frcair*rhair + tksnow = (1.-frcair)*tkice + frcair*tkair + +! no external heat source + DO j=1,plsice + htsrc(j) = 0.0 + ENDDO + +! define logical for snow covered surfaces: + scvr = snowh.gt.0. + +! define thermal properties for each sub/surface layer, starting +! with the top layer + jndx = isrfty + thck = thckly(jndx,1) + cmty = cmtype(jndx,1) + rhty = rhtype(jndx,1) + tkty = tktype(jndx,1) + +! initialize fields for no snow cover + z(0) = 0.0 + z(1) = thck + cmass(1) = cmty + rho(1) = rhty + tk(1) = tkty + +! modify layer 1 fields for snow cover IF present +! snow equivalent depth times snow liquid water depth gives the physical +! depth of snow for thermal conduction computation; snow is mixed +! uniformly by mass with the top surface layer + IF(scvr) THEN + zsnow = snowh*snwedp + msnow = rhsnow*zsnow + mlice = rhty*thck + rho(1) = (msnow*rhsnow + mlice*rhty)/(msnow+mlice) + cmass(1) = (msnow*cmsnow + mlice*cmty)/(msnow+mlice) + tk(1) = (msnow*tksnow + mlice*tkty)/(msnow+mlice) + z(1) = (msnow+mlice) / rho(1) + ENDIF + +! set surface thermal properties for the lower sub/surface layers: + DO j=2,plsice + jndx = isrfty + thck = thckly(jndx,j) + cmass(j) = cmtype(jndx,j) + rho(j) = rhtype(jndx,j) + tk(j) = tktype(jndx,j) + z(j) = z(j-1) + thck + ENDDO + +! define set of linear equations for temperature + DO j=1,plsice + tin(j) = tsbsf(j) + ENDDO + +! IF sea ice, compute heat flux from underlying ocean, assumed to be at +! the temperature of -2C + fbt = 0.0 + IF(isrfty.eq.2) THEN + zbot = 0.5*(z(plsice) - z(plsice-1)) + fbt = -tk(plsice)*(271.16 - tin(plsice))/zbot + ENDIF + +! set up linear equations + sbdiag(1) = 0. + spdiag(plsice) = 0. + +! single layer + IF (plsice.eq.1) THEN + rztop = 1./(z(1) - z(0)) + crt = (cmass(1)*rho(1)*rdtime) + diag(1) = crt - dfntdt*rztop + rhs(1) = diag(1)*tin(1) + fnt*rztop - fbt*rztop + htsrc(1) + +! more than one layer: top layer first + ELSEIF (plsice.gt.1) THEN + + crt = cmass(1)*rho(1)*rdtime + ztop = z(1) - z(0) + rztop = 1./ztop + tktop = 0.5*(tk(1) + tk(2)) + zmpl = 0.5*(z(2) + z(1)) + zm = 0.5*(z(1) + z(0)) + delzpl = zmpl - zm + fpls = 1./(ztop*delzpl) + tmp = crt - dfntdt*rztop + + diag(1) = tmp + tktop*fpls + spdiag(1) = -tktop*fpls + rhs(1) = tmp*tin(1) + fnt*rztop + htsrc(1) + +! intermediate layers + DO j=2,plsice-1 + crt = cmass(j)*rho(j)*rdtime + delz = z(j) - z(j-1) + zmpl = 0.5*(z(j+1) + z(j)) + zm = 0.5*(z(j) + z(j-1)) + zmmn = 0.5*(z(j-1) + z(j-2)) + delzpl = zmpl - zm + delzmn = zm - zmmn + fpls = 1./(delz*delzpl) + fmns = 1./(delz*delzmn) + tkpls = 0.5*(tk(j+1)+tk(j)) + tkmns = 0.5*(tk(j)+tk(j-1)) + + sbdiag(j) = -tkmns*fmns + diag(j) = crt + (tkpls*fpls + tkmns*fmns) + spdiag(j) = -tkpls*fpls + rhs(j) = crt*tin(j) + htsrc(j) + ENDDO + +! bottom layer + crt = cmass(plsice)*rho(plsice)*rdtime + zbot = z(plsice) - z(plsice-1) + zm = 0.5*(z(plsice) + z(plsice-1)) + zmmn = 0.5*(z(plsice-1) + z(plsice-2)) + delzmn = zm - zmmn + tkbot = 0.5*(tk(plsice-1) + tk(plsice)) + fmns = 1./(zbot*delzmn) + sbdiag(plsice) = -tkbot*fmns + diag(plsice) = crt + (tkbot*fmns) + rhs(plsice) = crt*tin(plsice) - fbt/zbot + htsrc(plsice) + ENDIF + + IF(plsice.eq.1) THEN + tsbsf(1) = rhs(1)/diag(1) + ELSE + CALL tridia (plsice,sbdiag,diag,spdiag,rhs,tsbsf) + ENDIF + + END SUBROUTINE srftsb + +END MODULE MOD_SimpleOcean +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 new file mode 100644 index 0000000000..91b23f156a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 @@ -0,0 +1,175 @@ +#include + +MODULE MOD_SnowFraction + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: snowfraction +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + PUBLIC :: snowfraction_pftwrap +#endif + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE snowfraction (lai,sai,z0m,zlnd,scv,snowdp,wt,sigf,fsno) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Provide snow cover fraction +! +! Original author: Yongjiu Dai, /09/1999/, /04/2014/ +! +! !REVISIONS: +! 10/2019, Hua Yuan: removed fveg to be compatible with PFT +! classification +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: scv ! snow water equivalent [mm or kg/m3] + real(r8), intent(in) :: snowdp ! snow depth [m] + real(r8), intent(in) :: z0m ! aerodynamic roughness length [m] + real(r8), intent(in) :: zlnd ! aerodynamic roughness length over soil surface [m] + real(r8), intent(in) :: lai ! leaf area index [-] + real(r8), intent(in) :: sai ! stem area index [-] + + real(r8), intent(out) :: wt ! fraction of vegetation covered with snow [-] + real(r8), intent(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(out) :: fsno ! fraction of soil covered by snow [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: fmelt ! dimensionless melting factor + real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. + ! WHILE the value of m given by Niu et al (2007) is 1.6 + ! WHILE Niu (2012) suggested 3.0 + +!----------------------------------------------------------------------- + IF(lai+sai > 1e-6) THEN + ! Fraction of vegetation buried (covered) by snow + wt = 0.1*snowdp/z0m + wt = wt/(1.+wt) + + ! Fraction of vegetation cover free of snow + sigf = 1. - wt + ELSE + wt = 0. + sigf = 1. + ENDIF + +! 10/16/2019, yuan: + !IF(sigf < 0.001) sigf = 0. + !IF(sigf > 0.999) sigf = 1. + +! Fraction of soil covered by snow + fsno = 0.0 + IF(snowdp > 0.) THEN + fmelt = (scv/snowdp/100.) ** m + fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) + ENDIF + + END SUBROUTINE snowfraction + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! A wrap SUBROUTINE to calculate snow cover fraction for PFT|PC run +! +! !REVISIONS: +! +! 06/2019, Hua Yuan: initial code adapted from snowfraction() by +! Yongjiu Dai +! +! 08/2019, Hua Yuan: removed fveg to be compatible with PFT +! classification +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch ! patch index + + real(r8), intent(in) :: zlnd ! aerodynamic roughness length over soil surface [m] + real(r8), intent(in) :: scv ! snow water equivalent [mm or kg/m3] + real(r8), intent(in) :: snowdp ! snow depth [m] + + real(r8), intent(out) :: wt ! fraction of vegetation covered with snow [-] + real(r8), intent(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(out) :: fsno ! fraction of soil covered by snow [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: fmelt ! dimensionless melting factor + real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. + ! WHILE the value of m given by Niu et al (2007) is 1.6 + ! WHILE Niu (2012) suggested 3.0 + + integer i, p, ps, pe + real(r8) wt_tmp +!----------------------------------------------------------------------- + + wt_tmp = 0. + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + DO i = ps, pe + p = pftclass(i) + + IF(tlai_p(i)+tsai_p(i) > 1.e-6) THEN + ! Fraction of vegetation buried (covered) by snow + wt = 0.1*snowdp/z0m_p(i) + wt = wt/(1.+wt) + + ! Fraction of vegetation cover free of snow + sigf_p(i) = 1. - wt + ELSE + wt = 0. + sigf_p(i) = 1. + ENDIF + + ! snow on vegetation, USE snowdp to calculate buried fraction + IF ( DEF_VEG_SNOW .and. tlai_p(i)+tsai_p(i) > 1.e-6 ) THEN + ! for trees, use hbot, htop to determine how much lsai being buried. + IF (p.gt.0 .and. p.le.8) THEN + wt = max(0., (snowdp-hbot_p(i))) / (htop_p(i)-hbot_p(i)) + wt = min(wt, 1.) + sigf_p(i) = 1. - wt + ENDIF + ENDIF + + wt_tmp = wt_tmp + wt*pftfrac(i) + ENDDO + + wt = wt_tmp + sigf = sum(sigf_p(ps:pe) * pftfrac(ps:pe)) + + ! Fraction of soil covered by snow + fsno = 0.0 + IF(snowdp > 0.) THEN + fmelt = (scv/snowdp/100.) ** m + fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) + ENDIF + + END SUBROUTINE snowfraction_pftwrap +#endif + +END MODULE MOD_SnowFraction +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 new file mode 100644 index 0000000000..e108a351d0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 @@ -0,0 +1,1290 @@ +#include + +MODULE MOD_SnowLayersCombineDivide + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: snowcompaction + PUBLIC :: snowlayerscombine + PUBLIC :: SnowLayersCombine_snicar + PUBLIC :: snowlayersdivide + PUBLIC :: SnowLayersDivide_snicar + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: combo + PRIVATE :: winddriftcompaction + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE snowcompaction (lb,deltim,imelt,fiold,& + t_soisno,wliq_soisno,wice_soisno,forc_us,forc_vs,dz_soisno) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! Revision: Yongjiu Dai, /07/31/2023 +! +! Four of metamorphisms of changing snow characteristics are +! implemented, i.e., destructive, overburden, melt and wind drift. The +! treatments of the destructive compaction was from SNTHERM.89 and +! SNTHERM.99 (1991, 1999). The contribution due to melt metamorphism is +! simply taken as a ratio of snow ice fraction after the melting versus +! before the melting. The treatments of the overburden compaction and +! the drifting compaction were borrowed from CLM5.0 which based on +! Vionnet et al. (2012) and van Kampenhout et al (2017). +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: lb ! lower bound of array + real(r8), intent(in) :: deltim ! seconds i a time step [second] + integer, intent(in) :: imelt(lb:0) ! signifies IF node in melting (imelt = 1) + real(r8), intent(in) :: fiold(lb:0) ! fraction of ice relative to the total water content + ! at the previous time step + real(r8), intent(in) :: t_soisno(lb:0) ! nodal temperature [K] + real(r8), intent(in) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] + + real(r8), intent(inout) :: dz_soisno(lb:0) ! layer thickness [m] + +!-------------------------- Local Variables ---------------------------- + integer j ! Numeber of doing loop + + real(r8), parameter :: c1 = 2.777e-7 ! [m2/(kg s)] + real(r8), parameter :: c2 = 23.0e-3 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6 ! [1/s] + real(r8), parameter :: c4 = 0.04 ! [1/K] + real(r8), parameter :: c5 = 2.0 ! + real(r8), parameter :: c6 = 5.15e-7 ! + real(r8), parameter :: c7 = 4.0 ! + ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: dm = 100.0 + real(r8), parameter :: eta0 = 9.e5 ! The Viscosity Coefficient Eta0 [kg-s/m2] + + real(r8) :: burden ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! rate of compaction of snowpack due to melt [1/s] + real(r8) :: ddz4 ! rate of compaction of snowpack due to wind drift. + + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + + real(r8) :: zpseudo ! wind drift compaction / pseudo depth + ! (only valid IF wind_dependent_snow_density is .true.) + logical :: mobile ! current snow layer is mobile, i.e. susceptible to wind drift + ! (only valid IF wind_dependent_snow_density is .true.) + real(r8) :: f1, f2, eta, forc_wind + +!----------------------------------------------------------------------- + ! Begin calculation - note that the following column loops are only invoked IF lb < 0 + + burden = 0.0 + zpseudo = 0.0 + mobile = .true. + + DO j = lb, 0 + wx = wice_soisno(j) + wliq_soisno(j) + void = 1.0-(wice_soisno(j)/denice + wliq_soisno(j)/denh2o)/dz_soisno(j) + +! Disallow compaction for water saturated node and lower ice lens node. + IF(void <= 0.001 .or. wice_soisno(j) <= .1)THEN + burden = burden+wx + + ! saturated node is immobile + ! This is only needed IF wind_dependent_snow_density is true, but it's + ! simplest just to update mobile always + mobile = .false. + + CYCLE + ENDIF + + bi = wice_soisno(j) / dz_soisno(j) + fi = wice_soisno(j) / wx + td = tfrz-t_soisno(j) + + dexpf = exp(-c4*td) + +! Compaction due to destructive metamorphism + ddz1 = -c3*dexpf + IF(bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + +! Liquid water term + IF(wliq_soisno(j) > 0.01*dz_soisno(j)) ddz1=ddz1*c5 + +! Compaction due to overburden +!* ddz2 = -burden*exp(-0.08*td-c2*bi)/eta0 + f1 = 1.0/(1.0+60.0*wliq_soisno(j)/(denh2o*dz_soisno(j))) + f2 = 4.0 ! currently fixed to maximum value, holds in absence of angular grains + eta = f1*f2*(bi/450.0)*exp(0.1*td + c2*bi)*7.62237e6 + ddz2 = -(burden+wx/2.0) / eta + +! Compaction occurring during melt + IF(imelt(j) == 1)THEN + ddz3 = - 1.0/deltim * max(0.0,(fiold(j) - fi)/fiold(j)) + ELSE + ddz3 = 0.0 + ENDIF + +! Compaction occurring due to wind drift + forc_wind = sqrt(forc_us**2+forc_vs**2) + CALL winddriftcompaction( bi,forc_wind,dz_soisno(j),zpseudo,mobile,ddz4 ) + +! Time rate of fractional change in dz (units of s-1) + pdzdtc = ddz1 + ddz2 + ddz3 + ddz4 + +! The change in dz_soisno due to compaction +! Limit compaction to be no greater than fully saturated layer thickness + dz_soisno(j) = dz_soisno(j)*(1.0+pdzdtc*deltim) + dz_soisno(j) = max(dz_soisno(j),(wice_soisno(j)/denice+ wliq_soisno(j)/denh2o)) + +! Pressure of overlying snow + burden = burden+wx + + ENDDO + + END SUBROUTINE snowcompaction + + + + SUBROUTINE winddriftcompaction(bi,forc_wind,dz,zpseudo,mobile,compaction_rate) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! Compute wind drift compaction for a single column and level. Also +! updates zpseudo and mobile for this column. However, zpseudo remains +! unchanged IF mobile is already false or becomes false within this +! SUBROUTINE. +! +! The structure of the updates done here for zpseudo and mobile +! requires that this SUBROUTINE be called first for the top layer of +! snow, THEN for the 2nd layer down, etc. - and finally for the bottom +! layer. Before beginning the loops over layers, mobile should be +! initialized to .true. and zpseudo should be initialized to 0. +! +! !REVISIONS: Yongjiu Dai, /07/31/2023 +! +! !USES: + USE MOD_Precision + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: bi ! partial density of ice [kg/m3] + real(r8) , intent(in) :: forc_wind ! atmospheric wind speed [m/s] + real(r8) , intent(in) :: dz ! layer depth for this column and level [m] + ! wind drift compaction / pseudo depth for this column at this layer + real(r8) , intent(inout) :: zpseudo + ! whether this snow column is still mobile at this layer (i.e., susceptible to wind drift) + logical , intent(inout) :: mobile + ! rate of compaction of snowpack due to wind drift, for the current column and layer + real(r8) , intent(out) :: compaction_rate + ! + ! !LOCAL VARIABLES: + real(r8) :: Frho ! Mobility density factor [-] + real(r8) :: MO ! Mobility index [-] + real(r8) :: SI ! Driftability index [-] + real(r8) :: gamma_drift ! Scaling factor for wind drift time scale [-] + real(r8) :: tau_inverse ! Inverse of the effective time scale [1/s] + + real(r8), parameter :: rho_min = 50._r8 ! wind drift compaction / minimum density [kg/m3] + real(r8), parameter :: rho_max = 350._r8 ! wind drift compaction / maximum density [kg/m3] + ! wind drift compaction / grain size (fixed value for now) + real(r8), parameter :: drift_gs = 0.35e-3_r8 + real(r8), parameter :: drift_sph = 1.0_r8 ! wind drift compaction / sphericity + real(r8), parameter :: tau_ref = 48._r8 * 3600._r8 ! wind drift compaction / reference time [s] + + !----------------------------------------------------------------------- + + IF (mobile) THEN + Frho = 1.25_r8 - 0.0042_r8*(max(rho_min, bi)-rho_min) + ! assuming dendricity = 0, sphericity = 1, grain size = 0.35 mm Non-dendritic snow + MO = 0.34_r8 * (-0.583_r8*drift_gs - 0.833_r8*drift_sph + 0.833_r8) + 0.66_r8*Frho + SI = -2.868_r8 * exp(-0.085_r8*forc_wind) + 1._r8 + MO + + IF (SI > 0.0_r8) THEN + SI = min(SI, 3.25_r8) + ! Increase zpseudo (wind drift / pseudo depth) to the middle of + ! the pseudo-node for the sake of the following calculation + zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) + gamma_drift = SI*exp(-zpseudo/0.1_r8) + tau_inverse = gamma_drift / tau_ref + compaction_rate = -max(0.0_r8, rho_max-bi) * tau_inverse + ! Further increase zpseudo to the bottom of the pseudo-node for + ! the sake of calculations done on the underlying layer (i.e., + ! the next time through the j loop). + zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) + ELSE ! SI <= 0 + mobile = .false. + compaction_rate = 0._r8 + ENDIF + ELSE ! .not. mobile + compaction_rate = 0._r8 + ENDIF + + END SUBROUTINE winddriftcompaction + + + + !----------------------------------------------------------------------- + SUBROUTINE snowlayerscombine (lb,snl, & + z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! checks for elements which are below prescribed minimum for thickness +! or mass. If snow element thickness or mass is less than a prescribed +! minimum, it is combined with neighboring element to be best combine +! with, and executes the combination of mass and energy in +! clm_combo.f90 +! +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb ! lower bound of array + +! numbering from 1 (bottom) mss (surface) + real(r8), intent(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] + real(r8), intent(inout) :: t_soisno (lb:1) ! node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:1) ! layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:1) ! node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] + real(r8), intent(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: scv ! snow mass - water equivalent [kg/m2] + integer, intent(inout) :: snl ! Number of snow + +!-------------------------- Local Variables ---------------------------- + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) + real(r8) :: zwice ! total ice mass in snow + real(r8) :: zwliq ! total liquid water in snow + + integer :: i ! number of DO looping + integer :: j ! node index + integer :: k ! number of DO looping + integer :: l ! node index + integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + +!----------------------------------------------------------------------- +! check the mass of ice lens of snow, when the total less than a small value, +! combine it with the underlying neighbor + msn_old = snl + DO j = msn_old+1, 0 + IF(wice_soisno(j) <= .1)THEN + wliq_soisno(j+1) = wliq_soisno(j+1) + wliq_soisno(j) + wice_soisno(j+1) = wice_soisno(j+1) + wice_soisno(j) + +! shift all elements above this down one. + IF(j > snl+1 .and. snl < -1)THEN + DO i = j, snl+2, -1 + t_soisno(i) = t_soisno(i-1) + wliq_soisno(i) = wliq_soisno(i-1) + wice_soisno(i) = wice_soisno(i-1) + dz_soisno(i) = dz_soisno(i-1) + ENDDO + ENDIF + + snl = snl + 1 +!* write(6,*) 'one snow layer is gone' + + ENDIF + + ENDDO + + IF(snl == 0)THEN + scv = 0. + snowdp = 0. +!* write(6,*) 'all snow has gone' + RETURN + ELSE + scv = 0. + snowdp = 0. + zwice = 0. + zwliq = 0. + DO j = snl + 1, 0 + scv = scv + wice_soisno(j) + wliq_soisno(j) + snowdp = snowdp + dz_soisno(j) + zwice = zwice + wice_soisno(j) + zwliq = zwliq + wliq_soisno(j) + ENDDO + ENDIF +!----------------------------------------------------------------------- +! check the snow depth + + IF(snowdp < 0.01)THEN !!! all snow gone + + snl = 0 + scv = zwice + IF(scv <= 0.) snowdp = 0. + +! the liquid water assumed ponding on soil surface + wliq_soisno(1) = wliq_soisno(1) + zwliq +!* write(6,'(17h all snow is gone)') + RETURN + + ELSE !!! snow layers combined + +! two or more layers + + IF(snl < -1)THEN + msn_old = snl + mssi = 1 + DO i = msn_old+1, 0 + +! If top node is removed, combine with bottom neighbor + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN + neibor = i + 1 + +! If the bottom neighbor is not snow, combine with the top neighbor + ELSEIF(i == 0)THEN + neibor = i - 1 + +! If NONE of the above special cases apply, combine with the thinnest neighbor + ELSE + neibor = i + 1 + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF + +! Node l and j are combined and stored as node j. + + IF(neibor > i)THEN + j = neibor + l = i + ELSE + j = i + l = neibor + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) + +! Now shift all elements above this down one. + + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 + t_soisno(k) = t_soisno(k-1) + wice_soisno(k) = wice_soisno(k-1) + wliq_soisno(k) = wliq_soisno(k-1) + dz_soisno(k) = dz_soisno(k-1) + ENDDO + ENDIF + + snl = snl + 1 + +!* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j + + IF(snl >= -1) EXIT + +! The layer thickness great than the prescribed minimum value + + ELSE + mssi = mssi + 1 + ENDIF + ENDDO + + ENDIF + +! Reset the node depth and the depth of layer interface + + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + ENDIF !!! snow layers combined + + END SUBROUTINE snowlayerscombine + + + + SUBROUTINE snowlayersdivide(lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! subdivides snow layer when its thickness exceed the prescribed maximum +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: lb ! lower bound of array + integer, intent(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(inout) :: t_soisno (lb:0) ! Node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:0) ! Layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:0) ! Node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] + +!-------------------------- Local Variables ---------------------------- + +! numbering from 1 (surface) msno (bottom) + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzsno(5) ! Snow layer thickness [m] + real(r8) :: swice(5) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(5) ! Nodel temperature [K] + + integer k ! number of DO looping + integer msno ! number of snow layer 1 (top) to msno (bottom) + + real(r8) zwice,zwliq,propor + +!----------------------------------------------------------------------- + + msno = abs(snl) + DO k = 1, msno + dzsno(k) = dz_soisno (k + snl) + swice(k) = wice_soisno(k + snl) + swliq(k) = wliq_soisno(k + snl) + tsno(k) = t_soisno (k + snl) + ENDDO + + IF(msno == 1)THEN + IF(dzsno(1) > 0.03)THEN + msno = 2 +! Specified a new snow layer + dzsno(1) = dzsno(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + + dzsno(2) = dzsno(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) +! write(6,*)'Subdivided Top Node into two layer (1/2)' + ENDIF + ENDIF + + IF(msno > 1)THEN + IF(dzsno(1) > 0.02)THEN + drr = dzsno(1) - 0.02 + propor = drr/dzsno(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + + propor = 0.02/dzsno(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dzsno(1) = 0.02 + + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & + drr,zwliq,zwice,tsno(1)) + +! write(6,*) 'Subdivided Top Node & +! 20 mm combined into underlying neighbor' + + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN +! subdivided a new layer + msno = 3 + dzsno(2) = dzsno(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + + dzsno(3) = dzsno(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) + ENDIF + ENDIF + ENDIF + + IF(msno > 2)THEN + IF(dzsno(2) > 0.05)THEN + drr = dzsno(2) - 0.05 + propor = drr/dzsno(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + + propor = 0.05/dzsno(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dzsno(2) = 0.05 + + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & + drr, zwliq, zwice, tsno(2)) + +! write(6,*)'Subdivided 50 mm from the subsurface layer & +! &and combined into underlying neighbor' + + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN +! subdivided a new layer + msno = 4 + dzsno(3) = dzsno(3)/2. + swice(3) = swice(3)/2. + swliq(3) = swliq(3)/2. + + dzsno(4) = dzsno(3) + swice(4) = swice(3) + swliq(4) = swliq(3) + tsno(4) = tsno(3) + ENDIF + ENDIF + ENDIF + + IF(msno > 3)THEN + IF(dzsno(3) > 0.11)THEN + drr = dzsno(3) - 0.11 + propor = drr/dzsno(3) + zwice = propor*swice(3) + zwliq = propor*swliq(3) + + propor = 0.11/dzsno(3) + swice(3) = propor*swice(3) + swliq(3) = propor*swliq(3) + dzsno(3) = 0.11 + + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & + drr, zwliq, zwice, tsno(3)) + +! write(6,*)'Subdivided 110 mm from the third Node & +! &and combined into underlying neighbor' + + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN +! subdivided a new layer + msno = 5 + dzsno(4) = dzsno(4)/2. + swice(4) = swice(4)/2. + swliq(4) = swliq(4)/2. + + dzsno(5) = dzsno(4) + swice(5) = swice(4) + swliq(5) = swliq(4) + tsno(5) = tsno(4) + ENDIF + ENDIF + ENDIF + + IF(msno > 4)THEN + IF(dzsno(4) > 0.23)THEN + drr = dzsno(4) - 0.23 + propor = drr/dzsno(4) + zwice = propor*swice(4) + zwliq = propor*swliq(4) + + propor = 0.23/dzsno(4) + swice(4) = propor*swice(4) + swliq(4) = propor*swliq(4) + dzsno(4) = 0.23 + + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & + drr, zwliq, zwice, tsno(4)) + +! write(6,*)'Subdivided 230 mm from the fourth Node & +! 'and combined into underlying neighbor' + ENDIF + ENDIF + + snl = - msno + + DO k = snl+1, 0 + dz_soisno(k) = dzsno(k - snl) + wice_soisno(k) = swice(k - snl) + wliq_soisno(k) = swliq(k - snl) + t_soisno(k) = tsno (k - snl) + ENDDO + + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + END SUBROUTINE snowlayersdivide + + + + SUBROUTINE combo ( dz_soisno, wliq_soisno, wice_soisno, t, & + dz2, wliq2, wice2, t2 ) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! combines two elements and returns the following combined +! variabless: dz_soisno, t, wliq_soisno, wice_soisno. +! the combined temperature is based on the equation: +! the sum of the enthalpies of the two elements = that of the combined element. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpice, cpliq, hfus, tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] + + real(r8), intent(inout) :: dz_soisno ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq_soisno ! liquid water of element 1 + real(r8), intent(inout) :: wice_soisno ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! node temperature of elment 1 [K] + +!-------------------------- Local Variables ---------------------------- + + real(r8) dzc ! Total thickness of nodes 1 and 2 (dzc=dz_soisno+dz2). + real(r8) wliqc ! Combined liquid water [kg/m2] + real(r8) wicec ! Combined ice [kg/m2] + real(r8) tc ! Combined node temperature [K] + real(r8) h ! enthalpy of element 1 [J/m2] + real(r8) h2 ! enthalpy of element 2 [J/m2] + real(r8) hc ! temporary + +!----------------------------------------------------------------------- + + dzc = dz_soisno+dz2 + wicec = (wice_soisno+wice2) + wliqc = (wliq_soisno+wliq2) + h = (cpice*wice_soisno+cpliq*wliq_soisno)*(t-tfrz)+hfus*wliq_soisno + h2 = (cpice*wice2+cpliq*wliq2)*(t2-tfrz)+hfus*wliq2 + + hc = h + h2 + IF(hc < 0.)THEN + tc = tfrz + hc/(cpice*wicec+cpliq*wliqc) + ELSEIF(hc.le.hfus*wliqc)THEN + tc = tfrz + ELSE + tc = tfrz + (hc - hfus*wliqc)/(cpice*wicec+cpliq*wliqc) + ENDIF + + dz_soisno = dzc + wice_soisno = wicec + wliq_soisno = wliqc + t = tc + + END SUBROUTINE combo + + + SUBROUTINE SnowLayersCombine_snicar (lb,snl, & + z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp,& + +! Aerosol Fluxes (Jan. 07, 2023) + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) +! Aerosol Fluxes (Jan. 07, 2023) + + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999; January 07, 2023 +! +! checks for elements which are below prescribed minimum for thickness or mass. +! If snow element thickness or mass is less than a prescribed minimum, +! it is combined with neighboring element to be best combine with, +! and executes the combination of mass and energy in clm_combo.f90 +! +! !REVISIONS: +! Yongjiu Dai, 01/2023: added Aerosol fluxes from SNICAR model +!======================================================================= + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb ! lower bound of array + +! numbering from 1 (bottom) mss (surface) + real(r8), intent(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] + real(r8), intent(inout) :: t_soisno (lb:1) ! node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:1) ! layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:1) ! node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] + real(r8), intent(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: scv ! snow mass - water equivalent [kg/m2] + integer, intent(inout) :: snl ! Number of snow + +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(inout) :: & + mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) + +!-------------------------- Local Variables ---------------------------- + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) + real(r8) :: zwice ! total ice mass in snow + real(r8) :: zwliq ! total liquid water in snow + + integer :: i ! number of DO looping + integer :: j ! node index + integer :: k ! number of DO looping + integer :: l ! node index + integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + +!----------------------------------------------------------------------- +! check the mass of ice lens of snow, when the total less than a small value, +! combine it with the underlying neighbor + msn_old = snl + DO j = msn_old+1, 0 + IF(wice_soisno(j) <= .1)THEN + wliq_soisno(j+1) = wliq_soisno(j+1) + wliq_soisno(j) + wice_soisno(j+1) = wice_soisno(j+1) + wice_soisno(j) + +!Aerosol Fluxes (January 07, 2023) + IF (j < 0) THEN ! 01/11/2023, yuan: add j < 0 + mss_bcphi(j+1) = mss_bcphi(j+1) + mss_bcphi(j) + mss_bcpho(j+1) = mss_bcpho(j+1) + mss_bcpho(j) + mss_ocphi(j+1) = mss_ocphi(j+1) + mss_ocphi(j) + mss_ocpho(j+1) = mss_ocpho(j+1) + mss_ocpho(j) + mss_dst1 (j+1) = mss_dst1 (j+1) + mss_dst1 (j) + mss_dst2 (j+1) = mss_dst2 (j+1) + mss_dst2 (j) + mss_dst3 (j+1) = mss_dst3 (j+1) + mss_dst3 (j) + mss_dst4 (j+1) = mss_dst4 (j+1) + mss_dst4 (j) + ENDIF +!Aerosol Fluxes (January 07, 2023) + + +! shift all elements above this down one. + IF(j > snl+1 .and. snl < -1)THEN + DO i = j, snl+2, -1 + t_soisno(i) = t_soisno(i-1) + wliq_soisno(i) = wliq_soisno(i-1) + wice_soisno(i) = wice_soisno(i-1) + dz_soisno(i) = dz_soisno(i-1) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(i) = mss_bcphi(i-1) + mss_bcpho(i) = mss_bcpho(i-1) + mss_ocphi(i) = mss_ocphi(i-1) + mss_ocpho(i) = mss_ocpho(i-1) + mss_dst1 (i) = mss_dst1 (i-1) + mss_dst2 (i) = mss_dst2 (i-1) + mss_dst3 (i) = mss_dst3 (i-1) + mss_dst4 (i) = mss_dst4 (i-1) +!Aerosol Fluxes (January 07, 2023) + ENDDO + ENDIF + + snl = snl + 1 +!* write(6,*) 'one snow layer is gone' + + ENDIF + + ENDDO + + IF(snl == 0)THEN + scv = 0._r8 + snowdp = 0._r8 + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(:) = 0._r8 + mss_bcpho(:) = 0._r8 + mss_ocphi(:) = 0._r8 + mss_ocpho(:) = 0._r8 + mss_dst1 (:) = 0._r8 + mss_dst2 (:) = 0._r8 + mss_dst3 (:) = 0._r8 + mss_dst4 (:) = 0._r8 +!Aerosol Fluxes (January 07, 2023) + +!* write(6,*) 'all snow has gone' + RETURN + ELSE + scv = 0._r8 + snowdp = 0._r8 + zwice = 0._r8 + zwliq = 0._r8 + DO j = snl + 1, 0 + scv = scv + wice_soisno(j) + wliq_soisno(j) + snowdp = snowdp + dz_soisno(j) + zwice = zwice + wice_soisno(j) + zwliq = zwliq + wliq_soisno(j) + ENDDO + ENDIF +!----------------------------------------------------------------------- +! check the snow depth + + IF(snowdp < 0.01_r8)THEN !!! all snow gone + + snl = 0 + scv = zwice + IF(scv <= 0._r8) snowdp = 0._r8 + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(:) = 0._r8 + mss_bcpho(:) = 0._r8 + mss_ocphi(:) = 0._r8 + mss_ocpho(:) = 0._r8 + mss_dst1 (:) = 0._r8 + mss_dst2 (:) = 0._r8 + mss_dst3 (:) = 0._r8 + mss_dst4 (:) = 0._r8 +!Aerosol Fluxes (January 07, 2023) + +! the liquid water assumed ponding on soil surface + wliq_soisno(1) = wliq_soisno(1) + zwliq +!* write(6,'(17h all snow is gone)') + RETURN + + ELSE !!! snow layers combined + +! two or more layers + + IF(snl < -1)THEN + msn_old = snl + mssi = 1 + DO i = msn_old+1, 0 + +! If top node is removed, combine with bottom neighbor + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN + neibor = i + 1 + +! If the bottom neighbor is not snow, combine with the top neighbor + ELSEIF(i == 0)THEN + neibor = i - 1 + +! If NONE of the above special cases apply, combine with the thinnest neighbor + ELSE + neibor = i + 1 + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF + +! Node l and j are combined and stored as node j. + + IF(neibor > i)THEN + j = neibor + l = i + ELSE + j = i + l = neibor + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(j) = mss_bcphi(j) + mss_bcphi(l) + mss_bcpho(j) = mss_bcpho(j) + mss_bcpho(l) + mss_ocphi(j) = mss_ocphi(j) + mss_ocphi(l) + mss_ocpho(j) = mss_ocpho(j) + mss_ocpho(l) + mss_dst1 (j) = mss_dst1 (j) + mss_dst1 (l) + mss_dst2 (j) = mss_dst2 (j) + mss_dst2 (l) + mss_dst3 (j) = mss_dst3 (j) + mss_dst3 (l) + mss_dst4 (j) = mss_dst4 (j) + mss_dst4 (l) +!Aerosol Fluxes (January 07, 2023) + + +! Now shift all elements above this down one. + + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 + t_soisno(k) = t_soisno(k-1) + wice_soisno(k) = wice_soisno(k-1) + wliq_soisno(k) = wliq_soisno(k-1) + dz_soisno(k) = dz_soisno(k-1) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(k) = mss_bcphi(k-1) + mss_bcpho(k) = mss_bcpho(k-1) + mss_ocphi(k) = mss_ocphi(k-1) + mss_ocpho(k) = mss_ocpho(k-1) + mss_dst1 (k) = mss_dst1 (k-1) + mss_dst2 (k) = mss_dst2 (k-1) + mss_dst3 (k) = mss_dst3 (k-1) + mss_dst4 (k) = mss_dst4 (k-1) +!Aerosol Fluxes (January 07, 2023) + ENDDO + ENDIF + + snl = snl + 1 + +!* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j + + IF(snl >= -1) EXIT + +! The layer thickness great than the prescribed minimum value + + ELSE + mssi = mssi + 1 + ENDIF + ENDDO + + ENDIF + +! Reset the node depth and the depth of layer interface + + zi_soisno(0) = 0._r8 + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5_r8*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + ENDIF !!! snow layers combined + + END SUBROUTINE SnowLayersCombine_snicar +!----------------------------------------------------------------------- + + + SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& + wliq_soisno,wice_soisno,t_soisno,& + +! Aerosol Fluxes (Jan. 07, 2023) + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) +! Aerosol Fluxes (Jan. 07, 2023) + + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999, January 07, 2023 +! +! subdivides snow layer when its thickness exceed the prescribed maximum +! +! !REVISIONS: +! Yongjiu Dai, 01/2023: added Aerosol fluxes from SNICAR model +!======================================================================= + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: lb ! lower bound of array + integer, intent(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(inout) :: t_soisno (lb:0) ! Node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:0) ! Layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:0) ! Node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] + +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(inout) :: & + mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) + +!-------------------------- Local Variables ---------------------------- + +! numbering from 1 (surface) msno (bottom) + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzsno(5) ! Snow layer thickness [m] + real(r8) :: swice(5) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(5) ! Node temperature [K] + + integer k ! number of DO looping + integer msno ! number of snow layer 1 (top) to msno (bottom) + + real(r8) zwice,zwliq,propor + +!Aerosol Fluxes (January 07, 2023) + real(r8) mss_aerosol(5,8) + real(r8) z_mss_aerosol(8) +!Aerosol Fluxes (January 07, 2023) + +!----------------------------------------------------------------------- + + msno = abs(snl) + DO k = 1, msno + dzsno(k) = dz_soisno (k + snl) + swice(k) = wice_soisno(k + snl) + swliq(k) = wliq_soisno(k + snl) + tsno (k) = t_soisno (k + snl) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(k, 1) = mss_bcphi(k+snl) + mss_aerosol(k, 2) = mss_bcpho(k+snl) + mss_aerosol(k, 3) = mss_ocphi(k+snl) + mss_aerosol(k, 4) = mss_ocpho(k+snl) + mss_aerosol(k, 5) = mss_dst1 (k+snl) + mss_aerosol(k, 6) = mss_dst2 (k+snl) + mss_aerosol(k, 7) = mss_dst3 (k+snl) + mss_aerosol(k, 8) = mss_dst4 (k+snl) +!Aerosol Fluxes (January 07, 2023) + + ENDDO + + IF(msno == 1)THEN + IF(dzsno(1) > 0.03)THEN + msno = 2 +! Specified a new snow layer + dzsno(1) = dzsno(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(1,:) = mss_aerosol(1,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(2) = dzsno(1) + swice(2) = swice(1) + swliq(2) = swliq(1) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = mss_aerosol(1,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(2) = tsno(1) + +! write(6,*)'Subdivided Top Node into two layer (1/2)' + ENDIF + ENDIF + + IF(msno > 1)THEN + IF(dzsno(1) > 0.02)THEN + drr = dzsno(1) - 0.02 + propor = drr/dzsno(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(1,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.02/dzsno(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(1,:) = propor*mss_aerosol(1,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(1) = 0.02 + + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & + drr,zwliq,zwice,tsno(1)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = z_mss_aerosol(:) + mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*) 'Subdivided Top Node & +! 20 mm combined into underlying neighbor' + + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN +! subdivided a new layer + msno = 3 + dzsno(2) = dzsno(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = mss_aerosol(2,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(3) = dzsno(2) + swice(3) = swice(2) + swliq(3) = swliq(2) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(3) = tsno(2) + ENDIF + ENDIF + ENDIF + + IF(msno > 2)THEN + IF(dzsno(2) > 0.05)THEN + drr = dzsno(2) - 0.05 + propor = drr/dzsno(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.05/dzsno(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = propor*mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(2) = 0.05 + + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & + drr, zwliq, zwice, tsno(2)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = z_mss_aerosol(:) + mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*)'Subdivided 50 mm from the subsurface layer & +! &and combined into underlying neighbor' + + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN +! subdivided a new layer + msno = 4 + dzsno(3) = dzsno(3)/2. + swice(3) = swice(3)/2. + swliq(3) = swliq(3)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = mss_aerosol(3,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(4) = dzsno(3) + swice(4) = swice(3) + swliq(4) = swliq(3) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(4) = tsno(3) + + ENDIF + ENDIF + ENDIF + + IF(msno > 3)THEN + IF(dzsno(3) > 0.11)THEN + drr = dzsno(3) - 0.11 + propor = drr/dzsno(3) + zwice = propor*swice(3) + zwliq = propor*swliq(3) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.11/dzsno(3) + swice(3) = propor*swice(3) + swliq(3) = propor*swliq(3) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = propor*mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(3) = 0.11 + + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & + drr, zwliq, zwice, tsno(3)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = z_mss_aerosol(:) + mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*)'Subdivided 110 mm from the third Node & +! &and combined into underlying neighbor' + + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN +! subdivided a new layer + msno = 5 + dzsno(4) = dzsno(4)/2. + swice(4) = swice(4)/2. + swliq(4) = swliq(4)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = mss_aerosol(4,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(5) = dzsno(4) + swice(5) = swice(4) + swliq(5) = swliq(4) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(5,:) = mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(5) = tsno(4) + + ENDIF + ENDIF + ENDIF + + IF(msno > 4)THEN + IF(dzsno(4) > 0.23)THEN + drr = dzsno(4) - 0.23 + propor = drr/dzsno(4) + zwice = propor*swice(4) + zwliq = propor*swliq(4) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.23/dzsno(4) + swice(4) = propor*swice(4) + swliq(4) = propor*swliq(4) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = propor*mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(4) = 0.23 + + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & + drr, zwliq, zwice, tsno(4)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(5,:) = z_mss_aerosol(:) + mss_aerosol(5,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*)'Subdivided 230 mm from the fourth Node & +! 'and combined into underlying neighbor' + ENDIF + ENDIF + + snl = - msno + + DO k = snl+1, 0 + dz_soisno(k) = dzsno(k - snl) + wice_soisno(k) = swice(k - snl) + wliq_soisno(k) = swliq(k - snl) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(k) = mss_aerosol(k - snl, 1) + mss_bcpho(k) = mss_aerosol(k - snl, 2) + mss_ocphi(k) = mss_aerosol(k - snl, 3) + mss_ocpho(k) = mss_aerosol(k - snl, 4) + mss_dst1 (k) = mss_aerosol(k - snl, 5) + mss_dst2 (k) = mss_aerosol(k - snl, 6) + mss_dst3 (k) = mss_aerosol(k - snl, 7) + mss_dst4 (k) = mss_aerosol(k - snl, 8) +!Aerosol Fluxes (January 07, 2023) + + t_soisno(k) = tsno (k - snl) + + ENDDO + + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + END SUBROUTINE SnowLayersDivide_snicar + +END MODULE MOD_SnowLayersCombineDivide +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 new file mode 100644 index 0000000000..2cb85a9df9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 @@ -0,0 +1,3000 @@ +#include + +MODULE MOD_SnowSnicar + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate albedo of snow containing impurities and the evolution of +! snow effective radius +! +! Original: +! 1) The Community Land Model version 5.0 (CLM5.0) +! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land +! Model (ELM v2.0) +! +! !REFERENCES: +! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling +! spectral snow albedo. Geosci. Model Dev., 14, 7673-7704, +! https://doi.org/10.5194/gmd-14-7673-2021 +! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land +! model (version 2.0) and assessing its impacts on snow and surface +! fluxes over the Tibetan Plateau. Geosci. Model Dev., 16, 75-94, +! https://doi.org/10.5194/gmd-16-75-2023 +! +! !REVISIONS: +! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global, only: maxsnl + USE MOD_SPMD_Task + + IMPLICIT NONE +! SAVE + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice (kg/m^3) + + integer, parameter :: iulog = 6 ! "stdout" log file unit number, default is 6 + integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + +!-------------------------------------------------------------------- +! DAI, Dec. 29, 2022 +! Temporary setting + + logical, parameter :: use_extrasnowlayers = .false. + character(len=256), parameter :: snow_shape = 'sphere' ! (=1), 'spheroid'(=2), 'hexagonal_plate'(=3), 'koch_snowflake'(=4) + logical, parameter :: use_dust_snow_internal_mixing = .false. + character(len=256), parameter :: snicar_atm_type = 'default' ! Atmospheric profile used to obtain surface-incident spectral flux distribution + ! and subsequent broadband albedo + ! = 'mid-latitude_winter' ! => 1 + ! = 'mid-latitude_summer' ! => 2 + ! = 'sub-Arctic_winter' ! => 3 + ! = 'sub-Arctic_summer' ! => 4 + ! = 'summit_Greenland' ! => 5 (sub-Arctic summer, surface pressure of 796hPa) + ! = 'high_mountain' ! => 6 (summer, surface pressure of 556 hPa) +!DAI, Dec. 29, 2022 +!----------------------------------------------------------------------- + + ! !PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption + PUBLIC :: SNICAR_AD_RT ! Snow albedo and vertically-resolved solar absorption by adding-doubling solution + ! To USE this subroutine, set use_snicar_ad = true + PUBLIC :: SnowAge_grain ! Snow effective grain size evolution + PUBLIC :: SnowAge_init ! Initial read in of snow-aging file + PUBLIC :: SnowOptics_init ! Initial read in of snow-optics file + ! + ! !PUBLIC DATA MEMBERS: + integer, PUBLIC, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + ! (indices described above) [nbr] + logical, PUBLIC, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) + ! in snowpack radiative calculations + logical, PUBLIC, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + ! !PRIVATE DATA MEMBERS: + integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] + integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] + integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] + integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] + integer, parameter :: idx_T_max = 11 ! maximum temperature index used in aging lookup table [idx] + integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_max = 31 ! maximum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_rhos_max = 8 ! maximum snow density index used in aging lookup table [idx] + integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] + +#ifdef MODAL_AER + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + !mgf++ + integer, parameter :: idx_bc_nclrds_min = 1 ! minimum index for BC particle size in optics lookup table + integer, parameter :: idx_bc_nclrds_max = 10 ! maximum index for BC particle size in optics lookup table + integer, parameter :: idx_bcint_icerds_min = 1 ! minimum index for snow grain size in optics lookup table for within-ice BC + integer, parameter :: idx_bcint_icerds_max = 8 ! maximum index for snow grain size in optics lookup table for within-ice BC + !mgf-- +#endif + + integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] + integer, parameter :: snw_rds_min_tbl = 30 ! minimum effective radius defined in Mie lookup table [microns] + real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns + real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] + real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] + !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89 + real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: zeroed to accomodate dry snow aging + real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: corrected for LWC in units of percent + + real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice + ! [s-1] (50% mass removal/year) + !$acc declare copyin(C1_liq_Brun89, C2_liq_Brun89, & + !$acc tim_cns_bc_rmv, tim_cns_oc_rmv, tim_cns_dst_rmv) + + ! scaling of the snow aging rate (tuning option): + logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor + real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate + ! snow and aerosol Mie parameters: + ! (arrays declared here, but are set in iniTimeConst) + ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) + + ! direct-beam weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_drc(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! diffuse radiation weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_dfs(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! direct & diffuse flux + real(r8), allocatable :: flx_wgt_dir (:,:,:) ! (6, 90, numrad_snw) ! direct flux, six atmospheric types, 0-89 SZA + real(r8), allocatable :: flx_wgt_dif (:,:) ! (6, numrad_snw) ! diffuse flux, six atmospheric types + + ! snow grain shape + integer, parameter :: snow_shape_sphere = 1 + integer, parameter :: snow_shape_spheroid = 2 + integer, parameter :: snow_shape_hexagonal_plate = 3 + integer, parameter :: snow_shape_koch_snowflake = 4 + + ! atmospheric condition for SNICAR-AD + integer, parameter :: atm_type_default = 0 + integer, parameter :: atm_type_mid_latitude_winter = 1 + integer, parameter :: atm_type_mid_latitude_summer = 2 + integer, parameter :: atm_type_sub_Arctic_winter = 3 + integer, parameter :: atm_type_sub_Arctic_summer = 4 + integer, parameter :: atm_type_summit_Greenland = 5 + integer, parameter :: atm_type_high_mountain = 6 + +#ifdef MODAL_AER + !mgf++ + ! Size-dependent BC optical properties. Currently a fixed BC size is + ! assumed, but this framework enables optical properties to be + ! assigned based on the BC effective radius, should this be + ! implemented in the future. + ! + ! within-ice BC (i.e., BC that was deposited within hydrometeors) + real(r8), allocatable :: ss_alb_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc1(:,:) ! (numrad_snw,idx_bc_nclrds_max); + + ! external BC + real(r8), allocatable :: ss_alb_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc2(:,:) ! (numrad_snw,idx_bc_nclrds_max); + !mgf-- +#else + ! hydrophiliic BC + real(r8), allocatable :: ss_alb_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc1(:) ! (numrad_snw); + + ! hydrophobic BC + real(r8), allocatable :: ss_alb_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc2(:) ! (numrad_snw); +#endif + + ! hydrophobic OC + real(r8), allocatable :: ss_alb_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc1(:) ! (numrad_snw); + + ! hydrophilic OC + real(r8), allocatable :: ss_alb_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc2(:) ! (numrad_snw); + + ! dust species 1: + real(r8), allocatable :: ss_alb_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst1(:) ! (numrad_snw); + + ! dust species 2: + real(r8), allocatable :: ss_alb_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst2(:) ! (numrad_snw); + + ! dust species 3: + real(r8), allocatable :: ss_alb_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst3(:) ! (numrad_snw); + + ! dust species 4: + real(r8), allocatable :: ss_alb_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst4(:) ! (numrad_snw); + +#ifdef MODAL_AER + ! Absorption enhancement factors for within-ice BC + real(r8), allocatable :: bcenh (:,:,:) ! (numrad_snw,idx_bc_nclrds_max,idx_bcint_icerds_max); +#endif + + ! best-fit parameters for snow aging defined over: + ! 11 temperatures from 225 to 273 K + ! 31 temperature gradients from 0 to 300 K/m + ! 8 snow densities from 0 to 350 kg/m3 + ! (arrays declared here, but are set in iniTimeConst) + ! + real(r8), allocatable :: snowage_tau (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [hour] + real(r8), allocatable :: snowage_kappa (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [unitless] + real(r8), allocatable :: snowage_drdt0 (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [um hr-1] + + ! + ! !REVISION HISTORY: + ! Created by Mark Flanner + !----------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Determine reflectance of, and vertically-resolved solar absorption in, +! snow with impurities. +! +! Original references on physical models of snow reflectance include: +! Wiscombe and Warren [1980] and Warren and Wiscombe [1980], +! Journal of Atmospheric Sciences, 37, +! +! The multi-layer solution for multiple-scattering used here is from: +! Toon et al. [1989], Rapid calculation of radiative heating rates +! and photodissociation rates in inhomogeneous multiple scattering atmospheres, +! J. Geophys. Res., 94, D13, 16287-16301 +! +! The implementation of the SNICAR model in CLM/CSIM is described in: +! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007], +! Present-day climate forcing and response from black carbon in snow, +! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003 +! +! !USES: +! +!----------------------------------------------------------------------- +! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: APRX_TYP ! two-stream approximation type + ! (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr] + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: n ! tridiagonal matrix index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_direct(maxsnl+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_net(maxsnl+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + ! intermediate variables for radiative transfer approximation: + real(r8):: gamma1(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma2(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma3(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma4(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: lambda(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: GAMMA(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: e1(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e2(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e3(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e4(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: C_pls_btm(maxsnl+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2] + real(r8):: C_mns_btm(maxsnl+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2] + real(r8):: C_pls_top(maxsnl+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2] + real(r8):: C_mns_top(maxsnl+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2] + real(r8):: A(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: B(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: D(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: E(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: AS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: DS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: X(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: Y(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw)) THEN + + ! Set variables specific to CLM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + + ! Error check for snow grain size: +#ifndef _OPENACC + IF (p_is_master) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL abort + ENDIF + ENDDO + ENDIF +#endif + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ENDIF + ENDIF + + ! Loop over snow spectral bands + DO bnd_idx = 1,numrad_snw + + mu_not = coszen ! must set here, because of error handling + flg_dover = 1 ! default is to redo + err_idx = 0 ! number of times through loop + + DO WHILE (flg_dover > 0) + + ! DEFAULT APPROXIMATIONS: + ! VIS: Delta-Eddington + ! NIR (all): Delta-Hemispheric Mean + ! WARNING: DO NOT USE DELTA-EDDINGTON FOR NIR DIFFUSE - this sometimes results in negative albedo + ! + ! ERROR CONDITIONS: + ! Conditions which cause "trip", resulting in redo of RT approximation: + ! 1. negative absorbed flux + ! 2. total absorbed flux greater than incident flux + ! 3. negative albedo + ! NOTE: These errors have only been encountered in spectral bands 4 and 5 + ! + ! ERROR HANDLING + ! 1st error (flg_dover=2): switch approximation (Edd->HM or HM->Edd) + ! 2nd error (flg_dover=3): change zenith angle by 0.02 (this happens about 1 in 10^6 cases) + ! 3rd error (flg_dover=4): switch approximation with new zenith + ! Subsequent errors: repeatedly change zenith and approximations... + + IF (bnd_idx == 1) THEN + IF (flg_dover == 2) THEN + APRX_TYP = 3 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 1 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 3 + ELSE + APRX_TYP = 1 + ENDIF + + ELSE + IF (flg_dover == 2) THEN + APRX_TYP = 1 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 3 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 1 + ELSE + APRX_TYP = 3 + ENDIF + + ENDIF + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + +!H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +!H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Total column optical depth: + ! tau_elm(i) = total optical depth above the bottom of layer i + tau_elm(snl_top) = 0._r8 + DO i=snl_top+1,snl_btm,1 + tau_elm(i) = tau_elm(i-1)+tau_star(i-1) + ENDDO + + ! Direct radiation at bottom of snowpack: + F_direct_btm = albsfc_lcl(bnd_idx)*mu_not * & + exp(-(tau_elm(snl_btm)+tau_star(snl_btm))/mu_not)*pi*flx_slrd_lcl(bnd_idx) + + ! Intermediates + ! Gamma values are approximation-specific. + + ! Eddington + IF (APRX_TYP==1) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (7-(omega_star(i)*(4+(3*g_star(i)))))/4 + gamma2(i) = -(1-(omega_star(i)*(4-(3*g_star(i)))))/4 + gamma3(i) = (2-(3*g_star(i)*mu_not))/4 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + + ! Quadrature + ELSEIF (APRX_TYP==2) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2 + gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2 + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 1/(3**0.5) + ENDDO + + ! Hemispheric Mean + ELSEIF (APRX_TYP==3) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = 2 - (omega_star(i)*(1+g_star(i))) + gamma2(i) = omega_star(i)*(1-g_star(i)) + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + ENDIF + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + lambda(i) = sqrt(abs((gamma1(i)**2) - (gamma2(i)**2))) + GAMMA(i) = gamma2(i)/(gamma1(i)+lambda(i)) + + e1(i) = 1+(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e2(i) = 1-(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e3(i) = GAMMA(i) + exp(-lambda(i)*tau_star(i)) + e4(i) = GAMMA(i) - exp(-lambda(i)*tau_star(i)) + ENDDO !ENDDO over snow layers + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + IF (flg_slr_in == 1) THEN + + C_pls_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)-(1/mu_not))*gamma3(i))+ & + (gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)+(1/mu_not))*gamma4(i))+ & + (gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_pls_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)-(1/mu_not))* & + gamma3(i))+(gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)+(1/mu_not))* & + gamma4(i))+(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + ELSE + C_pls_btm(i) = 0._r8 + C_mns_btm(i) = 0._r8 + C_pls_top(i) = 0._r8 + C_mns_top(i) = 0._r8 + ENDIF + ENDDO + + ! Coefficients for tridiaganol matrix solution + DO i=2*snl_lcl+1,0,1 + + !Boundary values for i=1 and i=2*snl_lcl, specifics for i=odd and i=even + IF (i==(2*snl_lcl+1)) THEN + A(i) = 0 + B(i) = e1(snl_top) + D(i) = -e2(snl_top) + E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top) + + ELSEIF(i==0) THEN + A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm)) + B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm)) + D(i) = 0 + E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm)) + + ELSEIF(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) + n=floor(i/2.0) + A(i) = (e2(n)*e3(n))-(e4(n)*e1(n)) + B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1)) + D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1)) + E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1))) + + ELSEIF(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl + n=(i/2) + A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1)) + B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1)) + D(i) = (e1(n+1)*e4(n+1))-(e2(n+1)*e3(n+1)) + E(i) = (e2(n+1)*(C_pls_top(n+1)-C_pls_btm(n)))+(e4(n+1)*(C_mns_top(n+1)-C_mns_btm(n))) + ENDIF + ENDDO + + AS(0) = A(0)/B(0) + DS(0) = E(0)/B(0) + + DO i=-1,(2*snl_lcl+1),-1 + X(i) = 1/(B(i)-(D(i)*AS(i+1))) + AS(i) = A(i)*X(i) + DS(i) = (E(i)-(D(i)*DS(i+1)))*X(i) + ENDDO + + Y(2*snl_lcl+1) = DS(2*snl_lcl+1) + DO i=(2*snl_lcl+2),0,1 + Y(i) = DS(i)-(AS(i)*Y(i-1)) + ENDDO + + ! Downward direct-beam and net flux (F_net) at the base of each layer: + DO i=snl_top,snl_btm,1 + F_direct(i) = mu_not*pi*flx_slrd_lcl(bnd_idx)*exp(-(tau_elm(i)+tau_star(i))/mu_not) + F_net(i) = (Y(2*i-1)*(e1(i)-e3(i))) + (Y(2*i)*(e2(i)-e4(i))) + & + C_pls_btm(i) - C_mns_btm(i) - F_direct(i) + ENDDO + + ! Upward flux at snowpack top: + F_sfc_pls = (Y(2*snl_lcl+1)*(exp(-lambda(snl_top)*tau_star(snl_top))+ & + GAMMA(snl_top))) + (Y(2*snl_lcl+2)*(exp(-lambda(snl_top)* & + tau_star(snl_top))-GAMMA(snl_top))) + C_pls_top(snl_top) + + ! Net flux at bottom = absorbed radiation by underlying surface: + F_btm_net = -F_net(snl_btm) + + + ! Bulk column albedo and surface net flux + albedo = F_sfc_pls/((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + F_sfc_net = F_sfc_pls - ((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + + trip = 0 + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + IF(i==snl_top) THEN + F_abs(i) = F_net(i)-F_sfc_net + ELSE + F_abs(i) = F_net(i)-F_net(i-1) + ENDIF + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + + ! ERROR check: negative absorption + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + trip = 1 + ENDIF + ENDDO + + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + + !ERROR check: absorption greater than incident flux + ! (should make condition more generic than "1._r8") + IF (F_abs_sum > 1._r8) THEN + trip = 1 + ENDIF + + !ERROR check: + IF ((albedo < 0._r8).and.(trip==0)) THEN + trip = 1 + ENDIF + + ! Set conditions for redoing RT calculation + IF ((trip == 1).and.(flg_dover == 1)) THEN + flg_dover = 2 + ELSEIF ((trip == 1).and.(flg_dover == 2)) THEN + flg_dover = 3 + ELSEIF ((trip == 1).and.(flg_dover == 3)) THEN + flg_dover = 4 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN + flg_dover = 3 + err_idx = err_idx + 1 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN + flg_dover = 0 +#ifndef _OPENACC + IF (p_is_master) THEN + write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice + write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + write(iulog,*) "frac_sno: ", frac_sno + CALL abort + ENDIF +#endif + ELSE + flg_dover = 0 + ENDIF + + ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (abs(energy_sum) > 0.00001_r8) THEN +#ifndef _OPENACC + IF (p_is_master) THEN + write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum + CALL abort + ENDIF +#endif + ENDIF + + albout_lcl(bnd_idx) = albedo + + ! Check that albedo is less than 1 + IF (albout_lcl(bnd_idx) > 1.0) THEN +#ifndef _OPENACC + IF (p_is_master) THEN + write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL abort + ENDIF +#endif + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Determine reflectance of, and vertically-resolved solar absorption in, +! snow with impurities, with updated shortwave scheme +! +! The multi-layer solution for multiple-scattering used here is from: +! Briegleb, P. and Light, B.: A Delta-Eddington mutiple scattering +! parameterization for solar radiation in the sea ice component of the +! community climate system model, 2007. +! +! The implementation of the SNICAR-AD model in ELM is described in: +! Dang et al., Inter-comparison and improvement of 2-stream shortwave +! radiative transfer models for unified treatment of cryospheric surfaces +! in ESMs, in review, 2019 +! +! To USE this subtroutine, set use_snicar_ad = true in ELM +! +! IF config_use_snicar_ad = true in MPAS-seaice +! Snow on land and snow on sea ice will be treated +! with the same model for their solar radiative properties. +! +! The inputs and outputs are the same to SUBROUTINE SNICAR_RT +! +! !USES: +!----------------------------------------------------------------------- +! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + ! integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + ! integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + ! integer :: c_idx ! column indices [idx] + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + integer :: snw_shp_lcl(maxsnl+1:0) ! Snow grain shape option: + ! 1=sphere; 2=spheroid; 3=hexagonal plate; 4=koch snowflake + real(r8):: snw_fs_lcl(maxsnl+1:0) ! Shape factor: ratio of nonspherical grain effective radii to that of equal-volume sphere + ! 0=USE recommended default value + ! others(0 1 (i.e. nonspherical) + real(r8):: snw_ar_lcl(maxsnl+1:0) ! % Aspect ratio: ratio of grain width to length + ! 0=USE recommended default value + ! others(0.1 1 (i.e. nonspherical) + real(r8):: & + diam_ice , & ! effective snow grain diameter + fs_sphd , & ! shape factor for spheroid + fs_hex0 , & ! shape factor for hexagonal plate + fs_hex , & ! shape factor for hexagonal plate (reference) + fs_koch , & ! shape factor for koch snowflake + AR_tmp , & ! aspect ratio for spheroid + g_ice_Cg_tmp(7) , & ! temporary for calculation of asymetry factor + gg_ice_F07_tmp(7) , & ! temporary for calculation of asymetry factor + g_ice_F07 , & ! temporary for calculation of asymetry factor + g_ice , & ! asymmetry factor + gg_F07_intp , & ! temporary for calculation of asymetry factor (interpolated) + g_Cg_intp , & ! temporary for calculation of asymetry factor (interpolated) + R_1_omega_tmp , & ! temporary for dust-snow mixing calculation + C_dust_total ! dust concentration + + integer :: atm_type_index ! index for atmospheric type + integer :: slr_zen ! integer value of solar zenith angle + + ! SNICAR_AD new variables, follow sea-ice shortwave conventions + real(r8):: & + trndir(maxsnl+1:1) , & ! solar beam down transmission from top + trntdr(maxsnl+1:1) , & ! total transmission to direct beam for layers above + trndif(maxsnl+1:1) , & ! diffuse transmission to diffuse beam for layers above + rupdir(maxsnl+1:1) , & ! reflectivity to direct radiation for layers below + rupdif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers below + rdndif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers above + dfdir(maxsnl+1:1) , & ! down-up flux at interface due to direct beam at top surface + dfdif(maxsnl+1:1) , & ! down-up flux at interface due to diffuse beam at top surface + dftmp(maxsnl+1:1) ! temporary variable for down-up flux at interface + + real(r8):: & + rdir(maxsnl+1:0) , & ! layer reflectivity to direct radiation + rdif_a(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from above + rdif_b(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from below + tdir(maxsnl+1:0) , & ! layer transmission to direct radiation (solar beam + diffuse) + tdif_a(maxsnl+1:0) , & ! layer transmission to diffuse radiation from above + tdif_b(maxsnl+1:0) , & ! layer transmission to diffuse radiation from below + trnlay(maxsnl+1:0) ! solar beam transm for layer (direct beam only) + + real(r8):: & + ts , & ! layer delta-scaled extinction optical depth + ws , & ! layer delta-scaled single scattering albedo + gs , & ! layer delta-scaled asymmetry parameter + extins , & ! extinction + alp , & ! temporary for alpha + gam , & ! temporary for agamm + amg , & ! alp - gam + apg , & ! alp + gam + ue , & ! temporary for u + refk , & ! interface multiple scattering + refkp1 , & ! interface multiple scattering for k+1 + refkm1 , & ! interface multiple scattering for k-1 + tdrrdir , & ! direct tran times layer direct ref + tdndif ! total down diffuse = tot tran - direct tran + + real(r8) :: & + alpha , & ! term in direct reflectivity and transmissivity + agamm , & ! term in direct reflectivity and transmissivity + el , & ! term in alpha,agamm,n,u + taus , & ! scaled extinction optical depth + omgs , & ! scaled single particle scattering albedo + asys , & ! scaled asymmetry parameter + u , & ! term in diffuse reflectivity and transmissivity + n , & ! term in diffuse reflectivity and transmissivity + lm , & ! temporary for el + mu , & ! cosine solar zenith for either snow or water + ne ! temporary for n + + ! perpendicular and parallel relative to plane of incidence and scattering + real(r8) :: & + R1 , & ! perpendicular polarization reflection amplitude + R2 , & ! parallel polarization reflection amplitude + T1 , & ! perpendicular polarization transmission amplitude + T2 , & ! parallel polarization transmission amplitude + Rf_dir_a , & ! fresnel reflection to direct radiation + Tf_dir_a , & ! fresnel transmission to direct radiation + Rf_dif_a , & ! fresnel reflection to diff radiation from above + Rf_dif_b , & ! fresnel reflection to diff radiation from below + Tf_dif_a , & ! fresnel transmission to diff radiation from above + Tf_dif_b ! fresnel transmission to diff radiation from below + + real(r8) :: & + gwt , & ! gaussian weight + swt , & ! sum of weights + trn , & ! layer transmission + rdr , & ! rdir for gaussian integration + tdr , & ! tdir for gaussian integration + smr , & ! accumulator for rdif gaussian integration + smt , & ! accumulator for tdif gaussian integration + exp_min ! minimum exponential value + + integer :: & + ng , & ! gaussian integration index + snl_btm_itf , & ! index of bottom snow layer interfaces (1) [idx] + ngmax = 8 ! gaussian integration index + + ! Gaussian integration angle and coefficients + real(r8) :: difgauspt(1:8) , difgauswt(1:8) + + ! constants used in algorithm + real(r8) :: & + c0 = 0.0_r8 , & + c1 = 1.0_r8 , & + c3 = 3.0_r8 , & + c4 = 4.0_r8 , & + c6 = 6.0_r8 , & + cp01 = 0.01_r8 , & + cp5 = 0.5_r8 , & + cp75 = 0.75_r8 , & + c1p5 = 1.5_r8 , & + trmin = 0.001_r8 , & + argmax = 10.0_r8 ! maximum argument of exponential + + ! cconstant coefficients used for SZA parameterization + real(r8) :: & + sza_a0 = 0.085730_r8 , & + sza_a1 = -0.630883_r8 , & + sza_a2 = 1.303723_r8 , & + sza_b0 = 1.467291_r8 , & + sza_b1 = -3.338043_r8 , & + sza_b2 = 6.807489_r8 , & + puny = 1.0e-11_r8 , & + mu_75 = 0.2588_r8 ! cosine of 75 degree + + ! coefficients used for SZA parameterization + real(r8) :: & + sza_c1 , & ! coefficient, SZA parameteirzation + sza_c0 , & ! coefficient, SZA parameterization + sza_factor , & ! factor used to adjust NIR direct albedo + flx_sza_adjust , & ! direct NIR flux adjustment from sza_factor + mu0 ! incident solar zenith angle + + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Constants for non-spherical ice particles and dust-snow internal mixing + real(r8) :: g_b2(7) + real(r8) :: g_b1(7) + real(r8) :: g_b0(7) + real(r8) :: g_F07_c2(7) + real(r8) :: g_F07_c1(7) + real(r8) :: g_F07_c0(7) + real(r8) :: g_F07_p2(7) + real(r8) :: g_F07_p1(7) + real(r8) :: g_F07_p0(7) + real(r8) :: dust_clear_d0(3) + real(r8) :: dust_clear_d1(3) + real(r8) :: dust_clear_d2(3) + real(r8) :: dust_cloudy_d0(3) + real(r8) :: dust_cloudy_d1(3) + real(r8) :: dust_cloudy_d2(3) + + !!! factors for considering snow grain shape + data g_b0(:) / 9.76029E-01_r8, 9.67798E-01_r8, 1.00111E+00_r8, 1.00224E+00_r8,& + 9.64295E-01_r8, 9.97475E-01_r8, 9.97475E-01_r8/ + data g_b1(:) / 5.21042E-01_r8, 4.96181E-01_r8, 1.83711E-01_r8, 1.37082E-01_r8,& + 5.50598E-02_r8, 8.48743E-02_r8, 8.48743E-02_r8/ + data g_b2(:) /-2.66792E-04_r8, 1.14088E-03_r8, 2.37011E-04_r8,-2.35905E-04_r8,& + 8.40449E-04_r8,-4.71484E-04_r8,-4.71484E-04_r8/ + + data g_F07_c2(:) / 1.349959E-1_r8, 1.115697E-1_r8, 9.853958E-2_r8, 5.557793E-2_r8,& + -1.233493E-1_r8, 0.0_r8, 0.0_r8/ + data g_F07_c1(:) /-3.987320E-1_r8,-3.723287E-1_r8,-3.924784E-1_r8,-3.259404E-1_r8,& + 4.429054E-2_r8,-1.726586E-1_r8,-1.726586E-1_r8/ + data g_F07_c0(:) / 7.938904E-1_r8, 8.030084E-1_r8, 8.513932E-1_r8, 8.692241E-1_r8,& + 7.085850E-1_r8, 6.412701E-1_r8, 6.412701E-1_r8/ + data g_F07_p2(:) / 3.165543E-3_r8, 2.014810E-3_r8, 1.780838E-3_r8, 6.987734E-4_r8,& + -1.882932E-2_r8,-2.277872E-2_r8,-2.277872E-2_r8/ + data g_F07_p1(:) / 1.140557E-1_r8, 1.143152E-1_r8, 1.143814E-1_r8, 1.071238E-1_r8,& + 1.353873E-1_r8, 1.914431E-1_r8, 1.914431E-1_r8/ + data g_F07_p0(:) / 5.292852E-1_r8, 5.425909E-1_r8, 5.601598E-1_r8, 6.023407E-1_r8,& + 6.473899E-1_r8, 4.634944E-1_r8, 4.634944E-1_r8/ + + !!! factors for considring dust-snow internal mixing + data dust_clear_d0(:) /1.0413E+00_r8,1.0168E+00_r8,1.0189E+00_r8/ + data dust_clear_d1(:) /1.0016E+00_r8,1.0070E+00_r8,1.0840E+00_r8/ + data dust_clear_d2(:) /2.4208E-01_r8,1.5300E-03_r8,1.1230E-04_r8/ + + data dust_cloudy_d0(:) /1.0388E+00_r8,1.0167E+00_r8,1.0189E+00_r8/ + data dust_cloudy_d1(:) /1.0015E+00_r8,1.0061E+00_r8,1.0823E+00_r8/ + data dust_cloudy_d2(:) /2.5973E-01_r8,1.6200E-03_r8,1.1721E-04_r8/ + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + !Gaussian integration angle and coefficients for diffuse radiation + difgauspt(1:8) & ! gaussian angles (radians) + = (/ 0.9894009_r8, 0.9445750_r8, & + 0.8656312_r8, 0.7554044_r8, & + 0.6178762_r8, 0.4580168_r8, & + 0.2816036_r8, 0.0950125_r8/) + difgauswt(1:8) & ! gaussian weights + = (/ 0.0271525_r8, 0.0622535_r8, & + 0.0951585_r8, 0.1246290_r8, & + 0.1495960_r8, 0.1691565_r8, & + 0.1826034_r8, 0.1894506_r8/) + + snw_shp_lcl(:) = snow_shape_sphere + snw_fs_lcl(:) = 0._r8 + snw_ar_lcl(:) = 0._r8 + atm_type_index = atm_type_default + + ! Define snow grain shape + IF (trim(snow_shape) == 'sphere') THEN + snw_shp_lcl(:) = snow_shape_sphere + ELSEIF (trim(snow_shape) == 'spheroid') THEN + snw_shp_lcl(:) = snow_shape_spheroid + ELSEIF (trim(snow_shape) == 'hexagonal_plate') THEN + snw_shp_lcl(:) = snow_shape_hexagonal_plate + ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN + snw_shp_lcl(:) = snow_shape_koch_snowflake + ELSE + IF (p_is_master) THEN + write(iulog,*) "snow_shape = ", snow_shape + CALL abort + ENDIF + ENDIF + + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (p_is_master) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL abort + ENDIF + ENDIF + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw) ) THEN + + ! Set variables specific to ELM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF ! END IF flg_snw_ice == 1 + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + ! Error check for snow grain size: + IF (p_is_master) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL abort + ENDIF + ENDDO + ENDIF + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ELSE + slr_zen = nint(acos(coszen) * 180._r8 / pi) + IF (slr_zen>89) THEN + slr_zen = 89 + ENDIF + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dir(atm_type_index, slr_zen+1, 2) + flx_wgt(3) = flx_wgt_dir(atm_type_index, slr_zen+1, 3) + flx_wgt(4) = flx_wgt_dir(atm_type_index, slr_zen+1, 4) + flx_wgt(5) = flx_wgt_dir(atm_type_index, slr_zen+1, 5) + ENDIF + + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ELSE + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dif(atm_type_index, 2) + flx_wgt(3) = flx_wgt_dif(atm_type_index, 3) + flx_wgt(4) = flx_wgt_dif(atm_type_index, 4) + flx_wgt(5) = flx_wgt_dif(atm_type_index, 5) + ENDIF + ENDIF + ENDIF ! END IF numrad_snw + + ! Loop over snow spectral bands + + exp_min = exp(-argmax) + DO bnd_idx = 1,numrad_snw + + ! note that we can remove flg_dover since this algorithm is + ! stable for mu_not > 0.01 + + ! mu_not is cosine solar zenith angle above the fresnel level; make + ! sure mu_not is large enough for stable and meaningful radiation + ! solution: .01 is like sun just touching horizon with its lower edge + ! equivalent to mu0 in sea-ice shortwave model ice_shortwave.F90 + mu_not = max(coszen, cp01) + + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + + ! Calculate the asymetry factors under different snow grain shapes + DO i=snl_top,snl_btm,1 + IF(snw_shp_lcl(i) == snow_shape_spheroid) THEN ! spheroid + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_sphd = 0.929_r8 + ELSE + fs_sphd = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 0.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_hex0 = 0.788_r8 + ELSE + fs_hex0 = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake + diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_koch = 0.712_r8 + ELSE + fs_koch = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_koch/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ENDIF + + ! Linear interpolation for calculating the asymetry factor at band_idx. + IF(snw_shp_lcl(i) > 1) THEN + IF(bnd_idx == 1) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 2) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 3) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 4) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 5) THEN + g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +g_ice_Cg_tmp(5) + gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +gg_ice_F07_tmp(5) + ENDIF + g_ice_F07 = gg_F07_intp + (1._r8 - gg_F07_intp) / ss_alb_snw_lcl(i) / 2._r8 + g_ice = g_ice_F07 * g_Cg_intp + asm_prm_snw_lcl(i) = g_ice + ENDIF + + IF(asm_prm_snw_lcl(i) > 0.99_r8) THEN + asm_prm_snw_lcl(i) = 0.99_r8 + ENDIF + + ENDDO + !!!-END + + !H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) + !H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + + ! Calculate single-scattering albedo for internal mixing of dust-snow + IF (use_dust_snow_internal_mixing) THEN + IF (bnd_idx < 4) THEN + C_dust_total = mss_cnc_aer_lcl(i,5) + mss_cnc_aer_lcl(i,6) & + + mss_cnc_aer_lcl(i,7) + mss_cnc_aer_lcl(i,8) + C_dust_total = C_dust_total * 1.0E+06_r8 + IF(C_dust_total > 0._r8) THEN + IF (flg_slr_in == 1) THEN + R_1_omega_tmp = dust_clear_d0(bnd_idx) & + + dust_clear_d2(bnd_idx)*(C_dust_total**dust_clear_d1(bnd_idx)) + ELSE + R_1_omega_tmp = dust_cloudy_d0(bnd_idx) & + + dust_cloudy_d2(bnd_idx)*(C_dust_total**dust_cloudy_d1(bnd_idx)) + ENDIF + ss_alb_snw_lcl(i) = 1.0_r8 - (1.0_r8 - ss_alb_snw_lcl(i)) *R_1_omega_tmp + ENDIF + ENDIF + DO j = 5,8,1 + ss_alb_aer_lcl(j) = 0._r8 + asm_prm_aer_lcl(j) = 0._r8 + ext_cff_mss_aer_lcl(j) = 0._r8 + ENDDO + ENDIF + + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + IF (use_dust_snow_internal_mixing .and. (j >= 5)) THEN + L_aer(i,j) = 0._r8 + ELSE + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + ENDIF + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO ! endWeighted Mie parameters of each layer + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Begin radiative transfer solver + ! Given input vertical profiles of optical properties, evaluate the + ! monochromatic Delta-Eddington adding-doubling solution + + ! note that trndir, trntdr, trndif, rupdir, rupdif, rdndif + ! are variables at the layer interface, + ! for snow with layers rangeing from snl_top to snl_btm + ! there are snl_top to snl_btm+1 layer interface + snl_btm_itf = snl_btm + 1 + + DO i = snl_top,snl_btm_itf,1 + trndir(i) = c0 + trntdr(i) = c0 + trndif(i) = c0 + rupdir(i) = c0 + rupdif(i) = c0 + rdndif(i) = c0 + ENDDO + + ! initialize top interface of top layer + trndir(snl_top) = c1 + trntdr(snl_top) = c1 + trndif(snl_top) = c1 + rdndif(snl_top) = c0 + + ! begin main level loop + ! for layer interfaces except for the very bottom + DO i = snl_top,snl_btm,1 + + ! initialize all layer apparent optical properties to 0 + rdir (i) = c0 + rdif_a(i) = c0 + rdif_b(i) = c0 + tdir (i) = c0 + tdif_a(i) = c0 + tdif_b(i) = c0 + trnlay(i) = c0 + + ! compute next layer Delta-eddington solution only IF total transmission + ! of radiation to the interface just above the layer exceeds trmin. + + IF (trntdr(i) > trmin ) THEN + + ! calculation over layers with penetrating radiation + + ! delta-transformed single-scattering properties + ! of this layer + ts = tau_star(i) + ws = omega_star(i) + gs = g_star(i) + + ! Delta-Eddington solution expressions + ! n(uu,et) = ((uu+c1)*(uu+c1)/et ) - ((uu-c1)*(uu-c1)*et) + ! u(w,gg,e) = c1p5*(c1 - w*gg)/e + ! el(w,gg) = sqrt(c3*(c1-w)*(c1 - w*gg)) + lm = sqrt(c3*(c1-ws)*(c1 - ws*gs)) !lm = el(ws,gs) + ue = c1p5*(c1 - ws*gs)/lm !ue = u(ws,gs,lm) + extins = max(exp_min, exp(-lm*ts)) + ne = ((ue+c1)*(ue+c1)/extins) - ((ue-c1)*(ue-c1)*extins) !ne = n(ue,extins) + + ! first calculation of rdif, tdif using Delta-Eddington formulas + ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne + rdif_a(i) = (ue**2-c1)*(c1/extins - extins)/ne + tdif_a(i) = c4*ue/ne + + ! evaluate rdir,tdir for direct beam + trnlay(i) = max(exp_min, exp(-ts/mu_not)) + + ! Delta-Eddington solution expressions + ! alpha(w,uu,gg,e) = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu)) + ! agamm(w,uu,gg,e) = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu)) + ! alp = alpha(ws,mu_not,gs,lm) + ! gam = agamm(ws,mu_not,gs,lm) + alp = cp75*ws*mu_not*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu_not*mu_not)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu_not*mu_not)/(c1-lm*lm*mu_not*mu_not)) + apg = alp + gam + amg = alp - gam + + rdir(i) = apg*rdif_a(i) + amg*(tdif_a(i)*trnlay(i) - c1) + tdir(i) = apg*tdif_a(i) + (amg* rdif_a(i)-apg+c1)*trnlay(i) + + ! recalculate rdif,tdif using direct angular integration over rdir,tdir, + ! since Delta-Eddington rdif formula is not well-behaved (it is usually + ! biased low and can even be negative); USE ngmax angles and gaussian + ! integration for most accuracy: + R1 = rdif_a(i) ! USE R1 as temporary + T1 = tdif_a(i) ! USE T1 as temporary + swt = c0 + smr = c0 + smt = c0 + DO ng=1,ngmax + mu = difgauspt(ng) + gwt = difgauswt(ng) + swt = swt + mu*gwt + trn = max(exp_min, exp(-ts/mu)) + ! alp = alpha(ws,mu,gs,lm) + ! gam = agamm(ws,mu,gs,lm) + alp = cp75*ws*mu*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu*mu)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu*mu)/(c1-lm*lm*mu*mu)) + apg = alp + gam + amg = alp - gam + rdr = apg*R1 + amg*T1*trn - amg + tdr = apg*T1 + amg*R1*trn - apg*trn + trn + smr = smr + mu*rdr*gwt + smt = smt + mu*tdr*gwt + ENDDO ! ng + rdif_a(i) = smr/swt + tdif_a(i) = smt/swt + + ! homogeneous layer + rdif_b(i) = rdif_a(i) + tdif_b(i) = tdif_a(i) + + ENDIF ! trntdr(k) > trmin + + ! Calculate the solar beam transmission, total transmission, and + ! reflectivity for diffuse radiation from below at interface i, + ! the top of the current layer k: + ! + ! layers interface + ! + ! --------------------- i-1 + ! i-1 + ! --------------------- i + ! i + ! --------------------- + + trndir(i+1) = trndir(i)*trnlay(i) + refkm1 = c1/(c1 - rdndif(i)*rdif_a(i)) + tdrrdir = trndir(i)*rdir(i) + tdndif = trntdr(i) - trndir(i) + trntdr(i+1) = trndir(i)*tdir(i) + & + (tdndif + tdrrdir*rdndif(i))*refkm1*tdif_a(i) + rdndif(i+1) = rdif_b(i) + & + (tdif_b(i)*rdndif(i)*refkm1*tdif_a(i)) + trndif(i+1) = trndif(i)*refkm1*tdif_a(i) + + ENDDO ! END main level loop + + + ! compute reflectivity to direct and diffuse radiation for layers + ! below by adding succesive layers starting from the underlying + ! ground and working upwards: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- i+1 + ! i+1 + ! --------------------- + + ! set the underlying ground albedo == albedo of near-IR + ! unless bnd_idx == 1, for visible + rupdir(snl_btm_itf) = albsfc(2) + rupdif(snl_btm_itf) = albsfc(2) + IF (bnd_idx == 1) THEN + rupdir(snl_btm_itf) = albsfc(1) + rupdif(snl_btm_itf) = albsfc(1) + ENDIF + + DO i=snl_btm,snl_top,-1 + ! interface scattering + refkp1 = c1/( c1 - rdif_b(i)*rupdif(i+1)) + ! dir from top layer plus exp tran ref from lower layer, interface + ! scattered and tran thru top layer from below, plus diff tran ref + ! from lower layer with interface scattering tran thru top from below + rupdir(i) = rdir(i) & + + ( trnlay(i) *rupdir(i+1) & + + (tdir(i)-trnlay(i))*rupdif(i+1))*refkp1*tdif_b(i) + ! dif from top layer from above, plus dif tran upwards reflected and + ! interface scattered which tran top from below + rupdif(i) = rdif_a(i) + tdif_a(i)*rupdif(i+1)*refkp1*tdif_b(i) + ENDDO ! i + + ! net flux (down-up) at each layer interface from the + ! snow top (i = snl_top) to bottom interface above land (i = snl_btm_itf) + ! the interface reflectivities and transmissivities required + ! to evaluate interface fluxes are returned from solution_dEdd; + ! now compute up and down fluxes for each interface, using the + ! combined layer properties at each interface: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- + + DO i = snl_top, snl_btm_itf + ! interface scattering + refk = c1/(c1 - rdndif(i)*rupdif(i)) + ! dir tran ref from below times interface scattering, plus diff + ! tran and ref from below times interface scattering + ! fdirup(i) = (trndir(i)*rupdir(i) + & + ! (trntdr(i)-trndir(i)) & + ! *rupdif(i))*refk + ! dir tran plus total diff trans times interface scattering plus + ! dir tran with up dir ref and down dif ref times interface scattering + ! fdirdn(i) = trndir(i) + (trntdr(i) & + ! - trndir(i) + trndir(i) & + ! *rupdir(i)*rdndif(i))*refk + ! diffuse tran ref from below times interface scattering + ! fdifup(i) = trndif(i)*rupdif(i)*refk + ! diffuse tran times interface scattering + ! fdifdn(i) = trndif(i)*refk + + ! netflux, down - up + ! dfdir = fdirdn - fdirup + dfdir(i) = trndir(i) & + + (trntdr(i)-trndir(i)) * (c1 - rupdif(i)) * refk & + - trndir(i)*rupdir(i) * (c1 - rdndif(i)) * refk + IF (dfdir(i) < puny) dfdir(i) = c0 + ! dfdif = fdifdn - fdifup + dfdif(i) = trndif(i) * (c1 - rupdif(i)) * refk + IF (dfdif(i) < puny) dfdif(i) = c0 + ENDDO ! k + + ! SNICAR_AD_RT is called twice for direct and diffuse incident fluxes + ! direct incident + IF (flg_slr_in == 1) THEN + albedo = rupdir(snl_top) + dftmp = dfdir + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = (trndir(snl_top)*rupdir(snl_top) + & + (trntdr(snl_top)-trndir(snl_top)) & + *rupdif(snl_top))*refk + !diffuse incident + ELSE + albedo = rupdif(snl_top) + dftmp = dfdif + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = trndif(snl_top)*rupdif(snl_top)*refk + ENDIF + + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + F_abs(i) = dftmp(i)-dftmp(i+1) + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + ! ERROR check: negative absorption + IF (p_is_master) THEN + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) + write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR_AD STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR_AD STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR_AD STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR_AD STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR_AD STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + CALL abort + ENDIF + ENDIF + ENDDO + + ! absobed flux by the underlying ground + F_btm_net = dftmp(snl_btm_itf) + + ! note here, snl_btm_itf = 1 by snow column set up in CLM + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + !ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (p_is_master) THEN + IF (abs(energy_sum) > 0.00001_r8) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum + write(iulog,*) "F_abs_sum: ",F_abs_sum + write(iulog,*) "F_btm_net: ",F_btm_net + write(iulog,*) "F_sfc_pls: ",F_sfc_pls + write(iulog,*) "mu_not*pi*flx_slrd_lcl(bnd_idx): ", mu_not*pi*flx_slrd_lcl(bnd_idx) + write(iulog,*) "flx_slri_lcl(bnd_idx)", flx_slri_lcl(bnd_idx) + write(iulog,*) "bnd_idx", bnd_idx + write(iulog,*) "F_abs", F_abs + write(iulog,*) "albedo", albedo + CALL abort + ENDIF + ENDIF + + albout_lcl(bnd_idx) = albedo + ! Check that albedo is less than 1 + IF (p_is_master) THEN + IF (albout_lcl(bnd_idx) > 1.0) THEN + write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL abort + ENDIF + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! near-IR direct albedo/absorption adjustment for high solar zenith angles + ! solar zenith angle parameterization + ! calculate the scaling factor for NIR direct albedo IF SZA>75 degree + IF ((mu_not < mu_75) .and. (flg_slr_in == 1)) THEN + sza_c1 = sza_a0 + sza_a1 * mu_not + sza_a2 * mu_not**2 + sza_c0 = sza_b0 + sza_b1 * mu_not + sza_b2 * mu_not**2 + sza_factor = sza_c1 * (log10(snw_rds_lcl(snl_top) * c1) - c6) + sza_c0 + flx_sza_adjust = albout(2) * (sza_factor-c1) * sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + albout(2) = albout(2) * sza_factor + flx_abs(snl_top,2) = flx_abs(snl_top,2) - flx_sza_adjust + ENDIF + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_AD_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_grain( dtime , snl , dz ,& + qflx_snow_grnd , qflx_snwcp_ice , qflx_snofrz_lyr ,& + do_capsnow , frac_sno , h2osno ,& + h2osno_liq , h2osno_ice , t_soisno ,& + t_grnd , forc_t , snw_rds ) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Updates the snow effective grain size (radius). +! Contributions to grain size evolution are from: +! 1. vapor redistribution (dry snow) +! 2. liquid water redistribution (wet snow) +! 3. re-freezing of liquid water +! +! Vapor redistribution: Method is to retrieve 3 best-bit parameters that +! depend on snow temperature, temperature gradient, and density, +! that are derived from the microphysical model described in: +! Flanner and Zender (2006), Linking snowpack microphysics and albedo +! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834. +! The parametric equation has the form: +! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), WHERE: +! r is the effective radius, +! tau and kappa are best-fit parameters, +! drdt_0 is the initial rate of change of effective radius, and +! dr_fresh is the difference between the current and fresh snow states +! (r_current - r_fresh). +! +! Liquid water redistribution: Apply the grain growth FUNCTION from: +! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of +! liquid-water content, Annals of Glaciology, 13, 22-26. +! There are two parameters that describe the grain growth rate as +! a FUNCTION of snow liquid water content (LWC). The "LWC=0" parameter +! is zeroed here because we are accounting for dry snowing with a +! different representation +! +! Re-freezing of liquid water: Assume that re-frozen liquid water clumps +! into an arbitrarily large effective grain size (snw_rds_refrz). +! The phenomenon is observed (Grenfell), but so far unquantified, as far as +! I am aware. +! +! !USES: +! +! DAI, Dec. 29, 2022 +!----------------------------------------------------------------------- +! !ARGUMENTS: + + IMPLICIT NONE + + real(r8) , intent(in) :: dtime ! land model time step [sec] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: dz ( maxsnl+1:1 ) ! layer thickness (col,lyr) [m] + + real(r8) , intent(in) :: qflx_snow_grnd ! snow on ground after interception (col) [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snofrz_lyr ( maxsnl+1:0 ) ! snow freezing rate (col,lyr) [kg m-2 s-1] + + logical , intent(in) :: do_capsnow ! true => DO snow capping + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8) , intent(in) :: h2osno ! snow water (col) [mm H2O] + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg m-2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg m-2] + + real(r8) , intent(in) :: t_soisno ( maxsnl+1:1 ) ! soil and snow temperature (col,lyr) [K] + real(r8) , intent(in) :: t_grnd ! ground temperature (col) [K] + real(r8) , intent(in) :: forc_t ! Atmospheric temperature (col) [K] + + real(r8) , intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective grain radius (col,lyr) [microns, m-6] + + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: snl_top ! top snow layer index [idx] + integer :: snl_btm ! bottom snow layer index [idx] + integer :: i ! layer index [idx] + ! integer :: c_idx ! column index [idx] + integer :: fc ! snow column filter index [idx] + integer :: T_idx ! snow aging lookup table temperature index [idx] + integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx] + integer :: rhos_idx ! snow aging lookup table snow density index [idx] + real(r8) :: t_snotop ! temperature at upper layer boundary [K] + real(r8) :: t_snobtm ! temperature at lower layer boundary [K] + real(r8) :: dTdz(maxsnl:0) ! snow temperature gradient (col,lyr) [K m-1] + real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour] + real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless] + real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1] + real(r8) :: dr ! incremental change in snow effective radius [um] + real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um] + real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um] + real(r8) :: newsnow ! fresh snowfall [kg m-2] + real(r8) :: refrzsnow ! re-frozen snow [kg m-2] + real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc] + real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc] + real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc] + real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc] + real(r8) :: rhos ! snow density [kg m-3] + real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2] + real(r8) :: cdz(maxsnl+1:0) ! column average layer thickness [m] + real(r8) :: snw_rds_fresh ! fresh snow radius [microns] + + real(r8) :: snot_top ! temperature in top snow layer (col) [K] + real(r8) :: dTdz_top ! temperature gradient in top layer (col) [K m-1] + real(r8) :: snw_rds_top ! effective grain radius, top layer (col) [microns, m-6] + real(r8) :: sno_liq_top ! liquid water fraction (mass) in top snow layer (col) [frc] + + !--------------------------------------------------------------------------! + + ! associate( & + ! snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers (col) [nbr] + ! dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness (col,lyr) [m] + + ! qflx_snow_grnd => col_wf%qflx_snow_grnd , & ! Input: [real(r8) (:) ] snow on ground after interception (col) [kg m-2 s-1] + ! qflx_snwcp_ice => col_wf%qflx_snwcp_ice , & ! Input: [real(r8) (:) ] excess precipitation due to snow capping [kg m-2 s-1] + ! qflx_snofrz_lyr => col_wf%qflx_snofrz_lyr , & ! Input: [real(r8) (:,:) ] snow freezing rate (col,lyr) [kg m-2 s-1] + + ! do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => DO snow capping + ! frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (col) [mm H2O] + ! h2osno_liq => col_ws%h2osno_liq , & ! Input: [real(r8) (:,:) ] liquid water content (col,lyr) [kg m-2] + ! h2osno_ice => col_ws%h2osno_ice , & ! Input: [real(r8) (:,:) ] ice content (col,lyr) [kg m-2] + ! snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective grain radius (col,lyr) [microns, m-6] + ! snw_rds_top => col_ws%snw_rds_top , & ! Output: [real(r8) (:) ] effective grain radius, top layer (col) [microns, m-6] + ! sno_liq_top => col_ws%sno_liq_top , & ! Output: [real(r8) (:) ] liquid water fraction (mass) in top snow layer (col) [frc] + + ! t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil and snow temperature (col,lyr) [K] + ! t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground temperature (col) [K] + ! snot_top => col_es%snot_top , & ! Output: [real(r8) (:) ] temperature in top snow layer (col) [K] + ! dTdz_top => col_es%dTdz_top & ! Output: [real(r8) (:) ] temperature gradient in top layer (col) [K m-1] + ! ) + + + IF (snl < 0 .and. h2osno > 0._r8) THEN + + snl_btm = 0 + snl_top = snl + 1 + + cdz(snl_top:snl_btm)=frac_sno*dz(snl_top:snl_btm) + + ! loop over snow layers + DO i = snl_top, snl_btm, 1 + ! + !********** 1. DRY SNOW AGING *********** + ! + h2osno_lyr = h2osno_liq(i) + h2osno_ice(i) + + ! temperature gradient + IF (i == snl_top) THEN + ! top layer + t_snotop = t_soisno(snl_top) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ELSE + t_snotop = (t_soisno(i-1)*dz(i) & + + t_soisno(i)*dz(i-1)) & + / (dz(i)+dz(i-1)) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ENDIF + + dTdz(i) = abs((t_snotop - t_snobtm) / cdz(i)) + + ! snow density + rhos = (h2osno_liq(i)+h2osno_ice(i)) / cdz(i) + + ! make sure rhos doesn't drop below 50 (see rhos_idx below) + rhos=max(50._r8,rhos) + + ! best-fit table indecies + T_idx = nint((t_soisno(i)-223) / 5) + 1 + Tgrd_idx = nint(dTdz(i) / 10) + 1 + rhos_idx = nint((rhos-50) / 50) + 1 + + ! boundary check: + IF (T_idx < idx_T_min) THEN + T_idx = idx_T_min + ENDIF + IF (T_idx > idx_T_max) THEN + T_idx = idx_T_max + ENDIF + IF (Tgrd_idx < idx_Tgrd_min) THEN + Tgrd_idx = idx_Tgrd_min + ENDIF + IF (Tgrd_idx > idx_Tgrd_max) THEN + Tgrd_idx = idx_Tgrd_max + ENDIF + IF (rhos_idx < idx_rhos_min) THEN + rhos_idx = idx_rhos_min + ENDIF + IF (rhos_idx > idx_rhos_max) THEN + rhos_idx = idx_rhos_max + ENDIF + + ! best-fit parameters + bst_tau = snowage_tau(rhos_idx,Tgrd_idx,T_idx) + bst_kappa = snowage_kappa(rhos_idx,Tgrd_idx,T_idx) + bst_drdt0 = snowage_drdt0(rhos_idx,Tgrd_idx,T_idx) + + ! change in snow effective radius, using best-fit parameters + ! added checks suggested by mgf. --HW 10/15/2015 + dr_fresh = snw_rds(i)-snw_rds_min + +#ifdef MODAL_AER + IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN + dr_fresh = 0.0_r8 + ELSEIF ( dr_fresh < 0.0_r8 ) THEN + IF (p_is_master) THEN + write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min + CALL abort + ENDIF + ENDIF + + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) +#else + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1/bst_kappa)) * (dtime/3600) +#endif + ! + !********** 2. WET SNOW AGING *********** + ! + ! We are assuming wet and dry evolution occur simultaneously, and + ! the contributions from both can be summed. + ! This is justified by setting the linear offset constant C1_liq_Brun89 to zero [Brun, 1989] + + ! liquid water faction + frc_liq = min(0.1_r8, (h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)))) + + !dr_wet = 1E6_r8*(dtime*(C1_liq_Brun89 + C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*(snw_rds(i)/1E6)**(2))) + !simplified, units of microns: + dr_wet = 1E18_r8*(dtime*(C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*snw_rds(i)**(2))) + + dr = dr + dr_wet + + ! + !********** 3. SNOWAGE SCALING (TURNED OFF BY DEFAULT) ************* + ! + ! Multiply rate of change of effective radius by some constant, xdrdt + IF (flg_snoage_scl) THEN + dr = dr*xdrdt + ENDIF + + ! + !********** 4. INCREMENT EFFECTIVE RADIUS, ACCOUNTING FOR: *********** + ! DRY AGING + ! WET AGING + ! FRESH SNOW + ! RE-FREEZING + ! + ! new snowfall [kg/m2] + IF (do_capsnow .and. .not. use_extrasnowlayers) THEN + newsnow = max(0._r8, (qflx_snwcp_ice*dtime)) + ELSE + newsnow = max(0._r8, (qflx_snow_grnd*dtime)) + ENDIF + + ! snow that has re-frozen [kg/m2] + refrzsnow = max(0._r8, (qflx_snofrz_lyr(i)*dtime)) + + ! fraction of layer mass that is re-frozen + frc_refrz = refrzsnow / h2osno_lyr + + ! fraction of layer mass that is new snow + IF (i == snl_top) THEN + frc_newsnow = newsnow / h2osno_lyr + ELSE + frc_newsnow = 0._r8 + ENDIF + + IF ((frc_refrz + frc_newsnow) > 1._r8) THEN + frc_refrz = frc_refrz / (frc_refrz + frc_newsnow) + frc_newsnow = 1._r8 - frc_refrz + frc_oldsnow = 0._r8 + ELSE + frc_oldsnow = 1._r8 - frc_refrz - frc_newsnow + ENDIF + + ! temperature dependent fresh grain size + snw_rds_fresh = FreshSnowRadius (forc_t) + + ! mass-weighted mean of fresh snow, old snow, and re-frozen snow effective radius + snw_rds(i) = (snw_rds(i)+dr)*frc_oldsnow + snw_rds_fresh*frc_newsnow + snw_rds_refrz*frc_refrz + ! + !********** 5. CHECK BOUNDARIES *********** + ! + ! boundary check + IF (snw_rds(i) < snw_rds_min) THEN + snw_rds(i) = snw_rds_min + ENDIF + + IF (snw_rds(i) > snw_rds_max) THEN + snw_rds(i) = snw_rds_max + ENDIF + + ! set top layer variables for history files + IF (i == snl_top) THEN + snot_top = t_soisno(i) + dTdz_top = dTdz(i) + snw_rds_top = snw_rds(i) + sno_liq_top = h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)) + ENDIF + + ENDDO + ENDIF ! ENDIF (snl < 0 ) + + ! Special CASE: snow on ground, but not enough to have defined a snow layer: + ! set snw_rds to fresh snow grain size: + + IF (snl >= 0 .and. h2osno > 0._r8) THEN + snw_rds(0) = snw_rds_min + ENDIF + + ! END associate + + END SUBROUTINE SnowAge_grain + !----------------------------------------------------------------------- + + + SUBROUTINE SnowOptics_init( fsnowoptics ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowoptics ! snow optical properties file name + character(len= 32) :: subname = 'SnowOptics_init' ! SUBROUTINE name + integer :: atm_type_index ! index for atmospheric type + + logical :: readvar ! determine IF variable was read from NetCDF file + !----------------------------------------------------------------------- + + readvar = .true. + + atm_type_index = atm_type_default + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (p_is_master) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL abort + ENDIF + ENDIF + + ! + ! Open optics file: + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read snow optical properties .....' + write(iulog,*) subname,trim(fsnowoptics) + ENDIF + + ! direct-beam snow Mie parameters: + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_drc', ss_alb_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_drc', asm_prm_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_drc', ext_cff_mss_snw_drc) + + ! diffuse snow Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_dfs', ss_alb_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_dfs', asm_prm_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_dfs', ext_cff_mss_snw_dfs) + + !!! Direct and diffuse flux under different atmospheric conditions + ! Direct-beam incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dir', flx_wgt_dir) + + ! Diffuse incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dif', flx_wgt_dif) + +#ifdef MODAL_AER + ! size-dependent BC parameters and BC enhancement factors + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' + ENDIF + ! + ! BC species 1 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc1) + ! + ! BC species 2 Mie parameters (identical, before enhancement factors applied) + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc2) + ! + ! size-dependent BC absorption enhancement factors for within-ice BC + CALL ncio_read_bcast_serial (fsnowoptics, 'bcint_enh_mam', bcenh) + ! +#else + ! bulk aerosol treatment + ! BC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphil', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphil', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphil', ext_cff_mss_bc1) + + ! + ! BC species 2 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphob', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphob', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphob', ext_cff_mss_bc2) + ! +#endif + ! + ! OC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphil', ss_alb_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphil', asm_prm_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphil', ext_cff_mss_oc1) + ! + ! OC species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphob', ss_alb_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphob', asm_prm_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphob', ext_cff_mss_oc2) + ! + ! dust species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust01', ss_alb_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust01', asm_prm_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust01', ext_cff_mss_dst1) + ! + ! dust species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust02', ss_alb_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust02', asm_prm_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust02', ext_cff_mss_dst2) + ! + ! dust species 3 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust03', ss_alb_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust03', asm_prm_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust03', ext_cff_mss_dst3) + ! + ! dust species 4 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust04', ss_alb_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust04', asm_prm_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust04', ext_cff_mss_dst4) + ! + ! + + IF (p_is_master) THEN + write(iulog,*) 'Successfully read snow optical properties' + ENDIF + + + ! print some diagnostics: + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & + ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & + ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & + ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & + ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' + ELSE + write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' + ENDIF + ENDIF + ! +#ifdef MODAL_AER + IF (p_is_master) THEN + ! unique dimensionality for modal aerosol optical properties + write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & + ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of Mie mass extinction coefficients for BC: ', & + ext_cff_mss_bc2(1,1), ext_cff_mss_bc2(1,2), ext_cff_mss_bc2(2,1), ext_cff_mss_bc2(5,1), ext_cff_mss_bc2(1,10),& + ext_cff_mss_bc1(1,10) + write (iulog,*) 'SNICAR: Subset of Mie asymmetry parameters for BC: ', & + asm_prm_bc1(1,1), asm_prm_bc1(1,2), asm_prm_bc1(2,1), asm_prm_bc1(5,1), asm_prm_bc1(1,10), asm_prm_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of BC absorption enhancement factors: ', & + bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) + ENDIF +#else + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & + ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & + ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) + ENDIF +#endif + + IF (p_is_master) THEN + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & + ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & + ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) + ENDIF + + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & + ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & + ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & + ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & + ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) + write(iulog,*) + ENDIF + + END SUBROUTINE SnowOptics_init + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_init( fsnowaging ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowaging ! snow aging parameters file name + character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name + ! + ! Open snow aging (effective radius evolution) file: + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read snow aging parameters .....' + write(iulog,*) subname,trim(fsnowaging) + ENDIF + + ! + ! SNOW aging parameters + ! + CALL ncio_read_bcast_serial (fsnowaging, 'tau', snowage_tau) + CALL ncio_read_bcast_serial (fsnowaging, 'kappa', snowage_kappa) + CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) + + ! + IF (p_is_master) THEN + write(iulog,*) 'Successfully read snow aging properties' + ENDIF + ! + ! print some diagnostics: + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) + write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) + write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) + ENDIF + + END SUBROUTINE SnowAge_init + !----------------------------------------------------------------------- + + + real(r8) FUNCTION FreshSnowRadius (forc_t) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Returns fresh snow grain radius, which is linearly dependent on temperature. +! This is implemented to remedy an outstanding bias that SNICAR has in initial +! grain size. See e.g. Sandells et al, 2017 for a discussion (10.5194/tc-11-229-2017). +! +! Yang et al. (2017), 10.1016/j.jqsrt.2016.03.033 +! discusses grain size observations, which suggest a temperature dependence. +! +! !REVISION HISTORY: +! Author: Leo VanKampenhout +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Const_Physical, only: tfrz + USE MOD_Aerosol, only: fresh_snw_rds_max + + ! !ARGUMENTS: + real(r8), intent(in) :: forc_t ! atmospheric temperature (Kelvin) + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + real(r8), parameter :: tmin = tfrz - 30._r8 ! start of linear ramp + real(r8), parameter :: tmax = tfrz - 0._r8 ! END of linear ramp + real(r8), parameter :: gs_min = snw_rds_min ! minimum value + real(r8) :: gs_max ! maximum value + + IF ( fresh_snw_rds_max <= snw_rds_min )THEN + FreshSnowRadius = snw_rds_min + ELSE + gs_max = fresh_snw_rds_max + + IF (forc_t < tmin) THEN + FreshSnowRadius = gs_min + ELSEIF (forc_t > tmax) THEN + FreshSnowRadius = gs_max + ELSE + FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & + (forc_t-tmin)/(tmax-tmin)*gs_max + ENDIF + ENDIF + + END FUNCTION FreshSnowRadius + +END MODULE MOD_SnowSnicar +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 new file mode 100644 index 0000000000..98a3ef8b5b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 @@ -0,0 +1,2994 @@ +#include + +!------------------------------------------------------------------------- +MODULE MOD_SnowSnicar_HiRes + + !----------------------------------------------------------------------- + ! DESCRIPTION: + ! Calculate albedo of snow containing impurities + ! and the evolution of snow effective radius + ! + ! ORIGINAL: + ! 1) The Community Land Model version 5.0 (CLM5.0) + ! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) + ! + ! REFERENCES: + ! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. + ! Geosci. Model Dev., 14, 7673–7704, https://doi.org/10.5194/gmd-14-7673-2021 + ! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) + ! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. + ! Geosci. Model Dev., 16, 75–94, https://doi.org/10.5194/gmd-16-75-2023 + ! + ! REVISIONS: + ! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING + ! + ! !USES: + USE MOD_Precision + USE MOD_Vars_Global, only: maxsnl + USE MOD_SPMD_Task + + IMPLICIT NONE +! SAVE + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice (kg/m^3) + + integer, parameter :: iulog = 6 ! "stdout" log file unit number, default is 6 + integer, parameter :: numrad = 5 ! number of solar radiation bands: vis, nir + +!-------------------------------------------------------------------- +! DAI, Dec. 29, 2022 +! Temporay setting + + logical, parameter :: use_extrasnowlayers = .false. + character(len=256), parameter :: snow_shape = 'sphere' ! (=1), 'spheroid'(=2), 'hexagonal_plate'(=3), 'koch_snowflake'(=4) + logical, parameter :: use_dust_snow_internal_mixing = .false. + character(len=256), parameter :: snicar_atm_type = 'default' ! Atmospheric profile used to obtain surface-incident spectral flux distribution + ! and subsequent broadband albedo + ! = 'mid-latitude_winter' ! => 1 + ! = 'mid-latitude_summer' ! => 2 + ! = 'sub-Arctic_winter' ! => 3 + ! = 'sub-Arctic_summer' ! => 4 + ! = 'summit_Greenland' ! => 5 (sub-Arctic summer, surface pressure of 796hPa) + ! = 'high_mountain' ! => 6 (summer, surface pressure of 556 hPa) +!DAI, Dec. 29, 2022 +!----------------------------------------------------------------------- + + ! !PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption + PUBLIC :: SNICAR_AD_RT ! Snow albedo and vertically-resolved solar absorption by adding-doubling solution + ! To USE this subtroutine, set use_snicar_ad = true + PUBLIC :: SnowAge_grain ! Snow effective grain size evolution + PUBLIC :: SnowAge_init ! Initial read in of snow-aging file + PUBLIC :: SnowOptics_init ! Initial read in of snow-optics file + ! + ! !PUBLIC DATA MEMBERS: + integer, PUBLIC, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + ! (indices described above) [nbr] + logical, PUBLIC, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) + ! in snowpack radiative calculations + logical, PUBLIC, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + ! !PRIVATE DATA MEMBERS: + integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] + integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] + integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] + integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] + integer, parameter :: idx_T_max = 11 ! maxiumum temperature index used in aging lookup table [idx] + integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_max = 31 ! maxiumum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_rhos_max = 8 ! maxiumum snow density index used in aging lookup table [idx] + integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] + +#ifdef MODAL_AER + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + !mgf++ + integer, parameter :: idx_bc_nclrds_min = 1 ! minimum index for BC particle size in optics lookup table + integer, parameter :: idx_bc_nclrds_max = 10 ! maximum index for BC particle size in optics lookup table + integer, parameter :: idx_bcint_icerds_min = 1 ! minimum index for snow grain size in optics lookup table for within-ice BC + integer, parameter :: idx_bcint_icerds_max = 8 ! maximum index for snow grain size in optics lookup table for within-ice BC + !mgf-- +#endif + + integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] + integer, parameter :: snw_rds_min_tbl = 30 ! minimium effective radius defined in Mie lookup table [microns] + real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns + real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] + real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] + !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89 + real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: zeroed to accomodate dry snow aging + real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: corrected for LWC in units of percent + + real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice + ! [s-1] (50% mass removal/year) + !$acc declare copyin(C1_liq_Brun89, C2_liq_Brun89, & + !$acc tim_cns_bc_rmv, tim_cns_oc_rmv, tim_cns_dst_rmv) + + ! scaling of the snow aging rate (tuning option): + logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor + real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate + ! snow and aerosol Mie parameters: + ! (arrays declared here, but are set in iniTimeConst) + ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) + + ! direct-beam weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_drc(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! diffuse radiation weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_dfs(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! direct & diffuse flux + real(r8), allocatable :: flx_wgt_dir (:,:,:) ! (6, 90, numrad_snw) ! direct flux, six atmospheric types, 0-89 SZA + real(r8), allocatable :: flx_wgt_dif (:,:) ! (6, numrad_snw) ! diffuse flux, six atmospheric types + + ! snow grain shape + integer, parameter :: snow_shape_sphere = 1 + integer, parameter :: snow_shape_spheroid = 2 + integer, parameter :: snow_shape_hexagonal_plate = 3 + integer, parameter :: snow_shape_koch_snowflake = 4 + + ! atmospheric condition for SNICAR-AD + integer, parameter :: atm_type_default = 0 + integer, parameter :: atm_type_mid_latitude_winter = 1 + integer, parameter :: atm_type_mid_latitude_summer = 2 + integer, parameter :: atm_type_sub_Arctic_winter = 3 + integer, parameter :: atm_type_sub_Arctic_summer = 4 + integer, parameter :: atm_type_summit_Greenland = 5 + integer, parameter :: atm_type_high_mountain = 6 + +#ifdef MODAL_AER + !mgf++ + ! Size-dependent BC optical properties. Currently a fixed BC size is + ! assumed, but this framework enables optical properties to be + ! assigned based on the BC effective radius, should this be + ! implemented in the future. + ! + ! within-ice BC (i.e., BC that was deposited within hydrometeors) + real(r8), allocatable :: ss_alb_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc1(:,:) ! (numrad_snw,idx_bc_nclrds_max); + + ! external BC + real(r8), allocatable :: ss_alb_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc2(:,:) ! (numrad_snw,idx_bc_nclrds_max); + !mgf-- +#else + ! hydrophiliic BC + real(r8), allocatable :: ss_alb_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc1(:) ! (numrad_snw); + + ! hydrophobic BC + real(r8), allocatable :: ss_alb_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc2(:) ! (numrad_snw); +#endif + + ! hydrophobic OC + real(r8), allocatable :: ss_alb_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc1(:) ! (numrad_snw); + + ! hydrophilic OC + real(r8), allocatable :: ss_alb_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc2(:) ! (numrad_snw); + + ! dust species 1: + real(r8), allocatable :: ss_alb_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst1(:) ! (numrad_snw); + + ! dust species 2: + real(r8), allocatable :: ss_alb_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst2(:) ! (numrad_snw); + + ! dust species 3: + real(r8), allocatable :: ss_alb_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst3(:) ! (numrad_snw); + + ! dust species 4: + real(r8), allocatable :: ss_alb_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst4(:) ! (numrad_snw); + +#ifdef MODAL_AER + ! Absorption enhancement factors for within-ice BC + real(r8), allocatable :: bcenh (:,:,:) ! (numrad_snw,idx_bc_nclrds_max,idx_bcint_icerds_max); +#endif + + ! best-fit parameters for snow aging defined over: + ! 11 temperatures from 225 to 273 K + ! 31 temperature gradients from 0 to 300 K/m + ! 8 snow densities from 0 to 350 kg/m3 + ! (arrays declared here, but are set in iniTimeConst) + ! + real(r8), allocatable :: snowage_tau (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [hour] + real(r8), allocatable :: snowage_kappa (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [unitless] + real(r8), allocatable :: snowage_drdt0 (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [um hr-1] + + ! + ! !REVISION HISTORY: + ! Created by Mark Flanner + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) + ! + ! !DESCRIPTION: + ! Determine reflectance of, and vertically-resolved solar absorption in, + ! snow with impurities. + ! + ! Original references on physical models of snow reflectance include: + ! Wiscombe and Warren [1980] and Warren and Wiscombe [1980], + ! Journal of Atmospheric Sciences, 37, + ! + ! The multi-layer solution for multiple-scattering used here is from: + ! Toon et al. [1989], Rapid calculation of radiative heating rates + ! and photodissociation rates in inhomogeneous multiple scattering atmospheres, + ! J. Geophys. Res., 94, D13, 16287-16301 + ! + ! The implementation of the SNICAR model in CLM/CSIM is described in: + ! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007], + ! Present-day climate forcing and response from black carbon in snow, + ! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003 + ! + ! !USES: + ! + ! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: APRX_TYP ! two-stream approximation type + ! (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr] + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: n ! tridiagonal matrix index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_direct(maxsnl+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_net(maxsnl+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + ! intermediate variables for radiative transfer approximation: + real(r8):: gamma1(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma2(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma3(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma4(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: lambda(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: GAMMA(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: e1(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e2(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e3(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e4(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: C_pls_btm(maxsnl+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2] + real(r8):: C_mns_btm(maxsnl+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2] + real(r8):: C_pls_top(maxsnl+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2] + real(r8):: C_mns_top(maxsnl+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2] + real(r8):: A(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: B(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: D(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: E(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: AS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: DS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: X(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: Y(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw)) THEN + + ! Set variables specific to CLM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + + ! Error check for snow grain size: +#ifndef _OPENACC + IF (p_is_master) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL abort + ENDIF + ENDDO + ENDIF +#endif + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ENDIF + ENDIF + + ! Loop over snow spectral bands + DO bnd_idx = 1,numrad_snw + + mu_not = coszen ! must set here, because of error handling + flg_dover = 1 ! default is to redo + err_idx = 0 ! number of times through loop + + DO WHILE (flg_dover > 0) + + ! DEFAULT APPROXIMATIONS: + ! VIS: Delta-Eddington + ! NIR (all): Delta-Hemispheric Mean + ! WARNING: DO NOT USE DELTA-EDDINGTON FOR NIR DIFFUSE - this sometimes results in negative albedo + ! + ! ERROR CONDITIONS: + ! Conditions which cause "trip", resulting in redo of RT approximation: + ! 1. negative absorbed flux + ! 2. total absorbed flux greater than incident flux + ! 3. negative albedo + ! NOTE: These errors have only been encountered in spectral bands 4 and 5 + ! + ! ERROR HANDLING + ! 1st error (flg_dover=2): switch approximation (Edd->HM or HM->Edd) + ! 2nd error (flg_dover=3): change zenith angle by 0.02 (this happens about 1 in 10^6 cases) + ! 3rd error (flg_dover=4): switch approximation with new zenith + ! Subsequent errors: repeatedly change zenith and approximations... + + IF (bnd_idx == 1) THEN + IF (flg_dover == 2) THEN + APRX_TYP = 3 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 1 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 3 + ELSE + APRX_TYP = 1 + ENDIF + + ELSE + IF (flg_dover == 2) THEN + APRX_TYP = 1 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 3 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 1 + ELSE + APRX_TYP = 3 + ENDIF + + ENDIF + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + +!H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +!H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Total column optical depth: + ! tau_elm(i) = total optical depth above the bottom of layer i + tau_elm(snl_top) = 0._r8 + DO i=snl_top+1,snl_btm,1 + tau_elm(i) = tau_elm(i-1)+tau_star(i-1) + ENDDO + + ! Direct radiation at bottom of snowpack: + F_direct_btm = albsfc_lcl(bnd_idx)*mu_not * & + exp(-(tau_elm(snl_btm)+tau_star(snl_btm))/mu_not)*pi*flx_slrd_lcl(bnd_idx) + + ! Intermediates + ! Gamma values are approximation-specific. + + ! Eddington + IF (APRX_TYP==1) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (7-(omega_star(i)*(4+(3*g_star(i)))))/4 + gamma2(i) = -(1-(omega_star(i)*(4-(3*g_star(i)))))/4 + gamma3(i) = (2-(3*g_star(i)*mu_not))/4 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + + ! Quadrature + ELSEIF (APRX_TYP==2) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2 + gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2 + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 1/(3**0.5) + ENDDO + + ! Hemispheric Mean + ELSEIF (APRX_TYP==3) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = 2 - (omega_star(i)*(1+g_star(i))) + gamma2(i) = omega_star(i)*(1-g_star(i)) + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + ENDIF + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + lambda(i) = sqrt(abs((gamma1(i)**2) - (gamma2(i)**2))) + GAMMA(i) = gamma2(i)/(gamma1(i)+lambda(i)) + + e1(i) = 1+(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e2(i) = 1-(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e3(i) = GAMMA(i) + exp(-lambda(i)*tau_star(i)) + e4(i) = GAMMA(i) - exp(-lambda(i)*tau_star(i)) + ENDDO !ENDDO over snow layers + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + IF (flg_slr_in == 1) THEN + + C_pls_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)-(1/mu_not))*gamma3(i))+ & + (gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)+(1/mu_not))*gamma4(i))+ & + (gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_pls_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)-(1/mu_not))* & + gamma3(i))+(gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)+(1/mu_not))* & + gamma4(i))+(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + ELSE + C_pls_btm(i) = 0._r8 + C_mns_btm(i) = 0._r8 + C_pls_top(i) = 0._r8 + C_mns_top(i) = 0._r8 + ENDIF + ENDDO + + ! Coefficients for tridiaganol matrix solution + DO i=2*snl_lcl+1,0,1 + + !Boundary values for i=1 and i=2*snl_lcl, specifics for i=odd and i=even + IF (i==(2*snl_lcl+1)) THEN + A(i) = 0 + B(i) = e1(snl_top) + D(i) = -e2(snl_top) + E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top) + + ELSEIF(i==0) THEN + A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm)) + B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm)) + D(i) = 0 + E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm)) + + ELSEIF(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) + n=floor(i/2.0) + A(i) = (e2(n)*e3(n))-(e4(n)*e1(n)) + B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1)) + D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1)) + E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1))) + + ELSEIF(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl + n=(i/2) + A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1)) + B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1)) + D(i) = (e1(n+1)*e4(n+1))-(e2(n+1)*e3(n+1)) + E(i) = (e2(n+1)*(C_pls_top(n+1)-C_pls_btm(n)))+(e4(n+1)*(C_mns_top(n+1)-C_mns_btm(n))) + ENDIF + ENDDO + + AS(0) = A(0)/B(0) + DS(0) = E(0)/B(0) + + DO i=-1,(2*snl_lcl+1),-1 + X(i) = 1/(B(i)-(D(i)*AS(i+1))) + AS(i) = A(i)*X(i) + DS(i) = (E(i)-(D(i)*DS(i+1)))*X(i) + ENDDO + + Y(2*snl_lcl+1) = DS(2*snl_lcl+1) + DO i=(2*snl_lcl+2),0,1 + Y(i) = DS(i)-(AS(i)*Y(i-1)) + ENDDO + + ! Downward direct-beam and net flux (F_net) at the base of each layer: + DO i=snl_top,snl_btm,1 + F_direct(i) = mu_not*pi*flx_slrd_lcl(bnd_idx)*exp(-(tau_elm(i)+tau_star(i))/mu_not) + F_net(i) = (Y(2*i-1)*(e1(i)-e3(i))) + (Y(2*i)*(e2(i)-e4(i))) + & + C_pls_btm(i) - C_mns_btm(i) - F_direct(i) + ENDDO + + ! Upward flux at snowpack top: + F_sfc_pls = (Y(2*snl_lcl+1)*(exp(-lambda(snl_top)*tau_star(snl_top))+ & + GAMMA(snl_top))) + (Y(2*snl_lcl+2)*(exp(-lambda(snl_top)* & + tau_star(snl_top))-GAMMA(snl_top))) + C_pls_top(snl_top) + + ! Net flux at bottom = absorbed radiation by underlying surface: + F_btm_net = -F_net(snl_btm) + + + ! Bulk column albedo and surface net flux + albedo = F_sfc_pls/((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + F_sfc_net = F_sfc_pls - ((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + + trip = 0 + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + IF(i==snl_top) THEN + F_abs(i) = F_net(i)-F_sfc_net + ELSE + F_abs(i) = F_net(i)-F_net(i-1) + ENDIF + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + + ! ERROR check: negative absorption + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + trip = 1 + ENDIF + ENDDO + + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + + !ERROR check: absorption greater than incident flux + ! (should make condition more generic than "1._r8") + IF (F_abs_sum > 1._r8) THEN + trip = 1 + ENDIF + + !ERROR check: + IF ((albedo < 0._r8).and.(trip==0)) THEN + trip = 1 + ENDIF + + ! Set conditions for redoing RT calculation + IF ((trip == 1).and.(flg_dover == 1)) THEN + flg_dover = 2 + ELSEIF ((trip == 1).and.(flg_dover == 2)) THEN + flg_dover = 3 + ELSEIF ((trip == 1).and.(flg_dover == 3)) THEN + flg_dover = 4 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN + flg_dover = 3 + err_idx = err_idx + 1 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN + flg_dover = 0 +#ifndef _OPENACC + IF (p_is_master) THEN + write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice + write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + write(iulog,*) "frac_sno: ", frac_sno + CALL abort + ENDIF +#endif + ELSE + flg_dover = 0 + ENDIF + + ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (abs(energy_sum) > 0.00001_r8) THEN +#ifndef _OPENACC + IF (p_is_master) THEN + write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum + CALL abort + ENDIF +#endif + ENDIF + + albout_lcl(bnd_idx) = albedo + + ! Check that albedo is less than 1 + IF (albout_lcl(bnd_idx) > 1.0) THEN +#ifndef _OPENACC + IF (p_is_master) THEN + write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL abort + ENDIF +#endif + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) + ! + ! !DESCRIPTION: + ! Determine reflectance of, and vertically-resolved solar absorption in, + ! snow with impurities, with updated shortwave scheme + ! + ! The multi-layer solution for multiple-scattering used here is from: + ! Briegleb, P. and Light, B.: A Delta-Eddington mutiple scattering + ! parameterization for solar radiation in the sea ice component of the + ! community climate system model, 2007. + ! + ! The implementation of the SNICAR-AD model in ELM is described in: + ! Dang et al., Inter-comparison and improvement of 2-stream shortwave + ! radiative transfer models for unified treatment of cryospheric surfaces + ! in ESMs, in review, 2019 + ! + ! To USE this subtroutine, set use_snicar_ad = true in ELM + ! + ! IF config_use_snicar_ad = true in MPAS-seaice + ! Snow on land and snow on sea ice will be treated + ! with the same model for their solar radiative properties. + ! + ! The inputs and outputs are the same to SUBROUTINE SNICAR_RT + ! + ! !USES: + ! + ! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + ! integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + ! integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + ! integer :: c_idx ! column indices [idx] + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + integer :: snw_shp_lcl(maxsnl+1:0) ! Snow grain shape option: + ! 1=sphere; 2=spheroid; 3=hexagonal plate; 4=koch snowflake + real(r8):: snw_fs_lcl(maxsnl+1:0) ! Shape factor: ratio of nonspherical grain effective radii to that of equal-volume sphere + ! 0=USE recommended default value + ! others(0 1 (i.e. nonspherical) + real(r8):: snw_ar_lcl(maxsnl+1:0) ! % Aspect ratio: ratio of grain width to length + ! 0=USE recommended default value + ! others(0.1 1 (i.e. nonspherical) + real(r8):: & + diam_ice , & ! effective snow grain diameter + fs_sphd , & ! shape factor for spheroid + fs_hex0 , & ! shape factor for hexagonal plate + fs_hex , & ! shape factor for hexagonal plate (reference) + fs_koch , & ! shape factor for koch snowflake + AR_tmp , & ! aspect ratio for spheroid + g_ice_Cg_tmp(7) , & ! temporary for calculation of asymetry factor + gg_ice_F07_tmp(7) , & ! temporary for calculation of asymetry factor + g_ice_F07 , & ! temporary for calculation of asymetry factor + g_ice , & ! asymmetry factor + gg_F07_intp , & ! temporary for calculation of asymetry factor (interpolated) + g_Cg_intp , & ! temporary for calculation of asymetry factor (interpolated) + R_1_omega_tmp , & ! temporary for dust-snow mixing calculation + C_dust_total ! dust concentration + + integer :: atm_type_index ! index for atmospheric type + integer :: slr_zen ! integer value of solar zenith angle + + ! SNICAR_AD new variables, follow sea-ice shortwave conventions + real(r8):: & + trndir(maxsnl+1:1) , & ! solar beam down transmission from top + trntdr(maxsnl+1:1) , & ! total transmission to direct beam for layers above + trndif(maxsnl+1:1) , & ! diffuse transmission to diffuse beam for layers above + rupdir(maxsnl+1:1) , & ! reflectivity to direct radiation for layers below + rupdif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers below + rdndif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers above + dfdir(maxsnl+1:1) , & ! down-up flux at interface due to direct beam at top surface + dfdif(maxsnl+1:1) , & ! down-up flux at interface due to diffuse beam at top surface + dftmp(maxsnl+1:1) ! temporary variable for down-up flux at interface + + real(r8):: & + rdir(maxsnl+1:0) , & ! layer reflectivity to direct radiation + rdif_a(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from above + rdif_b(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from below + tdir(maxsnl+1:0) , & ! layer transmission to direct radiation (solar beam + diffuse) + tdif_a(maxsnl+1:0) , & ! layer transmission to diffuse radiation from above + tdif_b(maxsnl+1:0) , & ! layer transmission to diffuse radiation from below + trnlay(maxsnl+1:0) ! solar beam transm for layer (direct beam only) + + real(r8):: & + ts , & ! layer delta-scaled extinction optical depth + ws , & ! layer delta-scaled single scattering albedo + gs , & ! layer delta-scaled asymmetry parameter + extins , & ! extinction + alp , & ! temporary for alpha + gam , & ! temporary for agamm + amg , & ! alp - gam + apg , & ! alp + gam + ue , & ! temporary for u + refk , & ! interface multiple scattering + refkp1 , & ! interface multiple scattering for k+1 + refkm1 , & ! interface multiple scattering for k-1 + tdrrdir , & ! direct tran times layer direct ref + tdndif ! total down diffuse = tot tran - direct tran + + real(r8) :: & + alpha , & ! term in direct reflectivity and transmissivity + agamm , & ! term in direct reflectivity and transmissivity + el , & ! term in alpha,agamm,n,u + taus , & ! scaled extinction optical depth + omgs , & ! scaled single particle scattering albedo + asys , & ! scaled asymmetry parameter + u , & ! term in diffuse reflectivity and transmissivity + n , & ! term in diffuse reflectivity and transmissivity + lm , & ! temporary for el + mu , & ! cosine solar zenith for either snow or water + ne ! temporary for n + + ! perpendicular and parallel relative to plane of incidence and scattering + real(r8) :: & + R1 , & ! perpendicular polarization reflection amplitude + R2 , & ! parallel polarization reflection amplitude + T1 , & ! perpendicular polarization transmission amplitude + T2 , & ! parallel polarization transmission amplitude + Rf_dir_a , & ! fresnel reflection to direct radiation + Tf_dir_a , & ! fresnel transmission to direct radiation + Rf_dif_a , & ! fresnel reflection to diff radiation from above + Rf_dif_b , & ! fresnel reflection to diff radiation from below + Tf_dif_a , & ! fresnel transmission to diff radiation from above + Tf_dif_b ! fresnel transmission to diff radiation from below + + real(r8) :: & + gwt , & ! gaussian weight + swt , & ! sum of weights + trn , & ! layer transmission + rdr , & ! rdir for gaussian integration + tdr , & ! tdir for gaussian integration + smr , & ! accumulator for rdif gaussian integration + smt , & ! accumulator for tdif gaussian integration + exp_min ! minimum exponential value + + integer :: & + ng , & ! gaussian integration index + snl_btm_itf , & ! index of bottom snow layer interfaces (1) [idx] + ngmax = 8 ! gaussian integration index + + ! Gaussian integration angle and coefficients + real(r8) :: difgauspt(1:8) , difgauswt(1:8) + + ! constants used in algorithm + real(r8) :: & + c0 = 0.0_r8 , & + c1 = 1.0_r8 , & + c3 = 3.0_r8 , & + c4 = 4.0_r8 , & + c6 = 6.0_r8 , & + cp01 = 0.01_r8 , & + cp5 = 0.5_r8 , & + cp75 = 0.75_r8 , & + c1p5 = 1.5_r8 , & + trmin = 0.001_r8 , & + argmax = 10.0_r8 ! maximum argument of exponential + + ! cconstant coefficients used for SZA parameterization + real(r8) :: & + sza_a0 = 0.085730_r8 , & + sza_a1 = -0.630883_r8 , & + sza_a2 = 1.303723_r8 , & + sza_b0 = 1.467291_r8 , & + sza_b1 = -3.338043_r8 , & + sza_b2 = 6.807489_r8 , & + puny = 1.0e-11_r8 , & + mu_75 = 0.2588_r8 ! cosine of 75 degree + + ! coefficients used for SZA parameterization + real(r8) :: & + sza_c1 , & ! coefficient, SZA parameteirzation + sza_c0 , & ! coefficient, SZA parameterization + sza_factor , & ! factor used to adjust NIR direct albedo + flx_sza_adjust , & ! direct NIR flux adjustment from sza_factor + mu0 ! incident solar zenith angle + + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Constants for non-spherical ice particles and dust-snow internal mixing + real(r8) :: g_b2(7) + real(r8) :: g_b1(7) + real(r8) :: g_b0(7) + real(r8) :: g_F07_c2(7) + real(r8) :: g_F07_c1(7) + real(r8) :: g_F07_c0(7) + real(r8) :: g_F07_p2(7) + real(r8) :: g_F07_p1(7) + real(r8) :: g_F07_p0(7) + real(r8) :: dust_clear_d0(3) + real(r8) :: dust_clear_d1(3) + real(r8) :: dust_clear_d2(3) + real(r8) :: dust_cloudy_d0(3) + real(r8) :: dust_cloudy_d1(3) + real(r8) :: dust_cloudy_d2(3) + + !!! factors for considering snow grain shape + data g_b0(:) / 9.76029E-01_r8, 9.67798E-01_r8, 1.00111E+00_r8, 1.00224E+00_r8,& + 9.64295E-01_r8, 9.97475E-01_r8, 9.97475E-01_r8/ + data g_b1(:) / 5.21042E-01_r8, 4.96181E-01_r8, 1.83711E-01_r8, 1.37082E-01_r8,& + 5.50598E-02_r8, 8.48743E-02_r8, 8.48743E-02_r8/ + data g_b2(:) /-2.66792E-04_r8, 1.14088E-03_r8, 2.37011E-04_r8,-2.35905E-04_r8,& + 8.40449E-04_r8,-4.71484E-04_r8,-4.71484E-04_r8/ + + data g_F07_c2(:) / 1.349959E-1_r8, 1.115697E-1_r8, 9.853958E-2_r8, 5.557793E-2_r8,& + -1.233493E-1_r8, 0.0_r8, 0.0_r8/ + data g_F07_c1(:) /-3.987320E-1_r8,-3.723287E-1_r8,-3.924784E-1_r8,-3.259404E-1_r8,& + 4.429054E-2_r8,-1.726586E-1_r8,-1.726586E-1_r8/ + data g_F07_c0(:) / 7.938904E-1_r8, 8.030084E-1_r8, 8.513932E-1_r8, 8.692241E-1_r8,& + 7.085850E-1_r8, 6.412701E-1_r8, 6.412701E-1_r8/ + data g_F07_p2(:) / 3.165543E-3_r8, 2.014810E-3_r8, 1.780838E-3_r8, 6.987734E-4_r8,& + -1.882932E-2_r8,-2.277872E-2_r8,-2.277872E-2_r8/ + data g_F07_p1(:) / 1.140557E-1_r8, 1.143152E-1_r8, 1.143814E-1_r8, 1.071238E-1_r8,& + 1.353873E-1_r8, 1.914431E-1_r8, 1.914431E-1_r8/ + data g_F07_p0(:) / 5.292852E-1_r8, 5.425909E-1_r8, 5.601598E-1_r8, 6.023407E-1_r8,& + 6.473899E-1_r8, 4.634944E-1_r8, 4.634944E-1_r8/ + + !!! factors for considring dust-snow internal mixing + data dust_clear_d0(:) /1.0413E+00_r8,1.0168E+00_r8,1.0189E+00_r8/ + data dust_clear_d1(:) /1.0016E+00_r8,1.0070E+00_r8,1.0840E+00_r8/ + data dust_clear_d2(:) /2.4208E-01_r8,1.5300E-03_r8,1.1230E-04_r8/ + + data dust_cloudy_d0(:) /1.0388E+00_r8,1.0167E+00_r8,1.0189E+00_r8/ + data dust_cloudy_d1(:) /1.0015E+00_r8,1.0061E+00_r8,1.0823E+00_r8/ + data dust_cloudy_d2(:) /2.5973E-01_r8,1.6200E-03_r8,1.1721E-04_r8/ + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + !Gaussian integration angle and coefficients for diffuse radiation + difgauspt(1:8) & ! gaussian angles (radians) + = (/ 0.9894009_r8, 0.9445750_r8, & + 0.8656312_r8, 0.7554044_r8, & + 0.6178762_r8, 0.4580168_r8, & + 0.2816036_r8, 0.0950125_r8/) + difgauswt(1:8) & ! gaussian weights + = (/ 0.0271525_r8, 0.0622535_r8, & + 0.0951585_r8, 0.1246290_r8, & + 0.1495960_r8, 0.1691565_r8, & + 0.1826034_r8, 0.1894506_r8/) + + snw_shp_lcl(:) = snow_shape_sphere + snw_fs_lcl(:) = 0._r8 + snw_ar_lcl(:) = 0._r8 + atm_type_index = atm_type_default + + ! Define snow grain shape + IF (trim(snow_shape) == 'sphere') THEN + snw_shp_lcl(:) = snow_shape_sphere + ELSEIF (trim(snow_shape) == 'spheroid') THEN + snw_shp_lcl(:) = snow_shape_spheroid + ELSEIF (trim(snow_shape) == 'hexagonal_plate') THEN + snw_shp_lcl(:) = snow_shape_hexagonal_plate + ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN + snw_shp_lcl(:) = snow_shape_koch_snowflake + ELSE + IF (p_is_master) THEN + write(iulog,*) "snow_shape = ", snow_shape + CALL abort + ENDIF + ENDIF + + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (p_is_master) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL abort + ENDIF + ENDIF + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw) ) THEN + + ! Set variables specific to ELM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF ! END IF flg_snw_ice == 1 + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + ! Error check for snow grain size: + IF (p_is_master) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL abort + ENDIF + ENDDO + ENDIF + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ELSE + slr_zen = nint(acos(coszen) * 180._r8 / pi) + IF (slr_zen>89) THEN + slr_zen = 89 + ENDIF + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dir(atm_type_index, slr_zen+1, 2) + flx_wgt(3) = flx_wgt_dir(atm_type_index, slr_zen+1, 3) + flx_wgt(4) = flx_wgt_dir(atm_type_index, slr_zen+1, 4) + flx_wgt(5) = flx_wgt_dir(atm_type_index, slr_zen+1, 5) + ENDIF + + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ELSE + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dif(atm_type_index, 2) + flx_wgt(3) = flx_wgt_dif(atm_type_index, 3) + flx_wgt(4) = flx_wgt_dif(atm_type_index, 4) + flx_wgt(5) = flx_wgt_dif(atm_type_index, 5) + ENDIF + ENDIF + ENDIF ! END IF numrad_snw + + ! Loop over snow spectral bands + + exp_min = exp(-argmax) + DO bnd_idx = 1,numrad_snw + + ! note that we can remove flg_dover since this algorithm is + ! stable for mu_not > 0.01 + + ! mu_not is cosine solar zenith angle above the fresnel level; make + ! sure mu_not is large enough for stable and meaningful radiation + ! solution: .01 is like sun just touching horizon with its lower edge + ! equivalent to mu0 in sea-ice shortwave model ice_shortwave.F90 + mu_not = max(coszen, cp01) + + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + + ! Calculate the asymetry factors under different snow grain shapes + DO i=snl_top,snl_btm,1 + IF(snw_shp_lcl(i) == snow_shape_spheroid) THEN ! spheroid + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_sphd = 0.929_r8 + ELSE + fs_sphd = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 0.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_hex0 = 0.788_r8 + ELSE + fs_hex0 = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake + diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_koch = 0.712_r8 + ELSE + fs_koch = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_koch/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ENDIF + + ! Linear interpolation for calculating the asymetry factor at band_idx. + IF(snw_shp_lcl(i) > 1) THEN + IF(bnd_idx == 1) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 2) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 3) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 4) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 5) THEN + g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +g_ice_Cg_tmp(5) + gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +gg_ice_F07_tmp(5) + ENDIF + g_ice_F07 = gg_F07_intp + (1._r8 - gg_F07_intp) / ss_alb_snw_lcl(i) / 2._r8 + g_ice = g_ice_F07 * g_Cg_intp + asm_prm_snw_lcl(i) = g_ice + ENDIF + + IF(asm_prm_snw_lcl(i) > 0.99_r8) THEN + asm_prm_snw_lcl(i) = 0.99_r8 + ENDIF + + ENDDO + !!!-END + + !H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) + !H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + + ! Calculate single-scattering albedo for internal mixing of dust-snow + IF (use_dust_snow_internal_mixing) THEN + IF (bnd_idx < 4) THEN + C_dust_total = mss_cnc_aer_lcl(i,5) + mss_cnc_aer_lcl(i,6) & + + mss_cnc_aer_lcl(i,7) + mss_cnc_aer_lcl(i,8) + C_dust_total = C_dust_total * 1.0E+06_r8 + IF(C_dust_total > 0._r8) THEN + IF (flg_slr_in == 1) THEN + R_1_omega_tmp = dust_clear_d0(bnd_idx) & + + dust_clear_d2(bnd_idx)*(C_dust_total**dust_clear_d1(bnd_idx)) + ELSE + R_1_omega_tmp = dust_cloudy_d0(bnd_idx) & + + dust_cloudy_d2(bnd_idx)*(C_dust_total**dust_cloudy_d1(bnd_idx)) + ENDIF + ss_alb_snw_lcl(i) = 1.0_r8 - (1.0_r8 - ss_alb_snw_lcl(i)) *R_1_omega_tmp + ENDIF + ENDIF + DO j = 5,8,1 + ss_alb_aer_lcl(j) = 0._r8 + asm_prm_aer_lcl(j) = 0._r8 + ext_cff_mss_aer_lcl(j) = 0._r8 + ENDDO + ENDIF + + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + IF (use_dust_snow_internal_mixing .and. (j >= 5)) THEN + L_aer(i,j) = 0._r8 + ELSE + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + ENDIF + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO ! endWeighted Mie parameters of each layer + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Begin radiative transfer solver + ! Given input vertical profiles of optical properties, evaluate the + ! monochromatic Delta-Eddington adding-doubling solution + + ! note that trndir, trntdr, trndif, rupdir, rupdif, rdndif + ! are variables at the layer interface, + ! for snow with layers rangeing from snl_top to snl_btm + ! there are snl_top to snl_btm+1 layer interface + snl_btm_itf = snl_btm + 1 + + DO i = snl_top,snl_btm_itf,1 + trndir(i) = c0 + trntdr(i) = c0 + trndif(i) = c0 + rupdir(i) = c0 + rupdif(i) = c0 + rdndif(i) = c0 + ENDDO + + ! initialize top interface of top layer + trndir(snl_top) = c1 + trntdr(snl_top) = c1 + trndif(snl_top) = c1 + rdndif(snl_top) = c0 + + ! begin main level loop + ! for layer interfaces except for the very bottom + DO i = snl_top,snl_btm,1 + + ! initialize all layer apparent optical properties to 0 + rdir (i) = c0 + rdif_a(i) = c0 + rdif_b(i) = c0 + tdir (i) = c0 + tdif_a(i) = c0 + tdif_b(i) = c0 + trnlay(i) = c0 + + ! compute next layer Delta-eddington solution only IF total transmission + ! of radiation to the interface just above the layer exceeds trmin. + + IF (trntdr(i) > trmin ) THEN + + ! calculation over layers with penetrating radiation + + ! delta-transformed single-scattering properties + ! of this layer + ts = tau_star(i) + ws = omega_star(i) + gs = g_star(i) + + ! Delta-Eddington solution expressions + ! n(uu,et) = ((uu+c1)*(uu+c1)/et ) - ((uu-c1)*(uu-c1)*et) + ! u(w,gg,e) = c1p5*(c1 - w*gg)/e + ! el(w,gg) = sqrt(c3*(c1-w)*(c1 - w*gg)) + lm = sqrt(c3*(c1-ws)*(c1 - ws*gs)) !lm = el(ws,gs) + ue = c1p5*(c1 - ws*gs)/lm !ue = u(ws,gs,lm) + extins = max(exp_min, exp(-lm*ts)) + ne = ((ue+c1)*(ue+c1)/extins) - ((ue-c1)*(ue-c1)*extins) !ne = n(ue,extins) + + ! first calculation of rdif, tdif using Delta-Eddington formulas + ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne + rdif_a(i) = (ue**2-c1)*(c1/extins - extins)/ne + tdif_a(i) = c4*ue/ne + + ! evaluate rdir,tdir for direct beam + trnlay(i) = max(exp_min, exp(-ts/mu_not)) + + ! Delta-Eddington solution expressions + ! alpha(w,uu,gg,e) = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu)) + ! agamm(w,uu,gg,e) = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu)) + ! alp = alpha(ws,mu_not,gs,lm) + ! gam = agamm(ws,mu_not,gs,lm) + alp = cp75*ws*mu_not*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu_not*mu_not)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu_not*mu_not)/(c1-lm*lm*mu_not*mu_not)) + apg = alp + gam + amg = alp - gam + + rdir(i) = apg*rdif_a(i) + amg*(tdif_a(i)*trnlay(i) - c1) + tdir(i) = apg*tdif_a(i) + (amg* rdif_a(i)-apg+c1)*trnlay(i) + + ! recalculate rdif,tdif using direct angular integration over rdir,tdir, + ! since Delta-Eddington rdif formula is not well-behaved (it is usually + ! biased low and can even be negative); USE ngmax angles and gaussian + ! integration for most accuracy: + R1 = rdif_a(i) ! USE R1 as temporary + T1 = tdif_a(i) ! USE T1 as temporary + swt = c0 + smr = c0 + smt = c0 + DO ng=1,ngmax + mu = difgauspt(ng) + gwt = difgauswt(ng) + swt = swt + mu*gwt + trn = max(exp_min, exp(-ts/mu)) + ! alp = alpha(ws,mu,gs,lm) + ! gam = agamm(ws,mu,gs,lm) + alp = cp75*ws*mu*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu*mu)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu*mu)/(c1-lm*lm*mu*mu)) + apg = alp + gam + amg = alp - gam + rdr = apg*R1 + amg*T1*trn - amg + tdr = apg*T1 + amg*R1*trn - apg*trn + trn + smr = smr + mu*rdr*gwt + smt = smt + mu*tdr*gwt + ENDDO ! ng + rdif_a(i) = smr/swt + tdif_a(i) = smt/swt + + ! homogeneous layer + rdif_b(i) = rdif_a(i) + tdif_b(i) = tdif_a(i) + + ENDIF ! trntdr(k) > trmin + + ! Calculate the solar beam transmission, total transmission, and + ! reflectivity for diffuse radiation from below at interface i, + ! the top of the current layer k: + ! + ! layers interface + ! + ! --------------------- i-1 + ! i-1 + ! --------------------- i + ! i + ! --------------------- + + trndir(i+1) = trndir(i)*trnlay(i) + refkm1 = c1/(c1 - rdndif(i)*rdif_a(i)) + tdrrdir = trndir(i)*rdir(i) + tdndif = trntdr(i) - trndir(i) + trntdr(i+1) = trndir(i)*tdir(i) + & + (tdndif + tdrrdir*rdndif(i))*refkm1*tdif_a(i) + rdndif(i+1) = rdif_b(i) + & + (tdif_b(i)*rdndif(i)*refkm1*tdif_a(i)) + trndif(i+1) = trndif(i)*refkm1*tdif_a(i) + + ENDDO ! END main level loop + + + ! compute reflectivity to direct and diffuse radiation for layers + ! below by adding succesive layers starting from the underlying + ! ground and working upwards: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- i+1 + ! i+1 + ! --------------------- + + ! set the underlying ground albedo == albedo of near-IR + ! unless bnd_idx == 1, for visible + rupdir(snl_btm_itf) = albsfc(2) + rupdif(snl_btm_itf) = albsfc(2) + IF (bnd_idx == 1) THEN + rupdir(snl_btm_itf) = albsfc(1) + rupdif(snl_btm_itf) = albsfc(1) + ENDIF + + DO i=snl_btm,snl_top,-1 + ! interface scattering + refkp1 = c1/( c1 - rdif_b(i)*rupdif(i+1)) + ! dir from top layer plus exp tran ref from lower layer, interface + ! scattered and tran thru top layer from below, plus diff tran ref + ! from lower layer with interface scattering tran thru top from below + rupdir(i) = rdir(i) & + + ( trnlay(i) *rupdir(i+1) & + + (tdir(i)-trnlay(i))*rupdif(i+1))*refkp1*tdif_b(i) + ! dif from top layer from above, plus dif tran upwards reflected and + ! interface scattered which tran top from below + rupdif(i) = rdif_a(i) + tdif_a(i)*rupdif(i+1)*refkp1*tdif_b(i) + ENDDO ! i + + ! net flux (down-up) at each layer interface from the + ! snow top (i = snl_top) to bottom interface above land (i = snl_btm_itf) + ! the interface reflectivities and transmissivities required + ! to evaluate interface fluxes are returned from solution_dEdd; + ! now compute up and down fluxes for each interface, using the + ! combined layer properties at each interface: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- + + DO i = snl_top, snl_btm_itf + ! interface scattering + refk = c1/(c1 - rdndif(i)*rupdif(i)) + ! dir tran ref from below times interface scattering, plus diff + ! tran and ref from below times interface scattering + ! fdirup(i) = (trndir(i)*rupdir(i) + & + ! (trntdr(i)-trndir(i)) & + ! *rupdif(i))*refk + ! dir tran plus total diff trans times interface scattering plus + ! dir tran with up dir ref and down dif ref times interface scattering + ! fdirdn(i) = trndir(i) + (trntdr(i) & + ! - trndir(i) + trndir(i) & + ! *rupdir(i)*rdndif(i))*refk + ! diffuse tran ref from below times interface scattering + ! fdifup(i) = trndif(i)*rupdif(i)*refk + ! diffuse tran times interface scattering + ! fdifdn(i) = trndif(i)*refk + + ! netflux, down - up + ! dfdir = fdirdn - fdirup + dfdir(i) = trndir(i) & + + (trntdr(i)-trndir(i)) * (c1 - rupdif(i)) * refk & + - trndir(i)*rupdir(i) * (c1 - rdndif(i)) * refk + IF (dfdir(i) < puny) dfdir(i) = c0 + ! dfdif = fdifdn - fdifup + dfdif(i) = trndif(i) * (c1 - rupdif(i)) * refk + IF (dfdif(i) < puny) dfdif(i) = c0 + ENDDO ! k + + ! SNICAR_AD_RT is called twice for direct and diffuse incident fluxes + ! direct incident + IF (flg_slr_in == 1) THEN + albedo = rupdir(snl_top) + dftmp = dfdir + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = (trndir(snl_top)*rupdir(snl_top) + & + (trntdr(snl_top)-trndir(snl_top)) & + *rupdif(snl_top))*refk + !diffuse incident + ELSE + albedo = rupdif(snl_top) + dftmp = dfdif + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = trndif(snl_top)*rupdif(snl_top)*refk + ENDIF + + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + F_abs(i) = dftmp(i)-dftmp(i+1) + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + ! ERROR check: negative absorption + IF (p_is_master) THEN + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) + write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR_AD STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR_AD STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR_AD STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR_AD STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR_AD STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + CALL abort + ENDIF + ENDIF + ENDDO + + ! absobed flux by the underlying ground + F_btm_net = dftmp(snl_btm_itf) + + ! note here, snl_btm_itf = 1 by snow column set up in CLM + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + !ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (p_is_master) THEN + IF (abs(energy_sum) > 0.00001_r8) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum + write(iulog,*) "F_abs_sum: ",F_abs_sum + write(iulog,*) "F_btm_net: ",F_btm_net + write(iulog,*) "F_sfc_pls: ",F_sfc_pls + write(iulog,*) "mu_not*pi*flx_slrd_lcl(bnd_idx): ", mu_not*pi*flx_slrd_lcl(bnd_idx) + write(iulog,*) "flx_slri_lcl(bnd_idx)", flx_slri_lcl(bnd_idx) + write(iulog,*) "bnd_idx", bnd_idx + write(iulog,*) "F_abs", F_abs + write(iulog,*) "albedo", albedo + CALL abort + ENDIF + ENDIF + + albout_lcl(bnd_idx) = albedo + ! Check that albedo is less than 1 + IF (p_is_master) THEN + IF (albout_lcl(bnd_idx) > 1.0) THEN + write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL abort + ENDIF + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! near-IR direct albedo/absorption adjustment for high solar zenith angles + ! solar zenith angle parameterization + ! calculate the scaling factor for NIR direct albedo IF SZA>75 degree + IF ((mu_not < mu_75) .and. (flg_slr_in == 1)) THEN + sza_c1 = sza_a0 + sza_a1 * mu_not + sza_a2 * mu_not**2 + sza_c0 = sza_b0 + sza_b1 * mu_not + sza_b2 * mu_not**2 + sza_factor = sza_c1 * (log10(snw_rds_lcl(snl_top) * c1) - c6) + sza_c0 + flx_sza_adjust = albout(2) * (sza_factor-c1) * sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + albout(2) = albout(2) * sza_factor + flx_abs(snl_top,2) = flx_abs(snl_top,2) - flx_sza_adjust + ENDIF + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_AD_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_grain( dtime , snl , dz , & + qflx_snow_grnd , qflx_snwcp_ice , qflx_snofrz_lyr , & + do_capsnow , frac_sno , h2osno , & + h2osno_liq , h2osno_ice , & + t_soisno , t_grnd , & + forc_t , snw_rds ) + ! + ! !DESCRIPTION: + ! Updates the snow effective grain size (radius). + ! Contributions to grain size evolution are from: + ! 1. vapor redistribution (dry snow) + ! 2. liquid water redistribution (wet snow) + ! 3. re-freezing of liquid water + ! + ! Vapor redistribution: Method is to retrieve 3 best-bit parameters that + ! depend on snow temperature, temperature gradient, and density, + ! that are derived from the microphysical model described in: + ! Flanner and Zender (2006), Linking snowpack microphysics and albedo + ! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834. + ! The parametric equation has the form: + ! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), WHERE: + ! r is the effective radius, + ! tau and kappa are best-fit parameters, + ! drdt_0 is the initial rate of change of effective radius, and + ! dr_fresh is the difference between the current and fresh snow states + ! (r_current - r_fresh). + ! + ! Liquid water redistribution: Apply the grain growth FUNCTION from: + ! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of + ! liquid-water content, Annals of Glaciology, 13, 22-26. + ! There are two parameters that describe the grain growth rate as + ! a FUNCTION of snow liquid water content (LWC). The "LWC=0" parameter + ! is zeroed here because we are accounting for dry snowing with a + ! different representation + ! + ! Re-freezing of liquid water: Assume that re-frozen liquid water clumps + ! into an arbitrarily large effective grain size (snw_rds_refrz). + ! The phenomenon is observed (Grenfell), but so far unquantified, as far as + ! I am aware. + ! + ! !USES: + ! + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! !ARGUMENTS: + + IMPLICIT NONE + + real(r8) , intent(in) :: dtime ! land model time step [sec] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: dz ( maxsnl+1:1 ) ! layer thickness (col,lyr) [m] + + real(r8) , intent(in) :: qflx_snow_grnd ! snow on ground after interception (col) [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snofrz_lyr ( maxsnl+1:0 ) ! snow freezing rate (col,lyr) [kg m-2 s-1] + + logical , intent(in) :: do_capsnow ! true => DO snow capping + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8) , intent(in) :: h2osno ! snow water (col) [mm H2O] + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg m-2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg m-2] + + real(r8) , intent(in) :: t_soisno ( maxsnl+1:1 ) ! soil and snow temperature (col,lyr) [K] + real(r8) , intent(in) :: t_grnd ! ground temperature (col) [K] + real(r8) , intent(in) :: forc_t ! Atmospheric temperature (col) [K] + + real(r8) , intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective grain radius (col,lyr) [microns, m-6] + + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: snl_top ! top snow layer index [idx] + integer :: snl_btm ! bottom snow layer index [idx] + integer :: i ! layer index [idx] + ! integer :: c_idx ! column index [idx] + integer :: fc ! snow column filter index [idx] + integer :: T_idx ! snow aging lookup table temperature index [idx] + integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx] + integer :: rhos_idx ! snow aging lookup table snow density index [idx] + real(r8) :: t_snotop ! temperature at upper layer boundary [K] + real(r8) :: t_snobtm ! temperature at lower layer boundary [K] + real(r8) :: dTdz(maxsnl:0) ! snow temperature gradient (col,lyr) [K m-1] + real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour] + real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless] + real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1] + real(r8) :: dr ! incremental change in snow effective radius [um] + real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um] + real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um] + real(r8) :: newsnow ! fresh snowfall [kg m-2] + real(r8) :: refrzsnow ! re-frozen snow [kg m-2] + real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc] + real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc] + real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc] + real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc] + real(r8) :: rhos ! snow density [kg m-3] + real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2] + real(r8) :: cdz(maxsnl+1:0) ! column average layer thickness [m] + real(r8) :: snw_rds_fresh ! fresh snow radius [microns] + + real(r8) :: snot_top ! temperature in top snow layer (col) [K] + real(r8) :: dTdz_top ! temperature gradient in top layer (col) [K m-1] + real(r8) :: snw_rds_top ! effective grain radius, top layer (col) [microns, m-6] + real(r8) :: sno_liq_top ! liquid water fraction (mass) in top snow layer (col) [frc] + + !--------------------------------------------------------------------------! + + ! associate( & + ! snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers (col) [nbr] + ! dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness (col,lyr) [m] + + ! qflx_snow_grnd => col_wf%qflx_snow_grnd , & ! Input: [real(r8) (:) ] snow on ground after interception (col) [kg m-2 s-1] + ! qflx_snwcp_ice => col_wf%qflx_snwcp_ice , & ! Input: [real(r8) (:) ] excess precipitation due to snow capping [kg m-2 s-1] + ! qflx_snofrz_lyr => col_wf%qflx_snofrz_lyr , & ! Input: [real(r8) (:,:) ] snow freezing rate (col,lyr) [kg m-2 s-1] + + ! do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => DO snow capping + ! frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (col) [mm H2O] + ! h2osno_liq => col_ws%h2osno_liq , & ! Input: [real(r8) (:,:) ] liquid water content (col,lyr) [kg m-2] + ! h2osno_ice => col_ws%h2osno_ice , & ! Input: [real(r8) (:,:) ] ice content (col,lyr) [kg m-2] + ! snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective grain radius (col,lyr) [microns, m-6] + ! snw_rds_top => col_ws%snw_rds_top , & ! Output: [real(r8) (:) ] effective grain radius, top layer (col) [microns, m-6] + ! sno_liq_top => col_ws%sno_liq_top , & ! Output: [real(r8) (:) ] liquid water fraction (mass) in top snow layer (col) [frc] + + ! t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil and snow temperature (col,lyr) [K] + ! t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground temperature (col) [K] + ! snot_top => col_es%snot_top , & ! Output: [real(r8) (:) ] temperature in top snow layer (col) [K] + ! dTdz_top => col_es%dTdz_top & ! Output: [real(r8) (:) ] temperature gradient in top layer (col) [K m-1] + ! ) + + + IF (snl < 0 .and. h2osno > 0._r8) THEN + + snl_btm = 0 + snl_top = snl + 1 + + cdz(snl_top:snl_btm)=frac_sno*dz(snl_top:snl_btm) + + ! loop over snow layers + DO i = snl_top, snl_btm, 1 + ! + !********** 1. DRY SNOW AGING *********** + ! + h2osno_lyr = h2osno_liq(i) + h2osno_ice(i) + + ! temperature gradient + IF (i == snl_top) THEN + ! top layer + t_snotop = t_soisno(snl_top) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ELSE + t_snotop = (t_soisno(i-1)*dz(i) & + + t_soisno(i)*dz(i-1)) & + / (dz(i)+dz(i-1)) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ENDIF + + dTdz(i) = abs((t_snotop - t_snobtm) / cdz(i)) + + ! snow density + rhos = (h2osno_liq(i)+h2osno_ice(i)) / cdz(i) + + ! make sure rhos doesn't drop below 50 (see rhos_idx below) + rhos=max(50._r8,rhos) + + ! best-fit table indecies + T_idx = nint((t_soisno(i)-223) / 5) + 1 + Tgrd_idx = nint(dTdz(i) / 10) + 1 + rhos_idx = nint((rhos-50) / 50) + 1 + + ! boundary check: + IF (T_idx < idx_T_min) THEN + T_idx = idx_T_min + ENDIF + IF (T_idx > idx_T_max) THEN + T_idx = idx_T_max + ENDIF + IF (Tgrd_idx < idx_Tgrd_min) THEN + Tgrd_idx = idx_Tgrd_min + ENDIF + IF (Tgrd_idx > idx_Tgrd_max) THEN + Tgrd_idx = idx_Tgrd_max + ENDIF + IF (rhos_idx < idx_rhos_min) THEN + rhos_idx = idx_rhos_min + ENDIF + IF (rhos_idx > idx_rhos_max) THEN + rhos_idx = idx_rhos_max + ENDIF + + ! best-fit parameters + bst_tau = snowage_tau(rhos_idx,Tgrd_idx,T_idx) + bst_kappa = snowage_kappa(rhos_idx,Tgrd_idx,T_idx) + bst_drdt0 = snowage_drdt0(rhos_idx,Tgrd_idx,T_idx) + + ! change in snow effective radius, using best-fit parameters + ! added checks suggested by mgf. --HW 10/15/2015 + dr_fresh = snw_rds(i)-snw_rds_min + +#ifdef MODAL_AER + IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN + dr_fresh = 0.0_r8 + ELSEIF ( dr_fresh < 0.0_r8 ) THEN + IF (p_is_master) THEN + write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min + CALL abort + ENDIF + ENDIF + + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) +#else + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1/bst_kappa)) * (dtime/3600) +#endif + ! + !********** 2. WET SNOW AGING *********** + ! + ! We are assuming wet and dry evolution occur simultaneously, and + ! the contributions from both can be summed. + ! This is justified by setting the linear offset constant C1_liq_Brun89 to zero [Brun, 1989] + + ! liquid water faction + frc_liq = min(0.1_r8, (h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)))) + + !dr_wet = 1E6_r8*(dtime*(C1_liq_Brun89 + C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*(snw_rds(i)/1E6)**(2))) + !simplified, units of microns: + dr_wet = 1E18_r8*(dtime*(C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*snw_rds(i)**(2))) + + dr = dr + dr_wet + + ! + !********** 3. SNOWAGE SCALING (TURNED OFF BY DEFAULT) ************* + ! + ! Multiply rate of change of effective radius by some constant, xdrdt + IF (flg_snoage_scl) THEN + dr = dr*xdrdt + ENDIF + + ! + !********** 4. INCREMENT EFFECTIVE RADIUS, ACCOUNTING FOR: *********** + ! DRY AGING + ! WET AGING + ! FRESH SNOW + ! RE-FREEZING + ! + ! new snowfall [kg/m2] + IF (do_capsnow .and. .not. use_extrasnowlayers) THEN + newsnow = max(0._r8, (qflx_snwcp_ice*dtime)) + ELSE + newsnow = max(0._r8, (qflx_snow_grnd*dtime)) + ENDIF + + ! snow that has re-frozen [kg/m2] + refrzsnow = max(0._r8, (qflx_snofrz_lyr(i)*dtime)) + + ! fraction of layer mass that is re-frozen + frc_refrz = refrzsnow / h2osno_lyr + + ! fraction of layer mass that is new snow + IF (i == snl_top) THEN + frc_newsnow = newsnow / h2osno_lyr + ELSE + frc_newsnow = 0._r8 + ENDIF + + IF ((frc_refrz + frc_newsnow) > 1._r8) THEN + frc_refrz = frc_refrz / (frc_refrz + frc_newsnow) + frc_newsnow = 1._r8 - frc_refrz + frc_oldsnow = 0._r8 + ELSE + frc_oldsnow = 1._r8 - frc_refrz - frc_newsnow + ENDIF + + ! temperature dependent fresh grain size + snw_rds_fresh = FreshSnowRadius (forc_t) + + ! mass-weighted mean of fresh snow, old snow, and re-frozen snow effective radius + snw_rds(i) = (snw_rds(i)+dr)*frc_oldsnow + snw_rds_fresh*frc_newsnow + snw_rds_refrz*frc_refrz + ! + !********** 5. CHECK BOUNDARIES *********** + ! + ! boundary check + IF (snw_rds(i) < snw_rds_min) THEN + snw_rds(i) = snw_rds_min + ENDIF + + IF (snw_rds(i) > snw_rds_max) THEN + snw_rds(i) = snw_rds_max + ENDIF + + ! set top layer variables for history files + IF (i == snl_top) THEN + snot_top = t_soisno(i) + dTdz_top = dTdz(i) + snw_rds_top = snw_rds(i) + sno_liq_top = h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)) + ENDIF + + ENDDO + ENDIF ! ENDIF (snl < 0 ) + + ! Special CASE: snow on ground, but not enough to have defined a snow layer: + ! set snw_rds to fresh snow grain size: + + IF (snl >= 0 .and. h2osno > 0._r8) THEN + snw_rds(0) = snw_rds_min + ENDIF + + ! END associate + + END SUBROUTINE SnowAge_grain + !----------------------------------------------------------------------- + + + SUBROUTINE SnowOptics_init( fsnowoptics ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowoptics ! snow optical properties file name + character(len= 32) :: subname = 'SnowOptics_init' ! SUBROUTINE name + integer :: atm_type_index ! index for atmospheric type + + logical :: readvar ! determine IF variable was read from NetCDF file + !----------------------------------------------------------------------- + + readvar = .true. + + atm_type_index = atm_type_default + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (p_is_master) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL abort + ENDIF + ENDIF + + ! + ! Open optics file: + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read snow optical properties .....' + write(iulog,*) subname,trim(fsnowoptics) + ENDIF + + ! direct-beam snow Mie parameters: + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_drc', ss_alb_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_drc', asm_prm_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_drc', ext_cff_mss_snw_drc) + + ! diffuse snow Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_dfs', ss_alb_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_dfs', asm_prm_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_dfs', ext_cff_mss_snw_dfs) + + !!! Direct and diffuse flux under different atmospheric conditions + ! Direct-beam incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dir', flx_wgt_dir) + + ! Diffuse incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dif', flx_wgt_dif) + +#ifdef MODAL_AER + ! size-dependent BC parameters and BC enhancement factors + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' + ENDIF + ! + ! BC species 1 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc1) + ! + ! BC species 2 Mie parameters (identical, before enhancement factors applied) + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc2) + ! + ! size-dependent BC absorption enhancement factors for within-ice BC + CALL ncio_read_bcast_serial (fsnowoptics, 'bcint_enh_mam', bcenh) + ! +#else + ! bulk aerosol treatment + ! BC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphil', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphil', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphil', ext_cff_mss_bc1) + + ! + ! BC species 2 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphob', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphob', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphob', ext_cff_mss_bc2) + ! +#endif + ! + ! OC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphil', ss_alb_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphil', asm_prm_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphil', ext_cff_mss_oc1) + ! + ! OC species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphob', ss_alb_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphob', asm_prm_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphob', ext_cff_mss_oc2) + ! + ! dust species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust01', ss_alb_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust01', asm_prm_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust01', ext_cff_mss_dst1) + ! + ! dust species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust02', ss_alb_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust02', asm_prm_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust02', ext_cff_mss_dst2) + ! + ! dust species 3 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust03', ss_alb_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust03', asm_prm_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust03', ext_cff_mss_dst3) + ! + ! dust species 4 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust04', ss_alb_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust04', asm_prm_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust04', ext_cff_mss_dst4) + ! + ! + + IF (p_is_master) THEN + write(iulog,*) 'Successfully read snow optical properties' + ENDIF + + + ! print some diagnostics: + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & + ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & + ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & + ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & + ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' + ELSE + write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' + ENDIF + ENDIF + ! +#ifdef MODAL_AER + IF (p_is_master) THEN + ! unique dimensionality for modal aerosol optical properties + write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & + ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of Mie mass extinction coefficients for BC: ', & + ext_cff_mss_bc2(1,1), ext_cff_mss_bc2(1,2), ext_cff_mss_bc2(2,1), ext_cff_mss_bc2(5,1), ext_cff_mss_bc2(1,10),& + ext_cff_mss_bc1(1,10) + write (iulog,*) 'SNICAR: Subset of Mie asymmetry parameters for BC: ', & + asm_prm_bc1(1,1), asm_prm_bc1(1,2), asm_prm_bc1(2,1), asm_prm_bc1(5,1), asm_prm_bc1(1,10), asm_prm_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of BC absorption enhancement factors: ', & + bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) + ENDIF +#else + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & + ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & + ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) + ENDIF +#endif + + IF (p_is_master) THEN + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & + ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & + ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) + ENDIF + + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & + ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & + ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & + ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & + ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) + write(iulog,*) + ENDIF + + END SUBROUTINE SnowOptics_init + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_init( fsnowaging ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowaging ! snow aging parameters file name + character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name + ! + ! Open snow aging (effective radius evolution) file: + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read snow aging parameters .....' + write(iulog,*) subname,trim(fsnowaging) + ENDIF + + ! + ! SNOW aging parameters + ! + CALL ncio_read_bcast_serial (fsnowaging, 'tau', snowage_tau) + CALL ncio_read_bcast_serial (fsnowaging, 'kappa', snowage_kappa) + CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) + + ! + IF (p_is_master) THEN + write(iulog,*) 'Successfully read snow aging properties' + ENDIF + ! + ! print some diagnostics: + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) + write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) + write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) + ENDIF + + END SUBROUTINE SnowAge_init + !----------------------------------------------------------------------- + + + real(r8) FUNCTION FreshSnowRadius (forc_t) + ! + ! !DESCRIPTION: + ! Returns fresh snow grain radius, which is linearly dependent on temperature. + ! This is implemented to remedy an outstanding bias that SNICAR has in initial + ! grain size. See e.g. Sandells et al, 2017 for a discussion (10.5194/tc-11-229-2017). + ! + ! Yang et al. (2017), 10.1016/j.jqsrt.2016.03.033 + ! discusses grain size observations, which suggest a temperature dependence. + ! + ! !REVISION HISTORY: + ! Author: Leo VanKampenhout + ! + ! !USES: + USE MOD_Const_Physical, only: tfrz + USE MOD_Aerosol, only: fresh_snw_rds_max + + ! !ARGUMENTS: + real(r8), intent(in) :: forc_t ! atmospheric temperature (Kelvin) + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + real(r8), parameter :: tmin = tfrz - 30._r8 ! start of linear ramp + real(r8), parameter :: tmax = tfrz - 0._r8 ! END of linear ramp + real(r8), parameter :: gs_min = snw_rds_min ! minimum value + real(r8) :: gs_max ! maximum value + + IF ( fresh_snw_rds_max <= snw_rds_min )THEN + FreshSnowRadius = snw_rds_min + ELSE + gs_max = fresh_snw_rds_max + + IF (forc_t < tmin) THEN + FreshSnowRadius = gs_min + ELSEIF (forc_t > tmax) THEN + FreshSnowRadius = gs_max + ELSE + FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & + (forc_t-tmin)/(tmax-tmin)*gs_max + ENDIF + ENDIF + + END FUNCTION FreshSnowRadius + +END MODULE MOD_SnowSnicar_HiRes diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 new file mode 100644 index 0000000000..74137a12db --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 @@ -0,0 +1,2458 @@ +#include + +MODULE MOD_SoilSnowHydrology + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_SNICAR, & + DEF_URBAN_RUN, DEF_USE_IRRIGATION, & + DEF_SPLIT_SOILSNOW, DEF_Runoff_SCHEME, & + DEF_DA_TWS_GRACE, DEF_Optimize_Baseflow, & + DEF_USE_Dynamic_Wetland +#if (defined CaMa_Flood) + USE YOS_CMF_INPUT, only: LWINFILT +#endif + USE MOD_LandPatch, only: landpatch + USE MOD_Runoff + USE MOD_Hydro_VIC + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: WATER_2014 + PUBLIC :: WATER_VSF + PUBLIC :: snowwater + PUBLIC :: soilwater + PUBLIC :: snowwater_snicar + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: groundwater + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,bsw ,porsl ,& + psi0 ,hksati ,theta_r ,fsatmax ,fsatdcf ,& + elvstd ,BVIC ,rootr ,rootflux ,t_soisno ,& + wliq_soisno ,wice_soisno ,smp ,hk ,pg_rain ,& + sm ,etr ,qseva ,qsdew ,qsubl ,& + qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,fsno ,& + rsur ,rnof ,qinfl ,pondmx ,ssi ,& + wimp ,smpmin ,zwt ,wdsrf ,wa ,& + qcharge ,& +#if (defined CaMa_Flood) + flddepth ,fldfrc ,qinfl_fld ,& +#endif +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of +! hydrological processes +! +! Original author: Yongjiu Dai, /09/1999/, /08/2002/, /04/2014/ +! +! FLOW DIAGRAM FOR WATER_2014.F90 +! +! WATER_2014 ===> snowwater +! SurfaceRunoff_TOPMOD +! soilwater +! SubsurfaceRunoff_TOPMOD +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_Vars_TimeInvariants, only: vic_b_infilt, vic_Dsmax, vic_Ds, vic_Ws, vic_c + USE MOD_Vars_1DFluxes, only: fevpg +#ifdef CROP + USE MOD_Vars_Global, only : irrig_method_paddy, pondmxc + use MOD_LandPFT, only : patch_pft_s, patch_pft_e + use MOD_Vars_PFTimeVariables, only: irrig_method_p +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,&! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=land water bodies, 99=ocean + + integer, intent(in) :: & + lb ,&! lower bound of array + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + deltim ,&! time step (s) + ! wtfact ,&! (updated to gridded 'fsatmax' data) fraction of model area with high water table + pondmx ,&! ponding depth (mm) + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable if porosity less than wimp + smpmin ,&! restriction for min of soil poten. (mm) + elvstd ,&! standard deviation of elevation (m) + BVIC ,&! + + z_soisno (lb:nl_soil) ,&! layer depth (m) + dz_soisno(lb:nl_soil) ,&! layer thickness (m) + zi_soisno(lb-1:nl_soil) ,&! interface level below a "z" level (m) + + bsw(1:nl_soil) ,&! Clapp-Hornberger "B" + porsl(1:nl_soil) ,&! saturated volumetric soil water content(porosity) + psi0(1:nl_soil) ,&! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil) ,&! hydraulic conductivity at saturation (mm h2o/s) + theta_r(1:nl_soil) ,&! residual moisture content [-] + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + rootr(1:nl_soil) ,&! water uptake fraction from different layers, all layers add to 1.0 + rootflux(1:nl_soil) ,&! root uptake from different layer, all layers add to transpiration + + t_soisno(lb:nl_soil) ,&! soil/snow skin temperature (K) + pg_rain ,&! rainfall after removal of interception (mm h2o/s) + sm ,&! snow melt (mm h2o/s) + etr ,&! actual transpiration (mm h2o/s) + qseva ,&! ground surface evaporation rate (mm h2o/s) + qsdew ,&! ground surface dew formation (mm h2o /s) [+] + qsubl ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros ,&! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil ,&! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil ,&! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil ,&! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow ,&! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow ,&! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow ,&! surface dew added to snow pack (mm h2o /s) [+] + fsno ! snow fractional cover + +#if (defined CaMa_Flood) + real(r8), intent(inout) :: flddepth ! inundation water depth [mm] + real(r8), intent(in) :: fldfrc ! inundation water depth [0-1] + real(r8), intent(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) +#endif + real(r8), intent(inout) :: & + wice_soisno(lb:nl_soil) ,&! ice lens (kg/m2) + wliq_soisno(lb:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(out) :: & + smp(1:nl_soil) ,&! soil matrix potential [mm] + hk (1:nl_soil) ! hydraulic conductivity [mm h2o/m] + + real(r8), intent(inout) :: & + zwt ,&! the depth from ground (soil) surface to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ! water storage in aquifer [mm] + + real(r8), intent(out) :: & + rsur ,&! surface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qinfl ,&! infiltration rate (mm h2o/s) + qcharge ! groundwater recharge (positive to aquifer) [mm/s] + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(in) :: forc_aer ( 14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + real(r8), intent(inout) :: & + mss_bcpho (lb:0) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +! irrigation variable + real(r8), intent(in) :: & + qflx_irrig_drip , &! irrigation flux from drip irrigation [mm/s] + qflx_irrig_flood , &! irrigation flux from flood irrigation [mm/s] + qflx_irrig_paddy ! irrigation flux from paddy irrigation [mm/s] + +!-------------------------- Local Variables ---------------------------- + + integer j ! loop counter + + real(r8) :: & + eff_porosity(1:nl_soil) ,&! effective porosity = porosity - vol_ice + dwat(1:nl_soil) ,&! change in soil water + gwat ,&! net water input from top (mm/s) + rsubst ,&! subsurface runoff (mm h2o/s) + vol_liq(1:nl_soil) ,&! partial volume of liquid water in layer + vol_ice(1:nl_soil) ,&! partial volume of ice lens in layer + icefrac(1:nl_soil) ,&! ice fraction (-) + zmm (1:nl_soil) ,&! layer depth (mm) + dzmm(1:nl_soil) ,&! layer thickness (mm) + zimm(0:nl_soil) ! interface level below a "z" level (mm) + + real(r8) :: err_solver, w_sum +#if (defined CaMa_Flood) + real(r8) ::gfld ,rsur_fld, qinfl_fld_subgrid ! inundation water input from top (mm/s) +#endif + + real(r8) :: gwat_prev + integer :: ps, pe, m + + real(r8) :: wliq_soisno_tmp(1:nl_soil) + +!======================================================================= +! [1] update the liquid water within snow layer and the water onto soil +!======================================================================= + + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva + ELSE + IF ((.not.DEF_USE_SNICAR) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + ENDIF + +ELSE + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva_soil + ELSE + IF (.not. DEF_USE_SNICAR) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + gwat = gwat + pg_rain*(1-fsno) - qseva_soil + ENDIF +ENDIF + +#ifdef CROP + IF(DEF_USE_IRRIGATION)THEN + gwat = gwat + qflx_irrig_drip + qflx_irrig_flood + qflx_irrig_paddy + gwat = gwat + wdsrf/deltim + ENDIF +#endif + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + +IF(patchtype<=1)THEN ! soil ground only + + ! For water balance check, the sum of water in soil column before the calculation + w_sum = sum(wliq_soisno(1:)) + sum(wice_soisno(1:)) + wa + + ! porosity of soil, partial volume of ice and liquid + DO j = 1, nl_soil + vol_ice(j) = min(porsl(j), wice_soisno(j)/(dz_soisno(j)*denice)) + eff_porosity(j) = max(0.01, porsl(j)-vol_ice(j)) + vol_liq(j) = min(eff_porosity(j), wliq_soisno(j)/(dz_soisno(j)*denh2o)) + IF(porsl(j) < 1.e-6)THEN + icefrac(j) = 0. + ELSE + icefrac(j) = min(1.,vol_ice(j)/porsl(j)) + ENDIF + ENDDO + + ! surface runoff including water table and surface saturated area + + rsur = 0. + rsubst = 0. + + IF (DEF_Runoff_SCHEME == 0) THEN + ! 0: runoff scheme from TOPMODEL + + IF (gwat > 0.) THEN + CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,fsatmax,fsatdcf,& + z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + eff_porosity,icefrac,zwt,gwat,rsur) + ELSE + rsur = 0. + ENDIF + + ELSEIF (DEF_Runoff_SCHEME == 1) THEN + ! 1: runoff scheme from VIC model + + wliq_soisno_tmp(:) = 0 + CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gwat, & + vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& + rsur, rsubst, wliq_soisno_tmp(1:nl_soil)) + + ELSEIF (DEF_Runoff_SCHEME == 2) THEN + ! 2: runoff scheme from XinAnJiang model + + CALL Runoff_XinAnJiang (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + elvstd, gwat, deltim, rsur, rsubst) + + ELSEIF (DEF_Runoff_SCHEME == 3) THEN + ! 3: runoff scheme from Simple VIC model + CALL Runoff_SimpleVIC (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + BVIC, gwat, deltim, rsur, rsubst) + + ENDIF +#ifdef CROP + IF(patchtype==0)THEN + IF(DEF_USE_IRRIGATION)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + DO m = ps, pe + IF(irrig_method_p(m) == irrig_method_paddy)THEN + wdsrf = rsur*deltim + rsur = 0. + IF(wdsrf.gt.pondmxc)THEN + wdsrf = pondmxc + rsur = rsur + (wdsrf - pondmxc)/deltim + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF +#endif + ! infiltration into surface soil layer + qinfl = gwat - rsur - wdsrf/deltim + +#if (defined CaMa_Flood) + IF (LWINFILT) THEN + ! re-infiltration [mm/s] calculation. + ! IF surface runoff is occurred (rsur != 0.), flood depth <1.e-6 and flood fraction <0.05, + ! the re-infiltration will not be calculated. + IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05) .and. (patchtype == 0) ) THEN + gfld=flddepth/deltim ! [mm/s] + ! surface runoff from inundation, this should not be added to the surface runoff from soil + ! otherwise, the surface runoff will be double counted. + ! only the re-infiltration is added to water balance calculation. + IF (DEF_Runoff_SCHEME == 0) THEN + + CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,1.0,fsatdcf,& + z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + eff_porosity,icefrac,zwt,gfld,rsur_fld) + + ELSEIF (DEF_Runoff_SCHEME == 1) THEN + wliq_soisno_tmp(:) = 0 + CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gfld, & + vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& + rsur_fld, rsubst, wliq_soisno_tmp(1:nl_soil)) + ELSEIF (DEF_Runoff_SCHEME == 2) THEN + CALL Runoff_XinAnJiang (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + elvstd, gfld, deltim, rsur_fld, rsubst) + ELSEIF (DEF_Runoff_SCHEME == 3) THEN + CALL Runoff_SimpleVIC (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + BVIC, gfld, deltim, rsur_fld, rsubst) + ENDIF + ! infiltration into surface soil layer + qinfl_fld_subgrid = gfld - rsur_fld !assume the re-infiltration is occurred in whole patch area. + ELSE + qinfl_fld_subgrid=0.0d0 + gfld=0.0d0 + rsur_fld=0.0d0 + + ENDIF + qinfl_fld=qinfl_fld_subgrid*fldfrc ! [mm/s] re-infiltration in grid. + qinfl=qinfl_fld+qinfl ! [mm/s] total infiltration in grid. + flddepth=flddepth-deltim*qinfl_fld_subgrid ! renew flood depth [mm], the flood depth is reduced by re-infiltration but only in inundation area. + ENDIF +#endif + +!======================================================================= +! [3] determine the change of soil water +!======================================================================= + + ! convert length units from m to mm + zmm(1:) = z_soisno(1:)*1000. + dzmm(1:) = dz_soisno(1:)*1000. + zimm(0:) = zi_soisno(0:)*1000. + + CALL soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& + qinfl,etr,z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + t_soisno(1:),vol_liq,vol_ice,smp,hk,icefrac,eff_porosity,& + porsl,hksati,bsw,psi0,rootr,rootflux,& + zwt,dwat,qcharge) + + ! update the mass of liquid water + DO j= 1, nl_soil + wliq_soisno(j) = wliq_soisno(j)+dwat(j)*dzmm(j) + ENDDO + + +!======================================================================= +! [4] subsurface runoff and the corrections +!======================================================================= + + CALL groundwater (nl_soil,deltim,pondmx,& + eff_porosity,icefrac,dz_soisno(1:),zi_soisno(0:),& + wice_soisno(1:),wliq_soisno(1:),& + porsl,psi0,bsw,zwt,wa,& + qcharge,rsubst) + + ! total runoff (mm/s) + rnof = rsubst + rsur + ! Renew the ice and liquid mass due to condensation +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF(lb >= 1)THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros-qsubl) * deltim) + ENDIF + + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr-rnof)*deltim + + IF(lb >= 1)THEN + err_solver = err_solver-(qsdew+qfros-qsubl)*deltim + ENDIF + +ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew_soil * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros_soil-qsubl_soil) * deltim) + + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr-rnof)*deltim + + err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim +ENDIF + +#if (defined CaMa_Flood) + IF (LWINFILT) THEN + err_solver = err_solver-(gfld-rsur_fld)*fldfrc*deltim + ENDIF +#endif + + +#if (defined CoLMDEBUG) + IF(abs(err_solver) > 1.e-3)THEN + write(6,*) 'Warning: water balance violation after all soilwater calculation', err_solver + ENDIF +#endif + + +!======================================================================= +! [6] assumed hydrological scheme for the wetland and glacier +!======================================================================= + +ELSE + IF(patchtype==2)THEN ! WETLAND + ! 09/20/2019, by Chaoqun Li: a potential bug below + ! surface runoff could > total runoff + ! original CoLM: rusr=0., qinfl=gwat, rsubst=0., rnof=0. + ! i.e., all water to be infiltration + qinfl = 0. + rsur = max(0.,gwat) + rsubst = 0. + rnof = 0. + DO j = 1, nl_soil + IF(t_soisno(j)>tfrz)THEN + wice_soisno(j) = 0.0 + wliq_soisno(j) = porsl(j)*dz_soisno(j)*1000. + ENDIF + ENDDO + ENDIF + IF(patchtype==3)THEN ! LAND ICE + rsur = max(0.0,gwat) + qinfl = 0. + rsubst = 0. + rnof = rsur + wice_soisno(1:nl_soil) = dz_soisno(1:nl_soil)*1000. + wliq_soisno(1:nl_soil) = 0.0 + ENDIF + + wa = 4800. + zwt = 0. + qcharge = 0. + +ENDIF + + END SUBROUTINE WATER_2014 + +!----------------------------------------------------------------------- + SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,bsw ,theta_r ,& + fsatmax ,fsatdcf ,topoweti ,alp_twi ,chi_twi ,& + mu_twi ,elvstd ,BVIC ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm ,n_vgm ,L_vgm ,sc_vgm ,fc_vgm ,& +#endif + porsl ,psi0 ,hksati ,rootr ,rootflux ,& + t_soisno ,wliq_soisno ,wice_soisno ,smp ,hk ,& + pg_rain ,sm ,etr ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,& + qfros_soil ,qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + fsno ,frcsat ,rsur ,rsur_se ,rsur_ie ,& + rsubst ,rnof ,qinfl ,qlayer ,ssi ,& + pondmx ,wimp ,zwt ,wdsrf ,wa ,& + wetwat ,& +#if (defined CaMa_Flood) + flddepth ,fldfrc ,qinfl_fld ,& +#endif +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! irrigation variable + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ) + +!=================================================================================== +! this is the main SUBROUTINE to execute the calculation of soil water processes +! +! Original author: Yongjiu Dai, /09/1999/, /08/2002/, /04/2014/ +! +! Modified by Shupeng Zhang /07/2023/ to USE Variably Saturated Flow algorithm +! Reference : +! Dai, Y., Zhang, S., Yuan, H., & Wei, N. (2019). +! Modeling Variably Saturated Flow in Stratified Soils +! With Explicit Tracking of Wetting Front and Water Table Locations. +! Water Resources Research. doi:10.1029/2019wr025368 +! +!=================================================================================== + + USE MOD_Precision + USE MOD_Hydro_SoilWater + USE MOD_Vars_TimeInvariants, only: wetwatmax + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_Vars_TimeInvariants, only: vic_b_infilt, vic_Dsmax, vic_Ds, vic_Ws, vic_c + USE MOD_Vars_1DFluxes, only: fevpg + USE MOD_Opt_Baseflow, only: scale_baseflow +#ifdef DataAssimilation + USE MOD_DA_TWS, only: fslp_k +#endif +#ifdef CROP + USE MOD_Vars_Global, only : irrig_method_paddy, pondmxc + use MOD_LandPFT, only : patch_pft_s, patch_pft_e + use MOD_Vars_PFTimeVariables, only: irrig_method_p +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,& ! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=land water bodies, 99=ocean + logical, intent(in) :: is_dry_lake + + integer, intent(in) :: & + lb , &! lower bound of array + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + deltim , &! time step (s) + ! wtfact , &! (updated to gridded 'fsatmax' data) fraction of model area with high water table + ssi , &! irreducible water saturation of snow + pondmx , &! ponding depth (mm) + wimp , &! water impermeable IF porosity less than wimp + elvstd , &! standard deviation of elevation (m) + BVIC , &! + z_soisno (lb:nl_soil) , &! layer depth (m) + dz_soisno(lb:nl_soil) , &! layer thickness (m) + zi_soisno(lb-1:nl_soil) , &! interface level below a "z" level (m) + bsw (1:nl_soil), & ! clapp and hornberger "b" parameter [-] + theta_r (1:nl_soil), & ! residual moisture content [-] + fsatmax , & ! maximum saturated area fraction [-] + fsatdcf , & ! decay factor in calculation of saturated area fraction [1/m] + topoweti , & ! mean topographic wetness index + alp_twi , & ! alpha in three parameter gamma distribution of twi + chi_twi , & ! chi in three parameter gamma distribution of twi + mu_twi , & ! mu in three parameter gamma distribution of twi +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:nl_soil), & ! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), & ! a shape parameter [dimensionless] + L_vgm (1:nl_soil), & ! pore-connectivity parameter [dimensionless] + sc_vgm (1:nl_soil), & ! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), & ! a scaling factor by using air entry value in the Mualem model [-] +#endif + porsl(1:nl_soil) , &! saturated volumetric soil water content(porosity) + psi0(1:nl_soil) , &! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil), &! hydraulic conductivity at saturation (mm h2o/s) + rootr(1:nl_soil) , &! water uptake fraction from different layers, all layers add to 1.0 + rootflux(1:nl_soil),&! root uptake from different layer, all layers add to transpiration + + t_soisno(lb:nl_soil), &! soil/snow skin temperature (K) + pg_rain , &! rainfall after removal of interception (mm h2o/s) + sm , &! snow melt (mm h2o/s) + etr , &! actual transpiration (mm h2o/s) + qseva , &! ground surface evaporation rate (mm h2o/s) + qsdew , &! ground surface dew formation (mm h2o /s) [+] + qsubl , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros , &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil , &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil , &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil , &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil , &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow , &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow , &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow , &! surface dew added to snow pack (mm h2o /s) [+] + fsno ! snow fractional cover +#if (defined CaMa_Flood) + real(r8), intent(inout) :: flddepth ! inundation water input from top (mm/s) + real(r8), intent(in) :: fldfrc ! inundation water input from top (mm/s) + real(r8), intent(out) :: qinfl_fld ! inundation water input from top (mm/s) +#endif + + real(r8), intent(inout) :: & + wice_soisno(lb:nl_soil) , &! ice lens (kg/m2) + wliq_soisno(lb:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(out) :: & + smp(1:nl_soil) , &! soil matrix potential [mm] + hk (1:nl_soil) ! hydraulic conductivity [mm h2o/s] + + real(r8), intent(inout) :: & + zwt , &! the depth from ground (soil) surface to water table [m] + wdsrf , &! depth of surface water [mm] + wa , &! water storage in aquifer [mm] + wetwat ! water storage in wetland [mm] + + real(r8), intent(out) :: & + frcsat , &! fraction of saturation area + rsur , &! surface runoff (mm h2o/s) + rsur_se , &! saturation excess surface runoff (mm h2o/s) + rsur_ie , &! infiltration excess surface runoff (mm h2o/s) + rsubst , &! subsurface runoff (mm h2o/s) + rnof , &! total runoff (mm h2o/s) + qinfl , &! infiltration rate (mm h2o/s) + qlayer(0:nl_soil) ! water flux between soil layer [mm h2o/s] + + + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(in) :: forc_aer ( 14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + real(r8), intent(inout) :: & + mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +! irrigation variable + real(r8), intent(in) :: & + qflx_irrig_drip , &! irrigation flux from drip irrigation [mm/s] + qflx_irrig_flood , &! irrigation flux from flood irrigation [mm/s] + qflx_irrig_paddy ! irrigation flux from paddy irrigation [mm/s] + +!-------------------------- Local Variables ---------------------------- + + integer j ! loop counter + + real(r8) :: & + eff_porosity(1:nl_soil), &! effective porosity = porosity - vol_ice + gwat , &! net water input from top (mm/s) + drainmax , &! drainage max (mm h2o/s) + vol_liq(1:nl_soil), &! partial volume of liquid water in layer + vol_ice(1:nl_soil), &! partial volume of ice lens in layer + icefrac(1:nl_soil) ! ice fraction (-) + + real(r8) :: eta + + real(r8) :: err_solver, w_sum, wresi(1:nl_soil) + real(r8) :: qgtop + + real(r8) :: zwtmm + real(r8) :: sp_zc(1:nl_soil), sp_zi(0:nl_soil), sp_dz(1:nl_soil) ! in mm + logical :: is_permeable(1:nl_soil) + real(r8) :: dzsum, dz + real(r8) :: icefracsum, fracice_rsub, imped + real(r8) :: wblc + +#ifdef Campbell_SOIL_MODEL + integer, parameter :: nprms = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: nprms = 5 +#endif + real(r8) :: prms(nprms, 1:nl_soil) +#if (defined CaMa_Flood) + real(r8) :: gfld,qinfl_all,rsur_fld, qinfl_fld_subgrid! inundation water input from top (mm/s) +#endif + + type(soil_con_struct ) :: soil_con + type(cell_data_struct) :: cell + real(r8) :: wliq_soisno_tmp(1:nl_soil) + + real(r8), parameter :: e_ice=6.0 !soil ice impedance factor + + integer :: ps, pe, m + + +#ifdef Campbell_SOIL_MODEL + prms(1,:) = bsw(1:nl_soil) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + prms(1,1:nl_soil) = alpha_vgm(1:nl_soil) + prms(2,1:nl_soil) = n_vgm (1:nl_soil) + prms(3,1:nl_soil) = L_vgm (1:nl_soil) + prms(4,1:nl_soil) = sc_vgm (1:nl_soil) + prms(5,1:nl_soil) = fc_vgm (1:nl_soil) +#endif + +!======================================================================= +! [1] update the liquid water within snow layer and the water onto soil +!======================================================================= + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva + ELSE + + IF ((.not.DEF_USE_SNICAR) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + ENDIF + +ELSE + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva_soil + ELSE + IF (.not. DEF_USE_SNICAR) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + gwat = gwat + pg_rain*(1-fsno) - qseva_soil + ENDIF +ENDIF + + +#ifdef CROP + IF(DEF_USE_IRRIGATION)THEN + gwat = gwat + qflx_irrig_drip + qflx_irrig_flood + qflx_irrig_paddy + ENDIF +#endif + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + +IF((patchtype<=1) .or. is_dry_lake & + .or. (DEF_USE_Dynamic_Wetland .and. (patchtype==2)))THEN ! soil ground only + + ! For water balance check, the sum of water in soil column before the calculation + w_sum = sum(wliq_soisno(1:nl_soil)) + sum(wice_soisno(1:nl_soil)) + wa + wdsrf + + ! Due to the increase in volume after freezing, the total volume of water and + ! ice may exceed the porosity of the soil. This excess water is temporarily + ! stored in "wresi". After calculating the movement of soil water, "wresi" + ! is added back to "wliq_soisno". + wresi(1:nl_soil) = 0. + ! porosity of soil, partial volume of ice and liquid + DO j = 1, nl_soil + vol_ice(j) = min(porsl(j), wice_soisno(j)/(dz_soisno(j)*denice)) + IF(porsl(j) < 1.e-6)THEN + icefrac(j) = 0. + ELSE + icefrac(j) = min(1.,vol_ice(j)/porsl(j)) + ENDIF + + eff_porosity(j) = max(wimp, porsl(j)-vol_ice(j)) + is_permeable(j) = eff_porosity(j) > max(wimp, theta_r(j)) + IF (is_permeable(j)) THEN + vol_liq(j) = wliq_soisno(j)/(dz_soisno(j)*denh2o) + vol_liq(j) = min(eff_porosity(j), max(0., vol_liq(j))) + wresi(j) = wliq_soisno(j) - dz_soisno(j) * denh2o * vol_liq(j) + ELSE + vol_liq(j) = 0. + ENDIF + ENDDO + + ! surface runoff including water table and surface saturated area + + rsur = 0. + rsubst = 0. + rsur_ie = 0. + rsur_se = 0. + +#ifndef CatchLateralFlow + IF (patchtype <= 1) THEN + + IF (DEF_Runoff_SCHEME == 0) THEN + + CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,fsatmax,fsatdcf,& + z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + eff_porosity,icefrac,zwt,gwat,rsur,rsur_se,rsur_ie,topoweti,alp_twi,chi_twi,mu_twi,frcsat,eta) + + CALL SubsurfaceRunoff_TOPMOD (nl_soil, icefrac, dz_soisno(1:), zi_soisno(0:), & + zwt, rsubst, hksati, topoweti, eta) + + ELSEIF (DEF_Runoff_SCHEME == 1) THEN + ! 1: runoff scheme from VIC model + + CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gwat, & + vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& + rsur, rsubst, wliq_soisno_tmp) + + rsur_se = rsur + rsur_ie = 0. + + ELSEIF (DEF_Runoff_SCHEME == 2) THEN + ! 2: runoff scheme from XinAnJiang model + + CALL Runoff_XinAnJiang (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + elvstd, gwat, deltim, rsur, rsubst, frcsat) + + rsur_se = rsur + rsur_ie = 0. + + ELSEIF (DEF_Runoff_SCHEME == 3) THEN + ! 3: runoff scheme from simplified VIC model + + CALL Runoff_SimpleVIC (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + BVIC, gwat, deltim, rsur, rsubst, frcsat) + + ! CALL SubsurfaceRunoff_SimpleVIC ( & + ! nl_soil, z_soisno(1:nl_soil), dz_soisno(1:nl_soil), wice_soisno(1:nl_soil), & + ! porsl(1:nl_soil), psi0(1:nl_soil), hksati(1:nl_soil), theta_r(1:nl_soil), & + ! nprms, prms(:,1:nl_soil), zwt, rsubst) + + rsur_se = rsur + rsur_ie = 0. + + ENDIF + + rsubst = rsubst * scale_baseflow(ipatch) + +#ifdef DataAssimilation + IF (DEF_DA_TWS_GRACE) THEN + rsur = max(min(rsur * fslp_k(ipatch), gwat), 0.) + rsubst = rsubst * fslp_k(ipatch) + ENDIF +#endif + +#ifdef CROP + IF(patchtype.eq.0 .AND. DEF_USE_IRRIGATION)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + DO m = ps, pe + IF(irrig_method_p(m).eq.irrig_method_paddy)THEN + rsur = 0 + ENDIF + ENDDO + ENDIF +#endif + ENDIF +#else + ! for catchment based lateral flow, + ! "rsur" is calculated in HYDRO/MOD_Catch_HillslopeFlow.F90 + ! "rsub" is calculated in HYDRO/MOD_Catch_SubsurfaceFlow.F90 +#endif + + ! infiltration into surface soil layer + qgtop = gwat - rsur + +#if (defined CaMa_Flood) + IF (LWINFILT) THEN + ! re-infiltration [mm/s] calculation. + ! IF surface runoff is occurred (rsur != 0.), flood depth <1.e-6 and flood fraction <0.05, + ! the re-infiltration will not be calculated. + IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05) .and. (patchtype == 0) ) THEN + gfld=flddepth/deltim ! [mm/s] + ! surface runoff from inundation, this should not be added to the surface runoff from soil + ! otherwise, the surface runoff will be double counted. + ! only the re-infiltration is added to water balance calculation. + IF (DEF_Runoff_SCHEME == 0) THEN + + CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,1.0,fsatdcf,& + z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + eff_porosity,icefrac,zwt,gfld,rsur_fld) + + ELSEIF (DEF_Runoff_SCHEME == 1) THEN + wliq_soisno_tmp(:) = 0 + CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gfld, & + vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& + rsur_fld, rsubst, wliq_soisno_tmp(1:nl_soil)) + ELSEIF (DEF_Runoff_SCHEME == 2) THEN + CALL Runoff_XinAnJiang (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + elvstd, gfld, deltim, rsur_fld, rsubst) + ELSEIF (DEF_Runoff_SCHEME == 3) THEN + CALL Runoff_SimpleVIC (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + BVIC, gfld, deltim, rsur_fld, rsubst) + ENDIF + ! infiltration into surface soil layer + qinfl_fld_subgrid = gfld - rsur_fld !assume the re-infiltration is occurred in whole patch area. + ELSE + qinfl_fld_subgrid=0.0d0 + gfld=0.0d0 + rsur_fld=0.0d0 + + ENDIF + qinfl_fld=qinfl_fld_subgrid*fldfrc ! [mm/s] re-infiltration in grid. + !qinfl=qinfl_fld+qinfl ! [mm/s] total infiltration in grid. + qgtop=qinfl_fld+qgtop ! [mm/s] total infiltration in grid. + flddepth=flddepth-deltim*qinfl_fld_subgrid ! renew flood depth [mm], the flood depth is reduced by re-infiltration but only in inundation area. + ENDIF +#endif +!======================================================================= +! [3] determine the change of soil water +!======================================================================= + + ! convert length units from m to mm + zwtmm = zwt * 1000.0 + sp_zc(1:nl_soil) = z_soisno (1:nl_soil) * 1000.0 ! from meter to mm + sp_zi(0:nl_soil) = zi_soisno(0:nl_soil) * 1000.0 ! from meter to mm + + ! check consistency between water table location and liquid water content + IF (wa < 0.) THEN + IF (zwtmm <= sp_zi(nl_soil)) THEN + CALL get_zwt_from_wa ( & + porsl(nl_soil), theta_r(nl_soil), psi0(nl_soil), hksati(nl_soil), & + nprms, prms(:,nl_soil), 1.e-5, 1.e-8, wa, sp_zi(nl_soil), zwtmm) + ENDIF + ELSE + DO j = 1, nl_soil + IF ((vol_liq(j) < eff_porosity(j)-1.e-8) .and. (zwtmm <= sp_zi(j-1))) THEN + zwtmm = sp_zi(j) + ENDIF + ENDDO + ENDIF + + ! update "vol_liq" in the level containing water table + ! "vol_liq" in this level refers to volume content in unsaturated part + IF (zwtmm < sp_zi(nl_soil)) THEN + DO j = nl_soil, 1, -1 + IF ((zwtmm >= sp_zi(j-1)) .and. (zwtmm < sp_zi(j))) THEN + + IF ((zwtmm > sp_zi(j-1)) .and. (is_permeable(j))) THEN + vol_liq(j) = (wliq_soisno(j)*1000.0/denh2o - eff_porosity(j)*(sp_zi(j)-zwtmm)) & + / (zwtmm - sp_zi(j-1)) + IF (vol_liq(j) < 0.) THEN + zwtmm = sp_zi(j) + vol_liq(j) = wliq_soisno(j)*1000.0/denh2o / (sp_zi(j) - sp_zi(j-1)) + ENDIF + + vol_liq(j) = max(0., min(eff_porosity(j), vol_liq(j))) + wresi(j) = wliq_soisno(j)*1000.0/denh2o - eff_porosity(j)*(sp_zi(j)-zwtmm) & + - vol_liq(j) * (zwtmm - sp_zi(j-1)) + ENDIF + + EXIT + ENDIF + ENDDO + ENDIF + + wdsrf = max(0., wdsrf) + + IF ((.not. is_permeable(1)) .and. (qgtop < 0.)) THEN + IF (wdsrf > 0) THEN + wdsrf = wdsrf + qgtop * deltim + IF (wdsrf < 0) THEN + wliq_soisno(1) = max(0., wliq_soisno(1) + wdsrf) + wdsrf = 0 + ENDIF + ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qgtop * deltim) + ENDIF + + qgtop = 0. + + ENDIF + + CALL soil_water_vertical_movement ( & + nl_soil, deltim, sp_zc(1:nl_soil), sp_zi(0:nl_soil), & + is_permeable(1:nl_soil), eff_porosity(1:nl_soil), theta_r(1:nl_soil), psi0(1:nl_soil), & + hksati(1:nl_soil), nprms, prms(:,1:nl_soil), porsl(nl_soil), qgtop, & + etr, rootr(1:nl_soil), rootflux(1:nl_soil), rsubst, & + qinfl, wdsrf, zwtmm, wa, & + vol_liq(1:nl_soil), smp(1:nl_soil), hk(1:nl_soil), qlayer(0:nl_soil),& + 1.e-3, wblc) + + ! update the mass of liquid water + DO j = nl_soil, 1, -1 + IF (is_permeable(j)) THEN + IF (zwtmm < sp_zi(j)) THEN + IF (zwtmm >= sp_zi(j-1)) THEN + wliq_soisno(j) = denh2o * ((eff_porosity(j)*(sp_zi(j)-zwtmm)) & + + vol_liq(j) * (zwtmm - sp_zi(j-1)))/1000.0 + ELSE + wliq_soisno(j) = denh2o * (eff_porosity(j)*(sp_zi(j)-sp_zi(j-1)))/1000.0 + ENDIF + ELSE + wliq_soisno(j) = denh2o * (vol_liq(j)*(sp_zi(j)-sp_zi(j-1)))/1000.0 + ENDIF + + wliq_soisno(j) = wliq_soisno(j) + wresi(j) + ENDIF + ENDDO + + zwt = zwtmm/1000.0 + + ! Renew the ice and liquid mass due to condensation +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF(lb >= 1)THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros-qsubl) * deltim) + ENDIF +ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew_soil * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros_soil-qsubl_soil) * deltim) +ENDIF + + ! water imbalance mainly due to insufficient liquid water for evapotranspiration + IF (wblc > 0.) THEN + DO j = 1, nl_soil + IF (wice_soisno(j) > wblc) THEN + wice_soisno(j) = wice_soisno(j) - wblc + wblc = 0. + EXIT + ELSE + wblc = wblc - wice_soisno(j) + wice_soisno(j) = 0. + ENDIF + ENDDO + ENDIF + +#ifndef CatchLateralFlow +#ifdef CROP + IF(patchtype.eq.0 .AND. DEF_USE_IRRIGATION)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + DO m = ps, pe + IF(irrig_method_p(m).eq.irrig_method_paddy .AND. wdsrf.gt.pondmxc)THEN + rsur = rsur + (wdsrf - pondmxc)/deltim + rsur_ie = rsur_ie + (wdsrf - pondmxc) / deltim + wdsrf = pondmxc + ELSEIF(irrig_method_p(m).ne.irrig_method_paddy .AND. wdsrf.gt.pondmx)THEN + rsur = rsur + (wdsrf - pondmx) / deltim + rsur_ie = rsur_ie + (wdsrf - pondmx) / deltim + wdsrf = pondmx + ENDIF + ENDDO + + IF (zwt <= 0.) THEN + rsur_ie = 0. + rsur_se = rsur + ENDIF + ! total runoff (mm/s) + rnof = rsubst + rsur + ELSE +#endif + IF (patchtype <= 1) THEN + IF (wdsrf > pondmx) THEN + rsur = rsur + (wdsrf - pondmx) / deltim + rsur_ie = rsur_ie + (wdsrf - pondmx) / deltim + wdsrf = pondmx + ENDIF + + IF (zwt <= 0.) THEN + rsur_ie = 0. + rsur_se = rsur + ENDIF + + ! total runoff (mm/s) + rnof = rsubst + rsur + ELSEIF (patchtype == 2) THEN ! for wetland + IF (wdsrf > wetwatmax) THEN + rsur_se = (wdsrf - wetwatmax) / deltim + wdsrf = wetwatmax + ENDIF + + rsur = rsur_se + ! total runoff (mm/s) + rnof = rsur + ELSE ! for dry lake + rnof = 0. + ENDIF +#ifdef CROP + ENDIF +#endif +#endif + + DO j = 1, nl_soil + IF(t_soisno(j) <= tfrz) THEN + ! consider impedance factor + vol_ice(j) = max(min(porsl(j), wice_soisno(j)/(dz_soisno(j)*denice)), 0.) + icefrac(j) = vol_ice(j)/porsl(j) + imped = 10.**(-e_ice*icefrac(j)) + hk(j) = imped * hk(j) + ENDIF + ENDDO + +#ifndef CatchLateralFlow + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr-rsur-rsubst)*deltim +#else + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr)*deltim +#endif + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF(lb >= 1)THEN + err_solver = err_solver - (qsdew+qfros-qsubl)*deltim + ENDIF +ELSE + err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim +ENDIF + +#if (defined CaMa_Flood) + IF (LWINFILT) THEN + err_solver = err_solver-(gfld-rsur_fld)*fldfrc*deltim + ENDIF +#endif + +#if (defined CoLMDEBUG) + IF(abs(err_solver) > 1.e-3)THEN + write(6,'(A,E20.5,A,I0)') 'Warning (WATER_VSF): water balance violation', err_solver, & + ' in element ', landpatch%eindex(ipatch) + ENDIF + IF (any(wliq_soisno < -1.e-3)) THEN + write(6,'(A,10E20.5)') 'Warning (WATER_VSF): negative soil water', wliq_soisno(1:nl_soil) + ENDIF +#endif + +!======================================================================= +! [6] assumed hydrological scheme for the wetland +!======================================================================= + +ELSE + IF(patchtype==2)THEN ! WETLAND + qinfl = 0. + zwt = 0. + + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + IF (lb >= 1) THEN + wetwat = wdsrf + wa + wetwat + (gwat - etr + qsdew + qfros - qsubl) * deltim + ELSE + wetwat = wdsrf + wa + wetwat + (gwat - etr) * deltim + ENDIF + ELSE + wetwat = wdsrf + wa + wetwat + (gwat - etr + qsdew_soil + qfros_soil - qsubl_soil) * deltim + ENDIF + + wresi(:) = 0. + DO j = 1, nl_soil + IF(t_soisno(j)>tfrz)THEN + wresi(j) = max(wliq_soisno(j) - porsl(j)*dz_soisno(j)*1000., 0.) + wliq_soisno(j) = wliq_soisno(j) - wresi(j) + ENDIF + ENDDO + + wetwat = wetwat + sum(wresi) + + IF (wetwat > wetwatmax) THEN + wdsrf = wetwat - wetwatmax + wetwat = wetwatmax + wa = 0. + ELSEIF (wetwat < 0) THEN + wa = wetwat + wdsrf = 0. + wetwat = 0. + ELSE + wdsrf = 0. + wa = 0. + ENDIF + + frcsat = 1. + +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rnof = rsur + rsur_se = rsur + rsur_ie = 0. +#endif + ENDIF + +ENDIF + + END SUBROUTINE WATER_VSF + + + SUBROUTINE snowwater (lb,deltim,ssi,wimp, & + pg_rain,qseva,qsdew,qsubl,qfros, & + dz_soisno,wice_soisno,wliq_soisno,qout_snowb) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, /09/1999; /04/2014 +! +! Water flow within snow is computed by an explicit and non-physical based +! scheme, which permits a part of liquid water over the holding capacity (a +! tentative value is used, i.e., equal to 0.033*porosity) to percolate into the +! underlying layer, except the case of that the porosity of one of the two +! neighboring layers is less than 0.05, the zero flow is assumed. The water +! flow out of the bottom snow pack will participate as the input of the soil +! water and runoff. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o ! physical constant + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + lb ! lower bound of array + + real(r8), intent(in) :: & + deltim, &! seconds in a time step (s) + ssi, &! irreducible water saturation of snow + wimp, &! water impermeable if porosity less than wimp + dz_soisno(lb:0), &! layer thickness (m) + + pg_rain, &! rainfall after removal of interception (mm h2o/s) + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros ! surface dew added to snow pack (mm h2o /s) [+] + + real(r8), intent(inout) :: & + wice_soisno(lb:0),&! ice lens (kg/m2) + wliq_soisno(lb:0) ! liquid water (kg/m2) + + real(r8), intent(out) :: & + qout_snowb ! rate of water out of snow bottom (mm/s) + +!-------------------------- Local Variables ---------------------------- + integer j ! k do loop/array indices + + real(r8) :: & + qin, &! water flow into the element (mm/s) + qout, &! water flow out of the element (mm/s) + zwice, &! the sum of ice mass of snow cover (kg/m2) + wgdif, &! ice mass after minus sublimation + vol_liq(lb:0), &! partial volume of liquid water in layer + vol_ice(lb:0), &! partial volume of ice lens in layer + eff_porosity(lb:0) ! effective porosity = porosity - vol_ice + +!======================================================================= +! renew the mass of ice lens (wice_soisno) and liquid (wliq_soisno) in the +! surface snow layer, resulted by sublimation (frost) / evaporation (condense) + + wgdif = wice_soisno(lb) + (qfros - qsubl)*deltim + wice_soisno(lb) = wgdif + IF(wgdif < 0.)THEN + wice_soisno(lb) = 0. + wliq_soisno(lb) = wliq_soisno(lb) + wgdif + ENDIF + + wliq_soisno(lb) = wliq_soisno(lb) + (pg_rain + qsdew - qseva)*deltim + IF (wliq_soisno(lb) < 0.) THEN + wice_soisno(lb) = wice_soisno(lb) + wliq_soisno(lb) + wice_soisno(lb) = max(wice_soisno(lb), 0.) + wliq_soisno(lb) = 0. + ENDIF + +! Porosity and partial volume + DO j = lb, 0 + vol_ice(j) = min(1., wice_soisno(j)/(dz_soisno(j)*denice)) + eff_porosity(j) = max(0.01, 1. - vol_ice(j)) + vol_liq(j) = min(eff_porosity(j), wliq_soisno(j)/(dz_soisno(j)*denh2o)) + ENDDO + +! Capillary force within snow could be two or more orders of magnitude less +! than those of gravity, this term may be ignored. Here we could keep the +! gravity term only. The general expression for water flow is "K * ss**3", +! however, no effective parameterization for "K". Thus, a very simple treatment +! (not physical based) is introduced: when the liquid water of layer exceeds +! the layer's holding capacity, the excess meltwater adds to the underlying +! neighbor layer. + + qin = 0. + DO j= lb, 0 + wliq_soisno(j) = wliq_soisno(j) + qin + + IF(j <= -1)THEN + ! no runoff over snow surface, just ponding on surface + IF(eff_porosity(j) mss_bcphi(j)) THEN + qout_bc_phi = mss_bcphi(j) + ENDIF + mss_bcphi(j) = mss_bcphi(j) - qout_bc_phi + qin_bc_phi = qout_bc_phi + + ! BCPHO: + ! 1. flux with meltwater: + qout_bc_pho = qout*scvng_fct_mlt_bcpho*(mss_bcpho(j)/mss_liqice(j)) + IF (qout_bc_pho > mss_bcpho(j)) THEN + qout_bc_pho = mss_bcpho(j) + ENDIF + mss_bcpho(j) = mss_bcpho(j) - qout_bc_pho + qin_bc_pho = qout_bc_pho + + ! OCPHI: + ! 1. flux with meltwater: + qout_oc_phi = qout*scvng_fct_mlt_ocphi*(mss_ocphi(j)/mss_liqice(j)) + IF (qout_oc_phi > mss_ocphi(j)) THEN + qout_oc_phi = mss_ocphi(j) + ENDIF + mss_ocphi(j) = mss_ocphi(j) - qout_oc_phi + qin_oc_phi = qout_oc_phi + + ! OCPHO: + ! 1. flux with meltwater: + qout_oc_pho = qout*scvng_fct_mlt_ocpho*(mss_ocpho(j)/mss_liqice(j)) + IF (qout_oc_pho > mss_ocpho(j)) THEN + qout_oc_pho = mss_ocpho(j) + ENDIF + mss_ocpho(j) = mss_ocpho(j) - qout_oc_pho + qin_oc_pho = qout_oc_pho + + ! DUST 1: + ! 1. flux with meltwater: + qout_dst1 = qout*scvng_fct_mlt_dst1*(mss_dst1(j)/mss_liqice(j)) + IF (qout_dst1 > mss_dst1(j)) THEN + qout_dst1 = mss_dst1(j) + ENDIF + mss_dst1(j) = mss_dst1(j) - qout_dst1 + qin_dst1 = qout_dst1 + + ! DUST 2: + ! 1. flux with meltwater: + qout_dst2 = qout*scvng_fct_mlt_dst2*(mss_dst2(j)/mss_liqice(j)) + IF (qout_dst2 > mss_dst2(j)) THEN + qout_dst2 = mss_dst2(j) + ENDIF + mss_dst2(j) = mss_dst2(j) - qout_dst2 + qin_dst2 = qout_dst2 + + ! DUST 3: + ! 1. flux with meltwater: + qout_dst3 = qout*scvng_fct_mlt_dst3*(mss_dst3(j)/mss_liqice(j)) + IF (qout_dst3 > mss_dst3(j)) THEN + qout_dst3 = mss_dst3(j) + ENDIF + mss_dst3(j) = mss_dst3(j) - qout_dst3 + qin_dst3 = qout_dst3 + + ! DUST 4: + ! 1. flux with meltwater: + qout_dst4 = qout*scvng_fct_mlt_dst4*(mss_dst4(j)/mss_liqice(j)) + IF (qout_dst4 > mss_dst4(j)) THEN + qout_dst4 = mss_dst4(j) + ENDIF + mss_dst4(j) = mss_dst4(j) - qout_dst4 + qin_dst4 = qout_dst4 +! Aerosol Fluxes (Jan. 07, 2023) + + ENDDO + + qout_snowb = qout/deltim + + +! Aerosol Fluxes (Jan. 07, 2023) +! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layere +!----------------------------------------------------------------------- +! set aerosol deposition fluxes from forcing array +! The forcing array is either set from an external file +! or from fluxes received from the atmosphere model +#ifdef MODAL_AER + ! Mapping for modal aerosol scheme where within-hydrometeor and + ! interstitial aerosol fluxes are differentiated. Here, "phi" + ! flavors of BC and OC correspond to within-hydrometeor + ! (cloud-borne) aerosol, and "pho" flavors are interstitial + ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are + ! purely diagnostic + ! + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + + flx_bc_dep_phi = forc_aer(3) + flx_bc_dep_pho = forc_aer(1) + forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(6) + flx_oc_dep_pho = forc_aer(4) + forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#else + ! Original mapping for bulk aerosol deposition. phi and pho BC/OC + ! species are distinguished in model, other fluxes (e.g., dry and + ! wet BC/OC) are purely diagnostic. + + flx_bc_dep_phi = forc_aer(1) + forc_aer(3) + flx_bc_dep_pho = forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(4) + forc_aer(6) + flx_oc_dep_pho = forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#endif + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + + mss_bcphi(lb) = mss_bcphi(lb) + (flx_bc_dep_phi*deltim) + mss_bcpho(lb) = mss_bcpho(lb) + (flx_bc_dep_pho*deltim) + mss_ocphi(lb) = mss_ocphi(lb) + (flx_oc_dep_phi*deltim) + mss_ocpho(lb) = mss_ocpho(lb) + (flx_oc_dep_pho*deltim) + + mss_dst1(lb) = mss_dst1(lb) + (flx_dst_dep_dry1 + flx_dst_dep_wet1)*deltim + mss_dst2(lb) = mss_dst2(lb) + (flx_dst_dep_dry2 + flx_dst_dep_wet2)*deltim + mss_dst3(lb) = mss_dst3(lb) + (flx_dst_dep_dry3 + flx_dst_dep_wet3)*deltim + mss_dst4(lb) = mss_dst4(lb) + (flx_dst_dep_dry4 + flx_dst_dep_wet4)*deltim + +#ifdef MODAL_AER + ! + ! Transfer BC and OC from the within-ice state to the external + ! state based on snow sublimation and re-freezing of liquid water. + ! Re-freezing effect is inactived by default because of + ! uncertainty in how this process operates. + + DO j= lb, 0 + IF (j >= lb) THEN + IF (j == lb) THEN + ! snow that has sublimated [kg/m2] (top layer only) + subsnow = max(0._r8, (qsubl*deltim)) + + ! fraction of layer mass that has sublimated: + IF ((wliq_soisno(j) + wice_soisno(j)) > 0._r8) THEN + frc_sub = subsnow / (wliq_soisno(j) + wice_soisno(j)) + ELSE + frc_sub = 0._r8 + ENDIF + ELSE + ! prohibit sublimation effect to operate on sub-surface layers: + frc_sub = 0._r8 + ENDIF + + ! fraction of layer mass transformed (sublimation only) + frc_transfer = frc_sub + + ! cap the fraction at 1 + IF (frc_transfer > 1._r8) THEN + frc_transfer = 1._r8 + ENDIF + + ! transfer proportionate mass of BC and OC: + dm_int = mss_bcphi(j)*frc_transfer + mss_bcphi(j) = mss_bcphi(j) - dm_int + mss_bcpho(j) = mss_bcpho(j) + dm_int + + dm_int = mss_ocphi(j)*frc_transfer + mss_ocphi(j) = mss_ocphi(j) - dm_int + mss_ocpho(j) = mss_ocpho(j) + dm_int + + ENDIF + ENDDO +#endif +! Aerosol Fluxes (Jan. 7, 2023) + + END SUBROUTINE SnowWater_snicar + + + SUBROUTINE soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& + qinfl,etr,z_soisno,dz_soisno,zi_soisno,& + t_soisno,vol_liq,vol_ice,smp,hk,icefrac,eff_porosity,& + porsl,hksati,bsw,psi0,rootr,rootflux,& + zwt,dwat,qcharge) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, 09/1999, 04/2014, 07/2014 +! +! some new parameterization are added, which are based on CLM4.5 +! +! Soil moisture is predicted from a 10-layer model (as with soil +! temperature), in which the vertical soil moisture transport is governed +! by infiltration, runoff, gradient diffusion, gravity, and root +! extraction through canopy transpiration. The net water applied to the +! surface layer is the snowmelt plus precipitation plus the throughfall +! of canopy dew minus surface runoff and evaporation. +! +! The vertical water flow in an unsaturated porous media is described by +! Darcy's law, and the hydraulic conductivity and the soil negative +! potential vary with soil water content and soil texture based on the work +! of Clapp and Hornberger (1978) and Cosby et al. (1984). The equation is +! integrated over the layer thickness, in which the time rate of change in +! water mass must equal the net flow across the bounding interface, plus the +! rate of internal source or sink. The terms of water flow across the layer +! interfaces are linearly expanded by using first-order Taylor expansion. +! The equations result in a tridiagonal system equation. +! +! Note: length units here are all millimeter +! (in temperature SUBROUTINE uses same soil layer +! structure required but lengths are m) +! +! Richards equation: +! +! d wat d d psi +! ----- = -- [ k(----- - 1) ] + S +! dt dz dz +! +! where: wat = volume of water per volume of soil (mm**3/mm**3) +! psi = soil matrix potential (mm) +! dt = time step (s) +! z = depth (mm) (positive downward) +! dz = thickness (mm) +! qin = inflow at top (mm h2o /s) +! qout= outflow at bottom (mm h2o /s) +! s = source/sink flux (mm h2o /s) +! k = hydraulic conductivity (mm h2o /s) +! +! d qin d qin +! qin[n+1] = qin[n] + -------- d wat(j-1) + --------- d wat(j) +! d wat(j-1) d wat(j) +! ==================|================= +! < qin +! +! d wat(j)/dt * dz = qin[n+1] - qout[n+1] + S(j) +! +! > qout +! ==================|================= +! d qout d qout +! qout[n+1] = qout[n] + --------- d wat(j) + --------- d wat(j+1) +! d wat(j) d wat(j+1) +! +! +! Solution: linearize k and psi about d wat and use tridiagonal +! system of equations to solve for d wat, +! where for layer j +! +! +! r_j = a_j [d wat_j-1] + b_j [d wat_j] + c_j [d wat_j+1] +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: grav,hfus,tfrz,denh2o,denice + USE MOD_Utils + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: patchtype ! land patch type + integer , intent(in) :: nl_soil ! number of soil layers + real(r8), intent(in) :: deltim ! land model time step (sec) + real(r8), intent(in) :: wimp ! water impermeable if porosity less than wimp + real(r8), intent(in) :: smpmin ! restriction for min of soil potential (mm) + + real(r8), intent(in) :: qinfl ! infiltration (mm H2O /s) + real(r8), intent(in) :: etr ! vegetation transpiration (mm H2O/s) (+ = to atm) + + real(r8), intent(in) :: z_soisno (1:nl_soil) ! layer depth (m) + real(r8), intent(in) :: dz_soisno(1:nl_soil) ! layer thickness (m) + real(r8), intent(in) :: zi_soisno(0:nl_soil) ! interface level below a "z" level (m) + + real(r8), intent(in) :: t_soisno (1:nl_soil) ! soil temperature (Kelvin) + real(r8), intent(in) :: vol_liq (1:nl_soil) ! liquid volumetric water content + real(r8), intent(in) :: vol_ice (1:nl_soil) ! ice volumetric water content + real(r8), intent(in) :: icefrac (1:nl_soil) + real(r8), intent(in) :: eff_porosity(1:nl_soil) ! effective porosity = porosity - vol_ice + + real(r8), intent(in) :: porsl (1:nl_soil) ! volumetric soil water at saturation (porosity) + real(r8), intent(in) :: hksati (1:nl_soil) ! hydraulic conductivity at saturation (mm H2O /s) + real(r8), intent(in) :: bsw (1:nl_soil) ! Clapp and Hornberger "b" + real(r8), intent(in) :: psi0 (1:nl_soil) ! minimum soil suction (mm) [-] + real(r8), intent(in) :: rootr (1:nl_soil) ! effective fraction of roots in each soil layer + real(r8), intent(in) :: rootflux(1:nl_soil)! root uptake from different layers, all layers add to transpiration + real(r8), intent(in) :: zwt ! the depth from ground (soil) surface to water table [m] + + real(r8), intent(out) :: dwat(1:nl_soil) ! change of soil water [m3/m3] + real(r8), intent(out) :: qcharge ! aquifer recharge rate (positive to aquifer) (mm/s) + real(r8), intent(out) :: smp(1:nl_soil) ! soil matrix potential [mm] + real(r8), intent(out) :: hk (1:nl_soil) ! hydraulic conductivity [mm h2o/s] + +!-------------------------- Local Variables ---------------------------- + + integer :: j ! do loop indices + real(r8) :: amx(1:nl_soil) ! "a" left off diagonal of tridiagonal matrix + real(r8) :: bmx(1:nl_soil) ! "b" diagonal column for tridiagonal matrix + real(r8) :: cmx(1:nl_soil) ! "c" right off diagonal tridiagonal matrix + real(r8) :: rmx(1:nl_soil) ! "r" forcing term of tridiagonal matrix + real(r8) :: zmm(1:nl_soil) ! layer depth [mm] + real(r8) :: dzmm(1:nl_soil) ! layer thickness [mm] + real(r8) :: zimm(0:nl_soil) ! layer interface depth [mm] + real(r8) :: den(1:nl_soil) ! used in calculating qin, qout + real(r8) :: alpha(1:nl_soil) ! used in calculating qin, qout + real(r8) :: qin(1:nl_soil) ! flux of water into soil layer [mm h2o/s] + real(r8) :: qout(1:nl_soil) ! flux of water out of soil layer [mm h2o/s] + real(r8) :: dqidw0(1:nl_soil) ! d(qin)/d(vol_liq(j-1)) + real(r8) :: dqidw1(1:nl_soil) ! d(qin)/d(vol_liq(j)) + real(r8) :: dqodw1(1:nl_soil) ! d(qout)/d(vol_liq(j)) + real(r8) :: dqodw2(1:nl_soil) ! d(qout)/d(vol_liq(j+1)) + real(r8) :: dsmpdw(1:nl_soil) ! d(smp)/d(vol_liq) + real(r8) :: s_node ! soil wetness + real(r8) :: s1 ! "s" at interface of layer + real(r8) :: s2 ! k*s**(2b+2) + real(r8) :: dhkdw1(1:nl_soil) ! d(hk)/d(vol_liq(j)) + real(r8) :: dhkdw2(1:nl_soil) ! d(hk)/d(vol_liq(j+1)) + real(r8) :: imped(1:nl_soil) ! + real(r8) :: errorw ! mass balance error for this time step + + integer :: jwt ! index of the soil layer right above the water table (-) + + real(r8), parameter :: e_ice=6.0 !soil ice impedance factor +!----------------------------------------------------------------------- + + !compute jwt index + ! The layer index of the first unsaturated layer, + ! i.e., the layer right above the water table + + jwt = nl_soil + ! allow jwt to equal zero when zwt is in top layer + DO j = 1, nl_soil + IF(zwt <= zi_soisno(j)) THEN + jwt = j-1 + EXIT + ENDIF + ENDDO + + ! Because the depths in this routine are in mm, use local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + dzmm(j) = dz_soisno(j)*1000. + zimm(j) = zi_soisno(j)*1000. + ENDDO + + zimm(0) = 0.0 + + ! Compute matric potential and derivative based on liquid water content only + DO j = 1, nl_soil + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + IF(t_soisno(j)>=tfrz) THEN + IF(porsl(j)<1.e-6)THEN ! bed rock + s_node = 0.001 + smp(j) = psi0(j) + dsmpdw(j) = 0. + ELSE + s_node = max(vol_liq(j)/porsl(j),0.01) + s_node = min(1.0,s_node) + smp(j) = psi0(j)*s_node**(-bsw(j)) + smp(j) = max(smpmin,smp(j)) + dsmpdw(j) = -bsw(j)*smp(j)/(s_node*porsl(j)) + ENDIF + ELSE + ! when ice is present, the matric potential is only related to temperature + ! by (Fuchs et al., 1978: Soil Sci. Soc. Amer. J. 42(3):379-385) + ! Unit 1 Joule = 1 (kg m2/s2), J/kg /(m/s2) ==> m ==> 1e3 mm + smp(j) = 1.e3 * 0.3336e6/9.80616*(t_soisno(j)-tfrz)/t_soisno(j) + smp(j) = max(smpmin, smp(j)) ! Limit soil suction + dsmpdw(j) = 0. + ENDIF + ELSE + IF(t_soisno(j)>=tfrz) THEN + IF(porsl(j)<1.e-6)THEN ! bed rock + s_node = 0.001 + smp(j) = psi0(j) + dsmpdw(j) = 0. + ELSE + s_node = max(vol_liq(j)/porsl(j),0.01) + s_node = min(1.0,s_node) + smp(j) = psi0(j)*s_node**(-bsw(j)) + smp(j) = max(smpmin,smp(j)) + dsmpdw(j) = -bsw(j)*smp(j)/(s_node*porsl(j)) + ENDIF + ELSE + ! when ice is present, the matric potential is only related to temperature + ! by (Fuchs et al., 1978: Soil Sci. Soc. Amer. J. 42(3):379-385) + ! Unit 1 Joule = 1 (kg m2/s2), J/kg /(m/s2) ==> m ==> 1e3 mm + smp(j) = 1.e3 * 0.3336e6/9.80616*(t_soisno(j)-tfrz)/t_soisno(j) + smp(j) = max(smpmin, smp(j)) ! Limit soil suction + dsmpdw(j) = 0. + ENDIF + ENDIF + ENDDO + + ! Hydraulic conductivity and soil matric potential and their derivatives + DO j = 1, nl_soil + + IF(j < nl_soil)THEN + den(j) = (zmm(j+1)-zmm(j)) + alpha(j) = (smp(j+1)-smp(j))/den(j) - 1. + ELSE + den(j) = 0. ! not used + alpha(j) = 0. ! not used + ENDIF + + IF((eff_porosity(j) < wimp) .or. (eff_porosity(min(nl_soil,j+1)) < wimp) & + .or. (vol_liq(j) <= 1.e-3))THEN + imped(j) = 0. + hk(j) = 0. + dhkdw1(j) = 0. + dhkdw2(j) = 0. + ELSE + ! The average conductivity between two heterogeneous medium layers (j and j + 1), + ! are computed using different methods + IF(j < nl_soil)THEN +! Method I: UPSTREAM MEAN + IF(alpha(j) <= 0.)THEN + hk(j) = hksati(j) * (vol_liq(j)/porsl(j))**(2.*bsw(j)+3.) + dhkdw1(j) = hksati(j) * (2.*bsw(j)+3.)*(vol_liq(j)/porsl(j))**(2.*bsw(j)+2.)/porsl(j) + dhkdw2(j) = 0. + ELSE + hk(j) = hksati(j+1) * (vol_liq(j+1)/porsl(j+1))**(2.*bsw(j+1)+3.) + dhkdw1(j) = 0. + dhkdw2(j) = hksati(j+1) * (2.*bsw(j+1)+3.)*(vol_liq(j+1)/porsl(j+1))**(2.*bsw(j+1)+2.)/porsl(j+1) + ENDIF +! Method II: + ! ! The harmonic averaging of the saturated conductivities + ! hksat_interface = (zmm(j+1)-zmm(j))/((zimm(j)-zmm(j))/hksati(j)+(zmm(j+1)-zimm(j))/hksati(j+1)) + ! s1 = (vol_liq(j)*(zimm(j)-zmm(j)) + vol_liq(j+1)*(zmm(j+1)-zimm(j))) & + ! / (porsl(j)*(zimm(j)-zmm(j)) + porsl(j+1)*(zmm(j+1)-zimm(j))) + ! s1 = min(1.,s1) + ! s2 = hksat_interface*s1**(2.*bsw(j)+2.) + ! hk(j) = s1*s2 + ! dhkdw1(j) = (2.*bsw(j)+3.)*s2*(zimm(j)-zmm(j))/(porsl(j)*(zimm(j)-zmm(j))+porsl(j+1)*(zmm(j+1)-zimm(j))) + ! dhkdw2(j) = (2.*bsw(j)+3.)*s2*(zmm(j+1)-zimm(j))/(porsl(j)*(zimm(j)-zmm(j))+porsl(j+1)*(zmm(j+1)-zimm(j))) + + ELSE + hk(j) = hksati(j) * (vol_liq(j)/porsl(j))**(2.*bsw(j)+3.) + dhkdw1(j) = hksati(j) * (2.*bsw(j)+3.)*(vol_liq(j)/porsl(j))**(2.*bsw(j)+2.)/porsl(j) + dhkdw2(j) = 0. + ENDIF + + ! replace fracice with impedance factor + imped(j)=10.**(-e_ice*(0.5*(icefrac(j)+icefrac(min(nl_soil,j+1))))) + hk(j) = imped(j) * hk(j) + dhkdw1(j) = imped(j) * dhkdw1(j) + dhkdw2(j) = imped(j) * dhkdw2(j) + ENDIF + ENDDO + + + ! Set up r, a, b, and c vectors for tridiagonal solution + + ! Node j=1 (top) + + j = 1 + qin(j) = qinfl + + qout(j) = -hk(j)*alpha(j) + dqodw1(j) = -(alpha(j)*dhkdw1(j) - hk(j)*dsmpdw(j)/den(j)) + dqodw2(j) = -(alpha(j)*dhkdw2(j) + hk(j)*dsmpdw(j+1)/den(j)) + + amx(j) = 0. + bmx(j) = dzmm(j)/deltim + dqodw1(j) + cmx(j) = dqodw2(j) + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + rmx(j) = qin(j) - qout(j) - rootflux(j) + ELSE + rmx(j) = qin(j) - qout(j) - etr*rootr(j) + ENDIF + + ! Nodes j=2 to j=nl_soil-1 + + DO j = 2, nl_soil - 1 + qin(j) = -hk(j-1)*alpha(j-1) + dqidw0(j) = -(alpha(j-1)*dhkdw1(j-1) - hk(j-1)*dsmpdw(j-1)/den(j-1)) + dqidw1(j) = -(alpha(j-1)*dhkdw2(j-1) + hk(j-1)*dsmpdw(j)/den(j-1)) + + qout(j) = -hk(j)*alpha(j) + dqodw1(j) = -(alpha(j)*dhkdw1(j) - hk(j)*dsmpdw(j)/den(j)) + dqodw2(j) = -(alpha(j)*dhkdw2(j) + hk(j)*dsmpdw(j+1)/den(j)) + + amx(j) = -dqidw0(j) + bmx(j) = dzmm(j)/deltim - dqidw1(j) + dqodw1(j) + cmx(j) = dqodw2(j) + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + rmx(j) = qin(j) - qout(j) - rootflux(j) + ELSE + rmx(j) = qin(j) - qout(j) - etr*rootr(j) + ENDIF + ENDDO + + ! Node j=nl_soil (bottom) + + j = nl_soil + qin(j) = -hk(j-1)*alpha(j-1) + dqidw0(j) = -(alpha(j-1)*dhkdw1(j-1) - hk(j-1)*dsmpdw(j-1)/den(j-1)) + dqidw1(j) = -(alpha(j-1)*dhkdw2(j-1) + hk(j-1)*dsmpdw(j)/den(j-1)) + + ! IF(j > jwt) THEN ! water table is in soil column + ! qout(j) = 0. + ! dqodw1(j) = 0. + ! dqodw2(j) = 0. + ! ELSE + qout(j) = hk(j) + dqodw1(j) = dhkdw1(j) + dqodw2(j) = 0. + ! ENDIF + + amx(j) = -dqidw0(j) + bmx(j) = dzmm(j)/deltim - dqidw1(j) + dqodw1(j) + cmx(j) = dqodw2(j) + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + rmx(j) = qin(j) - qout(j) - rootflux(j) + ELSE + rmx(j) = qin(j) - qout(j) - etr*rootr(j) + ENDIF + + ! Solve for dwat + + CALL tridia (nl_soil, amx, bmx, cmx, rmx, dwat ) + +#if (defined CoLMDEBUG) + ! The mass balance error (mm) for this time step is + errorw = -deltim*(qin(1)-qout(nl_soil)-dqodw1(nl_soil)*dwat(nl_soil)) + DO j = 1, nl_soil + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + errorw = errorw+dwat(j)*dzmm(j)+rootflux(j)*deltim + ELSE + errorw = errorw+dwat(j)*dzmm(j)+etr*rootr(j)*deltim + ENDIF + ENDDO + + IF(abs(errorw) > 1.e-3)THEN + write(6,*) 'mass balance error in time step =',errorw + ENDIF +#endif + + ! Recharge rate qcharge to groundwater (positive to aquifer) + qcharge = qout(nl_soil) + dqodw1(nl_soil)*dwat(nl_soil) + + + END SUBROUTINE soilwater + + + SUBROUTINE groundwater (nl_soil,deltim,pondmx,& + eff_porosity,icefrac,& + dz_soisno,zi_soisno,wice_soisno,wliq_soisno,& + porsl,psi0,bsw,zwt,wa,& + qcharge,rsubst) + +! ------------------------------------------------------------------------- + + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: nl_soil ! + real(r8), intent(in) :: deltim ! land model time step (sec) + real(r8), intent(in) :: pondmx ! + + real(r8), intent(in) :: eff_porosity(1:nl_soil) ! effective porosity = porosity - vol_ice + real(r8), intent(in) :: icefrac(1:nl_soil) ! ice fraction (-) + + real(r8), intent(in) :: dz_soisno (1:nl_soil) ! layer depth (m) + real(r8), intent(in) :: zi_soisno (0:nl_soil) ! interface level below a "z" level (m) + real(r8), intent(inout) :: wice_soisno(1:nl_soil) ! ice lens (kg/m2) + real(r8), intent(inout) :: wliq_soisno(1:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(in) :: porsl(1:nl_soil) ! volumetric soil water at saturation (porosity) + real(r8), intent(in) :: psi0(1:nl_soil) ! minimum soil suction (mm) [-] + real(r8), intent(in) :: bsw(1:nl_soil) ! Clapp and Hornberger "b" + + real(r8), intent(inout) :: zwt ! the depth from ground (soil) surface to water table [m] + real(r8), intent(inout) :: wa ! water in the unconfined aquifer (mm) + real(r8), intent(in) :: qcharge ! aquifer recharge rate (positive to aquifer) (mm/s) + real(r8), intent(inout) :: rsubst ! subsurface runoff (positive = out of soil column) (mm H2O /s) + +!-------------------------- Local Variables ---------------------------- + integer :: j ! indices + integer :: jwt ! index of the soil layer right above the water table (-) + real(r8) :: xs ! water needed to bring soil moisture to watmin (mm) + real(r8) :: dzmm(1:nl_soil) ! layer thickness (mm) + real(r8) :: xsi ! excess soil water above saturation at layer i (mm) + real(r8) :: xsia ! available pore space at layer i (mm) + real(r8) :: xs1 ! excess soil water above saturation at layer 1 (mm) + real(r8) :: ws ! summation of pore space of layers below water table (mm) + real(r8) :: s_node ! soil wetness (-) + real(r8) :: available_wliq_soisno ! available soil liquid water in a layer + real(r8) :: qcharge_tot ! + real(r8) :: qcharge_layer ! + real(r8) :: drainage ! + real(r8) :: drainage_tot ! + real(r8) :: drainage_layer ! + real(r8) :: s_y ! + real(r8) :: rous ! specific yield [-] + + real(r8) :: wt + real(r8) :: wtsub + real(r8) :: dzsum + real(r8) :: icefracsum + real(r8) :: fracice_rsub + real(r8) :: imped + + + real(r8), parameter :: watmin = 0.01 ! Limit irreducible wrapping liquid water + ! a tunable constant + real(r8), parameter :: rsbmx = 5.0 ! baseflow coefficient [mm/s] + real(r8), parameter :: timean = 10.5 ! global mean topographic index + +! ------------------------------------------------------------------------- + +! ! Convert layer thicknesses from m to mm + + DO j = 1,nl_soil + dzmm(j) = dz_soisno(j)*1000. + ENDDO + +! ! The layer index of the first unsaturated layer, +! ! i.e., the layer right above the water table + + jwt = nl_soil + ! allow jwt to equal zero when zwt is in top layer + DO j = 1, nl_soil + IF(zwt <= zi_soisno(j)) THEN + jwt = j-1 + EXIT + ENDIF + ENDDO + +!============================== QCHARGE ========================================= +! Water table changes due to qcharge +! use analytical expression for aquifer specific yield + rous = porsl(nl_soil)*(1.-(1.-1.e3*zwt/psi0(nl_soil))**(-1./bsw(nl_soil))) + rous = max(rous,0.02) + + wa = wa + qcharge*deltim +! +!--------------------------------------- + ! water table is below the soil column + IF(jwt == nl_soil) THEN + zwt = max(0.,zwt - (qcharge*deltim)/1000./rous) + ELSE + ! water table within soil layers 1-9 + ! try to raise water table to account for qcharge + + qcharge_tot = qcharge * deltim + + IF(qcharge_tot > 0.) THEN ! rising water table + DO j = jwt+1, 1,-1 + ! use analytical expression for specific yield + + s_y = porsl(j) * (1.-(1.-1.e3*zwt/psi0(j))**(-1./bsw(j))) + s_y=max(s_y,0.02) + + qcharge_layer = min(qcharge_tot,(s_y*(zwt-zi_soisno(j-1))*1.e3)) + qcharge_layer = max(qcharge_layer,0.) + + zwt = max(0.,zwt - qcharge_layer/s_y/1000.) + + qcharge_tot = qcharge_tot - qcharge_layer + IF (qcharge_tot <= 0.) EXIT + ENDDO + ELSE ! deepening water table (negative qcharge) + DO j = jwt+1, nl_soil + ! use analytical expression for specific yield + s_y = porsl(j) * (1.-(1.-1.e3*zwt/psi0(j))**(-1./bsw(j))) + s_y=max(s_y,0.02) + qcharge_layer = max(qcharge_tot,-(s_y*(zi_soisno(j) - zwt)*1.e3)) + qcharge_layer = min(qcharge_layer,0.) + qcharge_tot = qcharge_tot - qcharge_layer + + IF (qcharge_tot >= 0.) THEN + zwt = max(0.,zwt - qcharge_layer/s_y/1000.) + EXIT + ELSE + zwt = zi_soisno(j) + ENDIF + ENDDO + IF (qcharge_tot > 0.) zwt = max(0.,zwt - qcharge_tot/1000./rous) + ENDIF + ENDIF + +!-- Topographic runoff ---------------------------------------------------------- + IF (DEF_Runoff_SCHEME == 0) THEN + CALL SubsurfaceRunoff_TOPMOD (nl_soil, icefrac, dz_soisno, zi_soisno, zwt, rsubst) + ENDIF + + drainage = rsubst + + ! dzsum = 0. + ! icefracsum = 0. + ! DO j = max(jwt,1), nl_soil + ! dzsum = dzsum + dzmm(j) + ! icefracsum = icefracsum + icefrac(j) * dzmm(j) + ! ENDDO + ! ! add ice impedance factor to baseflow + ! fracice_rsub = max(0.,exp(-3.*(1.-(icefracsum/dzsum)))-exp(-3.))/(1.0-exp(-3.)) + ! imped = max(0.,1.-fracice_rsub) + ! drainage = imped * 5.5e-3 * exp(-2.5*zwt) ! drainage (positive = out of soil column) + +!-- Water table is below the soil column ---------------------------------------- + IF(jwt == nl_soil) THEN + wa = wa - drainage * deltim + zwt = max(0.,zwt + (drainage * deltim)/1000./rous) + wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + max(0.,(wa-5000.)) + wa = min(wa, 5000.) + ELSE +!-- Water table within soil layers 1-9 ------------------------------------------ +!============================== RSUB_TOP ========================================= + !-- Now remove water via drainage + drainage_tot = - drainage * deltim + DO j = jwt+1, nl_soil + ! use analytical expression for specific yield + s_y = porsl(j) * ( 1. - (1.-1.e3*zwt/psi0(j))**(-1./bsw(j))) + s_y = max(s_y,0.02) + + drainage_layer = max(drainage_tot, -(s_y*(zi_soisno(j)-zwt)*1.e3)) + drainage_layer = min(drainage_layer,0.) + wliq_soisno(j) = wliq_soisno(j) + drainage_layer + + drainage_tot = drainage_tot - drainage_layer + + IF(drainage_tot >= 0.)THEN + zwt = max(0.,zwt - drainage_layer/s_y/1000.) + EXIT + ELSE + zwt = zi_soisno(j) + ENDIF + ENDDO + +!-- Remove residual drainage ------------------------------------------------ + zwt = max(0.,zwt - drainage_tot/1000./rous) + wa = wa + drainage_tot + +!-- Recompute jwt --------------------------------------------------------------- + ! allow jwt to equal zero when zwt is in top layer + jwt = nl_soil + DO j = 1, nl_soil + IF(zwt <= zi_soisno(j)) THEN + jwt = j-1 + EXIT + ENDIF + ENDDO + + ENDIF ! end of jwt IF construct + + zwt = max(0.0,zwt) + zwt = min(80.,zwt) + + rsubst = drainage + + + ! Correction [1] + ! NON-physically based correction on wliq_soisno + ! excessive water above saturation added to the above unsaturated layer like a bucket + ! IF column over saturated, excess water goes to runoff + + DO j = nl_soil,2,-1 + xsi = max(wliq_soisno(j)-eff_porosity(j)*dzmm(j),0.) + wliq_soisno(j) = min(eff_porosity(j)*dzmm(j), wliq_soisno(j)) + wliq_soisno(j-1) = wliq_soisno(j-1) + xsi + ENDDO + + ! 12/2022, note by yuan: a potential bug below which needs check, + ! if wice_soisno(1) > pondmx + porsl*dzmm, so xs1>0, in that case, + ! wliq_soisno(1) will be nagtive, and xs1 is positive. + xs1 = wliq_soisno(1) - (pondmx+porsl(1)*dzmm(1)-wice_soisno(1)) + IF(xs1 > 0.)THEN + wliq_soisno(1) = pondmx+porsl(1)*dzmm(1)-wice_soisno(1) + ELSE + xs1 = 0. + ENDIF + + rsubst = rsubst + xs1 / deltim + + + ! Correction [2] + ! NON-physically based correction on wliq_soisno + ! Limit wliq_soisno to be greater than or equal to watmin. + ! Get water needed to bring wliq_soisno equal watmin from lower layer. + ! If insufficient water in soil layers, get from aquifer water + + xs = 0. + DO j = 1, nl_soil + IF (wliq_soisno(j) < 0.) THEN + xs = xs + wliq_soisno(j) + wliq_soisno(j) = 0. + ENDIF + ENDDO + + ! Sub-surface runoff and drainage + rsubst = rsubst + xs/deltim + IF (rsubst < 0.) THEN + wa = wa + rsubst*deltim + rsubst = 0. + ENDIF + +! DO j = 1, nl_soil-1 +! IF (wice_soisno(j)*wice_soisno(j+1) < 1.e-6)THEN +! IF (wliq_soisno(j) < watmin) THEN +! xs = watmin - wliq_soisno(j) +! ! deepen water table IF water is passed from below zwt layer +! IF(j == jwt) THEN +! zwt = max(0.,zwt + xs/eff_porosity(j)/1000.) +! ENDIF +! ELSE +! xs = 0. +! ENDIF +! wliq_soisno(j ) = wliq_soisno(j ) + xs +! wliq_soisno(j+1) = wliq_soisno(j+1) - xs +! ENDIF +! ENDDO + +! ! Get water for bottom layer from layers above if possible +! IF(wliq_soisno(nl_soil) < watmin)THEN +! xs = watmin-wliq_soisno(nl_soil) +! DO j = nl_soil-1, 1, -1 +! available_wliq_soisno = max(wliq_soisno(j)-watmin-xs,0.) +! IF(available_wliq_soisno >= xs)THEN +! wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + xs +! wliq_soisno(j ) = wliq_soisno(j ) - xs +! xs = 0. +! EXIT +! ELSE +! wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + available_wliq_soisno +! wliq_soisno(j ) = wliq_soisno(j ) - available_wliq_soisno +! xs = xs - available_wliq_soisno +! ENDIF +! ENDDO +! ELSE +! xs = 0. +! ENDIF + +! ! Needed in case there is no water to be found +! wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + xs + +! ! Sub-surface runoff and drainage +! rsubst = rsubst - xs/deltim + + END SUBROUTINE groundwater + + +END MODULE MOD_SoilSnowHydrology +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 new file mode 100644 index 0000000000..2807042e88 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 @@ -0,0 +1,319 @@ +#include + +MODULE MOD_SoilSurfaceResistance +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil surface resistance with multiple parameterization +! schemes +! +! Created by Zhuo Liu and Hua Yuan, 06/2023 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- +! !USE + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: SoilSurfaceResistance + + ! soil-gas diffusivity schemes: + ! 1: BBC (Buckingham-Burdine-Campbell Model), Moldrup et al., 1999. + ! 2: P_WLR (Penman Water Linear Reduction Model), Moldrup et al., 2000 + ! 3: MI_WLR (Millington Water Linear Reduction Model), Moldrup et al., 2000 + ! 4: MA_WLR (Marshal Water Linear Reduction Model), Moldrup et al., 2000 + ! 5: M_Q, Millington and Quirk, 1961 + ! 6: 3POE (Three-Porosity-Encased), Moldrup et al., 2005 +#ifdef Campbell_SOIL_MODEL + integer, parameter :: soil_gas_diffusivity_scheme = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: soil_gas_diffusivity_scheme = 6 +#endif + + +CONTAINS +!----------------------------------------------------------------------- + + SUBROUTINE SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + +!======================================================================= +! !DESCRIPTION: +! Main SUBROUTINE to CALL soil resistance model +! - Options for soil surface resistance schemes +! 1: SL14, Swenson and Lawrence (2014) +! 2: SZ09, Sakaguchi and Zeng (2009) +! 3: TR13, Tang and Riley (2013) +! 4: LP92, Lee and Pielke (1992) +! 5: S92, Sellers et al (1992) +! +! NOTE: Support for both Campbell and VG soil parameters. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o + USE MOD_Namelist, only: DEF_RSS_SCHEME + USE MOD_Hydro_SoilFunction + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + forc_rhoair, &! density air [kg/m**3] + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + porsl (1:nl_soil), &! soil porosity [-] + psi0 (1:nl_soil), &! saturated soil suction [mm] (NEGATIVE) +#ifdef Campbell_SOIL_MODEL + bsw (1:nl_soil), &! clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil), &! residual moisture content [-] + ! a parameter corresponding approximately to the inverse of the air-entry value + alpha_vgm (1:nl_soil), & + n_vgm (1:nl_soil), &! pore-connectivity parameter [dimensionless] + L_vgm (1:nl_soil), &! a shape parameter [dimensionless] + ! saturation at the air entry value in the classical vanGenuchten model [-] + sc_vgm (1:nl_soil), & + ! a scaling factor by using air entry value in the Mualem model [-] + fc_vgm (1:nl_soil), & +#endif + dz_soisno (1:nl_soil), &! layer thickness [m] + t_soisno (1:nl_soil), &! soil/snow skin temperature [K] + wliq_soisno (1:nl_soil), &! liquid water [kg/m2] + wice_soisno (1:nl_soil), &! ice lens [kg/m2] + fsno, &! fractional snow cover [-] + qg ! ground specific humidity [kg/kg] + + real(r8), intent(out) :: & + rss ! soil surface resistance [s/m] + +!-------------------------- Local Variables ---------------------------- + + REAL(r8) :: & + wx, &! partial volume of ice and water of surface layer + vol_liq, &! water content by volume [m3/m3] + s_node, &! vol_liq/porosity + smp_node, &! matrix potential [m] + eff_porosity, &! effective porosity = porosity - vol_ice + aird, &! “air-dry” soil moisture value + d0, &! water vapor diffusivity in open air [m2/s] + eps, &! air filled pore space + dg, &! gaseous diffusivity [m2/s] + dsl, &! soil dry surface layer thickness [m] + dw, &! aqueous diffusivity [m2/s] + hk, &! hydraulic conductivity [m h2o/s] + m_vgm, &! pore-connectivity related parameter [dimensionless] + S, &! Van Genuchten relative saturation [-] + wfc, &! field capacity of the first layer soil + rg_1, &! inverse of vapor diffusion resistance [m/s] + rw_1, &! inverse of volatilization resistance [m/s] + rss_1, &! inverse of soil surface resistance [m/s] + tao, &! tortuosity of the vapor flow paths through the soil matrix + eps100, &! air-filled porosity at −1000 mm of water matric potential + fac, &! temporal variable for calculating wx/porsl + fac_fc, &! temporal variable for calculating wx/wfc + B ! bunsen solubility coefficient + +!----------------------------------------------------------------------- + + ! calculate the top soil volumetric water content (m3/m3), soil matrix potential + ! and soil hydraulic conductivity + vol_liq = max(wliq_soisno(1),1.0e-6_r8)/(denh2o*dz_soisno(1)) + s_node = min(1., vol_liq/porsl(1)) + + ! calculate effective soil porosity + eff_porosity = max(0.01_r8,porsl(1)-min(porsl(1), wice_soisno(1)/(dz_soisno(1)*denice))) + + +#ifdef Campbell_SOIL_MODEL + smp_node = (psi0(1)/1000.)*s_node**(-bsw(1)) + hk = (hksati(1)/1000.)*(vol_liq/porsl(1))**(2.*bsw(1)+3.) + + ! calculate air free pore space + aird = porsl(1)*(psi0(1)/-1.e7_r8)**(1./bsw(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + smp_node = soil_psi_from_vliq (s_node*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + hk = soil_hk_from_psi (smp_node, psi0(1), hksati(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + + smp_node = smp_node/1000. + hk = hk/1000. + + ! calculate air free pore space + aird = soil_vliq_from_psi (-1.e7_r8, porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + + ! D0 : 2.12e-5 unit: m2 s-1 + ! ref1: CLM5 Documentation formula (5.81) + ! ref2: Sakaguchi and Zeng, 2009 + ! ref3: Tang and Riley, 2013. Figure 2, 3, 4, and 5. + d0 = 2.12e-5*(t_soisno(1)/273.15)**1.75 + eps = porsl(1) - aird + + + SELECTCASE (soil_gas_diffusivity_scheme) + + ! 1: BBC + CASE (1) +#ifdef Campbell_SOIL_MODEL + tao = eps*eps*(eps/porsl(1))**(3._r8/max(3._r8,bsw(1))) +#endif + + ! 2: P_WLR + CASE (2) + tao = 0.66*eps*(eps/porsl(1)) + + ! 3: MI_WLR + CASE (3) + tao = eps**(4._r8/3._r8)*(eps/porsl(1)) + + ! 4: MA_WLR + CASE (4) + tao = eps**(3./2.)*(eps/porsl(1)) + + ! 5: M_Q + CASE (5) + tao = eps**(4._r8/3._r8)*(eps/porsl(1))**(2.0_r8) + + ! 6: 3POE + CASE (6) +#ifdef Campbell_SOIL_MODEL + eps100 = porsl(1) - porsl(1)*(psi0(1)/-1000.)**(1./bsw(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + eps100 = porsl(1) - soil_vliq_from_psi (-1000., porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + tao = porsl(1)*porsl(1)*(eps/porsl(1))**(2.+log(eps100**0.25_r8)/log(eps100/porsl(1))) + + ENDSELECT + + + ! calculate gas and water diffusivity (dg and dw) + dg = d0*tao + + !NOTE: dw is only for TR13 scheme +#ifdef Campbell_SOIL_MODEL + ! TR13, Eq.(A5): + dw = -hk*bsw(1)*smp_node/vol_liq +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! TR13, Eqs. (A2), (A7), (A8) and (A10): + ! dw = -hk*(m-1)/(k*m*(theta_s-theta_r))*S**(-1/m)*(1-S**(1/m))**(-m) + ! where k=alpha_vgm, S=(1+(-k*smp_node)**(n))**(-m), m=m_vgm=1-1/n_vgm + m_vgm = 1. - 1./n_vgm(1) + S = (1. + (- alpha_vgm(1)*smp_node)**(n_vgm(1)))**(-m_vgm) + dw = -hk*(m_vgm-1.)/(alpha_vgm(1)*m_vgm*(porsl(1)-theta_r(1))) & + * S**(-1./m_vgm)*(1.-S**(1./m_vgm))**(-m_vgm) +#endif + + SELECTCASE (DEF_RSS_SCHEME) + +!----------------------------------------------------------------------- + ! calculate rss by SL14 + CASE (1) + dsl = dz_soisno(1)*max(1.e-6_r8,(0.8*eff_porosity - vol_liq)) & + /max(1.e-6_r8,(0.8*porsl(1)- aird)) + + dsl = max(dsl,0._r8) + dsl = min(dsl,0.2_r8) + + rss = dsl/dg + +!----------------------------------------------------------------------- + ! calculate rss by SZ09 + CASE (2) + dsl = dz_soisno(1)*(exp((1._r8 - vol_liq/porsl(1))**5) - 1._r8)/ (exp(1._r8) - 1._r8) + dsl = min(dsl,0.2_r8) + dsl = max(dsl,0._r8) + + rss = dsl/dg + +!----------------------------------------------------------------------- + ! calculate rss by TR13 + CASE (3) + ! TR13, Eq. (11) and Eq. (12): + B = denh2o/(qg*forc_rhoair) + ! TR13, Eq. (13): + rg_1 = 2.0_r8*dg*eps/dz_soisno(1) + rw_1 = 2.0_r8*dw*B*vol_liq/dz_soisno(1) + rss_1 = rg_1 + rw_1 + rss = 1.0/rss_1 + +!----------------------------------------------------------------------- + ! LP92 beta scheme + CASE (4) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) +#ifdef Campbell_SOIL_MODEL + wfc = porsl(1)*(0.1/(86400.*hksati(1)))**(1./(2.*bsw(1)+3.)) + !NOTE: CoLM wfc = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch)) + ! * soil_theta_s_l(ipatch) + !wfc = porsl(1)*(-3399._r8/psi0(1))**(-1./bsw(1)) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + wfc = theta_r(1)+(porsl(1)-theta_r(1))*(1+(alpha_vgm(1)*339.9)**n_vgm(1))**(1.0/n_vgm(1)-1) +#endif + + ! Lee and Pielke 1992 beta + IF (wx < wfc ) THEN !when water content of ths top layer is less than that at F.C. + fac_fc = min(1._r8, wx/wfc) + fac_fc = max(fac_fc,0.001_r8) + rss = 0.25_r8*(1._r8 - cos(fac_fc*3.1415926))**2._r8 + ELSE !when water content of ths top layer is more than that at F.C. + rss = 1._r8 + ENDIF + +!----------------------------------------------------------------------- + ! Sellers, 1992 + CASE (5) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) + !rss = exp(8.206-4.255*fac) !original Sellers (1992) + rss = exp(8.206-6.0*fac) !adjusted Sellers (1992) to decrease rss + !for wet soil according to Noah-MP v5 + ENDSELECT + +!----------------------------------------------------------------------- + ! account for snow fractional cover for rss + IF (DEF_RSS_SCHEME .ne. 4) THEN + ! with 1/rss = fsno/rss_snow + (1-fsno)/rss_soil, + ! assuming rss_snow = 1, so rss is calibrated as: + IF (1.-fsno+fsno*rss > 0.) THEN + rss = rss / (1.-fsno+fsno*rss) + ELSE + rss = 0. + ENDIF + rss = min(1.e6_r8,rss) + ENDIF + + ! account for snow fractional cover for LP92 beta scheme + !NOTE: rss here is for soil beta value + IF (DEF_RSS_SCHEME .eq. 4) THEN + ! modify soil beta by snow cover, assuming soil beta for snow surface is 1. + rss = (1.-fsno)*rss + fsno + ENDIF + + END Subroutine SoilSurfaceResistance + +END MODULE MOD_SoilSurfaceResistance +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 new file mode 100644 index 0000000000..980ae7db1e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 @@ -0,0 +1,524 @@ +#include + +MODULE MOD_SoilThermalParameters + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: hCapacity + PUBLIC :: hConductivity + PUBLIC :: soil_hcap_cond + + +! PRIVATE MEMBER FUNCTIONS: + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE hCapacity (patchtype,lb,nl_soil,csol,porsl,wice_soisno,wliq_soisno,scv,dz_soisno,cv) + + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of heat capacities of snow / soil layers the volumetric +! heat capacity is calculated as a linear combination in terms of the +! volumetric fraction of the constituent phases. Only used in urban +! model. TODO: merge with SUBROUTINE soil_hcap_cond +! +! !REVISIONS: +! 07/19/2014, Yongjiu Dai: treat the wetland as soil column instead of +! water body. +! 08/16/2014, Nan Wei: recalculate the heat capacity of soil layers +! underneath the lake +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: cpice,cpliq + IMPLICIT NONE + + integer, intent(in) :: lb ! lower bound of array + integer, intent(in) :: nl_soil ! upper bound of array + integer, intent(in) :: patchtype ! land patch type (0=soil, 1=urban, 2=wetland, + real(r8), intent(in) :: csol(1:nl_soil) ! heat capacity of soil soilds [J/(m3 K)] + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity + real(r8), intent(in) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + real(r8), intent(in) :: dz_soisno(lb:nl_soil) ! layer thickness [m] + real(r8), intent(in) :: scv ! snow water equivalent [mm] + real(r8), intent(out) :: cv(lb:nl_soil) ! heat capacity [J/(m2 K)] + +!----------------------------------------------------------------------- +! Soil heat capacity, which from de Vires (1963) + + IF(patchtype<=2 .or. patchtype==4)THEN ! soil ground and wetland and lake + cv(1:) = csol(1:)*(1.-porsl(1:))*dz_soisno(1:) & + + wice_soisno(1:)*cpice + wliq_soisno(1:)*cpliq + ELSE ! glacier/ice sheet + cv(1:) = wice_soisno(1:)*cpice + wliq_soisno(1:)*cpliq + ENDIF + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + +! Snow heat capacity + IF(lb<=0)THEN + cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) + ENDIF + + END SUBROUTINE hCapacity + + + SUBROUTINE hConductivity (patchtype,lb,nl_soil,& + dkdry,dksatu,porsl,dz_soisno,z_soisno,zi_soisno,& + t_soisno,wice_soisno,wliq_soisno,tk,tktopsoil) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of thermal conductivities of snow / soil layers The +! thermal conductivity of soil is computed from the algorithm of +! Johansen (as reported by Farouki 1981), and of snow is from the +! formulation used in SNTHERM (Jordan 1991). +! +! The thermal conductivities at the interfaces between two neighbor +! layers (j, j+1) are derived from an assumption that the flux across +! the interface is equal to that from the node j to the interface and +! the flux from the interface to the node j+1. +! +! Only used in urban model. TODO: merge with subroutine soil_hcap_cond +! +! !REVISIONS: +! 07/19/2014, Yongjiu Dai: treat the wetland as soil column instead of +! water body. +! 08/16/2014, Nan Wei: recalculate the heat conductivity of soil layers +! underneath the lake +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: denh2o,denice,tfrz,tkwat,tkice,tkair + IMPLICIT NONE + + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_soil !upper bound of array + integer, intent(in) :: patchtype !land patch type (0=soil, 1=urban, 2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: dkdry(1:nl_soil) !thermal conductivity for dry soil [W/m-K] + real(r8), intent(in) :: dksatu(1:nl_soil) !Thermal conductivity of saturated soil [W/m-K] + real(r8), intent(in) :: porsl(1:nl_soil) !fractional volume between soil grains=1.-dmvol + real(r8), intent(in) :: dz_soisno(lb:nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_soisno(lb:nl_soil) !node depth [m] + real(r8), intent(in) :: zi_soisno(lb-1:nl_soil) !interface depth [m] + real(r8), intent(in) :: t_soisno(lb:nl_soil) !Nodal temperature [K] + real(r8), intent(in) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + + real(r8), intent(out) :: tk(lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8), optional, intent(out) :: tktopsoil + +! local + real(r8) rhosnow ! partial density of water (ice + liquid) + real(r8) dksat ! thermal conductivity for saturated soil (j/(k s m)) + real(r8) dke ! kersten number + real(r8) fl ! fraction of liquid or unfrozen water to total water + real(r8) satw ! relative total water content of soil. + real(r8) thk(lb:nl_soil) ! thermal conductivity of layer + real(r8) xicevol + + integer i + +!----------------------------------------------------------------------- +! Thermal conductivity of soil from Farouki (1981), + DO i = 1, nl_soil + + IF(patchtype<=2 .or. patchtype==4)THEN !soil ground, wetland and lake + thk(i) = dkdry(i) !rock or dry soil + + IF(porsl(i)>1.e-05 .and. (wice_soisno(i)+wliq_soisno(i)) > 0.0)THEN + satw = (wliq_soisno(i)/denh2o+wice_soisno(i)/denice)/(dz_soisno(i)*porsl(i)) + satw = min(1., satw) + IF(satw>.1e-6)THEN + IF (patchtype==4) satw = 1. + fl = wliq_soisno(i)/(wice_soisno(i)+wliq_soisno(i)) + IF(t_soisno(i) >= tfrz) THEN ! Unfrozen soil + dke = log10(satw) + 1.0 + dke = max(dke, 0.) + dksat = dksatu(i) + ELSE ! Frozen soil + dke = satw + dksat = dksatu(i)*(2.29/0.57)**((1.-fl)*porsl(i)) + ENDIF + thk(i) = dke*dksat + (1.-dke)*dkdry(i) + IF (patchtype==4) THEN + satw = (wliq_soisno(i)/denh2o+wice_soisno(i)/denice)/(dz_soisno(i)*porsl(i)) + IF(satw > 1.0)THEN + xicevol = (satw-1.0)*porsl(i) + thk(i) = (thk(i) + xicevol*tkice)/(1.0 + xicevol)/(1.0 + xicevol) + ENDIF + ENDIF + ENDIF + ENDIF + IF(present(tktopsoil))tktopsoil = thk(1) + ELSEIF (patchtype == 3)THEN ! glacier + thk(i) = tkwat + IF(t_soisno(i)=lb) THEN + tk(i) = thk(i) + ENDIF + ENDIF +! - END - + ENDDO + tk(nl_soil) = 0. + + END SUBROUTINE hConductivity + + SUBROUTINE soil_hcap_cond(vf_gravels_s,vf_om_s,vf_sand_s,vf_pores_s,& + wf_gravels_s,wf_sand_s,k_solids,& + csol,kdry,ksat_u,ksat_f,& + BA_alpha,BA_beta,& + temperature,vf_water,vf_ice,hcap,thk) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate bulk soil heat capacity and soil thermal conductivity with +! 8 optional schemes The default soil thermal conductivity scheme is +! the fourth one (Balland V. and P. A. Arp, 2005) +! +! !REFERENCES: +! Dai et al.,2019: Evaluation of Soil Thermal Conductivity Schemes for +! Use in Land Surface Modeling J. of Advances in Modeling Earth +! Systems, DOI: 10.1029/2019MS001723 +! +! !Original author: Yongjiu Dai, 02/2018/ +! +! !REVISIONS: +! 06/2018, Nan Wei: add to CoLM/main +! 09/2022, Nan Wei: add soil thermal conductivity of Hailong He (Yan & +! He et al., 2019) +! ----------------------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical,only:tfrz + USE MOD_Namelist + + IMPLICIT NONE + real(r8), intent(in) :: vf_gravels_s ! volumetric fraction of gravels within soil solids + real(r8), intent(in) :: vf_om_s ! volumetric fraction of organic matter within soil solids + real(r8), intent(in) :: vf_sand_s ! volumetric fraction of sand within soil soilds + real(r8), intent(in) :: vf_pores_s ! volumetric pore space of the soil + + real(r8), intent(in) :: wf_gravels_s ! gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand_s ! gravimetric fraction of sand within soil soilds + real(r8), intent(in) :: k_solids ! thermal conductivity of soil solids + + real(r8), intent(in) :: temperature ! + real(r8), intent(in) :: vf_water ! + real(r8), intent(in) :: vf_ice ! + + real(r8), intent(in) :: csol ! heat capacity of dry soil [J/(m3 K)] + real(r8), intent(in) :: kdry ! thermal conductivity for dry soil [W/m/K] + real(r8), intent(in) :: ksat_u ! thermal conductivity of unfrozen saturated soil [W/m/K] + real(r8), intent(in) :: ksat_f ! thermal conductivity of frozen saturated soil [W/m/K] + real(r8), intent(in) :: BA_alpha ! alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta ! beta in Balland and Arp(2005) thermal conductivity scheme + + real(r8), intent(out) :: hcap ! J/(m3 K) + real(r8), intent(out) :: thk ! W/(m K) + + real(r8) c_water, c_ice + real(r8) a, kappa, alpha, beta + real(r8) aa,aaa,nwm,nw_nwm,x,ga,gc + integer i + + real(r8) sr ! wetness or degree of saturation = (vf_water+vf_ice)/vf_pores_s + real(r8) ke ! Kersten number or normalized thermal conductivity + real(r8) k_air,k_water,k_ice + +! ========================================================================================= +! The heat capacity and thermal conductivity [J(m3 K)] +! ========================================================================================= +!* c_water = 4.18e6 ! J/(m3 K) +!* c_ice = 1.88e6 ! J/(m3 K) + c_water = 4.188e6 ! J/(m3 K) = 4188[J/(kg K)]*1000(kg/m3) + c_ice = 1.94153e6 ! J/(m3 K) = 2117.27[J/(kg K)]*917(kg/m3) + + hcap = csol + vf_water*c_water + vf_ice*c_ice + +! ----------------------------------------------------------------------------------------- +! Setting +! ----------------------------------------------------------------------------------------- + k_air = 0.024 ! (W/m/K) + k_water = 0.57 ! (W/m/K) + k_ice = 2.29 ! (W/m/K) + + a = vf_gravels_s + vf_sand_s + + sr = (vf_water+vf_ice)/vf_pores_s +! sr = max(1.0e-6, sr) + sr = min(1.0, sr) + + IF(sr >= 1.0e-10) THEN + select CASE (DEF_THERMAL_CONDUCTIVITY_SCHEME) + CASE (1) +! ----------------------------------------------------------------------------------------- +! [1] Oleson et al., 2013: Technical Description of version 4.5 of the Community Land Model +! (CLM). NCAR/TN-503+STR (Section 6.3: Soil and Snow Thermal Properties) +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soil + ke = log10(sr) + 1.0 + ELSE ! Fozen or partially frozen soils + ke = sr + ENDIF + + CASE (2) +! ----------------------------------------------------------------------------------------- +! [2] Johansen O (1975): Thermal conductivity of soils. PhD Thesis. Trondheim, Norway: +! University of Trondheim. US army Crops of Engineerings, +! CRREL English Translation 637. +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soils + IF(a > 0.4)THEN ! coarse-grained + ke = 0.7*log10(max(sr,0.05)) + 1.0 + ELSE ! Fine-grained + ke = log10(max(sr,0.1)) + 1.0 + ENDIF + ELSE ! Frozen or partially frozen soils + ke = sr + ENDIF + + CASE (3) +! ----------------------------------------------------------------------------------------- +! [3] Cote, J., and J.-M. Konrad (2005), A generalized thermal conductivity model for soils +! and construction materials. Canadian Geotechnical Journal, 42(2): 443-458. +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soils +! kappa = Unfrozen +! /gravels and coarse sand /4.60/ +! /medium and fine sands /3.55/ +! /silty and clayey soils /1.90/ +! /organic fibrous soils (peat)/0.60/ + IF(a > 0.40)THEN + kappa = 4.60 + ELSEIF(a > 0.25)THEN + kappa = 3.55 + ELSEIF(a > 0.01)THEN + kappa = 1.90 + ELSE + kappa = 0.60 + ENDIF + + ELSE ! Frozen or partially frozen soils +! kappa = Frozen +! /gravels and coarse sand /1.70/ +! /medium and fine sands /0.95/ +! /silty and clayey soils /0.85/ +! /organic fibrous soils (peat)/0.25/ + IF(a > 0.40)THEN + kappa = 1.70 + ELSEIF(a > 0.25)THEN + kappa = 0.95 + ELSEIF(a > 0.01)THEN + kappa = 0.85 + ELSE + kappa = 0.25 + ENDIF + ENDIF + ke = kappa*sr/(1.0+(kappa-1.0)*sr) + + CASE (4) +! ----------------------------------------------------------------------------------------- +! [4] Balland V. and P. A. Arp, 2005: Modeling soil thermal conductivities over a wide +! range of conditions. J. Environ. Eng. Sci. 4: 549-558. +! be careful in specifying all k affecting fractions as VOLUME FRACTION, +! whether these fractions are part of the bulk volume, the pore space, or the solid space. +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soil +! alpha = 0.24 ! adjustable parameter +! beta = 18.1 ! adjustable parameter + + ke = sr**(0.5*(1.0+vf_om_s-BA_alpha*vf_sand_s-vf_gravels_s)) & + * ((1.0/(1.0+exp(-BA_beta*sr)))**3-((1.0-sr)/2.0)**3)**(1.0-vf_om_s) + ELSE ! Frozen or partially frozen soils + ke = sr**(1.0+vf_om_s) + ENDIF + + CASE (5) +! ----------------------------------------------------------------------------------------- +! [5] Lu et al., 2007: An improved model for predicting soil thermal conductivity from +! water content at room temperature. Soil Sci. Soc. Am. J. 71:8-14 +! ----------------------------------------------------------------------------------------- + IF(a > 0.4)THEN ! Coarse-textured soils = soils with sand fractions >40 (%) + alpha = 0.728 + beta = 1.165 + ELSE ! Fine-textured soils = soils with sand fractions <40 (%) + alpha = 0.37 + beta = 1.29 + ENDIF + + IF(temperature > tfrz)THEN ! Unfrozen soils + ke = exp(alpha*(1.0-sr**(alpha-beta))) + ELSE ! Frozen or partially frozen soils + ke = sr + ENDIF + END select + ELSE + ke = 0.0 + ENDIF + + IF (DEF_THERMAL_CONDUCTIVITY_SCHEME >= 1 .and. DEF_THERMAL_CONDUCTIVITY_SCHEME <=5) THEN + ke = max(ke, 0.0) + ke = min(ke, 1.0) + IF(temperature > tfrz)THEN ! Unfrozen soil + thk = (ksat_u-kdry)*ke + kdry + ELSE ! Frozen or partially frozen soils + thk = (ksat_f-kdry)*ke + kdry + ENDIF + ENDIF + + IF(DEF_THERMAL_CONDUCTIVITY_SCHEME == 6) THEN +! ----------------------------------------------------------------------------------------- +! [6] Series-Parallel Models (Tarnawski and Leong, 2012) +! ----------------------------------------------------------------------------------------- + a = wf_gravels_s+wf_sand_s + +! a fitting parameter of the soil solid uniform passage + aa = 0.0237 - 0.0175*a**3 + +! a fitting parameter of a minuscule portion of soil water (nw) +! plus a minuscule portion of soil air (na) + nwm = 0.088 - 0.037*a**3 + +! the degree of saturation of the minuscle pore space + x = 0.6 - 0.3*a**3 + IF(sr < 1.0e-6)THEN + nw_nwm = 0.0 + ELSE + nw_nwm = exp(1.0-sr**(-x)) + ENDIF + + IF(temperature > tfrz)THEN ! Unfrozen soil + thk = k_solids*aa + (1.0-vf_pores_s-aa+nwm)**2 & + / ((1.0-vf_pores_s-aa)/k_solids+nwm/(k_water*nw_nwm+k_air*(1.0-nw_nwm))) & + + k_water*(vf_pores_s*sr-nwm*nw_nwm) & + + k_air*(vf_pores_s*(1.0-sr)-nwm*(1.0-nw_nwm)) + ELSE + thk = k_solids*aa + (1.0-vf_pores_s-aa+nwm)**2 & + / ((1.0-vf_pores_s-aa)/k_solids+nwm/(k_ice*nw_nwm+k_air*(1.0-nw_nwm))) & + + k_ice*(vf_pores_s*sr-nwm*nw_nwm) & + + k_air*(vf_pores_s*(1.0-sr)-nwm*(1.0-nw_nwm)) + ENDIF + ENDIF + + IF(DEF_THERMAL_CONDUCTIVITY_SCHEME == 7) THEN +! ----------------------------------------------------------------------------------------- +! [7] Thermal properties of soils, in Physics of Plant Environment, +! ed. by W.R. van Wijk (North-Holland, Amsterdam, 1963), pp. 210-235 +! ----------------------------------------------------------------------------------------- + IF(sr*vf_pores_s <= 0.09)THEN + ga = 0.013+0.944*sr*vf_pores_s + ELSE + ga = 0.333 - (1.-sr)*vf_pores_s/vf_pores_s*(0.333-0.035) + ENDIF + gc = 1.0-2.0*ga + + IF(temperature > tfrz)THEN ! Unfrozen soil + aa = (2.0/(1.0+(k_air/k_water-1.0)*ga) & ! the shape factor + + 1.0/(1.0+(k_air/k_water-1.0)*gc))/3.0 + aaa = (2.0/(1.0+(k_solids/k_water-1.0)*0.125) & ! the shape factor + + 1.0/(1.0+(k_solids/k_water-1.0)*(1.0-2.0*0.125)))/3.0 + + thk = (sr*vf_pores_s*k_water + (1.-sr)*vf_pores_s*aa*k_air + & + (1.-vf_pores_s)*aaa*k_solids) & + / (sr*vf_pores_s + (1.-sr)*vf_pores_s*aa + (1.-vf_pores_s)*aaa) + ELSE + aa = (2.0/(1.0+(k_air/k_ice-1.0)*ga) & ! the shape factor + + 1.0/(1.0+(k_air/k_ice-1.0)*gc))/3.0 + aaa = (2.0/(1.0+(k_solids/k_ice-1.0)*0.125) & ! the shape factor + + 1.0/(1.0+(k_solids/k_ice-1.0)*(1.0-2.0*0.125)))/3.0 + + thk = (sr*vf_pores_s*k_ice + (1.-sr)*vf_pores_s*aa*k_air + & + (1.-vf_pores_s)*aaa*k_solids) & + / (sr*vf_pores_s + (1.-sr)*vf_pores_s*aa + (1.-vf_pores_s)*aaa) + ENDIF + ENDIF + + IF(DEF_THERMAL_CONDUCTIVITY_SCHEME == 8) THEN +! ----------------------------------------------------------------------------------------- +! [8] Yan & He et al., 2019: A generalized model for estimating effective soil thermal conductivity +! based on the Kasubuchi algorithm, Geoderma, Vol 353, 227-242 +! ----------------------------------------------------------------------------------------- + beta = -0.303*ksat_u - 0.201*wf_sand_s + 1.532 + IF(vf_water > 0.01)THEN + ke = (1+(vf_pores_s/beta)**(-1.0*beta))/(1+(vf_water/beta)**(-1.0*beta)) + ELSE + ke = 0.0 + ENDIF + + ke = max(ke, 0.0) + ke = min(ke, 1.0) + + IF(temperature > tfrz)THEN ! Unfrozen soil + thk = (ksat_u-kdry)*ke + kdry + ELSE ! Frozen or partially frozen soils + thk = (ksat_f-kdry)*ke + kdry + ENDIF + ENDIF + + END SUBROUTINE soil_hcap_cond + +END MODULE MOD_SoilThermalParameters +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 new file mode 100644 index 0000000000..c727e85c9e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 @@ -0,0 +1,1390 @@ +#include + +MODULE MOD_Thermal + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: THERMAL + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE THERMAL (ipatch ,patchtype,is_dry_lake,lb ,deltim ,& + trsmx0 ,zlnd ,zsno ,csoilc ,& + dewmx ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm , & +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,lai ,laisun ,& + laisha ,sai ,htop ,hbot ,& + sqrtdi ,rootfr ,rstfacsun_out ,rstfacsha_out ,& + rss ,gssun_out ,gssha_out ,assimsun_out ,& + etrsun_out ,assimsha_out ,etrsha_out ,& +!photosynthesis and plant hydraulic variables + effcon ,vmax25 ,c3c4 ,hksati ,smp ,hk ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& + ck ,vegwp ,gs0sun ,gs0sha ,& +!Ozone stress variables + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& +!end ozone stress variables +!Ozone WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + slti ,hlti ,shti ,hhti ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_pco2m ,forc_hpbl ,forc_po2m ,& + coszen ,parsun ,parsha ,sabvsun ,& + sabvsha ,sabg ,sabg_soil ,sabg_snow ,& + frl ,extkb ,extkd ,thermk ,& + fsno ,sigf ,dz_soisno ,z_soisno ,& + zi_soisno ,tleaf ,t_soisno ,wice_soisno ,& + wliq_soisno ,ldew ,ldew_rain ,ldew_snow ,& + fwet_snow ,scv ,snowdp ,imelt ,& + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + rootr ,rootflux ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,& + qsubl_soil ,qfros_soil ,qseva_snow ,qsdew_snow ,& + qsubl_snow ,qfros_snow ,sm ,tref ,& + qref ,trad ,rst ,assim ,& + respc ,errore ,emis ,z0m ,& + zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,& + pg_rain ,pg_snow ,t_precip ,qintr_rain ,& + qintr_snow ,snofrz ,sabg_snow_lyr ) + +!======================================================================= +! this is the main subroutine to execute the calculation +! of thermal processes and surface fluxes +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002 +! +! FLOW DIAGRAM FOR THERMAL.F90 +! +! THERMAL ===> qsadv +! GroundFluxes +! eroot |dewfraction +! LeafTemperature | |qsadv +! LeafTemperaturePC | ----------> |moninobukini +! |moninobuk +! |MOD_AssimStomataConductance +! +! GroundTemperature ----------> meltf +! +! +! !REVISIONS: +! 08/2019, Hua Yuan: added initial codes for PFT and Plant Community +! (PC) vegetation classification processes +! +! 01/2021, Nan Wei: added variables passing of plant hydraulics and +! precipitation sensible heat with canopy and ground for PFT +! and Plant Community (PC) +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_PFT + USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& + stefnc,denice,tfrz,vonkar,grav,cpliq,cpice + USE MOD_FrictionVelocity + USE MOD_Eroot + USE MOD_GroundFluxes + USE MOD_LeafTemperature + USE MOD_LeafTemperaturePC + USE MOD_GroundTemperature + USE MOD_Qsadv + USE MOD_SoilSurfaceResistance +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Vars_TimeVariables, only: & + lai_enftemp, lai_enfboreal, lai_dnfboreal, lai_ebftrop, lai_ebftemp, lai_dbftrop, lai_dbftemp, & + lai_dbfboreal, lai_ebstemp, lai_dbstemp, lai_dbsboreal, lai_c3arcgrass, lai_c3grass, lai_c4grass + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq +#endif + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW, & + DEF_USE_LCT,DEF_USE_PFT,DEF_USE_PC,DEF_PC_CROP_SPLIT + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: & + ipatch, &! patch index + lb, &! lower bound of array + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=glacier/ice sheet, 4=land water bodies) + logical, intent(in) :: is_dry_lake + + real(r8), intent(inout) :: & + sai ! stem area index [-] + real(r8), intent(in) :: & + deltim, &! model time step [second] + trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + capr, &! tuning factor to turn first layer T into surface T + cnfac, &! Crank Nicholson factor between 0 and 1 + + ! soil physical parameters + vf_quartz (1:nl_soil), &! volumetric fraction of quartz within mineral soil + vf_gravels(1:nl_soil), &! volumetric fraction of gravels + vf_om (1:nl_soil), &! volumetric fraction of organic matter + vf_sand (1:nl_soil), &! volumetric fraction of sand + wf_gravels(1:nl_soil), &! gravimetric fraction of gravels + wf_sand (1:nl_soil), &! gravimetric fraction of sand + csol (1:nl_soil), &! heat capacity of soil solids [J/(m3 K)] + porsl (1:nl_soil), &! soil porosity [-] + psi0 (1:nl_soil), &! soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + bsw(1:nl_soil), &! clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil), &! residual moisture content [-] + alpha_vgm (1:nl_soil), &! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), &! pore-connectivity parameter [dimensionless] + L_vgm (1:nl_soil), &! a shape parameter [dimensionless] + sc_vgm (1:nl_soil), &! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), &! a scaling factor by using air entry value in the Mualem model [-] +#endif + k_solids (1:nl_soil), &! thermal conductivity of minerals soil [W/m-K] + dkdry (1:nl_soil), &! thermal conductivity of dry soil [W/m-K] + dksatu (1:nl_soil), &! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (1:nl_soil), &! thermal conductivity of saturated frozen soil [W/m-K] + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + BA_alpha (1:nl_soil), &! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (1:nl_soil), &! beta in Balland and Arp(2005) thermal conductivity scheme + + ! vegetation parameters + lai, &! adjusted leaf area index for seasonal variation [-] + htop, &! canopy crown top height [m] + hbot, &! canopy crown bottom height [m] + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + rootfr(1:nl_soil), &! root fraction + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + kmax_sun, &! Plant Hydraulics Parameters + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck, &! shape-fitting parameter for vulnerability curve (-) + slti, &! slope of low temperature inhibition function [s3] + hlti, &! 1/2 point of low temperature inhibition function [s4] + shti, &! slope of high temperature inhibition function [s1] + hhti, &! 1/2 point of high temperature inhibition function [s2] + trda, &! temperature coefficient in gs-a model [s5] + trdm, &! temperature coefficient in gs-a model [s6] + trop, &! temperature coefficient in gs-a model + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + extkn, &! coefficient of leaf nitrogen allocation + + ! atmospherical variables and observational height + forc_hgt_u, &! observational height of wind [m] + forc_hgt_t, &! observational height of temperature [m] + forc_hgt_q, &! observational height of humidity [m] + forc_us, &! wind component in eastward direction [m/s] + forc_vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + forc_q, &! specific humidity at agcm reference height [kg/kg] + forc_rhoair, &! density air [kg/m3] + forc_psrf, &! atmosphere pressure at the surface [pa] + forc_pco2m, &! CO2 concentration in atmos. (pascals) + forc_po2m, &! O2 concentration in atmos. (pascals) + forc_hpbl, &! atmospheric boundary layer height [m] + pg_rain, &! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain, &! rainfall interception (mm h2o/s) + qintr_snow, &! snowfall interception (mm h2o/s) + + ! radiative fluxes + coszen, &! cosine of the solar zenith angle + parsun, &! photosynthetic active radiation by sunlit leaves (W m-2) + parsha, &! photosynthetic active radiation by shaded leaves (W m-2) + sabvsun, &! solar radiation absorbed by vegetation [W/m2] + sabvsha, &! solar radiation absorbed by vegetation [W/m2] + sabg, &! solar radiation absorbed by ground [W/m2] + sabg_soil, &! solar radiation absorbed by ground soil [W/m2] + sabg_snow, &! solar radiation absorbed by ground snow [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + thermk, &! canopy gap fraction for tir radiation + + ! state variable (1) + fsno, &! fraction of ground covered by snow + sigf, &! fraction of veg cover, excluding snow-covered veg [-] + dz_soisno(lb:nl_soil), &! layer thickness [m] + z_soisno (lb:nl_soil), &! node depth [m] + zi_soisno(lb-1:nl_soil) ! interface depth [m] + + integer , intent(in) :: & + c3c4 ! C3/C4 plant type + + real(r8), intent(in) :: & + sabg_snow_lyr(lb:1) ! snow layer absorption + + ! state variables (2) + real(r8), intent(inout) :: & + vegwp(1:nvegwcs), &! vegetation water potential + gs0sun, &! working copy of sunlit stomata conductance + gs0sha, &! working copy of shaded stomata conductance +!Ozone stress variables + lai_old , &! lai in last time step + o3uptakesun, &! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha, &! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone , &! Ozone +!end ozone stress variables + +!Ozone WUE stomata model parameter + lambda, &! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + + tleaf, &! shaded leaf temperature [K] + t_soisno(lb:nl_soil), &! soil temperature [K] + wice_soisno(lb:nl_soil), &! ice lens [kg/m2] + wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + + real(r8), intent(in) :: & + smp(1:nl_soil) , &! soil matrix potential [mm] + hk(1:nl_soil) ! hydraulic conductivity [mm h2o/s] + + real(r8), intent(inout) :: & + ldew, &! depth of water on foliage [kg/(m2 s)] + ldew_rain, &! depth of rain on foliage [kg/(m2 s)] + ldew_snow, &! depth of rain on foliage [kg/(m2 s)] + fwet_snow, &! vegetation canopy snow fractional cover [-] + scv, &! snow cover, water equivalent [mm, kg/m2] + snowdp ! snow depth [m] + + real(r8), intent(out) :: & + snofrz (lb:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + + integer, intent(out) :: & + imelt(lb:nl_soil) ! flag for melting or freezing [-] + + real(r8), intent(out) :: & + laisun, &! sunlit leaf area index + laisha, &! shaded leaf area index + gssun_out, &! sunlit stomata conductance + gssha_out, &! shaded stomata conductance + rstfacsun_out, &! factor of soil water stress on sunlit leaf + rstfacsha_out ! factor of soil water stress on shaded leaf + + real(r8), intent(out) :: & + assimsun_out , &! diagnostic sunlit leaf assim value for output + etrsun_out , &! diagnostic sunlit leaf etr value for output + assimsha_out , &! diagnostic shaded leaf assim for output + etrsha_out ! diagnostic shaded leaf etr for output + + ! Output fluxes + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat from canopy height to atmosphere [W/m2] + fevpa, &! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa, &! latent heat flux from canopy height to atmosphere [W/m2] + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + olrg, &! outgoing long-wave radiation from ground+canopy + fgrnd, &! ground heat flux [W/m2] + rootr(1:nl_soil), &! water uptake fraction from different layers, all layers add to 1.0 + rootflux(1:nl_soil), &! root uptake from different layer, all layers add to transpiration + + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros, &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil, &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil, &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil, &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil, &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow, &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow, &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow, &! surface dew added to snow pack (mm h2o /s) [+] + + sm, &! rate of snowmelt [kg/(m2 s)] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air specific humidity + trad, &! radiative temperature [K] + rss, &! bare soil resistance for evaporation [s/m] + rst, &! stomatal resistance (s m-1) + assim, &! assimilation + respc, &! respiration + + ! additional variables required by coupling with WRF or RSM model + emis, &! averaged bulk surface emissivity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! u* in similarity theory [m/s] + qstar, &! q* in similarity theory [kg/kg] + tstar, &! t* in similarity theory [K] + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + +!Ozone stress variables + real(r8),intent(inout) :: & + o3coefv_sun,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun,&! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ! Ozone stress factor for stomata on shaded leaf +!end ozone stress variables + + +!-------------------------- Local Variables ---------------------------- + + integer i,j + + real(r8) :: & + fseng_soil, &! sensible heat flux from soil fraction + fseng_snow, &! sensible heat flux from snow fraction + fevpg_soil, &! latent heat flux from soil fraction + fevpg_snow, &! latent heat flux from snow fraction + + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + degdT, &! d(eg)/dT + dqgdT, &! d(qg)/dT + dlrad, &! downward longwave radiation blow the canopy [W/m2] + eg, &! water vapor pressure at temperature T [pa] + egsmax, &! max. evaporation which soil can provide at one time step + egidif, &! the excess of evaporation over "egsmax" + emg, &! ground emissivity (0.97 for snow, + ! glaciers and water surface; 0.96 for soil and wetland) + errore, &! energy balnce error [w/m2] + etrc, &! maximum possible transpiration rate [mm/s] + fac, &! soil wetness of surface layer + fact(lb:nl_soil), &! used in computing tridiagonal matrix + fsun, &! fraction of sunlit canopy + hr, &! relative humidity + htvp, &! latent heat of vapor of water (or sublimation) [j/kg] + olru, &! olrg excluding dwonwelling reflection [W/m2] + olrb, &! olrg assuming blackbody emission [W/m2] + psit, &! negative potential of soil + qg, &! ground specific humidity [kg/kg] +! 03/07/2020, yuan: + q_soil, &! ground soil specific humidity [kg/kg] + q_snow, &! ground snow specific humidity [kg/kg] + qsatg, &! saturated humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + qred, &! soil surface relative humidity + sabv, &! solar absorbed by canopy [W/m2] + thm, &! intermediate variable (forc_t+0.0098*forc_hgt_t) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + rstfac, &! factor of soil water stress + t_grnd, &! ground surface temperature [K] + t_grnd_bef, &! ground surface temperature [K] + t_soil, &! ground soil temperature + t_snow, &! ground snow temperature + t_soisno_bef(lb:nl_soil), &! soil/snow temperature before update + tinc, &! temperature difference of two time step + ur, &! wind speed at reference height [m/s] + ulrad, &! upward longwave radiation above the canopy [W/m2] + wice0(lb:nl_soil), &! ice mass from previous time-step + wliq0(lb:nl_soil), &! liquid mass from previous time-step + wx, &! patial volume of ice and water of surface layer + xmf, &! total latent heat of phase change of ground water [W/m2] + hprl, &! precipitation sensible heat from canopy [W/m2] + dheatl ! vegetation heat change [W/m2] + + real(r8) :: z0m_g,z0h_g,zol_g,obu_g,rib_g,ustar_g,qstar_g,tstar_g + real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu + + integer p, ps, pe, pn + + real(r8), allocatable :: rootr_p (:,:) + real(r8), allocatable :: rootflux_p (:,:) + real(r8), allocatable :: etrc_p (:) + real(r8), allocatable :: rstfac_p (:) + real(r8), allocatable :: rstfacsun_p (:) + real(r8), allocatable :: rstfacsha_p (:) + real(r8), allocatable :: gssun_p (:) + real(r8), allocatable :: gssha_p (:) + real(r8), allocatable :: fsun_p (:) + real(r8), allocatable :: sabv_p (:) + real(r8), allocatable :: fcover (:) + +! 03/06/2020, yuan: added + real(r8), allocatable :: fseng_soil_p (:) + real(r8), allocatable :: fseng_snow_p (:) + real(r8), allocatable :: fevpg_soil_p (:) + real(r8), allocatable :: fevpg_snow_p (:) + real(r8), allocatable :: cgrnd_p (:) + real(r8), allocatable :: cgrnds_p (:) + real(r8), allocatable :: cgrndl_p (:) + real(r8), allocatable :: dlrad_p (:) + real(r8), allocatable :: ulrad_p (:) + real(r8), allocatable :: zol_p (:) + real(r8), allocatable :: rib_p (:) + real(r8), allocatable :: ustar_p (:) + real(r8), allocatable :: qstar_p (:) + real(r8), allocatable :: tstar_p (:) + real(r8), allocatable :: fm_p (:) + real(r8), allocatable :: fh_p (:) + real(r8), allocatable :: fq_p (:) + real(r8), allocatable :: hprl_p (:) + real(r8), allocatable :: assimsun_p (:) + real(r8), allocatable :: etrsun_p (:) + real(r8), allocatable :: assimsha_p (:) + real(r8), allocatable :: etrsha_p (:) + real(r8), allocatable :: dheatl_p (:) + + +!======================================================================= +! [1] Initial set and propositional variables +!======================================================================= + + ! emissivity + emg = 0.96 + IF (scv>0. .or. patchtype==3) emg = 0.97 + + ! fluxes + taux = 0.; tauy = 0. + fsena = 0.; fevpa = 0. + lfevpa = 0.; fsenl = 0. + fevpl = 0.; etr = 0. + fseng = 0.; fevpg = 0. + + cgrnds = 0.; cgrndl = 0. + cgrnd = 0.; tref = 0. + qref = 0.; rst = 2.0e4 + assim = 0.; respc = 0. + hprl = 0.; dheatl = 0. + + emis = 0.; z0m = 0. + zol = 0.; rib = 0. + ustar = 0.; qstar = 0. + tstar = 0.; rootr = 0. + rootflux = 0. + + dlrad = frl + + t_soil = t_soisno(1) + t_snow = t_soisno(lb) + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + t_grnd = t_soisno(lb) + ulrad = frl*(1.-emg) + emg*stefnc*t_grnd**4 +ELSE + t_grnd = fsno*t_snow + (1.-fsno)*t_soil + ulrad = frl*(1.-emg) & + + fsno*emg*stefnc*t_snow**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 +ENDIF + + ! temperature and water mass from previous time step + t_soisno_bef(lb:) = t_soisno(lb:) + t_grnd_bef = t_grnd + wice0(lb:) = wice_soisno(lb:) + wliq0(lb:) = wliq_soisno(lb:) + + ! latent heat, assumed that the sublimation occurred only as wliq_soisno=0 + htvp = hvap + IF (wliq_soisno(lb)<=0. .and. wice_soisno(lb)>0.) htvp = hsub + + ! potential temperature at the reference height + thm = forc_t + 0.0098*forc_hgt_t !intermediate variable equivalent to + !forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) !potential T + thv = th*(1.+0.61*forc_q) !virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) !limit set to 0.1 + + +!======================================================================= +! [2] specific humidity and its derivative at ground surface +!======================================================================= + + qred = 1. + hr = 1. + + IF ((patchtype<=1) .or. is_dry_lake & + .or. (DEF_USE_Dynamic_Wetland .and. (patchtype==2))) THEN !soil ground + wx = (wliq_soisno(1)/denh2o + wice_soisno(1)/denice)/dz_soisno(1) + IF (porsl(1) < 1.e-6) THEN !bed rock + fac = 0.001 + ELSE + fac = min(1.,wx/porsl(1)) + fac = max( fac, 0.001 ) + ENDIF + +#ifdef Campbell_SOIL_MODEL + psit = psi0(1) * fac ** (- bsw(1) ) !psit = max(smpmin, psit) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + psit = soil_psi_from_vliq ( fac*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + psit = max( -1.e8, psit ) + hr = exp(psit/roverg/t_grnd) + qred = (1.-fsno)*hr + fsno + ENDIF + +IF (.not. DEF_SPLIT_SOILSNOW) THEN + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + + qg = qred*qsatg + dqgdT = qred*qsatgdT + + IF (qsatg > forc_q .and. forc_q > qred*qsatg) THEN + qg = forc_q; dqgdT = 0. + ENDIF + + q_soil = qg + q_snow = qg + +ELSE + CALL qsadv(t_soil,forc_psrf,eg,degdT,qsatg,qsatgdT) + + q_soil = hr*qsatg + dqgdT = (1.-fsno)*hr*qsatgdT + + IF(qsatg > forc_q .and. forc_q > hr*qsatg)THEN + q_soil = forc_q; dqgdT = 0. + ENDIF + + CALL qsadv(t_snow,forc_psrf,eg,degdT,qsatg,qsatgdT) + + q_snow = qsatg + dqgdT = dqgdT + fsno*qsatgdT + + ! weighted average qg + qg = (1.-fsno)*q_soil + fsno*q_snow +ENDIF + + ! calculate soil surface resistance (rss) + ! ------------------------------------------------ + !NOTE: (1) DEF_RSS_SCHEME=0 means no rss considered + ! (2) Do NOT calculate rss for the first timestep + IF (DEF_RSS_SCHEME>0 .and. rss/=spval) THEN + + !NOTE: If the beta scheme is used, the rss is not soil resistance, + !but soil beta factor (soil wetness relative to field capacity [0-1]). + CALL SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + ELSE + IF (DEF_RSS_SCHEME == 4) THEN + rss = 1. !LP92 + ELSE + rss = 0. !the other RSS schemes + ENDIF + ENDIF + +!======================================================================= +! [3] Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +! TODO: modify code description +!======================================================================= + + ! Always CALL GroundFluxes for bare ground CASE + CALL GroundFluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_hpbl, & + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,t_grnd,qg,rss,dqgdT,htvp, & + fsno,cgrnd,cgrndl,cgrnds, & + t_soil,t_snow,q_soil,q_snow, & + !taux,tauy,fseng,fevpg,tref,qref, & + taux,tauy,fseng,fseng_soil,fseng_snow, & + fevpg,fevpg_soil,fevpg_snow,tref,qref, & + z0m_g,z0h_g,zol_g,rib_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) + + obu_g = forc_hgt_u / zol_g + + +!======================================================================= +! [4] Canopy temperature, fluxes from the canopy +!======================================================================= + +IF ( patchtype==0.and.DEF_USE_LCT .or. patchtype>0 ) THEN + + sabv = sabvsun + sabvsha + + IF (lai+sai > 1e-6) THEN + + ! soil water stress factor on stomatal resistance + CALL eroot (nl_soil,trsmx0,porsl,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr,dz_soisno,t_soisno,wliq_soisno,rootr,etrc,rstfac) + + ! fraction of sunlit and shaded leaves of canopy + fsun = ( 1. - exp(-min(extkb*lai,40.))) / max( min(extkb*lai,40.), 1.e-6 ) + + IF (coszen<=0.0 .or. sabv<1.) fsun = 0.5 + + laisun = lai*fsun + laisha = lai*(1-fsun) + rstfacsun_out = rstfac + rstfacsha_out = rstfac + + CALL LeafTemperature(ipatch,1,deltim,csoilc ,dewmx ,htvp ,& + lai ,sai ,htop ,hbot ,sqrtdi ,& + effcon ,vmax25 ,c3c4 ,slti ,hlti ,shti ,& + hhti ,trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,extkb ,& + extkd ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,forc_q ,& + forc_psrf ,forc_rhoair ,parsun ,parsha ,sabv ,& + frl ,fsun ,thermk ,rstfacsun_out,rstfacsha_out,& + gssun_out ,gssha_out ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf ,etrc ,t_grnd ,qg ,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& + emg ,tleaf ,ldew ,ldew_rain ,ldew_snow ,& + fwet_snow ,taux ,tauy ,& + fseng ,fseng_soil ,fseng_snow ,& + fevpg ,fevpg_soil ,fevpg_snow ,& + cgrnd ,cgrndl ,cgrnds ,& + tref ,qref ,rst ,assim ,respc ,& + fsenl ,fevpl ,etr ,dlrad ,ulrad ,& + z0m ,zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,rootfr ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& + psi50_sha ,psi50_xyl ,psi50_root ,ck ,vegwp ,& + gs0sun ,gs0sha ,& + assimsun_out,etrsun_out ,assimsha_out ,etrsha_out ,& +!Ozone stress variables + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& +!end ozone stress variables +!Ozone WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + forc_hpbl ,& + qintr_rain ,qintr_snow ,t_precip ,hprl ,dheatl ,& + smp ,hk(1:) ,hksati(1:) ,rootflux(1:) ) + ELSE + tleaf = forc_t + laisun = 0. + laisha = 0. + ldew_rain = 0. + ldew_snow = 0. + fwet_snow = 0. + ldew = 0. + rstfacsun_out = 0. + rstfacsha_out = 0. + assimsun_out = 0. + assimsha_out = 0. + etrsun_out = 0. + etrsha_out = 0. + gssun_out = 0. + gssha_out = 0. + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp = -2.5e4 + ENDIF + ENDIF + +ENDIF + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +IF (patchtype == 0) THEN + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( rootr_p (nl_soil, ps:pe) ) + allocate ( rootflux_p(nl_soil,ps:pe)) + allocate ( etrc_p (ps:pe) ) + allocate ( rstfac_p (ps:pe) ) + allocate ( rstfacsun_p (ps:pe) ) + allocate ( rstfacsha_p (ps:pe) ) + allocate ( gssun_p (ps:pe) ) + allocate ( gssha_p (ps:pe) ) + allocate ( fsun_p (ps:pe) ) + allocate ( sabv_p (ps:pe) ) + allocate ( fcover (ps:pe) ) + + allocate ( fseng_soil_p (ps:pe) ) + allocate ( fseng_snow_p (ps:pe) ) + allocate ( fevpg_soil_p (ps:pe) ) + allocate ( fevpg_snow_p (ps:pe) ) + allocate ( cgrnd_p (ps:pe) ) + allocate ( cgrnds_p (ps:pe) ) + allocate ( cgrndl_p (ps:pe) ) + allocate ( dlrad_p (ps:pe) ) + allocate ( ulrad_p (ps:pe) ) + allocate ( zol_p (ps:pe) ) + allocate ( rib_p (ps:pe) ) + allocate ( ustar_p (ps:pe) ) + allocate ( qstar_p (ps:pe) ) + allocate ( tstar_p (ps:pe) ) + allocate ( fm_p (ps:pe) ) + allocate ( fh_p (ps:pe) ) + allocate ( fq_p (ps:pe) ) + + allocate ( hprl_p (ps:pe) ) + allocate ( assimsun_p (ps:pe) ) + allocate ( etrsun_p (ps:pe) ) + allocate ( assimsha_p (ps:pe) ) + allocate ( etrsha_p (ps:pe) ) + allocate ( dheatl_p (ps:pe) ) + + sabv_p(ps:pe) = sabvsun_p(ps:pe) + sabvsha_p(ps:pe) + sabv = sabvsun + sabvsha + + DO i = ps, pe + p = pftclass(i) + + IF (lai_p(i)+sai_p(i) > 1e-6) THEN + + CALL eroot (nl_soil,trsmx0,porsl,& +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr_p(:,p),& + dz_soisno,t_soisno,wliq_soisno,rootr_p(:,i),etrc_p(i),rstfac_p(i)) + + ! fraction of sunlit and shaded leaves of canopy + fsun_p(i) = ( 1. - exp(-min(extkb_p(i)*lai_p(i),40.))) & + / max( min(extkb_p(i)*lai_p(i),40.), 1.e-6 ) + + IF (coszen<=0.0 .or. sabv_p(i)<1.) fsun_p(i) = 0.5 + + laisun_p(i) = lai_p(i)*fsun_p(i) + laisha_p(i) = lai_p(i)*(1-fsun_p(i)) + rstfacsun_p(i) = rstfac_p(i) + rstfacsha_p(i) = rstfac_p(i) + ELSE + laisun_p(i) = 0. + laisha_p(i) = 0. + ldew_rain_p(i) = 0. + ldew_snow_p(i) = 0. + fwet_snow_p(i) = 0. + ldew_p(i) = 0. + rootr_p(:,i) = 0. + rootflux_p(:,i)= 0. + rstfacsun_p(i) = 0. + rstfacsha_p(i) = 0. + dheatl_p(i) = 0. + ENDIF + ENDDO + + IF (.not. DEF_USE_LAIFEEDBACK)THEN + lai_enftemp (ipatch) = 0._r8 + lai_enfboreal (ipatch) = 0._r8 + lai_dnfboreal (ipatch) = 0._r8 + lai_ebftrop (ipatch) = 0._r8 + lai_ebftemp (ipatch) = 0._r8 + lai_dbftrop (ipatch) = 0._r8 + lai_dbftemp (ipatch) = 0._r8 + lai_dbfboreal (ipatch) = 0._r8 + lai_ebstemp (ipatch) = 0._r8 + lai_dbstemp (ipatch) = 0._r8 + lai_dbsboreal (ipatch) = 0._r8 + lai_c3arcgrass (ipatch) = 0._r8 + lai_c3grass (ipatch) = 0._r8 + lai_c4grass (ipatch) = 0._r8 + DO i = ps, pe + p = pftclass(i) + IF(p .eq. 1)THEN + lai_enftemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 2)THEN + lai_enfboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 3)THEN + lai_dnfboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 4)THEN + lai_ebftrop (ipatch) = lai_p(i) + ELSE IF(p .eq. 5)THEN + lai_ebftemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 6)THEN + lai_dbftrop (ipatch) = lai_p(i) + ELSE IF(p .eq. 7)THEN + lai_dbftemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 8)THEN + lai_dbfboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 9)THEN + lai_ebstemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 10)THEN + lai_dbstemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 11)THEN + lai_dbsboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 12)THEN + lai_c3arcgrass(ipatch) = lai_p(i) + ELSE IF(p .eq. 13)THEN + lai_c3grass (ipatch) = lai_p(i) + ELSE IF(p .eq. 14)THEN + lai_c4grass (ipatch) = lai_p(i) + ENDIF + ENDDO + ENDIF + + DO i = ps, pe + p = pftclass(i) + + ! Dealing with PFTs for PC: + ! If defined DEF_PC_CROP_SPLIT, for crop PFTs, use 1D twostream model; + ! Otherwise, skip to run PC 3D model. + IF ( DEF_USE_PC .and. (.not.DEF_PC_CROP_SPLIT .or. p.lt.15) ) THEN + CYCLE + ENDIF + + IF (lai_p(i)+sai_p(i) > 1e-6) THEN + + CALL LeafTemperature(ipatch,p,deltim ,csoilc ,dewmx ,htvp ,& + lai_p(i) ,sai_p(i) ,htop_p(i) ,hbot_p(i) ,sqrtdi_p(p) ,& + effcon_p(p) ,vmax25_p(p) ,c3c4_p(p) ,slti_p(p) ,hlti_p(p) ,shti_p(p) ,& + hhti_p(p) ,trda_p(p) ,trdm_p(p) ,trop_p(p) ,g1_p(p) ,& + g0_p(p) ,gradm_p(p) ,binter_p(p) ,extkn_p(p) ,extkb_p(i) ,& + extkd_p(i) ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,forc_q ,& + forc_psrf ,forc_rhoair ,parsun_p(i) ,parsha_p(i) ,sabv_p(i) ,& + frl ,fsun_p(i) ,thermk_p(i) ,rstfacsun_p(i) ,rstfacsha_p(i) ,& + gssun_p(i) ,gssha_p(i) ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf_p(i) ,etrc_p(i) ,t_grnd ,qg ,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& + emg ,tleaf_p(i) ,ldew_p(i) ,ldew_rain_p(i) ,ldew_snow_p(i) ,& + fwet_snow_p(i) ,taux_p(i) ,tauy_p(i) ,& + fseng_p(i) ,fseng_soil_p(i) ,fseng_snow_p(i) ,& + fevpg_p(i) ,fevpg_soil_p(i) ,fevpg_snow_p(i) ,& + cgrnd_p(i) ,cgrndl_p(i) ,cgrnds_p(i) ,& + tref_p(i) ,qref_p(i) ,rst_p(i) ,assim_p(i) ,respc_p(i) ,& + fsenl_p(i) ,fevpl_p(i) ,etr_p(i) ,dlrad_p(i) ,ulrad_p(i) ,& + z0m_p(i) ,zol_p(i) ,rib_p(i) ,ustar_p(i) ,qstar_p(i) ,& + tstar_p(i) ,fm_p(i) ,fh_p(i) ,fq_p(i) ,rootfr_p(:,p) ,& + kmax_sun_p(p) ,kmax_sha_p(p) ,kmax_xyl_p(p) ,kmax_root_p(p) ,psi50_sun_p(p) ,& + psi50_sha_p(p) ,psi50_xyl_p(p) ,psi50_root_p(p) ,ck_p(p) ,vegwp_p(:,i) ,& + gs0sun_p(i) ,gs0sha_p(i) ,& + assimsun_p(i) ,etrsun_p(i) ,assimsha_p(i) ,etrsha_p(i) ,& +!Ozone stress variables + o3coefv_sun_p(i),o3coefv_sha_p(i),o3coefg_sun_p(i),o3coefg_sha_p(i),& + lai_old_p(i) ,o3uptakesun_p(i),o3uptakesha_p(i),forc_ozone ,& +!end ozone stress variables +!Ozone WUE stomata model parameter + lambda_p(p) ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + forc_hpbl ,& + qintr_rain_p(i) ,qintr_snow_p(i) ,t_precip ,hprl_p(i) ,dheatl_p(i) ,& + smp ,hk(1:) ,hksati(1:) ,rootflux_p(1:,i) ) + ELSE + + CALL GroundFluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_hpbl, & + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,t_grnd,qg,rss,dqgdT,htvp, & + fsno,cgrnd_p(i),cgrndl_p(i),cgrnds_p(i), & + t_soil,t_snow,q_soil,q_snow, & + taux_p(i),tauy_p(i),fseng_p(i),fseng_soil_p(i),fseng_snow_p(i), & + fevpg_p(i),fevpg_soil_p(i),fevpg_snow_p(i),tref_p(i),qref_p(i), & + z0m_p(i),z0h_g,zol_p(i),rib_p(i),ustar_p(i),& + qstar_p(i),tstar_p(i),fm_p(i),fh_p(i),fq_p(i)) + + tleaf_p (i) = forc_t + gssun_p (i) = 0. + gssha_p (i) = 0. + assimsun_p (i) = 0. + etrsun_p (i) = 0. + assimsha_p (i) = 0. + etrsha_p (i) = 0. + rst_p (i) = 2.0e4 + assim_p (i) = 0. + respc_p (i) = 0. + fsenl_p (i) = 0. + fevpl_p (i) = 0. + etr_p (i) = 0. + dlrad_p (i) = frl + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + ulrad_p (i) = frl*(1.-emg) + emg*stefnc*t_grnd**4 +ELSE + ulrad_p (i) = frl*(1.-emg) & + + fsno*emg*stefnc*t_snow**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 +ENDIF + hprl_p (i) = 0. + + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp_p(:,i) = -2.5e4 + ENDIF + ENDIF + ENDDO + + ! Calculate end index of natrue PFTs + DO i = ps, pe + pn = i + p = pftclass(i) + IF (DEF_PC_CROP_SPLIT .and. p.ge.15) THEN + pn = pn - 1 + EXIT + ENDIF + ENDDO + +IF ( DEF_USE_PC .and. pn.ge.ps ) THEN + + pe = pn + + ! initialization + rst_p (ps:pe) = 2.0e4 + assim_p (ps:pe) = 0. + respc_p (ps:pe) = 0. + fsenl_p (ps:pe) = 0. + fevpl_p (ps:pe) = 0. + etr_p (ps:pe) = 0. + hprl_p (ps:pe) = 0. + assimsun_p (ps:pe) = 0. + assimsha_p (ps:pe) = 0. + etrsun_p (ps:pe) = 0. + etrsha_p (ps:pe) = 0. + gssun_p (ps:pe) = 0. + gssha_p (ps:pe) = 0. + fcover (ps:pe) = pftfrac(ps:pe) / sum(pftfrac(ps:pe)) + z0m_p (ps:pe) = (1.-fsno)*zlnd + fsno*zsno + z0m = sum( z0m_p (ps:pe)*pftfrac(ps:pe) ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp_p (:,ps:pe) = -2.5e4 + ENDIF + + CALL LeafTemperaturePC (ipatch,ps,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass(ps:pe) ,fcover(ps:pe) ,htop_p(ps:pe) ,hbot_p(ps:pe) ,& + lai_p(ps:pe) ,sai_p(ps:pe) ,extkb_p(ps:pe) ,extkd_p(ps:pe) ,forc_hgt_u ,& + forc_hgt_t ,forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + thm ,th ,thv ,forc_q ,forc_psrf ,& + forc_rhoair ,parsun_p(ps:pe) ,parsha_p(ps:pe) ,fsun_p(:) ,sabv_p(:) ,& + frl ,thermk_p(ps:pe) ,fshade_p(ps:pe) ,rstfacsun_p(:) ,rstfacsha_p(:) ,& + gssun_p(:) ,gssha_p(:) ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf_p(ps:pe) ,etrc_p(:) ,t_grnd ,qg,rss ,dqgdT ,& + emg ,t_soil ,t_snow ,q_soil ,q_snow ,& + z0m_p(ps:pe) ,tleaf_p(ps:pe) ,ldew_p(ps:pe) ,ldew_rain_p(ps:pe),ldew_snow_p(ps:pe),& + fwet_snow_p(ps:pe),taux ,tauy ,fseng ,fseng_soil ,& + fseng_snow ,fevpg ,fevpg_soil ,fevpg_snow ,cgrnd ,& + cgrndl ,cgrnds ,tref ,qref ,rst_p(ps:pe) ,& + assim_p(ps:pe) ,respc_p(ps:pe) ,fsenl_p(ps:pe) ,fevpl_p(ps:pe) ,etr_p(ps:pe) ,& + dlrad ,ulrad ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,fh ,& + fq ,vegwp_p(:,ps:pe) ,gs0sun_p(ps:pe) ,gs0sha_p(ps:pe) ,assimsun_p(:) ,& + etrsun_p(:) ,assimsha_p(:) ,etrsha_p(:) ,& +!Ozone stress variables + o3coefv_sun_p(ps:pe) ,o3coefv_sha_p(ps:pe) ,o3coefg_sun_p(ps:pe) ,o3coefg_sha_p(ps:pe) ,& + lai_old_p(ps:pe) ,o3uptakesun_p(ps:pe) ,o3uptakesha_p(ps:pe) ,forc_ozone ,& +!End ozone stress variables + forc_hpbl ,& + qintr_rain_p(ps:pe) ,qintr_snow_p(ps:pe) ,t_precip ,hprl_p(:) ,& + dheatl_p(ps:pe) ,smp ,hk(1:) ,hksati(1:) ,& + rootflux_p(:,:) ) + + dlrad_p (ps:pe) = dlrad + ulrad_p (ps:pe) = ulrad + tref_p (ps:pe) = tref + qref_p (ps:pe) = qref + taux_p (ps:pe) = taux + tauy_p (ps:pe) = tauy + fseng_p (ps:pe) = fseng + fseng_soil_p (ps:pe) = fseng_soil + fseng_snow_p (ps:pe) = fseng_snow + fevpg_p (ps:pe) = fevpg + fevpg_soil_p (ps:pe) = fevpg_soil + fevpg_snow_p (ps:pe) = fevpg_snow + cgrnd_p (ps:pe) = cgrnd + cgrndl_p (ps:pe) = cgrndl + cgrnds_p (ps:pe) = cgrnds + z0m_p (ps:pe) = z0m + zol_p (ps:pe) = zol + rib_p (ps:pe) = rib + ustar_p (ps:pe) = ustar + qstar_p (ps:pe) = qstar + tstar_p (ps:pe) = tstar + fm_p (ps:pe) = fm + fh_p (ps:pe) = fh + fq_p (ps:pe) = fq +ENDIF + + pe = patch_pft_e(ipatch) + + ! aggregate PFTs to a patch + laisun = sum( laisun_p (ps:pe)*pftfrac(ps:pe) ) + laisha = sum( laisha_p (ps:pe)*pftfrac(ps:pe) ) + tleaf = sum( tleaf_p (ps:pe)*pftfrac(ps:pe) ) + ldew_rain = sum( ldew_rain_p (ps:pe)*pftfrac(ps:pe) ) + ldew_snow = sum( ldew_snow_p (ps:pe)*pftfrac(ps:pe) ) + fwet_snow = sum( fwet_snow_p (ps:pe)*pftfrac(ps:pe) ) + ldew = sum( ldew_p (ps:pe)*pftfrac(ps:pe) ) + ! may have problem with rst, but the same for LC + rst = sum( rst_p (ps:pe)*pftfrac(ps:pe) ) + assim = sum( assim_p (ps:pe)*pftfrac(ps:pe) ) + respc = sum( respc_p (ps:pe)*pftfrac(ps:pe) ) + fsenl = sum( fsenl_p (ps:pe)*pftfrac(ps:pe) ) + fevpl = sum( fevpl_p (ps:pe)*pftfrac(ps:pe) ) + etr = sum( etr_p (ps:pe)*pftfrac(ps:pe) ) + + dlrad = sum( dlrad_p (ps:pe)*pftfrac(ps:pe) ) + ulrad = sum( ulrad_p (ps:pe)*pftfrac(ps:pe) ) + tref = sum( tref_p (ps:pe)*pftfrac(ps:pe) ) + qref = sum( qref_p (ps:pe)*pftfrac(ps:pe) ) + taux = sum( taux_p (ps:pe)*pftfrac(ps:pe) ) + tauy = sum( tauy_p (ps:pe)*pftfrac(ps:pe) ) + fseng = sum( fseng_p (ps:pe)*pftfrac(ps:pe) ) + fseng_soil = sum( fseng_soil_p(ps:pe)*pftfrac(ps:pe) ) + fseng_snow = sum( fseng_snow_p(ps:pe)*pftfrac(ps:pe) ) + fevpg = sum( fevpg_p (ps:pe)*pftfrac(ps:pe) ) + fevpg_soil = sum( fevpg_soil_p(ps:pe)*pftfrac(ps:pe) ) + fevpg_snow = sum( fevpg_snow_p(ps:pe)*pftfrac(ps:pe) ) + cgrnd = sum( cgrnd_p (ps:pe)*pftfrac(ps:pe) ) + cgrndl = sum( cgrndl_p (ps:pe)*pftfrac(ps:pe) ) + cgrnds = sum( cgrnds_p (ps:pe)*pftfrac(ps:pe) ) + z0m = sum( z0m_p (ps:pe)*pftfrac(ps:pe) ) + zol = sum( zol_p (ps:pe)*pftfrac(ps:pe) ) + rib = sum( rib_p (ps:pe)*pftfrac(ps:pe) ) + ustar = sum( ustar_p (ps:pe)*pftfrac(ps:pe) ) + qstar = sum( qstar_p (ps:pe)*pftfrac(ps:pe) ) + tstar = sum( tstar_p (ps:pe)*pftfrac(ps:pe) ) + fm = sum( fm_p (ps:pe)*pftfrac(ps:pe) ) + fh = sum( fh_p (ps:pe)*pftfrac(ps:pe) ) + fq = sum( fq_p (ps:pe)*pftfrac(ps:pe) ) + + rstfacsun_out = sum( rstfacsun_p (ps:pe)*pftfrac(ps:pe) ) + rstfacsha_out = sum( rstfacsha_p (ps:pe)*pftfrac(ps:pe) ) + gssun_out = sum( gssun_p (ps:pe)*pftfrac(ps:pe) ) + gssha_out = sum( gssha_p (ps:pe)*pftfrac(ps:pe) ) + assimsun_out = sum( assimsun_p (ps:pe)*pftfrac(ps:pe) ) + etrsun_out = sum( etrsun_p (ps:pe)*pftfrac(ps:pe) ) + assimsha_out = sum( assimsha_p (ps:pe)*pftfrac(ps:pe) ) + etrsha_out = sum( etrsha_p (ps:pe)*pftfrac(ps:pe) ) + hprl = sum( hprl_p (ps:pe)*pftfrac(ps:pe) ) + dheatl = sum( dheatl_p (ps:pe)*pftfrac(ps:pe) ) +IF (DEF_USE_OZONESTRESS)THEN + o3uptakesun = sum(o3uptakesun_p(ps:pe)*pftfrac(ps:pe) ) + o3uptakesha = sum(o3uptakesha_p(ps:pe)*pftfrac(ps:pe) ) +END IF + + IF(DEF_USE_PLANTHYDRAULICS)THEN + DO j = 1, nvegwcs + vegwp(j) = sum( vegwp_p(j,ps:pe)*pftfrac(ps:pe) ) + ENDDO + + IF (abs(etr) > 0.) THEN + DO j = 1, nl_soil + rootflux(j) = sum(rootflux_p(j,ps:pe)*pftfrac(ps:pe)) + ENDDO + ENDIF + ELSE + IF (abs(etr) > 0.) THEN + DO j = 1, nl_soil + rootr(j) = sum(rootr_p(j,ps:pe)*etr_p(ps:pe)*pftfrac(ps:pe)) / etr + ENDDO + ENDIF + ENDIF + + deallocate ( rootflux_p ) + deallocate ( etrc_p ) + deallocate ( rstfac_p ) + deallocate ( rstfacsun_p ) + deallocate ( rstfacsha_p ) + deallocate ( gssun_p ) + deallocate ( gssha_p ) + deallocate ( fsun_p ) + deallocate ( sabv_p ) + deallocate ( fcover ) + + deallocate ( fseng_soil_p) + deallocate ( fseng_snow_p) + deallocate ( fevpg_soil_p) + deallocate ( fevpg_snow_p) + deallocate ( cgrnd_p ) + deallocate ( cgrnds_p ) + deallocate ( cgrndl_p ) + deallocate ( dlrad_p ) + deallocate ( ulrad_p ) + deallocate ( zol_p ) + deallocate ( rib_p ) + deallocate ( ustar_p ) + deallocate ( qstar_p ) + deallocate ( tstar_p ) + deallocate ( fm_p ) + deallocate ( fh_p ) + deallocate ( fq_p ) + + deallocate ( hprl_p ) + deallocate ( assimsun_p ) + deallocate ( etrsun_p ) + deallocate ( assimsha_p ) + deallocate ( etrsha_p ) + deallocate ( dheatl_p ) + +ENDIF +#endif + + +!======================================================================= +! [5] Ground temperature +!======================================================================= + + CALL GroundTemperature (patchtype,is_dry_lake,lb,nl_soil,deltim,& + capr,cnfac,vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm,& + sc_vgm , fc_vgm,& +#endif + csol,k_solids,dksatu,dksatf,dkdry,& + BA_alpha,BA_beta,& + sigf,dz_soisno,z_soisno,zi_soisno,& + t_soisno,t_grnd,t_soil,t_snow,wice_soisno,wliq_soisno,scv,snowdp,fsno,& + frl,dlrad,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + fseng,fseng_soil,fseng_snow,fevpg,fevpg_soil,fevpg_snow,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! [6] Correct fluxes to present soil temperature +!======================================================================= + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + t_grnd = t_soisno(lb) + tinc = t_soisno(lb) - t_soisno_bef(lb) + ELSE + t_grnd = fsno*t_soisno(lb) + (1.0-fsno)*t_soisno(1) + tinc = t_grnd - t_grnd_bef + ENDIF + + fseng = fseng + tinc*cgrnds + fseng_soil = fseng_soil + tinc*cgrnds + fseng_snow = fseng_snow + tinc*cgrnds + fevpg = fevpg + tinc*cgrndl + fevpg_soil = fevpg_soil + tinc*cgrndl + fevpg_snow = fevpg_snow + tinc*cgrndl + +! calculation of evaporative potential; flux in kg m-2 s-1. +! egidif holds the excess energy IF all water is evaporated +! during the timestep. This energy is later added to the sensible heat flux. + + qseva = 0. + qsubl = 0. + qfros = 0. + qsdew = 0. + qseva_soil = 0. + qsubl_soil = 0. + qfros_soil = 0. + qsdew_soil = 0. + qseva_snow = 0. + qsubl_snow = 0. + qfros_snow = 0. + qsdew_snow = 0. + + +IF (.not. DEF_SPLIT_SOILSNOW) THEN + egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim + egidif = max( 0., fevpg - egsmax ) + fevpg = min( fevpg, egsmax ) + fseng = fseng + htvp*egidif + + IF (fevpg >= 0.) THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva = min(wliq_soisno(lb)/deltim, fevpg) + qsubl = fevpg - qseva + ELSE + IF (t_grnd < tfrz) THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF + ENDIF + +ELSE + IF (lb < 1) THEN ! snow layer exist + egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim + egidif = max( 0., fevpg_snow - egsmax ) + fevpg_snow = min ( fevpg_snow, egsmax ) + fseng_snow = fseng_snow + htvp*egidif + ELSE ! no snow layer, attribute to soil + fevpg_soil = fevpg_soil*(1.-fsno) + fevpg_snow*fsno + ENDIF + + egsmax = (wice_soisno(1)+wliq_soisno(1)) / deltim + egidif = max( 0., fevpg_soil - egsmax ) + fevpg_soil = min ( fevpg_soil, egsmax ) + fseng_soil = fseng_soil + htvp*egidif + + IF (lb < 1) THEN ! snow layer exist + fseng = fseng_soil*(1.-fsno) + fseng_snow*fsno + fevpg = fevpg_soil*(1.-fsno) + fevpg_snow*fsno + ELSE ! no snow layer, attribute to soil + fseng = fseng_soil; fseng_snow = 0. + fevpg = fevpg_soil; fevpg_snow = 0. + ENDIF + + IF(fevpg_snow >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_snow = min(wliq_soisno(lb)/deltim, fevpg_snow) + qsubl_snow = fevpg_snow - qseva_snow + qseva_snow = qseva_snow*fsno + qsubl_snow = qsubl_snow*fsno + ELSE + ! snow temperature < tfrz + IF(t_soisno(lb) < tfrz)THEN + qfros_snow = abs(fevpg_snow*fsno) + ELSE + qsdew_snow = abs(fevpg_snow*fsno) + ENDIF + ENDIF + + IF(fevpg_soil >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_soil = min(wliq_soisno(1)/deltim, fevpg_soil) + qsubl_soil = fevpg_soil - qseva_soil + ELSE + ! soil temperature < tfrz + IF(t_soisno(1) < tfrz)THEN + qfros_soil = abs(fevpg_soil) + ELSE + qsdew_soil = abs(fevpg_soil) + ENDIF + ENDIF + + IF (lb < 1) THEN ! snow layer exists + qseva_soil = qseva_soil*(1.-fsno) + qsubl_soil = qsubl_soil*(1.-fsno) + qfros_soil = qfros_soil*(1.-fsno) + qsdew_soil = qsdew_soil*(1.-fsno) + ENDIF +ENDIF + + +! total fluxes to atmosphere + fsena = fsenl + fseng + fevpa = fevpl + fevpg + lfevpa = hvap*fevpl + htvp*fevpg ! W/m^2 (accounting for sublimation) + +! ground heat flux +IF (.not.DEF_SPLIT_SOILSNOW) THEN + fgrnd = sabg + dlrad*emg & + - emg*stefnc*t_grnd_bef**4 & + - emg*stefnc*t_grnd_bef**3*(4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) +ELSE + fgrnd = sabg + dlrad*emg & + - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 & + - emg*stefnc*t_grnd_bef**3*(4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) +ENDIF + +! outgoing long-wave radiation from canopy + ground + olrg = ulrad & +! for conservation we put the increase of ground longwave to outgoing + + 4.*emg*stefnc*t_grnd_bef**3*tinc + +! averaged bulk surface emissivity + olrb = stefnc*t_grnd_bef**3*(4.*tinc) + olru = ulrad + emg*olrb + olrb = ulrad + olrb + emis = olru / olrb + +! radiative temperature + IF (olrg < 0) THEN + print *, "MOD_Thermal.F90: Error! Negative outgoing longwave radiation flux: " + write(6,*) ipatch, olrg, tinc, ulrad + write(6,*) ipatch,errore,sabv,sabg,frl,olrg,fsenl,fseng,hvap*fevpl,htvp*fevpg,xmf,fgrnd + ENDIF + + trad = (olrg/stefnc)**0.25 + +! additional variables required by WRF and RSM model + IF (lai+sai <= 1e-6) THEN + ustar = ustar_g + tstar = tstar_g + qstar = qstar_g + rib = rib_g + zol = zol_g + z0m = z0m_g + fm = fm_g + fh = fh_g + fq = fq_g + ENDIF + + +!======================================================================= +! [7] energy balance error +!======================================================================= + + ! one way to check energy balance + errore = sabv + sabg + frl - olrg - fsena - lfevpa - fgrnd - dheatl + hprl & + + cpliq*pg_rain*(t_precip-t_grnd) + cpice*pg_snow*(t_precip-t_grnd) + + ! another way to check energy balance + errore = sabv + sabg + frl - olrg - fsena - lfevpa - xmf - dheatl + hprl & + + cpliq*pg_rain*(t_precip-t_grnd) + cpice*pg_snow*(t_precip-t_grnd) + + DO j = lb, nl_soil + errore = errore - (t_soisno(j)-t_soisno_bef(j))/fact(j) + ENDDO + +#if (defined CoLMDEBUG) + IF (abs(errore) > .5) THEN + write(6,*) 'MOD_Thermal.F90: energy balance violation' + write(6,*) ipatch,errore,sabv,sabg,frl,olrg,fsenl,fseng,hvap*fevpl,htvp*fevpg,xmf,hprl + write(6,*) cpliq*pg_rain*(t_precip-t_grnd), cpice*pg_snow*(t_precip-t_grnd) + CALL CoLM_stop () + ENDIF +100 format(10(f15.3)) +#endif + + END SUBROUTINE THERMAL + +END MODULE MOD_Thermal +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 new file mode 100644 index 0000000000..6ab6cbff0f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 @@ -0,0 +1,465 @@ +MODULE MOD_TurbulenceLEddy + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: moninobuk_leddy + PUBLIC :: moninobukm_leddy + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: psi + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE moninobuk_leddy(hu,ht,hq,displa,z0m,z0h,z0q,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + +!======================================================================= +! +! Implement the LZD2022 scheme (Liu et al., 2022), which accounts for +! large eddy effects by including the boundary layer height in the phim +! FUNCTION, to compute friction velocity, relation for potential +! temperature and humidity profiles of surface boundary layer. +! +! !REFERENCES: +! [1] Zeng et al., 1998: Intercomparison of bulk aerodynamic algorithms +! for the computation of sea surface fluxes using TOGA CORE and TAO +! data. J. Climate, 11: 2628-2644. +! [2] Liu et al., 2022: A surface flux estimation scheme accounting for +! large-eddy effects for land surface modeling. GRL, 49, +! e2022GL101754. +! +! Created by Shaofeng Liu, May 5, 2023 +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fm10m ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam, & + zetam2 ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zetazi ! hpbl/obu, dimensionless height used in the LZD2022 scheme + real(r8) Bm ! Coefficient of the LZD2022 scheme: Bm = 0.0047*(-hpbl/L) + 0.1854 + real(r8) Bm2 ! max(Bm, 0.2722) + +! real(r8), external :: psi ! stability FUNCTION for unstable CASE +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.05 +! + zetazi = max(5.*hu, hpbl)/obu + IF(zetazi >= 0.) THEN !stable + zetazi = min(200.,max(zetazi,1.e-5)) + ELSE !unstable + zetazi = max(-1.e4,min(zetazi,-1.e-5)) + ENDIF + + Bm = 0.0047 * (-zetazi) + 0.1854 + zetam = 0.5*Bm**4 * ( -16. - sqrt(256. + 4./Bm**4) ) + Bm2 = max(Bm, 0.2722) + zetam2 = min(zetam, -0.13) + + IF(zeta < zetam2)THEN ! zeta < zetam2 + fm = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) + ustar = vonkar*um / fm +! +! End: Shaofeng Liu, 2023.05.05 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + +! for 10 meter wind-velocity + zldis=10.+z0m + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.18 +! + IF(zeta < zetam2)THEN ! zeta < zetam2 + fm10m = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) +! +! End: Shaofeng Liu, 2023.05.18 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobuk_leddy + + + SUBROUTINE moninobukm_leddy(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt, hpbl, & + ustar,fh2m,fq2m,htop,fmtop,fm,fh,fq,fht,fqt,phih) + +!======================================================================= +! +! !DESCRIPTION: +! +! +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of friction velocity, relation for potential temperature and +! humidity profiles of surface boundary layer. the scheme is based on the work +! of Zeng et al. (1998): Intercomparison of bulk aerodynamic algorithms for the +! computation of sea surface fluxes using TOGA CORE and TAO data. J. Climate, +! Vol. 11: 2628-2644 +! +! !REVISIONS: +! Hua Yuan, 09/2017: adapted from moninobuk FUNCTION to calculate canopy top +! fm, fq and phih for roughness sublayer u/k profile calculation +! Shaofeng Liu, 05/2023: implement the LZD2022 scheme (Liu et al., 2022), which +! accounts for large eddy effects by including the +! boundary leyer height in the phim FUNCTION. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +! ---------------------- dummy argument -------------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: displat ! displacement height of the top layer [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: z0mt ! roughness length of the top layer, latent heat [m] + real(r8), intent(in) :: htop ! canopy top height of the top layer [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fmtop ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: fht ! integral of profile FUNCTION for heat at the top layer + real(r8), intent(out) :: fqt ! integral of profile FUNCTION for moisture at the top layer + real(r8), intent(out) :: phih ! phi(h), similarity FUNCTION for sensible heat + +!------------------------ local variables ------------------------------ + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam, & + zetam2 ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zetazi ! hpbl/obu, dimensionless height used in the LZD2022 scheme + real(r8) Bm ! Coefficient of the LZD2022 scheme: Bm = 0.0047*(-hpbl/L) + 0.1854 + real(r8) Bm2 ! max(Bm, 0.2722) + +! real(r8), external :: psi ! stability FUNCTION for unstable CASE +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.05 +! +! zetazi = hpbl/obu + zetazi = max(5.*hu, hpbl)/obu + IF(zetazi >= 0.) THEN !stable + zetazi = min(200.,max(zetazi,1.e-5)) + ELSE !unstable + zetazi = max(-1.e4,min(zetazi,-1.e-5)) + ENDIF + + Bm = 0.0047 * (-zetazi) + 0.1854 + zetam = 0.5*Bm**4 * ( -16. - sqrt(256. + 4./Bm**4) ) + Bm2 = max(Bm, 0.2722) + zetam2 = min(zetam, -0.13) + + IF(zeta < zetam2)THEN ! zeta < zetam2 + fm = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) + ustar = vonkar*um / fm +! +! End: Shaofeng Liu, 2023.05.05 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + +! for canopy top wind-velocity +!NOTE: changed for canopy top wind-velocity (no wake assumed) + zldis=htop-displa + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.18 +! +! zetam=1.574 + IF(zeta < zetam2)THEN ! zeta < zetam2 + fmtop = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) +! +! End: Shaofeng Liu, 2023.05.18 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for top layer temperature + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fht = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for canopy top phi(h) +! CESM TECH NOTE eq. (5.31) + zldis=htop-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + +! for top layer humidity + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fqt = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobukm_leddy + + + + real(r8) FUNCTION psi(k,zeta) + +!======================================================================= +! stability FUNCTION for unstable CASE (rib < 0) + + USE MOD_Precision + IMPLICIT NONE + + integer k + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) chik ! + + chik = (1.-16.*zeta)**0.25 + IF(k == 1)THEN + psi = 2.*log((1.+chik)*0.5)+log((1.+chik*chik)*0.5)-2.*atan(chik)+2.*atan(1.) + ELSE + psi = 2.*log((1.+chik*chik)*0.5) + ENDIF + + END FUNCTION psi + + +END MODULE MOD_TurbulenceLEddy +! --------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 new file mode 100644 index 0000000000..692a8a5be6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 @@ -0,0 +1,969 @@ +#include + +MODULE MOD_UserSpecifiedForcing + +!DESCRIPTION +!=========== + !---This MODULE is used for read atmospheric forcing dataset from various sources. + ! ------------------------------------------------------------ + ! Read forcing data from : + ! 1) PRINCETON 2) GSWP2 3) GSWP3 + ! 4) QIAN 5) CRUNCEPV4 6) CRUNCEPV7 + ! 7) ERA5LAND 8) ERA5 9) MSWX + ! 10) WFDE5 11) CRUJRA 12) WFDEI + ! 13) JRA55 14) GDAS 15) CLDAS + ! 16) CMFD 17) TPMFD 18) CMIP6 + ! 19) POINT 20) JRA3Q 21) CRA40 + ! + ! PLEASE modify the following codes when specified forcing used + ! ------------------------------------------------------------ +!Original Author: +!------------------- + !---Shupeng Zhang and Zhongwang Wei + +!References: +!------------------- + !---In preparation + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + !* :SUBROUTINE:"init_user_specified_forcing" : initialization of the selected forcing dataset + !* :SUBROUTINE:"metfilename" : identify the forcing file name + !* :SUBROUTINE:"metpreprocess" : preprocess the forcing data + +!REVISION HISTORY + !---------------- + ! 2023.05.01 Shupeng Zhang and Zhongwang Wei @ SYSU + ! 2021.12.02 Shupeng Zhang and Zhongwang Wei @ SYSU + ! Siguang Zhu and Nan Wei, 10/2014: metpreprocess for forc_q calibration + ! Hua Yuan, 04/2014: initial code of forcing structure for CoLM2014 + + USE MOD_Precision + + IMPLICIT NONE + + character(len=256) :: dataset + + logical :: solarin_all_band ! whether solar radiation in all bands is available + + character(len=256) :: HEIGHT_mode ! observation height mode + real(r8) :: HEIGHT_V ! observation height of wind speed + real(r8) :: HEIGHT_T ! observation height of air temperature + real(r8) :: HEIGHT_Q ! observation height of specific humidity + + integer :: NVAR ! variable number of forcing data + integer :: startyr ! start year of forcing data + integer :: startmo ! start month of forcing data + integer :: endyr ! END year of forcing data + integer :: endmo ! END month of forcing data + + integer, allocatable :: dtime(:) ! time interval of forcing data + integer, allocatable :: offset(:) ! offset of forcing data + + logical :: leapyear ! leapyear calendar + logical :: data2d ! data in 2 dimension (lon, lat) + logical :: hightdim ! have "z" dimension + logical :: dim2d ! lat/lon value in 2 dimension (lon, lat) + + character(len=256) :: latname ! dimension name of latitude + character(len=256) :: lonname ! dimension name of longitude + + character(len=256) :: groupby ! file grouped by year/month + + character(len=256), allocatable :: fprefix(:) ! file prefix + character(len=256), allocatable :: vname(:) ! variable name + character(len=256), allocatable :: timelog(:) ! variable time log info + character(len=256), allocatable :: tintalgo(:) ! interpolation algorithm + + ! ----- public subroutines ----- + PUBLIC :: init_user_specified_forcing ! initialization of the selected forcing dataset + PUBLIC :: metfilename ! identify the forcing file name + PUBLIC :: metpreprocess ! preprocess the forcing data + +CONTAINS + + ! ---------------- + SUBROUTINE init_user_specified_forcing + + USE MOD_Namelist + IMPLICIT NONE + + ! Local variables + integer :: ivar,NVAR_default + + NVAR = DEF_forcing%NVAR + NVAR_default=NVAR + IF (DEF_USE_CBL_HEIGHT) THEN + NVAR=NVAR+1 + ENDIF + + IF (allocated(dtime )) deallocate(dtime) + IF (allocated(offset)) deallocate(offset) + allocate (dtime (NVAR)) + allocate (offset (NVAR)) + + IF (allocated(fprefix )) deallocate(fprefix ) + IF (allocated(vname )) deallocate(vname ) + IF (allocated(timelog )) deallocate(timelog ) + IF (allocated(tintalgo)) deallocate(tintalgo) + allocate (fprefix (NVAR)) + allocate (vname (NVAR)) + allocate (timelog (NVAR)) + allocate (tintalgo (NVAR)) + + solarin_all_band = DEF_forcing%solarin_all_band ! whether solar radiation in all bands + HEIGHT_mode = DEF_forcing%HEIGHT_mode ! observation height mode + HEIGHT_V = DEF_forcing%HEIGHT_V ! observation height of wind speed + HEIGHT_T = DEF_forcing%HEIGHT_T ! observation height of air temperature + HEIGHT_Q = DEF_forcing%HEIGHT_Q ! observation height of specific humidity + + startyr = DEF_forcing%startyr ! start year of forcing data + startmo = DEF_forcing%startmo ! start month of forcing data + endyr = DEF_forcing%endyr ! end year of forcing data + endmo = DEF_forcing%endmo ! end month of forcing data + dtime(:) = DEF_forcing%dtime(:) ! time interval of forcing data + offset(:) = DEF_forcing%offset(:) ! offset of forcing data + + leapyear = DEF_forcing%leapyear ! whether leapyear calendar + data2d = DEF_forcing%data2d ! whether data in 2 dimension (lon, lat) + hightdim = DEF_forcing%hightdim ! whether have "z" dimension (height) + dim2d = DEF_forcing%dim2d ! whether lat/lon in 2 dimension (lon,lat) + + latname = DEF_forcing%latname ! dimension name of latitude + lonname = DEF_forcing%lonname ! dimension name of longitude + + groupby = DEF_forcing%groupby ! file grouped by year/month + + DO ivar = 1, NVAR_default + fprefix (ivar) = DEF_forcing%fprefix(ivar) ! file prefix + vname (ivar) = DEF_forcing%vname(ivar) ! variable name + timelog (ivar) = DEF_forcing%timelog(ivar) ! variable name + tintalgo(ivar) = DEF_forcing%tintalgo(ivar) ! interpolation algorithm + ENDDO + IF (DEF_USE_CBL_HEIGHT) THEN + fprefix (NVAR) = DEF_forcing%CBL_fprefix + vname (NVAR) = DEF_forcing%CBL_vname + tintalgo(NVAR) = DEF_forcing%CBL_tintalgo + dtime (NVAR) = DEF_forcing%CBL_dtime + offset (NVAR) = DEF_forcing%CBL_offset + ENDIF + END SUBROUTINE init_user_specified_forcing + + ! ---------------- + FUNCTION metfilename(year, month, day, var_i, is_spinup) + + USE MOD_Namelist + IMPLICIT NONE + + integer, intent(in) :: year + integer, intent(in) :: month + integer, intent(in) :: day + integer, intent(in) :: var_i + + logical, intent(in), optional :: is_spinup + + character(len=256) :: metfilename + character(len=256) :: yearstr + character(len=256) :: monthstr + + write(yearstr, '(I4.4)') year + write(monthstr, '(I2.2)') month + + IF (present(is_spinup)) THEN + IF (DEF_USE_ClimForcing_for_Spinup .and. is_spinup) THEN + yearstr = 'clim' + ENDIF + ENDIF + + select CASE (trim(DEF_forcing%dataset)) + CASE ('PRINCETON') ! Princeton forcing data + !DESCRIPTION + !=========== + !---Princeton Global Meteorological Forcing Dataset for Land Surface Modeling + + !data source: + !------------------- + !---https://rda.ucar.edu/datasets/ds314.0/ + + !References: + !------------------- + !---Sheffield, J., G. Goteti, and E. F. Wood, 2006: Development of a 50-year + ! high-resolution global dataset of meteorological forcings for land surface modeling J. + ! Climate, 19(13), 3088-3111. + + !REVISION HISTORY + !---------------- + !---2022.05.01 Zhongwang Wei @ SYSU: remove the "z" dimension + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(yearstr)//'.nc' + CASE ('GSWP3') ! GSWP3 forcing data + !DESCRIPTION + !=========== + !---Global Meteorological Forcing Dataset for Global Soil Wetness Project Phase 3 + + !data source: + !------------------- + !---http://hydro.iis.u-tokyo.ac.jp/GSWP3/ + !---https://www.isimip.org/gettingstarted/input-data-bias-adjustment/details/4/ + + !References: + !------------------- + !---Dirmeyer, P. A., Gao, X., Zhao, M., Guo, Z., Oki, T. and Hanasaki, N. (2006) GSWP-2: + ! Multimodel Analysis and Implications for Our Perception of the Land Surface. Bulletin + ! of the American Meteorological Society, 87(10), 1381-98. + + !REVISION HISTORY + !---------------- + !--- + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' + CASE ('QIAN') ! Qian forcing data + !DESCRIPTION + !=========== + !---Qian Global Meteorological Forcing Dataset from 1948 to 2004 + + !data source: + !------------------- + !---Not available now! + + !References: + !------------------- + !---Qian T., and co-authors, 2006: Simulation of Global Land Surface Conditions from 1948 + ! to 2004. Part I: Forcing Data and Evaluations. J. Hydrometeorol., 7, 953-975. + + !REVISION HISTORY + !---------------- + !--- + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' + CASE ('CRUNCEPV4') ! CRUNCEP V4 forcing data + !DESCRIPTION + !=========== + !---CRUNCEP Version 4 - Atmospheric Forcing Data for the Community Land Model + + !data source: + !------------------- + !---http://dods.extra.cea.fr/data/p529viov/cruncep/V5_1901_2013/ + + !References: + !------------------- + !---Viovy, N. (2010), CRU‐NCEP dataset. + ! [Available at: http://dods.extra.cea.fr/data/p529viov/cruncep/readme.htm.] + + !REVISION HISTORY + !---------------- + !--- + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' + CASE ('CRUNCEPV7') ! CRUNCEP V7 forcing data + !DESCRIPTION + !=========== + !---CRUNCEP Version 7 - Atmospheric Forcing Data for the Community Land Model + + !data source: + !------------------- + !---https://rda.ucar.edu/datasets/ds314.3/ + + !References: + !------------------- + !---Viovy, Nicolas. (2018). CRUNCEP Version 7 - + ! Atmospheric Forcing Data for the Community Land Model. + ! Research Data Archive at the National Center for Atmospheric Research, + ! Computational and Information Systems Laboratory. + ! https://doi.org/10.5065/PZ8F-F017. Accessed 05 May 2023. + + !REVISION HISTORY + !---------------- + !--- + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' + CASE ('ERA5LAND') ! ERA5-Land forcing data + !DESCRIPTION + !=========== + !---enhanced global dataset for the land component of the fifth + ! generation of European ReAnalysis (ERA5) + + !data source: + !------------------- + !---https://cds.climate.copernicus.eu/cdsapp#!/dataset/reanalysis-era5-land?tab=form + + !References: + !------------------- + !---Muñoz-Sabater, J., Dutra, E., Agustí-Panareda, A., Albergel, C., Arduini, G., Balsamo, + ! G., Boussetta, S., Choulga, M., Harrigan, S., Hersbach, H. and Martens, B., 2021. + ! ERA5-Land: A state-of-the-art global reanalysis dataset for land applications. Earth + ! System Science Data, 13(9), pp.4349-4383. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; + ! remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr) + select CASE (var_i) + CASE (1) + metfilename = trim(metfilename) // '_2m_temperature.nc' + CASE (2) + metfilename = trim(metfilename) //'_specific_humidity.nc' + CASE (3) + metfilename = trim(metfilename) //'_surface_pressure.nc' + CASE (4) + metfilename = trim(metfilename) //'_total_precipitation_m_hr.nc' + CASE (5) + metfilename = trim(metfilename) //'_10m_u_component_of_wind.nc' + CASE (6) + metfilename = trim(metfilename) //'_10m_v_component_of_wind.nc' + CASE (7) + metfilename = trim(metfilename) //'_surface_solar_radiation_downwards_w_m2.nc' + CASE (8) + metfilename = trim(metfilename) //'_surface_thermal_radiation_downwards_w_m2.nc' + END select + CASE ('ERA5') ! ERA5 forcing data + !DESCRIPTION + !=========== + !---The fifth generation of European ReAnalysis (ERA5) + + !data source: + !------------------- + !---https://cds.climate.copernicus.eu/cdsapp#! + ! /dataset/reanalysis-era5-single-levels?tab=overview + + !References: + !------------------- + !---Hersbach, H., Bell, B., Berrisford, P., Hirahara, S., Horányi, A., Muñoz‐Sabater, J., + ! Nicolas, J., Peubey, C., Radu, R., Schepers, D. and Simmons, A., 2020. The ERA5 global + ! reanalysis. Quarterly Journal of the Royal Meteorological Society, 146(730), + ! pp.1999-2049. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; remove + ! offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr) + select CASE (var_i) + CASE (1) + metfilename = trim(metfilename) // '_2m_temperature.nc4' + CASE (2) + metfilename = trim(metfilename) //'_q.nc4' + CASE (3) + metfilename = trim(metfilename) //'_surface_pressure.nc4' + CASE (4) + metfilename = trim(metfilename) //'_mean_total_precipitation_rate.nc4' + CASE (5) + metfilename = trim(metfilename) //'_10m_u_component_of_wind.nc4' + CASE (6) + metfilename = trim(metfilename) //'_10m_v_component_of_wind.nc4' + CASE (7) + metfilename = trim(metfilename) //'_mean_surface_downward_short_wave_radiation_flux.nc4' + CASE (8) + metfilename = trim(metfilename) //'_mean_surface_downward_long_wave_radiation_flux.nc4' + END select + CASE ('MSWX') ! MSWX forcing data + !DESCRIPTION + !=========== + !---Multi-Source Weather forcing data + + !data source: + !------------------- + !---https://www.gloh2o.org/mswx/ + + !References: + !------------------- + !---Beck, H.E., van Dijk, A.I., Larraondo, P.R., McVicar, T.R., Pan, M., Dutra, E. and + ! Miralles, D.G., 2022. MSWX: Global 3-hourly 0.1 bias-corrected meteorological data + ! including near-real-time updates and forecast ensembles. Bulletin of the American + ! Meteorological Society, 103(3), pp.E710-E732. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: Regroup data into monthly + + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)//'.nc' + CASE ('WFDE5') + !DESCRIPTION + !=========== + !---WATCH Forcing Data methodology applied to ERA5 reanalysis data + + !data source: + !------------------- + !---https://doi.org/10.24381/cds.20d54e34 + + !References: + !------------------- + !---Cucchi, M., Weedon, G.P., Amici, A., Bellouin, N., Lange, S., Müller Schmied, H., + ! Hersbach, H. and Buontempo, C., 2020. WFDE5: bias-adjusted ERA5 reanalysis data + ! for impact studies. Earth System Science Data, 12(3), pp.2097-2120. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; + ! remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'_v2.1.nc' + CASE ('CRUJRA') + !DESCRIPTION + !=========== + !---Collection of CRU JRA forcing datasets of gridded land surface blend + ! of Climatic Research Unit (CRU) and Japanese reanalysis (JRA) data + + !data source: + !------------------- + !---https://catalogue.ceda.ac.uk/uuid/863a47a6d8414b6982e1396c69a9efe8 + + !References: + !------------------- + !---University of East Anglia Climatic Research Unit; Harris, I.C. (2019): + ! CRU JRA: Collection of CRU JRA forcing datasets of gridded land surface blend + ! of Climatic Research Unit (CRU) and Japanese reanalysis (JRA) data.. + ! Centre for Environmental Data Analysis, date of citation. + !http://catalogue.ceda.ac.uk/uuid/863a47a6d8414b6982e1396c69a9efe8 + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; + ! remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'.365d.noc.nc' + + + CASE ('WFDEI') + !DESCRIPTION + !=========== + !---WATCH Forcing Data methodology applied to ERA-Interim reanalysis data + + !data source: + !------------------- + !---https://doi.org/10.24381/cds.20d54e34 + + !References: + !------------------- + !---Weedon, G.P., Balsamo, G., Bellouin, N., Gomes, S., Best, M.J. and Viterbo, P., 2014. + ! The WFDEI meteorological forcing data set: WATCH Forcing Data methodology applied + ! to ERA‐Interim reanalysis data. Water Resources Research, 50(9), pp.7505-7514. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; + ! remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' + CASE ('JRA3Q') + !DESCRIPTION + !=========== + !---Japanese Reanalysis for Three Quarters of a Century + + !data source: + !------------------- + !---https://rda.ucar.edu/datasets/ds640.0/ + + !References: + !------------------- + !---Kosaka Y., S. Kobayashi, Y. Harada, C. Kobayashi, H. Naoe, K. Yoshimoto, M. Harada, N. + ! Goto, J. Chiba, K. Miyaoka, R. Sekiguchi, M. Deushi, H. Kamahori, T. Nakaegawa; T. + ! Y.Tanaka, T. Tokuhiro, Y. Sato, Y. Matsushita, and K. Onogi, 2024: The JRA-3Q + ! reanalysis. J. Meteor. Soc. Japan, 102, https://doi.org/10.2151/jmsj.2024-004. + + + !REVISION HISTORY + !---------------- + !---2024.03.04 Zhongwang Wei @ SYSU: remove offset and scale_factor + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)//'.nc' + + CASE ('JRA55') + !DESCRIPTION + !=========== + !---the Japanese 55-year Reanalysis + + !data source: + !------------------- + !---https://jra.kishou.go.jp/JRA-55/index_en.html + + !References: + !------------------- + !---Kobayashi, S., Y. Ota, Y. Harada, A. Ebita, M. Moriya, H. Onoda, K. Onogi, + ! H. Kamahori, C. Kobayashi, H. Endo, K. Miyaoka, and K. Takahashi , 2015: + ! The JRA-55 Reanalysis: General specifications and basic characteristics. + ! J. Meteor. Soc. Japan, 93, 5-48, doi:10.2151/jmsj.2015-001. + !---Harada, Y., H. Kamahori, C. Kobayashi, H. Endo, S. Kobayashi, Y. Ota, H. Onoda, + ! K. Onogi, K. Miyaoka, and K. Takahashi, 2016: The JRA-55 Reanalysis: Representation + ! of atmospheric circulation and climate variability, J. Meteor. Soc. Japan, 94, + ! 269-302, doi:10.2151/jmsj.2016-015. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; + ! remove offset and scale_factor + + + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc' + + + CASE ('GDAS') + !DESCRIPTION + !=========== + !--- Forcing Data From Global Data Assimilation System + + !data source: + !------------------- + !--https://disc.sci.gsfc.nasa.gov/datasets/GLDAS_NOAH025_3H_V2.1/summary + + !References: + !------------------- + !---Beaudoing, H. and M. Rodell, NASA/GSFC/HSL (2020), GLDAS Noah Land Surface Model L4 3 + ! hourly 0.25 x 0.25 degree V2.1, Greenbelt, Maryland, USA, Goddard Earth Sciences Data + ! and Information Services Center (GES DISC), Accessed: [Data Access Date], + ! 10.5067/E7TYRXPJKWOQ + !---Rodell, M., P.R. Houser, U. Jambor, J. Gottschalck, K. Mitchell, C. Meng, K. Arsenault, + ! B. Cosgrove, J. Radakovich, M. Bosilovich, J.K. Entin, J.P. Walker, D. Lohmann, and D. + ! Toll, 2004: The Global Land Data Assimilation System, Bull. Amer. Meteor. Soc., 85, + ! 381-394, doi:10.1175/BAMS-85-3-381 + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: merge the data into monthly file; + ! zip file to reduce the size of the data; remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc4' + CASE ('CLDAS') + + !DESCRIPTION + !=========== + !---The Real-Time Product Dataset Of The China Meteorological Administration + ! Land Data Assimilation System + + !data source: + !------------------- + !--CMA, not pulicly available + + !References: + !------------------- + !---Xia, Y.L.; Hao, Z.C.; Shi, C.X.; Li, Y.H.; Meng, J.; Xu, T.R.; Wu, X.Y.; Zhang, B.Q. + ! Regional and global land data assimilation systems: Innovations, challenges, and + ! prospects. J. Meteorol. Res. 2019, 33, 159-189. + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: gap filling for the missing data; + ! zip file to reduce the size of the data; remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//'-'//trim(yearstr)//trim(monthstr)//'.nc' + CASE ('CMFD') + !DESCRIPTION + !=========== + !--- The China Meteorological Forcing Dataset + + !data source: + !------------------- + !--https://data.tpdc.ac.cn/en/data/8028b944-daaa-4511-8769-965612652c49/ + + !References: + !------------------- + !---He, J., Yang, K., Tang, W., Lu, H., Qin, J., Chen, Y. and Li, X., 2020. + ! The first high-resolution meteorological forcing dataset for land process + ! studies over China. Scientific data, 7(1), p.25. + + !REVISION HISTORY + !---------------- + !--- + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc4' + CASE ('CMFDv2') + !DESCRIPTION + !=========== + !--- The China Meteorological Forcing Dataset version 2.0 + + !data source: + !------------------- + !--https://data.tpdc.ac.cn/en/data/e60dfd96-5fd8-493f-beae-e8e5d24dece4 + + !References: + !------------------- + !---He, J., Yang, K., Li, X., Tang, W., Shao, C., Jiang, Y., Ding, B. 2024. + ! The China Meteorological Forcing Dataset (CMFD) version 2.0. + ! National Tibetan Plateau/Third Pole Environment Data Center, + ! https://doi.org/10.11888/Atmos.tpdc.300398. https://cstr.cn/18406.11.Atmos.tpdc.300398. + + !REVISION HISTORY + !---------------- + !--- + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc' + CASE ('CMIP6') + !DESCRIPTION + !=========== + !---the Climate Model Intercomparison Project Phase 6 (CMIP6) forcing data sets + + !data source: + !------------------- + !---https://esgf-node.llnl.gov/projects/cmip6/ + + !References: + !------------------- + !--- + + !REVISION HISTORY + !---------------- + !---2021.11.01 Zhongwang Wei @ SYSU: regroup the data into monthly file; + ! zip file to reduce the size of the data; remove offset and scale_factor + + + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc' + + CASE ('CRA40') + !DESCRIPTION + !=========== + !---CMA first-generation global atmospheric reanalysis (RA) covering 1979-2018 (CRA-40) + + !data source: + !------------------- + !---https://data.cma.cn/en + + !References: + !------------------- + !---Liu, Z., Jiang, L., Shi, C. et al. CRA-40/Atmosphere—The First-Generation Chinese + ! Atmospheric Reanalysis (1979-2018): System Description and Performance Evaluation. J + ! Meteorol Res 37, 1-19 (2023). https://doi.org/10.1007/s13351-023-2086-x + + + + !REVISION HISTORY + !---------------- + !---2024.04.10 Zhongwang Wei @ SYSU: regroup the data into annual file; + ! zip file to reduce the size of the data; remove offset and scale_factor + + + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc' + CASE ('TPMFD') + !DESCRIPTION + !=========== + !---A high-resolution near-surface meteorological forcing dataset for the Third Pole region + + !data source: + !------------------- + !---https://data.tpdc.ac.cn/zh-hans/data/44a449ce-e660-44c3-bbf2-31ef7d716ec7 + + !References: + !------------------- + !---Yang, K., Jiang, Y., Tang, W., He, J., Shao, C., Zhou, X., Lu, H., + ! Chen, Y., Li, X., Shi, J. (2023). A high-resolution near-surface + ! meteorological forcing dataset for the Third Pole region （TPMFD, 1979-2020）. + ! National Tibetan Plateau/Third Pole Environment Data Center, + ! https://doi.org/10.11888/Atmos.tpdc.300398. https://cstr.cn/18406.11.Atmos.tpdc.300398. + + !REVISION HISTORY + !---------------- + !---2023.11.01 Zhongwang Wei @ SYSU: regroup the data into monthly file; + ! zip file to reduce the size of the data; remove offset and scale_factor + + metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc' + CASE ('IsoGSM') + !DESCRIPTION + !=========== + !--- Isotopes-incorporated Global Spectral Model (IsoGSM) + + !data source: + !------------------- + !---https://isotope.iis.u-tokyo.ac.jp/about-our-lab?lang=en + + !References: + !------------------- + !---Bong, H., Cauquoin, A., Okazaki, A., Chang, E.-C., Werner, M., Wei, Z., et al. (2024). + ! Process-based intercomparison of water isotope-enabled models and reanalysis nudging effects. + ! Journal of Geophysical Research: Atmospheres, 129, e2023JD038719. + ! https://doi.org/10.1029/2023JD038719 + + !REVISION HISTORY + !---------------- + !---2025.03.23 Zhongwang Wei @ SYSU: add the isotope forcing data + + metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc' + + + CASE ('POINT') + metfilename = '/'//trim(fprefix(1)) + END select + IF (DEF_USE_CBL_HEIGHT) THEN + select CASE (var_i) + CASE (9) + metfilename = '/'//trim(fprefix(9))//'_'//trim(yearstr)//'_'//trim(monthstr)//& + '_boundary_layer_height.nc4' + END select + ENDIF + END FUNCTION metfilename + + ! preprocess for forcing data [not applicable yet for PRINCETON] + ! ------------------------------------------------------------ + SUBROUTINE metpreprocess(grid, forcn, has_missing_value, forcfirst, missing_value) + + USE MOD_Const_Physical + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_Qsadv + IMPLICIT NONE + type(grid_type), intent(in) :: grid + type(block_data_real8_2d), intent(inout) :: forcn(:) + type(block_data_real8_2d), intent(in) :: forcfirst + logical, intent(in) :: has_missing_value + real(r8), intent(in) :: missing_value + + integer :: iblkme, ib, jb, i, j + real(r8) :: es, esdT, qsat_tmp, dqsat_tmpdT, e, ea + + !---------------------------------------------------------------------------- + ! use polynomials to calculate saturation vapor pressure and derivative with + ! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + ! required to convert relative humidity to specific humidity + !---------------------------------------------------------------------------- + IF (trim(DEF_forcing%dataset) == 'POINT') THEN +#ifdef SinglePoint + CALL qsadv(forcn(1)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1), & + forcn(3)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1)) THEN + forcn(2)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1) = qsat_tmp + ENDIF +#endif + ELSE + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + DO j = 1, grid%ycnt(jb) + DO i = 1, grid%xcnt(ib) + + IF (has_missing_value) THEN + IF (forcfirst%blk(ib,jb)%val(i,j) == missing_value) THEN + CYCLE + ENDIF + ENDIF + + select CASE (trim(DEF_forcing%dataset)) + + CASE ('PRINCETON') + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('GSWP2') + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('GSWP3') + IF (forcn(1)%blk(ib,jb)%val(i,j)<212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0 + IF (forcn(4)%blk(ib,jb)%val(i,j)<0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('QIAN') + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + e = forcn(3)%blk(ib,jb)%val(i,j) * forcn(2)%blk(ib,jb)%val(i,j) & + / (0.622_R8 + 0.378_R8 * forcn(2)%blk(ib,jb)%val(i,j)) + ea = 0.70_R8 + 5.95e-05_R8 * 0.01_R8 * e & + * exp(1500.0_R8/forcn(1)%blk(ib,jb)%val(i,j)) + forcn(8)%blk(ib,jb)%val(i,j) = ea * stefnc * forcn(1)%blk(ib,jb)%val(i,j)**4 + + CASE ('CRUNCEPV4') + + IF (forcn(1)%blk(ib,jb)%val(i,j) < 212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0 + IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + IF (forcn(7)%blk(ib,jb)%val(i,j) < 0.0) forcn(7)%blk(ib,jb)%val(i,j) = 0.0 + ! 12th grade of Typhoon 32.7-36.9 m/s + IF (abs(forcn(5)%blk(ib,jb)%val(i,j)) > 40.0) forcn(5)%blk(ib,jb)%val(i,j) = & + 40.0*forcn(5)%blk(ib,jb)%val(i,j)/abs(forcn(5)%blk(ib,jb)%val(i,j)) + IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) forcn(6)%blk(ib,jb)%val(i,j) = & + 40.0*forcn(6)%blk(ib,jb)%val(i,j)/abs(forcn(6)%blk(ib,jb)%val(i,j)) + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('CRUNCEPV7') + + IF (forcn(1)%blk(ib,jb)%val(i,j) < 212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0 + IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + IF (forcn(7)%blk(ib,jb)%val(i,j) < 0.0) forcn(7)%blk(ib,jb)%val(i,j) = 0.0 + ! 12th grade of Typhoon 32.7-36.9 m/s + ! NOTE by Wenzong: This is a problem when running a GNU-compiled PROGRAM, + ! because there is no data of forcn(5), temporarily comment the code below + ! IF (abs(forcn(5)%blk(ib,jb)%val(i,j))>40.0) forcn(5)%blk(ib,jb)%val(i,j) = & + ! 40.0*forcn(5)%blk(ib,jb)%val(i,j)/abs(forcn(5)%blk(ib,jb)%val(i,j)) + IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) forcn(6)%blk(ib,jb)%val(i,j) = & + 40.0*forcn(6)%blk(ib,jb)%val(i,j)/abs(forcn(6)%blk(ib,jb)%val(i,j)) + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('ERA5LAND') + + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j) * 1000./3600. + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('ERA5') + + IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + IF (abs(forcn(5)%blk(ib,jb)%val(i,j)) > 40.0) & + forcn(5)%blk(ib,jb)%val(i,j) = 40.0*sign(1.0,forcn(5)%blk(ib,jb)%val(i,j)) + IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) & + forcn(6)%blk(ib,jb)%val(i,j) = 40.0*sign(1.0,forcn(6)%blk(ib,jb)%val(i,j)) + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + + CASE ('MSWX') + + forcn(1)%blk(ib,jb)%val(i,j)=forcn(1)%blk(ib,jb)%val(i,j)+273.15 + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/10800. + IF (forcn(4)%blk(ib,jb)%val(i,j)>1000.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + IF (forcn(2)%blk(ib,jb)%val(i,j)<0.5E-05) & + forcn(2)%blk(ib,jb)%val(i,j) = 0.5E-05 + + CASE ('WFDE5') + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('WFDEI') + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('CLDAS') ! CLDAS forcing + + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600. + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('CMFD') ! CMFD forcing + + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600. + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + CASE ('CMFDv2') ! CMFDv2 forcing + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('CRUJRA') ! CRUJRA forcing + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/21600. + forcn(7)%blk(ib,jb)%val(i,j)=forcn(7)%blk(ib,jb)%val(i,j)/21600. + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('GDAS') ! GDAS forcing + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('JRA55') ! JRA55 forcing + + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/86400.0 !mm/s + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('JRA3Q') ! JRA3Q forcing + + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j) + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('TPMFD') ! TPMFD forcing + + forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600.!convert to mm/s + forcn(3)%blk(ib,jb)%val(i,j)=forcn(3)%blk(ib,jb)%val(i,j)*100. !convert to pa + + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + CASE ('CMIP6') ! CMIP6 forcing + + IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 + + CASE ('IsoGSM') ! IsoGSM forcing + CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & + es,esdT,qsat_tmp,dqsat_tmpdT) + IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN + forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp + ENDIF + + END select + + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE metpreprocess + +END MODULE MOD_UserSpecifiedForcing +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 new file mode 100644 index 0000000000..0f0bb1da03 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 @@ -0,0 +1,2970 @@ +#include + +MODULE MOD_Vars_1DAccFluxes + + USE MOD_Precision +#ifdef DataAssimilation + USE MOD_DA_Vars_TimeVariables + USE MOD_DA_Vars_1DFluxes + USE MOD_Namelist +#endif +#ifdef EXTERNAL_LAKE + USE MOD_Lake_1DAccVars +#endif + + real(r8) :: nac ! number of accumulation + real(r8), allocatable :: nac_ln (:) + real(r8), allocatable :: nac_dt (:) + logical, allocatable :: filter_dt (:) + + real(r8), allocatable :: a_us (:) + real(r8), allocatable :: a_vs (:) + real(r8), allocatable :: a_t (:) + real(r8), allocatable :: a_q (:) + real(r8), allocatable :: a_prc (:) + real(r8), allocatable :: a_prl (:) + real(r8), allocatable :: a_pbot (:) + real(r8), allocatable :: a_frl (:) + real(r8), allocatable :: a_solarin (:) + real(r8), allocatable :: a_hpbl (:) + + real(r8), allocatable :: a_taux (:) + real(r8), allocatable :: a_tauy (:) + real(r8), allocatable :: a_fsena (:) + real(r8), allocatable :: a_lfevpa (:) + real(r8), allocatable :: a_fevpa (:) + real(r8), allocatable :: a_fsenl (:) + real(r8), allocatable :: a_fevpl (:) + real(r8), allocatable :: a_etr (:) + real(r8), allocatable :: a_fseng (:) + real(r8), allocatable :: a_fevpg (:) + real(r8), allocatable :: a_fgrnd (:) + real(r8), allocatable :: a_sabvsun (:) + real(r8), allocatable :: a_sabvsha (:) + real(r8), allocatable :: a_sabg (:) + real(r8), allocatable :: a_olrg (:) + real(r8), allocatable :: a_rnet (:) + real(r8), allocatable :: a_xerr (:) + real(r8), allocatable :: a_zerr (:) + real(r8), allocatable :: a_rsur (:) + real(r8), allocatable :: a_rsur_se (:) + real(r8), allocatable :: a_rsur_ie (:) + real(r8), allocatable :: a_rsub (:) + real(r8), allocatable :: a_rnof (:) +#ifdef CatchLateralFlow + real(r8), allocatable :: a_xwsur (:) + real(r8), allocatable :: a_xwsub (:) + real(r8), allocatable :: a_fldarea (:) +#endif + real(r8), allocatable :: a_qintr (:) + real(r8), allocatable :: a_qinfl (:) + real(r8), allocatable :: a_qdrip (:) + real(r8), allocatable :: a_rstfacsun (:) + real(r8), allocatable :: a_rstfacsha (:) + real(r8), allocatable :: a_gssun (:) + real(r8), allocatable :: a_gssha (:) + real(r8), allocatable :: a_rss (:) + real(r8), allocatable :: a_wdsrf (:) + real(r8), allocatable :: a_zwt (:) + real(r8), allocatable :: a_wa (:) + real(r8), allocatable :: a_wat (:) + real(r8), allocatable :: a_wetwat (:) + real(r8), allocatable :: a_assim (:) + real(r8), allocatable :: a_respc (:) + real(r8), allocatable :: a_assimsun (:) + real(r8), allocatable :: a_assimsha (:) + real(r8), allocatable :: a_etrsun (:) + real(r8), allocatable :: a_etrsha (:) + + real(r8), allocatable :: a_qcharge (:) + + real(r8), allocatable :: a_t_grnd (:) + real(r8), allocatable :: a_tleaf (:) + real(r8), allocatable :: a_ldew (:) + real(r8), allocatable :: a_ldew_rain (:) + real(r8), allocatable :: a_ldew_snow (:) + real(r8), allocatable :: a_scv (:) + real(r8), allocatable :: a_snowdp (:) + real(r8), allocatable :: a_fsno (:) + real(r8), allocatable :: a_frcsat (:) + real(r8), allocatable :: a_sigf (:) + real(r8), allocatable :: a_green (:) + real(r8), allocatable :: a_lai (:) + real(r8), allocatable :: a_laisun (:) + real(r8), allocatable :: a_laisha (:) + real(r8), allocatable :: a_sai (:) + real(r8), allocatable :: a_alb (:,:,:) + +#ifdef HYPERSPECTRAL + real(r8), allocatable :: a_alb_hires (:,:,:) + real(r8), allocatable :: a_reflectance_out (:,:,:) + real(r8), allocatable :: a_transmittance_out (:,:,:) +#endif + real(r8), allocatable :: a_emis (:) + real(r8), allocatable :: a_z0m (:) + real(r8), allocatable :: a_trad (:) + real(r8), allocatable :: a_tref (:) + real(r8), allocatable :: a_t2m_wmo (:) + real(r8), allocatable :: a_qref (:) + real(r8), allocatable :: a_rain (:) + real(r8), allocatable :: a_snow (:) + + real(r8), allocatable :: a_o3uptakesun(:) + real(r8), allocatable :: a_o3uptakesha(:) + +#ifdef DataAssimilation + real(r8), allocatable :: a_h2osoi_ens (:,:,:) + real(r8), allocatable :: a_t_brt_smap_ens (:,:,:) + real(r8), allocatable :: a_t_brt_fy3d_ens (:,:,:) + real(r8), allocatable :: a_t_brt_smap (:,:) + real(r8), allocatable :: a_t_brt_fy3d (:,:) + real(r8), allocatable :: a_wliq_soisno_ens(:,:,:) + real(r8), allocatable :: a_wice_soisno_ens(:,:,:) + real(r8), allocatable :: a_t_soisno_ens (:,:,:) +#endif + +#ifdef URBAN_MODEL + real(r8), allocatable :: a_t_room (:) !temperature of inner building [K] + real(r8), allocatable :: a_tafu (:) !temperature of outer building [K] + real(r8), allocatable :: a_fhac (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: a_fwst (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: a_fach (:) !flux from inner and outer air exchange [W/m2] + real(r8), allocatable :: a_fahe (:) !flux from metabolic and vehicle [W/m2] + real(r8), allocatable :: a_fhah (:) !sensible flux from heating [W/m2] + real(r8), allocatable :: a_vehc (:) !flux from vehicle [W/m2] + real(r8), allocatable :: a_meta (:) !flux from metabolic [W/m2] + + real(r8), allocatable :: a_senroof (:) !sensible heat flux from roof [W/m2] + real(r8), allocatable :: a_senwsun (:) !sensible heat flux from sunlit wall [W/m2] + real(r8), allocatable :: a_senwsha (:) !sensible heat flux from shaded wall [W/m2] + real(r8), allocatable :: a_sengimp (:) !sensible heat flux from impervious road [W/m2] + real(r8), allocatable :: a_sengper (:) !sensible heat flux from pervious road [W/m2] + real(r8), allocatable :: a_senurbl (:) !sensible heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: a_lfevproof (:) !latent heat flux from roof [W/m2] + real(r8), allocatable :: a_lfevpgimp (:) !latent heat flux from impervious road [W/m2] + real(r8), allocatable :: a_lfevpgper (:) !latent heat flux from pervious road [W/m2] + real(r8), allocatable :: a_lfevpurbl (:) !latent heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: a_troof (:) !temperature of roof [K] + real(r8), allocatable :: a_twall (:) !temperature of wall [K] +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + real(r8), allocatable :: a_lai_enftemp (:) !1 + real(r8), allocatable :: a_lai_enfboreal (:) !2 + real(r8), allocatable :: a_lai_dnfboreal (:) !3 + real(r8), allocatable :: a_lai_ebftrop (:) !4 + real(r8), allocatable :: a_lai_ebftemp (:) !5 + real(r8), allocatable :: a_lai_dbftrop (:) !6 + real(r8), allocatable :: a_lai_dbftemp (:) !7 + real(r8), allocatable :: a_lai_dbfboreal (:) !8 + real(r8), allocatable :: a_lai_ebstemp (:) !9 + real(r8), allocatable :: a_lai_dbstemp (:) !10 + real(r8), allocatable :: a_lai_dbsboreal (:) !11 + real(r8), allocatable :: a_lai_c3arcgrass (:) !12 + real(r8), allocatable :: a_lai_c3grass (:) !13 + real(r8), allocatable :: a_lai_c4grass (:) !14 +#endif + +#ifdef BGC + real(r8), allocatable :: a_leafc (:) + real(r8), allocatable :: a_leafc_storage (:) + real(r8), allocatable :: a_leafc_xfer (:) + real(r8), allocatable :: a_frootc (:) + real(r8), allocatable :: a_frootc_storage (:) + real(r8), allocatable :: a_frootc_xfer (:) + real(r8), allocatable :: a_livestemc (:) + real(r8), allocatable :: a_livestemc_storage (:) + real(r8), allocatable :: a_livestemc_xfer (:) + real(r8), allocatable :: a_deadstemc (:) + real(r8), allocatable :: a_deadstemc_storage (:) + real(r8), allocatable :: a_deadstemc_xfer (:) + real(r8), allocatable :: a_livecrootc (:) + real(r8), allocatable :: a_livecrootc_storage (:) + real(r8), allocatable :: a_livecrootc_xfer (:) + real(r8), allocatable :: a_deadcrootc (:) + real(r8), allocatable :: a_deadcrootc_storage (:) + real(r8), allocatable :: a_deadcrootc_xfer (:) + real(r8), allocatable :: a_grainc (:) + real(r8), allocatable :: a_grainc_storage (:) + real(r8), allocatable :: a_grainc_xfer (:) + real(r8), allocatable :: a_leafn (:) + real(r8), allocatable :: a_leafn_storage (:) + real(r8), allocatable :: a_leafn_xfer (:) + real(r8), allocatable :: a_frootn (:) + real(r8), allocatable :: a_frootn_storage (:) + real(r8), allocatable :: a_frootn_xfer (:) + real(r8), allocatable :: a_livestemn (:) + real(r8), allocatable :: a_livestemn_storage (:) + real(r8), allocatable :: a_livestemn_xfer (:) + real(r8), allocatable :: a_deadstemn (:) + real(r8), allocatable :: a_deadstemn_storage (:) + real(r8), allocatable :: a_deadstemn_xfer (:) + real(r8), allocatable :: a_livecrootn (:) + real(r8), allocatable :: a_livecrootn_storage (:) + real(r8), allocatable :: a_livecrootn_xfer (:) + real(r8), allocatable :: a_deadcrootn (:) + real(r8), allocatable :: a_deadcrootn_storage (:) + real(r8), allocatable :: a_deadcrootn_xfer (:) + real(r8), allocatable :: a_grainn (:) + real(r8), allocatable :: a_grainn_storage (:) + real(r8), allocatable :: a_grainn_xfer (:) + real(r8), allocatable :: a_retransn (:) + real(r8), allocatable :: a_gpp (:) + real(r8), allocatable :: a_downreg (:) + real(r8), allocatable :: a_ar (:) + real(r8), allocatable :: a_cwdprod (:) + real(r8), allocatable :: a_cwddecomp (:) + real(r8), allocatable :: a_hr (:) + real(r8), allocatable :: a_fpg (:) + real(r8), allocatable :: a_fpi (:) + real(r8), allocatable :: a_totvegc (:) + real(r8), allocatable :: a_totlitc (:) + real(r8), allocatable :: a_totcwdc (:) + real(r8), allocatable :: a_totsomc (:) + real(r8), allocatable :: a_totcolc (:) + real(r8), allocatable :: a_totvegn (:) + real(r8), allocatable :: a_totlitn (:) + real(r8), allocatable :: a_totcwdn (:) + real(r8), allocatable :: a_totsomn (:) + real(r8), allocatable :: a_totcoln (:) + real(r8), allocatable :: a_gpp_enftemp (:) !1 + real(r8), allocatable :: a_gpp_enfboreal (:) !2 + real(r8), allocatable :: a_gpp_dnfboreal (:) !3 + real(r8), allocatable :: a_gpp_ebftrop (:) !4 + real(r8), allocatable :: a_gpp_ebftemp (:) !5 + real(r8), allocatable :: a_gpp_dbftrop (:) !6 + real(r8), allocatable :: a_gpp_dbftemp (:) !7 + real(r8), allocatable :: a_gpp_dbfboreal (:) !8 + real(r8), allocatable :: a_gpp_ebstemp (:) !9 + real(r8), allocatable :: a_gpp_dbstemp (:) !10 + real(r8), allocatable :: a_gpp_dbsboreal (:) !11 + real(r8), allocatable :: a_gpp_c3arcgrass (:) !12 + real(r8), allocatable :: a_gpp_c3grass (:) !13 + real(r8), allocatable :: a_gpp_c4grass (:) !14 + real(r8), allocatable :: a_npp_enftemp (:) !1 + real(r8), allocatable :: a_npp_enfboreal (:) !2 + real(r8), allocatable :: a_npp_dnfboreal (:) !3 + real(r8), allocatable :: a_npp_ebftrop (:) !4 + real(r8), allocatable :: a_npp_ebftemp (:) !5 + real(r8), allocatable :: a_npp_dbftrop (:) !6 + real(r8), allocatable :: a_npp_dbftemp (:) !7 + real(r8), allocatable :: a_npp_dbfboreal (:) !8 + real(r8), allocatable :: a_npp_ebstemp (:) !9 + real(r8), allocatable :: a_npp_dbstemp (:) !10 + real(r8), allocatable :: a_npp_dbsboreal (:) !11 + real(r8), allocatable :: a_npp_c3arcgrass (:) !12 + real(r8), allocatable :: a_npp_c3grass (:) !13 + real(r8), allocatable :: a_npp_c4grass (:) !14 + real(r8), allocatable :: a_npptoleafc_enftemp (:) !1 + real(r8), allocatable :: a_npptoleafc_enfboreal (:) !2 + real(r8), allocatable :: a_npptoleafc_dnfboreal (:) !3 + real(r8), allocatable :: a_npptoleafc_ebftrop (:) !4 + real(r8), allocatable :: a_npptoleafc_ebftemp (:) !5 + real(r8), allocatable :: a_npptoleafc_dbftrop (:) !6 + real(r8), allocatable :: a_npptoleafc_dbftemp (:) !7 + real(r8), allocatable :: a_npptoleafc_dbfboreal (:) !8 + real(r8), allocatable :: a_npptoleafc_ebstemp (:) !9 + real(r8), allocatable :: a_npptoleafc_dbstemp (:) !10 + real(r8), allocatable :: a_npptoleafc_dbsboreal (:) !11 + real(r8), allocatable :: a_npptoleafc_c3arcgrass (:) !12 + real(r8), allocatable :: a_npptoleafc_c3grass (:) !13 + real(r8), allocatable :: a_npptoleafc_c4grass (:) !14 + real(r8), allocatable :: a_leafc_enftemp (:) !1 + real(r8), allocatable :: a_leafc_enfboreal (:) !2 + real(r8), allocatable :: a_leafc_dnfboreal (:) !3 + real(r8), allocatable :: a_leafc_ebftrop (:) !4 + real(r8), allocatable :: a_leafc_ebftemp (:) !5 + real(r8), allocatable :: a_leafc_dbftrop (:) !6 + real(r8), allocatable :: a_leafc_dbftemp (:) !7 + real(r8), allocatable :: a_leafc_dbfboreal (:) !8 + real(r8), allocatable :: a_leafc_ebstemp (:) !9 + real(r8), allocatable :: a_leafc_dbstemp (:) !10 + real(r8), allocatable :: a_leafc_dbsboreal (:) !11 + real(r8), allocatable :: a_leafc_c3arcgrass (:) !12 + real(r8), allocatable :: a_leafc_c3grass (:) !13 + real(r8), allocatable :: a_leafc_c4grass (:) !14 + real(r8), allocatable :: a_O2_DECOMP_DEPTH_UNSAT (:,:) + real(r8), allocatable :: a_CONC_O2_UNSAT (:,:) +#ifdef CROP + real(r8), allocatable :: a_pdcorn (:) + real(r8), allocatable :: a_pdswheat (:) + real(r8), allocatable :: a_pdwwheat (:) + real(r8), allocatable :: a_pdsoybean (:) + real(r8), allocatable :: a_pdcotton (:) + real(r8), allocatable :: a_pdrice1 (:) + real(r8), allocatable :: a_pdrice2 (:) + real(r8), allocatable :: a_pdsugarcane (:) + real(r8), allocatable :: a_plantdate (:) + real(r8), allocatable :: a_manunitro (:) + real(r8), allocatable :: a_fertnitro_corn (:) + real(r8), allocatable :: a_fertnitro_swheat (:) + real(r8), allocatable :: a_fertnitro_wwheat (:) + real(r8), allocatable :: a_fertnitro_soybean (:) + real(r8), allocatable :: a_fertnitro_cotton (:) + real(r8), allocatable :: a_fertnitro_rice1 (:) + real(r8), allocatable :: a_fertnitro_rice2 (:) + real(r8), allocatable :: a_fertnitro_sugarcane (:) + real(r8), allocatable :: a_irrig_method_corn (:) + real(r8), allocatable :: a_irrig_method_swheat (:) + real(r8), allocatable :: a_irrig_method_wwheat (:) + real(r8), allocatable :: a_irrig_method_soybean (:) + real(r8), allocatable :: a_irrig_method_cotton (:) + real(r8), allocatable :: a_irrig_method_rice1 (:) + real(r8), allocatable :: a_irrig_method_rice2 (:) + real(r8), allocatable :: a_irrig_method_sugarcane(:) + + real(r8), allocatable :: a_cphase (:) + real(r8), allocatable :: a_gddplant (:) + real(r8), allocatable :: a_gddmaturity (:) + real(r8), allocatable :: a_vf (:) + real(r8), allocatable :: a_hui (:) + real(r8), allocatable :: a_cropprod1c (:) + real(r8), allocatable :: a_cropprod1c_loss (:) + real(r8), allocatable :: a_cropseedc_deficit (:) + real(r8), allocatable :: a_grainc_to_cropprodc (:) + real(r8), allocatable :: a_grainc_to_seed (:) + real(r8), allocatable :: a_fert_to_sminn (:) + + real(r8), allocatable :: a_sum_irrig (:) + real(r8), allocatable :: a_sum_deficit_irrig (:) + real(r8), allocatable :: a_sum_irrig_count (:) + real(r8), allocatable :: a_waterstorage (:) + real(r8), allocatable :: a_groundwater_demand (:) + real(r8), allocatable :: a_groundwater_supply (:) + real(r8), allocatable :: a_reservoirriver_demand(:) + real(r8), allocatable :: a_reservoirriver_supply(:) + real(r8), allocatable :: a_reservoir_supply (:) + real(r8), allocatable :: a_river_supply (:) + real(r8), allocatable :: a_runoff_supply (:) +#endif + real(r8), allocatable :: a_ndep_to_sminn (:) + real(r8), allocatable :: a_abm (:) + real(r8), allocatable :: a_gdp (:) + real(r8), allocatable :: a_peatf (:) + real(r8), allocatable :: a_hdm (:) + real(r8), allocatable :: a_lnfm (:) + real(r8), allocatable :: a_leafcCap (:) + real(r8), allocatable :: a_leafc_storageCap (:) + real(r8), allocatable :: a_leafc_xferCap (:) + real(r8), allocatable :: a_frootcCap (:) + real(r8), allocatable :: a_frootc_storageCap (:) + real(r8), allocatable :: a_frootc_xferCap (:) + real(r8), allocatable :: a_livestemcCap (:) + real(r8), allocatable :: a_livestemc_storageCap (:) + real(r8), allocatable :: a_livestemc_xferCap (:) + real(r8), allocatable :: a_deadstemcCap (:) + real(r8), allocatable :: a_deadstemc_storageCap (:) + real(r8), allocatable :: a_deadstemc_xferCap (:) + real(r8), allocatable :: a_livecrootcCap (:) + real(r8), allocatable :: a_livecrootc_storageCap (:) + real(r8), allocatable :: a_livecrootc_xferCap (:) + real(r8), allocatable :: a_deadcrootcCap (:) + real(r8), allocatable :: a_deadcrootc_storageCap (:) + real(r8), allocatable :: a_deadcrootc_xferCap (:) + real(r8), allocatable :: a_leafnCap (:) + real(r8), allocatable :: a_leafn_storageCap (:) + real(r8), allocatable :: a_leafn_xferCap (:) + real(r8), allocatable :: a_frootnCap (:) + real(r8), allocatable :: a_frootn_storageCap (:) + real(r8), allocatable :: a_frootn_xferCap (:) + real(r8), allocatable :: a_livestemnCap (:) + real(r8), allocatable :: a_livestemn_storageCap (:) + real(r8), allocatable :: a_livestemn_xferCap (:) + real(r8), allocatable :: a_deadstemnCap (:) + real(r8), allocatable :: a_deadstemn_storageCap (:) + real(r8), allocatable :: a_deadstemn_xferCap (:) + real(r8), allocatable :: a_livecrootnCap (:) + real(r8), allocatable :: a_livecrootn_storageCap (:) + real(r8), allocatable :: a_livecrootn_xferCap (:) + real(r8), allocatable :: a_deadcrootnCap (:) + real(r8), allocatable :: a_deadcrootn_storageCap (:) + real(r8), allocatable :: a_deadcrootn_xferCap (:) +#endif +! Ozone stress variables + real(r8), allocatable :: a_ozone (:) +! End ozone stress variables + + real(r8), allocatable :: a_t_soisno (:,:) + real(r8), allocatable :: a_wliq_soisno (:,:) + real(r8), allocatable :: a_wice_soisno (:,:) + real(r8), allocatable :: a_h2osoi (:,:) + real(r8), allocatable :: a_qlayer (:,:) + real(r8), allocatable :: a_lake_deficit (:) + real(r8), allocatable :: a_rootr (:,:) + real(r8), allocatable :: a_BD_all (:,:) + real(r8), allocatable :: a_wfc (:,:) + real(r8), allocatable :: a_OM_density (:,:) +!Plant Hydraulic parameters + real(r8), allocatable :: a_vegwp (:,:) +!END plant hydraulic parameters + real(r8), allocatable :: a_dz_lake (:,:) + real(r8), allocatable :: a_t_lake (:,:) + real(r8), allocatable :: a_lake_icefrac(:,:) + +#ifdef BGC + real(r8), allocatable :: a_litr1c_vr (:,:) + real(r8), allocatable :: a_litr2c_vr (:,:) + real(r8), allocatable :: a_litr3c_vr (:,:) + real(r8), allocatable :: a_soil1c_vr (:,:) + real(r8), allocatable :: a_soil2c_vr (:,:) + real(r8), allocatable :: a_soil3c_vr (:,:) + real(r8), allocatable :: a_cwdc_vr (:,:) + real(r8), allocatable :: a_litr1n_vr (:,:) + real(r8), allocatable :: a_litr2n_vr (:,:) + real(r8), allocatable :: a_litr3n_vr (:,:) + real(r8), allocatable :: a_soil1n_vr (:,:) + real(r8), allocatable :: a_soil2n_vr (:,:) + real(r8), allocatable :: a_soil3n_vr (:,:) + real(r8), allocatable :: a_cwdn_vr (:,:) + real(r8), allocatable :: a_totsoiln_vr (:,:) + real(r8), allocatable :: a_litr1cCap_vr(:,:) + real(r8), allocatable :: a_litr2cCap_vr(:,:) + real(r8), allocatable :: a_litr3cCap_vr(:,:) + real(r8), allocatable :: a_soil1cCap_vr(:,:) + real(r8), allocatable :: a_soil2cCap_vr(:,:) + real(r8), allocatable :: a_soil3cCap_vr(:,:) + real(r8), allocatable :: a_cwdcCap_vr (:,:) + real(r8), allocatable :: a_litr1nCap_vr(:,:) + real(r8), allocatable :: a_litr2nCap_vr(:,:) + real(r8), allocatable :: a_litr3nCap_vr(:,:) + real(r8), allocatable :: a_soil1nCap_vr(:,:) + real(r8), allocatable :: a_soil2nCap_vr(:,:) + real(r8), allocatable :: a_soil3nCap_vr(:,:) + real(r8), allocatable :: a_cwdnCap_vr (:,:) + real(r8), allocatable :: a_t_scalar (:,:) + real(r8), allocatable :: a_w_scalar (:,:) + real(r8), allocatable :: a_sminn_vr (:,:) + real(r8), allocatable :: decomp_vr_tmp (:,:) +#endif + + real(r8), allocatable :: a_ustar (:) + real(r8), allocatable :: a_ustar2 (:) + real(r8), allocatable :: a_tstar (:) + real(r8), allocatable :: a_qstar (:) + real(r8), allocatable :: a_zol (:) + real(r8), allocatable :: a_rib (:) + real(r8), allocatable :: a_fm (:) + real(r8), allocatable :: a_fh (:) + real(r8), allocatable :: a_fq (:) + + real(r8), allocatable :: a_us10m (:) + real(r8), allocatable :: a_vs10m (:) + real(r8), allocatable :: a_fm10m (:) + + real(r8), allocatable :: a_sr (:) + real(r8), allocatable :: a_solvd (:) + real(r8), allocatable :: a_solvi (:) + real(r8), allocatable :: a_solnd (:) + real(r8), allocatable :: a_solni (:) + real(r8), allocatable :: a_srvd (:) + real(r8), allocatable :: a_srvi (:) + real(r8), allocatable :: a_srnd (:) + real(r8), allocatable :: a_srni (:) + real(r8), allocatable :: a_solvdln (:) + real(r8), allocatable :: a_solviln (:) + real(r8), allocatable :: a_solndln (:) + real(r8), allocatable :: a_solniln (:) + real(r8), allocatable :: a_srvdln (:) + real(r8), allocatable :: a_srviln (:) + real(r8), allocatable :: a_srndln (:) + real(r8), allocatable :: a_srniln (:) +#ifdef HYPERSPECTRAL + real(r8), allocatable :: a_sol_dir_ln_hires(:,:) + real(r8), allocatable :: a_sol_dif_ln_hires(:,:) + real(r8), allocatable :: a_sr_dir_ln_hires (:,:) + real(r8), allocatable :: a_sr_dif_ln_hires (:,:) +#endif + real(r8), allocatable :: a_sensors (:,:) + + PUBLIC :: allocate_acc_fluxes + PUBLIC :: deallocate_acc_fluxes + PUBLIC :: flush_acc_fluxes + PUBLIC :: accumulate_fluxes + +CONTAINS + + SUBROUTINE allocate_acc_fluxes + + USE MOD_SPMD_Task + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_LandUrban, only: numurban + USE MOD_Vars_1DFluxes, only: nsensor +#ifdef CROP + USE MOD_LandCrop +#endif + USE MOD_Vars_Global + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + allocate (a_us (numpatch)) + allocate (a_vs (numpatch)) + allocate (a_t (numpatch)) + allocate (a_q (numpatch)) + allocate (a_prc (numpatch)) + allocate (a_prl (numpatch)) + allocate (a_pbot (numpatch)) + allocate (a_frl (numpatch)) + allocate (a_solarin (numpatch)) + allocate (a_hpbl (numpatch)) + + allocate (a_taux (numpatch)) + allocate (a_tauy (numpatch)) + allocate (a_fsena (numpatch)) + allocate (a_lfevpa (numpatch)) + allocate (a_fevpa (numpatch)) + allocate (a_fsenl (numpatch)) + allocate (a_fevpl (numpatch)) + allocate (a_etr (numpatch)) + allocate (a_fseng (numpatch)) + allocate (a_fevpg (numpatch)) + allocate (a_fgrnd (numpatch)) + allocate (a_sabvsun (numpatch)) + allocate (a_sabvsha (numpatch)) + allocate (a_sabg (numpatch)) + allocate (a_olrg (numpatch)) + allocate (a_rnet (numpatch)) + allocate (a_xerr (numpatch)) + allocate (a_zerr (numpatch)) + allocate (a_rsur (numpatch)) + allocate (a_rsur_se (numpatch)) + allocate (a_rsur_ie (numpatch)) + allocate (a_rsub (numpatch)) + allocate (a_rnof (numpatch)) +#ifdef CatchLateralFlow + allocate (a_xwsur (numpatch)) + allocate (a_xwsub (numpatch)) + allocate (a_fldarea (numpatch)) +#endif + allocate (a_qintr (numpatch)) + allocate (a_qinfl (numpatch)) + allocate (a_qdrip (numpatch)) + allocate (a_rstfacsun (numpatch)) + allocate (a_rstfacsha (numpatch)) + allocate (a_gssun (numpatch)) + allocate (a_gssha (numpatch)) + allocate (a_rss (numpatch)) + allocate (a_wdsrf (numpatch)) + + allocate (a_zwt (numpatch)) + allocate (a_wa (numpatch)) + allocate (a_wat (numpatch)) + allocate (a_wetwat (numpatch)) + allocate (a_assim (numpatch)) + allocate (a_respc (numpatch)) + + allocate (a_assimsun (numpatch)) + allocate (a_assimsha (numpatch)) + allocate (a_etrsun (numpatch)) + allocate (a_etrsha (numpatch)) + + allocate (a_qcharge (numpatch)) + + allocate (a_t_grnd (numpatch)) + allocate (a_tleaf (numpatch)) + allocate (a_ldew_rain (numpatch)) + allocate (a_ldew_snow (numpatch)) + allocate (a_ldew (numpatch)) + allocate (a_scv (numpatch)) + allocate (a_snowdp (numpatch)) + allocate (a_fsno (numpatch)) + allocate (a_frcsat (numpatch)) + allocate (a_sigf (numpatch)) + allocate (a_green (numpatch)) + allocate (a_lai (numpatch)) + allocate (a_laisun (numpatch)) + allocate (a_laisha (numpatch)) + allocate (a_sai (numpatch)) + + allocate (a_alb (2 ,2,numpatch)) +#ifdef HYPERSPECTRAL + allocate (a_alb_hires (211,2,numpatch)) + allocate (a_reflectance_out (211,16,numpatch)) + allocate (a_transmittance_out(211,16,numpatch)) +#endif + allocate (a_emis (numpatch)) + allocate (a_z0m (numpatch)) + allocate (a_trad (numpatch)) + allocate (a_tref (numpatch)) + allocate (a_t2m_wmo (numpatch)) + allocate (a_qref (numpatch)) + allocate (a_rain (numpatch)) + allocate (a_snow (numpatch)) + + allocate (a_o3uptakesun(numpatch)) + allocate (a_o3uptakesha(numpatch)) + +#ifdef DataAssimilation + allocate (a_h2osoi_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)) + allocate (a_t_brt_smap_ens (2,DEF_DA_ENS_NUM,numpatch)) + allocate (a_t_brt_fy3d_ens (2,DEF_DA_ENS_NUM,numpatch)) + allocate (a_t_brt_smap (2,numpatch)) + allocate (a_t_brt_fy3d (2,numpatch)) + allocate (a_wliq_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)) + allocate (a_wice_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)) + allocate (a_t_soisno_ens (maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)) +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + allocate (a_t_room (numurban)) + allocate (a_tafu (numurban)) + allocate (a_fhac (numurban)) + allocate (a_fwst (numurban)) + allocate (a_fach (numurban)) + allocate (a_fahe (numurban)) + allocate (a_fhah (numurban)) + allocate (a_vehc (numurban)) + allocate (a_meta (numurban)) + + allocate (a_senroof (numurban)) + allocate (a_senwsun (numurban)) + allocate (a_senwsha (numurban)) + allocate (a_sengimp (numurban)) + allocate (a_sengper (numurban)) + allocate (a_senurbl (numurban)) + + allocate (a_lfevproof (numurban)) + allocate (a_lfevpgimp (numurban)) + allocate (a_lfevpgper (numurban)) + allocate (a_lfevpurbl (numurban)) + + allocate (a_troof (numurban)) + allocate (a_twall (numurban)) + ENDIF +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + allocate (a_lai_enftemp (numpatch)) + allocate (a_lai_enfboreal (numpatch)) + allocate (a_lai_dnfboreal (numpatch)) + allocate (a_lai_ebftrop (numpatch)) + allocate (a_lai_ebftemp (numpatch)) + allocate (a_lai_dbftrop (numpatch)) + allocate (a_lai_dbftemp (numpatch)) + allocate (a_lai_dbfboreal (numpatch)) + allocate (a_lai_ebstemp (numpatch)) + allocate (a_lai_dbstemp (numpatch)) + allocate (a_lai_dbsboreal (numpatch)) + allocate (a_lai_c3arcgrass (numpatch)) + allocate (a_lai_c3grass (numpatch)) + allocate (a_lai_c4grass (numpatch)) +#endif +#ifdef BGC + allocate (a_leafc (numpatch)) + allocate (a_leafc_storage (numpatch)) + allocate (a_leafc_xfer (numpatch)) + allocate (a_frootc (numpatch)) + allocate (a_frootc_storage (numpatch)) + allocate (a_frootc_xfer (numpatch)) + allocate (a_livestemc (numpatch)) + allocate (a_livestemc_storage (numpatch)) + allocate (a_livestemc_xfer (numpatch)) + allocate (a_deadstemc (numpatch)) + allocate (a_deadstemc_storage (numpatch)) + allocate (a_deadstemc_xfer (numpatch)) + allocate (a_livecrootc (numpatch)) + allocate (a_livecrootc_storage (numpatch)) + allocate (a_livecrootc_xfer (numpatch)) + allocate (a_deadcrootc (numpatch)) + allocate (a_deadcrootc_storage (numpatch)) + allocate (a_deadcrootc_xfer (numpatch)) + allocate (a_grainc (numpatch)) + allocate (a_grainc_storage (numpatch)) + allocate (a_grainc_xfer (numpatch)) + allocate (a_leafn (numpatch)) + allocate (a_leafn_storage (numpatch)) + allocate (a_leafn_xfer (numpatch)) + allocate (a_frootn (numpatch)) + allocate (a_frootn_storage (numpatch)) + allocate (a_frootn_xfer (numpatch)) + allocate (a_livestemn (numpatch)) + allocate (a_livestemn_storage (numpatch)) + allocate (a_livestemn_xfer (numpatch)) + allocate (a_deadstemn (numpatch)) + allocate (a_deadstemn_storage (numpatch)) + allocate (a_deadstemn_xfer (numpatch)) + allocate (a_livecrootn (numpatch)) + allocate (a_livecrootn_storage (numpatch)) + allocate (a_livecrootn_xfer (numpatch)) + allocate (a_deadcrootn (numpatch)) + allocate (a_deadcrootn_storage (numpatch)) + allocate (a_deadcrootn_xfer (numpatch)) + allocate (a_grainn (numpatch)) + allocate (a_grainn_storage (numpatch)) + allocate (a_grainn_xfer (numpatch)) + allocate (a_retransn (numpatch)) + allocate (a_gpp (numpatch)) + allocate (a_downreg (numpatch)) + allocate (a_ar (numpatch)) + allocate (a_cwdprod (numpatch)) + allocate (a_cwddecomp (numpatch)) + allocate (a_hr (numpatch)) + allocate (a_fpg (numpatch)) + allocate (a_fpi (numpatch)) + allocate (a_totvegc (numpatch)) + allocate (a_totlitc (numpatch)) + allocate (a_totcwdc (numpatch)) + allocate (a_totsomc (numpatch)) + allocate (a_totcolc (numpatch)) + allocate (a_totvegn (numpatch)) + allocate (a_totlitn (numpatch)) + allocate (a_totcwdn (numpatch)) + allocate (a_totsomn (numpatch)) + allocate (a_totcoln (numpatch)) + allocate (a_gpp_enftemp (numpatch)) !1 + allocate (a_gpp_enfboreal (numpatch)) !2 + allocate (a_gpp_dnfboreal (numpatch)) !3 + allocate (a_gpp_ebftrop (numpatch)) !4 + allocate (a_gpp_ebftemp (numpatch)) !5 + allocate (a_gpp_dbftrop (numpatch)) !6 + allocate (a_gpp_dbftemp (numpatch)) !7 + allocate (a_gpp_dbfboreal (numpatch)) !8 + allocate (a_gpp_ebstemp (numpatch)) !9 + allocate (a_gpp_dbstemp (numpatch)) !10 + allocate (a_gpp_dbsboreal (numpatch)) !11 + allocate (a_gpp_c3arcgrass (numpatch)) !12 + allocate (a_gpp_c3grass (numpatch)) !13 + allocate (a_gpp_c4grass (numpatch)) !14 + allocate (a_npp_enftemp (numpatch)) !1 + allocate (a_npp_enfboreal (numpatch)) !2 + allocate (a_npp_dnfboreal (numpatch)) !3 + allocate (a_npp_ebftrop (numpatch)) !4 + allocate (a_npp_ebftemp (numpatch)) !5 + allocate (a_npp_dbftrop (numpatch)) !6 + allocate (a_npp_dbftemp (numpatch)) !7 + allocate (a_npp_dbfboreal (numpatch)) !8 + allocate (a_npp_ebstemp (numpatch)) !9 + allocate (a_npp_dbstemp (numpatch)) !10 + allocate (a_npp_dbsboreal (numpatch)) !11 + allocate (a_npp_c3arcgrass (numpatch)) !12 + allocate (a_npp_c3grass (numpatch)) !13 + allocate (a_npp_c4grass (numpatch)) !14 + allocate (a_npptoleafc_enftemp (numpatch)) !1 + allocate (a_npptoleafc_enfboreal (numpatch)) !2 + allocate (a_npptoleafc_dnfboreal (numpatch)) !3 + allocate (a_npptoleafc_ebftrop (numpatch)) !4 + allocate (a_npptoleafc_ebftemp (numpatch)) !5 + allocate (a_npptoleafc_dbftrop (numpatch)) !6 + allocate (a_npptoleafc_dbftemp (numpatch)) !7 + allocate (a_npptoleafc_dbfboreal (numpatch)) !8 + allocate (a_npptoleafc_ebstemp (numpatch)) !9 + allocate (a_npptoleafc_dbstemp (numpatch)) !10 + allocate (a_npptoleafc_dbsboreal (numpatch)) !11 + allocate (a_npptoleafc_c3arcgrass (numpatch)) !12 + allocate (a_npptoleafc_c3grass (numpatch)) !13 + allocate (a_npptoleafc_c4grass (numpatch)) !14 + allocate (a_leafc_enftemp (numpatch)) !1 + allocate (a_leafc_enfboreal (numpatch)) !2 + allocate (a_leafc_dnfboreal (numpatch)) !3 + allocate (a_leafc_ebftrop (numpatch)) !4 + allocate (a_leafc_ebftemp (numpatch)) !5 + allocate (a_leafc_dbftrop (numpatch)) !6 + allocate (a_leafc_dbftemp (numpatch)) !7 + allocate (a_leafc_dbfboreal (numpatch)) !8 + allocate (a_leafc_ebstemp (numpatch)) !9 + allocate (a_leafc_dbstemp (numpatch)) !10 + allocate (a_leafc_dbsboreal (numpatch)) !11 + allocate (a_leafc_c3arcgrass (numpatch)) !12 + allocate (a_leafc_c3grass (numpatch)) !13 + allocate (a_leafc_c4grass (numpatch)) !14 + + allocate (a_O2_DECOMP_DEPTH_UNSAT (1:nl_soil,numpatch)) + allocate (a_CONC_O2_UNSAT (1:nl_soil,numpatch)) + +#ifdef CROP + allocate (a_pdcorn (numpatch)) + allocate (a_pdswheat (numpatch)) + allocate (a_pdwwheat (numpatch)) + allocate (a_pdsoybean (numpatch)) + allocate (a_pdcotton (numpatch)) + allocate (a_pdrice1 (numpatch)) + allocate (a_pdrice2 (numpatch)) + allocate (a_pdsugarcane (numpatch)) + allocate (a_plantdate (numpatch)) + allocate (a_manunitro (numpatch)) + allocate (a_fertnitro_corn (numpatch)) + allocate (a_fertnitro_swheat (numpatch)) + allocate (a_fertnitro_wwheat (numpatch)) + allocate (a_fertnitro_soybean (numpatch)) + allocate (a_fertnitro_cotton (numpatch)) + allocate (a_fertnitro_rice1 (numpatch)) + allocate (a_fertnitro_rice2 (numpatch)) + allocate (a_fertnitro_sugarcane(numpatch)) + allocate (a_irrig_method_corn (numpatch)) + allocate (a_irrig_method_swheat (numpatch)) + allocate (a_irrig_method_wwheat (numpatch)) + allocate (a_irrig_method_soybean (numpatch)) + allocate (a_irrig_method_cotton (numpatch)) + allocate (a_irrig_method_rice1 (numpatch)) + allocate (a_irrig_method_rice2 (numpatch)) + allocate (a_irrig_method_sugarcane(numpatch)) + allocate (a_cphase (numpatch)) + allocate (a_hui (numpatch)) + allocate (a_gddmaturity (numpatch)) + allocate (a_gddplant (numpatch)) + allocate (a_vf (numpatch)) + allocate (a_cropprod1c (numpatch)) + allocate (a_cropprod1c_loss (numpatch)) + allocate (a_cropseedc_deficit (numpatch)) + allocate (a_grainc_to_cropprodc(numpatch)) + allocate (a_grainc_to_seed (numpatch)) + allocate (a_fert_to_sminn (numpatch)) + + allocate (a_sum_irrig (numpatch)) + allocate (a_sum_deficit_irrig (numpatch)) + allocate (a_sum_irrig_count (numpatch)) + allocate (a_waterstorage (numpatch)) + allocate (a_groundwater_demand (numpatch)) + allocate (a_groundwater_supply (numpatch)) + allocate (a_reservoirriver_demand(numpatch)) + allocate (a_reservoirriver_supply(numpatch)) + allocate (a_reservoir_supply (numpatch)) + allocate (a_river_supply (numpatch)) + allocate (a_runoff_supply (numpatch)) +#endif + allocate (a_ndep_to_sminn (numpatch)) + + allocate (a_abm (numpatch)) + allocate (a_gdp (numpatch)) + allocate (a_peatf (numpatch)) + allocate (a_hdm (numpatch)) + allocate (a_lnfm (numpatch)) + + allocate (a_leafcCap (numpatch)) + allocate (a_leafc_storageCap (numpatch)) + allocate (a_leafc_xferCap (numpatch)) + allocate (a_frootcCap (numpatch)) + allocate (a_frootc_storageCap (numpatch)) + allocate (a_frootc_xferCap (numpatch)) + allocate (a_livestemcCap (numpatch)) + allocate (a_livestemc_storageCap (numpatch)) + allocate (a_livestemc_xferCap (numpatch)) + allocate (a_deadstemcCap (numpatch)) + allocate (a_deadstemc_storageCap (numpatch)) + allocate (a_deadstemc_xferCap (numpatch)) + allocate (a_livecrootcCap (numpatch)) + allocate (a_livecrootc_storageCap (numpatch)) + allocate (a_livecrootc_xferCap (numpatch)) + allocate (a_deadcrootcCap (numpatch)) + allocate (a_deadcrootc_storageCap (numpatch)) + allocate (a_deadcrootc_xferCap (numpatch)) + allocate (a_leafnCap (numpatch)) + allocate (a_leafn_storageCap (numpatch)) + allocate (a_leafn_xferCap (numpatch)) + allocate (a_frootnCap (numpatch)) + allocate (a_frootn_storageCap (numpatch)) + allocate (a_frootn_xferCap (numpatch)) + allocate (a_livestemnCap (numpatch)) + allocate (a_livestemn_storageCap (numpatch)) + allocate (a_livestemn_xferCap (numpatch)) + allocate (a_deadstemnCap (numpatch)) + allocate (a_deadstemn_storageCap (numpatch)) + allocate (a_deadstemn_xferCap (numpatch)) + allocate (a_livecrootnCap (numpatch)) + allocate (a_livecrootn_storageCap (numpatch)) + allocate (a_livecrootn_xferCap (numpatch)) + allocate (a_deadcrootnCap (numpatch)) + allocate (a_deadcrootn_storageCap (numpatch)) + allocate (a_deadcrootn_xferCap (numpatch)) +#endif +! Ozone stress variables + allocate (a_ozone (numpatch)) +! End ozone stress variables + allocate (a_t_soisno (maxsnl+1:nl_soil,numpatch)) + allocate (a_wliq_soisno (maxsnl+1:nl_soil,numpatch)) + allocate (a_wice_soisno (maxsnl+1:nl_soil,numpatch)) + allocate (a_h2osoi (1:nl_soil, numpatch)) + allocate (a_qlayer (0:nl_soil, numpatch)) + allocate (a_lake_deficit (numpatch)) + allocate (a_rootr (1:nl_soil, numpatch)) + allocate (a_BD_all (1:nl_soil, numpatch)) + allocate (a_wfc (1:nl_soil, numpatch)) + allocate (a_OM_density (1:nl_soil, numpatch)) +!Plant Hydraulic parameters + allocate (a_vegwp (1:nvegwcs, numpatch)) +!End Plant Hydraulic parameters + allocate (a_dz_lake (nl_lake, numpatch)) + allocate (a_t_lake (nl_lake, numpatch)) + allocate (a_lake_icefrac(nl_lake, numpatch)) + +#ifdef BGC + allocate (a_litr1c_vr (1:nl_soil, numpatch)) + allocate (a_litr2c_vr (1:nl_soil, numpatch)) + allocate (a_litr3c_vr (1:nl_soil, numpatch)) + allocate (a_soil1c_vr (1:nl_soil, numpatch)) + allocate (a_soil2c_vr (1:nl_soil, numpatch)) + allocate (a_soil3c_vr (1:nl_soil, numpatch)) + allocate (a_cwdc_vr (1:nl_soil, numpatch)) + allocate (a_litr1n_vr (1:nl_soil, numpatch)) + allocate (a_litr2n_vr (1:nl_soil, numpatch)) + allocate (a_litr3n_vr (1:nl_soil, numpatch)) + allocate (a_soil1n_vr (1:nl_soil, numpatch)) + allocate (a_soil2n_vr (1:nl_soil, numpatch)) + allocate (a_soil3n_vr (1:nl_soil, numpatch)) + allocate (a_cwdn_vr (1:nl_soil, numpatch)) + allocate (a_totsoiln_vr (1:nl_soil, numpatch)) + allocate (a_sminn_vr (1:nl_soil, numpatch)) + allocate (decomp_vr_tmp (1:nl_soil, numpatch)) + + allocate (a_litr1cCap_vr(1:nl_soil, numpatch)) + allocate (a_litr2cCap_vr(1:nl_soil, numpatch)) + allocate (a_litr3cCap_vr(1:nl_soil, numpatch)) + allocate (a_soil1cCap_vr(1:nl_soil, numpatch)) + allocate (a_soil2cCap_vr(1:nl_soil, numpatch)) + allocate (a_soil3cCap_vr(1:nl_soil, numpatch)) + allocate (a_cwdcCap_vr (1:nl_soil, numpatch)) + allocate (a_litr1nCap_vr(1:nl_soil, numpatch)) + allocate (a_litr2nCap_vr(1:nl_soil, numpatch)) + allocate (a_litr3nCap_vr(1:nl_soil, numpatch)) + allocate (a_soil1nCap_vr(1:nl_soil, numpatch)) + allocate (a_soil2nCap_vr(1:nl_soil, numpatch)) + allocate (a_soil3nCap_vr(1:nl_soil, numpatch)) + allocate (a_cwdnCap_vr (1:nl_soil, numpatch)) + allocate (a_t_scalar (1:nl_soil, numpatch)) + allocate (a_w_scalar (1:nl_soil, numpatch)) +#endif + + allocate (a_ustar (numpatch)) + allocate (a_ustar2 (numpatch)) + allocate (a_tstar (numpatch)) + allocate (a_qstar (numpatch)) + allocate (a_zol (numpatch)) + allocate (a_rib (numpatch)) + allocate (a_fm (numpatch)) + allocate (a_fh (numpatch)) + allocate (a_fq (numpatch)) + + allocate (a_us10m (numpatch)) + allocate (a_vs10m (numpatch)) + allocate (a_fm10m (numpatch)) + + allocate (a_sr (numpatch)) + allocate (a_solvd (numpatch)) + allocate (a_solvi (numpatch)) + allocate (a_solnd (numpatch)) + allocate (a_solni (numpatch)) + allocate (a_srvd (numpatch)) + allocate (a_srvi (numpatch)) + allocate (a_srnd (numpatch)) + allocate (a_srni (numpatch)) + allocate (a_solvdln (numpatch)) + allocate (a_solviln (numpatch)) + allocate (a_solndln (numpatch)) + allocate (a_solniln (numpatch)) + allocate (a_srvdln (numpatch)) + allocate (a_srviln (numpatch)) + allocate (a_srndln (numpatch)) + allocate (a_srniln (numpatch)) +#ifdef HYPERSPECTRAL + allocate (a_sol_dir_ln_hires(211, numpatch)) + allocate (a_sol_dif_ln_hires(211, numpatch)) + allocate (a_sr_dir_ln_hires (211, numpatch)) + allocate (a_sr_dif_ln_hires (211, numpatch)) +#endif + allocate (a_sensors (nsensor,numpatch)) + + allocate (nac_ln (numpatch)) + allocate (nac_dt (numpatch)) + allocate (filter_dt (numpatch)) + + ENDIF + ENDIF + +#ifdef EXTERNAL_LAKE + CALL allocate_LakeAccVars +#endif + + IF (p_is_worker) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + ENDIF + + END SUBROUTINE allocate_acc_fluxes + + SUBROUTINE deallocate_acc_fluxes () + + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + USE MOD_LandUrban, only: numurban + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + deallocate (a_us ) + deallocate (a_vs ) + deallocate (a_t ) + deallocate (a_q ) + deallocate (a_prc ) + deallocate (a_prl ) + deallocate (a_pbot ) + deallocate (a_frl ) + deallocate (a_solarin) + deallocate (a_hpbl ) + + deallocate (a_taux ) + deallocate (a_tauy ) + deallocate (a_fsena ) + deallocate (a_lfevpa ) + deallocate (a_fevpa ) + deallocate (a_fsenl ) + deallocate (a_fevpl ) + deallocate (a_etr ) + deallocate (a_fseng ) + deallocate (a_fevpg ) + deallocate (a_fgrnd ) + deallocate (a_sabvsun ) + deallocate (a_sabvsha ) + deallocate (a_sabg ) + deallocate (a_olrg ) + deallocate (a_rnet ) + deallocate (a_xerr ) + deallocate (a_zerr ) + deallocate (a_rsur ) + deallocate (a_rsur_se ) + deallocate (a_rsur_ie ) + deallocate (a_rsub ) + deallocate (a_rnof ) +#ifdef CatchLateralFlow + deallocate (a_xwsur ) + deallocate (a_xwsub ) + deallocate (a_fldarea ) +#endif + deallocate (a_qintr ) + deallocate (a_qinfl ) + deallocate (a_qdrip ) + deallocate (a_rstfacsun ) + deallocate (a_rstfacsha ) + deallocate (a_gssun ) + deallocate (a_gssha ) + deallocate (a_rss ) + deallocate (a_wdsrf ) + + deallocate (a_zwt ) + deallocate (a_wa ) + deallocate (a_wat ) + deallocate (a_wetwat ) + deallocate (a_assim ) + deallocate (a_respc ) + + deallocate (a_assimsun ) !1 + deallocate (a_assimsha ) !1 + deallocate (a_etrsun ) !1 + deallocate (a_etrsha ) !1 + + deallocate (a_qcharge ) + + deallocate (a_t_grnd ) + deallocate (a_tleaf ) + deallocate (a_ldew_rain ) + deallocate (a_ldew_snow ) + deallocate (a_ldew ) + deallocate (a_scv ) + deallocate (a_snowdp ) + deallocate (a_fsno ) + deallocate (a_frcsat ) + deallocate (a_sigf ) + deallocate (a_green ) + deallocate (a_lai ) + deallocate (a_laisun ) + deallocate (a_laisha ) + deallocate (a_sai ) + + deallocate (a_alb ) +#ifdef HYPERSPECTRAL + deallocate (a_alb_hires ) + deallocate (a_reflectance_out ) + deallocate (a_transmittance_out) +#endif + + deallocate (a_emis ) + deallocate (a_z0m ) + deallocate (a_trad ) + deallocate (a_tref ) + deallocate (a_t2m_wmo ) + deallocate (a_qref ) + deallocate (a_rain ) + deallocate (a_snow ) + + deallocate (a_o3uptakesun) + deallocate (a_o3uptakesha) + +#ifdef DataAssimilation + deallocate (a_h2osoi_ens ) + deallocate (a_t_brt_smap_ens ) + deallocate (a_t_brt_fy3d_ens ) + deallocate (a_t_brt_fy3d ) + deallocate (a_t_brt_smap ) + deallocate (a_wliq_soisno_ens) + deallocate (a_wice_soisno_ens) + deallocate (a_t_soisno_ens ) +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + deallocate (a_t_room ) + deallocate (a_tafu ) + deallocate (a_fhac ) + deallocate (a_fwst ) + deallocate (a_fach ) + deallocate (a_fahe ) + deallocate (a_fhah ) + deallocate (a_vehc ) + deallocate (a_meta ) + + deallocate (a_senroof ) + deallocate (a_senwsun ) + deallocate (a_senwsha ) + deallocate (a_sengimp ) + deallocate (a_sengper ) + deallocate (a_senurbl ) + + deallocate (a_lfevproof ) + deallocate (a_lfevpgimp ) + deallocate (a_lfevpgper ) + deallocate (a_lfevpurbl ) + + deallocate (a_troof ) + deallocate (a_twall ) + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + deallocate (a_lai_enftemp ) + deallocate (a_lai_enfboreal ) + deallocate (a_lai_dnfboreal ) + deallocate (a_lai_ebftrop ) + deallocate (a_lai_ebftemp ) + deallocate (a_lai_dbftrop ) + deallocate (a_lai_dbftemp ) + deallocate (a_lai_dbfboreal ) + deallocate (a_lai_ebstemp ) + deallocate (a_lai_dbstemp ) + deallocate (a_lai_dbsboreal ) + deallocate (a_lai_c3arcgrass ) + deallocate (a_lai_c3grass ) + deallocate (a_lai_c4grass ) +#endif + +#ifdef BGC + deallocate (a_leafc ) + deallocate (a_leafc_storage ) + deallocate (a_leafc_xfer ) + deallocate (a_frootc ) + deallocate (a_frootc_storage ) + deallocate (a_frootc_xfer ) + deallocate (a_livestemc ) + deallocate (a_livestemc_storage ) + deallocate (a_livestemc_xfer ) + deallocate (a_deadstemc ) + deallocate (a_deadstemc_storage ) + deallocate (a_deadstemc_xfer ) + deallocate (a_livecrootc ) + deallocate (a_livecrootc_storage ) + deallocate (a_livecrootc_xfer ) + deallocate (a_deadcrootc ) + deallocate (a_deadcrootc_storage ) + deallocate (a_deadcrootc_xfer ) + deallocate (a_grainc ) + deallocate (a_grainc_storage ) + deallocate (a_grainc_xfer ) + deallocate (a_leafn ) + deallocate (a_leafn_storage ) + deallocate (a_leafn_xfer ) + deallocate (a_frootn ) + deallocate (a_frootn_storage ) + deallocate (a_frootn_xfer ) + deallocate (a_livestemn ) + deallocate (a_livestemn_storage ) + deallocate (a_livestemn_xfer ) + deallocate (a_deadstemn ) + deallocate (a_deadstemn_storage ) + deallocate (a_deadstemn_xfer ) + deallocate (a_livecrootn ) + deallocate (a_livecrootn_storage ) + deallocate (a_livecrootn_xfer ) + deallocate (a_deadcrootn ) + deallocate (a_deadcrootn_storage ) + deallocate (a_deadcrootn_xfer ) + deallocate (a_grainn ) + deallocate (a_grainn_storage ) + deallocate (a_grainn_xfer ) + deallocate (a_retransn ) + deallocate (a_gpp ) + deallocate (a_downreg ) + deallocate (a_ar ) + deallocate (a_cwdprod ) + deallocate (a_cwddecomp ) + deallocate (a_hr ) + deallocate (a_fpg ) + deallocate (a_fpi ) + deallocate (a_totvegc ) + deallocate (a_totlitc ) + deallocate (a_totcwdc ) + deallocate (a_totsomc ) + deallocate (a_totcolc ) + deallocate (a_totvegn ) + deallocate (a_totlitn ) + deallocate (a_totcwdn ) + deallocate (a_totsomn ) + deallocate (a_totcoln ) + deallocate (a_gpp_enftemp ) !1 + deallocate (a_gpp_enfboreal ) !2 + deallocate (a_gpp_dnfboreal ) !3 + deallocate (a_gpp_ebftrop ) !4 + deallocate (a_gpp_ebftemp ) !5 + deallocate (a_gpp_dbftrop ) !6 + deallocate (a_gpp_dbftemp ) !7 + deallocate (a_gpp_dbfboreal ) !8 + deallocate (a_gpp_ebstemp ) !9 + deallocate (a_gpp_dbstemp ) !10 + deallocate (a_gpp_dbsboreal ) !11 + deallocate (a_gpp_c3arcgrass ) !12 + deallocate (a_gpp_c3grass ) !13 + deallocate (a_gpp_c4grass ) !14 + deallocate (a_npp_enftemp ) !1 + deallocate (a_npp_enfboreal ) !2 + deallocate (a_npp_dnfboreal ) !3 + deallocate (a_npp_ebftrop ) !4 + deallocate (a_npp_ebftemp ) !5 + deallocate (a_npp_dbftrop ) !6 + deallocate (a_npp_dbftemp ) !7 + deallocate (a_npp_dbfboreal ) !8 + deallocate (a_npp_ebstemp ) !9 + deallocate (a_npp_dbstemp ) !10 + deallocate (a_npp_dbsboreal ) !11 + deallocate (a_npp_c3arcgrass ) !12 + deallocate (a_npp_c3grass ) !13 + deallocate (a_npp_c4grass ) !14 + deallocate (a_npptoleafc_enftemp ) !1 + deallocate (a_npptoleafc_enfboreal ) !2 + deallocate (a_npptoleafc_dnfboreal ) !3 + deallocate (a_npptoleafc_ebftrop ) !4 + deallocate (a_npptoleafc_ebftemp ) !5 + deallocate (a_npptoleafc_dbftrop ) !6 + deallocate (a_npptoleafc_dbftemp ) !7 + deallocate (a_npptoleafc_dbfboreal ) !8 + deallocate (a_npptoleafc_ebstemp ) !9 + deallocate (a_npptoleafc_dbstemp ) !10 + deallocate (a_npptoleafc_dbsboreal ) !11 + deallocate (a_npptoleafc_c3arcgrass ) !12 + deallocate (a_npptoleafc_c3grass ) !13 + deallocate (a_npptoleafc_c4grass ) !14 + deallocate (a_leafc_enftemp ) !1 + deallocate (a_leafc_enfboreal ) !2 + deallocate (a_leafc_dnfboreal ) !3 + deallocate (a_leafc_ebftrop ) !4 + deallocate (a_leafc_ebftemp ) !5 + deallocate (a_leafc_dbftrop ) !6 + deallocate (a_leafc_dbftemp ) !7 + deallocate (a_leafc_dbfboreal ) !8 + deallocate (a_leafc_ebstemp ) !9 + deallocate (a_leafc_dbstemp ) !10 + deallocate (a_leafc_dbsboreal ) !11 + deallocate (a_leafc_c3arcgrass ) !12 + deallocate (a_leafc_c3grass ) !13 + deallocate (a_leafc_c4grass ) !14 + + deallocate (a_O2_DECOMP_DEPTH_UNSAT ) + deallocate (a_CONC_O2_UNSAT ) + +#ifdef CROP + deallocate (a_pdcorn ) + deallocate (a_pdswheat ) + deallocate (a_pdwwheat ) + deallocate (a_pdsoybean ) + deallocate (a_pdcotton ) + deallocate (a_pdrice1 ) + deallocate (a_pdrice2 ) + deallocate (a_pdsugarcane ) + deallocate (a_plantdate ) + deallocate (a_manunitro ) + deallocate (a_fertnitro_corn ) + deallocate (a_fertnitro_swheat ) + deallocate (a_fertnitro_wwheat ) + deallocate (a_fertnitro_soybean ) + deallocate (a_fertnitro_cotton ) + deallocate (a_fertnitro_rice1 ) + deallocate (a_fertnitro_rice2 ) + deallocate (a_fertnitro_sugarcane) + deallocate (a_irrig_method_corn ) + deallocate (a_irrig_method_swheat ) + deallocate (a_irrig_method_wwheat ) + deallocate (a_irrig_method_soybean ) + deallocate (a_irrig_method_cotton ) + deallocate (a_irrig_method_rice1 ) + deallocate (a_irrig_method_rice2 ) + deallocate (a_irrig_method_sugarcane) + deallocate (a_cphase ) + deallocate (a_hui ) + deallocate (a_vf ) + deallocate (a_gddmaturity ) + deallocate (a_gddplant ) + deallocate (a_cropprod1c ) + deallocate (a_cropprod1c_loss ) + deallocate (a_cropseedc_deficit ) + deallocate (a_grainc_to_cropprodc) + deallocate (a_grainc_to_seed ) + deallocate (a_fert_to_sminn ) + + deallocate (a_sum_irrig ) + deallocate (a_sum_deficit_irrig ) + deallocate (a_sum_irrig_count ) + deallocate (a_waterstorage ) + deallocate (a_groundwater_demand ) + deallocate (a_groundwater_supply ) + deallocate (a_reservoirriver_demand) + deallocate (a_reservoirriver_supply) + deallocate (a_reservoir_supply ) + deallocate (a_river_supply ) + deallocate (a_runoff_supply ) +#endif + deallocate (a_ndep_to_sminn ) + + deallocate (a_abm ) + deallocate (a_gdp ) + deallocate (a_peatf ) + deallocate (a_hdm ) + deallocate (a_lnfm ) + + deallocate (a_leafcCap ) + deallocate (a_leafc_storageCap ) + deallocate (a_leafc_xferCap ) + deallocate (a_frootcCap ) + deallocate (a_frootc_storageCap ) + deallocate (a_frootc_xferCap ) + deallocate (a_livestemcCap ) + deallocate (a_livestemc_storageCap ) + deallocate (a_livestemc_xferCap ) + deallocate (a_deadstemcCap ) + deallocate (a_deadstemc_storageCap ) + deallocate (a_deadstemc_xferCap ) + deallocate (a_livecrootcCap ) + deallocate (a_livecrootc_storageCap) + deallocate (a_livecrootc_xferCap ) + deallocate (a_deadcrootcCap ) + deallocate (a_deadcrootc_storageCap) + deallocate (a_deadcrootc_xferCap ) + deallocate (a_leafnCap ) + deallocate (a_leafn_storageCap ) + deallocate (a_leafn_xferCap ) + deallocate (a_frootnCap ) + deallocate (a_frootn_storageCap ) + deallocate (a_frootn_xferCap ) + deallocate (a_livestemnCap ) + deallocate (a_livestemn_storageCap ) + deallocate (a_livestemn_xferCap ) + deallocate (a_deadstemnCap ) + deallocate (a_deadstemn_storageCap ) + deallocate (a_deadstemn_xferCap ) + deallocate (a_livecrootnCap ) + deallocate (a_livecrootn_storageCap) + deallocate (a_livecrootn_xferCap ) + deallocate (a_deadcrootnCap ) + deallocate (a_deadcrootn_storageCap) + deallocate (a_deadcrootn_xferCap ) +#endif +! Ozone stress variables + deallocate (a_ozone ) +! END ozone stress variables + + deallocate (a_t_soisno ) + deallocate (a_wliq_soisno ) + deallocate (a_wice_soisno ) + deallocate (a_h2osoi ) + deallocate (a_qlayer ) + deallocate (a_lake_deficit) + deallocate (a_rootr ) + deallocate (a_BD_all ) + deallocate (a_wfc ) + deallocate (a_OM_density ) +!Plant Hydraulic parameters + deallocate (a_vegwp ) +!END plant hydraulic parameters + deallocate (a_dz_lake ) + deallocate (a_t_lake ) + deallocate (a_lake_icefrac) +#ifdef BGC + deallocate (a_litr1c_vr ) + deallocate (a_litr2c_vr ) + deallocate (a_litr3c_vr ) + deallocate (a_soil1c_vr ) + deallocate (a_soil2c_vr ) + deallocate (a_soil3c_vr ) + deallocate (a_cwdc_vr ) + deallocate (a_litr1n_vr ) + deallocate (a_litr2n_vr ) + deallocate (a_litr3n_vr ) + deallocate (a_soil1n_vr ) + deallocate (a_soil2n_vr ) + deallocate (a_soil3n_vr ) + deallocate (a_cwdn_vr ) + deallocate (a_totsoiln_vr ) + deallocate (a_sminn_vr ) + deallocate (decomp_vr_tmp ) + deallocate (a_litr1cCap_vr) + deallocate (a_litr2cCap_vr) + deallocate (a_litr3cCap_vr) + deallocate (a_soil1cCap_vr) + deallocate (a_soil2cCap_vr) + deallocate (a_soil3cCap_vr) + deallocate (a_cwdcCap_vr ) + deallocate (a_litr1nCap_vr) + deallocate (a_litr2nCap_vr) + deallocate (a_litr3nCap_vr) + deallocate (a_soil1nCap_vr) + deallocate (a_soil2nCap_vr) + deallocate (a_soil3nCap_vr) + deallocate (a_cwdnCap_vr ) + deallocate (a_t_scalar ) + deallocate (a_w_scalar ) +#endif + + deallocate (a_ustar ) + deallocate (a_ustar2 ) + deallocate (a_tstar ) + deallocate (a_qstar ) + deallocate (a_zol ) + deallocate (a_rib ) + deallocate (a_fm ) + deallocate (a_fh ) + deallocate (a_fq ) + + deallocate (a_us10m ) + deallocate (a_vs10m ) + deallocate (a_fm10m ) + + deallocate (a_sr ) + deallocate (a_solvd ) + deallocate (a_solvi ) + deallocate (a_solnd ) + deallocate (a_solni ) + deallocate (a_srvd ) + deallocate (a_srvi ) + deallocate (a_srnd ) + deallocate (a_srni ) + deallocate (a_solvdln ) + deallocate (a_solviln ) + deallocate (a_solndln ) + deallocate (a_solniln ) + deallocate (a_srvdln ) + deallocate (a_srviln ) + deallocate (a_srndln ) + deallocate (a_srniln ) +#ifdef HYPERSPECTRAL + deallocate (a_sol_dir_ln_hires) + deallocate (a_sol_dif_ln_hires) + deallocate (a_sr_dir_ln_hires ) + deallocate (a_sr_dif_ln_hires ) +#endif + deallocate (a_sensors ) + + deallocate (nac_ln ) + deallocate (nac_dt ) + deallocate (filter_dt ) + + ENDIF + ENDIF + +#ifdef EXTERNAL_LAKE + CALL deallocate_LakeAccVars +#endif + + END SUBROUTINE deallocate_acc_fluxes + + !----------------------- + SUBROUTINE FLUSH_acc_fluxes () + + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + USE MOD_LandUrban, only: numurban + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + IF (p_is_worker) THEN + + nac = 0 + + IF (numpatch > 0) THEN + + ! flush the Fluxes for accumulation + a_us (:) = spval + a_vs (:) = spval + a_t (:) = spval + a_q (:) = spval + a_prc (:) = spval + a_prl (:) = spval + a_pbot (:) = spval + a_frl (:) = spval + a_solarin (:) = spval + a_hpbl (:) = spval + + a_taux (:) = spval + a_tauy (:) = spval + a_fsena (:) = spval + a_lfevpa (:) = spval + a_fevpa (:) = spval + a_fsenl (:) = spval + a_fevpl (:) = spval + a_etr (:) = spval + a_fseng (:) = spval + a_fevpg (:) = spval + a_fgrnd (:) = spval + a_sabvsun (:) = spval + a_sabvsha (:) = spval + a_sabg (:) = spval + a_olrg (:) = spval + a_rnet (:) = spval + a_xerr (:) = spval + a_zerr (:) = spval + a_rsur (:) = spval + a_rsur_se (:) = spval + a_rsur_ie (:) = spval + a_rsub (:) = spval + a_rnof (:) = spval +#ifdef CatchLateralFlow + a_xwsur (:) = spval + a_xwsub (:) = spval + a_fldarea (:) = spval +#endif + a_qintr (:) = spval + a_qinfl (:) = spval + a_qdrip (:) = spval + a_rstfacsun (:) = spval + a_rstfacsha (:) = spval + a_gssun (:) = spval + a_gssha (:) = spval + a_rss (:) = spval + + a_wdsrf (:) = spval + a_zwt (:) = spval + a_wa (:) = spval + a_wat (:) = spval + a_wetwat (:) = spval + a_assim (:) = spval + a_respc (:) = spval + a_assimsun (:) = spval + a_assimsha (:) = spval + a_etrsun (:) = spval + a_etrsha (:) = spval + + a_qcharge (:) = spval + + a_t_grnd (:) = spval + a_tleaf (:) = spval + a_ldew_rain (:) = spval + a_ldew_snow (:) = spval + a_ldew (:) = spval + a_scv (:) = spval + a_snowdp (:) = spval + a_fsno (:) = spval + a_frcsat (:) = spval + a_sigf (:) = spval + a_green (:) = spval + a_lai (:) = spval + a_laisun (:) = spval + a_laisha (:) = spval + a_sai (:) = spval + + a_alb (:,:,:) = spval + +#ifdef HYPERSPECTRAL + a_alb_hires (:,:,:) = spval +#endif + + a_emis (:) = spval + a_z0m (:) = spval + a_trad (:) = spval + a_tref (:) = spval + a_t2m_wmo (:) = spval + a_qref (:) = spval + a_rain (:) = spval + a_snow (:) = spval + + a_o3uptakesun(:) = spval + a_o3uptakesha(:) = spval + +#ifdef DataAssimilation + a_h2osoi_ens (:,:,:) = spval + a_t_brt_smap_ens (:,:,:) = spval + a_t_brt_fy3d_ens (:,:,:) = spval + a_t_brt_fy3d (:,:) = spval + a_t_brt_smap (:,:) = spval + a_wliq_soisno_ens(:,:,:) = spval + a_wice_soisno_ens(:,:,:) = spval + a_t_soisno_ens (:,:,:) = spval +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + a_t_room (:) = spval + a_tafu (:) = spval + a_fhac (:) = spval + a_fwst (:) = spval + a_fach (:) = spval + a_fahe (:) = spval + a_fhah (:) = spval + a_vehc (:) = spval + a_meta (:) = spval + + a_senroof (:) = spval + a_senwsun (:) = spval + a_senwsha (:) = spval + a_sengimp (:) = spval + a_sengper (:) = spval + a_senurbl (:) = spval + + a_lfevproof(:) = spval + a_lfevpgimp(:) = spval + a_lfevpgper(:) = spval + a_lfevpurbl(:) = spval + + a_troof (:) = spval + a_twall (:) = spval + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + a_lai_enftemp (:) = spval + a_lai_enfboreal (:) = spval + a_lai_dnfboreal (:) = spval + a_lai_ebftrop (:) = spval + a_lai_ebftemp (:) = spval + a_lai_dbftrop (:) = spval + a_lai_dbftemp (:) = spval + a_lai_dbfboreal (:) = spval + a_lai_ebstemp (:) = spval + a_lai_dbstemp (:) = spval + a_lai_dbsboreal (:) = spval + a_lai_c3arcgrass (:) = spval + a_lai_c3grass (:) = spval + a_lai_c4grass (:) = spval +#endif +#ifdef BGC + a_leafc (:) = spval + a_leafc_storage (:) = spval + a_leafc_xfer (:) = spval + a_frootc (:) = spval + a_frootc_storage (:) = spval + a_frootc_xfer (:) = spval + a_livestemc (:) = spval + a_livestemc_storage (:) = spval + a_livestemc_xfer (:) = spval + a_deadstemc (:) = spval + a_deadstemc_storage (:) = spval + a_deadstemc_xfer (:) = spval + a_livecrootc (:) = spval + a_livecrootc_storage (:) = spval + a_livecrootc_xfer (:) = spval + a_deadcrootc (:) = spval + a_deadcrootc_storage (:) = spval + a_deadcrootc_xfer (:) = spval + a_grainc (:) = spval + a_grainc_storage (:) = spval + a_grainc_xfer (:) = spval + a_leafn (:) = spval + a_leafn_storage (:) = spval + a_leafn_xfer (:) = spval + a_frootn (:) = spval + a_frootn_storage (:) = spval + a_frootn_xfer (:) = spval + a_livestemn (:) = spval + a_livestemn_storage (:) = spval + a_livestemn_xfer (:) = spval + a_deadstemn (:) = spval + a_deadstemn_storage (:) = spval + a_deadstemn_xfer (:) = spval + a_livecrootn (:) = spval + a_livecrootn_storage (:) = spval + a_livecrootn_xfer (:) = spval + a_deadcrootn (:) = spval + a_deadcrootn_storage (:) = spval + a_deadcrootn_xfer (:) = spval + a_grainn (:) = spval + a_grainn_storage (:) = spval + a_grainn_xfer (:) = spval + a_retransn (:) = spval + a_gpp (:) = spval + a_downreg (:) = spval + a_ar (:) = spval + a_cwdprod (:) = spval + a_cwddecomp (:) = spval + a_hr (:) = spval + a_fpg (:) = spval + a_fpi (:) = spval + a_totvegc (:) = spval + a_totlitc (:) = spval + a_totcwdc (:) = spval + a_totsomc (:) = spval + a_totcolc (:) = spval + a_totvegn (:) = spval + a_totlitn (:) = spval + a_totcwdn (:) = spval + a_totsomn (:) = spval + a_totcoln (:) = spval + a_gpp_enftemp (:) = spval + a_gpp_enfboreal (:) = spval + a_gpp_dnfboreal (:) = spval + a_gpp_ebftrop (:) = spval + a_gpp_ebftemp (:) = spval + a_gpp_dbftrop (:) = spval + a_gpp_dbftemp (:) = spval + a_gpp_dbfboreal (:) = spval + a_gpp_ebstemp (:) = spval + a_gpp_dbstemp (:) = spval + a_gpp_dbsboreal (:) = spval + a_gpp_c3arcgrass (:) = spval + a_gpp_c3grass (:) = spval + a_gpp_c4grass (:) = spval + a_npp_enftemp (:) = spval + a_npp_enfboreal (:) = spval + a_npp_dnfboreal (:) = spval + a_npp_ebftrop (:) = spval + a_npp_ebftemp (:) = spval + a_npp_dbftrop (:) = spval + a_npp_dbftemp (:) = spval + a_npp_dbfboreal (:) = spval + a_npp_ebstemp (:) = spval + a_npp_dbstemp (:) = spval + a_npp_dbsboreal (:) = spval + a_npp_c3arcgrass (:) = spval + a_npp_c3grass (:) = spval + a_npp_c4grass (:) = spval + a_npptoleafc_enftemp (:) = spval + a_npptoleafc_enfboreal (:) = spval + a_npptoleafc_dnfboreal (:) = spval + a_npptoleafc_ebftrop (:) = spval + a_npptoleafc_ebftemp (:) = spval + a_npptoleafc_dbftrop (:) = spval + a_npptoleafc_dbftemp (:) = spval + a_npptoleafc_dbfboreal (:) = spval + a_npptoleafc_ebstemp (:) = spval + a_npptoleafc_dbstemp (:) = spval + a_npptoleafc_dbsboreal (:) = spval + a_npptoleafc_c3arcgrass (:) = spval + a_npptoleafc_c3grass (:) = spval + a_npptoleafc_c4grass (:) = spval + a_leafc_enftemp (:) = spval + a_leafc_enfboreal (:) = spval + a_leafc_dnfboreal (:) = spval + a_leafc_ebftrop (:) = spval + a_leafc_ebftemp (:) = spval + a_leafc_dbftrop (:) = spval + a_leafc_dbftemp (:) = spval + a_leafc_dbfboreal (:) = spval + a_leafc_ebstemp (:) = spval + a_leafc_dbstemp (:) = spval + a_leafc_dbsboreal (:) = spval + a_leafc_c3arcgrass (:) = spval + a_leafc_c3grass (:) = spval + a_leafc_c4grass (:) = spval + + a_O2_DECOMP_DEPTH_UNSAT (:,:) = spval + a_CONC_O2_UNSAT (:,:) = spval +#ifdef CROP + a_pdcorn (:) = spval + a_pdswheat (:) = spval + a_pdwwheat (:) = spval + a_pdsoybean (:) = spval + a_pdcotton (:) = spval + a_pdrice1 (:) = spval + a_pdrice2 (:) = spval + a_pdsugarcane (:) = spval + a_plantdate (:) = spval + a_manunitro (:) = spval + a_fertnitro_corn (:) = spval + a_fertnitro_swheat (:) = spval + a_fertnitro_wwheat (:) = spval + a_fertnitro_soybean (:) = spval + a_fertnitro_cotton (:) = spval + a_fertnitro_rice1 (:) = spval + a_fertnitro_rice2 (:) = spval + a_fertnitro_sugarcane(:) = spval + a_irrig_method_corn (:) = spval + a_irrig_method_swheat (:) = spval + a_irrig_method_wwheat (:) = spval + a_irrig_method_soybean (:) = spval + a_irrig_method_cotton (:) = spval + a_irrig_method_rice1 (:) = spval + a_irrig_method_rice2 (:) = spval + a_irrig_method_sugarcane(:) = spval + a_cphase (:) = spval + a_vf (:) = spval + a_gddmaturity (:) = spval + a_gddplant (:) = spval + a_hui (:) = spval + a_cropprod1c (:) = spval + a_cropprod1c_loss (:) = spval + a_cropseedc_deficit (:) = spval + a_grainc_to_cropprodc(:) = spval + a_grainc_to_seed (:) = spval + a_fert_to_sminn (:) = spval + + a_sum_irrig (:) = spval + a_sum_deficit_irrig (:) = spval + a_sum_irrig_count (:) = spval + a_waterstorage (:) = spval + a_groundwater_demand (:) = spval + a_groundwater_supply (:) = spval + a_reservoirriver_demand(:) = spval + a_reservoirriver_supply(:) = spval + a_reservoir_supply (:) = spval + a_river_supply (:) = spval + a_runoff_supply (:) = spval +#endif + a_ndep_to_sminn (:) = spval + + a_abm (:) = spval + a_gdp (:) = spval + a_peatf (:) = spval + a_hdm (:) = spval + a_lnfm (:) = spval + + a_leafcCap (:) = spval + a_leafc_storageCap (:) = spval + a_leafc_xferCap (:) = spval + a_frootcCap (:) = spval + a_frootc_storageCap (:) = spval + a_frootc_xferCap (:) = spval + a_livestemcCap (:) = spval + a_livestemc_storageCap (:) = spval + a_livestemc_xferCap (:) = spval + a_deadstemcCap (:) = spval + a_deadstemc_storageCap (:) = spval + a_deadstemc_xferCap (:) = spval + a_livecrootcCap (:) = spval + a_livecrootc_storageCap(:) = spval + a_livecrootc_xferCap (:) = spval + a_deadcrootcCap (:) = spval + a_deadcrootc_storageCap(:) = spval + a_deadcrootc_xferCap (:) = spval + a_leafnCap (:) = spval + a_leafn_storageCap (:) = spval + a_leafn_xferCap (:) = spval + a_frootnCap (:) = spval + a_frootn_storageCap (:) = spval + a_frootn_xferCap (:) = spval + a_livestemnCap (:) = spval + a_livestemn_storageCap (:) = spval + a_livestemn_xferCap (:) = spval + a_deadstemnCap (:) = spval + a_deadstemn_storageCap (:) = spval + a_deadstemn_xferCap (:) = spval + a_livecrootnCap (:) = spval + a_livecrootn_storageCap(:) = spval + a_livecrootn_xferCap (:) = spval + a_deadcrootnCap (:) = spval + a_deadcrootn_storageCap(:) = spval + a_deadcrootn_xferCap (:) = spval +#endif + a_ozone (:) = spval + + a_t_soisno (:,:) = spval + a_wliq_soisno (:,:) = spval + a_wice_soisno (:,:) = spval + a_h2osoi (:,:) = spval + a_qlayer (:,:) = spval + a_lake_deficit (:) = spval + a_rootr (:,:) = spval + a_BD_all (:,:) = spval + a_wfc (:,:) = spval + a_OM_density (:,:) = spval +!Plant Hydraulic parameters + a_vegwp (:,:) = spval +!END plant hydraulic parameters + a_dz_lake (:,:) = spval + a_t_lake (:,:) = spval + a_lake_icefrac (:,:) = spval +#ifdef BGC + a_litr1c_vr (:,:) = spval + a_litr2c_vr (:,:) = spval + a_litr3c_vr (:,:) = spval + a_soil1c_vr (:,:) = spval + a_soil2c_vr (:,:) = spval + a_soil3c_vr (:,:) = spval + a_cwdc_vr (:,:) = spval + a_litr1n_vr (:,:) = spval + a_litr2n_vr (:,:) = spval + a_litr3n_vr (:,:) = spval + a_soil1n_vr (:,:) = spval + a_soil2n_vr (:,:) = spval + a_soil3n_vr (:,:) = spval + a_cwdn_vr (:,:) = spval + a_totsoiln_vr (:,:) = spval + + a_litr1cCap_vr (:,:) = spval + a_litr2cCap_vr (:,:) = spval + a_litr3cCap_vr (:,:) = spval + a_soil1cCap_vr (:,:) = spval + a_soil2cCap_vr (:,:) = spval + a_soil3cCap_vr (:,:) = spval + a_cwdcCap_vr (:,:) = spval + a_litr1nCap_vr (:,:) = spval + a_litr2nCap_vr (:,:) = spval + a_litr3nCap_vr (:,:) = spval + a_soil1nCap_vr (:,:) = spval + a_soil2nCap_vr (:,:) = spval + a_soil3nCap_vr (:,:) = spval + a_cwdnCap_vr (:,:) = spval + + a_t_scalar (:,:) = spval + a_w_scalar (:,:) = spval + + a_sminn_vr (:,:) = spval +#endif + + a_ustar (:) = spval + a_ustar2(:) = spval + a_tstar (:) = spval + a_qstar (:) = spval + a_zol (:) = spval + a_rib (:) = spval + a_fm (:) = spval + a_fh (:) = spval + a_fq (:) = spval + + a_us10m (:) = spval + a_vs10m (:) = spval + a_fm10m (:) = spval + + a_sr (:) = spval + a_solvd (:) = spval + a_solvi (:) = spval + a_solnd (:) = spval + a_solni (:) = spval + a_srvd (:) = spval + a_srvi (:) = spval + a_srnd (:) = spval + a_srni (:) = spval + a_solvdln (:) = spval + a_solviln (:) = spval + a_solndln (:) = spval + a_solniln (:) = spval + a_srvdln (:) = spval + a_srviln (:) = spval + a_srndln (:) = spval + a_srniln (:) = spval +#ifdef HYPERSPECTRAL + a_sol_dir_ln_hires(:,:) = spval + a_sol_dif_ln_hires(:,:) = spval + a_sr_dir_ln_hires (:,:) = spval + a_sr_dif_ln_hires (:,:) = spval +#endif + a_sensors(:,:) = spval + + nac_ln (:) = 0 + nac_dt (:) = 0 + filter_dt (:) = .true. + + ENDIF + ENDIF + +#ifdef EXTERNAL_LAKE + CALL Flush_LakeAccVars +#endif + + END SUBROUTINE FLUSH_acc_fluxes + + SUBROUTINE accumulate_fluxes +! ---------------------------------------------------------------------- +! perform the grid average mapping: average a subgrid input 1d vector +! of length numpatch to a output 2d array of length [ghist%xcnt,ghist%ycnt] +! +! Created by Yongjiu Dai, 03/2014 +!--------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE mod_forcing, only: forcmask_pch + USE MOD_Mesh, only: numelm + USE MOD_LandElm + USE MOD_LandPatch, only: numpatch, elm_patch + USE MOD_LandUrban, only: numurban + USE MOD_Const_Physical, only: vonkar, stefnc, cpair, rgas, grav + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Vars_1DForcing + USE MOD_Vars_1DFluxes + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_OZONESTRESS, DEF_USE_PLANTHYDRAULICS, DEF_USE_NITRIF + USE MOD_TurbulenceLEddy + USE MOD_Vars_Global +#ifdef CatchLateralFlow + USE MOD_Catch_Vars_1DFluxes + USE MOD_Catch_Hist, only: accumulate_fluxes_basin +#endif + + IMPLICIT NONE + + ! Local Variables + + real(r8), allocatable :: r_trad (:) + real(r8), allocatable :: r_ustar (:) + real(r8), allocatable :: r_ustar2 (:) !define a temporary for estimating us10m only, output should be r_ustar. Shaofeng, 2023.05.20 + real(r8), allocatable :: r_tstar (:) + real(r8), allocatable :: r_qstar (:) + real(r8), allocatable :: r_zol (:) + real(r8), allocatable :: r_rib (:) + real(r8), allocatable :: r_fm (:) + real(r8), allocatable :: r_fh (:) + real(r8), allocatable :: r_fq (:) + + real(r8), allocatable :: r_us10m (:) + real(r8), allocatable :: r_vs10m (:) + real(r8), allocatable :: r_fm10m (:) + + logical, allocatable :: filter (:) + + !--------------------------------------------------------------------- + integer ib, jb, i, j, ielm, istt, iend + real(r8) sumwt + real(r8) rhoair,thm,th,thv,ur,displa_av,zldis,hgt_u,hgt_t,hgt_q + real(r8) hpbl ! atmospheric boundary layer height [m] + real(r8) z0m_av,z0h_av,z0q_av,us,vs,tm,qm,psrf,taux_e,tauy_e,fsena_e,fevpa_e + real(r8) r_ustar_e, r_tstar_e, r_qstar_e, r_zol_e, r_ustar2_e, r_fm10m_e + real(r8) r_fm_e, r_fh_e, r_fq_e, r_rib_e, r_us10m_e, r_vs10m_e + real(r8) obu,fh2m,fq2m + real(r8) um,thvstar,beta,zii,wc,wc2 + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + ! count for time steps + nac = nac + 1 + + ! count for local noon time steps + DO i = 1, numpatch + IF (solvdln(i) /= spval) THEN + nac_ln(i) = nac_ln(i) + 1 + ENDIF + ENDDO + + ! set daytime filter + filter_dt(:) = coszen(:) > 0 + + ! count for daytime time steps + WHERE ( filter_dt(:) ) nac_dt(:) = nac_dt(:) + 1 + + CALL acc1d (forc_us , a_us ) + CALL acc1d (forc_vs , a_vs ) + CALL acc1d (forc_t , a_t ) + CALL acc1d (forc_q , a_q ) + CALL acc1d (forc_prc , a_prc ) + CALL acc1d (forc_prl , a_prl ) + CALL acc1d (forc_pbot , a_pbot ) + CALL acc1d (forc_frl , a_frl ) + + CALL acc1d (forc_sols , a_solarin ) + CALL acc1d (forc_soll , a_solarin ) + CALL acc1d (forc_solsd , a_solarin ) + CALL acc1d (forc_solld , a_solarin ) + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL acc1d (forc_hpbl , a_hpbl) + ENDIF + + CALL acc1d (taux , a_taux ) + CALL acc1d (tauy , a_tauy ) + CALL acc1d (fsena , a_fsena ) + CALL acc1d (lfevpa , a_lfevpa ) + CALL acc1d (fevpa , a_fevpa ) + CALL acc1d (fsenl , a_fsenl ) + CALL acc1d (fevpl , a_fevpl ) + CALL acc1d (etr , a_etr ) + CALL acc1d (fseng , a_fseng ) + CALL acc1d (fevpg , a_fevpg ) + CALL acc1d (fgrnd , a_fgrnd ) + CALL acc1d (sabvsun , a_sabvsun ) + CALL acc1d (sabvsha , a_sabvsha ) + CALL acc1d (sabg , a_sabg ) + CALL acc1d (olrg , a_olrg ) + + IF (DEF_forcing%has_missing_value) THEN + WHERE (forcmask_pch) + rnet = sabg + sabvsun + sabvsha - olrg + forc_frl + END WHERE + ELSE + WHERE(patchmask) + rnet = sabg + sabvsun + sabvsha - olrg + forc_frl + END WHERE + ENDIF + CALL acc1d (rnet , a_rnet ) + + CALL acc1d (xerr , a_xerr ) + CALL acc1d (zerr , a_zerr ) + CALL acc1d (rsur , a_rsur ) +#ifndef CatchLateralFlow + CALL acc1d (rsur_se , a_rsur_se ) + CALL acc1d (rsur_ie , a_rsur_ie ) +#endif + CALL acc1d (rsub , a_rsub ) + CALL acc1d (rnof , a_rnof ) +#ifdef CatchLateralFlow + CALL acc1d (xwsur , a_xwsur ) + CALL acc1d (xwsub , a_xwsub ) + CALL acc1d (fldarea , a_fldarea ) +#endif + CALL acc1d (qintr , a_qintr ) + CALL acc1d (qinfl , a_qinfl ) + CALL acc1d (qdrip , a_qdrip ) + + CALL acc1d (rstfacsun_out , a_rstfacsun ) + CALL acc1d (rstfacsha_out , a_rstfacsha ) + + CALL acc1d (gssun_out , a_gssun ) + CALL acc1d (gssha_out , a_gssha ) + + CALL acc1d (rss , a_rss ) + CALL acc1d (wdsrf , a_wdsrf ) + CALL acc1d (zwt , a_zwt ) + CALL acc1d (wa , a_wa ) + CALL acc1d (wat , a_wat ) + CALL acc1d (wetwat , a_wetwat ) + CALL acc1d (assim , a_assim ) + CALL acc1d (respc , a_respc ) + CALL acc1d (assimsun_out , a_assimsun ) + CALL acc1d (assimsha_out , a_assimsha ) + CALL acc1d (etrsun_out , a_etrsun ) + CALL acc1d (etrsha_out , a_etrsha ) + + CALL acc1d (qcharge , a_qcharge ) + + CALL acc1d (t_grnd , a_t_grnd ) + CALL acc1d (tleaf , a_tleaf ) + CALL acc1d (ldew_rain , a_ldew_rain ) + CALL acc1d (ldew_snow , a_ldew_snow ) + CALL acc1d (ldew , a_ldew ) + CALL acc1d (scv , a_scv ) + CALL acc1d (snowdp , a_snowdp ) + CALL acc1d (fsno , a_fsno ) + CALL acc1d (frcsat , a_frcsat ) + CALL acc1d (sigf , a_sigf ) + CALL acc1d (green , a_green ) + CALL acc1d (lai , a_lai ) + CALL acc1d (laisun , a_laisun ) + CALL acc1d (laisha , a_laisha ) + CALL acc1d (sai , a_sai ) + + ! only acc for daytime for albedo + CALL acc3d (alb , a_alb, filter_dt ) +#ifdef HYPERSPECTRAL + CALL acc3d (alb_hires , a_alb_hires, filter_dt ) +#endif + + CALL acc1d (emis , a_emis ) + CALL acc1d (z0m , a_z0m ) + + allocate (r_trad (numpatch)) ; r_trad(:) = spval + DO i = 1, numpatch + IF (DEF_forcing%has_missing_value) THEN + IF (.not. forcmask_pch(i)) CYCLE + ENDIF + + IF (.not. patchmask(i)) CYCLE + r_trad(i) = (olrg(i)/stefnc)**0.25 + ENDDO + CALL acc1d (r_trad , a_trad ) + deallocate (r_trad ) + + CALL acc1d (tref , a_tref ) + CALL acc1d (qref , a_qref ) + + ! set 2m WMO temperature + DO ielm = 1, numelm + + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + + ! landelm%settyp=1 means 2m WMO patch exist, + ! which is the last end patch in a element. + IF (landelm%settyp(ielm)==1 .and. forcmask_pch(iend)) THEN + ! all set to the 2m WMO patch tref + t2m_wmo(istt:iend) = tref(iend) + ELSE + ! if no 2m WMO patch, keep t2m_wmo to tref + t2m_wmo(istt:iend) = tref(istt:iend) + ENDIF + ENDDO + + CALL acc1d (t2m_wmo, a_t2m_wmo) + + CALL acc1d (forc_rain, a_rain ) + CALL acc1d (forc_snow, a_snow ) + + IF (DEF_USE_OZONESTRESS)THEN + CALL acc1d(o3uptakesun,a_o3uptakesun) + CALL acc1d(o3uptakesha,a_o3uptakesha) + ENDIF + +#ifdef DataAssimilation + CALL acc3d (h2osoi_ens , a_h2osoi_ens ) + CALL acc3d (t_brt_smap_ens , a_t_brt_smap_ens ) + CALL acc2d (t_brt_smap , a_t_brt_smap ) + CALL acc3d (t_brt_fy3d_ens , a_t_brt_fy3d_ens ) + CALL acc2d (t_brt_fy3d , a_t_brt_fy3d ) + CALL acc3d (wliq_soisno_ens, a_wliq_soisno_ens) + CALL acc3d (wice_soisno_ens, a_wice_soisno_ens) + CALL acc3d (t_soisno_ens , a_t_soisno_ens ) +#endif + +#ifdef URBAN_MODEL + IF (numurban > 0) THEN + CALL acc1d(t_room , a_t_room ) + CALL acc1d(tafu , a_tafu ) + CALL acc1d(fhac , a_fhac ) + CALL acc1d(fwst , a_fwst ) + CALL acc1d(fach , a_fach ) + CALL acc1d(fahe , a_fahe ) + CALL acc1d(fhah , a_fhah ) + CALL acc1d(vehc , a_vehc ) + CALL acc1d(meta , a_meta ) + + CALL acc1d(fsen_roof , a_senroof ) + CALL acc1d(fsen_wsun , a_senwsun ) + CALL acc1d(fsen_wsha , a_senwsha ) + CALL acc1d(fsen_gimp , a_sengimp ) + CALL acc1d(fsen_gper , a_sengper ) + CALL acc1d(fsen_urbl , a_senurbl ) + + CALL acc1d(lfevp_roof , a_lfevproof ) + CALL acc1d(lfevp_gimp , a_lfevpgimp ) + CALL acc1d(lfevp_gper , a_lfevpgper ) + CALL acc1d(lfevp_urbl , a_lfevpurbl ) + + CALL acc1d(t_roof , a_troof ) + CALL acc1d(t_wall , a_twall ) + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL acc1d (lai_enftemp , a_lai_enftemp ) + CALL acc1d (lai_enfboreal , a_lai_enfboreal ) + CALL acc1d (lai_dnfboreal , a_lai_dnfboreal ) + CALL acc1d (lai_ebftrop , a_lai_ebftrop ) + CALL acc1d (lai_ebftemp , a_lai_ebftemp ) + CALL acc1d (lai_dbftrop , a_lai_dbftrop ) + CALL acc1d (lai_dbftemp , a_lai_dbftemp ) + CALL acc1d (lai_dbfboreal , a_lai_dbfboreal ) + CALL acc1d (lai_ebstemp , a_lai_ebstemp ) + CALL acc1d (lai_dbstemp , a_lai_dbstemp ) + CALL acc1d (lai_dbsboreal , a_lai_dbsboreal ) + CALL acc1d (lai_c3arcgrass , a_lai_c3arcgrass ) + CALL acc1d (lai_c3grass , a_lai_c3grass ) + CALL acc1d (lai_c4grass , a_lai_c4grass ) +#endif +#ifdef BGC + CALL acc1d (leafc , a_leafc ) + CALL acc1d (leafc_storage , a_leafc_storage ) + CALL acc1d (leafc_xfer , a_leafc_xfer ) + CALL acc1d (frootc , a_frootc ) + CALL acc1d (frootc_storage , a_frootc_storage ) + CALL acc1d (frootc_xfer , a_frootc_xfer ) + CALL acc1d (livestemc , a_livestemc ) + CALL acc1d (livestemc_storage , a_livestemc_storage ) + CALL acc1d (livestemc_xfer , a_livestemc_xfer ) + CALL acc1d (deadstemc , a_deadstemc ) + CALL acc1d (deadstemc_storage , a_deadstemc_storage ) + CALL acc1d (deadstemc_xfer , a_deadstemc_xfer ) + CALL acc1d (livecrootc , a_livecrootc ) + CALL acc1d (livecrootc_storage , a_livecrootc_storage ) + CALL acc1d (livecrootc_xfer , a_livecrootc_xfer ) + CALL acc1d (deadcrootc , a_deadcrootc ) + CALL acc1d (deadcrootc_storage , a_deadcrootc_storage ) + CALL acc1d (deadcrootc_xfer , a_deadcrootc_xfer ) + CALL acc1d (grainc , a_grainc ) + CALL acc1d (grainc_storage , a_grainc_storage ) + CALL acc1d (grainc_xfer , a_grainc_xfer ) + CALL acc1d (leafn , a_leafn ) + CALL acc1d (leafn_storage , a_leafn_storage ) + CALL acc1d (leafn_xfer , a_leafn_xfer ) + CALL acc1d (frootn , a_frootn ) + CALL acc1d (frootn_storage , a_frootn_storage ) + CALL acc1d (frootn_xfer , a_frootn_xfer ) + CALL acc1d (livestemn , a_livestemn ) + CALL acc1d (livestemn_storage , a_livestemn_storage ) + CALL acc1d (livestemn_xfer , a_livestemn_xfer ) + CALL acc1d (deadstemn , a_deadstemn ) + CALL acc1d (deadstemn_storage , a_deadstemn_storage ) + CALL acc1d (deadstemn_xfer , a_deadstemn_xfer ) + CALL acc1d (livecrootn , a_livecrootn ) + CALL acc1d (livecrootn_storage , a_livecrootn_storage ) + CALL acc1d (livecrootn_xfer , a_livecrootn_xfer ) + CALL acc1d (deadcrootn , a_deadcrootn ) + CALL acc1d (deadcrootn_storage , a_deadcrootn_storage ) + CALL acc1d (deadcrootn_xfer , a_deadcrootn_xfer ) + CALL acc1d (grainn , a_grainn ) + CALL acc1d (grainn_storage , a_grainn_storage ) + CALL acc1d (grainn_xfer , a_grainn_xfer ) + CALL acc1d (retransn , a_retransn ) + CALL acc1d (gpp , a_gpp ) + CALL acc1d (downreg , a_downreg ) + CALL acc1d (ar , a_ar ) + CALL acc1d (cwdprod , a_cwdprod ) + CALL acc1d (cwddecomp , a_cwddecomp ) + CALL acc1d (decomp_hr , a_hr ) + CALL acc1d (fpg , a_fpg ) + CALL acc1d (fpi , a_fpi ) + CALL acc1d (totvegc , a_totvegc ) + CALL acc1d (totlitc , a_totlitc ) + CALL acc1d (totcwdc , a_totcwdc ) + CALL acc1d (totsomc , a_totsomc ) + CALL acc1d (totcolc , a_totcolc ) + CALL acc1d (totvegn , a_totvegn ) + CALL acc1d (totlitn , a_totlitn ) + CALL acc1d (totcwdn , a_totcwdn ) + CALL acc1d (totsomn , a_totsomn ) + CALL acc1d (totcoln , a_totcoln ) + CALL acc1d (gpp_enftemp , a_gpp_enftemp ) + CALL acc1d (gpp_enfboreal , a_gpp_enfboreal ) + CALL acc1d (gpp_dnfboreal , a_gpp_dnfboreal ) + CALL acc1d (gpp_ebftrop , a_gpp_ebftrop ) + CALL acc1d (gpp_ebftemp , a_gpp_ebftemp ) + CALL acc1d (gpp_dbftrop , a_gpp_dbftrop ) + CALL acc1d (gpp_dbftemp , a_gpp_dbftemp ) + CALL acc1d (gpp_dbfboreal , a_gpp_dbfboreal ) + CALL acc1d (gpp_ebstemp , a_gpp_ebstemp ) + CALL acc1d (gpp_dbstemp , a_gpp_dbstemp ) + CALL acc1d (gpp_dbsboreal , a_gpp_dbsboreal ) + CALL acc1d (gpp_c3arcgrass , a_gpp_c3arcgrass ) + CALL acc1d (gpp_c3grass , a_gpp_c3grass ) + CALL acc1d (gpp_c4grass , a_gpp_c4grass ) + CALL acc1d (npp_enftemp , a_npp_enftemp ) + CALL acc1d (npp_enfboreal , a_npp_enfboreal ) + CALL acc1d (npp_dnfboreal , a_npp_dnfboreal ) + CALL acc1d (npp_ebftrop , a_npp_ebftrop ) + CALL acc1d (npp_ebftemp , a_npp_ebftemp ) + CALL acc1d (npp_dbftrop , a_npp_dbftrop ) + CALL acc1d (npp_dbftemp , a_npp_dbftemp ) + CALL acc1d (npp_dbfboreal , a_npp_dbfboreal ) + CALL acc1d (npp_ebstemp , a_npp_ebstemp ) + CALL acc1d (npp_dbstemp , a_npp_dbstemp ) + CALL acc1d (npp_dbsboreal , a_npp_dbsboreal ) + CALL acc1d (npp_c3arcgrass , a_npp_c3arcgrass ) + CALL acc1d (npp_c3grass , a_npp_c3grass ) + CALL acc1d (npp_c4grass , a_npp_c4grass ) + CALL acc1d (npptoleafc_enftemp , a_npptoleafc_enftemp ) + CALL acc1d (npptoleafc_enfboreal , a_npptoleafc_enfboreal ) + CALL acc1d (npptoleafc_dnfboreal , a_npptoleafc_dnfboreal ) + CALL acc1d (npptoleafc_ebftrop , a_npptoleafc_ebftrop ) + CALL acc1d (npptoleafc_ebftemp , a_npptoleafc_ebftemp ) + CALL acc1d (npptoleafc_dbftrop , a_npptoleafc_dbftrop ) + CALL acc1d (npptoleafc_dbftemp , a_npptoleafc_dbftemp ) + CALL acc1d (npptoleafc_dbfboreal , a_npptoleafc_dbfboreal ) + CALL acc1d (npptoleafc_ebstemp , a_npptoleafc_ebstemp ) + CALL acc1d (npptoleafc_dbstemp , a_npptoleafc_dbstemp ) + CALL acc1d (npptoleafc_dbsboreal , a_npptoleafc_dbsboreal ) + CALL acc1d (npptoleafc_c3arcgrass , a_npptoleafc_c3arcgrass ) + CALL acc1d (npptoleafc_c3grass , a_npptoleafc_c3grass ) + CALL acc1d (npptoleafc_c4grass , a_npptoleafc_c4grass ) + CALL acc1d (leafc_enftemp , a_leafc_enftemp ) + CALL acc1d (leafc_enfboreal , a_leafc_enfboreal ) + CALL acc1d (leafc_dnfboreal , a_leafc_dnfboreal ) + CALL acc1d (leafc_ebftrop , a_leafc_ebftrop ) + CALL acc1d (leafc_ebftemp , a_leafc_ebftemp ) + CALL acc1d (leafc_dbftrop , a_leafc_dbftrop ) + CALL acc1d (leafc_dbftemp , a_leafc_dbftemp ) + CALL acc1d (leafc_dbfboreal , a_leafc_dbfboreal ) + CALL acc1d (leafc_ebstemp , a_leafc_ebstemp ) + CALL acc1d (leafc_dbstemp , a_leafc_dbstemp ) + CALL acc1d (leafc_dbsboreal , a_leafc_dbsboreal ) + CALL acc1d (leafc_c3arcgrass , a_leafc_c3arcgrass ) + CALL acc1d (leafc_c3grass , a_leafc_c3grass ) + CALL acc1d (leafc_c4grass , a_leafc_c4grass ) + IF(DEF_USE_NITRIF)THEN + CALL acc2d (to2_decomp_depth_unsat, a_O2_DECOMP_DEPTH_UNSAT) + CALL acc2d (tconc_o2_unsat , a_CONC_O2_UNSAT ) + ENDIF +#ifdef CROP + CALL acc1d (pdcorn , a_pdcorn ) + CALL acc1d (pdswheat , a_pdswheat ) + CALL acc1d (pdwwheat , a_pdwwheat ) + CALL acc1d (pdsoybean , a_pdsoybean ) + CALL acc1d (pdcotton , a_pdcotton ) + CALL acc1d (pdrice1 , a_pdrice1 ) + CALL acc1d (pdrice2 , a_pdrice2 ) + CALL acc1d (pdsugarcane , a_pdsugarcane ) + CALL acc1d (plantdate , a_plantdate ) + CALL acc1d (manunitro , a_manunitro ) + CALL acc1d (fertnitro_corn , a_fertnitro_corn ) + CALL acc1d (fertnitro_swheat , a_fertnitro_swheat ) + CALL acc1d (fertnitro_wwheat , a_fertnitro_wwheat ) + CALL acc1d (fertnitro_soybean , a_fertnitro_soybean ) + CALL acc1d (fertnitro_cotton , a_fertnitro_cotton ) + CALL acc1d (fertnitro_rice1 , a_fertnitro_rice1 ) + CALL acc1d (fertnitro_rice2 , a_fertnitro_rice2 ) + CALL acc1d (fertnitro_sugarcane, a_fertnitro_sugarcane) + CALL acc1d (real(irrig_method_corn ,r8), a_irrig_method_corn ) + CALL acc1d (real(irrig_method_swheat ,r8), a_irrig_method_swheat ) + CALL acc1d (real(irrig_method_wwheat ,r8), a_irrig_method_wwheat ) + CALL acc1d (real(irrig_method_soybean ,r8), a_irrig_method_soybean ) + CALL acc1d (real(irrig_method_cotton ,r8), a_irrig_method_cotton ) + CALL acc1d (real(irrig_method_rice1 ,r8), a_irrig_method_rice1 ) + CALL acc1d (real(irrig_method_rice2 ,r8), a_irrig_method_rice2 ) + CALL acc1d (real(irrig_method_sugarcane,r8), a_irrig_method_sugarcane) + CALL acc1d (cphase , a_cphase ) + CALL acc1d (hui , a_hui ) + CALL acc1d (vf , a_vf ) + CALL acc1d (gddmaturity , a_gddmaturity ) + CALL acc1d (gddplant , a_gddplant ) + CALL acc1d (cropprod1c , a_cropprod1c ) + CALL acc1d (cropprod1c_loss , a_cropprod1c_loss ) + CALL acc1d (cropseedc_deficit , a_cropseedc_deficit ) + CALL acc1d (grainc_to_cropprodc, a_grainc_to_cropprodc) + CALL acc1d (grainc_to_seed , a_grainc_to_seed ) + CALL acc1d (fert_to_sminn , a_fert_to_sminn ) + + a_sum_irrig = sum_irrig + a_sum_irrig_count = sum_irrig_count + a_waterstorage = waterstorage + CALL acc1d (groundwater_demand , a_groundwater_demand ) + CALL acc1d (groundwater_supply , a_groundwater_supply ) + CALL acc1d (reservoirriver_demand, a_reservoirriver_demand) + CALL acc1d (reservoirriver_supply, a_reservoirriver_supply) + CALL acc1d (reservoir_supply , a_reservoir_supply) + CALL acc1d (river_supply , a_river_supply) + CALL acc1d (runoff_supply , a_runoff_supply) +#endif + CALL acc1d (ndep_to_sminn , a_ndep_to_sminn ) + IF(DEF_USE_FIRE)THEN + CALL acc1d (abm_lf , a_abm ) + CALL acc1d (gdp_lf , a_gdp ) + CALL acc1d (peatf_lf , a_peatf ) + CALL acc1d (hdm_lf , a_hdm ) + CALL acc1d (lnfm , a_lnfm ) + ENDIF + IF(DEF_USE_DiagMatrix)THEN + CALL acc1d (leafcCap ,a_leafcCap ) + CALL acc1d (leafc_storageCap ,a_leafc_storageCap ) + CALL acc1d (leafc_xferCap ,a_leafc_xferCap ) + CALL acc1d (frootcCap ,a_frootcCap ) + CALL acc1d (frootc_storageCap ,a_frootc_storageCap ) + CALL acc1d (frootc_xferCap ,a_frootc_xferCap ) + CALL acc1d (livestemcCap ,a_livestemcCap ) + CALL acc1d (livestemc_storageCap ,a_livestemc_storageCap ) + CALL acc1d (livestemc_xferCap ,a_livestemc_xferCap ) + CALL acc1d (deadstemcCap ,a_deadstemcCap ) + CALL acc1d (deadstemc_storageCap ,a_deadstemc_storageCap ) + CALL acc1d (deadstemc_xferCap ,a_deadstemc_xferCap ) + CALL acc1d (livecrootcCap ,a_livecrootcCap ) + CALL acc1d (livecrootc_storageCap,a_livecrootc_storageCap) + CALL acc1d (livecrootc_xferCap ,a_livecrootc_xferCap ) + CALL acc1d (deadcrootcCap ,a_deadcrootcCap ) + CALL acc1d (deadcrootc_storageCap,a_deadcrootc_storageCap) + CALL acc1d (deadcrootc_xferCap ,a_deadcrootc_xferCap ) + CALL acc1d (leafnCap ,a_leafnCap ) + CALL acc1d (leafn_storageCap ,a_leafn_storageCap ) + CALL acc1d (leafn_xferCap ,a_leafn_xferCap ) + CALL acc1d (frootnCap ,a_frootnCap ) + CALL acc1d (frootn_storageCap ,a_frootn_storageCap ) + CALL acc1d (frootn_xferCap ,a_frootn_xferCap ) + CALL acc1d (livestemnCap ,a_livestemnCap ) + CALL acc1d (livestemn_storageCap ,a_livestemn_storageCap ) + CALL acc1d (livestemn_xferCap ,a_livestemn_xferCap ) + CALL acc1d (deadstemnCap ,a_deadstemnCap ) + CALL acc1d (deadstemn_storageCap ,a_deadstemn_storageCap ) + CALL acc1d (deadstemn_xferCap ,a_deadstemn_xferCap ) + CALL acc1d (livecrootnCap ,a_livecrootnCap ) + CALL acc1d (livecrootn_storageCap,a_livecrootn_storageCap) + CALL acc1d (livecrootn_xferCap ,a_livecrootn_xferCap ) + CALL acc1d (deadcrootnCap ,a_deadcrootnCap ) + CALL acc1d (deadcrootn_storageCap,a_deadcrootn_storageCap) + CALL acc1d (deadcrootn_xferCap ,a_deadcrootn_xferCap ) + ENDIF +#endif + IF(DEF_USE_OZONESTRESS)THEN + CALL acc1d (forc_ozone , a_ozone ) + ENDIF + + IF (.not. DEF_USE_Dynamic_Lake) THEN + CALL acc1d (lake_deficit, a_lake_deficit) + ENDIF + + CALL acc2d (t_soisno , a_t_soisno ) + CALL acc2d (wliq_soisno , a_wliq_soisno ) + CALL acc2d (wice_soisno , a_wice_soisno ) + + CALL acc2d (h2osoi , a_h2osoi ) + CALL acc2d (qlayer , a_qlayer ) + CALL acc2d (rootr , a_rootr ) + CALL acc2d (BD_all , a_BD_all ) + CALL acc2d (wfc , a_wfc ) + CALL acc2d (OM_density , a_OM_density ) + IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL acc2d (vegwp , a_vegwp ) + ENDIF + IF (DEF_USE_Dynamic_Lake) THEN + CALL acc2d (dz_lake , a_dz_lake ) + ENDIF + CALL acc2d (t_lake , a_t_lake ) + CALL acc2d (lake_icefrac, a_lake_icefrac ) +#ifdef BGC + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_met_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr1c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cel_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr2c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_lig_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr3c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil1,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil1c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil2,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil2c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil3,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil3c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cwd,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_cwdc_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_met_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr1n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cel_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr2n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_lig_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr3n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil1,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil1n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil2,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil2n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil3,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil3n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cwd,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_cwdn_vr ) + CALL acc2d (totsoiln_vr , a_totsoiln_vr ) + + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_met_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr1cCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_cel_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr2cCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_lig_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr3cCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil1,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil1cCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil2,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil2cCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil3,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil3cCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_cwd,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_cwdcCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_met_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr1nCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_cel_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr2nCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_lig_lit,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr3nCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil1,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil1nCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil2,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil2nCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil3,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil3nCap_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil + decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_cwd,i) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_cwdnCap_vr ) + CALL acc2d (sminn_vr , a_sminn_vr ) + + CALL acc2d (t_scalar , a_t_scalar ) + CALL acc2d (w_scalar , a_w_scalar ) +#endif + allocate (r_ustar (numpatch)); r_ustar (:) = spval + allocate (r_ustar2 (numpatch)); r_ustar2(:) = spval !Shaofeng, 2023.05.20 + allocate (r_tstar (numpatch)); r_tstar (:) = spval + allocate (r_qstar (numpatch)); r_qstar (:) = spval + allocate (r_zol (numpatch)); r_zol (:) = spval + allocate (r_rib (numpatch)); r_rib (:) = spval + allocate (r_fm (numpatch)); r_fm (:) = spval + allocate (r_fh (numpatch)); r_fh (:) = spval + allocate (r_fq (numpatch)); r_fq (:) = spval + allocate (r_us10m (numpatch)); r_us10m (:) = spval + allocate (r_vs10m (numpatch)); r_vs10m (:) = spval + allocate (r_fm10m (numpatch)); r_fm10m (:) = spval + + DO ielm = 1, numelm + + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + + allocate (filter (istt:iend)) + filter(:) = .true. + + filter(:) = patchmask(istt:iend) + + IF (DEF_forcing%has_missing_value) THEN + WHERE (.not. forcmask_pch(istt:iend)) filter = .false. + filter = filter .and. forcmask_pch(istt:iend) + ENDIF + + IF (.not. any(filter)) THEN + deallocate(filter) + CYCLE + ENDIF + + sumwt = sum(elm_patch%subfrc(istt:iend), mask = filter) + + ! Aggregate variables from patches to element (gridcell in latitude-longitude mesh) + z0m_av = sum(z0m (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + hgt_u = sum(forc_hgt_u (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + hgt_t = sum(forc_hgt_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + hgt_q = sum(forc_hgt_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + us = sum(forc_us (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + vs = sum(forc_vs (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + tm = sum(forc_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + qm = sum(forc_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + psrf = sum(forc_psrf (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + taux_e = sum(taux (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + tauy_e = sum(tauy (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + fsena_e = sum(fsena (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + fevpa_e = sum(fevpa (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + hpbl = sum(forc_hpbl(istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + ENDIF + + z0h_av = z0m_av + z0q_av = z0m_av + + displa_av = 2./3.*z0m_av/0.07 + + hgt_u = max(hgt_u, 5.+displa_av) + hgt_t = max(hgt_t, 5.+displa_av) + hgt_q = max(hgt_q, 5.+displa_av) + + zldis = hgt_u-displa_av + + rhoair = (psrf - 0.378*qm*psrf/(0.622+0.378*qm)) / (rgas*tm) + + r_ustar_e = sqrt(max(1.e-6,sqrt(taux_e**2+tauy_e**2))/rhoair) + r_tstar_e = -fsena_e/(rhoair*r_ustar_e)/cpair + r_qstar_e = -fevpa_e/(rhoair*r_ustar_e) + + thm = tm + 0.0098*hgt_t + th = tm*(100000./psrf)**(rgas/cpair) + thv = th*(1.+0.61*qm) + + r_zol_e = zldis*vonkar*grav * (r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e) & + / (r_ustar_e**2*thv) + + IF(r_zol_e >= 0.)THEN !stable + r_zol_e = min(2.,max(r_zol_e,1.e-6)) + ELSE !unstable + r_zol_e = max(-100.,min(r_zol_e,-1.e-6)) + ENDIF + + beta = 1. + zii = 1000. + + thvstar=r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e + ur = sqrt(us*us+vs*vs) + IF(r_zol_e >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hgt_u,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*r_ustar_e*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = max(0.1,sqrt(ur*ur+wc2)) + ENDIF + + obu = zldis/r_zol_e + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& + obu,um, hpbl, r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20 + ELSE + CALL moninobuk(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& + obu,um,r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20 + ENDIF + + ! bug found by chen qiying 2013/07/01 + r_rib_e = r_zol_e /vonkar * r_ustar2_e**2 / (vonkar/r_fh_e*um**2) + r_rib_e = min(5.,r_rib_e) + + r_us10m_e = us/um * r_ustar2_e /vonkar * r_fm10m_e + r_vs10m_e = vs/um * r_ustar2_e /vonkar * r_fm10m_e + + ! Assign values from element (gridcell in latitude-longitude mesh) to patches. + ! Notice that all values on patches in an element are equal. + r_ustar (istt:iend) = r_ustar_e + r_ustar2(istt:iend) = r_ustar2_e + r_tstar (istt:iend) = r_tstar_e + r_qstar (istt:iend) = r_qstar_e + r_zol (istt:iend) = r_zol_e + r_rib (istt:iend) = r_rib_e + r_fm (istt:iend) = r_fm_e + r_fh (istt:iend) = r_fh_e + r_fq (istt:iend) = r_fq_e + r_us10m (istt:iend) = r_us10m_e + r_vs10m (istt:iend) = r_vs10m_e + r_fm10m (istt:iend) = r_fm10m_e + + deallocate(filter) + + ENDDO + + CALL acc1d (r_ustar , a_ustar ) + CALL acc1d (r_ustar2 , a_ustar2 ) + CALL acc1d (r_tstar , a_tstar ) + CALL acc1d (r_qstar , a_qstar ) + CALL acc1d (r_zol , a_zol ) + CALL acc1d (r_rib , a_rib ) + CALL acc1d (r_fm , a_fm ) + CALL acc1d (r_fh , a_fh ) + CALL acc1d (r_fq , a_fq ) + + CALL acc1d (r_us10m , a_us10m ) + CALL acc1d (r_vs10m , a_vs10m ) + CALL acc1d (r_fm10m , a_fm10m ) + + deallocate (r_ustar ) + deallocate (r_ustar2) !Shaofeng, 2023.05.20 + deallocate (r_tstar ) + deallocate (r_qstar ) + deallocate (r_zol ) + deallocate (r_rib ) + deallocate (r_fm ) + deallocate (r_fh ) + deallocate (r_fq ) + + deallocate (r_us10m ) + deallocate (r_vs10m ) + deallocate (r_fm10m ) + + CALL acc1d (sr , a_sr ) + CALL acc1d (solvd , a_solvd ) + CALL acc1d (solvi , a_solvi ) + CALL acc1d (solnd , a_solnd ) + CALL acc1d (solni , a_solni ) + CALL acc1d (srvd , a_srvd ) + CALL acc1d (srvi , a_srvi ) + CALL acc1d (srnd , a_srnd ) + CALL acc1d (srni , a_srni ) + CALL acc1d (solvdln , a_solvdln ) + CALL acc1d (solviln , a_solviln ) + CALL acc1d (solndln , a_solndln ) + CALL acc1d (solniln , a_solniln ) + CALL acc1d (srvdln , a_srvdln ) + CALL acc1d (srviln , a_srviln ) + CALL acc1d (srndln , a_srndln ) + CALL acc1d (srniln , a_srniln ) + + CALL acc2d (sensors , a_sensors ) +#ifdef HYPERSPECTRAL + CALL acc2d (sol_dir_ln_hires, a_sol_dir_ln_hires) + CALL acc2d (sol_dif_ln_hires, a_sol_dif_ln_hires) + CALL acc2d (sr_dir_ln_hires , a_sr_dir_ln_hires ) + CALL acc2d (sr_dif_ln_hires , a_sr_dif_ln_hires ) +#endif + + ENDIF + ENDIF + +#ifdef CatchLateralFlow + CALL accumulate_fluxes_basin () +#endif + +#ifdef EXTERNAL_LAKE + CALL accumulate_LakeTimeVars +#endif + + END SUBROUTINE accumulate_fluxes + + + !------ + SUBROUTINE acc1d (var, s) + + USE MOD_Precision + USE MOD_Vars_Global, only: spval + + IMPLICIT NONE + + real(r8), intent(in) :: var(:) + real(r8), intent(inout) :: s (:) + ! Local variables + integer :: i + + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i) + ELSE + s(i) = var(i) + ENDIF + ENDIF + ENDDO + + END SUBROUTINE acc1d + + !------ + SUBROUTINE acc2d (var, s) + + USE MOD_Precision + USE MOD_Vars_Global, only: spval + + IMPLICIT NONE + + real(r8), intent(in) :: var(:,:) + real(r8), intent(inout) :: s (:,:) + ! Local variables + integer :: i1, i2 + + DO i2 = lbound(var,2), ubound(var,2) + DO i1 = lbound(var,1), ubound(var,1) + IF (var(i1,i2) /= spval) THEN + IF (s(i1,i2) /= spval) THEN + s(i1,i2) = s(i1,i2) + var(i1,i2) + ELSE + s(i1,i2) = var(i1,i2) + ENDIF + ENDIF + ENDDO + ENDDO + + END SUBROUTINE acc2d + + !------ + SUBROUTINE acc3d (var, s, filter) + + USE MOD_Precision + USE MOD_Vars_Global, only: spval + + IMPLICIT NONE + + real(r8), intent(in) :: var(:,:,:) + real(r8), intent(inout) :: s (:,:,:) + logical, intent(in), optional :: filter(:) + + ! Local variables + integer :: i1, i2, i3 + + DO i3 = lbound(var,3), ubound(var,3) + + IF ( present(filter) ) THEN + IF ( .not. filter(i3) ) CYCLE + ENDIF + + DO i2 = lbound(var,2), ubound(var,2) + DO i1 = lbound(var,1), ubound(var,1) + IF (var(i1,i2,i3) /= spval) THEN + IF (s(i1,i2,i3) /= spval) THEN + s(i1,i2,i3) = s(i1,i2,i3) + var(i1,i2,i3) + ELSE + s(i1,i2,i3) = var(i1,i2,i3) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE acc3d + +END MODULE MOD_Vars_1DAccFluxes +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..9238a3410d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 @@ -0,0 +1,305 @@ +#include + +MODULE MOD_Vars_1DFluxes +!----------------------------------------------------------------------- +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + + USE MOD_Precision +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_1DPFTFluxes +#endif +#ifdef BGC + USE MOD_BGC_Vars_1DFluxes +#endif +#ifdef CatchLateralFlow + USE MOD_Catch_Vars_1DFluxes +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_1DFluxes +#endif +#ifdef DataAssimilation + USE MOD_DA_Vars_1DFluxes +#endif + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- +! Fluxes +!----------------------------------------------------------------------- + real(r8), allocatable :: taux (:) !wind stress: E-W [kg/m/s2] + real(r8), allocatable :: tauy (:) !wind stress: N-S [kg/m/s2] + real(r8), allocatable :: fsena (:) !sensible heat from canopy height to atmosphere [W/m2] + real(r8), allocatable :: lfevpa (:) !latent heat flux from canopy height to atmosphere [W/m2] + real(r8), allocatable :: fevpa (:) !evapotranspiration from canopy to atmosphere [mm/s] + real(r8), allocatable :: fsenl (:) !sensible heat from leaves [W/m2] + real(r8), allocatable :: fevpl (:) !evaporation+transpiration from leaves [mm/s] + real(r8), allocatable :: etr (:) !transpiration rate [mm/s] + real(r8), allocatable :: fseng (:) !sensible heat flux from ground [W/m2] + real(r8), allocatable :: fevpg (:) !evaporation heat flux from ground [mm/s] + real(r8), allocatable :: fgrnd (:) !ground heat flux [W/m2] + real(r8), allocatable :: sabvsun(:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: sabvsha(:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: sabg (:) !solar absorbed by ground [W/m2] + real(r8), allocatable :: sr (:) !total reflected solar radiation (W/m2) + real(r8), allocatable :: solvd (:) !incident direct beam vis solar radiation (W/m2) + real(r8), allocatable :: solvi (:) !incident diffuse beam vis solar radiation (W/m2) + real(r8), allocatable :: solnd (:) !incident direct beam nir solar radiation (W/m2) + real(r8), allocatable :: solni (:) !incident diffuse beam nir solar radiation (W/m2) + real(r8), allocatable :: srvd (:) !reflected direct beam vis solar radiation (W/m2) + real(r8), allocatable :: srvi (:) !reflected diffuse beam vis solar radiation (W/m2) + real(r8), allocatable :: srnd (:) !reflected direct beam nir solar radiation (W/m2) + real(r8), allocatable :: srni (:) !reflected diffuse beam nir solar radiation (W/m2) + real(r8), allocatable :: solvdln(:) !incident direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: solviln(:) !incident diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: solndln(:) !incident direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: solniln(:) !incident diffuse beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: srvdln (:) !reflected direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: srviln (:) !reflected diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: srndln (:) !reflected direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: srniln (:) !reflected diffuse beam nir solar radiation at local noon (W/m2) +#ifdef HYPERSPECTRAL + real(r8), allocatable :: sol_dir_ln_hires(:,:) !incident direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: sol_dif_ln_hires(:,:) !incident diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: sr_dir_ln_hires (:,:) !reflected direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: sr_dif_ln_hires (:,:) !reflected diffuse beam nir solar radiation at local noon (W/m2) +#endif + real(r8), allocatable :: olrg (:) !outgoing long-wave radiation from ground+canopy [W/m2] + real(r8), allocatable :: rnet (:) !net radiation by surface [W/m2] + real(r8), allocatable :: xerr (:) !the error of water balance [mm/s] + real(r8), allocatable :: zerr (:) !the error of energy balance [W/m2] + real(r8), allocatable :: frcsat (:) !fraction of saturation area [-] + real(r8), allocatable :: rsur (:) !surface runoff (mm h2o/s) + real(r8), allocatable :: rsur_se(:) !saturation excess surface runoff (mm h2o/s) + real(r8), allocatable :: rsur_ie(:) !infiltration excess surface runoff (mm h2o/s) + real(r8), allocatable :: rsub (:) !subsurface runoff (mm h2o/s) + real(r8), allocatable :: rnof (:) !total runoff (mm h2o/s) + real(r8), allocatable :: qintr (:) !interception (mm h2o/s) + real(r8), allocatable :: qinfl (:) !infiltration (mm h2o/s) + real(r8), allocatable :: qdrip (:) !throughfall (mm h2o/s) + real(r8), allocatable :: assim (:) !canopy assimilation rate (mol m-2 s-1) + real(r8), allocatable :: respc (:) !canopy respiration (mol m-2 s-1) + + real(r8), allocatable :: qcharge(:) !groundwater recharge [mm/s] + + real(r8), allocatable :: qlayer (:,:) !water flux at between soil layer [mm h2o/s] + real(r8), allocatable :: lake_deficit (:) !lake deficit due to evaporation (mm h2o/s) + + real(r8), allocatable :: oroflag(:) !/ocean(0)/seaice(2) flag + + integer, parameter :: nsensor = 1 + real(r8), allocatable :: sensors(:,:) + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_Fluxes + PUBLIC :: deallocate_1D_Fluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_Fluxes + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! ------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate ( taux (numpatch) ) ; taux (:) = spval ! wind stress: E-W [kg/m/s2] + allocate ( tauy (numpatch) ) ; tauy (:) = spval ! wind stress: N-S [kg/m/s2] + allocate ( fsena (numpatch) ) ; fsena (:) = spval ! sensible heat from canopy height to atmosphere [W/m2] + allocate ( lfevpa (numpatch) ) ; lfevpa (:) = spval ! latent heat flux from canopy height to atmosphere [W/m2] + allocate ( fevpa (numpatch) ) ; fevpa (:) = spval ! evapotranspiration from canopy to atmosphere [mm/s] + allocate ( fsenl (numpatch) ) ; fsenl (:) = spval ! sensible heat from leaves [W/m2] + allocate ( fevpl (numpatch) ) ; fevpl (:) = spval ! evaporation+transpiration from leaves [mm/s] + allocate ( etr (numpatch) ) ; etr (:) = spval ! transpiration rate [mm/s] + allocate ( fseng (numpatch) ) ; fseng (:) = spval ! sensible heat flux from ground [W/m2] + allocate ( fevpg (numpatch) ) ; fevpg (:) = spval ! evaporation heat flux from ground [mm/s] + allocate ( fgrnd (numpatch) ) ; fgrnd (:) = spval ! ground heat flux [W/m2] + allocate ( sabvsun(numpatch) ) ; sabvsun(:) = spval ! solar absorbed by sunlit vegetation [W/m2] + allocate ( sabvsha(numpatch) ) ; sabvsha(:) = spval ! solar absorbed by shaded vegetation [W/m2] + allocate ( sabg (numpatch) ) ; sabg (:) = spval ! solar absorbed by ground [W/m2] + allocate ( sr (numpatch) ) ; sr (:) = spval ! incident direct beam vis solar radiation (W/m2) + allocate ( solvd (numpatch) ) ; solvd (:) = spval ! incident direct beam vis solar radiation (W/m2) + allocate ( solvi (numpatch) ) ; solvi (:) = spval ! incident diffuse beam vis solar radiation (W/m2) + allocate ( solnd (numpatch) ) ; solnd (:) = spval ! incident direct beam nir solar radiation (W/m2) + allocate ( solni (numpatch) ) ; solni (:) = spval ! incident diffuse beam nir solar radiation (W/m2) + allocate ( srvd (numpatch) ) ; srvd (:) = spval ! reflected direct beam vis solar radiation (W/m2) + allocate ( srvi (numpatch) ) ; srvi (:) = spval ! reflected diffuse beam vis solar radiation (W/m2) + allocate ( srnd (numpatch) ) ; srnd (:) = spval ! reflected direct beam nir solar radiation (W/m2) + allocate ( srni (numpatch) ) ; srni (:) = spval ! reflected diffuse beam nir solar radiation (W/m2) + allocate ( solvdln(numpatch) ) ; solvdln(:) = spval ! incident direct beam vis solar radiation at local noon(W/m2) + allocate ( solviln(numpatch) ) ; solviln(:) = spval ! incident diffuse beam vis solar radiation at local noon(W/m2) + allocate ( solndln(numpatch) ) ; solndln(:) = spval ! incident direct beam nir solar radiation at local noon(W/m2) + allocate ( solniln(numpatch) ) ; solniln(:) = spval ! incident diffuse beam nir solar radiation at local noon(W/m2) + allocate ( srvdln (numpatch) ) ; srvdln (:) = spval ! reflected direct beam vis solar radiation at local noon(W/m2) + allocate ( srviln (numpatch) ) ; srviln (:) = spval ! reflected diffuse beam vis solar radiation at local noon(W/m2) + allocate ( srndln (numpatch) ) ; srndln (:) = spval ! reflected direct beam nir solar radiation at local noon(W/m2) + allocate ( srniln (numpatch) ) ; srniln (:) = spval ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#ifdef HYPERSPECTRAL + allocate ( sol_dir_ln_hires(211,numpatch) ) ; sol_dir_ln_hires(:,:) = spval ! incident direct beam vis solar radiation at local noon(W/m2) + allocate ( sol_dif_ln_hires(211,numpatch) ) ; sol_dif_ln_hires(:,:) = spval ! incident diffuse beam vis solar radiation at local noon(W/m2) + allocate ( sr_dir_ln_hires (211,numpatch) ) ; sr_dir_ln_hires (:,:) = spval ! reflected direct beam nir solar radiation at local noon(W/m2) + allocate ( sr_dif_ln_hires (211,numpatch) ) ; sr_dif_ln_hires (:,:) = spval ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#endif + allocate ( olrg (numpatch) ) ; olrg (:) = spval ! outgoing long-wave radiation from ground+canopy [W/m2] + allocate ( rnet (numpatch) ) ; rnet (:) = spval ! net radiation by surface [W/m2] + allocate ( xerr (numpatch) ) ; xerr (:) = spval ! the error of water balance [mm/s] + allocate ( zerr (numpatch) ) ; zerr (:) = spval ! the error of energy balance [W/m2] + + allocate ( frcsat (numpatch) ) ; frcsat (:) = spval ! fraction of saturation area [-] + allocate ( rsur (numpatch) ) ; rsur (:) = spval ! surface runoff (mm h2o/s) + allocate ( rsur_se(numpatch) ) ; rsur_se(:) = spval ! saturation excess surface runoff (mm h2o/s) + allocate ( rsur_ie(numpatch) ) ; rsur_ie(:) = spval ! infiltration excess surface runoff (mm h2o/s) + allocate ( rsub (numpatch) ) ; rsub (:) = spval ! subsurface runoff (mm h2o/s) + allocate ( rnof (numpatch) ) ; rnof (:) = spval ! total runoff (mm h2o/s) + allocate ( qintr (numpatch) ) ; qintr (:) = spval ! interception (mm h2o/s) + allocate ( qinfl (numpatch) ) ; qinfl (:) = spval ! infiltration (mm h2o/s) + allocate ( qdrip (numpatch) ) ; qdrip (:) = spval ! throughfall (mm h2o/s) + allocate ( assim (numpatch) ) ; assim (:) = spval ! canopy assimilation rate (mol m-2 s-1) + allocate ( respc (numpatch) ) ; respc (:) = spval ! canopy respiration (mol m-2 s-1) + + allocate ( qcharge(numpatch) ) ; qcharge(:) = spval ! groundwater recharge [mm/s] + + allocate ( qlayer (0:nl_soil,numpatch) ); qlayer(:,:) = spval ! water flux between soil layer [mm h2o/s] + allocate ( lake_deficit (numpatch) ); lake_deficit(:) = spval ! lake deficit due to evaporation (mm h2o/s) + + allocate ( oroflag(numpatch) ) ; oroflag(:) = 1.0 ! /ocean(0)/seaice(2) flag + + allocate ( sensors(nsensor,numpatch) ); sensors(:,:) = spval ! + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL allocate_1D_PFTFluxes +#endif + +#ifdef BGC + CALL allocate_1D_BGCFluxes +#endif + +#ifdef CatchLateralFlow + CALL allocate_1D_CatchFluxes +#endif + +#ifdef URBAN_MODEL + CALL allocate_1D_UrbanFluxes +#endif + +#ifdef DataAssimilation + CALL allocate_1D_DAFluxes +#endif + + END SUBROUTINE allocate_1D_Fluxes + + SUBROUTINE deallocate_1D_Fluxes () + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPatch + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + deallocate ( taux ) ! wind stress: E-W [kg/m/s2] + deallocate ( tauy ) ! wind stress: N-S [kg/m/s2] + deallocate ( fsena ) ! sensible heat from canopy height to atmosphere [W/m2] + deallocate ( lfevpa ) ! latent heat flux from canopy height to atmosphere [W/m2] + deallocate ( fevpa ) ! evapotranspiration from canopy to atmosphere [mm/s] + deallocate ( fsenl ) ! sensible heat from leaves [W/m2] + deallocate ( fevpl ) ! evaporation+transpiration from leaves [mm/s] + deallocate ( etr ) ! transpiration rate [mm/s] + deallocate ( fseng ) ! sensible heat flux from ground [W/m2] + deallocate ( fevpg ) ! evaporation heat flux from ground [mm/s] + deallocate ( fgrnd ) ! ground heat flux [W/m2] + deallocate ( sabvsun ) ! solar absorbed by sunlit vegetation [W/m2] + deallocate ( sabvsha ) ! solar absorbed by shaded vegetation [W/m2] + deallocate ( sabg ) ! solar absorbed by ground [W/m2] + deallocate ( sr ) ! incident direct beam vis solar radiation (W/m2) + deallocate ( solvd ) ! incident direct beam vis solar radiation (W/m2) + deallocate ( solvi ) ! incident diffuse beam vis solar radiation (W/m2) + deallocate ( solnd ) ! incident direct beam nir solar radiation (W/m2) + deallocate ( solni ) ! incident diffuse beam nir solar radiation (W/m2) + deallocate ( srvd ) ! reflected direct beam vis solar radiation (W/m2) + deallocate ( srvi ) ! reflected diffuse beam vis solar radiation (W/m2) + deallocate ( srnd ) ! reflected direct beam nir solar radiation (W/m2) + deallocate ( srni ) ! reflected diffuse beam nir solar radiation (W/m2) + deallocate ( solvdln ) ! incident direct beam vis solar radiation at local noon(W/m2) + deallocate ( solviln ) ! incident diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( solndln ) ! incident direct beam nir solar radiation at local noon(W/m2) + deallocate ( solniln ) ! incident diffuse beam nir solar radiation at local noon(W/m2) + deallocate ( srvdln ) ! reflected direct beam vis solar radiation at local noon(W/m2) + deallocate ( srviln ) ! reflected diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( srndln ) ! reflected direct beam nir solar radiation at local noon(W/m2) + deallocate ( srniln ) ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#ifdef HYPERSPECTRAL + deallocate ( sol_dir_ln_hires ) ! incident direct beam vis solar radiation at local noon(W/m2) + deallocate ( sol_dif_ln_hires ) ! incident diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( sr_dir_ln_hires ) ! reflected direct beam nir solar radiation at local noon(W/m2) + deallocate ( sr_dif_ln_hires ) ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#endif + deallocate ( olrg ) ! outgoing long-wave radiation from ground+canopy [W/m2] + deallocate ( rnet ) ! net radiation by surface [W/m2] + deallocate ( xerr ) ! the error of water balance [mm/s] + deallocate ( zerr ) ! the error of energy balance [W/m2] + deallocate ( frcsat ) ! fraction of saturation area [-] + deallocate ( rsur ) ! surface runoff (mm h2o/s) + deallocate ( rsur_se ) ! saturation excess surface runoff (mm h2o/s) + deallocate ( rsur_ie ) ! infiltration excess surface runoff (mm h2o/s) + deallocate ( rsub ) ! subsurface runoff (mm h2o/s) + deallocate ( rnof ) ! total runoff (mm h2o/s) + deallocate ( qintr ) ! interception (mm h2o/s) + deallocate ( qinfl ) ! infiltration (mm h2o/s) + deallocate ( qdrip ) ! throughfall (mm h2o/s) + deallocate ( assim ) ! canopy assimilation rate (mol m-2 s-1) + deallocate ( respc ) ! canopy respiration (mol m-2 s-1) + + deallocate ( qcharge ) ! groundwater recharge [mm/s] + deallocate ( qlayer ) ! water flux between soil layer [mm h2o/s] + deallocate ( lake_deficit ) ! lake deficit due to evaporation (mm h2o/s) + + deallocate ( oroflag ) ! + + deallocate ( sensors ) ! + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL deallocate_1D_PFTFluxes +#endif + +#ifdef BGC + CALL deallocate_1D_BGCFluxes +#endif + +#ifdef CatchLateralFlow + CALL deallocate_1D_CatchFluxes +#endif + +#ifdef URBAN_MODEL + CALL deallocate_1D_UrbanFluxes +#endif + +#ifdef DataAssimilation + CALL deallocate_1D_DAFluxes +#endif + + END SUBROUTINE deallocate_1D_Fluxes + +END MODULE MOD_Vars_1DFluxes +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 new file mode 100644 index 0000000000..6075b103de --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 @@ -0,0 +1,167 @@ +#include + +MODULE MOD_Vars_1DForcing +!----------------------------------------------------------------------- +! Meteorological Forcing +! +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- + real(r8), allocatable :: forc_pco2m (:) ! CO2 concentration in atmos. (pascals) + real(r8), allocatable :: forc_po2m (:) ! O2 concentration in atmos. (pascals) + real(r8), allocatable :: forc_us (:) ! wind in eastward direction [m/s] + real(r8), allocatable :: forc_vs (:) ! wind in northward direction [m/s] + real(r8), allocatable :: forc_t (:) ! temperature at reference height [kelvin] + real(r8), allocatable :: forc_q (:) ! specific humidity at reference height [kg/kg] + real(r8), allocatable :: forc_prc (:) ! convective precipitation [mm/s] + real(r8), allocatable :: forc_prl (:) ! large scale precipitation [mm/s] + real(r8), allocatable :: forc_rain (:) ! rain [mm/s] + real(r8), allocatable :: forc_snow (:) ! snow [mm/s] + real(r8), allocatable :: forc_psrf (:) ! atmospheric pressure at the surface [pa] + real(r8), allocatable :: forc_pbot (:) ! atm bottom level pressure (or reference height) (pa) + real(r8), allocatable :: forc_sols (:) ! atm vis direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_soll (:) ! atm nir direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solsd (:) ! atm vis diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solld (:) ! atm nir diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_frl (:) ! atmospheric infrared (longwave) radiation [W/m2] + real(r8), allocatable :: forc_swrad (:) ! atmospheric shortwave radiation [W/m2] + real(r8), allocatable :: forc_hgt_u (:) ! observational height of wind [m] + real(r8), allocatable :: forc_hgt_t (:) ! observational height of temperature [m] + real(r8), allocatable :: forc_hgt_q (:) ! observational height of humidity [m] + real(r8), allocatable :: forc_rhoair(:) ! air density [kg/m3] + real(r8), allocatable :: forc_ozone (:) ! air density [kg/m3] +#ifdef HYPERSPECTRAL + real(r8), allocatable :: forc_solarin(:) ! incident solar radiation [W/m2] +#endif + + real(r8), allocatable :: forc_topo (:) ! topography [m] + + real(r8), allocatable :: forc_hpbl (:) ! atmospheric boundary layer height [m] + real(r8), allocatable :: forc_aerdep(:,:) ! atmospheric aerosol deposition data [kg/m/s] + + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_Forcing + PUBLIC :: deallocate_1D_Forcing + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- +CONTAINS +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_Forcing + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! ------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_LandPatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate (forc_pco2m (numpatch) ) ! CO2 concentration in atmos. (pascals) + allocate (forc_po2m (numpatch) ) ! O2 concentration in atmos. (pascals) + allocate (forc_us (numpatch) ) ! wind in eastward direction [m/s] + allocate (forc_vs (numpatch) ) ! wind in northward direction [m/s] + allocate (forc_t (numpatch) ) ! temperature at reference height [kelvin] + allocate (forc_q (numpatch) ) ! specific humidity at reference height [kg/kg] + allocate (forc_prc (numpatch) ) ! convective precipitation [mm/s] + allocate (forc_prl (numpatch) ) ! large scale precipitation [mm/s] + allocate (forc_rain (numpatch) ) ! rain [mm/s] + allocate (forc_snow (numpatch) ) ! snow [mm/s] + allocate (forc_psrf (numpatch) ) ! atmospheric pressure at the surface [pa] + allocate (forc_pbot (numpatch) ) ! atm bottom level pressure (or reference height) (pa) +#ifdef HYPERSPECTRAL + allocate (forc_solarin(numpatch) ) ! solar rad onto srf [W/m2] +#endif + allocate (forc_sols (numpatch) ) ! atm vis direct beam solar rad onto srf [W/m2] + allocate (forc_soll (numpatch) ) ! atm nir direct beam solar rad onto srf [W/m2] + allocate (forc_solsd (numpatch) ) ! atm vis diffuse solar rad onto srf [W/m2] + allocate (forc_solld (numpatch) ) ! atm nir diffuse solar rad onto srf [W/m2] + allocate (forc_frl (numpatch) ) ! atmospheric infrared (longwave) radiation [W/m2] + allocate (forc_swrad (numpatch) ) ! atmospheric shortwave radiation [W/m2] + allocate (forc_hgt_u (numpatch) ) ! observational height of wind [m] + allocate (forc_hgt_t (numpatch) ) ! observational height of temperature [m] + allocate (forc_hgt_q (numpatch) ) ! observational height of humidity [m] + allocate (forc_rhoair (numpatch) ) ! air density [kg/m3] + allocate (forc_ozone (numpatch) ) ! air density [kg/m3] + + allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] + + IF (DEF_USE_Forcing_Downscaling) THEN + allocate (forc_topo (numpatch)) + ENDIF + + allocate (forc_aerdep(14,numpatch) ) ! atmospheric aerosol deposition data [kg/m/s] + + ENDIF + + ENDIF + + END SUBROUTINE allocate_1D_Forcing + + + SUBROUTINE deallocate_1D_Forcing () + + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_LandPatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + deallocate ( forc_pco2m ) ! CO2 concentration in atmos. (pascals) + deallocate ( forc_po2m ) ! O2 concentration in atmos. (pascals) + deallocate ( forc_us ) ! wind in eastward direction [m/s] + deallocate ( forc_vs ) ! wind in northward direction [m/s] + deallocate ( forc_t ) ! temperature at reference height [kelvin] + deallocate ( forc_q ) ! specific humidity at reference height [kg/kg] + deallocate ( forc_prc ) ! convective precipitation [mm/s] + deallocate ( forc_prl ) ! large scale precipitation [mm/s] + deallocate ( forc_rain ) ! rain [mm/s] + deallocate ( forc_snow ) ! snow [mm/s] + deallocate ( forc_psrf ) ! atmospheric pressure at the surface [pa] + deallocate ( forc_pbot ) ! atm bottom level pressure (or reference height) (pa) +#ifdef HYPERSPECTRAL + deallocate ( forc_solarin) ! solar rad onto srf [W/m2] +#endif + deallocate ( forc_sols ) ! atm vis direct beam solar rad onto srf [W/m2] + deallocate ( forc_soll ) ! atm nir direct beam solar rad onto srf [W/m2] + deallocate ( forc_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] + deallocate ( forc_solld ) ! atm nir diffuse solar rad onto srf [W/m2] + deallocate ( forc_frl ) ! atmospheric infrared (longwave) radiation [W/m2] + deallocate ( forc_swrad ) ! atmospheric shortwave radiation [W/m2] + deallocate ( forc_hgt_u ) ! observational height of wind [m] + deallocate ( forc_hgt_t ) ! observational height of temperature [m] + deallocate ( forc_hgt_q ) ! observational height of humidity [m] + deallocate ( forc_rhoair ) ! air density [kg/m3] + deallocate ( forc_ozone ) ! Ozone partial pressure [mol/mol] + + deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] + + IF (DEF_USE_Forcing_Downscaling) THEN + deallocate (forc_topo) + ENDIF + + deallocate ( forc_aerdep ) ! atmospheric aerosol deposition data [kg/m/s] + + ENDIF + + ENDIF + + END SUBROUTINE deallocate_1D_Forcing + +END MODULE MOD_Vars_1DForcing +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 new file mode 100644 index 0000000000..e7ba1d5ec5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 @@ -0,0 +1,173 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_Vars_1DPFTFluxes +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Define PFT flux variables +! +! Created by Hua Yuan, 08/2019 +!----------------------------------------------------------------------- + + USE MOD_Precision +#ifdef BGC + USE MOD_BGC_Vars_1DPFTFluxes +#endif + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- +! Fluxes +!----------------------------------------------------------------------- + real(r8), allocatable :: taux_p (:) !wind stress: E-W [kg/m/s2] + real(r8), allocatable :: tauy_p (:) !wind stress: N-S [kg/m/s2] + real(r8), allocatable :: fsenl_p (:) !sensible heat from leaves [W/m2] + real(r8), allocatable :: fevpl_p (:) !evaporation+transpiration from leaves [mm/s] + real(r8), allocatable :: etr_p (:) !transpiration rate [mm/s] + real(r8), allocatable :: fseng_p (:) !sensible heat flux from ground [W/m2] + real(r8), allocatable :: fevpg_p (:) !evaporation heat flux from ground [mm/s] + real(r8), allocatable :: parsun_p (:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: parsha_p (:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: sabvsun_p(:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: sabvsha_p(:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: qintr_p (:) !interception (mm h2o/s) + real(r8), allocatable :: qintr_rain_p(:) !rainfall interception (mm h2o/s) + real(r8), allocatable :: qintr_snow_p(:) !snowfall interception (mm h2o/s) + real(r8), allocatable :: assim_p (:) !canopy assimilation rate (mol m-2 s-1) + real(r8), allocatable :: respc_p (:) !canopy respiration (mol m-2 s-1) + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_PFTFluxes + PUBLIC :: deallocate_1D_PFTFluxes + PUBLIC :: set_1D_PFTFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_PFTFluxes + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + allocate (taux_p (numpft)) ; taux_p (:) = spval !wind stress: E-W [kg/m/s2] + allocate (tauy_p (numpft)) ; tauy_p (:) = spval !wind stress: N-S [kg/m/s2] + allocate (fsenl_p (numpft)) ; fsenl_p (:) = spval !sensible heat from leaves [W/m2] + allocate (fevpl_p (numpft)) ; fevpl_p (:) = spval !evaporation+transpiration from leaves [mm/s] + allocate (etr_p (numpft)) ; etr_p (:) = spval !transpiration rate [mm/s] + allocate (fseng_p (numpft)) ; fseng_p (:) = spval !sensible heat flux from ground [W/m2] + allocate (fevpg_p (numpft)) ; fevpg_p (:) = spval !evaporation heat flux from ground [mm/s] + allocate (parsun_p (numpft)) ; parsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] + allocate (parsha_p (numpft)) ; parsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] + allocate (sabvsun_p (numpft)) ; sabvsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] + allocate (sabvsha_p (numpft)) ; sabvsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] + allocate (qintr_p (numpft)) ; qintr_p (:) = spval !interception (mm h2o/s) + allocate (qintr_rain_p (numpft)) ; qintr_rain_p (:) = spval !rainfall interception (mm h2o/s) + allocate (qintr_snow_p (numpft)) ; qintr_snow_p (:) = spval !snowfall interception (mm h2o/s) + allocate (assim_p (numpft)) ; assim_p (:) = spval !canopy assimilation rate (mol m-2 s-1) + allocate (respc_p (numpft)) ; respc_p (:) = spval !canopy respiration (mol m-2 s-1) + + ENDIF + ENDIF + +#ifdef BGC + CALL allocate_1D_BGCPFTFluxes +#endif + + END SUBROUTINE allocate_1D_PFTFluxes + + SUBROUTINE deallocate_1D_PFTFluxes + ! ------------------------------------------------------------------- + ! deallocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPFT + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + deallocate (taux_p ) + deallocate (tauy_p ) + deallocate (fsenl_p ) + deallocate (fevpl_p ) + deallocate (etr_p ) + deallocate (fseng_p ) + deallocate (fevpg_p ) + deallocate (parsun_p ) + deallocate (parsha_p ) + deallocate (sabvsun_p ) + deallocate (sabvsha_p ) + deallocate (qintr_p ) + deallocate (qintr_rain_p ) + deallocate (qintr_snow_p ) + deallocate (assim_p ) + deallocate (respc_p ) + + ENDIF + ENDIF + +#ifdef BGC + CALL deallocate_1D_BGCPFTFluxes +#endif + + END SUBROUTINE deallocate_1D_PFTFluxes + + SUBROUTINE set_1D_PFTFluxes(Values, Nan) + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + IMPLICIT NONE + + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + taux_p (:) = Values !wind stress: E-W [kg/m/s2] + tauy_p (:) = Values !wind stress: N-S [kg/m/s2] + fsenl_p (:) = Values !sensible heat from leaves [W/m2] + fevpl_p (:) = Values !evaporation+transpiration from leaves [mm/s] + etr_p (:) = Values !transpiration rate [mm/s] + fseng_p (:) = Values !sensible heat flux from ground [W/m2] + fevpg_p (:) = Values !evaporation heat flux from ground [mm/s] + parsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] + parsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] + sabvsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] + sabvsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] + qintr_p (:) = Values !interception (mm h2o/s) + qintr_rain_p(:) = Values !rainfall interception (mm h2o/s) + qintr_snow_p(:) = Values !snowfall interception (mm h2o/s) + assim_p (:) = Values !canopy assimilation rate (mol m-2 s-1) + respc_p (:) = Values !canopy respiration (mol m-2 s-1) + + ENDIF + ENDIF + +#ifdef BGC + CALL set_1D_BGCPFTFluxes (Values, Nan) +#endif + + END SUBROUTINE set_1D_PFTFluxes + +END MODULE MOD_Vars_1DPFTFluxes + +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 new file mode 100644 index 0000000000..ca17147eb1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 @@ -0,0 +1,81 @@ +#include + +MODULE MOD_Vars_2DForcing +!----------------------------------------------------------------------- +! Meteorogical Forcing +! +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + + USE MOD_DataType + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- + type(block_data_real8_2d) :: forc_xy_pco2m ! CO2 concentration in atmos. (pascals) + type(block_data_real8_2d) :: forc_xy_po2m ! O2 concentration in atmos. (pascals) + type(block_data_real8_2d) :: forc_xy_us ! wind in eastward direction [m/s] + type(block_data_real8_2d) :: forc_xy_vs ! wind in northward direction [m/s] + type(block_data_real8_2d) :: forc_xy_t ! temperature at reference height [kelvin] + type(block_data_real8_2d) :: forc_xy_q ! specific humidity at reference height [kg/kg] + type(block_data_real8_2d) :: forc_xy_prc ! convective precipitation [mm/s] + type(block_data_real8_2d) :: forc_xy_prl ! large scale precipitation [mm/s] + type(block_data_real8_2d) :: forc_xy_psrf ! atmospheric pressure at the surface [pa] + type(block_data_real8_2d) :: forc_xy_pbot ! atm bottom level pressure (or reference height) (pa) + type(block_data_real8_2d) :: forc_xy_sols ! atm vis direct beam solar rad onto srf [W/m2] + type(block_data_real8_2d) :: forc_xy_soll ! atm nir direct beam solar rad onto srf [W/m2] + type(block_data_real8_2d) :: forc_xy_solsd ! atm vis diffuse solar rad onto srf [W/m2] + type(block_data_real8_2d) :: forc_xy_solld ! atm nir diffuse solar rad onto srf [W/m2] + type(block_data_real8_2d) :: forc_xy_frl ! atmospheric infrared (longwave) radiation [W/m2] + type(block_data_real8_2d) :: forc_xy_hgt_u ! observational height of wind [m] + type(block_data_real8_2d) :: forc_xy_hgt_t ! observational height of temperature [m] + type(block_data_real8_2d) :: forc_xy_hgt_q ! observational height of humidity [m] + type(block_data_real8_2d) :: forc_xy_rhoair ! air density [kg/m3] + type(block_data_real8_2d) :: forc_xy_hpbl ! atmospheric boundary layer height [m] + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_2D_Forcing + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_2D_Forcing (grid) + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 2d [lon_points,lat_points] variables + ! ------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_DataType + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + + IF (p_is_io) THEN + + CALL allocate_block_data (grid, forc_xy_pco2m ) ! CO2 concentration in atmos. (pascals) + CALL allocate_block_data (grid, forc_xy_po2m ) ! O2 concentration in atmos. (pascals) + CALL allocate_block_data (grid, forc_xy_us ) ! wind in eastward direction [m/s] + CALL allocate_block_data (grid, forc_xy_vs ) ! wind in northward direction [m/s] + CALL allocate_block_data (grid, forc_xy_t ) ! temperature at reference height [kelvin] + CALL allocate_block_data (grid, forc_xy_q ) ! specific humidity at reference height [kg/kg] + CALL allocate_block_data (grid, forc_xy_prc ) ! convective precipitation [mm/s] + CALL allocate_block_data (grid, forc_xy_prl ) ! large scale precipitation [mm/s] + CALL allocate_block_data (grid, forc_xy_psrf ) ! atmospheric pressure at the surface [pa] + CALL allocate_block_data (grid, forc_xy_pbot ) ! atm bottom level pressure (or reference height) (pa) + CALL allocate_block_data (grid, forc_xy_sols ) ! atm vis direct beam solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_soll ) ! atm nir direct beam solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_solld ) ! atm nir diffuse solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_frl ) ! atmospheric infrared (longwave) radiation [W/m2] + CALL allocate_block_data (grid, forc_xy_hgt_u ) ! observational height of wind [m] + CALL allocate_block_data (grid, forc_xy_hgt_t ) ! observational height of temperature [m] + CALL allocate_block_data (grid, forc_xy_hgt_q ) ! observational height of humidity [m] + CALL allocate_block_data (grid, forc_xy_rhoair) ! air density [kg/m3] + CALL allocate_block_data (grid, forc_xy_hpbl ) ! atmospheric boundary layer height [m] + ENDIF + + END SUBROUTINE allocate_2D_Forcing + +END MODULE MOD_Vars_2DForcing +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 new file mode 100644 index 0000000000..473bebe5c8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 @@ -0,0 +1,168 @@ +#include + +MODULE MOD_Vars_Global +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Define some global variables +! +! !REVISIONS: +! Hua Yuan, 08/2019: initial version partly adapted from CoLM2014 +! TODO ... +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +#ifdef LULC_USGS + ! GLCC USGS number of land cover category + integer, parameter :: N_land_classification = 24 + ! GLCC USGS land cover named index (could be added IF needed) + integer, parameter :: URBAN = 1 + integer, parameter :: WATERBODY = 16 + integer, parameter :: WETLAND = 17 + integer, parameter :: CROPLAND = 7 + integer, parameter :: GLACIERS = 24 +#else + ! MODIS IGBP number of land cover category + integer, parameter :: N_land_classification = 17 + ! MODIS IGBP land cover named index (could be added IF needed) + integer, parameter :: WETLAND = 11 + integer, parameter :: CROPLAND = 12 + integer, parameter :: URBAN = 13 + integer, parameter :: GLACIERS = 15 + integer, parameter :: WATERBODY = 17 +#endif + + ! number of plant functional types +#ifndef CROP + integer, parameter :: N_PFT = 16 + integer, parameter :: N_CFT = 0 +#else + integer, parameter :: N_PFT = 15 + integer, parameter :: N_CFT = 64 +#endif + + ! urban type number + integer :: N_URB + + ! vertical layer number + integer, parameter :: maxsnl = -5 + integer, parameter :: nl_soil = 10 + integer, parameter :: nl_soil_full = 15 + + integer, parameter :: nl_lake = 10 + integer, parameter :: nl_roof = 10 + integer, parameter :: nl_wall = 10 + integer, parameter :: nvegwcs = 4 ! number of vegetation water potential nodes + integer, parameter :: nwl = 211 ! number of hyperspectral wavelengths + ! used for downscaling + integer, parameter :: num_slope_type = 4 + integer, parameter :: num_aspect_type = 9 + integer, parameter :: num_zenith = 101 + integer, parameter :: num_zenith_parameter = 3 + integer, parameter :: num_azimuth = 16 + + ! bgc variables + integer, parameter :: ndecomp_pools = 7 + integer, parameter :: ndecomp_transitions = 10 + integer, parameter :: npcropmin = 17 + real(r8),parameter :: zmin_bedrock = 0.4 + integer, parameter :: nbedrock = 10 + integer, parameter :: ndecomp_pools_vr = ndecomp_pools * nl_soil + + ! crop index + integer, parameter :: noveg = 0 + integer, parameter :: nbrdlf_evr_shrub = 9 + integer, parameter :: nbrdlf_dcd_brl_shrub = 11 + integer, parameter :: nc3crop = 15 + integer, parameter :: nc3irrig = 16 + integer, parameter :: ntmp_corn = 17 ! temperate_corn + integer, parameter :: nirrig_tmp_corn = 18 ! irrigated temperate corn + integer, parameter :: nswheat = 19 ! spring wheat + integer, parameter :: nirrig_swheat = 20 ! irrigated spring wheat + integer, parameter :: nwwheat = 21 ! winter wheat + integer, parameter :: nirrig_wwheat = 22 ! irrigated winter wheat + integer, parameter :: ntmp_soybean = 23 ! temperate soybean + integer, parameter :: nirrig_tmp_soybean = 24 ! irrigated temperate soybean + integer, parameter :: ncotton = 41 ! cotton + integer, parameter :: nirrig_cotton = 42 ! irrigated cotton + integer, parameter :: nrice = 61 ! rice + integer, parameter :: nirrig_rice = 62 ! irrigated rice + integer, parameter :: nsugarcane = 67 ! sugarcane + integer, parameter :: nirrig_sugarcane = 68 ! irrigated sugarcane + integer, parameter :: nmiscanthus = 71 ! miscanthus + integer, parameter :: nirrig_miscanthus = 72 ! irrigated miscanthus + integer, parameter :: nswitchgrass = 73 ! switchgrass + integer, parameter :: nirrig_switchgrass = 74 ! irrigated switchgrass + integer, parameter :: ntrp_corn = 75 ! tropical corn + integer, parameter :: nirrig_trp_corn = 76 ! irrigated tropical corn + integer, parameter :: ntrp_soybean = 77 ! tropical soybean + integer, parameter :: nirrig_trp_soybean = 78 ! irrigated tropical soybean + + real(r8) :: z_soi (1:nl_soil) ! node depth [m] + real(r8) :: dz_soi(1:nl_soil) ! soil node thickness [m] + real(r8) :: zi_soi(1:nl_soil) ! interface level below a zsoi level [m] + + real(r8), parameter :: spval = -1.e36_r8 ! missing value + integer , parameter :: spval_i4 = -9999 ! missing value + real(r8), parameter :: PI = 4*atan(1.) ! pi value + real(r8), parameter :: deg2rad = 1.745329251994330e-2_r8 ! degree to radius + + integer , parameter :: irrig_start_time = 21600 ! local time of irrigation start + real(r8), parameter :: irrig_max_depth = 1._r8 ! max irrigation depth + real(r8), parameter :: irrig_threshold_fraction = 1._r8 ! irrigation thershold + real(r8), parameter :: irrig_supply_fraction = 1._r8 ! irrigation supply thershold + real(r8), parameter :: irrig_min_cphase = 1._r8 ! crop phenology when begin irrigation + real(r8), parameter :: irrig_max_cphase = 4._r8 ! crop phenology when end irrigation + integer , parameter :: irrig_time_per_day = 14400 ! irrigation last time + integer , parameter :: irrig_method_drip = 1 ! irrigation method + integer , parameter :: irrig_method_sprinkler = 2 ! irrigation method + integer , parameter :: irrig_method_flood = 3 ! irrigation method + integer , parameter :: irrig_method_paddy = 4 ! irrigation method + real(r8), parameter :: pondmxc = 100.0 ! ponding depth (mm) +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Init_GlobalVars + +CONTAINS + + SUBROUTINE Init_GlobalVars + + IMPLICIT NONE + + integer :: nsl + + ! node depths of each soil layer + DO nsl = 1, nl_soil + z_soi(nsl) = 0.025*(exp(0.5*(nsl-0.5))-1.) + ENDDO + + ! thickness between two soil layer interfaces + dz_soi(1) = 0.5*(z_soi(1)+z_soi(2)) !=zi_soi(1) + dz_soi(nl_soil) = z_soi(nl_soil)-z_soi(nl_soil-1) + DO nsl = 2, nl_soil-1 + dz_soi(nsl) = 0.5*(z_soi(nsl+1)-z_soi(nsl-1)) + ENDDO + + ! interface depths of soil layers + zi_soi(1) = dz_soi(1) + DO nsl = 2, nl_soil + zi_soi(nsl) = zi_soi(nsl-1) + dz_soi(nsl) + ENDDO + + ! set urban class number + IF (DEF_URBAN_type_scheme == 1) THEN + N_URB = 3 + ELSE IF(DEF_URBAN_type_scheme == 2) THEN + N_URB = 10 + ENDIF + + !ndecomp_pools_vr = ndecomp_pools * nl_soil + + END SUBROUTINE Init_GlobalVars + +END MODULE MOD_Vars_Global +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..7496c1ec85 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 @@ -0,0 +1,1120 @@ +#include + +!----------------------------------------------------------------------- +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +MODULE MOD_Vars_PFTimeInvariants +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Define PFT time invariables +! +! Added by Hua Yuan, 08/2019 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + integer , allocatable :: pftclass (:) !PFT type + real(r8), allocatable :: pftfrac (:) !PFT fractional cover + real(r8), allocatable :: htop_p (:) !canopy top height [m] + real(r8), allocatable :: hbot_p (:) !canopy bottom height [m] +#ifdef CROP + real(r8), allocatable :: cropfrac (:) !Crop fractional cover +#endif + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_PFTimeInvariants + PUBLIC :: READ_PFTimeInvariants + PUBLIC :: WRITE_PFTimeInvariants + PUBLIC :: deallocate_PFTimeInvariants +#ifdef RangeCheck + PUBLIC :: check_PFTimeInvariants +#endif + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_PFTimeInvariants + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + USE MOD_LandPFT, only: numpft + USE MOD_Precision + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + allocate (pftclass (numpft)) + allocate (pftfrac (numpft)) + allocate (htop_p (numpft)) + allocate (hbot_p (numpft)) + ENDIF + +#ifdef CROP + IF (numpatch > 0) THEN + allocate (cropfrac (numpatch)) + ENDIF +#endif + ENDIF + + END SUBROUTINE allocate_PFTimeInvariants + + SUBROUTINE READ_PFTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_LandPFT + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + CALL ncio_read_vector (file_restart, 'pftclass', landpft, pftclass) ! + CALL ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! + CALL ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! + CALL ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! +#ifdef CROP + CALL ncio_read_vector (file_restart, 'cropfrac ', landpatch, cropfrac) ! +#endif + + END SUBROUTINE READ_PFTimeInvariants + + SUBROUTINE WRITE_PFTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_LandPatch + USE MOD_Namelist + USE MOD_Vars_Global + IMPLICIT NONE + + ! Local variables + character(len=*), intent(in) :: file_restart + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + + CALL ncio_write_vector (file_restart, 'pftclass', 'pft', landpft, pftclass, compress) ! + CALL ncio_write_vector (file_restart, 'pftfrac ', 'pft', landpft, pftfrac , compress) ! + CALL ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! + CALL ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! + +#ifdef CROP + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'cropfrac', 'patch', landpatch, cropfrac, compress) ! +#endif + + END SUBROUTINE WRITE_PFTimeInvariants + + SUBROUTINE deallocate_PFTimeInvariants + ! ------------------------------------------------------------------- + ! Deallocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPFT + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + deallocate (pftclass) + deallocate (pftfrac ) + deallocate (htop_p ) + deallocate (hbot_p ) +#ifdef CROP + deallocate (cropfrac) +#endif + ENDIF + ENDIF + + END SUBROUTINE deallocate_PFTimeInvariants + +#ifdef RangeCheck + SUBROUTINE check_PFTimeInvariants () + + USE MOD_RangeCheck + IMPLICIT NONE + + CALL check_vector_data ('pftfrac', pftfrac) ! + CALL check_vector_data ('htop_p ', htop_p ) ! + CALL check_vector_data ('hbot_p ', hbot_p ) ! +#ifdef CROP + CALL check_vector_data ('cropfrac', cropfrac) ! +#endif + + END SUBROUTINE check_PFTimeInvariants +#endif + +END MODULE MOD_Vars_PFTimeInvariants +#endif + +MODULE MOD_Vars_TimeInvariants +! ------------------------------- +! Created by Yongjiu Dai, 03/2014 +! ------------------------------- + + USE MOD_Precision +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants +#endif +#ifdef BGC + USE MOD_BGC_Vars_TimeInvariants +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeInvariants +#endif + IMPLICIT NONE + SAVE + +! ----------------------------------------------------------------- +! surface classification and soil information + integer, allocatable :: patchclass (:) !index of land cover type of the patches at the fraction > 0 + integer, allocatable :: patchtype (:) !land patch type + logical, allocatable :: patchmask (:) !patch mask + + real(r8), allocatable :: patchlatr (:) !latitude in radians + real(r8), allocatable :: patchlonr (:) !longitude in radians + + real(r8), allocatable :: lakedepth (:) !lake depth + real(r8), allocatable :: dz_lake (:,:) !new lake scheme + + real(r8), allocatable :: soil_s_v_alb (:) !albedo of visible of the saturated soil + real(r8), allocatable :: soil_d_v_alb (:) !albedo of visible of the dry soil + real(r8), allocatable :: soil_s_n_alb (:) !albedo of near infrared of the saturated soil + real(r8), allocatable :: soil_d_n_alb (:) !albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + real(r8), allocatable :: soil_alb (:,:) ! hyper spectral soil albedo. (numpatch, nwl) +#endif + real(r8), allocatable :: vf_quartz (:,:) !volumetric fraction of quartz within mineral soil + real(r8), allocatable :: vf_gravels (:,:) !volumetric fraction of gravels + real(r8), allocatable :: vf_om (:,:) !volumetric fraction of organic matter + real(r8), allocatable :: vf_sand (:,:) !volumetric fraction of sand + real(r8), allocatable :: vf_clay (:,:) !volumetric fraction of clay + real(r8), allocatable :: wf_gravels (:,:) !gravimetric fraction of gravels + real(r8), allocatable :: wf_sand (:,:) !gravimetric fraction of sand + real(r8), allocatable :: wf_clay (:,:) !gravimetric fraction of clay + real(r8), allocatable :: wf_om (:,:) !gravimetric fraction of om +#ifdef DataAssimilation + real(r8), allocatable :: wf_silt (:,:) !gravimetric fraction of silt +#endif + real(r8), allocatable :: OM_density (:,:) !OM density (kg/m3) + real(r8), allocatable :: BD_all (:,:) !bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3) + + real(r8), allocatable :: wfc (:,:) !field capacity + real(r8), allocatable :: porsl (:,:) !fraction of soil that is voids [-] + real(r8), allocatable :: psi0 (:,:) !minimum soil suction [mm] (NOTE: "-" valued) + real(r8), allocatable :: bsw (:,:) !clapp and hornberger "b" parameter [-] + real(r8), allocatable :: theta_r (:,:) !residual moisture content [-] + real(r8), allocatable :: BVIC (:) !b parameter in Fraction of saturated soil in a grid calculated by VIC +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), allocatable :: alpha_vgm (:,:) !a parameter corresponding approximately to the inverse of the air-entry value + real(r8), allocatable :: L_vgm (:,:) !pore-connectivity parameter [dimensionless] + real(r8), allocatable :: n_vgm (:,:) !a shape parameter [dimensionless] + real(r8), allocatable :: sc_vgm (:,:) !saturation at the air entry value in the classical vanGenuchten model [-] + real(r8), allocatable :: fc_vgm (:,:) !a scaling factor by using air entry value in the Mualem model [-] +#endif + + integer, allocatable :: soiltext (:) !USDA soil texture class + + real(r8), allocatable :: fsatmax (:) !maximum saturated area fraction [-] + real(r8), allocatable :: fsatdcf (:) !decay factor in calculation of saturated area fraction [1/m] + + real(r8), allocatable :: topoweti (:) !topographic wetness index [log m] + real(r8), allocatable :: alp_twi (:) !alpha in three parameter gamma distribution of twi + real(r8), allocatable :: chi_twi (:) !chi in three parameter gamma distribution of twi + real(r8), allocatable :: mu_twi (:) !mu in three parameter gamma distribution of twi + + real(r8), allocatable :: vic_b_infilt (:) + real(r8), allocatable :: vic_Dsmax (:) + real(r8), allocatable :: vic_Ds (:) + real(r8), allocatable :: vic_Ws (:) + real(r8), allocatable :: vic_c (:) + + real(r8), allocatable :: hksati (:,:) !hydraulic conductivity at saturation [mm h2o/s] + real(r8), allocatable :: csol (:,:) !heat capacity of soil solids [J/(m3 K)] + real(r8), allocatable :: k_solids (:,:) !thermal conductivity of soil solids [W/m-K] + real(r8), allocatable :: dksatu (:,:) !thermal conductivity of saturated soil [W/m-K] + real(r8), allocatable :: dksatf (:,:) !thermal conductivity of saturated frozen soil [W/m-K] + real(r8), allocatable :: dkdry (:,:) !thermal conductivity for dry soil [W/(m-K)] + real(r8), allocatable :: BA_alpha (:,:) !alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: BA_beta (:,:) !beta in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: htop (:) !canopy top height [m] + real(r8), allocatable :: hbot (:) !canopy bottom height [m] + + real(r8), allocatable :: dbedrock (:) !depth to bedrock + integer , allocatable :: ibedrock (:) !bedrock level + + real(r8), allocatable :: elvmean (:) !elevation above sea level [m] + real(r8), allocatable :: elvstd (:) !standard deviation of elevation [m] + real(r8), allocatable :: slpratio (:) !slope ratio [-] + + real(r8) :: zlnd !roughness length for soil [m] + real(r8) :: zsno !roughness length for snow [m] + real(r8) :: csoilc !drag coefficient for soil under canopy [-] + real(r8) :: dewmx !maximum dew + ! 'wtfact' is updated to gridded 'fsatmax' data. + ! real(r8) :: wtfact !fraction of model area with high water table + real(r8) :: capr !tuning factor to turn first layer T into surface T + real(r8) :: cnfac !Crank Nicholson factor between 0 and 1 + real(r8) :: ssi !irreducible water saturation of snow + real(r8) :: wimp !water impermeable IF porosity less than wimp + real(r8) :: pondmx !ponding depth (mm) + real(r8) :: smpmax !wilting point potential in mm + real(r8) :: smpmin !restriction for min of soil poten. (mm) + real(r8) :: smpmax_hr !wilting point potential in mm for heterotrophic respiration + real(r8) :: smpmin_hr !restriction for min of soil poten for heterotrophic respiration. (mm) + real(r8) :: trsmx0 !max transpiration for moist soil+100% veg. [mm/s] + real(r8) :: tcrit !critical temp. to determine rain or snow + real(r8) :: wetwatmax !maximum wetland water (mm) + + ! Used for downscaling + real(r8), allocatable :: svf_patches (:) !sky view factor + real(r8), allocatable :: cur_patches (:) !curvature + real(r8), allocatable :: sf_lut_patches (:,:,:) !look up table of shadow factor of a patch + real(r8), allocatable :: sf_curve_patches(:,:,:) !curve parameters of shadow factor of a patch + real(r8), allocatable :: asp_type_patches (:,:) !topographic aspect of each character of one patch + real(r8), allocatable :: slp_type_patches (:,:) !topographic slope of each character of one patch + real(r8), allocatable :: area_type_patches (:,:) !area percentage of each character of one patch + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_TimeInvariants + PUBLIC :: deallocate_TimeInvariants + PUBLIC :: READ_TimeInvariants + PUBLIC :: WRITE_TimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_TimeInvariants () + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! ------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate (patchclass (numpatch)) + allocate (patchtype (numpatch)) + allocate (patchmask (numpatch)) + + allocate (patchlonr (numpatch)) + allocate (patchlatr (numpatch)) + + allocate (lakedepth (numpatch)) + allocate (dz_lake (nl_lake,numpatch)) + + allocate (soil_s_v_alb (numpatch)) + allocate (soil_d_v_alb (numpatch)) + allocate (soil_s_n_alb (numpatch)) + allocate (soil_d_n_alb (numpatch)) +#ifdef HYPERSPECTRAL + allocate (soil_alb (nwl, numpatch)) +#endif + + allocate (vf_quartz (nl_soil,numpatch)) + allocate (vf_gravels (nl_soil,numpatch)) + allocate (vf_om (nl_soil,numpatch)) + allocate (vf_sand (nl_soil,numpatch)) + allocate (vf_clay (nl_soil,numpatch)) + allocate (wf_gravels (nl_soil,numpatch)) + allocate (wf_sand (nl_soil,numpatch)) + allocate (wf_clay (nl_soil,numpatch)) + allocate (wf_om (nl_soil,numpatch)) +#ifdef DataAssimilation + allocate (wf_silt (nl_soil,numpatch)) +#endif + allocate (OM_density (nl_soil,numpatch)) + allocate (BD_all (nl_soil,numpatch)) + allocate (wfc (nl_soil,numpatch)) + allocate (porsl (nl_soil,numpatch)) + allocate (psi0 (nl_soil,numpatch)) + allocate (bsw (nl_soil,numpatch)) + allocate (theta_r (nl_soil,numpatch)) + allocate (BVIC (numpatch)) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + allocate (alpha_vgm (nl_soil,numpatch)) + allocate (L_vgm (nl_soil,numpatch)) + allocate (n_vgm (nl_soil,numpatch)) + allocate (sc_vgm (nl_soil,numpatch)) + allocate (fc_vgm (nl_soil,numpatch)) +#endif + allocate (soiltext (numpatch)) + + allocate (fsatmax (numpatch)) + allocate (fsatdcf (numpatch)) + allocate (topoweti (numpatch)) + allocate (alp_twi (numpatch)) + allocate (chi_twi (numpatch)) + allocate (mu_twi (numpatch)) + + allocate (vic_b_infilt (numpatch)) + allocate (vic_Dsmax (numpatch)) + allocate (vic_Ds (numpatch)) + allocate (vic_Ws (numpatch)) + allocate (vic_c (numpatch)) + + allocate (hksati (nl_soil,numpatch)) + allocate (csol (nl_soil,numpatch)) + allocate (k_solids (nl_soil,numpatch)) + allocate (dksatu (nl_soil,numpatch)) + allocate (dksatf (nl_soil,numpatch)) + allocate (dkdry (nl_soil,numpatch)) + allocate (BA_alpha (nl_soil,numpatch)) + allocate (BA_beta (nl_soil,numpatch)) + allocate (htop (numpatch)) + allocate (hbot (numpatch)) + allocate (dbedrock (numpatch)) + allocate (ibedrock (numpatch)) + allocate (elvmean (numpatch)) + allocate (elvstd (numpatch)) + allocate (slpratio (numpatch)) + + IF (DEF_USE_Forcing_Downscaling) THEN + ! Used for downscaling + allocate (svf_patches (numpatch)) + allocate (asp_type_patches (num_slope_type,numpatch)) + allocate (slp_type_patches (num_slope_type,numpatch)) + allocate (area_type_patches (num_slope_type,numpatch)) + allocate (cur_patches (numpatch)) +#ifdef SinglePoint + allocate (sf_lut_patches (num_azimuth,num_zenith,numpatch)) +#else + allocate (sf_curve_patches (num_azimuth,num_zenith_parameter,numpatch)) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + ! Used for downscaling + allocate (asp_type_patches (num_aspect_type,numpatch)) + allocate (slp_type_patches (num_aspect_type,numpatch)) + allocate (cur_patches (numpatch)) + ENDIF + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL allocate_PFTimeInvariants +#endif + +#ifdef BGC + CALL allocate_BGCTimeInvariants +#endif + +#ifdef URBAN_MODEL + CALL allocate_UrbanTimeInvariants +#endif + + END SUBROUTINE allocate_TimeInvariants + + !--------------------------------------- + SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector + USE MOD_NetCDFSerial +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + USE MOD_Const_LC, only: patchtypes + + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: casename + character(len=*), intent(in) :: dir_restart + + ! Local variables + character(len=256) :: file_restart, cyear, lndname + + write(cyear,'(i4.4)') lc_year + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' + + CALL ncio_read_vector (file_restart, 'patchclass', landpatch, patchclass) ! + CALL ncio_read_vector (file_restart, 'patchtype' , landpatch, patchtype ) ! + CALL ncio_read_vector (file_restart, 'patchmask' , landpatch, patchmask ) ! + + CALL ncio_read_vector (file_restart, 'patchlonr' , landpatch, patchlonr ) ! + CALL ncio_read_vector (file_restart, 'patchlatr' , landpatch, patchlatr ) ! + + CALL ncio_read_vector (file_restart, 'lakedepth', landpatch, lakedepth) ! + CALL ncio_read_vector (file_restart, 'dz_lake' , nl_lake, landpatch, dz_lake) ! + + CALL ncio_read_vector (file_restart, 'soil_s_v_alb', landpatch, soil_s_v_alb) ! albedo of visible of the saturated soil + CALL ncio_read_vector (file_restart, 'soil_d_v_alb', landpatch, soil_d_v_alb) ! albedo of visible of the dry soil + CALL ncio_read_vector (file_restart, 'soil_s_n_alb', landpatch, soil_s_n_alb) ! albedo of near infrared of the saturated soil + CALL ncio_read_vector (file_restart, 'soil_d_n_alb', landpatch, soil_d_n_alb) ! albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + CALL ncio_read_vector (file_restart, 'soil_alb' , nwl, landpatch, soil_alb ) ! hyper spectral soil albedo. (numpatch, nwl) +#endif + + CALL ncio_read_vector (file_restart, 'vf_quartz ', nl_soil, landpatch, vf_quartz ) ! volumetric fraction of quartz within mineral soil + CALL ncio_read_vector (file_restart, 'vf_gravels', nl_soil, landpatch, vf_gravels) ! volumetric fraction of gravels + CALL ncio_read_vector (file_restart, 'vf_om ', nl_soil, landpatch, vf_om ) ! volumetric fraction of organic matter + CALL ncio_read_vector (file_restart, 'vf_sand ', nl_soil, landpatch, vf_sand ) ! volumetric fraction of sand + CALL ncio_read_vector (file_restart, 'vf_clay ', nl_soil, landpatch, vf_clay ,defval = 0.1 ) ! volumetric fraction of clay + CALL ncio_read_vector (file_restart, 'wf_gravels', nl_soil, landpatch, wf_gravels) ! gravimetric fraction of gravels + CALL ncio_read_vector (file_restart, 'wf_sand ', nl_soil, landpatch, wf_sand ) ! gravimetric fraction of sand + CALL ncio_read_vector (file_restart, 'wf_clay ', nl_soil, landpatch, wf_clay ) ! gravimetric fraction of clay + CALL ncio_read_vector (file_restart, 'wf_om ', nl_soil, landpatch, wf_om ) ! gravimetric fraction of om + CALL ncio_read_vector (file_restart, 'OM_density', nl_soil, landpatch, OM_density) ! OM density + CALL ncio_read_vector (file_restart, 'BD_all ', nl_soil, landpatch, BD_all ) ! bulk density of soil + CALL ncio_read_vector (file_restart, 'wfc ', nl_soil, landpatch, wfc ) ! field capacity + CALL ncio_read_vector (file_restart, 'porsl ' , nl_soil, landpatch, porsl ) ! fraction of soil that is voids [-] + CALL ncio_read_vector (file_restart, 'psi0 ' , nl_soil, landpatch, psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL ncio_read_vector (file_restart, 'bsw ' , nl_soil, landpatch, bsw ) ! clapp and hornberger "b" parameter [-] + CALL ncio_read_vector (file_restart, 'theta_r ' , nl_soil, landpatch, theta_r ) ! residual moisture content [-] + CALL ncio_read_vector (file_restart, 'BVIC ' , landpatch, BVIC ) ! b parameter in Fraction of saturated soil in a grid calculated by VIC +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_read_vector (file_restart, 'alpha_vgm' , nl_soil, landpatch, alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL ncio_read_vector (file_restart, 'L_vgm ' , nl_soil, landpatch, L_vgm ) ! pore-connectivity parameter [dimensionless] + CALL ncio_read_vector (file_restart, 'n_vgm ' , nl_soil, landpatch, n_vgm ) ! a shape parameter [dimensionless] + CALL ncio_read_vector (file_restart, 'sc_vgm ' , nl_soil, landpatch, sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif +#ifdef DataAssimilation + IF (numpatch > 0 .and. p_is_worker) wf_silt = 1.0_r8 - wf_gravels - wf_sand - wf_clay - wf_om +#endif + + CALL ncio_read_vector (file_restart, 'soiltext', landpatch, soiltext, defval = 0 ) + + IF (DEF_Runoff_SCHEME == 0) THEN + CALL ncio_read_vector (file_restart, 'topoweti', landpatch, topoweti, defval = 9.27 ) + CALL ncio_read_vector (file_restart, 'fsatmax ', landpatch, fsatmax , defval = 0.38 ) + CALL ncio_read_vector (file_restart, 'fsatdcf ', landpatch, fsatdcf , defval = 0.55 ) + CALL ncio_read_vector (file_restart, 'alp_twi ', landpatch, alp_twi , defval = 1.34 ) + CALL ncio_read_vector (file_restart, 'chi_twi ', landpatch, chi_twi , defval = 1.61 ) + CALL ncio_read_vector (file_restart, 'mu_twi ', landpatch, mu_twi , defval = 6.95 ) + ENDIF + + CALL ncio_read_vector (file_restart, 'vic_b_infilt', landpatch, vic_b_infilt) + CALL ncio_read_vector (file_restart, 'vic_Dsmax' , landpatch, vic_Dsmax ) + CALL ncio_read_vector (file_restart, 'vic_Ds' , landpatch, vic_Ds ) + CALL ncio_read_vector (file_restart, 'vic_Ws' , landpatch, vic_Ws ) + CALL ncio_read_vector (file_restart, 'vic_c' , landpatch, vic_c ) + + CALL ncio_read_vector (file_restart, 'hksati ' , nl_soil, landpatch, hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + CALL ncio_read_vector (file_restart, 'csol ' , nl_soil, landpatch, csol ) ! heat capacity of soil solids [J/(m3 K)] + CALL ncio_read_vector (file_restart, 'k_solids', nl_soil, landpatch, k_solids) ! thermal conductivity of soil solids [W/m-K] + CALL ncio_read_vector (file_restart, 'dksatu ' , nl_soil, landpatch, dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + CALL ncio_read_vector (file_restart, 'dksatf ' , nl_soil, landpatch, dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + CALL ncio_read_vector (file_restart, 'dkdry ' , nl_soil, landpatch, dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + CALL ncio_read_vector (file_restart, 'BA_alpha', nl_soil, landpatch, BA_alpha) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_read_vector (file_restart, 'BA_beta' , nl_soil, landpatch, BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_read_vector (file_restart, 'htop' , landpatch, htop) ! + CALL ncio_read_vector (file_restart, 'hbot' , landpatch, hbot) ! + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_read_vector (file_restart, 'debdrock' , landpatch, dbedrock) ! + CALL ncio_read_vector (file_restart, 'ibedrock' , landpatch, ibedrock) ! + ENDIF + + CALL ncio_read_vector (file_restart, 'elvmean ', landpatch, elvmean ) ! + CALL ncio_read_vector (file_restart, 'elvstd ', landpatch, elvstd ) ! + CALL ncio_read_vector (file_restart, 'slpratio', landpatch, slpratio) ! + + CALL ncio_read_bcast_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_read_bcast_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_read_bcast_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_read_bcast_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + ! CALL ncio_read_bcast_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_read_bcast_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_read_bcast_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_read_bcast_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_read_bcast_serial (file_restart, 'wimp ', wimp ) ! water impermeable IF porosity less than wimp + CALL ncio_read_bcast_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_read_bcast_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_read_bcast_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_read_bcast_serial (file_restart, 'smpmax_hr', smpmax_hr) ! wilting point potential in mm + CALL ncio_read_bcast_serial (file_restart, 'smpmin_hr', smpmin_hr) ! restriction for min of soil poten. (mm) + CALL ncio_read_bcast_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_read_bcast_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_read_bcast_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_read_vector (file_restart, 'slp_type_patches' , num_slope_type, landpatch, slp_type_patches) + CALL ncio_read_vector (file_restart, 'svf_patches' , landpatch, svf_patches ) + CALL ncio_read_vector (file_restart, 'asp_type_patches' , num_slope_type, landpatch, asp_type_patches) + CALL ncio_read_vector (file_restart, 'area_type_patches', num_slope_type, landpatch, area_type_patches) + CALL ncio_read_vector (file_restart, 'cur_patches' , landpatch, cur_patches ) +#ifdef SinglePoint + CALL ncio_read_vector (file_restart, 'sf_lut_patches' , num_azimuth , num_zenith, landpatch, sf_lut_patches) +#else + CALL ncio_read_vector (file_restart, 'sf_curve_patches' , num_azimuth , num_zenith_parameter, landpatch, sf_curve_patches) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + CALL ncio_read_vector (file_restart, 'slp_type_patches' , num_aspect_type, landpatch, slp_type_patches) + CALL ncio_read_vector (file_restart, 'asp_type_patches' , num_aspect_type, landpatch, asp_type_patches) + CALL ncio_read_vector (file_restart, 'cur_patches' , landpatch, cur_patches ) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) == 0) THEN + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_PFTimeInvariants (file_restart) + ENDIF +#else + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_PFTimeInvariants (file_restart) +#endif +#endif + +#if (defined BGC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_BGCTimeInvariants (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_UrbanTimeInvariants (file_restart) +#endif + +#ifdef RangeCheck + CALL check_TimeInvariants () +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,*) 'Loading Time Invariants done.' + ENDIF + + END SUBROUTINE READ_TimeInvariants + + !--------------------------------------- + SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_BEDROCK + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: casename + character(len=*), intent(in) :: dir_restart + + ! Local Variables + character(len=256) :: file_restart, cyear + integer :: compress + + compress = DEF_REST_CompressLevel + + write(cyear,'(i4.4)') lc_year + + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/const') + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' + + CALL ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'type', num_slope_type) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'azi', num_azimuth) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'zen', num_zenith) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'zen_p', num_zenith_parameter) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'type_a', num_aspect_type) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'wavelength', nwl) + + CALL ncio_write_vector (file_restart, 'patchclass', 'patch', landpatch, patchclass) ! + CALL ncio_write_vector (file_restart, 'patchtype' , 'patch', landpatch, patchtype ) ! + CALL ncio_write_vector (file_restart, 'patchmask' , 'patch', landpatch, patchmask ) ! + + CALL ncio_write_vector (file_restart, 'patchlonr' , 'patch', landpatch, patchlonr ) ! + CALL ncio_write_vector (file_restart, 'patchlatr' , 'patch', landpatch, patchlatr ) ! + + CALL ncio_write_vector (file_restart, 'lakedepth' , 'patch', landpatch, lakedepth , compress) ! + CALL ncio_write_vector (file_restart, 'dz_lake' , 'lake', nl_lake, 'patch', landpatch, dz_lake, compress) ! + + CALL ncio_write_vector (file_restart, 'soil_s_v_alb', 'patch', landpatch, soil_s_v_alb, compress) ! albedo of visible of the saturated soil + CALL ncio_write_vector (file_restart, 'soil_d_v_alb', 'patch', landpatch, soil_d_v_alb, compress) ! albedo of visible of the dry soil + CALL ncio_write_vector (file_restart, 'soil_s_n_alb', 'patch', landpatch, soil_s_n_alb, compress) ! albedo of near infrared of the saturated soil + CALL ncio_write_vector (file_restart, 'soil_d_n_alb', 'patch', landpatch, soil_d_n_alb, compress) ! albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + CALL ncio_write_vector (file_restart, 'soil_alb' , 'wavelength', nwl, 'patch', landpatch, soil_alb, compress) ! hyper spectral soil albedo. (numpatch, nwl) +#endif + + CALL ncio_write_vector (file_restart, 'vf_quartz ', 'soil', nl_soil, 'patch', landpatch, vf_quartz , compress) ! volumetric fraction of quartz within mineral soil + CALL ncio_write_vector (file_restart, 'vf_gravels', 'soil', nl_soil, 'patch', landpatch, vf_gravels, compress) ! volumetric fraction of gravels + CALL ncio_write_vector (file_restart, 'vf_om ', 'soil', nl_soil, 'patch', landpatch, vf_om , compress) ! volumetric fraction of organic matter + CALL ncio_write_vector (file_restart, 'vf_sand ', 'soil', nl_soil, 'patch', landpatch, vf_sand , compress) ! volumetric fraction of sand + CALL ncio_write_vector (file_restart, 'vf_clay ', 'soil', nl_soil, 'patch', landpatch, vf_clay , compress) ! volumetric fraction of clay + CALL ncio_write_vector (file_restart, 'wf_gravels', 'soil', nl_soil, 'patch', landpatch, wf_gravels, compress) ! gravimetric fraction of gravels + CALL ncio_write_vector (file_restart, 'wf_sand ', 'soil', nl_soil, 'patch', landpatch, wf_sand , compress) ! gravimetric fraction of sand + CALL ncio_write_vector (file_restart, 'wf_clay ', 'soil', nl_soil, 'patch', landpatch, wf_clay , compress) ! gravimetric fraction of clay + CALL ncio_write_vector (file_restart, 'wf_om ', 'soil', nl_soil, 'patch', landpatch, wf_om , compress) ! gravimetric fraction of om + CALL ncio_write_vector (file_restart, 'OM_density', 'soil', nl_soil, 'patch', landpatch, OM_density, compress) ! OM_density + CALL ncio_write_vector (file_restart, 'BD_all ', 'soil', nl_soil, 'patch', landpatch, BD_all , compress) ! bulk density of soil + CALL ncio_write_vector (file_restart, 'wfc ', 'soil', nl_soil, 'patch', landpatch, wfc , compress) ! field capacity + CALL ncio_write_vector (file_restart, 'porsl ', 'soil', nl_soil, 'patch', landpatch, porsl , compress) ! fraction of soil that is voids [-] + CALL ncio_write_vector (file_restart, 'psi0 ', 'soil', nl_soil, 'patch', landpatch, psi0 , compress) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL ncio_write_vector (file_restart, 'bsw ', 'soil', nl_soil, 'patch', landpatch, bsw , compress) ! clapp and hornberger "b" parameter [-] + CALL ncio_write_vector (file_restart, 'theta_r ' , 'soil', nl_soil, 'patch', landpatch, theta_r , compress) ! residual moisture content [-] + CALL ncio_write_vector (file_restart, 'BVIC ' , 'patch', landpatch, BVIC, compress) ! b parameter in Fraction of saturated soil in a grid calculated by VIC + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_write_vector (file_restart, 'alpha_vgm' , 'soil', nl_soil, 'patch', landpatch, alpha_vgm , compress) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL ncio_write_vector (file_restart, 'L_vgm ' , 'soil', nl_soil, 'patch', landpatch, L_vgm , compress) ! pore-connectivity parameter [dimensionless] + CALL ncio_write_vector (file_restart, 'n_vgm ' , 'soil', nl_soil, 'patch', landpatch, n_vgm , compress) ! a shape parameter [dimensionless] + CALL ncio_write_vector (file_restart, 'sc_vgm ' , 'soil', nl_soil, 'patch', landpatch, sc_vgm , compress) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL ncio_write_vector (file_restart, 'fc_vgm ' , 'soil', nl_soil, 'patch', landpatch, fc_vgm , compress) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + + CALL ncio_write_vector (file_restart, 'soiltext', 'patch', landpatch, soiltext) + + IF (DEF_Runoff_SCHEME == 0) THEN + CALL ncio_write_vector (file_restart, 'topoweti', 'patch', landpatch, topoweti) + CALL ncio_write_vector (file_restart, 'fsatmax ', 'patch', landpatch, fsatmax ) + CALL ncio_write_vector (file_restart, 'fsatdcf ', 'patch', landpatch, fsatdcf ) + CALL ncio_write_vector (file_restart, 'alp_twi ', 'patch', landpatch, alp_twi ) + CALL ncio_write_vector (file_restart, 'chi_twi ', 'patch', landpatch, chi_twi ) + CALL ncio_write_vector (file_restart, 'mu_twi ', 'patch', landpatch, mu_twi ) + ENDIF + + CALL ncio_write_vector (file_restart, 'vic_b_infilt', 'patch', landpatch, vic_b_infilt) + CALL ncio_write_vector (file_restart, 'vic_Dsmax' , 'patch', landpatch, vic_Dsmax ) + CALL ncio_write_vector (file_restart, 'vic_Ds' , 'patch', landpatch, vic_Ds ) + CALL ncio_write_vector (file_restart, 'vic_Ws' , 'patch', landpatch, vic_Ws ) + CALL ncio_write_vector (file_restart, 'vic_c' , 'patch', landpatch, vic_c ) + + CALL ncio_write_vector (file_restart, 'hksati ' , 'soil', nl_soil, 'patch', landpatch, hksati , compress) ! hydraulic conductivity at saturation [mm h2o/s] + CALL ncio_write_vector (file_restart, 'csol ' , 'soil', nl_soil, 'patch', landpatch, csol , compress) ! heat capacity of soil solids [J/(m3 K)] + CALL ncio_write_vector (file_restart, 'k_solids ' , 'soil', nl_soil, 'patch', landpatch, k_solids , compress) ! thermal conductivity of soil solids [W/m-K] + CALL ncio_write_vector (file_restart, 'dksatu ' , 'soil', nl_soil, 'patch', landpatch, dksatu , compress) ! thermal conductivity of saturated soil [W/m-K] + CALL ncio_write_vector (file_restart, 'dksatf ' , 'soil', nl_soil, 'patch', landpatch, dksatf , compress) ! thermal conductivity of saturated soil [W/m-K] + CALL ncio_write_vector (file_restart, 'dkdry ' , 'soil', nl_soil, 'patch', landpatch, dkdry , compress) ! thermal conductivity for dry soil [W/(m-K)] + CALL ncio_write_vector (file_restart, 'BA_alpha ' , 'soil', nl_soil, 'patch', landpatch, BA_alpha , compress) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_write_vector (file_restart, 'BA_beta ' , 'soil', nl_soil, 'patch', landpatch, BA_beta , compress) ! beta in Balland and Arp(2005) thermal conductivity scheme + + CALL ncio_write_vector (file_restart, 'htop' , 'patch', landpatch, htop) ! + CALL ncio_write_vector (file_restart, 'hbot' , 'patch', landpatch, hbot) ! + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_write_vector (file_restart, 'debdrock' , 'patch', landpatch, dbedrock) + CALL ncio_write_vector (file_restart, 'ibedrock' , 'patch', landpatch, ibedrock) + ENDIF + + CALL ncio_write_vector (file_restart, 'elvmean ', 'patch', landpatch, elvmean ) + CALL ncio_write_vector (file_restart, 'elvstd ', 'patch', landpatch, elvstd ) + CALL ncio_write_vector (file_restart, 'slpratio', 'patch', landpatch, slpratio) + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_write_vector (file_restart, 'svf_patches', 'patch', landpatch, svf_patches) + CALL ncio_write_vector (file_restart, 'cur_patches', 'patch', landpatch, cur_patches) + CALL ncio_write_vector (file_restart, 'slp_type_patches', 'type', num_slope_type, 'patch', landpatch, slp_type_patches) + CALL ncio_write_vector (file_restart, 'asp_type_patches', 'type', num_slope_type, 'patch', landpatch, asp_type_patches) + CALL ncio_write_vector (file_restart, 'area_type_patches', 'type', num_slope_type, 'patch', landpatch, area_type_patches) +#ifdef SinglePoint + CALL ncio_write_vector (file_restart, 'sf_lut_patches', 'azi' , num_azimuth,'zen', num_zenith, 'patch', landpatch, sf_lut_patches) +#else + CALL ncio_write_vector (file_restart, 'sf_curve_patches', 'azi' , num_azimuth,'zen_p', num_zenith_parameter, 'patch', landpatch, sf_curve_patches) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + CALL ncio_write_vector (file_restart, 'cur_patches', 'patch', landpatch, cur_patches) + CALL ncio_write_vector (file_restart, 'slp_type_patches', 'type_a', num_aspect_type, 'patch', landpatch, slp_type_patches) + CALL ncio_write_vector (file_restart, 'asp_type_patches', 'type_a', num_aspect_type, 'patch', landpatch, asp_type_patches) + ENDIF + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + if (p_is_master) then + +#if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) + CALL ncio_create_file (file_restart) +#endif + + CALL ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_write_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_write_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + ! CALL ncio_write_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_write_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_write_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_write_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_write_serial (file_restart, 'wimp ', wimp ) ! water impermeable if porosity less than wimp + CALL ncio_write_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_write_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_write_serial (file_restart, 'smpmax_hr', smpmax_hr) ! wilting point potential in mm + CALL ncio_write_serial (file_restart, 'smpmin_hr', smpmin_hr) ! restriction for min of soil poten. (mm) + CALL ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_PFTimeInvariants (file_restart) +#endif + +#if (defined BGC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_BGCTimeInvariants (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_UrbanTimeInvariants (file_restart) +#endif + + END SUBROUTINE WRITE_TimeInvariants + + SUBROUTINE deallocate_TimeInvariants () + + USE MOD_Namelist, only: DEF_USE_Forcing_Downscaling, DEF_USE_Forcing_Downscaling_Simple + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + + IMPLICIT NONE + + ! -------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------- + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + deallocate (patchclass ) + deallocate (patchtype ) + deallocate (patchmask ) + + deallocate (patchlonr ) + deallocate (patchlatr ) + + deallocate (lakedepth ) + deallocate (dz_lake ) + + deallocate (soil_s_v_alb ) + deallocate (soil_d_v_alb ) + deallocate (soil_s_n_alb ) + deallocate (soil_d_n_alb ) +#ifdef HYPERSPECTRAL + deallocate (soil_alb ) +#endif + + deallocate (vf_quartz ) + deallocate (vf_gravels ) + deallocate (vf_om ) + deallocate (vf_sand ) + deallocate (vf_clay ) + deallocate (wf_gravels ) + deallocate (wf_sand ) + deallocate (wf_clay ) + deallocate (wf_om ) +#ifdef DataAssimilation + deallocate (wf_silt ) +#endif + deallocate (OM_density ) + deallocate (BD_all ) + deallocate (wfc ) + deallocate (porsl ) + deallocate (psi0 ) + deallocate (bsw ) + deallocate (theta_r ) + deallocate (BVIC ) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + deallocate (alpha_vgm ) + deallocate (L_vgm ) + deallocate (n_vgm ) + deallocate (sc_vgm ) + deallocate (fc_vgm ) +#endif + deallocate (soiltext ) + + deallocate (fsatmax ) + deallocate (fsatdcf ) + deallocate (topoweti ) + deallocate (alp_twi ) + deallocate (chi_twi ) + deallocate (mu_twi ) + + deallocate (vic_b_infilt ) + deallocate (vic_Dsmax ) + deallocate (vic_Ds ) + deallocate (vic_Ws ) + deallocate (vic_c ) + + deallocate (hksati ) + deallocate (csol ) + deallocate (k_solids ) + deallocate (dksatu ) + deallocate (dksatf ) + deallocate (dkdry ) + deallocate (BA_alpha ) + deallocate (BA_beta ) + + deallocate (htop ) + deallocate (hbot ) + + deallocate (dbedrock ) + deallocate (ibedrock ) + + deallocate (elvmean ) + deallocate (elvstd ) + deallocate (slpratio ) + + IF (DEF_USE_Forcing_Downscaling) THEN + deallocate(slp_type_patches ) + deallocate(svf_patches ) + deallocate(asp_type_patches ) + deallocate(area_type_patches ) +#ifdef SinglePoint + deallocate(sf_lut_patches ) +#else + deallocate(sf_curve_patches ) +#endif + deallocate(cur_patches ) + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + deallocate(slp_type_patches ) + deallocate(asp_type_patches ) + deallocate(cur_patches ) + ENDIF + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL deallocate_PFTimeInvariants +#endif + +#ifdef BGC + CALL deallocate_BGCTimeInvariants +#endif + +#ifdef URBAN_MODEL + CALL deallocate_UrbanTimeInvariants +#endif + END SUBROUTINE deallocate_TimeInvariants + +#ifdef RangeCheck + SUBROUTINE check_TimeInvariants () + + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_Runoff_SCHEME, DEF_TOPMOD_method, DEF_USE_BEDROCK, & + DEF_USE_Forcing_Downscaling, DEF_USE_Forcing_Downscaling_Simple + + IMPLICIT NONE + + real(r8), allocatable :: tmpcheck(:,:) + + IF (p_is_master) THEN + write(*,'(/,A29)') 'Checking Time Invariants ...' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + CALL check_vector_data ('lakedepth [m] ', lakedepth ) ! + CALL check_vector_data ('dz_lake [m] ', dz_lake ) ! new lake scheme + + CALL check_vector_data ('soil_s_v_alb [-] ', soil_s_v_alb) ! albedo of visible of the saturated soil + CALL check_vector_data ('soil_d_v_alb [-] ', soil_d_v_alb) ! albedo of visible of the dry soil + CALL check_vector_data ('soil_s_n_alb [-] ', soil_s_n_alb) ! albedo of near infrared of the saturated soil + CALL check_vector_data ('soil_d_n_alb [-] ', soil_d_n_alb) ! albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + CALL check_vector_data ('soil_alb [-] ', soil_alb ) ! hyper spectral soil albedo. +#endif + CALL check_vector_data ('vf_quartz [m3/m3] ', vf_quartz ) ! volumetric fraction of quartz within mineral soil + CALL check_vector_data ('vf_gravels [m3/m3] ', vf_gravels ) ! volumetric fraction of gravels + CALL check_vector_data ('vf_sand [m3/m3] ', vf_sand ) ! volumetric fraction of sand + CALL check_vector_data ('vf_clay [m3/m3] ', vf_clay ) ! volumetric fraction of clay + CALL check_vector_data ('vf_om [m3/m3] ', vf_om ) ! volumetric fraction of organic matter + CALL check_vector_data ('wf_gravels [kg/kg] ', wf_gravels ) ! gravimetric fraction of gravels + CALL check_vector_data ('wf_sand [kg/kg] ', wf_sand ) ! gravimetric fraction of sand + CALL check_vector_data ('wf_clay [kg/kg] ', wf_clay ) ! gravimetric fraction of clay + CALL check_vector_data ('wf_om [kg/kg] ', wf_om ) ! gravimetric fraction of om + CALL check_vector_data ('OM_density [kg/m3] ', OM_density ) ! OM density + CALL check_vector_data ('BD_all [kg/m3] ', BD_all ) ! bulk density of soils + CALL check_vector_data ('wfc [m3/m3] ', wfc ) ! field capacity + CALL check_vector_data ('porsl [m3/m3] ', porsl ) ! fraction of soil that is voids [-] + CALL check_vector_data ('psi0 [mm] ', psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL check_vector_data ('bsw [-] ', bsw ) ! clapp and hornberger "b" parameter [-] +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL check_vector_data ('theta_r [m3/m3] ', theta_r ) ! residual moisture content [-] + CALL check_vector_data ('alpha_vgm [-] ', alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL check_vector_data ('L_vgm [-] ', L_vgm ) ! pore-connectivity parameter [dimensionless] + CALL check_vector_data ('n_vgm [-] ', n_vgm ) ! a shape parameter [dimensionless] + CALL check_vector_data ('sc_vgm [-] ', sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL check_vector_data ('fc_vgm [-] ', fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + + IF ((DEF_Runoff_SCHEME == 0) .and. (DEF_TOPMOD_method == 1)) THEN + CALL check_vector_data ('mean twi [log m] ', topoweti) ! + CALL check_vector_data ('max sat frac area [-]', fsatmax ) ! + CALL check_vector_data ('sat frac area decay ', fsatdcf ) ! + ENDIF + + IF ((DEF_Runoff_SCHEME == 0) .and. (DEF_TOPMOD_method == 2)) THEN + CALL check_vector_data ('mean twi [log m] ', topoweti) ! + CALL check_vector_data ('twi alpha in 3-gamma ', alp_twi ) + CALL check_vector_data ('twi chi in 3-gamma ', chi_twi ) + CALL check_vector_data ('twi mu in 3-gamma ', mu_twi ) + ENDIF + + CALL check_vector_data ('hksati [mm/s] ', hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + CALL check_vector_data ('csol [J/m3/K]', csol ) ! heat capacity of soil solids [J/(m3 K)] + CALL check_vector_data ('k_solids [W/m/K] ', k_solids ) ! thermal conductivity of soil solids [W/m-K] + CALL check_vector_data ('dksatu [W/m/K] ', dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + CALL check_vector_data ('dksatf [W/m/K] ', dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + CALL check_vector_data ('dkdry [W/m/K] ', dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + CALL check_vector_data ('BA_alpha [-] ', BA_alpha ) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL check_vector_data ('BA_beta [-] ', BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + + CALL check_vector_data ('soiltexture [-] ', soiltext, -1) ! + + CALL check_vector_data ('htop [m] ', htop ) + CALL check_vector_data ('hbot [m] ', hbot ) + + IF(DEF_USE_BEDROCK)THEN + CALL check_vector_data ('dbedrock [m] ', dbedrock ) ! + ENDIF + + CALL check_vector_data ('elvmean [m] ', elvmean ) ! + CALL check_vector_data ('elvstd [m] ', elvstd ) ! + CALL check_vector_data ('slpratio [-] ', slpratio ) ! + + IF (DEF_Runoff_SCHEME == 3) THEN + CALL check_vector_data ('BVIC [-] ', BVIC ) ! + ENDIF + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL check_vector_data ('slp_type [rad] ', slp_type_patches ) ! slope + CALL check_vector_data ('svf [-] ', svf_patches ) ! sky view factor + CALL check_vector_data ('asp_type [rad] ', asp_type_patches ) ! aspect + CALL check_vector_data ('area_type [-] ', area_type_patches) ! area percent + CALL check_vector_data ('cur [-] ', cur_patches ) +#ifdef SinglePoint + CALL check_vector_data ('sf_lut [-] ', sf_lut_patches ) ! shadow mask +#else + IF (allocated(sf_curve_patches)) allocate(tmpcheck(size(sf_curve_patches,1),size(sf_curve_patches,3))) + + IF (allocated(sf_curve_patches)) tmpcheck = sf_curve_patches(:,1,:) + CALL check_vector_data ('1 sf_curve p [-] ', tmpcheck) ! shadow mask + IF (allocated(sf_curve_patches)) tmpcheck = sf_curve_patches(:,2,:) + CALL check_vector_data ('2 sf_curve p [-] ', tmpcheck) ! shadow mask + IF (allocated(sf_curve_patches)) tmpcheck = sf_curve_patches(:,3,:) + CALL check_vector_data ('3 sf_curve p [-] ', tmpcheck) ! shadow mask + + IF (allocated(tmpcheck)) deallocate(tmpcheck) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + CALL check_vector_data ('slp_type [rad] ', slp_type_patches ) ! slope + CALL check_vector_data ('asp_type [-] ', asp_type_patches ) ! aspect fraction of direction of patches + CALL check_vector_data ('cur [-] ', cur_patches ) + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,'(/,A)') 'Checking Constants ...' + write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] + write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] + write(*,'(A,E20.10)') 'csoilc [-] ', csoilc ! drag coefficient for soil under canopy [-] + write(*,'(A,E20.10)') 'dewmx [mm] ', dewmx ! maximum dew + ! write(*,'(A,E20.10)') 'wtfact [-] ', wtfact ! fraction of model area with high water table + write(*,'(A,E20.10)') 'capr [-] ', capr ! tuning factor to turn first layer T into surface T + write(*,'(A,E20.10)') 'cnfac [-] ', cnfac ! Crank Nicholson factor between 0 and 1 + write(*,'(A,E20.10)') 'ssi [-] ', ssi ! irreducible water saturation of snow + write(*,'(A,E20.10)') 'wimp [m3/m3]', wimp ! water impermeable IF porosity less than wimp + write(*,'(A,E20.10)') 'pondmx [mm] ', pondmx ! ponding depth (mm) + write(*,'(A,E20.10)') 'smpmax [mm] ', smpmax ! wilting point potential in mm + write(*,'(A,E20.10)') 'smpmin [mm] ', smpmin ! restriction for min of soil poten. (mm) + write(*,'(A,E20.10)') 'smpmax_hr [mm]', smpmax_hr ! wilting point potential in mm + write(*,'(A,E20.10)') 'smpmin_hr [mm]', smpmin_hr ! restriction for min of soil poten. (mm) + write(*,'(A,E20.10)') 'trsmx0 [mm/s] ', trsmx0 ! max transpiration for moist soil+100% veg. [mm/s] + write(*,'(A,E20.10)') 'tcrit [K] ', tcrit ! critical temp. to determine rain or snow + write(*,'(A,E20.10)') 'wetwatmax [mm]', wetwatmax ! maximum wetland water (mm) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL check_PFTimeInvariants +#endif + +#ifdef BGC + CALL check_BGCTimeInvariants +#endif + + END SUBROUTINE check_TimeInvariants +#endif + +END MODULE MOD_Vars_TimeInvariants +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..6ebc93b313 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 @@ -0,0 +1,1644 @@ +#include + +!----------------------------------------------------------------------- +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +MODULE MOD_Vars_PFTimeVariables +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Define PFT time variables +! +! Added by Hua Yuan, 08/2019 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_TimeManager +#ifdef BGC + USE MOD_BGC_Vars_PFTimeVariables +#endif + + IMPLICIT NONE + SAVE +!----------------------------------------------------------------------- +! Time-varying state variables which required by restart run + + ! for LULC_IGBP_PFT or LULC_IGBP_PC + real(r8), allocatable :: tleaf_p (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_p (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_p (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_p (:) !depth of snow on foliage [mm] + real(r8), allocatable :: fwet_snow_p (:) !vegetation snow fractional cover [-] + real(r8), allocatable :: sigf_p (:) !fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: tlai_p (:) !leaf area index + real(r8), allocatable :: lai_p (:) !leaf area index + real(r8), allocatable :: laisun_p (:) !sunlit leaf area index + real(r8), allocatable :: laisha_p (:) !shaded leaf area index + real(r8), allocatable :: tsai_p (:) !stem area index + real(r8), allocatable :: sai_p (:) !stem area index + real(r8), allocatable :: ssun_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) + +#ifdef HYPERSPECTRAL + real(r8), allocatable :: ssun_hires_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_hires_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) +#endif + + real(r8), allocatable :: thermk_p (:) !canopy gap fraction for tir radiation + real(r8), allocatable :: fshade_p (:) !canopy shade fraction for tir radiation + real(r8), allocatable :: extkb_p (:) !(k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd_p (:) !diffuse and scattered diffuse PAR extinction coefficient + !TODO@yuan: to check the below for PC whether they are needed + real(r8), allocatable :: tref_p (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: t2m_wmo_p (:) !2 m WMO air temperature [kelvin] + real(r8), allocatable :: qref_p (:) !2 m height air specific humidity + real(r8), allocatable :: rst_p (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: z0m_p (:) !effective roughness [m] +! Plant Hydraulic variables + real(r8), allocatable :: vegwp_p (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_p (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_p (:) !working copy of shaded stomata conductance +! END plant hydraulic variables +! Ozone Stress Variables + real(r8), allocatable :: o3coefv_sun_p(:) !Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha_p(:) !Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun_p(:) !Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha_p(:) !Ozone stress factor for stomata on shaded leaf + real(r8), allocatable :: lai_old_p (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_p(:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_p(:) !Ozone does, shaded leaf (mmol O3/m^2) +! END Ozone Stress Variables +! irrigation variables + integer , allocatable :: irrig_method_p(:)!irrigation method +! END irrigation variables + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_PFTimeVariables + PUBLIC :: deallocate_PFTimeVariables + PUBLIC :: READ_PFTimeVariables + PUBLIC :: WRITE_PFTimeVariables +#ifdef RangeCheck + PUBLIC :: check_PFTimeVariables +#endif + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_PFTimeVariables () + !-------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpft] variables + !-------------------------------------------------------------------- + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + USE MOD_Vars_Global + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + allocate (tleaf_p (numpft)) ; tleaf_p (:) = spval !leaf temperature [K] + allocate (ldew_p (numpft)) ; ldew_p (:) = spval !depth of water on foliage [mm] + allocate (ldew_rain_p (numpft)) ; ldew_rain_p (:) = spval !depth of rain on foliage [mm] + allocate (ldew_snow_p (numpft)) ; ldew_snow_p (:) = spval !depth of snow on foliage [mm] + allocate (fwet_snow_p (numpft)) ; fwet_snow_p (:) = spval !vegetation snow fractional cover [-] + allocate (sigf_p (numpft)) ; sigf_p (:) = spval !fraction of veg cover, excluding snow-covered veg [-] + allocate (tlai_p (numpft)) ; tlai_p (:) = spval !leaf area index + allocate (lai_p (numpft)) ; lai_p (:) = spval !leaf area index + allocate (laisun_p (numpft)) ; laisun_p (:) = spval !leaf area index + allocate (laisha_p (numpft)) ; laisha_p (:) = spval !leaf area index + allocate (tsai_p (numpft)) ; tsai_p (:) = spval !stem area index + allocate (sai_p (numpft)) ; sai_p (:) = spval !stem area index + allocate (ssun_p (2,2,numpft)) ; ssun_p (:,:,:) = spval !sunlit canopy absorption for solar radiation (0-1) + allocate (ssha_p (2,2,numpft)) ; ssha_p (:,:,:) = spval !shaded canopy absorption for solar radiation (0-1) + +#ifdef HYPERSPECTRAL + allocate (ssun_hires_p (211,2,numpft)) ; ssun_hires_p (:,:,:) = spval !sunlit canopy absorption for solar radiation (0-1) + allocate (ssha_hires_p (211,2,numpft)) ; ssha_hires_p (:,:,:) = spval !shaded canopy absorption for solar radiation (0-1) +#endif + + allocate (thermk_p (numpft)) ; thermk_p (:) = spval !canopy gap fraction for tir radiation + allocate (fshade_p (numpft)) ; fshade_p (:) = spval !canopy shade fraction for tir radiation + allocate (extkb_p (numpft)) ; extkb_p (:) = spval !(k, g(mu)/mu) direct solar extinction coefficient + allocate (extkd_p (numpft)) ; extkd_p (:) = spval !diffuse and scattered diffuse PAR extinction coefficient + allocate (tref_p (numpft)) ; tref_p (:) = spval !2 m height air temperature [kelvin] + allocate (t2m_wmo_p (numpft)) ; t2m_wmo_p (:) = spval !2 m WMO air temperature [kelvin] + allocate (qref_p (numpft)) ; qref_p (:) = spval !2 m height air specific humidity + allocate (rst_p (numpft)) ; rst_p (:) = spval !canopy stomatal resistance (s/m) + allocate (z0m_p (numpft)) ; z0m_p (:) = spval !effective roughness [m] +! Plant Hydraulic variables + allocate (vegwp_p(1:nvegwcs,numpft)); vegwp_p (:,:) = spval + allocate (gs0sun_p (numpft)); gs0sun_p (:) = spval + allocate (gs0sha_p (numpft)); gs0sha_p (:) = spval +! END plant hydraulic variables +! Allocate Ozone Stress Variables + allocate (o3coefv_sun_p(numpft)) ; o3coefv_sun_p(:) = spval !Ozone stress factor for photosynthesis on sunlit leaf + allocate (o3coefv_sha_p(numpft)) ; o3coefv_sha_p(:) = spval !Ozone stress factor for photosynthesis on shaded leaf + allocate (o3coefg_sun_p(numpft)) ; o3coefg_sun_p(:) = spval !Ozone stress factor for stomata on sunlit leaf + allocate (o3coefg_sha_p(numpft)) ; o3coefg_sha_p(:) = spval !Ozone stress factor for stomata on shaded leaf + allocate (lai_old_p (numpft)) ; lai_old_p (:) = spval !lai in last time step + allocate (o3uptakesun_p(numpft)) ; o3uptakesun_p(:) = spval !Ozone does, sunlit leaf (mmol O3/m^2) + allocate (o3uptakesha_p(numpft)) ; o3uptakesha_p(:) = spval !Ozone does, shaded leaf (mmol O3/m^2) +! END allocate Ozone Stress Variables + allocate (irrig_method_p(numpft)); irrig_method_p(:) = 0! irrigation method + + ENDIF + ENDIF + +#ifdef BGC + CALL allocate_BGCPFTimeVariables +#endif + + END SUBROUTINE allocate_PFTimeVariables + + SUBROUTINE READ_PFTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + CALL ncio_read_vector (file_restart, 'tleaf_p ', landpft, tleaf_p ) + CALL ncio_read_vector (file_restart, 'ldew_p ', landpft, ldew_p ) + CALL ncio_read_vector (file_restart, 'ldew_rain_p',landpft, ldew_rain_p ) + CALL ncio_read_vector (file_restart, 'ldew_snow_p',landpft, ldew_snow_p ) + CALL ncio_read_vector (file_restart, 'fwet_snow_p',landpft, fwet_snow_p ) + CALL ncio_read_vector (file_restart, 'sigf_p ', landpft, sigf_p ) + CALL ncio_read_vector (file_restart, 'tlai_p ', landpft, tlai_p ) + CALL ncio_read_vector (file_restart, 'lai_p ', landpft, lai_p ) +! CALL ncio_read_vector (file_restart, 'laisun_p ', landpft, laisun_p ) +! CALL ncio_read_vector (file_restart, 'laisha_p ', landpft, laisha_p ) + CALL ncio_read_vector (file_restart, 'tsai_p ', landpft, tsai_p ) + CALL ncio_read_vector (file_restart, 'sai_p ', landpft, sai_p ) + CALL ncio_read_vector (file_restart, 'ssun_p ', 2,2, landpft, ssun_p ) + CALL ncio_read_vector (file_restart, 'ssha_p ', 2,2, landpft, ssha_p ) + +#ifdef HYPERSPECTRAL + CALL ncio_read_vector (file_restart, 'ssun_hires_p ', 211,2, landpft, ssun_hires_p ) + CALL ncio_read_vector (file_restart, 'ssha_hires_p ', 211,2, landpft, ssha_hires_p ) +#endif + + CALL ncio_read_vector (file_restart, 'thermk_p ', landpft, thermk_p ) + CALL ncio_read_vector (file_restart, 'fshade_p ', landpft, fshade_p ) + CALL ncio_read_vector (file_restart, 'extkb_p ', landpft, extkb_p ) + CALL ncio_read_vector (file_restart, 'extkd_p ', landpft, extkd_p ) + CALL ncio_read_vector (file_restart, 'tref_p ', landpft, tref_p ) + CALL ncio_read_vector (file_restart, 'qref_p ', landpft, qref_p ) + CALL ncio_read_vector (file_restart, 'rst_p ', landpft, rst_p ) + CALL ncio_read_vector (file_restart, 'z0m_p ', landpft, z0m_p ) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_read_vector (file_restart, 'vegwp_p ', nvegwcs, landpft, vegwp_p ) + CALL ncio_read_vector (file_restart, 'gs0sun_p ', landpft, gs0sun_p ) + CALL ncio_read_vector (file_restart, 'gs0sha_p ', landpft, gs0sha_p ) +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_read_vector (file_restart, 'lai_old_p ', landpft, lai_old_p , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'o3uptakesun_p', landpft, o3uptakesun_p, defval = 0._r8) + CALL ncio_read_vector (file_restart, 'o3uptakesha_p', landpft, o3uptakesha_p, defval = 0._r8) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL ncio_read_vector (file_restart,'irrig_method_p', landpft,irrig_method_p, defval = 0) +ENDIF + +#ifdef BGC + CALL read_BGCPFTimeVariables (file_restart) +#endif + + END SUBROUTINE READ_PFTimeVariables + + SUBROUTINE WRITE_PFTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION + USE MOD_LandPFT + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + CALL ncio_define_dimension_vector (file_restart, landpft, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpft, 'rtyp', 2) + + CALL ncio_define_dimension_vector (file_restart, landpft, 'wavelength', 211) + +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_define_dimension_vector (file_restart, landpft, 'vegnodes', nvegwcs) +ENDIF + + CALL ncio_write_vector (file_restart, 'tleaf_p ', 'pft', landpft, tleaf_p , compress) + CALL ncio_write_vector (file_restart, 'ldew_p ', 'pft', landpft, ldew_p , compress) + CALL ncio_write_vector (file_restart, 'ldew_rain_p','pft',landpft,ldew_rain_p,compress) + CALL ncio_write_vector (file_restart, 'ldew_snow_p','pft',landpft,ldew_snow_p,compress) + CALL ncio_write_vector (file_restart, 'fwet_snow_p','pft',landpft,fwet_snow_p,compress) + CALL ncio_write_vector (file_restart, 'sigf_p ', 'pft', landpft, sigf_p , compress) + CALL ncio_write_vector (file_restart, 'tlai_p ', 'pft', landpft, tlai_p , compress) + CALL ncio_write_vector (file_restart, 'lai_p ', 'pft', landpft, lai_p , compress) +! CALL ncio_write_vector (file_restart, 'laisun_p ', 'pft', landpft, laisun_p , compress) +! CALL ncio_write_vector (file_restart, 'laisha_p ', 'pft', landpft, laisha_p , compress) + CALL ncio_write_vector (file_restart, 'tsai_p ', 'pft', landpft, tsai_p , compress) + CALL ncio_write_vector (file_restart, 'sai_p ', 'pft', landpft, sai_p , compress) + CALL ncio_write_vector (file_restart, 'ssun_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssun_p, compress) + CALL ncio_write_vector (file_restart, 'ssha_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssha_p, compress) + +#ifdef HYPERSPECTRAL + CALL ncio_write_vector (file_restart, 'ssun_hires_p', 'wavelength', 211, 'rtyp', 2, 'pft', landpft, ssun_hires_p, compress) + CALL ncio_write_vector (file_restart, 'ssha_hires_p', 'wavelength', 211, 'rtyp', 2, 'pft', landpft, ssha_hires_p, compress) +#endif + + CALL ncio_write_vector (file_restart, 'thermk_p ', 'pft', landpft, thermk_p , compress) + CALL ncio_write_vector (file_restart, 'fshade_p ', 'pft', landpft, fshade_p , compress) + CALL ncio_write_vector (file_restart, 'extkb_p ', 'pft', landpft, extkb_p , compress) + CALL ncio_write_vector (file_restart, 'extkd_p ', 'pft', landpft, extkd_p , compress) + CALL ncio_write_vector (file_restart, 'tref_p ', 'pft', landpft, tref_p , compress) + CALL ncio_write_vector (file_restart, 'qref_p ', 'pft', landpft, qref_p , compress) + CALL ncio_write_vector (file_restart, 'rst_p ', 'pft', landpft, rst_p , compress) + CALL ncio_write_vector (file_restart, 'z0m_p ', 'pft', landpft, z0m_p , compress) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_write_vector (file_restart, 'vegwp_p ', 'vegnodes', nvegwcs, 'pft', landpft, vegwp_p, compress) + CALL ncio_write_vector (file_restart, 'gs0sun_p ', 'pft', landpft, gs0sun_p , compress) + CALL ncio_write_vector (file_restart, 'gs0sha_p ', 'pft', landpft, gs0sha_p , compress) +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_write_vector (file_restart, 'lai_old_p ', 'pft', landpft, lai_old_p , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun_p', 'pft', landpft, o3uptakesun_p, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha_p', 'pft', landpft, o3uptakesha_p, compress) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL ncio_write_vector (file_restart,'irrig_method_p','pft', landpft, irrig_method_p, compress) +ENDIF + +#ifdef BGC + CALL WRITE_BGCPFTimeVariables (file_restart) +#endif + + END SUBROUTINE WRITE_PFTimeVariables + + + SUBROUTINE deallocate_PFTimeVariables + !-------------------------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpft/numpc] variables + !-------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPFT + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + deallocate (tleaf_p ) ! leaf temperature [K] + deallocate (ldew_p ) ! depth of water on foliage [mm] + deallocate (ldew_rain_p ) ! depth of rain on foliage [mm] + deallocate (ldew_snow_p ) ! depth of snow on foliage [mm] + deallocate (fwet_snow_p ) ! vegetation snow fractional cover [-] + deallocate (sigf_p ) ! fraction of veg cover, excluding snow-covered veg [-] + deallocate (tlai_p ) ! leaf area index + deallocate (lai_p ) ! leaf area index + deallocate (laisun_p ) ! leaf area index + deallocate (laisha_p ) ! leaf area index + deallocate (tsai_p ) ! stem area index + deallocate (sai_p ) ! stem area index + deallocate (ssun_p ) ! sunlit canopy absorption for solar radiation (0-1) + deallocate (ssha_p ) ! shaded canopy absorption for solar radiation (0-1) + +#ifdef HYPERSPECTRAL + deallocate (ssun_hires_p ) ! sunlit canopy absorption for solar radiation (0-1) + deallocate (ssha_hires_p ) ! shaded canopy absorption for solar radiation (0-1) +#endif + + deallocate (thermk_p ) ! canopy gap fraction for tir radiation + deallocate (fshade_p ) ! canopy gap fraction for tir radiation + deallocate (extkb_p ) ! (k, g(mu)/mu) direct solar extinction coefficient + deallocate (extkd_p ) ! diffuse and scattered diffuse PAR extinction coefficient + deallocate (tref_p ) ! 2 m height air temperature [kelvin] + deallocate (t2m_wmo_p ) ! 2 m WMO air temperature [kelvin] + deallocate (qref_p ) ! 2 m height air specific humidity + deallocate (rst_p ) ! canopy stomatal resistance (s/m) + deallocate (z0m_p ) ! effective roughness [m] +! Plant Hydraulic variables + deallocate (vegwp_p ) ! vegetation water potential [mm] + deallocate (gs0sun_p ) ! working copy of sunlit stomata conductance + deallocate (gs0sha_p ) ! working copy of shaded stomata conductance +! END plant hydraulic variables +! Ozone Stress variables + deallocate (o3coefv_sun_p ) ! Ozone stress factor for photosynthesis on sunlit leaf + deallocate (o3coefv_sha_p ) ! Ozone stress factor for photosynthesis on shaded leaf + deallocate (o3coefg_sun_p ) ! Ozone stress factor for stomata on sunlit leaf + deallocate (o3coefg_sha_p ) ! Ozone stress factor for stomata on shaded leaf + deallocate (lai_old_p ) ! lai in last time step + deallocate (o3uptakesun_p ) ! Ozone does, sunlit leaf (mmol O3/m^2) + deallocate (o3uptakesha_p ) ! Ozone does, shaded leaf (mmol O3/m^2) + deallocate (irrig_method_p ) +! Ozone Stress variables + ENDIF + ENDIF + +#ifdef BGC + CALL deallocate_BGCPFTimeVariables +#endif + + END SUBROUTINE deallocate_PFTimeVariables + +#ifdef RangeCheck + SUBROUTINE check_PFTimeVariables + + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + + IMPLICIT NONE + + CALL check_vector_data (' tleaf_p', tleaf_p ) + CALL check_vector_data (' ldew_p', ldew_p ) + CALL check_vector_data (' ldew_rain_p', ldew_rain_p ) + CALL check_vector_data (' ldew_snow_p', ldew_snow_p ) + CALL check_vector_data (' fwet_snow_p', fwet_snow_p ) + CALL check_vector_data (' sigf_p', sigf_p ) + CALL check_vector_data (' tlai_p', tlai_p ) + CALL check_vector_data (' lai_p', lai_p ) + CALL check_vector_data (' laisun_p', lai_p ) + CALL check_vector_data (' laisha_p', lai_p ) + CALL check_vector_data (' tsai_p', tsai_p ) + CALL check_vector_data (' sai_p', sai_p ) + CALL check_vector_data (' ssun_p', ssun_p ) + CALL check_vector_data (' ssha_p', ssha_p ) + CALL check_vector_data (' thermk_p', thermk_p ) + CALL check_vector_data (' fshade_p', fshade_p ) + CALL check_vector_data (' extkb_p', extkb_p ) + CALL check_vector_data (' extkd_p', extkd_p ) + CALL check_vector_data (' tref_p', tref_p ) + CALL check_vector_data (' t2m_wmo_p', t2m_wmo_p ) + CALL check_vector_data (' qref_p', qref_p ) + CALL check_vector_data (' rst_p', rst_p ) + CALL check_vector_data (' z0m_p', z0m_p ) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data (' vegwp_p', vegwp_p ) + CALL check_vector_data (' gs0sun_p', gs0sun_p ) + CALL check_vector_data (' gs0sha_p', gs0sha_p ) +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL check_vector_data (' o3coefv_sun_p', o3coefv_sun_p ) + CALL check_vector_data (' o3coefv_sha_p', o3coefv_sha_p ) + CALL check_vector_data (' o3coefg_sun_p', o3coefg_sun_p ) + CALL check_vector_data (' o3coefg_sha_p', o3coefg_sha_p ) + CALL check_vector_data (' lai_old_p', lai_old_p ) + CALL check_vector_data (' o3uptakesun_p', o3uptakesun_p ) + CALL check_vector_data (' o3uptakesha_p', o3uptakesha_p ) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL check_vector_data ('irrig_method_p', irrig_method_p ) +ENDIF + +#ifdef BGC + CALL check_BGCPFTimeVariables +#endif + + END SUBROUTINE check_PFTimeVariables +#endif + +END MODULE MOD_Vars_PFTimeVariables +#endif + + +MODULE MOD_Vars_TimeVariables +! ------------------------------- +! Created by Yongjiu Dai, 03/2014 +! ------------------------------- + + USE MOD_Precision + USE MOD_TimeManager +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeVariables +#endif +#ifdef BGC + USE MOD_BGC_Vars_TimeVariables +#endif +#ifdef CatchLateralFlow + USE MOD_Catch_Vars_TimeVariables +#endif +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeTimeVars +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeVariables +#endif +#ifdef EXTERNAL_LAKE + USE MOD_Lake_TimeVars +#endif +#ifdef DataAssimilation + USE MOD_DA_Vars_TimeVariables +#endif + + IMPLICIT NONE + SAVE +! ----------------------------------------------------------------- +! Time-varying state variables which required by restart run + real(r8), allocatable :: z_sno (:,:) ! node depth [m] + real(r8), allocatable :: dz_sno (:,:) ! interface depth [m] + real(r8), allocatable :: t_soisno (:,:) ! soil temperature [K] + real(r8), allocatable :: wliq_soisno (:,:) ! liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno (:,:) ! ice lens in layers [kg/m2] + real(r8), allocatable :: h2osoi (:,:) ! volumetric soil water in layers [m3/m3] + real(r8), allocatable :: smp (:,:) ! soil matrix potential [mm] + real(r8), allocatable :: hk (:,:) ! hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: rootr (:,:) ! transpiration contribution fraction from different layers + real(r8), allocatable :: rootflux (:,:) ! water exchange between soil and root. Positive: soil->root [?] +!Plant Hydraulic variables + real(r8), allocatable :: vegwp (:,:) ! vegetation water potential [mm] + real(r8), allocatable :: gs0sun (:) ! working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha (:) ! working copy of shaded stomata conductance +!END plant hydraulic variables +!Ozone stress variables + real(r8), allocatable :: o3coefv_sun (:) ! Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha (:) ! Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun (:) ! Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha (:) ! Ozone stress factor for stomata on shaded leaf + real(r8), allocatable :: lai_old (:) ! lai in last time step + real(r8), allocatable :: o3uptakesun (:) ! Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha (:) ! Ozone does, shaded leaf (mmol O3/m^2) +!END ozone stress variables + real(r8), allocatable :: rstfacsun_out (:) ! factor of soil water stress on sunlit leaf + real(r8), allocatable :: rstfacsha_out (:) ! factor of soil water stress on shaded leaf + real(r8), allocatable :: gssun_out (:) ! stomata conductance on sunlit leaf + real(r8), allocatable :: gssha_out (:) ! stomata conductance on shaded leaf + real(r8), allocatable :: t_grnd (:) ! ground surface temperature [K] + + real(r8), allocatable :: assimsun_out (:) ! diagnostic sunlit leaf assim value for output + real(r8), allocatable :: assimsha_out (:) ! diagnostic sunlit leaf etr value for output + real(r8), allocatable :: etrsun_out (:) ! diagnostic shaded leaf assim for output + real(r8), allocatable :: etrsha_out (:) ! diagnostic shaded leaf etr for output + + real(r8), allocatable :: tleaf (:) ! leaf temperature [K] + real(r8), allocatable :: ldew (:) ! depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: fwet_snow (:) ! vegetation snow fractional cover [-] + real(r8), allocatable :: sag (:) ! non dimensional snow age [-] + real(r8), allocatable :: scv (:) ! snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp (:) ! snow depth [meter] + real(r8), allocatable :: fveg (:) ! fraction of vegetation cover + real(r8), allocatable :: fsno (:) ! fraction of snow cover on ground + real(r8), allocatable :: sigf (:) ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: green (:) ! leaf greenness + real(r8), allocatable :: tlai (:) ! leaf area index + real(r8), allocatable :: lai (:) ! leaf area index + real(r8), allocatable :: laisun (:) ! leaf area index for sunlit leaf + real(r8), allocatable :: laisha (:) ! leaf area index for shaded leaf + real(r8), allocatable :: tsai (:) ! stem area index + real(r8), allocatable :: sai (:) ! stem area index +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + real(r8), allocatable :: lai_enftemp (:) ! lai for needleleaf evergreen temperate tree (m2 m-2) + real(r8), allocatable :: lai_enfboreal (:) ! lai for needleleaf evergreen boreal tree (m2 m-2) + real(r8), allocatable :: lai_dnfboreal (:) ! lai for needleleaf deciduous boreal tree (m2 m-2) + real(r8), allocatable :: lai_ebftrop (:) ! lai for broadleaf evergreen tropical tree (m2 m-2) + real(r8), allocatable :: lai_ebftemp (:) ! lai for broadleaf evergreen temperate tree (m2 m-2) + real(r8), allocatable :: lai_dbftrop (:) ! lai for broadleaf deciduous tropical tree (m2 m-2) + real(r8), allocatable :: lai_dbftemp (:) ! lai for broadleaf deciduous temperate tree (m2 m-2) + real(r8), allocatable :: lai_dbfboreal (:) ! lai for broadleaf deciduous boreal tree (m2 m-2) + real(r8), allocatable :: lai_ebstemp (:) ! lai for broadleaf evergreen temperate shrub (m2 m-2) + real(r8), allocatable :: lai_dbstemp (:) ! lai for broadleaf deciduous temperate shrub (m2 m-2) + real(r8), allocatable :: lai_dbsboreal (:) ! lai for broadleaf deciduous boreal shrub (m2 m-2) + real(r8), allocatable :: lai_c3arcgrass(:) ! lai for c3 arctic grass (m2 m-2) + real(r8), allocatable :: lai_c3grass (:) ! lai for c3 grass (m2 m-2) + real(r8), allocatable :: lai_c4grass (:) ! lai for c4 grass (m2 m-2) +#endif + + real(r8), allocatable :: coszen (:) ! cosine of solar zenith angle + real(r8), allocatable :: alb (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: ssun (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha (:,:,:) ! shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssoi (:,:,:) ! soil absorption for solar radiation (0-1) + real(r8), allocatable :: ssno (:,:,:) ! snow absorption for solar radiation (0-1) +#ifdef HYPERSPECTRAL + ! new variables for hyperspectral scheme + real(r8), allocatable :: alb_hires (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: reflectance_out (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: transmittance_out (:,:,:) ! averaged albedo [-] +#endif + real(r8), allocatable :: thermk (:) ! canopy gap fraction for tir radiation + real(r8), allocatable :: extkb (:) ! (k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd (:) ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), allocatable :: zwt (:) ! the depth to water table [m] + real(r8), allocatable :: wa (:) ! water storage in aquifer [mm] + real(r8), allocatable :: wetwat (:) ! water storage in wetland [mm] + real(r8), allocatable :: wat (:) ! total water storage [mm] + real(r8), allocatable :: wdsrf (:) ! depth of surface water [mm] + real(r8), allocatable :: rss (:) ! soil surface resistance [s/m] + + real(r8), allocatable :: t_lake (:,:) ! lake layer temperature [K] + real(r8), allocatable :: lake_icefrac(:,:) ! lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1 (:) ! top level eddy conductivity (W/m K) + + real(r8), allocatable :: snw_rds (:,:) ! effective grain radius (col,lyr) [microns, m-6] + real(r8), allocatable :: mss_bcpho (:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_bcphi (:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocpho (:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocphi (:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst1 (:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst2 (:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst3 (:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst4 (:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), allocatable :: ssno_lyr(:,:,:,:) ! snow layer absorption [-] + + real(r8), allocatable :: trad (:) ! radiative temperature of surface [K] + real(r8), allocatable :: tref (:) ! 2 m height air temperature [kelvin] + real(r8), allocatable :: t2m_wmo (:) ! 2 m WMO air temperature [kelvin] + real(r8), allocatable :: qref (:) ! 2 m height air specific humidity + real(r8), allocatable :: rst (:) ! canopy stomatal resistance (s/m) + real(r8), allocatable :: emis (:) ! averaged bulk surface emissivity + real(r8), allocatable :: z0m (:) ! effective roughness [m] + real(r8), allocatable :: displa (:) ! zero displacement height [m] + real(r8), allocatable :: zol (:) ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), allocatable :: rib (:) ! bulk Richardson number in surface layer + real(r8), allocatable :: ustar (:) ! u* in similarity theory [m/s] + real(r8), allocatable :: qstar (:) ! q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar (:) ! t* in similarity theory [K] + real(r8), allocatable :: fm (:) ! integral of profile FUNCTION for momentum + real(r8), allocatable :: fh (:) ! integral of profile FUNCTION for heat + real(r8), allocatable :: fq (:) ! integral of profile FUNCTION for moisture + + real(r8), allocatable :: irrig_rate (:) ! irrigation rate [mm s-1] + real(r8), allocatable :: actual_irrig (:) ! actual irrigation amount [kg/m2] + real(r8), allocatable :: deficit_irrig (:) ! irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig (:) ! total irrigation amount [kg/m2] + real(r8), allocatable :: sum_deficit_irrig (:) ! total irrigation amount demand [kg/m2] + real(r8), allocatable :: sum_irrig_count (:) ! total irrigation counts [-] + integer , allocatable :: n_irrig_steps_left (:) ! left steps for once irrigation [-] + real(r8), allocatable :: waterstorage (:) ! water of water storage pool (from reservoir and river) [kg/m2] + real(r8), allocatable :: waterstorage_supply (:) ! irrigation supply from water storage pool [kg/m2] + real(r8), allocatable :: groundwater_demand (:) ! irrigation demand for ground water [kg/m2] + real(r8), allocatable :: groundwater_supply (:) ! irrigation supply from ground water [kg/m2] + real(r8), allocatable :: reservoirriver_demand(:)! irrigation demand for reservoir or river [kg/m2] + real(r8), allocatable :: reservoirriver_supply(:)! irrigation supply from reservoir or river [kg/m2] + real(r8), allocatable :: reservoir_supply (:)! irrigation supply from reservoir [kg/m2] + real(r8), allocatable :: river_supply (:)! irrigation supply from river [kg/m2] + real(r8), allocatable :: runoff_supply (:)! irrigation supply from runoff [kg/m2] + real(r8), allocatable :: tairday (:) ! daily mean temperature [degree C] + real(r8), allocatable :: usday (:) ! daily mean wind component in eastward direction [m/s] + real(r8), allocatable :: vsday (:) ! daily mean wind component in northward direction [m/s] + real(r8), allocatable :: pairday (:) ! daily mean pressure [kPa] + real(r8), allocatable :: rnetday (:) ! daily net radiation flux [MJ/m2/day] + real(r8), allocatable :: fgrndday (:) ! daily ground heat flux [MJ/m2/day] + real(r8), allocatable :: potential_evapotranspiration (:) ! daily potential evapotranspiration [mm/day] + + integer , allocatable :: irrig_method_corn (:) ! irrigation method for corn (0-3) + integer , allocatable :: irrig_method_swheat (:) ! irrigation method for spring wheat (0-3) + integer , allocatable :: irrig_method_wwheat (:) ! irrigation method for winter wheat (0-3) + integer , allocatable :: irrig_method_soybean (:) ! irrigation method for soybean (0-3) + integer , allocatable :: irrig_method_cotton (:) ! irrigation method for cotton (0-3) + integer , allocatable :: irrig_method_rice1 (:) ! irrigation method for rice1 (0-3) + integer , allocatable :: irrig_method_rice2 (:) ! irrigation method for rice2 (0-3) + integer , allocatable :: irrig_method_sugarcane (:) ! irrigation method for sugarcane (0-3) + + real(r8), allocatable :: irrig_gw_alloc (:) ! irrigation demand allocated to groundwater [kg/kg] + real(r8), allocatable :: irrig_sw_alloc (:) ! irrigation demand allocated to surfacewater [kg/kg] + real(r8), allocatable :: zwt_stand (:) ! initial the depth to water table [m] + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_TimeVariables + PUBLIC :: deallocate_TimeVariables + PUBLIC :: READ_TimeVariables + PUBLIC :: WRITE_TimeVariables +#ifdef RangeCheck + PUBLIC :: check_TimeVariables +#endif + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_TimeVariables + !-------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + !-------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate (z_sno (maxsnl+1:0, numpatch)); z_sno (:,:) = spval + allocate (dz_sno (maxsnl+1:0, numpatch)); dz_sno (:,:) = spval + allocate (t_soisno (maxsnl+1:nl_soil,numpatch)); t_soisno (:,:) = spval + allocate (wliq_soisno(maxsnl+1:nl_soil,numpatch)); wliq_soisno (:,:) = spval + allocate (wice_soisno(maxsnl+1:nl_soil,numpatch)); wice_soisno (:,:) = spval + allocate (smp (1:nl_soil,numpatch)); smp (:,:) = spval + allocate (hk (1:nl_soil,numpatch)); hk (:,:) = spval + allocate (h2osoi (1:nl_soil,numpatch)); h2osoi (:,:) = spval + allocate (rootr (1:nl_soil,numpatch)); rootr (:,:) = spval + allocate (rootflux (1:nl_soil,numpatch)); rootflux (:,:) = spval +!Plant Hydraulic variables + allocate (vegwp (1:nvegwcs,numpatch)); vegwp (:,:) = spval + allocate (gs0sun (numpatch)); gs0sun (:) = spval + allocate (gs0sha (numpatch)); gs0sha (:) = spval +!END plant hydraulic variables +!Ozone Stress variables + allocate (o3coefv_sun (numpatch)); o3coefv_sun (:) = spval + allocate (o3coefv_sha (numpatch)); o3coefv_sha (:) = spval + allocate (o3coefg_sun (numpatch)); o3coefg_sun (:) = spval + allocate (o3coefg_sha (numpatch)); o3coefg_sha (:) = spval + allocate (lai_old (numpatch)); lai_old (:) = spval + allocate (o3uptakesun (numpatch)); o3uptakesun (:) = spval + allocate (o3uptakesha (numpatch)); o3uptakesha (:) = spval +!END ozone stress variables + + allocate (rstfacsun_out (numpatch)); rstfacsun_out (:) = spval + allocate (rstfacsha_out (numpatch)); rstfacsha_out (:) = spval + allocate (gssun_out (numpatch)); gssun_out (:) = spval + allocate (gssha_out (numpatch)); gssha_out (:) = spval + allocate (assimsun_out (numpatch)); assimsun_out (:) = spval + allocate (assimsha_out (numpatch)); assimsha_out (:) = spval + allocate (etrsun_out (numpatch)); etrsun_out (:) = spval + allocate (etrsha_out (numpatch)); etrsha_out (:) = spval + + allocate (t_grnd (numpatch)); t_grnd (:) = spval + allocate (tleaf (numpatch)); tleaf (:) = spval + allocate (ldew (numpatch)); ldew (:) = spval + allocate (ldew_rain (numpatch)); ldew_rain (:) = spval + allocate (ldew_snow (numpatch)); ldew_snow (:) = spval + allocate (fwet_snow (numpatch)); fwet_snow (:) = spval + allocate (sag (numpatch)); sag (:) = spval + allocate (scv (numpatch)); scv (:) = spval + allocate (snowdp (numpatch)); snowdp (:) = spval + allocate (fveg (numpatch)); fveg (:) = spval + allocate (fsno (numpatch)); fsno (:) = spval + allocate (sigf (numpatch)); sigf (:) = spval + allocate (green (numpatch)); green (:) = spval + allocate (tlai (numpatch)); tlai (:) = spval + allocate (lai (numpatch)); lai (:) = spval + allocate (laisun (numpatch)); laisun (:) = spval + allocate (laisha (numpatch)); laisha (:) = spval + allocate (tsai (numpatch)); tsai (:) = spval + allocate (sai (numpatch)); sai (:) = spval + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + allocate (lai_enftemp (numpatch)); lai_enftemp (:) = spval + allocate (lai_enfboreal (numpatch)); lai_enfboreal (:) = spval + allocate (lai_dnfboreal (numpatch)); lai_dnfboreal (:) = spval + allocate (lai_ebftrop (numpatch)); lai_ebftrop (:) = spval + allocate (lai_ebftemp (numpatch)); lai_ebftemp (:) = spval + allocate (lai_dbftrop (numpatch)); lai_dbftrop (:) = spval + allocate (lai_dbftemp (numpatch)); lai_dbftemp (:) = spval + allocate (lai_dbfboreal (numpatch)); lai_dbfboreal (:) = spval + allocate (lai_ebstemp (numpatch)); lai_ebstemp (:) = spval + allocate (lai_dbstemp (numpatch)); lai_dbstemp (:) = spval + allocate (lai_dbsboreal (numpatch)); lai_dbsboreal (:) = spval + allocate (lai_c3arcgrass (numpatch)); lai_c3arcgrass(:) = spval + allocate (lai_c3grass (numpatch)); lai_c3grass (:) = spval + allocate (lai_c4grass (numpatch)); lai_c4grass (:) = spval +#endif + allocate (coszen (numpatch)); coszen (:) = spval + allocate (alb (2,2,numpatch)); alb (:,:,:) = spval + allocate (ssun (2,2,numpatch)); ssun (:,:,:) = spval + allocate (ssha (2,2,numpatch)); ssha (:,:,:) = spval + allocate (ssoi (2,2,numpatch)); ssoi (:,:,:) = spval + allocate (ssno (2,2,numpatch)); ssno (:,:,:) = spval +#ifdef HYPERSPECTRAL + ! high resolution parameters + allocate (alb_hires (211,2,numpatch)); alb_hires (:,:,:) = spval + allocate (reflectance_out (211,0:15,numpatch)); reflectance_out (:,:,:) = spval + allocate (transmittance_out (211,0:15,numpatch)); transmittance_out(:,:,:) = spval +#endif + allocate (thermk (numpatch)); thermk (:) = spval + allocate (extkb (numpatch)); extkb (:) = spval + allocate (extkd (numpatch)); extkd (:) = spval + allocate (zwt (numpatch)); zwt (:) = spval + allocate (wa (numpatch)); wa (:) = spval + allocate (wetwat (numpatch)); wetwat (:) = spval + allocate (wat (numpatch)); wat (:) = spval + allocate (wdsrf (numpatch)); wdsrf (:) = spval + allocate (rss (numpatch)); rss (:) = spval + allocate (t_lake (nl_lake,numpatch)); t_lake (:,:) = spval + allocate (lake_icefrac (nl_lake,numpatch)); lake_icefrac(:,:) = spval + allocate (savedtke1 (numpatch)); savedtke1 (:) = spval + + allocate (snw_rds (maxsnl+1:0,numpatch)); snw_rds (:,:) = spval + allocate (mss_bcpho (maxsnl+1:0,numpatch)); mss_bcpho (:,:) = spval + allocate (mss_bcphi (maxsnl+1:0,numpatch)); mss_bcphi (:,:) = spval + allocate (mss_ocpho (maxsnl+1:0,numpatch)); mss_ocpho (:,:) = spval + allocate (mss_ocphi (maxsnl+1:0,numpatch)); mss_ocphi (:,:) = spval + allocate (mss_dst1 (maxsnl+1:0,numpatch)); mss_dst1 (:,:) = spval + allocate (mss_dst2 (maxsnl+1:0,numpatch)); mss_dst2 (:,:) = spval + allocate (mss_dst3 (maxsnl+1:0,numpatch)); mss_dst3 (:,:) = spval + allocate (mss_dst4 (maxsnl+1:0,numpatch)); mss_dst4 (:,:) = spval + allocate (ssno_lyr (2,2,maxsnl+1:1,numpatch)); ssno_lyr(:,:,:,:) = spval + + allocate (trad (numpatch)); trad (:) = spval + allocate (tref (numpatch)); tref (:) = spval + allocate (t2m_wmo (numpatch)); t2m_wmo (:) = spval + allocate (qref (numpatch)); qref (:) = spval + allocate (rst (numpatch)); rst (:) = spval + allocate (emis (numpatch)); emis (:) = spval + allocate (z0m (numpatch)); z0m (:) = spval + allocate (displa (numpatch)); displa (:) = spval + allocate (zol (numpatch)); zol (:) = spval + allocate (rib (numpatch)); rib (:) = spval + allocate (ustar (numpatch)); ustar (:) = spval + allocate (qstar (numpatch)); qstar (:) = spval + allocate (tstar (numpatch)); tstar (:) = spval + allocate (fm (numpatch)); fm (:) = spval + allocate (fh (numpatch)); fh (:) = spval + allocate (fq (numpatch)); fq (:) = spval + + allocate ( irrig_rate (numpatch)); irrig_rate (:) = spval + allocate ( deficit_irrig (numpatch)); deficit_irrig (:) = spval + allocate ( actual_irrig (numpatch)); actual_irrig (:) = spval + allocate ( sum_irrig (numpatch)); sum_irrig (:) = spval + allocate ( sum_deficit_irrig (numpatch)); sum_deficit_irrig (:) = spval + allocate ( sum_irrig_count (numpatch)); sum_irrig_count (:) = spval + allocate ( n_irrig_steps_left (numpatch)); n_irrig_steps_left (:) = spval_i4 + allocate ( waterstorage (numpatch)); waterstorage (:) = spval + allocate ( waterstorage_supply (numpatch)); waterstorage_supply (:) = spval + allocate ( groundwater_demand (numpatch)); groundwater_demand (:) = spval + allocate ( groundwater_supply (numpatch)); groundwater_supply (:) = spval + allocate ( reservoirriver_demand (numpatch)); reservoirriver_demand (:) = spval + allocate ( reservoirriver_supply (numpatch)); reservoirriver_supply (:) = spval + allocate ( reservoir_supply (numpatch)); reservoir_supply (:) = spval + allocate ( river_supply (numpatch)); river_supply (:) = spval + allocate ( runoff_supply (numpatch)); runoff_supply (:) = spval + allocate ( tairday (numpatch)); tairday (:) = spval + allocate ( usday (numpatch)); usday (:) = spval + allocate ( vsday (numpatch)); vsday (:) = spval + allocate ( pairday (numpatch)); pairday (:) = spval + allocate ( rnetday (numpatch)); rnetday (:) = spval + allocate ( fgrndday (numpatch)); fgrndday (:) = spval + allocate ( potential_evapotranspiration(numpatch)); potential_evapotranspiration(:) = spval + + allocate ( irrig_method_corn (numpatch)); irrig_method_corn (:) = spval_i4 + allocate ( irrig_method_swheat (numpatch)); irrig_method_swheat (:) = spval_i4 + allocate ( irrig_method_wwheat (numpatch)); irrig_method_wwheat (:) = spval_i4 + allocate ( irrig_method_soybean (numpatch)); irrig_method_soybean (:) = spval_i4 + allocate ( irrig_method_cotton (numpatch)); irrig_method_cotton (:) = spval_i4 + allocate ( irrig_method_rice1 (numpatch)); irrig_method_rice1 (:) = spval_i4 + allocate ( irrig_method_rice2 (numpatch)); irrig_method_rice2 (:) = spval_i4 + allocate ( irrig_method_sugarcane (numpatch)); irrig_method_sugarcane (:) = spval_i4 + + allocate ( irrig_gw_alloc (numpatch)); irrig_gw_alloc (:) = spval + allocate ( irrig_sw_alloc (numpatch)); irrig_sw_alloc (:) = spval + allocate ( zwt_stand (numpatch)); zwt_stand (:) = spval + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL allocate_PFTimeVariables +#endif + +#ifdef BGC + CALL allocate_BGCTimeVariables +#endif + +#ifdef CatchLateralFlow + CALL allocate_CatchTimeVariables +#endif + +#ifdef GridRiverLakeFlow + CALL allocate_GridRiverLakeTimeVars +#endif + +#ifdef URBAN_MODEL + CALL allocate_UrbanTimeVariables +#endif + +#ifdef EXTERNAL_LAKE + CALL allocate_LakeTimeVars +#endif + +#ifdef DataAssimilation + CALL allocate_DATimeVariables +#endif + + END SUBROUTINE allocate_TimeVariables + + + + SUBROUTINE deallocate_TimeVariables () + + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + !-------------------------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + !-------------------------------------------------------------------- + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + deallocate (z_sno ) + deallocate (dz_sno ) + deallocate (t_soisno ) + deallocate (wliq_soisno ) + deallocate (wice_soisno ) + deallocate (smp ) + deallocate (hk ) + deallocate (h2osoi ) + deallocate (rootr ) + deallocate (rootflux ) +!Plant Hydraulic variables + deallocate (vegwp ) + deallocate (gs0sun ) + deallocate (gs0sha ) +!END plant hydraulic variables +!Ozone stress variables + deallocate (o3coefv_sun ) ! Ozone stress factor for photosynthesis on sunlit leaf + deallocate (o3coefv_sha ) ! Ozone stress factor for photosynthesis on shaded leaf + deallocate (o3coefg_sun ) ! Ozone stress factor for stomata on sunlit leaf + deallocate (o3coefg_sha ) ! Ozone stress factor for stomata on shaded leaf + deallocate (lai_old ) ! lai in last time step + deallocate (o3uptakesun ) ! Ozone does, sunlit leaf (mmol O3/m^2) + deallocate (o3uptakesha ) ! Ozone does, shaded leaf (mmol O3/m^2) +!END Ozone stress variables + deallocate (rstfacsun_out ) + deallocate (rstfacsha_out ) + deallocate (gssun_out ) + deallocate (gssha_out ) + deallocate (assimsun_out ) + deallocate (assimsha_out ) + deallocate (etrsun_out ) + deallocate (etrsha_out ) + + deallocate (t_grnd ) + deallocate (tleaf ) + deallocate (ldew ) + deallocate (ldew_rain ) + deallocate (ldew_snow ) + deallocate (fwet_snow ) + deallocate (sag ) + deallocate (scv ) + deallocate (snowdp ) + deallocate (fveg ) + deallocate (fsno ) + deallocate (sigf ) + deallocate (green ) + deallocate (tlai ) + deallocate (lai ) + deallocate (laisun ) + deallocate (laisha ) + deallocate (tsai ) + deallocate (sai ) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + deallocate (lai_enftemp ) + deallocate (lai_enfboreal ) + deallocate (lai_dnfboreal ) + deallocate (lai_ebftrop ) + deallocate (lai_ebftemp ) + deallocate (lai_dbftrop ) + deallocate (lai_dbftemp ) + deallocate (lai_dbfboreal ) + deallocate (lai_ebstemp ) + deallocate (lai_dbstemp ) + deallocate (lai_dbsboreal ) + deallocate (lai_c3arcgrass ) + deallocate (lai_c3grass ) + deallocate (lai_c4grass ) +#endif + deallocate (coszen ) + deallocate (alb ) + deallocate (ssun ) + deallocate (ssha ) + deallocate (ssoi ) + deallocate (ssno ) + deallocate (thermk ) + deallocate (extkb ) + deallocate (extkd ) + deallocate (zwt ) + deallocate (wa ) + deallocate (wetwat ) + deallocate (wat ) + deallocate (wdsrf ) + deallocate (rss ) + + deallocate (t_lake ) ! new lake scheme + deallocate (lake_icefrac ) ! new lake scheme + deallocate (savedtke1 ) ! new lake scheme + + deallocate (snw_rds ) + deallocate (mss_bcpho ) + deallocate (mss_bcphi ) + deallocate (mss_ocpho ) + deallocate (mss_ocphi ) + deallocate (mss_dst1 ) + deallocate (mss_dst2 ) + deallocate (mss_dst3 ) + deallocate (mss_dst4 ) + deallocate (ssno_lyr ) + + deallocate (trad ) + deallocate (tref ) + deallocate (t2m_wmo ) + deallocate (qref ) + deallocate (rst ) + deallocate (emis ) + deallocate (z0m ) + deallocate (displa ) + deallocate (zol ) + deallocate (rib ) + deallocate (ustar ) + deallocate (qstar ) + deallocate (tstar ) + deallocate (fm ) + deallocate (fh ) + deallocate (fq ) + + deallocate (irrig_rate ) + deallocate (deficit_irrig ) + deallocate (actual_irrig ) + deallocate (sum_irrig ) + deallocate (sum_deficit_irrig ) + deallocate (sum_irrig_count ) + deallocate (n_irrig_steps_left ) + deallocate (waterstorage ) + deallocate (waterstorage_supply ) + deallocate (groundwater_demand ) + deallocate (groundwater_supply ) + deallocate (reservoirriver_demand ) + deallocate (reservoirriver_supply ) + deallocate (reservoir_supply ) + deallocate (river_supply ) + deallocate (runoff_supply ) + deallocate (tairday ) + deallocate (usday ) + deallocate (vsday ) + deallocate (pairday ) + deallocate (rnetday ) + deallocate (fgrndday ) + deallocate (potential_evapotranspiration) + + deallocate (irrig_method_corn ) + deallocate (irrig_method_swheat ) + deallocate (irrig_method_wwheat ) + deallocate (irrig_method_soybean ) + deallocate (irrig_method_cotton ) + deallocate (irrig_method_rice1 ) + deallocate (irrig_method_rice2 ) + deallocate (irrig_method_sugarcane ) + + deallocate (irrig_gw_alloc ) + deallocate (irrig_sw_alloc ) + deallocate (zwt_stand ) + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL deallocate_PFTimeVariables +#endif + +#if (defined BGC) + CALL deallocate_BGCTimeVariables +#endif + +#ifdef CatchLateralFlow + CALL deallocate_CatchTimeVariables +#endif + +#ifdef GridRiverLakeFlow + CALL deallocate_GridRiverLakeTimeVars +#endif + +#if (defined URBAN_MODEL) + CALL deallocate_UrbanTimeVariables +#endif + +#ifdef EXTERNAL_LAKE + CALL deallocate_LakeTimeVars +#endif + +#ifdef DataAssimilation + CALL deallocate_DATimeVariables +#endif + + END SUBROUTINE deallocate_TimeVariables + + + !--------------------------------------- + FUNCTION save_to_restart (idate, deltim, itstamp, ptstamp, etstamp) result(rwrite) + + USE MOD_Namelist + IMPLICIT NONE + + logical :: rwrite + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + type(timestamp), intent(in) :: itstamp, ptstamp, etstamp + + + ! added by yuan, 08/31/2014 + SELECTCASE (trim(adjustl(DEF_WRST_FREQ))) + CASE ('TIMESTEP') + rwrite = .true. + CASE ('HOURLY') + rwrite = isendofhour (idate, deltim) + CASE ('DAILY') + rwrite = isendofday(idate, deltim) + CASE ('MONTHLY') + rwrite = isendofmonth(idate, deltim) + CASE ('YEARLY') + rwrite = isendofyear(idate, deltim) + CASE default + rwrite = .false. + write(*,*) 'Warning: Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for restart frequency.' + write(*,*) ' Set to FALSE by default. ' + ENDSELECT + + IF (rwrite) THEN + rwrite = ((ptstamp <= itstamp) .or. isendofyear(idate,deltim)) + ENDIF + + rwrite = rwrite .or. (.not. (itstamp < etstamp)) + + END FUNCTION save_to_restart + + + SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION, DEF_USE_Dynamic_Lake, SITE_landtype + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants, only: dz_lake + USE MOD_Const_LC, only: patchtypes + IMPLICIT NONE + + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(len=*), intent(in) :: site + character(len=*), intent(in) :: dir_restart + + ! Local variables + character(len=256) :: file_restart + character(len=14) :: cdate + character(len=256) :: cyear !character for lc_year + integer :: compress + + compress = DEF_REST_CompressLevel + + ! land cover type year + write(cyear,'(i4.4)') lc_year + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) + ENDIF +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + + + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_define_dimension_vector (file_restart, landpatch, 'vegnodes', nvegwcs) +ENDIF + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) +#ifdef HYPERSPECTRAL + CALL ncio_define_dimension_vector (file_restart, landpatch, 'wavelength', 211) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'PFT', 16) +#endif + ! Time-varying state variables which required by restart run + CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'patch', landpatch, z_sno , compress) ! node depth [m] + CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'patch', landpatch, dz_sno, compress) ! interface depth [m] + CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, t_soisno , compress) ! soil temperature [K] + CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wliq_soisno, compress) ! liquid water in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wice_soisno, compress) ! ice lens in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'patch', landpatch, smp, compress) ! soil matrix potential [mm] + CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'patch', landpatch, hk, compress) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_write_vector (file_restart, 'vegwp', 'vegnodes', nvegwcs, 'patch', landpatch, vegwp, compress) ! vegetation water potential [mm] + CALL ncio_write_vector (file_restart, 'gs0sun', 'patch', landpatch, gs0sun, compress) ! working copy of sunlit stomata conductance + CALL ncio_write_vector (file_restart, 'gs0sha', 'patch', landpatch, gs0sha, compress) ! working copy of shalit stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_write_vector (file_restart, 'lai_old ', 'patch', landpatch, lai_old , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun', 'patch', landpatch, o3uptakesun, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha', 'patch', landpatch, o3uptakesha, compress) + CALL ncio_write_vector (file_restart, 'o3coefv_sun', 'patch', landpatch, o3coefv_sun, compress) + CALL ncio_write_vector (file_restart, 'o3coefv_sha', 'patch', landpatch, o3coefv_sha, compress) + CALL ncio_write_vector (file_restart, 'o3coefg_sun', 'patch', landpatch, o3coefg_sun, compress) + CALL ncio_write_vector (file_restart, 'o3coefg_sha', 'patch', landpatch, o3coefg_sha, compress) +ENDIF + CALL ncio_write_vector (file_restart, 't_grnd ' , 'patch', landpatch, t_grnd , compress) ! ground surface temperature [K] + CALL ncio_write_vector (file_restart, 'tleaf ' , 'patch', landpatch, tleaf , compress) ! leaf temperature [K] + CALL ncio_write_vector (file_restart, 'ldew ' , 'patch', landpatch, ldew , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_rain' , 'patch', landpatch, ldew_rain , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_snow' , 'patch', landpatch, ldew_snow , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'fwet_snow' , 'patch', landpatch, fwet_snow , compress) ! vegetation snow fractional cover [-] + CALL ncio_write_vector (file_restart, 'sag ' , 'patch', landpatch, sag , compress) ! non dimensional snow age [-] + CALL ncio_write_vector (file_restart, 'scv ' , 'patch', landpatch, scv , compress) ! snow cover, water equivalent [mm] + CALL ncio_write_vector (file_restart, 'snowdp ' , 'patch', landpatch, snowdp , compress) ! snow depth [meter] + CALL ncio_write_vector (file_restart, 'fveg ' , 'patch', landpatch, fveg , compress) ! fraction of vegetation cover + CALL ncio_write_vector (file_restart, 'fsno ' , 'patch', landpatch, fsno , compress) ! fraction of snow cover on ground + CALL ncio_write_vector (file_restart, 'sigf ' , 'patch', landpatch, sigf , compress) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_write_vector (file_restart, 'green ' , 'patch', landpatch, green , compress) ! leaf greenness + CALL ncio_write_vector (file_restart, 'lai ' , 'patch', landpatch, lai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'tlai ' , 'patch', landpatch, tlai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'sai ' , 'patch', landpatch, sai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'tsai ' , 'patch', landpatch, tsai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'coszen ' , 'patch', landpatch, coszen , compress) ! cosine of solar zenith angle + CALL ncio_write_vector (file_restart, 'alb ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, alb , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'ssun ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssun, compress) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssha ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssha, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssoi ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssoi, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssno ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssno, compress) ! shaded canopy absorption for solar radiation (0-1) +#ifdef HYPERSPECTRAL + CALL ncio_write_vector (file_restart, 'alb_hires' , 'wavelength', 211, 'rtyp', 2, 'patch', landpatch, alb_hires , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'reflectance_out' , 'wavelength', 211, 'PFT', 16, 'patch', landpatch, reflectance_out , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'transmittance_out', 'wavelength', 211, 'PFT', 16, 'patch', landpatch, transmittance_out, compress) ! averaged albedo [-] +#endif + + CALL ncio_write_vector (file_restart, 'thermk ' , 'patch', landpatch, thermk , compress) ! canopy gap fraction for tir radiation + CALL ncio_write_vector (file_restart, 'extkb ' , 'patch', landpatch, extkb , compress) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_write_vector (file_restart, 'extkd ' , 'patch', landpatch, extkd , compress) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_write_vector (file_restart, 'zwt ' , 'patch', landpatch, zwt , compress) ! the depth to water table [m] + CALL ncio_write_vector (file_restart, 'wa ' , 'patch', landpatch, wa , compress) ! water storage in aquifer [mm] + CALL ncio_write_vector (file_restart, 'wetwat ' , 'patch', landpatch, wetwat , compress) ! water storage in wetland [mm] + CALL ncio_write_vector (file_restart, 'wdsrf ' , 'patch', landpatch, wdsrf , compress) ! depth of surface water [mm] + CALL ncio_write_vector (file_restart, 'rss ' , 'patch', landpatch, rss , compress) ! soil surface resistance [s/m] + +IF (DEF_USE_Dynamic_Lake) THEN + CALL ncio_write_vector (file_restart, 'dz_lake' , 'lake', nl_lake, 'patch', landpatch, dz_lake , compress) +ENDIF + CALL ncio_write_vector (file_restart, 't_lake ' , 'lake', nl_lake, 'patch', landpatch, t_lake , compress) + CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'patch', landpatch, lake_icefrac, compress) + CALL ncio_write_vector (file_restart, 'savedtke1 ', 'patch', landpatch, savedtke1 , compress) + CALL ncio_write_vector (file_restart, 'snw_rds ', 'snow', -maxsnl, 'patch', landpatch, snw_rds , compress) + CALL ncio_write_vector (file_restart, 'mss_bcpho', 'snow', -maxsnl, 'patch', landpatch, mss_bcpho, compress) + CALL ncio_write_vector (file_restart, 'mss_bcphi', 'snow', -maxsnl, 'patch', landpatch, mss_bcphi, compress) + CALL ncio_write_vector (file_restart, 'mss_ocpho', 'snow', -maxsnl, 'patch', landpatch, mss_ocpho, compress) + CALL ncio_write_vector (file_restart, 'mss_ocphi', 'snow', -maxsnl, 'patch', landpatch, mss_ocphi, compress) + CALL ncio_write_vector (file_restart, 'mss_dst1 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst1 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst2 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst2 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst3 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst3 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst4 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst4 , compress) + CALL ncio_write_vector (file_restart, 'ssno_lyr', 'band', 2, 'rtyp', 2, 'snowp1', -maxsnl+1, 'patch', landpatch, ssno_lyr, compress) + + ! Additional va_vectorriables required by regional model (such as WRF ) RSM) + CALL ncio_write_vector (file_restart, 'trad ', 'patch', landpatch, trad , compress) ! radiative temperature of surface [K] + CALL ncio_write_vector (file_restart, 'tref ', 'patch', landpatch, tref , compress) ! 2 m height air temperature [kelvin] + CALL ncio_write_vector (file_restart, 'qref ', 'patch', landpatch, qref , compress) ! 2 m height air specific humidity + CALL ncio_write_vector (file_restart, 'rst ', 'patch', landpatch, rst , compress) ! canopy stomatal resistance (s/m) + CALL ncio_write_vector (file_restart, 'emis ', 'patch', landpatch, emis , compress) ! averaged bulk surface emissivity + CALL ncio_write_vector (file_restart, 'z0m ', 'patch', landpatch, z0m , compress) ! effective roughness [m] + CALL ncio_write_vector (file_restart, 'zol ', 'patch', landpatch, zol , compress) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_write_vector (file_restart, 'rib ', 'patch', landpatch, rib , compress) ! bulk Richardson number in surface layer + CALL ncio_write_vector (file_restart, 'ustar', 'patch', landpatch, ustar, compress) ! u* in similarity theory [m/s] + CALL ncio_write_vector (file_restart, 'qstar', 'patch', landpatch, qstar, compress) ! q* in similarity theory [kg/kg] + CALL ncio_write_vector (file_restart, 'tstar', 'patch', landpatch, tstar, compress) ! t* in similarity theory [K] + CALL ncio_write_vector (file_restart, 'fm ', 'patch', landpatch, fm , compress) ! integral of profile FUNCTION for momentum + CALL ncio_write_vector (file_restart, 'fh ', 'patch', landpatch, fh , compress) ! integral of profile FUNCTION for heat + CALL ncio_write_vector (file_restart, 'fq ', 'patch', landpatch, fq , compress) ! integral of profile FUNCTION for moisture + +IF (DEF_USE_IRRIGATION) THEN + CALL ncio_write_vector (file_restart, 'irrig_rate ' , 'patch',landpatch,irrig_rate , compress) + CALL ncio_write_vector (file_restart, 'sum_irrig ' , 'patch',landpatch,sum_irrig , compress) + CALL ncio_write_vector (file_restart, 'sum_deficit_irrig ' , 'patch',landpatch,sum_deficit_irrig , compress) + CALL ncio_write_vector (file_restart, 'sum_irrig_count ' , 'patch',landpatch,sum_irrig_count , compress) + CALL ncio_write_vector (file_restart, 'n_irrig_steps_left ' , 'patch',landpatch,n_irrig_steps_left , compress) + CALL ncio_write_vector (file_restart, 'waterstorage ' , 'patch',landpatch,waterstorage , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_corn ' , 'patch',landpatch,irrig_method_corn , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_swheat ' , 'patch',landpatch,irrig_method_swheat , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_wwheat ' , 'patch',landpatch,irrig_method_wwheat , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_soybean ' , 'patch',landpatch,irrig_method_soybean , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_cotton ' , 'patch',landpatch,irrig_method_cotton , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_rice1 ' , 'patch',landpatch,irrig_method_rice1 , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_rice2 ' , 'patch',landpatch,irrig_method_rice2 , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_sugarcane' , 'patch',landpatch,irrig_method_sugarcane, compress) + CALL ncio_write_vector (file_restart, 'irrig_gw_alloc ' , 'patch',landpatch,irrig_gw_alloc , compress) + CALL ncio_write_vector (file_restart, 'irrig_sw_alloc ' , 'patch',landpatch,irrig_sw_alloc , compress) + CALL ncio_write_vector (file_restart, 'zwt_stand ' , 'patch',landpatch,zwt_stand , compress) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) == 0) THEN + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_PFTimeVariables (file_restart) + ENDIF +#else + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_PFTimeVariables (file_restart) +#endif +#endif + +#if (defined BGC) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_BGCTimeVariables (file_restart) +#endif + +#if (defined CatchLateralFlow) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_CatchTimeVariables (file_restart) +#endif + +#ifdef GridRiverLakeFlow + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_GridRiverLakeTimeVars (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_UrbanTimeVariables (file_restart) +#endif + +#ifdef EXTERNAL_LAKE + CALL WRITE_LakeTimeVars (idate, lc_year, site, dir_restart) +#endif + +#ifdef DataAssimilation + CALL WRITE_DATimeVariables (idate, lc_year, site, dir_restart) +#endif + + END SUBROUTINE WRITE_TimeVariables + + + SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants, only: dz_lake + USE MOD_Const_LC, only: patchtypes + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(len=*), intent(in) :: site + character(len=*), intent(in) :: dir_restart + + ! Local variables + character(len=256) :: file_restart + character(len=14) :: cdate, cyear + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,*) 'Loading Time Variables ...' + ENDIF + + ! land cover type year + write(cyear,'(i4.4)') lc_year + + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + + ! Time-varying state variables which required by restart run + CALL ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] + CALL ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] + CALL ncio_read_vector (file_restart, 't_soisno' , nl_soil-maxsnl, landpatch, t_soisno ) ! soil temperature [K] + CALL ncio_read_vector (file_restart, 'wliq_soisno', nl_soil-maxsnl, landpatch, wliq_soisno) ! liquid water in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'wice_soisno', nl_soil-maxsnl, landpatch, wice_soisno) ! ice lens in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'smp', nl_soil, landpatch, smp ) ! soil matrix potential [mm] + CALL ncio_read_vector (file_restart, 'hk', nl_soil, landpatch, hk ) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_read_vector (file_restart, 'vegwp', nvegwcs, landpatch, vegwp ) ! vegetation water potential [mm] + CALL ncio_read_vector (file_restart, 'gs0sun ', landpatch, gs0sun ) ! working copy of sunlit stomata conductance + CALL ncio_read_vector (file_restart, 'gs0sha ', landpatch, gs0sha ) ! working copy of shaded stomata conductance +ENDIF + CALL ncio_read_vector (file_restart, 't_grnd ' , landpatch, t_grnd ) ! ground surface temperature [K] + CALL ncio_read_vector (file_restart, 'tleaf ' , landpatch, tleaf ) ! leaf temperature [K] + CALL ncio_read_vector (file_restart, 'ldew ' , landpatch, ldew ) ! depth of water on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_rain' , landpatch, ldew_rain ) ! depth of rain on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_snow' , landpatch, ldew_snow ) ! depth of snow on foliage [mm] + CALL ncio_read_vector (file_restart, 'fwet_snow' , landpatch, fwet_snow ) ! vegetation snow fractional cover [-] + CALL ncio_read_vector (file_restart, 'sag ' , landpatch, sag ) ! non dimensional snow age [-] + CALL ncio_read_vector (file_restart, 'scv ' , landpatch, scv ) ! snow cover, water equivalent [mm] + CALL ncio_read_vector (file_restart, 'snowdp ' , landpatch, snowdp ) ! snow depth [meter] + CALL ncio_read_vector (file_restart, 'fveg ' , landpatch, fveg ) ! fraction of vegetation cover + CALL ncio_read_vector (file_restart, 'fsno ' , landpatch, fsno ) ! fraction of snow cover on ground + CALL ncio_read_vector (file_restart, 'sigf ' , landpatch, sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_read_vector (file_restart, 'green ' , landpatch, green ) ! leaf greenness + CALL ncio_read_vector (file_restart, 'lai ' , landpatch, lai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'tlai ' , landpatch, tlai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'sai ' , landpatch, sai ) ! stem area index + CALL ncio_read_vector (file_restart, 'tsai ' , landpatch, tsai ) ! stem area index + CALL ncio_read_vector (file_restart, 'coszen ' , landpatch, coszen ) ! cosine of solar zenith angle +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_read_vector (file_restart, 'lai_old ', landpatch, lai_old ) + CALL ncio_read_vector (file_restart, 'o3uptakesun', landpatch, o3uptakesun) + CALL ncio_read_vector (file_restart, 'o3uptakesha', landpatch, o3uptakesha) + CALL ncio_read_vector (file_restart, 'o3coefv_sun', landpatch, o3coefv_sun) + CALL ncio_read_vector (file_restart, 'o3coefv_sha', landpatch, o3coefv_sha) + CALL ncio_read_vector (file_restart, 'o3coefg_sun', landpatch, o3coefg_sun) + CALL ncio_read_vector (file_restart, 'o3coefg_sha', landpatch, o3coefg_sha) +ENDIF + CALL ncio_read_vector (file_restart, 'alb ' , 2, 2, landpatch, alb ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'ssun ' , 2, 2, landpatch, ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssha ' , 2, 2, landpatch, ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssoi ' , 2, 2, landpatch, ssoi ) ! soil absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssno ' , 2, 2, landpatch, ssno ) ! snow absorption for solar radiation (0-1) +#ifdef HYPERSPECTRAL + CALL ncio_read_vector (file_restart, 'alb_hires ' , 211, 2, landpatch, alb_hires ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'reflectance_out' , 211, 16, landpatch, reflectance_out ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'transmittance_out', 211, 16, landpatch, transmittance_out) ! averaged albedo [-] +#endif + + CALL ncio_read_vector (file_restart, 'thermk ' , landpatch, thermk ) ! canopy gap fraction for tir radiation + CALL ncio_read_vector (file_restart, 'extkb ' , landpatch, extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_read_vector (file_restart, 'extkd ' , landpatch, extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_read_vector (file_restart, 'zwt ' , landpatch, zwt ) ! the depth to water table [m] + CALL ncio_read_vector (file_restart, 'wa ' , landpatch, wa ) ! water storage in aquifer [mm] + CALL ncio_read_vector (file_restart, 'wetwat ' , landpatch, wetwat ) ! water storage in wetland [mm] + CALL ncio_read_vector (file_restart, 'wdsrf ' , landpatch, wdsrf ) ! depth of surface water [mm] + CALL ncio_read_vector (file_restart, 'rss ' , landpatch, rss ) ! soil surface resistance [s/m] + +IF (DEF_USE_Dynamic_Lake) THEN + CALL ncio_read_vector (file_restart, 'dz_lake' , nl_lake, landpatch, dz_lake ) +ENDIF + CALL ncio_read_vector (file_restart, 't_lake ' , nl_lake, landpatch, t_lake ) + CALL ncio_read_vector (file_restart, 'lake_icefrc', nl_lake, landpatch, lake_icefrac) + CALL ncio_read_vector (file_restart, 'savedtke1', landpatch, savedtke1) + + CALL ncio_read_vector (file_restart, 'snw_rds ', -maxsnl, landpatch, snw_rds ) + CALL ncio_read_vector (file_restart, 'mss_bcpho', -maxsnl, landpatch, mss_bcpho) + CALL ncio_read_vector (file_restart, 'mss_bcphi', -maxsnl, landpatch, mss_bcphi) + CALL ncio_read_vector (file_restart, 'mss_ocpho', -maxsnl, landpatch, mss_ocpho) + CALL ncio_read_vector (file_restart, 'mss_ocphi', -maxsnl, landpatch, mss_ocphi) + CALL ncio_read_vector (file_restart, 'mss_dst1 ', -maxsnl, landpatch, mss_dst1 ) + CALL ncio_read_vector (file_restart, 'mss_dst2 ', -maxsnl, landpatch, mss_dst2 ) + CALL ncio_read_vector (file_restart, 'mss_dst3 ', -maxsnl, landpatch, mss_dst3 ) + CALL ncio_read_vector (file_restart, 'mss_dst4 ', -maxsnl, landpatch, mss_dst4 ) + CALL ncio_read_vector (file_restart, 'ssno_lyr', 2,2, -maxsnl+1, landpatch, ssno_lyr) + + ! Additional variables required by regional model (such as WRF ) RSM) + CALL ncio_read_vector (file_restart, 'trad ', landpatch, trad ) ! radiative temperature of surface [K] + CALL ncio_read_vector (file_restart, 'tref ', landpatch, tref ) ! 2 m height air temperature [kelvin] + CALL ncio_read_vector (file_restart, 'qref ', landpatch, qref ) ! 2 m height air specific humidity + CALL ncio_read_vector (file_restart, 'rst ', landpatch, rst ) ! canopy stomatal resistance (s/m) + CALL ncio_read_vector (file_restart, 'emis ', landpatch, emis ) ! averaged bulk surface emissivity + CALL ncio_read_vector (file_restart, 'z0m ', landpatch, z0m ) ! effective roughness [m] + CALL ncio_read_vector (file_restart, 'zol ', landpatch, zol ) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_read_vector (file_restart, 'rib ', landpatch, rib ) ! bulk Richardson number in surface layer + CALL ncio_read_vector (file_restart, 'ustar', landpatch, ustar) ! u* in similarity theory [m/s] + CALL ncio_read_vector (file_restart, 'qstar', landpatch, qstar) ! q* in similarity theory [kg/kg] + CALL ncio_read_vector (file_restart, 'tstar', landpatch, tstar) ! t* in similarity theory [K] + CALL ncio_read_vector (file_restart, 'fm ', landpatch, fm ) ! integral of profile FUNCTION for momentum + CALL ncio_read_vector (file_restart, 'fh ', landpatch, fh ) ! integral of profile FUNCTION for heat + CALL ncio_read_vector (file_restart, 'fq ', landpatch, fq ) ! integral of profile FUNCTION for moisture + +IF (DEF_USE_IRRIGATION) THEN + CALL ncio_read_vector (file_restart, 'irrig_rate ' , landpatch, irrig_rate ) + CALL ncio_read_vector (file_restart, 'sum_irrig ' , landpatch, sum_irrig ) + CALL ncio_read_vector (file_restart, 'sum_deficit_irrig ' , landpatch, sum_deficit_irrig ) + CALL ncio_read_vector (file_restart, 'sum_irrig_count ' , landpatch, sum_irrig_count ) + CALL ncio_read_vector (file_restart, 'n_irrig_steps_left ' , landpatch, n_irrig_steps_left ) + CALL ncio_read_vector (file_restart, 'waterstorage ' , landpatch, waterstorage ) + CALL ncio_read_vector (file_restart, 'irrig_method_corn ' , landpatch, irrig_method_corn ) + CALL ncio_read_vector (file_restart, 'irrig_method_swheat ' , landpatch, irrig_method_swheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_wwheat ' , landpatch, irrig_method_wwheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_soybean ' , landpatch, irrig_method_soybean ) + CALL ncio_read_vector (file_restart, 'irrig_method_cotton ' , landpatch, irrig_method_cotton ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice1 ' , landpatch, irrig_method_rice1 ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice2 ' , landpatch, irrig_method_rice2 ) + CALL ncio_read_vector (file_restart, 'irrig_method_sugarcane' , landpatch, irrig_method_sugarcane) + CALL ncio_read_vector (file_restart, 'irrig_gw_alloc ' , landpatch, irrig_gw_alloc ) + CALL ncio_read_vector (file_restart, 'irrig_sw_alloc ' , landpatch, irrig_sw_alloc ) + CALL ncio_read_vector (file_restart, 'zwt_stand ' , landpatch, zwt_stand ) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) == 0) THEN + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_PFTimeVariables (file_restart) + ENDIF +#else + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_PFTimeVariables (file_restart) +#endif +#endif + +#if (defined BGC) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_BGCTimeVariables (file_restart) +#endif + +#if (defined CatchLateralFlow) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_CatchTimeVariables (file_restart) +#endif + +#ifdef GridRiverLakeFlow + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_GridRiverLakeTimeVars (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_UrbanTimeVariables (file_restart) +#endif + +#ifdef EXTERNAL_LAKE + CALL READ_LakeTimeVars(idate, lc_year, site, dir_restart) +#endif + +#ifdef DataAssimilation + CALL READ_DATimeVariables (idate, lc_year, site, dir_restart) +#endif + +#ifdef RangeCheck + CALL check_TimeVariables +#endif + + IF (p_is_master) THEN + write(*,*) 'Loading Time Variables done.' + ENDIF + + END SUBROUTINE READ_TimeVariables + + +#ifdef RangeCheck + SUBROUTINE check_TimeVariables () + + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & + DEF_USE_SNICAR, DEF_USE_Dynamic_Lake + USE MOD_Vars_TimeInvariants, only: dz_lake + + IMPLICIT NONE + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/,A27)') 'Checking Time Variables ...' + ENDIF + + CALL check_vector_data ('t_grnd [K] ', t_grnd ) ! ground surface temperature [K] + CALL check_vector_data ('tleaf [K] ', tleaf ) ! leaf temperature [K] + CALL check_vector_data ('ldew [mm] ', ldew ) ! depth of water on foliage [mm] + CALL check_vector_data ('ldew_rain [mm] ', ldew_rain ) ! depth of rain on foliage [mm] + CALL check_vector_data ('ldew_snow [mm] ', ldew_snow ) ! depth of snow on foliage [mm] + CALL check_vector_data ('fwet_snow [mm] ', fwet_snow ) ! vegetation snow fractional cover [-] + CALL check_vector_data ('sag [-] ', sag ) ! non dimensional snow age [-] + CALL check_vector_data ('scv [mm] ', scv ) ! snow cover, water equivalent [mm] + CALL check_vector_data ('snowdp [m] ', snowdp ) ! snow depth [meter] + CALL check_vector_data ('fveg [-] ', fveg ) ! fraction of vegetation cover + CALL check_vector_data ('fsno [-] ', fsno ) ! fraction of snow cover on ground + CALL check_vector_data ('sigf [-] ', sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL check_vector_data ('green [-] ', green ) ! leaf greenness + CALL check_vector_data ('lai [-] ', lai ) ! leaf area index + CALL check_vector_data ('tlai [-] ', tlai ) ! leaf area index + CALL check_vector_data ('sai [-] ', sai ) ! stem area index + CALL check_vector_data ('tsai [-] ', tsai ) ! stem area index + CALL check_vector_data ('coszen [-] ', coszen ) ! cosine of solar zenith angle + CALL check_vector_data ('alb [-] ', alb ) ! averaged albedo [-] + CALL check_vector_data ('ssun [-] ', ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssha [-] ', ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssoi [-] ', ssoi ) ! soil absorption for solar radiation (0-1) + CALL check_vector_data ('ssno [-] ', ssno ) ! snow absorption for solar radiation (0-1) + CALL check_vector_data ('thermk [-] ', thermk ) ! canopy gap fraction for tir radiation + CALL check_vector_data ('extkb [-] ', extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL check_vector_data ('extkd [-] ', extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL check_vector_data ('zwt [m] ', zwt ) ! the depth to water table [m] + CALL check_vector_data ('wa [mm] ', wa ) ! water storage in aquifer [mm] + CALL check_vector_data ('wetwat [mm] ', wetwat ) ! water storage in wetland [mm] + CALL check_vector_data ('wdsrf [mm] ', wdsrf ) ! depth of surface water [mm] + CALL check_vector_data ('rss [s/m] ', rss ) ! soil surface resistance [s/m] +IF (DEF_USE_Dynamic_Lake) THEN + CALL check_vector_data ('dz_lake [m] ', dz_lake )! +ENDIF + CALL check_vector_data ('t_lake [K] ', t_lake )! + CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac)! + CALL check_vector_data ('savedtke1 [W/m K]', savedtke1 )! + CALL check_vector_data ('z_sno [m] ', z_sno ) ! node depth [m] + CALL check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] + CALL check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] + CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] + CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] + CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] + CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] + CALL check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance + CALL check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shaded stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL check_vector_data ('o3coefv_sun ', o3coefv_sun) + CALL check_vector_data ('o3coefv_sha ', o3coefv_sha) + CALL check_vector_data ('o3coefg_sun ', o3coefg_sun) + CALL check_vector_data ('o3coefg_sha ', o3coefg_sha) + CALL check_vector_data ('lai_old ', lai_old ) + CALL check_vector_data ('o3uptakesun ', o3uptakesun) + CALL check_vector_data ('o3uptakesha ', o3uptakesha) +ENDIF + +IF (DEF_USE_SNICAR) THEN + CALL check_vector_data ('snw_rds [m-6] ', snw_rds ) + CALL check_vector_data ('mss_bcpho [Kg] ', mss_bcpho ) + CALL check_vector_data ('mss_bcphi [Kg] ', mss_bcphi ) + CALL check_vector_data ('mss_ocpho [Kg] ', mss_ocpho ) + CALL check_vector_data ('mss_ocphi [Kg] ', mss_ocphi ) + CALL check_vector_data ('mss_dst1 [Kg] ', mss_dst1 ) + CALL check_vector_data ('mss_dst2 [Kg] ', mss_dst2 ) + CALL check_vector_data ('mss_dst3 [Kg] ', mss_dst3 ) + CALL check_vector_data ('mss_dst4 [Kg] ', mss_dst4 ) + CALL check_vector_data ('ssno_lyr [-] ', ssno_lyr ) +ENDIF + +IF (DEF_USE_IRRIGATION) THEN + CALL check_vector_data ('irrig_rate ' , irrig_rate ) + CALL check_vector_data ('deficit_irrig ' , deficit_irrig ) + CALL check_vector_data ('actual_irrig ' , actual_irrig ) + CALL check_vector_data ('sum_irrig ' , sum_irrig ) + CALL check_vector_data ('sum_deficit_irrig ' , sum_deficit_irrig ) + CALL check_vector_data ('sum_irrig_count ' , sum_irrig_count ) + CALL check_vector_data ('n_irrig_steps_left ' , n_irrig_steps_left ) + CALL check_vector_data ('waterstorage ' , waterstorage ) + CALL check_vector_data ('waterstorage_supply ' , waterstorage_supply ) + CALL check_vector_data ('groundwater_demand ' , groundwater_demand ) + CALL check_vector_data ('groundwater_supply ' , groundwater_supply ) + CALL check_vector_data ('reservoirriver_demand ' , reservoirriver_demand ) + CALL check_vector_data ('reservoirriver_supply ' , reservoirriver_supply ) + CALL check_vector_data ('irrig_method_corn ' , irrig_method_corn ) + CALL check_vector_data ('irrig_method_swheat ' , irrig_method_swheat ) + CALL check_vector_data ('irrig_method_wwheat ' , irrig_method_wwheat ) + CALL check_vector_data ('irrig_method_soybean ' , irrig_method_soybean ) + CALL check_vector_data ('irrig_method_cotton ' , irrig_method_cotton ) + CALL check_vector_data ('irrig_method_rice1 ' , irrig_method_rice1 ) + CALL check_vector_data ('irrig_method_rice2 ' , irrig_method_rice2 ) + CALL check_vector_data ('irrig_method_sugarcane' , irrig_method_sugarcane) + CALL check_vector_data ('irrig_gw_alloc ' , irrig_gw_alloc ) + CALL check_vector_data ('irrig_sw_alloc ' , irrig_sw_alloc ) + CALL check_vector_data ('zwt_stand ' , zwt_stand ) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL check_PFTimeVariables +#endif + +#if (defined BGC) + CALL check_BGCTimeVariables +#endif + +#ifdef EXTERNAL_LAKE + CALL CHECK_LakeTimeVars +#endif + +#ifdef DataAssimilation + IF (DEF_DA_ENS_NUM > 1) CALL check_DATimeVariables +#endif + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE check_TimeVariables +#endif + + +END MODULE MOD_Vars_TimeVariables +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 new file mode 100644 index 0000000000..c892e935c2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 @@ -0,0 +1,146 @@ +#include + +MODULE MOD_VicParaReadin + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: vicpara_readin +CONTAINS + + SUBROUTINE vicpara_readin () + ! =========================================================== + ! ! DESCRIPTION: + ! Read in vic parameter from data + + ! =========================================================== + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_LandPatch + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + ! USE MOD_Mapping_Grid2Pset + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + ! USE MOD_Grid + ! USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_RangeCheck + USE MOD_Block + + + IMPLICIT NONE + character(len=256) :: file_vic_para + + type(grid_type) :: grid_b_infilt + type(grid_type) :: grid_Ws + type(grid_type) :: grid_Ds + type(grid_type) :: grid_DsM + + type(block_data_real8_2d) :: f_xy_b_infilt + type(block_data_real8_2d) :: f_xy_Ws + type(block_data_real8_2d) :: f_xy_Ds + type(block_data_real8_2d) :: f_xy_DsM + + type(spatial_mapping_type) :: mg2patch_b_infilt + type(spatial_mapping_type) :: mg2patch_Ws + type(spatial_mapping_type) :: mg2patch_Ds + type(spatial_mapping_type) :: mg2patch_DsM + + real(r8) ,allocatable :: b_infilt_tmp (:) + real(r8) ,allocatable :: Ws_tmp (:) + real(r8) ,allocatable :: Ds_tmp (:) + real(r8) ,allocatable :: DsM_tmp (:) + ! Local variables + real(r8), allocatable :: lat(:), lon(:) + real(r8) :: missing_value + integer :: cft, npatch, ipft + + file_vic_para = trim(DEF_file_VIC_OPT) + + CALL ncio_read_bcast_serial (file_vic_para, 'lat', lat) + CALL ncio_read_bcast_serial (file_vic_para, 'lon', lon) + + + CALL grid_b_infilt%define_by_center (lat, lon) + CALL grid_Ws%define_by_center (lat, lon) + CALL grid_Ds%define_by_center (lat, lon) + CALL grid_DsM%define_by_center (lat, lon) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_b_infilt, f_xy_b_infilt) + CALL allocate_block_data (grid_Ws, f_xy_Ws) + CALL allocate_block_data (grid_Ds, f_xy_Ds) + CALL allocate_block_data (grid_DsM, f_xy_DsM) + ENDIF + + IF (p_is_io) THEN + CALL ncio_read_block (file_vic_para,'b', grid_b_infilt, f_xy_b_infilt) + CALL ncio_read_block (file_vic_para,'Ws', grid_Ws, f_xy_Ws) + CALL ncio_read_block (file_vic_para,'Ds', grid_Ds, f_xy_Ds) + CALL ncio_read_block (file_vic_para,'DsM', grid_DsM, f_xy_DsM) + ENDIF + + CALL mg2patch_b_infilt%build_arealweighted (grid_b_infilt, landpatch) + CALL mg2patch_Ws%build_arealweighted (grid_Ws, landpatch) + CALL mg2patch_Ds%build_arealweighted (grid_Ds, landpatch) + CALL mg2patch_DsM%build_arealweighted (grid_DsM, landpatch) + + + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_worker) THEN + IF (numpatch > 0) allocate (b_infilt_tmp (numpatch)) + IF (numpatch > 0) allocate (Ws_tmp (numpatch)) + IF (numpatch > 0) allocate (Ds_tmp (numpatch)) + IF (numpatch > 0) allocate (DsM_tmp (numpatch)) + ENDIF + + CALL mg2patch_b_infilt%grid2pset (f_xy_b_infilt, b_infilt_tmp(:)) + CALL mg2patch_Ws%grid2pset (f_xy_Ws, Ws_tmp(:)) + CALL mg2patch_Ds%grid2pset (f_xy_Ds, Ds_tmp(:)) + CALL mg2patch_DsM%grid2pset (f_xy_DsM, DsM_tmp(:)) + + IF (p_is_worker) THEN + vic_b_infilt(:) = -9999 + vic_Dsmax(:) = -9999 + vic_Ds(:) = -9999 + vic_Ws(:) = -9999 + vic_c = 2 + ENDIF + + IF (p_is_worker) THEN + DO ipft = 1, numpatch + !WRITE(*,*) 'Values of vic_b_infilt: ', DsM_tmp(ipft) + vic_b_infilt(ipft) = b_infilt_tmp(ipft) + vic_Ws(ipft) = Ws_tmp(ipft) + vic_Ds(ipft) = Ds_tmp(ipft) + vic_Dsmax(ipft) = DsM_tmp(ipft) + vic_c(ipft)=2 + ENDDO + ! 输出 vic_b_infilt 数组的值 + !WRITE(*,*) 'Values of vic_b_infilt: ', vic_b_infilt + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('vic_b_infilt', vic_b_infilt) + CALL check_vector_data ('vic_Ws', vic_Ws) + CALL check_vector_data ('vic_Ds', vic_Ds) + CALL check_vector_data ('vic_Dsmax', vic_Dsmax) +#endif + IF (allocated (b_infilt_tmp)) deallocate (b_infilt_tmp) + IF (allocated (Ws_tmp)) deallocate (Ws_tmp) + IF (allocated (Ds_tmp)) deallocate (Ds_tmp) + IF (allocated (DsM_tmp)) deallocate (DsM_tmp) + + END SUBROUTINE vicpara_readin +END MODULE MOD_VicParaReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 new file mode 100644 index 0000000000..ca93a95083 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 @@ -0,0 +1,119 @@ +MODULE MOD_WetBulb + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: wetbulb + + +!----------------------------------------------------------------------- + + CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE wetbulb(t,p,q,twc) + +!======================================================================= +! Wet-bulb temperature +! +! Yongjiu Dai, 07/2013 +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, hvap, cpair + USE MOD_Qsadv + + IMPLICIT NONE + real(r8), intent(in) :: t ! air temperature [K] + real(r8), intent(in) :: p ! atmos pressure [pa] + real(r8), intent(in) :: q ! air specific humidity [kg/kg] + real(r8), intent(out) :: twc ! wet bulb temperature [K] + + integer i + real(r8) es, esdT, qs, qsdT, r, rws + +! ---------------------------------------------------------- +! real(r8) tcair ! dry-bulb temperature in celsius +! real(r8) bp ! approximate average barometric pressure [mb] +! real(r8) ea ! water vapor pressure in air [mb] +! real(r8) eas ! saturated water vapor pressure in air [mb] +! real(r8) delt ! delt=eas*4278.63/((tcair+242.792)*(tcair+242.792)) +! real(r8) tav ! average of dry-bulb temperature and wet bulb temperature in celsius +! real(r8) eav ! eav=2.7489E8*exp(-4278.63/(tav+242.792)) +! real(r8) rh ! relative humidity +! ---------------------------------------------------------- +! WETBULB computes wet-bulb temperatures from dry-bulb (tkair) and +! vapor pressure of air(ea). routine adapted from e. anderson, p. 188. +! ---------------------------------------------------------- +! CALL qsadv(t,p,es,esdT,qs,qsdT) +! rh = min(1.0,q/qs) +! bp = p/100.0 ! mb +! eas = es/100.0 ! mb +! ea = eas ! mb +! delt = esdT/100. ! mb/K +! +! tcair = t - tfrz +! +!* eas = 2.7489e8*exp(-4278.63/(tcair+242.792)) +!* delt = eas*4278.63/((tcair+242.792)*(tcair+242.792)) +! +! DO i = 1, 3 +! twc = delt*tcair+6.6e-4 *bp*tcair+7.59e-7*bp*tcair*tcair+ea-eas +! twc = twc/(delt+6.6e-4*bp+7.59e-7*bp*tcair) ! in celsius +! +! tav = 0.5*(tcair+twc)+tfrz +! CALL qsadv(tav,p,es,esdT,qs,qsdT) +! eav = es/100. +! delt = esdT/100. +! +!* tav = 0.5*(tcair+twc) +!* eav = 2.7489e8*exp(-4278.63/(tav+242.792)) +!* delt = eav*4278.63/((tav+242.792)*(tav+242.792)) +! ENDDO +! twc = twc + tfrz +! ---------------------------------------------------------- + +! ---------------------------------------------------------- +! the defining equation for the wetbulb temp Twb is +! f(Twb) = Twb-T - Lv/Cp [r-rs(Twb)] = 0, +! WHERE +! T = the dry-bulb temp (K), +! Lv = the latent heat of vaporization (J/kg/K), +! Cp = the specific heat of air at constant pressure, +! r = the water vapor mixing ratio [q/(1-q)], +! rs(Twb) = the saturation mixing ratio at wetbulb temp. +! http://www.asp.ucar.edu/colloquium/1992/notes/paet1/node81.html +! ---------------------------------------------------------- + CALL qsadv(t,p,es,esdT,qs,qsdT) + r = q/(1.0-q) + IF (q >= qs) r = qs/(1.0-qs) + twc = t + DO i = 1, 6 + CALL qsadv(twc,p,es,esdT,qs,qsdT) + rws= qs/(1.0-qs) + twc = (twc + t + hvap/cpair*(r-rws))/2.0 + ENDDO + +!*---------------------------------------------------------- +!*wetbulb temp as air temp and relative humidity at standard sea level pressure. +!*valid for RH% (5%-99%), T (-20C-50C). R. Stull, 2011: Wet-bulb temperature form +!*relative humidity and air temperature. J. Appl. Meteor. and Climatol., vol 50, 2267-2269. +!*---------------------------------------------------------- +!* tcair = t - tfrz +!* CALL qsadv(t,p,es,esdT,qs,qsdT) +!* rh = min(1.0,q/qs) +!* twc = tcair*atan(0.151977*(rh*100.+8.313659)**0.5) & +!* + atan(tcair+rh*100.)-atan(rh*100.-1.676331) & +!* + 0.00391838*(rh*100.)**1.5*atan(0.023101*rh*100.)-4.686035 +!* twc = twc + tfrz +!*---------------------------------------------------------- + + END SUBROUTINE wetbulb + +END MODULE MOD_WetBulb +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 new file mode 100644 index 0000000000..c66187ab10 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 @@ -0,0 +1,1181 @@ +! ******************************************************************************** +! dataSpec_PDB.f90 +! ******************************************************************************** +! lambda = wavelength (nm) +! refractive = refractive index of leaf material +! k_Cab = specific absorption coefficient of chlorophyll (a+b) (cm2.�g-1) +! k_Car = specific absorption coefficient of carotenoids (cm2.�g-1) +! k_Anth = specific absorption coefficient of Anthocyanins (cm2.�g-1) +! k_Cw = specific absorption coefficient of water (cm-1) +! k_Cm = specific absorption coefficient of dry matter (cm2.g-1) +! k_Bp = specific absorption coefficient of brown pigments (arbitrary units) +! ******************************************************************************** +! Reference: +! F�ret, Gitelson, Noble & Jacqumoud (2017). PROSPECT-D: Towards modeling +! leaf optical properties through a complete lifecycle +! Remote Sensing of Environment, 193:204�215 +! DOI: http://doi.org/10.1016/j.rse.2017.03.004 +! The specific absorption coefficient of brown pigments is provided by F. Baret +! (EMMAH, INRA Avignon, baret@avignon.inra.fr) and used with his autorization. +! ******************************************************************************** +! version 6.0 (16 January 2017) +! ******************************************************************************** + +module MOD_dataSpec_PDB + +USE MOD_Precision +implicit none +integer, parameter :: nw=2101 +integer i, lambda(nw) +real(r8) refractive(nw), k_Cab(nw), k_Car(nw), k_Anth(nw), k_Brown(nw), k_Cw(nw), k_Cm(nw) + + +! ******************************************************************************** +! Wavelength +! ******************************************************************************** + data (lambda(i),i=1,100)/& +400,401,402,403,404,405,406,407,408,409,& +410,411,412,413,414,415,416,417,418,419,& +420,421,422,423,424,425,426,427,428,429,& +430,431,432,433,434,435,436,437,438,439,& +440,441,442,443,444,445,446,447,448,449,& +450,451,452,453,454,455,456,457,458,459,& +460,461,462,463,464,465,466,467,468,469,& +470,471,472,473,474,475,476,477,478,479,& +480,481,482,483,484,485,486,487,488,489,& +490,491,492,493,494,495,496,497,498,499/ + data (lambda(i),i=101,200)/& +500,501,502,503,504,505,506,507,508,509,& +510,511,512,513,514,515,516,517,518,519,& +520,521,522,523,524,525,526,527,528,529,& +530,531,532,533,534,535,536,537,538,539,& +540,541,542,543,544,545,546,547,548,549,& +550,551,552,553,554,555,556,557,558,559,& +560,561,562,563,564,565,566,567,568,569,& +570,571,572,573,574,575,576,577,578,579,& +580,581,582,583,584,585,586,587,588,589,& +590,591,592,593,594,595,596,597,598,599/ + data (lambda(i),i=201,300)/& +600,601,602,603,604,605,606,607,608,609,& +610,611,612,613,614,615,616,617,618,619,& +620,621,622,623,624,625,626,627,628,629,& +630,631,632,633,634,635,636,637,638,639,& +640,641,642,643,644,645,646,647,648,649,& +650,651,652,653,654,655,656,657,658,659,& +660,661,662,663,664,665,666,667,668,669,& +670,671,672,673,674,675,676,677,678,679,& +680,681,682,683,684,685,686,687,688,689,& +690,691,692,693,694,695,696,697,698,699/ + data (lambda(i),i=301,400)/& +700,701,702,703,704,705,706,707,708,709,& +710,711,712,713,714,715,716,717,718,719,& +720,721,722,723,724,725,726,727,728,729,& +730,731,732,733,734,735,736,737,738,739,& +740,741,742,743,744,745,746,747,748,749,& +750,751,752,753,754,755,756,757,758,759,& +760,761,762,763,764,765,766,767,768,769,& +770,771,772,773,774,775,776,777,778,779,& +780,781,782,783,784,785,786,787,788,789,& +790,791,792,793,794,795,796,797,798,799/ + data (lambda(i),i=401,500)/& +800,801,802,803,804,805,806,807,808,809,& +810,811,812,813,814,815,816,817,818,819,& +820,821,822,823,824,825,826,827,828,829,& +830,831,832,833,834,835,836,837,838,839,& +840,841,842,843,844,845,846,847,848,849,& +850,851,852,853,854,855,856,857,858,859,& +860,861,862,863,864,865,866,867,868,869,& +870,871,872,873,874,875,876,877,878,879,& +880,881,882,883,884,885,886,887,888,889,& +890,891,892,893,894,895,896,897,898,899/ + data (lambda(i),i=501,600)/& +900,901,902,903,904,905,906,907,908,909,& +910,911,912,913,914,915,916,917,918,919,& +920,921,922,923,924,925,926,927,928,929,& +930,931,932,933,934,935,936,937,938,939,& +940,941,942,943,944,945,946,947,948,949,& +950,951,952,953,954,955,956,957,958,959,& +960,961,962,963,964,965,966,967,968,969,& +970,971,972,973,974,975,976,977,978,979,& +980,981,982,983,984,985,986,987,988,989,& +990,991,992,993,994,995,996,997,998,999/ + data (lambda(i),i=601,700)/& +1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,& +1010,1011,1012,1013,1014,1015,1016,1017,1018,1019,& +1020,1021,1022,1023,1024,1025,1026,1027,1028,1029,& +1030,1031,1032,1033,1034,1035,1036,1037,1038,1039,& +1040,1041,1042,1043,1044,1045,1046,1047,1048,1049,& +1050,1051,1052,1053,1054,1055,1056,1057,1058,1059,& +1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,& +1070,1071,1072,1073,1074,1075,1076,1077,1078,1079,& +1080,1081,1082,1083,1084,1085,1086,1087,1088,1089,& +1090,1091,1092,1093,1094,1095,1096,1097,1098,1099/ + data (lambda(i),i=701,800)/& +1100,1101,1102,1103,1104,1105,1106,1107,1108,1109,& +1110,1111,1112,1113,1114,1115,1116,1117,1118,1119,& +1120,1121,1122,1123,1124,1125,1126,1127,1128,1129,& +1130,1131,1132,1133,1134,1135,1136,1137,1138,1139,& +1140,1141,1142,1143,1144,1145,1146,1147,1148,1149,& +1150,1151,1152,1153,1154,1155,1156,1157,1158,1159,& +1160,1161,1162,1163,1164,1165,1166,1167,1168,1169,& +1170,1171,1172,1173,1174,1175,1176,1177,1178,1179,& +1180,1181,1182,1183,1184,1185,1186,1187,1188,1189,& +1190,1191,1192,1193,1194,1195,1196,1197,1198,1199/ + data (lambda(i),i=801,900)/& +1200,1201,1202,1203,1204,1205,1206,1207,1208,1209,& +1210,1211,1212,1213,1214,1215,1216,1217,1218,1219,& +1220,1221,1222,1223,1224,1225,1226,1227,1228,1229,& +1230,1231,1232,1233,1234,1235,1236,1237,1238,1239,& +1240,1241,1242,1243,1244,1245,1246,1247,1248,1249,& +1250,1251,1252,1253,1254,1255,1256,1257,1258,1259,& +1260,1261,1262,1263,1264,1265,1266,1267,1268,1269,& +1270,1271,1272,1273,1274,1275,1276,1277,1278,1279,& +1280,1281,1282,1283,1284,1285,1286,1287,1288,1289,& +1290,1291,1292,1293,1294,1295,1296,1297,1298,1299/ + data (lambda(i),i=901,1000)/& +1300,1301,1302,1303,1304,1305,1306,1307,1308,1309,& +1310,1311,1312,1313,1314,1315,1316,1317,1318,1319,& +1320,1321,1322,1323,1324,1325,1326,1327,1328,1329,& +1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,& +1340,1341,1342,1343,1344,1345,1346,1347,1348,1349,& +1350,1351,1352,1353,1354,1355,1356,1357,1358,1359,& +1360,1361,1362,1363,1364,1365,1366,1367,1368,1369,& +1370,1371,1372,1373,1374,1375,1376,1377,1378,1379,& +1380,1381,1382,1383,1384,1385,1386,1387,1388,1389,& +1390,1391,1392,1393,1394,1395,1396,1397,1398,1399/ + data (lambda(i),i=1001,1100)/& +1400,1401,1402,1403,1404,1405,1406,1407,1408,1409,& +1410,1411,1412,1413,1414,1415,1416,1417,1418,1419,& +1420,1421,1422,1423,1424,1425,1426,1427,1428,1429,& +1430,1431,1432,1433,1434,1435,1436,1437,1438,1439,& +1440,1441,1442,1443,1444,1445,1446,1447,1448,1449,& +1450,1451,1452,1453,1454,1455,1456,1457,1458,1459,& +1460,1461,1462,1463,1464,1465,1466,1467,1468,1469,& +1470,1471,1472,1473,1474,1475,1476,1477,1478,1479,& +1480,1481,1482,1483,1484,1485,1486,1487,1488,1489,& +1490,1491,1492,1493,1494,1495,1496,1497,1498,1499/ + data (lambda(i),i=1101,1200)/& +1500,1501,1502,1503,1504,1505,1506,1507,1508,1509,& +1510,1511,1512,1513,1514,1515,1516,1517,1518,1519,& +1520,1521,1522,1523,1524,1525,1526,1527,1528,1529,& +1530,1531,1532,1533,1534,1535,1536,1537,1538,1539,& +1540,1541,1542,1543,1544,1545,1546,1547,1548,1549,& +1550,1551,1552,1553,1554,1555,1556,1557,1558,1559,& +1560,1561,1562,1563,1564,1565,1566,1567,1568,1569,& +1570,1571,1572,1573,1574,1575,1576,1577,1578,1579,& +1580,1581,1582,1583,1584,1585,1586,1587,1588,1589,& +1590,1591,1592,1593,1594,1595,1596,1597,1598,1599/ + data (lambda(i),i=1201,1300)/& +1600,1601,1602,1603,1604,1605,1606,1607,1608,1609,& +1610,1611,1612,1613,1614,1615,1616,1617,1618,1619,& +1620,1621,1622,1623,1624,1625,1626,1627,1628,1629,& +1630,1631,1632,1633,1634,1635,1636,1637,1638,1639,& +1640,1641,1642,1643,1644,1645,1646,1647,1648,1649,& +1650,1651,1652,1653,1654,1655,1656,1657,1658,1659,& +1660,1661,1662,1663,1664,1665,1666,1667,1668,1669,& +1670,1671,1672,1673,1674,1675,1676,1677,1678,1679,& +1680,1681,1682,1683,1684,1685,1686,1687,1688,1689,& +1690,1691,1692,1693,1694,1695,1696,1697,1698,1699/ + data (lambda(i),i=1301,1400)/& +1700,1701,1702,1703,1704,1705,1706,1707,1708,1709,& +1710,1711,1712,1713,1714,1715,1716,1717,1718,1719,& +1720,1721,1722,1723,1724,1725,1726,1727,1728,1729,& +1730,1731,1732,1733,1734,1735,1736,1737,1738,1739,& +1740,1741,1742,1743,1744,1745,1746,1747,1748,1749,& +1750,1751,1752,1753,1754,1755,1756,1757,1758,1759,& +1760,1761,1762,1763,1764,1765,1766,1767,1768,1769,& +1770,1771,1772,1773,1774,1775,1776,1777,1778,1779,& +1780,1781,1782,1783,1784,1785,1786,1787,1788,1789,& +1790,1791,1792,1793,1794,1795,1796,1797,1798,1799/ + data (lambda(i),i=1401,1500)/& +1800,1801,1802,1803,1804,1805,1806,1807,1808,1809,& +1810,1811,1812,1813,1814,1815,1816,1817,1818,1819,& +1820,1821,1822,1823,1824,1825,1826,1827,1828,1829,& +1830,1831,1832,1833,1834,1835,1836,1837,1838,1839,& +1840,1841,1842,1843,1844,1845,1846,1847,1848,1849,& +1850,1851,1852,1853,1854,1855,1856,1857,1858,1859,& +1860,1861,1862,1863,1864,1865,1866,1867,1868,1869,& +1870,1871,1872,1873,1874,1875,1876,1877,1878,1879,& +1880,1881,1882,1883,1884,1885,1886,1887,1888,1889,& +1890,1891,1892,1893,1894,1895,1896,1897,1898,1899/ + data (lambda(i),i=1501,1600)/& +1900,1901,1902,1903,1904,1905,1906,1907,1908,1909,& +1910,1911,1912,1913,1914,1915,1916,1917,1918,1919,& +1920,1921,1922,1923,1924,1925,1926,1927,1928,1929,& +1930,1931,1932,1933,1934,1935,1936,1937,1938,1939,& +1940,1941,1942,1943,1944,1945,1946,1947,1948,1949,& +1950,1951,1952,1953,1954,1955,1956,1957,1958,1959,& +1960,1961,1962,1963,1964,1965,1966,1967,1968,1969,& +1970,1971,1972,1973,1974,1975,1976,1977,1978,1979,& +1980,1981,1982,1983,1984,1985,1986,1987,1988,1989,& +1990,1991,1992,1993,1994,1995,1996,1997,1998,1999/ + data (lambda(i),i=1601,1700)/& +2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,& +2010,2011,2012,2013,2014,2015,2016,2017,2018,2019,& +2020,2021,2022,2023,2024,2025,2026,2027,2028,2029,& +2030,2031,2032,2033,2034,2035,2036,2037,2038,2039,& +2040,2041,2042,2043,2044,2045,2046,2047,2048,2049,& +2050,2051,2052,2053,2054,2055,2056,2057,2058,2059,& +2060,2061,2062,2063,2064,2065,2066,2067,2068,2069,& +2070,2071,2072,2073,2074,2075,2076,2077,2078,2079,& +2080,2081,2082,2083,2084,2085,2086,2087,2088,2089,& +2090,2091,2092,2093,2094,2095,2096,2097,2098,2099/ + data (lambda(i),i=1701,1800)/& +2100,2101,2102,2103,2104,2105,2106,2107,2108,2109,& +2110,2111,2112,2113,2114,2115,2116,2117,2118,2119,& +2120,2121,2122,2123,2124,2125,2126,2127,2128,2129,& +2130,2131,2132,2133,2134,2135,2136,2137,2138,2139,& +2140,2141,2142,2143,2144,2145,2146,2147,2148,2149,& +2150,2151,2152,2153,2154,2155,2156,2157,2158,2159,& +2160,2161,2162,2163,2164,2165,2166,2167,2168,2169,& +2170,2171,2172,2173,2174,2175,2176,2177,2178,2179,& +2180,2181,2182,2183,2184,2185,2186,2187,2188,2189,& +2190,2191,2192,2193,2194,2195,2196,2197,2198,2199/ + data (lambda(i),i=1801,1900)/& +2200,2201,2202,2203,2204,2205,2206,2207,2208,2209,& +2210,2211,2212,2213,2214,2215,2216,2217,2218,2219,& +2220,2221,2222,2223,2224,2225,2226,2227,2228,2229,& +2230,2231,2232,2233,2234,2235,2236,2237,2238,2239,& +2240,2241,2242,2243,2244,2245,2246,2247,2248,2249,& +2250,2251,2252,2253,2254,2255,2256,2257,2258,2259,& +2260,2261,2262,2263,2264,2265,2266,2267,2268,2269,& +2270,2271,2272,2273,2274,2275,2276,2277,2278,2279,& +2280,2281,2282,2283,2284,2285,2286,2287,2288,2289,& +2290,2291,2292,2293,2294,2295,2296,2297,2298,2299/ + data (lambda(i),i=1901,2000)/& +2300,2301,2302,2303,2304,2305,2306,2307,2308,2309,& +2310,2311,2312,2313,2314,2315,2316,2317,2318,2319,& +2320,2321,2322,2323,2324,2325,2326,2327,2328,2329,& +2330,2331,2332,2333,2334,2335,2336,2337,2338,2339,& +2340,2341,2342,2343,2344,2345,2346,2347,2348,2349,& +2350,2351,2352,2353,2354,2355,2356,2357,2358,2359,& +2360,2361,2362,2363,2364,2365,2366,2367,2368,2369,& +2370,2371,2372,2373,2374,2375,2376,2377,2378,2379,& +2380,2381,2382,2383,2384,2385,2386,2387,2388,2389,& +2390,2391,2392,2393,2394,2395,2396,2397,2398,2399/ + data (lambda(i),i=2001,2101)/& +2400,2401,2402,2403,2404,2405,2406,2407,2408,2409,& +2410,2411,2412,2413,2414,2415,2416,2417,2418,2419,& +2420,2421,2422,2423,2424,2425,2426,2427,2428,2429,& +2430,2431,2432,2433,2434,2435,2436,2437,2438,2439,& +2440,2441,2442,2443,2444,2445,2446,2447,2448,2449,& +2450,2451,2452,2453,2454,2455,2456,2457,2458,2459,& +2460,2461,2462,2463,2464,2465,2466,2467,2468,2469,& +2470,2471,2472,2473,2474,2475,2476,2477,2478,2479,& +2480,2481,2482,2483,2484,2485,2486,2487,2488,2489,& +2490,2491,2492,2493,2494,2495,2496,2497,2498,2499,& +2500./ + +! ******************************************************************************** +! Refractive index +! ******************************************************************************** + + data (refractive(i),i=1,100)/& +1.5115,1.5115,1.5115,1.5115,1.5115,1.5115,1.5108,1.5101,1.5095,1.5088,& +1.5081,1.5076,1.5071,1.5065,1.506,1.5055,1.505,1.5046,1.5041,1.5037,& +1.5032,1.5029,1.5026,1.5022,1.5019,1.5016,1.5013,1.501,1.5008,1.5005,& +1.5002,1.5,1.4997,1.4995,1.4992,1.499,1.4988,1.4986,1.4984,1.4982,& +1.498,1.4977,1.4974,1.4972,1.4969,1.4966,1.4964,1.4962,1.4959,1.4957,& +1.4955,1.4953,1.4951,1.4949,1.4947,1.4945,1.4943,1.4942,1.494,1.4939,& +1.4937,1.4935,1.4934,1.4932,1.4931,1.4929,1.4928,1.4927,1.4925,1.4924,& +1.4923,1.4922,1.492,1.4919,1.4917,1.4916,1.4915,1.4914,1.4912,1.4911,& +1.491,1.4909,1.4907,1.4906,1.4904,1.4903,1.4902,1.49,1.4899,1.4897,& +1.4896,1.4895,1.4893,1.4892,1.489,1.4889,1.4887,1.4885,1.4884,1.4882/ + data (refractive(i),i=101,200)/& +1.488,1.4878,1.4876,1.4875,1.4873,1.4871,1.4869,1.4867,1.4865,1.4863,& +1.4861,1.4859,1.4856,1.4854,1.4851,1.4849,1.4846,1.4844,1.4841,1.4839,& +1.4836,1.4833,1.483,1.4828,1.4825,1.4822,1.4819,1.4816,1.4813,1.481,& +1.4807,1.4804,1.4801,1.4797,1.4794,1.4791,1.4788,1.4784,1.4781,1.4777,& +1.4774,1.4771,1.4767,1.4764,1.476,1.4757,1.4753,1.475,1.4746,1.4743,& +1.4739,1.4735,1.4732,1.4728,1.4725,1.4721,1.4717,1.4713,1.4709,1.4705,& +1.4701,1.4697,1.4693,1.4689,1.4685,1.4681,1.4677,1.4673,1.467,1.4666,& +1.4662,1.4658,1.4654,1.4651,1.4647,1.4643,1.4639,1.4635,1.4632,1.4628,& +1.4624,1.462,1.4616,1.4613,1.4609,1.4605,1.4602,1.4598,1.4595,1.4591,& +1.4588,1.4585,1.4582,1.4579,1.4576,1.4573,1.457,1.4567,1.4565,1.4562/ + data (refractive(i),i=201,300)/& +1.4559,1.4556,1.4553,1.4551,1.4548,1.4545,1.4543,1.454,1.4538,1.4535,& +1.4533,1.4531,1.4528,1.4526,1.4523,1.4521,1.4519,1.4517,1.4514,1.4512,& +1.451,1.4508,1.4506,1.4504,1.4502,1.45,1.4498,1.4497,1.4495,1.4494,& +1.4492,1.4491,1.4489,1.4488,1.4486,1.4485,1.4484,1.4483,1.4482,1.4481,& +1.448,1.4479,1.4478,1.4478,1.4477,1.4476,1.4475,1.4475,1.4474,1.4474,& +1.4473,1.4473,1.4472,1.4472,1.4471,1.4471,1.447,1.447,1.4469,1.4469,& +1.4468,1.4468,1.4468,1.4467,1.4467,1.4467,1.4466,1.4466,1.4465,1.4465,& +1.4464,1.4464,1.4463,1.4463,1.4462,1.4462,1.4461,1.446,1.446,1.4459,& +1.4458,1.4457,1.4457,1.4456,1.4456,1.4455,1.4454,1.4453,1.4453,1.4452,& +1.4451,1.445,1.445,1.4449,1.4449,1.4448,1.4447,1.4446,1.4446,1.4445/ + data (refractive(i),i=301,400)/& +1.4444,1.4443,1.4442,1.4441,1.444,1.4439,1.4438,1.4437,1.4435,1.4434,& +1.4433,1.4431,1.443,1.4428,1.4427,1.4425,1.4423,1.4422,1.442,1.4419,& +1.4417,1.4415,1.4413,1.4411,1.4409,1.4407,1.4405,1.4403,1.4402,1.44,& +1.4398,1.4396,1.4394,1.4393,1.4391,1.4389,1.4387,1.4385,1.4384,1.4382,& +1.438,1.4378,1.4377,1.4375,1.4374,1.4372,1.4371,1.437,1.4368,1.4367,& +1.4366,1.4364,1.4363,1.4361,1.436,1.4358,1.4357,1.4356,1.4354,1.4353,& +1.4352,1.4351,1.435,1.4349,1.4348,1.4347,1.4346,1.4345,1.4345,1.4344,& +1.4343,1.4343,1.4342,1.4342,1.4341,1.4341,1.4341,1.4341,1.434,1.434,& +1.434,1.434,1.434,1.434,1.434,1.434,1.434,1.4341,1.4341,1.4342,& +1.4342,1.4342,1.4342,1.4343,1.4343,1.4343,1.4343,1.4344,1.4344,1.4345/ + data (refractive(i),i=401,500)/& +1.4345,1.4345,1.4346,1.4346,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,& +1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,& +1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4348,1.4348,& +1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,& +1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4347,1.4347,& +1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4346,1.4346,& +1.4346,1.4346,1.4346,1.4345,1.4345,1.4345,1.4345,1.4345,1.4345,1.4345,& +1.4345,1.4345,1.4345,1.4344,1.4344,1.4344,1.4344,1.4343,1.4343,1.4342,& +1.4342,1.4342,1.4342,1.4341,1.4341,1.4341,1.4341,1.4341,1.434,1.434,& +1.434,1.434,1.4339,1.4339,1.4338,1.4338,1.4338,1.4338,1.4337,1.4337/ + data (refractive(i),i=501,600)/& +1.4337,1.4337,1.4336,1.4336,1.4335,1.4335,1.4335,1.4335,1.4334,1.4334,& +1.4334,1.4334,1.4333,1.4333,1.4332,1.4332,1.4332,1.4332,1.4331,1.4331,& +1.4331,1.4331,1.433,1.433,1.4329,1.4329,1.4329,1.4328,1.4328,1.4327,& +1.4327,1.4326,1.4326,1.4325,1.4325,1.4324,1.4324,1.4323,1.4323,1.4322,& +1.4322,1.4322,1.4321,1.4321,1.432,1.432,1.432,1.4319,1.4319,1.4318,& +1.4318,1.4318,1.4317,1.4317,1.4316,1.4316,1.4316,1.4315,1.4315,1.4314,& +1.4314,1.4313,1.4313,1.4312,1.4312,1.4311,1.431,1.431,1.4309,1.4309,& +1.4308,1.4307,1.4307,1.4306,1.4306,1.4305,1.4304,1.4304,1.4303,1.4303,& +1.4302,1.4301,1.43,1.43,1.4299,1.4298,1.4297,1.4297,1.4296,1.4296,& +1.4295,1.4294,1.4293,1.4293,1.4292,1.4291,1.429,1.4289,1.4289,1.4288/ + data (refractive(i),i=601,700)/& +1.4287,1.4286,1.4285,1.4285,1.4284,1.4283,1.4282,1.4281,1.4281,1.428,& +1.4279,1.4278,1.4277,1.4276,1.4275,1.4274,1.4273,1.4272,1.4272,1.4271,& +1.427,1.4269,1.4268,1.4267,1.4266,1.4265,1.4264,1.4263,1.4263,1.4262,& +1.4261,1.426,1.4259,1.4258,1.4257,1.4256,1.4255,1.4254,1.4253,1.4252,& +1.4251,1.425,1.4249,1.4248,1.4247,1.4246,1.4245,1.4244,1.4242,1.4241,& +1.424,1.4239,1.4238,1.4237,1.4236,1.4235,1.4234,1.4233,1.4232,1.4231,& +1.423,1.4229,1.4228,1.4226,1.4225,1.4224,1.4223,1.4222,1.422,1.4219,& +1.4218,1.4217,1.4216,1.4215,1.4214,1.4213,1.4212,1.4211,1.4209,1.4208,& +1.4207,1.4206,1.4205,1.4203,1.4202,1.4201,1.42,1.4199,1.4197,1.4196,& +1.4195,1.4194,1.4193,1.4191,1.419,1.4189,1.4188,1.4187,1.4185,1.4184/ + data (refractive(i),i=701,800)/& +1.4183,1.4182,1.4181,1.4179,1.4178,1.4177,1.4176,1.4175,1.4173,1.4172,& +1.4171,1.417,1.4169,1.4167,1.4166,1.4165,1.4164,1.4163,1.4161,1.416,& +1.4159,1.4158,1.4157,1.4156,1.4155,1.4154,1.4153,1.4152,1.415,1.4149,& +1.4148,1.4147,1.4146,1.4145,1.4144,1.4143,1.4142,1.4141,1.4139,1.4138,& +1.4137,1.4136,1.4135,1.4133,1.4132,1.4131,1.413,1.4129,1.4128,1.4127,& +1.4126,1.4125,1.4124,1.4122,1.4121,1.412,1.4119,1.4118,1.4117,1.4116,& +1.4115,1.4114,1.4113,1.4111,1.411,1.4109,1.4108,1.4107,1.4106,1.4105,& +1.4104,1.4103,1.4102,1.4101,1.41,1.4099,1.4098,1.4097,1.4096,1.4095,& +1.4094,1.4093,1.4092,1.409,1.4089,1.4088,1.4087,1.4086,1.4085,1.4084,& +1.4083,1.4082,1.4081,1.408,1.4079,1.4078,1.4077,1.4076,1.4075,1.4074/ + data (refractive(i),i=801,900)/& +1.4073,1.4072,1.4071,1.407,1.4069,1.4068,1.4067,1.4066,1.4065,1.4064,& +1.4063,1.4062,1.4061,1.406,1.4059,1.4058,1.4057,1.4056,1.4054,1.4053,& +1.4052,1.4051,1.405,1.4049,1.4048,1.4047,1.4046,1.4045,1.4044,1.4043,& +1.4042,1.4041,1.404,1.4038,1.4037,1.4036,1.4035,1.4034,1.4033,1.4032,& +1.4031,1.403,1.4029,1.4028,1.4027,1.4026,1.4025,1.4024,1.4023,1.4022,& +1.4021,1.402,1.4019,1.4017,1.4016,1.4015,1.4014,1.4013,1.4012,1.4011,& +1.401,1.4009,1.4008,1.4007,1.4006,1.4005,1.4004,1.4003,1.4001,1.4,& +1.3999,1.3998,1.3997,1.3996,1.3995,1.3994,1.3993,1.3992,1.3991,1.399,& +1.3989,1.3988,1.3987,1.3985,1.3984,1.3983,1.3982,1.3981,1.398,1.3979,& +1.3978,1.3977,1.3976,1.3975,1.3974,1.3973,1.3972,1.3971,1.397,1.3969/ + data (refractive(i),i=901,1000)/& +1.3968,1.3967,1.3966,1.3965,1.3964,1.3963,1.3962,1.3961,1.396,1.3959,& +1.3958,1.3957,1.3956,1.3955,1.3954,1.3953,1.3952,1.3951,1.3949,1.3948,& +1.3947,1.3946,1.3945,1.3944,1.3943,1.3942,1.3941,1.394,1.3939,1.3938,& +1.3937,1.3936,1.3935,1.3934,1.3933,1.3932,1.3931,1.393,1.3929,1.3928,& +1.3927,1.3926,1.3925,1.3924,1.3923,1.3922,1.3921,1.392,1.3919,1.3918,& +1.3917,1.3916,1.3915,1.3914,1.3913,1.3912,1.3911,1.391,1.3909,1.3908,& +1.3907,1.3906,1.3905,1.3904,1.3903,1.3902,1.3901,1.39,1.3899,1.3898,& +1.3897,1.3896,1.3895,1.3893,1.3892,1.3891,1.389,1.3889,1.3888,1.3887,& +1.3886,1.3885,1.3884,1.3883,1.3882,1.3881,1.388,1.3879,1.3877,1.3876,& +1.3875,1.3874,1.3873,1.3872,1.3871,1.387,1.3869,1.3868,1.3867,1.3866/ + data (refractive(i),i=1001,1100)/& +1.3865,1.3864,1.3863,1.3861,1.386,1.3859,1.3858,1.3857,1.3855,1.3854,& +1.3853,1.3852,1.3851,1.3849,1.3848,1.3847,1.3846,1.3845,1.3843,1.3842,& +1.3841,1.384,1.3839,1.3837,1.3836,1.3835,1.3834,1.3833,1.3831,1.383,& +1.3829,1.3828,1.3826,1.3825,1.3823,1.3822,1.3821,1.382,1.3818,1.3817,& +1.3816,1.3815,1.3813,1.3812,1.381,1.3809,1.3808,1.3807,1.3805,1.3804,& +1.3803,1.3802,1.38,1.3799,1.3797,1.3796,1.3794,1.3793,1.3791,1.379,& +1.3788,1.3787,1.3785,1.3784,1.3782,1.3781,1.3779,1.3778,1.3776,1.3775,& +1.3773,1.3772,1.377,1.3769,1.3767,1.3766,1.3764,1.3763,1.3761,1.376,& +1.3758,1.3756,1.3755,1.3753,1.3752,1.375,1.3748,1.3747,1.3745,1.3744,& +1.3742,1.374,1.3739,1.3737,1.3736,1.3734,1.3732,1.3731,1.3729,1.3728/ + data (refractive(i),i=1101,1200)/& +1.3726,1.3724,1.3723,1.3721,1.372,1.3718,1.3716,1.3715,1.3713,1.3712,& +1.371,1.3708,1.3706,1.3705,1.3703,1.3701,1.3699,1.3698,1.3696,1.3695,& +1.3693,1.3692,1.369,1.3689,1.3687,1.3686,1.3684,1.3683,1.3681,1.368,& +1.3678,1.3676,1.3675,1.3673,1.3672,1.367,1.3668,1.3666,1.3665,1.3663,& +1.3661,1.3659,1.3658,1.3656,1.3655,1.3653,1.3651,1.365,1.3648,1.3647,& +1.3645,1.3643,1.3641,1.364,1.3638,1.3636,1.3634,1.3633,1.3631,1.363,& +1.3628,1.3626,1.3625,1.3623,1.3622,1.362,1.3618,1.3617,1.3615,1.3614,& +1.3612,1.361,1.3608,1.3607,1.3605,1.3603,1.3601,1.36,1.3598,1.3597,& +1.3595,1.3593,1.3592,1.359,1.3589,1.3587,1.3585,1.3584,1.3582,1.3581,& +1.3579,1.3577,1.3576,1.3574,1.3573,1.3571,1.3569,1.3568,1.3566,1.3565/ + data (refractive(i),i=1201,1300)/& +1.3563,1.3561,1.356,1.3558,1.3557,1.3555,1.3553,1.3552,1.355,1.3549,& +1.3547,1.3545,1.3544,1.3542,1.3541,1.3539,1.3537,1.3536,1.3534,1.3533,& +1.3531,1.3529,1.3528,1.3526,1.3525,1.3523,1.3521,1.352,1.3518,1.3517,& +1.3515,1.3513,1.3512,1.351,1.3509,1.3507,1.3505,1.3504,1.3502,1.3501,& +1.3499,1.3498,1.3496,1.3495,1.3493,1.3492,1.349,1.3489,1.3487,1.3486,& +1.3484,1.3482,1.3481,1.3479,1.3478,1.3476,1.3475,1.3473,1.3472,1.347,& +1.3469,1.3467,1.3466,1.3464,1.3463,1.3461,1.3459,1.3458,1.3456,1.3455,& +1.3453,1.3452,1.345,1.3449,1.3447,1.3446,1.3445,1.3443,1.3442,1.344,& +1.3439,1.3438,1.3436,1.3435,1.3433,1.3432,1.3431,1.3429,1.3428,1.3426,& +1.3425,1.3424,1.3422,1.3421,1.3419,1.3418,1.3417,1.3415,1.3414,1.3412/ + data (refractive(i),i=1301,1400)/& +1.3411,1.341,1.3409,1.3407,1.3406,1.3405,1.3404,1.3402,1.3401,1.3399,& +1.3398,1.3397,1.3396,1.3394,1.3393,1.3392,1.3391,1.339,1.3388,1.3387,& +1.3386,1.3385,1.3383,1.3382,1.338,1.3379,1.3378,1.3377,1.3376,1.3375,& +1.3374,1.3373,1.3372,1.337,1.3369,1.3368,1.3367,1.3366,1.3365,1.3364,& +1.3363,1.3362,1.3361,1.3359,1.3358,1.3357,1.3356,1.3355,1.3354,1.3353,& +1.3352,1.3351,1.335,1.3349,1.3348,1.3347,1.3346,1.3345,1.3344,1.3343,& +1.3342,1.3341,1.334,1.3339,1.3338,1.3337,1.3336,1.3335,1.3334,1.3333,& +1.3332,1.3331,1.333,1.3329,1.3328,1.3327,1.3326,1.3325,1.3324,1.3323,& +1.3322,1.3321,1.332,1.332,1.3319,1.3318,1.3317,1.3316,1.3316,1.3315,& +1.3314,1.3313,1.3312,1.3311,1.331,1.3309,1.3308,1.3307,1.3307,1.3306/ + data (refractive(i),i=1401,1500)/& +1.3305,1.3304,1.3303,1.3303,1.3302,1.3301,1.33,1.3299,1.3299,1.3298,& +1.3297,1.3296,1.3295,1.3295,1.3294,1.3293,1.3292,1.3291,1.3291,1.329,& +1.3289,1.3288,1.3287,1.3287,1.3286,1.3285,1.3284,1.3283,1.3283,1.3282,& +1.3281,1.328,1.3279,1.3279,1.3278,1.3277,1.3276,1.3275,1.3275,1.3274,& +1.3273,1.3272,1.3271,1.3271,1.327,1.3269,1.3268,1.3268,1.3267,1.3267,& +1.3266,1.3265,1.3264,1.3264,1.3263,1.3262,1.3261,1.3261,1.326,1.326,& +1.3259,1.3258,1.3257,1.3257,1.3256,1.3255,1.3254,1.3254,1.3253,1.3253,& +1.3252,1.3251,1.325,1.325,1.3249,1.3248,1.3247,1.3247,1.3246,1.3246,& +1.3245,1.3244,1.3243,1.3243,1.3242,1.3241,1.324,1.324,1.3239,1.3239,& +1.3238,1.3237,1.3236,1.3236,1.3235,1.3234,1.3233,1.3233,1.3232,1.3232/ + data (refractive(i),i=1501,1600)/& +1.3231,1.323,1.323,1.3229,1.3229,1.3228,1.3227,1.3227,1.3226,1.3226,& +1.3225,1.3224,1.3224,1.3223,1.3223,1.3222,1.3221,1.322,1.322,1.3219,& +1.3218,1.3217,1.3217,1.3216,1.3216,1.3215,1.3214,1.3213,1.3213,1.3212,& +1.3211,1.321,1.321,1.3209,1.3209,1.3208,1.3207,1.3206,1.3206,1.3205,& +1.3204,1.3203,1.3203,1.3202,1.3202,1.3201,1.32,1.32,1.3199,1.3199,& +1.3198,1.3197,1.3197,1.3196,1.3196,1.3195,1.3194,1.3193,1.3193,1.3192,& +1.3191,1.319,1.319,1.3189,1.3189,1.3188,1.3187,1.3186,1.3186,1.3185,& +1.3184,1.3183,1.3183,1.3182,1.3182,1.3181,1.318,1.3179,1.3179,1.3178,& +1.3177,1.3176,1.3175,1.3175,1.3174,1.3173,1.3172,1.3171,1.3171,1.317,& +1.3169,1.3168,1.3167,1.3167,1.3166,1.3165,1.3164,1.3163,1.3163,1.3162/ + data (refractive(i),i=1601,1700)/& +1.3161,1.316,1.3159,1.3159,1.3158,1.3157,1.3156,1.3155,1.3154,1.3153,& +1.3152,1.3151,1.315,1.315,1.3149,1.3148,1.3147,1.3146,1.3146,1.3145,& +1.3144,1.3143,1.3142,1.3141,1.314,1.3139,1.3138,1.3137,1.3136,1.3135,& +1.3134,1.3133,1.3132,1.3131,1.313,1.3129,1.3128,1.3127,1.3126,1.3125,& +1.3124,1.3123,1.3122,1.3121,1.312,1.3119,1.3118,1.3117,1.3116,1.3115,& +1.3114,1.3113,1.3112,1.311,1.3109,1.3108,1.3107,1.3106,1.3105,1.3104,& +1.3103,1.3102,1.3101,1.3099,1.3098,1.3097,1.3096,1.3095,1.3094,1.3093,& +1.3092,1.3091,1.309,1.3088,1.3087,1.3086,1.3085,1.3084,1.3082,1.3081,& +1.308,1.3079,1.3078,1.3076,1.3075,1.3074,1.3073,1.3072,1.307,1.3069,& +1.3068,1.3067,1.3066,1.3064,1.3063,1.3062,1.3061,1.306,1.3059,1.3058/ + data (refractive(i),i=1701,1800)/& +1.3057,1.3056,1.3055,1.3053,1.3052,1.3051,1.305,1.3049,1.3047,1.3046,& +1.3045,1.3044,1.3043,1.3041,1.304,1.3039,1.3038,1.3037,1.3035,1.3034,& +1.3033,1.3032,1.3031,1.3029,1.3028,1.3027,1.3026,1.3025,1.3023,1.3022,& +1.3021,1.302,1.3019,1.3017,1.3016,1.3015,1.3014,1.3013,1.3011,1.301,& +1.3009,1.3008,1.3007,1.3005,1.3004,1.3003,1.3002,1.3001,1.2999,1.2998,& +1.2997,1.2996,1.2995,1.2993,1.2992,1.2991,1.299,1.2989,1.2987,1.2986,& +1.2985,1.2984,1.2983,1.2981,1.298,1.2979,1.2978,1.2977,1.2975,1.2974,& +1.2973,1.2972,1.297,1.2969,1.2967,1.2966,1.2965,1.2964,1.2962,1.2961,& +1.296,1.2959,1.2958,1.2957,1.2956,1.2955,1.2954,1.2953,1.2951,1.295,& +1.2949,1.2948,1.2947,1.2945,1.2944,1.2943,1.2942,1.2941,1.2939,1.2938/ + data (refractive(i),i=1801,1900)/& +1.2937,1.2936,1.2935,1.2933,1.2932,1.2931,1.293,1.2928,1.2927,1.2925,& +1.2924,1.2923,1.2922,1.292,1.2919,1.2918,1.2917,1.2916,1.2914,1.2913,& +1.2912,1.2911,1.291,1.2908,1.2907,1.2906,1.2905,1.2904,1.2902,1.2901,& +1.29,1.2899,1.2898,1.2896,1.2895,1.2894,1.2893,1.2892,1.289,1.2889,& +1.2888,1.2887,1.2886,1.2884,1.2883,1.2882,1.2881,1.288,1.2878,1.2877,& +1.2876,1.2875,1.2874,1.2873,1.2872,1.2871,1.287,1.2869,1.2867,1.2866,& +1.2865,1.2864,1.2863,1.2862,1.2861,1.286,1.2859,1.2858,1.2856,1.2855,& +1.2854,1.2853,1.2852,1.285,1.2849,1.2848,1.2847,1.2846,1.2845,1.2844,& +1.2843,1.2842,1.2841,1.284,1.2839,1.2838,1.2837,1.2836,1.2834,1.2833,& +1.2832,1.2831,1.283,1.2829,1.2828,1.2827,1.2826,1.2825,1.2824,1.2823/ + data (refractive(i),i=1901,2000)/& +1.2822,1.2821,1.282,1.2818,1.2817,1.2816,1.2815,1.2814,1.2813,1.2812,& +1.2811,1.281,1.2809,1.2808,1.2807,1.2806,1.2805,1.2804,1.2803,1.2802,& +1.2801,1.28,1.2799,1.2799,1.2798,1.2797,1.2796,1.2795,1.2795,1.2794,& +1.2793,1.2792,1.2791,1.2791,1.279,1.2789,1.2788,1.2788,1.2787,1.2787,& +1.2786,1.2785,1.2785,1.2784,1.2784,1.2783,1.2782,1.2781,1.278,1.2779,& +1.2778,1.2777,1.2776,1.2776,1.2775,1.2774,1.2773,1.2772,1.2771,1.277,& +1.2769,1.2768,1.2767,1.2766,1.2765,1.2764,1.2763,1.2762,1.2761,1.276,& +1.2759,1.2758,1.2757,1.2757,1.2756,1.2755,1.2754,1.2753,1.2753,1.2752,& +1.2751,1.275,1.2749,1.2749,1.2748,1.2747,1.2746,1.2745,1.2745,1.2744,& +1.2743,1.2742,1.2742,1.2741,1.2741,1.274,1.2739,1.2739,1.2738,1.2738/ + data (refractive(i),i=2001,2101)/& +1.2737,1.2736,1.2736,1.2735,1.2735,1.2734,1.2733,1.2733,1.2732,1.2732,& +1.2731,1.273,1.273,1.2729,1.2729,1.2728,1.2727,1.2727,1.2726,1.2726,& +1.2725,1.2725,1.2724,1.2724,1.2723,1.2723,1.2722,1.2722,1.2721,1.2721,& +1.272,1.272,1.2719,1.2719,1.2718,1.2718,1.2717,1.2717,1.2716,1.2716,& +1.2715,1.2715,1.2714,1.2714,1.2713,1.2713,1.2713,1.2713,1.2712,1.2712,& +1.2712,1.2712,1.2711,1.2711,1.271,1.271,1.271,1.271,1.2709,1.2709,& +1.2709,1.2709,1.2709,1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,& +1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,1.2709,1.2709,1.271,& +1.271,1.2711,1.2712,1.2712,1.2713,1.2714,1.2715,1.2716,1.2717,1.2718,& +1.2719,1.272,1.2722,1.2723,1.2725,1.2726,1.2728,1.273,1.2732,1.2734,& +1.2736/ + +! ******************************************************************************** +! Specific absorption coefficient of chlorophyll +! ******************************************************************************** + + data (k_Cab(i),i=1,100)/& +0.064881,0.066732,0.068551,0.069982,0.0709,0.071333,0.07132,0.07126,0.071223,0.071228,& +0.071491,0.071888,0.072018,0.071827,0.071493,0.071132,0.070763,0.070437,0.070094,0.06984,& +0.069819,0.070054,0.070281,0.070503,0.070473,0.070528,0.070809,0.071312,0.071622,0.071905,& +0.072449,0.073091,0.073652,0.074047,0.074335,0.074542,0.074691,0.074653,0.07457,0.074285,& +0.073794,0.072818,0.071622,0.070459,0.069105,0.067568,0.066026,0.064492,0.062668,0.060755,& +0.058775,0.056778,0.054732,0.052844,0.051125,0.049573,0.048139,0.046801,0.045645,0.044691,& +0.043873,0.043162,0.042653,0.042206,0.041774,0.041297,0.040911,0.040571,0.040302,0.040009,& +0.039727,0.039521,0.039292,0.039035,0.038773,0.038523,0.03826,0.037881,0.03751,0.037149,& +0.036776,0.0363,0.035761,0.03521,0.034583,0.033909,0.033184,0.032377,0.031519,0.030584,& +0.029662,0.028699,0.027692,0.02664,0.02559,0.024517,0.023428,0.022328,0.021224,0.020137/ + data (k_Cab(i),i=101,200)/& +0.019048,0.01798,0.016943,0.015923,0.014934,0.013979,0.01305,0.012154,0.011296,0.01048,& +0.0097008,0.008954,0.0082461,0.00758,0.0069574,0.0063867,0.005868,0.0054015,0.0049913,0.0046349,& +0.0043338,0.004085,0.0038874,0.0037421,0.0036525,0.0036118,0.0036193,0.0036728,0.0037697,0.0039032,& +0.004069,0.0042637,0.0044843,0.00473,0.0049935,0.0052728,0.0055645,0.0058662,0.0061706,0.0064792,& +0.0067864,0.00709,0.007388,0.0076742,0.0079483,0.0082083,0.0084536,0.008685,0.0089037,0.0091119,& +0.0093094,0.0095001,0.0096821,0.0098639,0.01004,0.010214,0.010386,0.010556,0.010724,0.010889,& +0.011048,0.011217,0.011402,0.011605,0.011827,0.012075,0.01234,0.012628,0.012933,0.01326,& +0.013598,0.013947,0.014301,0.014658,0.01501,0.015357,0.015693,0.016023,0.01634,0.016648,& +0.016945,0.017241,0.017527,0.017801,0.018066,0.018325,0.018568,0.0188,0.019019,0.019228,& +0.019419,0.019599,0.019766,0.019922,0.020066,0.020199,0.020327,0.020458,0.020585,0.020715/ + data (k_Cab(i),i=201,300)/& +0.020854,0.021007,0.021172,0.021348,0.021546,0.021764,0.022003,0.022268,0.022553,0.022859,& +0.023177,0.023502,0.023842,0.024199,0.024561,0.024917,0.025269,0.025617,0.02595,0.026255,& +0.02653,0.026786,0.02701,0.027207,0.027379,0.027523,0.027645,0.027739,0.027821,0.027895,& +0.027978,0.028072,0.028194,0.02836,0.028573,0.028846,0.029181,0.029599,0.030077,0.030634,& +0.031248,0.031927,0.032659,0.033441,0.034255,0.035101,0.035949,0.036779,0.037588,0.038323,& +0.039014,0.039631,0.040222,0.040804,0.041418,0.042107,0.04288,0.043808,0.044861,0.046107,& +0.047495,0.049113,0.050849,0.05273,0.0547,0.056761,0.058868,0.06083,0.06275,0.064472,& +0.066112,0.067471,0.068675,0.069635,0.070465,0.070995,0.071402,0.071358,0.071127,0.070185,& +0.068921,0.066576,0.063948,0.060482,0.056858,0.052747,0.048726,0.044707,0.040858,0.037141,& +0.033671,0.030459,0.027502,0.024787,0.02233,0.020144,0.018173,0.016421,0.014852,0.013471/ + data (k_Cab(i),i=301,400)/& +0.012241,0.011155,0.010193,0.009343,0.0085869,0.007915,0.0073126,0.0067711,0.0062803,0.0058322,& +0.0054214,0.0050449,0.0046965,0.0043735,0.004072,0.0037922,0.0035302,0.0032856,0.0030575,0.0028435,& +0.0026434,0.0024563,0.0022809,0.0021168,0.0019636,0.0018206,0.0016869,0.0015628,0.0014468,0.0013388,& +0.0012386,0.0011459,0.0010591,0.00097828,0.00090409,0.00083609,0.00077289,0.00071503,0.00066162,0.00061235,& +0.00056764,0.00052722,0.00048994,0.00045636,0.00042566,0.00039812,0.00037316,0.00035104,0.00033141,0.00031371,& +0.00029841,0.00028315,0.00026796,0.00025289,0.00023795,0.00022319,0.00020864,0.00019431,0.00018026,0.00016649,& +0.00015306,0.00013998,0.00012729,0.00011501,0.00010319,9.1841e-05,8.1005e-05,7.0709e-05,6.0985e-05,5.1862e-05,& +4.3372e-05,3.5545e-05,2.8412e-05,2.2003e-05,1.6349e-05,1.1481e-05,7.4298e-06,4.2252e-06,1.8983e-06,4.7969e-07,& +1.0525e-13,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0/ + data (k_Cab(i),i=401,2101)/1701*0./ + +! ******************************************************************************** +! Specific absorption coefficient of carotenoids +! ******************************************************************************** + + data (k_Car(i),i=1,100)/& +0.16734,0.16761,0.16718,0.16721,0.16761,0.1676,0.16751,0.16743,0.16724,0.16668,& +0.16588,0.16552,0.16545,0.16569,0.16609,0.16619,0.16629,0.16646,0.16662,0.16687,& +0.16716,0.16754,0.16798,0.16844,0.1686,0.16847,0.16814,0.168,0.16773,0.16741,& +0.16755,0.16774,0.16791,0.16797,0.16794,0.16797,0.16818,0.16832,0.1687,0.16916,& +0.16957,0.16968,0.16963,0.1699,0.16991,0.16981,0.16977,0.16973,0.16935,0.16857,& +0.16744,0.16602,0.16446,0.1629,0.16136,0.15978,0.15822,0.15656,0.15497,0.1533,& +0.15167,0.14997,0.14832,0.14677,0.14508,0.14349,0.142,0.14055,0.13919,0.13802,& +0.13701,0.13614,0.13548,0.135,0.13464,0.13437,0.13417,0.13394,0.13375,0.13356,& +0.13327,0.13279,0.13217,0.13141,0.13042,0.12922,0.12782,0.12631,0.12457,0.12269,& +0.12066,0.1186,0.11652,0.11441,0.11227,0.11011,0.10793,0.10573,0.1035,0.10126/ + data (k_Car(i),i=101,200)/& +0.099004,0.096734,0.09445,0.092156,0.089854,0.087544,0.085228,0.082909,0.080588,0.078267,& +0.075947,0.073631,0.071319,0.069014,0.066717,0.064431,0.062156,0.059895,0.057649,0.055421,& +0.053211,0.051021,0.048854,0.04671,0.044592,0.042502,0.040441,0.03841,0.036412,0.034449,& +0.032521,0.030631,0.028781,0.026971,0.025205,0.023483,0.021808,0.020181,0.018603,0.017077,& +0.015605,0.014187,0.012826,0.011524,0.010282,0.0091015,0.0079848,0.0069335,0.0059492,0.0050338,& +0.004189,0.0034164,0.0027178,0.0020949,0.0015495,0.0010832,0.00069786,0.00039514,0.00017677,4.448e-05,& +2.1316e-13,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0/ + data (k_Car(i),i=201,2101)/1901*0./ + +! ******************************************************************************** +! Specific absorption coefficient of anthocyanins +! ******************************************************************************** + + data (k_Anth(i),i=1,100)/& +0.066675,0.064056,0.061933,0.059922,0.058277,0.056699,0.055366,0.054163,0.053116,0.05198,& +0.050951,0.050117,0.049387,0.048604,0.047876,0.047379,0.046899,0.046532,0.046157,0.045792,& +0.045429,0.045144,0.044845,0.044536,0.044249,0.044116,0.043958,0.043874,0.043805,0.043858,& +0.043861,0.043912,0.043959,0.044037,0.04411,0.044203,0.044277,0.044399,0.04451,0.044647,& +0.044787,0.044919,0.045061,0.045227,0.045415,0.045589,0.045753,0.045857,0.045994,0.046195,& +0.046414,0.04668,0.046953,0.047162,0.04736,0.047593,0.047814,0.048082,0.048335,0.048595,& +0.048839,0.049123,0.04937,0.049608,0.049841,0.050136,0.05042,0.050784,0.05115,0.051557,& +0.051941,0.052387,0.05282,0.053409,0.05399,0.054462,0.05494,0.055543,0.056155,0.056638,& +0.057152,0.057689,0.058265,0.058847,0.059478,0.060054,0.06067,0.061221,0.061809,0.062358,& +0.062922,0.063434,0.06397,0.064462,0.064964,0.065431,0.06591,0.066378,0.066852,0.067309/ + data (k_Anth(i),i=101,200)/& +0.067771,0.068133,0.068479,0.068815,0.06914,0.069362,0.069563,0.069828,0.070073,0.070279,& +0.070472,0.070679,0.070872,0.071025,0.071165,0.071285,0.07139,0.071486,0.071573,0.07163,& +0.071682,0.071739,0.071775,0.071815,0.071864,0.071959,0.07206,0.072153,0.07224,0.072295,& +0.072349,0.072414,0.072476,0.07251,0.072528,0.072529,0.072506,0.072433,0.07234,0.07221,& +0.072063,0.071837,0.071602,0.071343,0.071067,0.070707,0.070307,0.06984,0.069355,0.068756,& +0.06814,0.06744,0.066733,0.065904,0.065061,0.06421,0.063357,0.062437,0.061518,0.060579,& +0.059652,0.058611,0.057591,0.056554,0.055543,0.054379,0.053243,0.052056,0.0509,0.049671,& +0.048481,0.047309,0.046174,0.045,0.043871,0.042781,0.041734,0.040618,0.039543,0.038457,& +0.037412,0.0362,0.035043,0.033919,0.032846,0.031701,0.030606,0.029616,0.028665,0.027715,& +0.026803,0.025951,0.025134,0.024293,0.023487,0.022687,0.021918,0.021085,0.020284,0.019497/ + data (k_Anth(i),i=201,300)/& +0.01874,0.017977,0.017242,0.016604,0.015987,0.01541,0.014845,0.014317,0.0138,0.013295,& +0.012801,0.012336,0.011884,0.011394,0.010918,0.010464,0.010022,0.0095808,0.0091553,0.0087766,& +0.008411,0.0080523,0.0077073,0.0073755,0.0070567,0.0067504,0.0064566,0.0061747,0.0059044,0.0056455,& +0.0053977,0.0051604,0.0049336,0.0047168,0.0045097,0.004312,0.0041234,0.0039435,0.003772,0.0036087,& +0.003453,0.0033048,0.0031638,0.0030295,0.0029017,0.00278,0.0026642,0.0025538,0.0024487,0.0023483,& +0.0022525,0.0021608,0.0020731,0.0019889,0.0019079,0.0018298,0.0017542,0.0016809,0.0016096,0.0015398,& +0.0014713,0.0014037,0.0013368,0.0012702,0.0012035,0.0011365,0.0010688,0.0010001,0.00093008,0.00085841,& +0.00078476,0.00071002,0.00063884,0.00057124,0.00050727,0.00044695,0.0003903,0.00033737,0.00028817,0.00024273,& +0.0002011,0.00016329,0.00012933,9.9259e-05,7.3102e-05,5.0888e-05,3.2647e-05,1.8408e-05,8.2009e-06,2.0551e-06,& +0,0,0,0,0,0,0,0,0,0/ + data (k_Anth(i),i=301,2101)/1801*0./ + +! ******************************************************************************** +! Specific absorption coefficient of brown pigments +! ******************************************************************************** + + data (k_Brown(i),i=1,100)/& +5.272e-01,5.262e-01,5.252e-01,5.242e-01,5.232e-01,5.222e-01,5.212e-01,5.202e-01,5.192e-01,5.182e-01,& +5.172e-01,5.162e-01,5.152e-01,5.142e-01,5.132e-01,5.122e-01,5.112e-01,5.102e-01,5.092e-01,5.082e-01,& +5.072e-01,5.062e-01,5.052e-01,5.042e-01,5.032e-01,5.022e-01,5.012e-01,5.002e-01,4.992e-01,4.982e-01,& +4.972e-01,4.960e-01,4.948e-01,4.936e-01,4.924e-01,4.912e-01,4.900e-01,4.888e-01,4.876e-01,4.864e-01,& +4.852e-01,4.840e-01,4.829e-01,4.817e-01,4.805e-01,4.793e-01,4.781e-01,4.769e-01,4.757e-01,4.745e-01,& +4.733e-01,4.720e-01,4.708e-01,4.695e-01,4.683e-01,4.670e-01,4.658e-01,4.645e-01,4.633e-01,4.620e-01,& +4.608e-01,4.597e-01,4.587e-01,4.577e-01,4.566e-01,4.556e-01,4.546e-01,4.535e-01,4.525e-01,4.515e-01,& +4.504e-01,4.494e-01,4.484e-01,4.473e-01,4.463e-01,4.453e-01,4.442e-01,4.432e-01,4.422e-01,4.411e-01,& +4.401e-01,4.388e-01,4.375e-01,4.362e-01,4.350e-01,4.337e-01,4.324e-01,4.311e-01,4.298e-01,4.285e-01,& +4.272e-01,4.260e-01,4.247e-01,4.234e-01,4.221e-01,4.208e-01,4.195e-01,4.183e-01,4.170e-01,4.157e-01/ + data (k_Brown(i),i=101,200)/& +4.144e-01,4.135e-01,4.127e-01,4.118e-01,4.109e-01,4.100e-01,4.092e-01,4.083e-01,4.074e-01,4.065e-01,& +4.057e-01,4.047e-01,4.038e-01,4.028e-01,4.019e-01,4.009e-01,4.000e-01,3.990e-01,3.981e-01,3.971e-01,& +3.962e-01,3.952e-01,3.943e-01,3.933e-01,3.924e-01,3.914e-01,3.905e-01,3.895e-01,3.886e-01,3.876e-01,& +3.867e-01,3.846e-01,3.824e-01,3.803e-01,3.782e-01,3.760e-01,3.739e-01,3.718e-01,3.696e-01,3.675e-01,& +3.654e-01,3.639e-01,3.625e-01,3.611e-01,3.597e-01,3.582e-01,3.568e-01,3.554e-01,3.540e-01,3.525e-01,& +3.511e-01,3.500e-01,3.489e-01,3.478e-01,3.467e-01,3.456e-01,3.445e-01,3.434e-01,3.423e-01,3.412e-01,& +3.401e-01,3.383e-01,3.366e-01,3.348e-01,3.330e-01,3.312e-01,3.294e-01,3.276e-01,3.258e-01,3.241e-01,& +3.223e-01,3.202e-01,3.182e-01,3.162e-01,3.141e-01,3.121e-01,3.100e-01,3.080e-01,3.059e-01,3.039e-01,& +3.019e-01,2.999e-01,2.979e-01,2.959e-01,2.940e-01,2.920e-01,2.900e-01,2.881e-01,2.861e-01,2.841e-01,& +2.821e-01,2.803e-01,2.784e-01,2.766e-01,2.747e-01,2.728e-01,2.710e-01,2.691e-01,2.673e-01,2.654e-01/ + data (k_Brown(i),i=201,300)/& +2.636e-01,2.618e-01,2.601e-01,2.584e-01,2.566e-01,2.549e-01,2.532e-01,2.515e-01,2.497e-01,2.480e-01,& +2.463e-01,2.447e-01,2.431e-01,2.414e-01,2.398e-01,2.382e-01,2.366e-01,2.350e-01,2.334e-01,2.318e-01,& +2.302e-01,2.288e-01,2.273e-01,2.258e-01,2.244e-01,2.229e-01,2.215e-01,2.200e-01,2.185e-01,2.171e-01,& +2.156e-01,2.143e-01,2.129e-01,2.115e-01,2.102e-01,2.088e-01,2.074e-01,2.061e-01,2.047e-01,2.033e-01,& +2.020e-01,2.007e-01,1.994e-01,1.981e-01,1.968e-01,1.955e-01,1.942e-01,1.929e-01,1.916e-01,1.903e-01,& +1.890e-01,1.878e-01,1.865e-01,1.853e-01,1.841e-01,1.829e-01,1.816e-01,1.804e-01,1.792e-01,1.780e-01,& +1.768e-01,1.755e-01,1.742e-01,1.729e-01,1.717e-01,1.704e-01,1.691e-01,1.679e-01,1.666e-01,1.653e-01,& +1.641e-01,1.627e-01,1.613e-01,1.600e-01,1.586e-01,1.572e-01,1.559e-01,1.545e-01,1.532e-01,1.518e-01,& +1.504e-01,1.491e-01,1.478e-01,1.464e-01,1.451e-01,1.437e-01,1.424e-01,1.411e-01,1.397e-01,1.384e-01,& +1.370e-01,1.358e-01,1.345e-01,1.333e-01,1.320e-01,1.308e-01,1.295e-01,1.283e-01,1.270e-01,1.258e-01/ + data (k_Brown(i),i=301,400)/& +1.245e-01,1.234e-01,1.223e-01,1.212e-01,1.200e-01,1.189e-01,1.178e-01,1.167e-01,1.156e-01,1.144e-01,& +1.133e-01,1.122e-01,1.111e-01,1.100e-01,1.089e-01,1.078e-01,1.067e-01,1.056e-01,1.046e-01,1.035e-01,& +1.024e-01,1.013e-01,1.003e-01,9.931e-02,9.829e-02,9.727e-02,9.625e-02,9.524e-02,9.422e-02,9.320e-02,& +9.218e-02,9.120e-02,9.022e-02,8.924e-02,8.827e-02,8.729e-02,8.631e-02,8.533e-02,8.435e-02,8.337e-02,& +8.239e-02,8.155e-02,8.070e-02,7.985e-02,7.901e-02,7.816e-02,7.732e-02,7.647e-02,7.562e-02,7.478e-02,& +7.393e-02,7.319e-02,7.245e-02,7.171e-02,7.097e-02,7.023e-02,6.949e-02,6.875e-02,6.801e-02,6.727e-02,& +6.653e-02,6.586e-02,6.519e-02,6.452e-02,6.385e-02,6.318e-02,6.251e-02,6.184e-02,6.117e-02,6.050e-02,& +5.983e-02,5.913e-02,5.843e-02,5.773e-02,5.704e-02,5.634e-02,5.564e-02,5.494e-02,5.424e-02,5.354e-02,& +5.284e-02,5.226e-02,5.167e-02,5.109e-02,5.050e-02,4.992e-02,4.933e-02,4.874e-02,4.816e-02,4.757e-02,& +4.699e-02,4.646e-02,4.594e-02,4.542e-02,4.490e-02,4.437e-02,4.385e-02,4.333e-02,4.281e-02,4.228e-02/ + data (k_Brown(i),i=401,500)/& +4.176e-02,4.128e-02,4.081e-02,4.033e-02,3.985e-02,3.937e-02,3.889e-02,3.841e-02,3.793e-02,3.746e-02,& +3.698e-02,3.657e-02,3.615e-02,3.574e-02,3.533e-02,3.492e-02,3.451e-02,3.409e-02,3.368e-02,3.327e-02,& +3.286e-02,3.249e-02,3.212e-02,3.175e-02,3.139e-02,3.102e-02,3.065e-02,3.028e-02,2.991e-02,2.954e-02,& +2.918e-02,2.885e-02,2.852e-02,2.819e-02,2.786e-02,2.753e-02,2.720e-02,2.688e-02,2.655e-02,2.622e-02,& +2.589e-02,2.559e-02,2.529e-02,2.499e-02,2.469e-02,2.440e-02,2.410e-02,2.380e-02,2.350e-02,2.320e-02,& +2.290e-02,2.264e-02,2.238e-02,2.212e-02,2.186e-02,2.159e-02,2.133e-02,2.107e-02,2.081e-02,2.055e-02,& +2.029e-02,2.006e-02,1.983e-02,1.961e-02,1.938e-02,1.915e-02,1.893e-02,1.870e-02,1.847e-02,1.825e-02,& +1.802e-02,1.782e-02,1.762e-02,1.742e-02,1.723e-02,1.703e-02,1.683e-02,1.663e-02,1.643e-02,1.623e-02,& +1.604e-02,1.586e-02,1.568e-02,1.551e-02,1.533e-02,1.516e-02,1.498e-02,1.481e-02,1.463e-02,1.446e-02,& +1.428e-02,1.414e-02,1.400e-02,1.385e-02,1.371e-02,1.357e-02,1.343e-02,1.328e-02,1.314e-02,1.300e-02/ + data (k_Brown(i),i=501,600)/& +1.286e-02,1.275e-02,1.265e-02,1.255e-02,1.245e-02,1.235e-02,1.225e-02,1.215e-02,1.205e-02,1.195e-02,& +1.185e-02,1.175e-02,1.165e-02,1.155e-02,1.145e-02,1.135e-02,1.125e-02,1.115e-02,1.105e-02,1.096e-02,& +1.086e-02,1.076e-02,1.066e-02,1.056e-02,1.047e-02,1.037e-02,1.027e-02,1.017e-02,1.008e-02,9.980e-03,& +9.884e-03,9.787e-03,9.691e-03,9.595e-03,9.500e-03,9.404e-03,9.309e-03,9.214e-03,9.120e-03,9.025e-03,& +8.931e-03,8.837e-03,8.743e-03,8.650e-03,8.557e-03,8.464e-03,8.371e-03,8.279e-03,8.187e-03,8.095e-03,& +8.004e-03,7.913e-03,7.822e-03,7.732e-03,7.641e-03,7.552e-03,7.462e-03,7.373e-03,7.284e-03,7.195e-03,& +7.107e-03,7.019e-03,6.932e-03,6.844e-03,6.758e-03,6.671e-03,6.585e-03,6.499e-03,6.414e-03,6.329e-03,& +6.244e-03,6.160e-03,6.076e-03,5.993e-03,5.910e-03,5.827e-03,5.745e-03,5.663e-03,5.581e-03,5.500e-03,& +5.419e-03,5.339e-03,5.259e-03,5.180e-03,5.101e-03,5.023e-03,4.945e-03,4.867e-03,4.790e-03,4.713e-03,& +4.637e-03,4.561e-03,4.486e-03,4.411e-03,4.337e-03,4.263e-03,4.190e-03,4.117e-03,4.044e-03,3.972e-03/ + data (k_Brown(i),i=601,700)/& +3.901e-03,3.830e-03,3.760e-03,3.690e-03,3.620e-03,3.552e-03,3.483e-03,3.416e-03,3.348e-03,3.282e-03,& +3.215e-03,3.150e-03,3.085e-03,3.020e-03,2.956e-03,2.893e-03,2.830e-03,2.768e-03,2.706e-03,2.645e-03,& +2.585e-03,2.525e-03,2.465e-03,2.407e-03,2.348e-03,2.291e-03,2.234e-03,2.178e-03,2.122e-03,2.067e-03,& +2.012e-03,1.959e-03,1.905e-03,1.853e-03,1.801e-03,1.750e-03,1.699e-03,1.649e-03,1.600e-03,1.551e-03,& +1.503e-03,1.456e-03,1.409e-03,1.363e-03,1.318e-03,1.274e-03,1.230e-03,1.187e-03,1.144e-03,1.102e-03,& +1.061e-03,1.021e-03,9.811e-04,9.422e-04,9.040e-04,8.665e-04,8.297e-04,7.937e-04,7.584e-04,7.239e-04,& +6.901e-04,6.571e-04,6.248e-04,5.933e-04,5.626e-04,5.326e-04,5.034e-04,4.750e-04,4.473e-04,4.205e-04,& +3.944e-04,3.691e-04,3.446e-04,3.210e-04,2.981e-04,2.760e-04,2.548e-04,2.344e-04,2.148e-04,1.960e-04,& +1.780e-04,1.609e-04,1.446e-04,1.292e-04,1.146e-04,1.009e-04,8.804e-05,7.603e-05,6.488e-05,5.460e-05,& +4.519e-05,3.666e-05,2.901e-05,2.225e-05,1.637e-05,1.138e-05,7.297e-06,4.111e-06,1.830e-06,4.581e-07/ + data (k_Brown(i),i=701,2101)/1401*0./ + +! ******************************************************************************** +! Specific absorption coefficient of water +! ******************************************************************************** + + data (k_Cw(i),i=1,100)/& +5.800E-05,5.852E-05,5.900E-05,5.989E-05,6.100E-05,6.203E-05,6.300E-05,6.399E-05,6.500E-05,6.603E-05,& +6.700E-05,6.790E-05,6.900E-05,7.050E-05,7.200E-05,7.312E-05,7.400E-05,7.490E-05,7.600E-05,7.740E-05,& +7.900E-05,8.063E-05,8.200E-05,8.297E-05,8.400E-05,8.551E-05,8.700E-05,8.800E-05,8.900E-05,9.050E-05,& +9.200E-05,9.300E-05,9.400E-05,9.550E-05,9.700E-05,9.801E-05,9.900E-05,1.005E-04,1.020E-04,1.031E-04,& +1.040E-04,1.050E-04,1.060E-04,1.070E-04,1.080E-04,1.090E-04,1.100E-04,1.110E-04,1.120E-04,1.130E-04,& +1.140E-04,1.150E-04,1.160E-04,1.170E-04,1.180E-04,1.190E-04,1.200E-04,1.210E-04,1.220E-04,1.230E-04,& +1.240E-04,1.250E-04,1.260E-04,1.270E-04,1.280E-04,1.289E-04,1.300E-04,1.315E-04,1.330E-04,1.340E-04,& +1.350E-04,1.364E-04,1.380E-04,1.396E-04,1.410E-04,1.424E-04,1.440E-04,1.459E-04,1.480E-04,1.499E-04,& +1.520E-04,1.544E-04,1.570E-04,1.596E-04,1.620E-04,1.643E-04,1.670E-04,1.704E-04,1.740E-04,1.775E-04,& +1.810E-04,1.849E-04,1.890E-04,1.934E-04,1.980E-04,2.031E-04,2.090E-04,2.158E-04,2.230E-04,2.303E-04/ + data (k_Cw(i),i=101,200)/& +2.380E-04,2.463E-04,2.550E-04,2.640E-04,2.730E-04,2.819E-04,2.910E-04,3.004E-04,3.100E-04,3.194E-04,& +3.290E-04,3.390E-04,3.490E-04,3.588E-04,3.680E-04,3.767E-04,3.860E-04,3.962E-04,4.040E-04,4.069E-04,& +4.090E-04,4.138E-04,4.160E-04,4.112E-04,4.090E-04,4.176E-04,4.270E-04,4.268E-04,4.230E-04,4.237E-04,& +4.290E-04,4.371E-04,4.450E-04,4.506E-04,4.560E-04,4.631E-04,4.700E-04,4.748E-04,4.800E-04,4.879E-04,& +4.950E-04,4.983E-04,5.030E-04,5.141E-04,5.270E-04,5.363E-04,5.440E-04,5.532E-04,5.640E-04,5.759E-04,& +5.880E-04,5.998E-04,6.110E-04,6.215E-04,6.310E-04,6.391E-04,6.460E-04,6.520E-04,6.580E-04,6.647E-04,& +6.720E-04,6.793E-04,6.860E-04,6.920E-04,6.990E-04,7.084E-04,7.180E-04,7.257E-04,7.340E-04,7.455E-04,& +7.590E-04,7.729E-04,7.870E-04,8.020E-04,8.190E-04,8.386E-04,8.580E-04,8.754E-04,8.960E-04,9.238E-04,& +9.520E-04,9.745E-04,1.000E-03,1.037E-03,1.079E-03,1.119E-03,1.159E-03,1.204E-03,1.253E-03,1.304E-03,& +1.356E-03,1.408E-03,1.459E-03,1.510E-03,1.567E-03,1.635E-03,1.700E-03,1.758E-03,1.860E-03,2.042E-03/ + data (k_Cw(i),i=201,300)/& +2.224E-03,2.323E-03,2.366E-03,2.400E-03,2.448E-03,2.519E-03,2.587E-03,2.629E-03,2.653E-03,2.674E-03,& +2.691E-03,2.704E-03,2.715E-03,2.727E-03,2.740E-03,2.753E-03,2.764E-03,2.775E-03,2.785E-03,2.797E-03,& +2.810E-03,2.824E-03,2.839E-03,2.854E-03,2.868E-03,2.881E-03,2.893E-03,2.907E-03,2.922E-03,2.938E-03,& +2.955E-03,2.972E-03,2.988E-03,3.000E-03,3.011E-03,3.023E-03,3.038E-03,3.057E-03,3.076E-03,3.094E-03,& +3.111E-03,3.127E-03,3.144E-03,3.162E-03,3.181E-03,3.202E-03,3.223E-03,3.242E-03,3.263E-03,3.289E-03,& +3.315E-03,3.338E-03,3.362E-03,3.390E-03,3.423E-03,3.461E-03,3.508E-03,3.567E-03,3.636E-03,3.712E-03,& +3.791E-03,3.866E-03,3.931E-03,3.981E-03,4.019E-03,4.049E-03,4.072E-03,4.087E-03,4.098E-03,4.109E-03,& +4.122E-03,4.137E-03,4.150E-03,4.160E-03,4.173E-03,4.196E-03,4.223E-03,4.248E-03,4.270E-03,4.293E-03,& +4.318E-03,4.347E-03,4.381E-03,4.418E-03,4.458E-03,4.500E-03,4.545E-03,4.594E-03,4.646E-03,4.701E-03,& +4.760E-03,4.827E-03,4.903E-03,4.986E-03,5.071E-03,5.154E-03,5.244E-03,5.351E-03,5.470E-03,5.594E-03/ + data (k_Cw(i),i=301,400)/& +5.722E-03,5.855E-03,5.995E-03,6.146E-03,6.303E-03,6.463E-03,6.628E-03,6.804E-03,6.993E-03,7.197E-03,& +7.415E-03,7.647E-03,7.893E-03,8.157E-03,8.445E-03,8.763E-03,9.109E-03,9.479E-03,9.871E-03,1.029E-02,& +1.072E-02,1.119E-02,1.168E-02,1.218E-02,1.268E-02,1.319E-02,1.372E-02,1.428E-02,1.487E-02,1.551E-02,& +1.621E-02,1.699E-02,1.787E-02,1.886E-02,1.992E-02,2.101E-02,2.207E-02,2.306E-02,2.394E-02,2.469E-02,& +2.532E-02,2.583E-02,2.623E-02,2.652E-02,2.672E-02,2.689E-02,2.702E-02,2.713E-02,2.722E-02,2.728E-02,& +2.733E-02,2.738E-02,2.741E-02,2.745E-02,2.748E-02,2.751E-02,2.754E-02,2.758E-02,2.763E-02,2.767E-02,& +2.771E-02,2.773E-02,2.773E-02,2.774E-02,2.774E-02,2.773E-02,2.770E-02,2.766E-02,2.761E-02,2.757E-02,& +2.754E-02,2.752E-02,2.748E-02,2.741E-02,2.731E-02,2.720E-02,2.710E-02,2.701E-02,2.690E-02,2.675E-02,& +2.659E-02,2.645E-02,2.633E-02,2.624E-02,2.613E-02,2.593E-02,2.558E-02,2.523E-02,2.513E-02,2.501E-02,& +2.466E-02,2.447E-02,2.412E-02,2.389E-02,2.374E-02,2.355E-02,2.337E-02,2.318E-02,2.304E-02,2.281E-02/ + data (k_Cw(i),i=401,500)/& +2.246E-02,2.243E-02,2.238E-02,2.222E-02,2.204E-02,2.201E-02,2.204E-02,2.196E-02,2.177E-02,2.190E-02,& +2.188E-02,2.188E-02,2.198E-02,2.210E-02,2.223E-02,2.233E-02,2.248E-02,2.276E-02,2.304E-02,2.311E-02,& +2.329E-02,2.388E-02,2.446E-02,2.475E-02,2.516E-02,2.620E-02,2.769E-02,2.830E-02,2.914E-02,3.108E-02,& +3.214E-02,3.297E-02,3.459E-02,3.606E-02,3.662E-02,3.702E-02,3.788E-02,3.829E-02,3.854E-02,3.909E-02,& +3.949E-02,3.972E-02,4.000E-02,4.040E-02,4.057E-02,4.075E-02,4.115E-02,4.127E-02,4.149E-02,4.204E-02,& +4.199E-02,4.223E-02,4.254E-02,4.272E-02,4.280E-02,4.306E-02,4.360E-02,4.369E-02,4.379E-02,4.433E-02,& +4.454E-02,4.466E-02,4.505E-02,4.527E-02,4.552E-02,4.605E-02,4.658E-02,4.691E-02,4.705E-02,4.713E-02,& +4.752E-02,4.833E-02,4.867E-02,4.894E-02,4.960E-02,5.006E-02,5.050E-02,5.115E-02,5.153E-02,5.204E-02,& +5.298E-02,5.346E-02,5.386E-02,5.465E-02,5.528E-02,5.566E-02,5.596E-02,5.653E-02,5.745E-02,5.789E-02,& +5.831E-02,5.924E-02,5.982E-02,6.009E-02,6.035E-02,6.094E-02,6.185E-02,6.226E-02,6.269E-02,6.360E-02/ + data (k_Cw(i),i=501,600)/& +6.407E-02,6.458E-02,6.562E-02,6.636E-02,6.672E-02,6.699E-02,6.769E-02,6.900E-02,6.989E-02,7.037E-02,& +7.085E-02,7.187E-02,7.358E-02,7.486E-02,7.562E-02,7.630E-02,7.792E-02,8.085E-02,8.292E-02,8.410E-02,& +8.528E-02,8.801E-02,9.268E-02,9.584E-02,9.819E-02,1.012E-01,1.042E-01,1.066E-01,1.113E-01,1.194E-01,& +1.246E-01,1.281E-01,1.327E-01,1.374E-01,1.410E-01,1.465E-01,1.557E-01,1.635E-01,1.688E-01,1.732E-01,& +1.818E-01,1.963E-01,2.050E-01,2.106E-01,2.187E-01,2.287E-01,2.386E-01,2.468E-01,2.542E-01,2.701E-01,& +2.976E-01,3.153E-01,3.274E-01,3.438E-01,3.622E-01,3.785E-01,3.930E-01,4.068E-01,4.184E-01,4.273E-01,& +4.385E-01,4.538E-01,4.611E-01,4.633E-01,4.663E-01,4.701E-01,4.733E-01,4.756E-01,4.772E-01,4.785E-01,& +4.800E-01,4.814E-01,4.827E-01,4.843E-01,4.864E-01,4.870E-01,4.867E-01,4.864E-01,4.857E-01,4.841E-01,& +4.821E-01,4.804E-01,4.786E-01,4.764E-01,4.738E-01,4.710E-01,4.677E-01,4.641E-01,4.604E-01,4.570E-01,& +4.532E-01,4.482E-01,4.434E-01,4.397E-01,4.362E-01,4.316E-01,4.265E-01,4.215E-01,4.168E-01,4.121E-01/ + data (k_Cw(i),i=601,700)/& +4.072E-01,4.017E-01,3.963E-01,3.915E-01,3.868E-01,3.816E-01,3.760E-01,3.701E-01,3.640E-01,3.581E-01,& +3.521E-01,3.461E-01,3.402E-01,3.349E-01,3.297E-01,3.243E-01,3.191E-01,3.141E-01,3.086E-01,3.022E-01,& +2.957E-01,2.897E-01,2.840E-01,2.782E-01,2.724E-01,2.672E-01,2.621E-01,2.566E-01,2.506E-01,2.444E-01,& +2.391E-01,2.357E-01,2.331E-01,2.299E-01,2.251E-01,2.198E-01,2.151E-01,2.109E-01,2.064E-01,2.020E-01,& +1.981E-01,1.944E-01,1.904E-01,1.868E-01,1.841E-01,1.818E-01,1.790E-01,1.752E-01,1.715E-01,1.687E-01,& +1.664E-01,1.639E-01,1.613E-01,1.586E-01,1.562E-01,1.545E-01,1.532E-01,1.522E-01,1.510E-01,1.495E-01,& +1.475E-01,1.457E-01,1.447E-01,1.442E-01,1.438E-01,1.433E-01,1.426E-01,1.418E-01,1.412E-01,1.410E-01,& +1.409E-01,1.408E-01,1.406E-01,1.405E-01,1.408E-01,1.414E-01,1.426E-01,1.435E-01,1.438E-01,1.439E-01,& +1.443E-01,1.456E-01,1.475E-01,1.498E-01,1.519E-01,1.534E-01,1.547E-01,1.561E-01,1.580E-01,1.604E-01,& +1.632E-01,1.659E-01,1.677E-01,1.693E-01,1.712E-01,1.739E-01,1.777E-01,1.824E-01,1.866E-01,1.890E-01/ + data (k_Cw(i),i=701,800)/& +1.906E-01,1.929E-01,1.967E-01,2.005E-01,2.031E-01,2.051E-01,2.079E-01,2.123E-01,2.166E-01,2.196E-01,& +2.219E-01,2.251E-01,2.298E-01,2.337E-01,2.346E-01,2.342E-01,2.353E-01,2.397E-01,2.450E-01,2.491E-01,& +2.528E-01,2.578E-01,2.650E-01,2.719E-01,2.765E-01,2.811E-01,2.891E-01,3.023E-01,3.164E-01,3.271E-01,& +3.378E-01,3.533E-01,3.770E-01,4.037E-01,4.281E-01,4.502E-01,4.712E-01,4.932E-01,5.202E-01,5.572E-01,& +6.052E-01,6.520E-01,6.863E-01,7.159E-01,7.535E-01,8.064E-01,8.597E-01,8.981E-01,9.253E-01,9.493E-01,& +9.769E-01,1.008E+00,1.041E+00,1.073E+00,1.100E+00,1.119E+00,1.131E+00,1.140E+00,1.150E+00,1.160E+00,& +1.170E+00,1.181E+00,1.190E+00,1.194E+00,1.196E+00,1.197E+00,1.200E+00,1.203E+00,1.205E+00,1.206E+00,& +1.207E+00,1.213E+00,1.223E+00,1.232E+00,1.234E+00,1.232E+00,1.229E+00,1.230E+00,1.233E+00,1.236E+00,& +1.239E+00,1.241E+00,1.244E+00,1.248E+00,1.252E+00,1.256E+00,1.258E+00,1.260E+00,1.262E+00,1.265E+00,& +1.267E+00,1.270E+00,1.272E+00,1.275E+00,1.277E+00,1.280E+00,1.282E+00,1.283E+00,1.283E+00,1.279E+00/ + data (k_Cw(i),i=801,900)/& +1.272E+00,1.266E+00,1.267E+00,1.271E+00,1.273E+00,1.271E+00,1.265E+00,1.260E+00,1.258E+00,1.258E+00,& +1.257E+00,1.252E+00,1.247E+00,1.243E+00,1.243E+00,1.243E+00,1.240E+00,1.233E+00,1.224E+00,1.216E+00,& +1.214E+00,1.214E+00,1.213E+00,1.210E+00,1.205E+00,1.200E+00,1.199E+00,1.198E+00,1.197E+00,1.194E+00,& +1.189E+00,1.184E+00,1.180E+00,1.176E+00,1.171E+00,1.166E+00,1.161E+00,1.158E+00,1.157E+00,1.157E+00,& +1.155E+00,1.152E+00,1.148E+00,1.142E+00,1.138E+00,1.133E+00,1.130E+00,1.126E+00,1.123E+00,1.120E+00,& +1.116E+00,1.111E+00,1.107E+00,1.103E+00,1.101E+00,1.101E+00,1.101E+00,1.101E+00,1.100E+00,1.098E+00,& +1.094E+00,1.089E+00,1.085E+00,1.084E+00,1.083E+00,1.083E+00,1.082E+00,1.081E+00,1.080E+00,1.079E+00,& +1.080E+00,1.083E+00,1.087E+00,1.093E+00,1.099E+00,1.104E+00,1.107E+00,1.109E+00,1.111E+00,1.115E+00,& +1.121E+00,1.129E+00,1.137E+00,1.147E+00,1.156E+00,1.164E+00,1.170E+00,1.175E+00,1.181E+00,1.188E+00,& +1.196E+00,1.206E+00,1.216E+00,1.227E+00,1.239E+00,1.252E+00,1.267E+00,1.283E+00,1.297E+00,1.310E+00/ + data (k_Cw(i),i=901,1000)/& +1.323E+00,1.336E+00,1.351E+00,1.370E+00,1.392E+00,1.416E+00,1.440E+00,1.465E+00,1.489E+00,1.511E+00,& +1.532E+00,1.555E+00,1.580E+00,1.610E+00,1.642E+00,1.672E+00,1.701E+00,1.728E+00,1.758E+00,1.791E+00,& +1.831E+00,1.872E+00,1.911E+00,1.943E+00,1.974E+00,2.007E+00,2.047E+00,2.098E+00,2.153E+00,2.203E+00,& +2.243E+00,2.277E+00,2.312E+00,2.357E+00,2.415E+00,2.479E+00,2.540E+00,2.590E+00,2.631E+00,2.666E+00,& +2.701E+00,2.738E+00,2.780E+00,2.829E+00,2.889E+00,2.960E+00,3.033E+00,3.097E+00,3.146E+00,3.181E+00,& +3.226E+00,3.267E+00,3.319E+00,3.363E+00,3.412E+00,3.449E+00,3.504E+00,3.544E+00,3.600E+00,3.648E+00,& +3.701E+00,3.752E+00,3.802E+00,3.871E+00,3.927E+00,3.985E+00,4.064E+00,4.125E+00,4.216E+00,4.302E+00,& +4.389E+00,4.504E+00,4.630E+00,4.737E+00,4.904E+00,5.092E+00,5.260E+00,5.479E+00,5.720E+00,6.006E+00,& +6.242E+00,6.580E+00,6.927E+00,7.313E+00,7.633E+00,8.089E+00,8.545E+00,9.030E+00,9.591E+00,1.002E+01,& +1.063E+01,1.122E+01,1.184E+01,1.245E+01,1.316E+01,1.369E+01,1.434E+01,1.509E+01,1.578E+01,1.646E+01/ + data (k_Cw(i),i=1001,1100)/& +1.714E+01,1.781E+01,1.854E+01,1.919E+01,1.980E+01,2.029E+01,2.089E+01,2.146E+01,2.202E+01,2.260E+01,& +2.313E+01,2.360E+01,2.407E+01,2.450E+01,2.493E+01,2.533E+01,2.571E+01,2.606E+01,2.641E+01,2.673E+01,& +2.701E+01,2.729E+01,2.756E+01,2.782E+01,2.806E+01,2.835E+01,2.856E+01,2.875E+01,2.892E+01,2.908E+01,& +2.926E+01,2.940E+01,2.956E+01,2.966E+01,2.982E+01,2.993E+01,3.003E+01,3.014E+01,3.023E+01,3.029E+01,& +3.036E+01,3.042E+01,3.046E+01,3.049E+01,3.052E+01,3.053E+01,3.055E+01,3.056E+01,3.056E+01,3.055E+01,& +3.054E+01,3.051E+01,3.049E+01,3.045E+01,3.041E+01,3.035E+01,3.029E+01,3.023E+01,3.014E+01,3.006E+01,& +2.998E+01,2.983E+01,2.971E+01,2.957E+01,2.936E+01,2.917E+01,2.899E+01,2.872E+01,2.851E+01,2.829E+01,& +2.800E+01,2.777E+01,2.754E+01,2.722E+01,2.699E+01,2.664E+01,2.638E+01,2.611E+01,2.581E+01,2.555E+01,& +2.522E+01,2.497E+01,2.468E+01,2.443E+01,2.413E+01,2.388E+01,2.364E+01,2.332E+01,2.307E+01,2.274E+01,& +2.250E+01,2.218E+01,2.193E+01,2.163E+01,2.139E+01,2.107E+01,2.082E+01,2.052E+01,2.025E+01,2.001E+01/ + data (k_Cw(i),i=1101,1200)/& +1.972E+01,1.951E+01,1.924E+01,1.900E+01,1.874E+01,1.847E+01,1.827E+01,1.802E+01,1.784E+01,1.758E+01,& +1.734E+01,1.712E+01,1.688E+01,1.671E+01,1.647E+01,1.623E+01,1.606E+01,1.583E+01,1.562E+01,1.545E+01,& +1.525E+01,1.504E+01,1.489E+01,1.468E+01,1.447E+01,1.432E+01,1.413E+01,1.395E+01,1.381E+01,1.364E+01,& +1.348E+01,1.329E+01,1.316E+01,1.298E+01,1.282E+01,1.265E+01,1.254E+01,1.238E+01,1.223E+01,1.206E+01,& +1.193E+01,1.181E+01,1.166E+01,1.152E+01,1.137E+01,1.126E+01,1.114E+01,1.100E+01,1.088E+01,1.075E+01,& +1.064E+01,1.054E+01,1.044E+01,1.032E+01,1.022E+01,1.011E+01,1.001E+01,9.912E+00,9.839E+00,9.754E+00,& +9.660E+00,9.563E+00,9.477E+00,9.383E+00,9.305E+00,9.202E+00,9.133E+00,9.047E+00,8.977E+00,8.898E+00,& +8.820E+00,8.742E+00,8.665E+00,8.588E+00,8.509E+00,8.448E+00,8.364E+00,8.295E+00,8.234E+00,8.157E+00,& +8.104E+00,8.036E+00,7.959E+00,7.890E+00,7.834E+00,7.773E+00,7.712E+00,7.654E+00,7.609E+00,7.548E+00,& +7.495E+00,7.432E+00,7.374E+00,7.315E+00,7.252E+00,7.203E+00,7.164E+00,7.124E+00,7.084E+00,7.041E+00/ + data (k_Cw(i),i=1201,1300)/& +6.987E+00,6.943E+00,6.910E+00,6.865E+00,6.828E+00,6.776E+00,6.742E+00,6.714E+00,6.695E+00,6.654E+00,& +6.630E+00,6.599E+00,6.567E+00,6.526E+00,6.501E+00,6.474E+00,6.449E+00,6.420E+00,6.401E+00,6.363E+00,& +6.345E+00,6.309E+00,6.282E+00,6.250E+00,6.214E+00,6.186E+00,6.163E+00,6.130E+00,6.121E+00,6.091E+00,& +6.076E+00,6.053E+00,6.048E+00,6.016E+00,6.005E+00,5.982E+00,5.973E+00,5.947E+00,5.940E+00,5.919E+00,& +5.911E+00,5.887E+00,5.875E+00,5.846E+00,5.826E+00,5.798E+00,5.787E+00,5.751E+00,5.746E+00,5.718E+00,& +5.705E+00,5.685E+00,5.684E+00,5.657E+00,5.658E+00,5.644E+00,5.648E+00,5.626E+00,5.626E+00,5.619E+00,& +5.618E+00,5.603E+00,5.614E+00,5.597E+00,5.603E+00,5.582E+00,5.584E+00,5.564E+00,5.563E+00,5.547E+00,& +5.545E+00,5.536E+00,5.542E+00,5.529E+00,5.532E+00,5.525E+00,5.533E+00,5.528E+00,5.529E+00,5.516E+00,& +5.524E+00,5.516E+00,5.526E+00,5.520E+00,5.520E+00,5.516E+00,5.522E+00,5.511E+00,5.527E+00,5.511E+00,& +5.519E+00,5.515E+00,5.520E+00,5.510E+00,5.518E+00,5.523E+00,5.538E+00,5.535E+00,5.544E+00,5.557E+00/ + data (k_Cw(i),i=1301,1400)/& +5.571E+00,5.583E+00,5.606E+00,5.607E+00,5.629E+00,5.636E+00,5.664E+00,5.670E+00,5.693E+00,5.702E+00,& +5.733E+00,5.752E+00,5.766E+00,5.776E+00,5.797E+00,5.811E+00,5.829E+00,5.842E+00,5.877E+00,5.891E+00,& +5.930E+00,5.945E+00,5.972E+00,5.999E+00,6.025E+00,6.051E+00,6.087E+00,6.096E+00,6.136E+00,6.166E+00,& +6.198E+00,6.219E+00,6.256E+00,6.284E+00,6.335E+00,6.369E+00,6.392E+00,6.445E+00,6.493E+00,6.517E+00,& +6.571E+00,6.617E+00,6.658E+00,6.689E+00,6.748E+00,6.796E+00,6.842E+00,6.897E+00,6.955E+00,7.003E+00,& +7.054E+00,7.111E+00,7.179E+00,7.235E+00,7.274E+00,7.339E+00,7.414E+00,7.481E+00,7.536E+00,7.594E+00,& +7.669E+00,7.734E+00,7.776E+00,7.833E+00,7.893E+00,7.952E+00,8.000E+00,8.045E+00,8.103E+00,8.155E+00,& +8.205E+00,8.241E+00,8.264E+00,8.321E+00,8.352E+00,8.394E+00,8.430E+00,8.448E+00,8.477E+00,8.512E+00,& +8.535E+00,8.562E+00,8.593E+00,8.618E+00,8.640E+00,8.670E+00,8.689E+00,8.720E+00,8.738E+00,8.755E+00,& +8.777E+00,8.778E+00,8.778E+00,8.794E+00,8.805E+00,8.807E+00,8.809E+00,8.811E+00,8.799E+00,8.795E+00/ + data (k_Cw(i),i=1401,1500)/& +8.789E+00,8.779E+00,8.767E+00,8.754E+00,8.750E+00,8.738E+00,8.739E+00,8.735E+00,8.744E+00,8.753E+00,& +8.755E+00,8.780E+00,8.787E+00,8.790E+00,8.798E+00,8.794E+00,8.811E+00,8.820E+00,8.836E+00,8.845E+00,& +8.854E+00,8.858E+00,8.868E+00,8.869E+00,8.884E+00,8.888E+00,8.900E+00,8.922E+00,8.951E+00,8.973E+00,& +9.010E+00,9.034E+00,9.110E+00,9.146E+00,9.195E+00,9.259E+00,9.315E+00,9.380E+00,9.457E+00,9.535E+00,& +9.633E+00,9.723E+00,9.824E+00,9.935E+00,1.005E+01,1.018E+01,1.031E+01,1.042E+01,1.059E+01,1.075E+01,& +1.094E+01,1.110E+01,1.139E+01,1.160E+01,1.184E+01,1.208E+01,1.235E+01,1.266E+01,1.301E+01,1.334E+01,& +1.375E+01,1.412E+01,1.478E+01,1.529E+01,1.586E+01,1.641E+01,1.709E+01,1.774E+01,1.853E+01,1.925E+01,& +2.051E+01,2.148E+01,2.250E+01,2.367E+01,2.483E+01,2.622E+01,2.751E+01,2.972E+01,3.144E+01,3.317E+01,& +3.504E+01,3.725E+01,3.927E+01,4.269E+01,4.530E+01,4.789E+01,5.060E+01,5.360E+01,5.761E+01,6.088E+01,& +6.401E+01,6.720E+01,7.059E+01,7.497E+01,7.841E+01,8.157E+01,8.469E+01,8.752E+01,9.189E+01,9.456E+01/ + data (k_Cw(i),i=1501,1600)/& +9.722E+01,9.995E+01,1.033E+02,1.057E+02,1.078E+02,1.097E+02,1.123E+02,1.140E+02,1.157E+02,1.171E+02,& +1.190E+02,1.203E+02,1.215E+02,1.226E+02,1.240E+02,1.248E+02,1.257E+02,1.265E+02,1.275E+02,1.281E+02,& +1.286E+02,1.292E+02,1.296E+02,1.299E+02,1.303E+02,1.304E+02,1.306E+02,1.306E+02,1.306E+02,1.305E+02,& +1.304E+02,1.301E+02,1.299E+02,1.296E+02,1.291E+02,1.287E+02,1.282E+02,1.275E+02,1.270E+02,1.264E+02,& +1.256E+02,1.249E+02,1.242E+02,1.232E+02,1.224E+02,1.216E+02,1.206E+02,1.197E+02,1.190E+02,1.178E+02,& +1.170E+02,1.157E+02,1.149E+02,1.140E+02,1.128E+02,1.118E+02,1.110E+02,1.097E+02,1.088E+02,1.076E+02,& +1.066E+02,1.058E+02,1.044E+02,1.036E+02,1.023E+02,1.014E+02,1.005E+02,9.928E+01,9.831E+01,9.711E+01,& +9.631E+01,9.488E+01,9.412E+01,9.341E+01,9.206E+01,9.121E+01,9.009E+01,8.929E+01,8.804E+01,8.725E+01,& +8.611E+01,8.532E+01,8.460E+01,8.336E+01,8.262E+01,8.151E+01,8.076E+01,7.973E+01,7.904E+01,7.800E+01,& +7.723E+01,7.628E+01,7.557E+01,7.463E+01,7.392E+01,7.298E+01,7.234E+01,7.141E+01,7.082E+01,6.986E+01/ + data (k_Cw(i),i=1601,1700)/& +6.924E+01,6.865E+01,6.779E+01,6.688E+01,6.634E+01,6.548E+01,6.490E+01,6.412E+01,6.358E+01,6.281E+01,& +6.232E+01,6.156E+01,6.105E+01,6.029E+01,5.980E+01,5.907E+01,5.857E+01,5.788E+01,5.746E+01,5.680E+01,& +5.632E+01,5.566E+01,5.503E+01,5.463E+01,5.398E+01,5.356E+01,5.294E+01,5.256E+01,5.197E+01,5.138E+01,& +5.098E+01,5.047E+01,5.006E+01,4.951E+01,4.915E+01,4.860E+01,4.806E+01,4.773E+01,4.718E+01,4.685E+01,& +4.635E+01,4.584E+01,4.553E+01,4.503E+01,4.473E+01,4.426E+01,4.379E+01,4.348E+01,4.302E+01,4.273E+01,& +4.228E+01,4.186E+01,4.155E+01,4.115E+01,4.072E+01,4.046E+01,4.002E+01,3.975E+01,3.934E+01,3.894E+01,& +3.868E+01,3.827E+01,3.790E+01,3.762E+01,3.726E+01,3.687E+01,3.664E+01,3.628E+01,3.592E+01,3.568E+01,& +3.536E+01,3.499E+01,3.479E+01,3.447E+01,3.413E+01,3.392E+01,3.363E+01,3.329E+01,3.309E+01,3.280E+01,& +3.251E+01,3.231E+01,3.200E+01,3.172E+01,3.154E+01,3.127E+01,3.097E+01,3.071E+01,3.052E+01,3.025E+01,& +2.999E+01,2.980E+01,2.958E+01,2.929E+01,2.906E+01,2.888E+01,2.865E+01,2.840E+01,2.822E+01,2.799E+01/ + data (k_Cw(i),i=1701,1800)/& +2.776E+01,2.751E+01,2.737E+01,2.713E+01,2.692E+01,2.671E+01,2.657E+01,2.637E+01,2.617E+01,2.597E+01,& +2.584E+01,2.565E+01,2.547E+01,2.528E+01,2.518E+01,2.501E+01,2.485E+01,2.466E+01,2.455E+01,2.438E+01,& +2.420E+01,2.401E+01,2.386E+01,2.374E+01,2.358E+01,2.342E+01,2.328E+01,2.318E+01,2.304E+01,2.289E+01,& +2.275E+01,2.262E+01,2.252E+01,2.239E+01,2.227E+01,2.214E+01,2.202E+01,2.194E+01,2.183E+01,2.172E+01,& +2.162E+01,2.150E+01,2.140E+01,2.133E+01,2.123E+01,2.112E+01,2.102E+01,2.091E+01,2.085E+01,2.077E+01,& +2.067E+01,2.058E+01,2.049E+01,2.040E+01,2.033E+01,2.027E+01,2.018E+01,2.010E+01,2.002E+01,1.995E+01,& +1.987E+01,1.983E+01,1.976E+01,1.969E+01,1.963E+01,1.958E+01,1.952E+01,1.946E+01,1.942E+01,1.938E+01,& +1.933E+01,1.928E+01,1.923E+01,1.918E+01,1.913E+01,1.909E+01,1.904E+01,1.900E+01,1.896E+01,1.889E+01,& +1.884E+01,1.880E+01,1.874E+01,1.870E+01,1.866E+01,1.860E+01,1.856E+01,1.852E+01,1.849E+01,1.845E+01,& +1.843E+01,1.839E+01,1.837E+01,1.837E+01,1.838E+01,1.837E+01,1.836E+01,1.835E+01,1.835E+01,1.835E+01/ + data (k_Cw(i),i=1801,1900)/& +1.834E+01,1.833E+01,1.833E+01,1.833E+01,1.834E+01,1.833E+01,1.834E+01,1.834E+01,1.832E+01,1.831E+01,& +1.829E+01,1.828E+01,1.828E+01,1.829E+01,1.829E+01,1.830E+01,1.832E+01,1.835E+01,1.836E+01,1.837E+01,& +1.837E+01,1.838E+01,1.837E+01,1.840E+01,1.842E+01,1.843E+01,1.846E+01,1.849E+01,1.851E+01,1.854E+01,& +1.857E+01,1.858E+01,1.860E+01,1.864E+01,1.865E+01,1.867E+01,1.870E+01,1.875E+01,1.879E+01,1.883E+01,& +1.888E+01,1.893E+01,1.897E+01,1.903E+01,1.908E+01,1.913E+01,1.919E+01,1.924E+01,1.929E+01,1.934E+01,& +1.940E+01,1.946E+01,1.951E+01,1.961E+01,1.966E+01,1.973E+01,1.980E+01,1.985E+01,1.991E+01,1.997E+01,& +2.004E+01,2.013E+01,2.020E+01,2.027E+01,2.038E+01,2.046E+01,2.054E+01,2.062E+01,2.071E+01,2.079E+01,& +2.087E+01,2.094E+01,2.103E+01,2.111E+01,2.126E+01,2.135E+01,2.145E+01,2.153E+01,2.164E+01,2.174E+01,& +2.183E+01,2.192E+01,2.202E+01,2.212E+01,2.223E+01,2.234E+01,2.245E+01,2.264E+01,2.276E+01,2.287E+01,& +2.301E+01,2.313E+01,2.327E+01,2.338E+01,2.351E+01,2.363E+01,2.377E+01,2.385E+01,2.409E+01,2.418E+01/ + data (k_Cw(i),i=1901,2000)/& +2.433E+01,2.444E+01,2.459E+01,2.470E+01,2.485E+01,2.495E+01,2.523E+01,2.534E+01,2.549E+01,2.564E+01,& +2.579E+01,2.592E+01,2.611E+01,2.623E+01,2.653E+01,2.664E+01,2.681E+01,2.695E+01,2.712E+01,2.727E+01,& +2.744E+01,2.756E+01,2.789E+01,2.802E+01,2.819E+01,2.838E+01,2.855E+01,2.869E+01,2.903E+01,2.916E+01,& +2.934E+01,2.951E+01,2.969E+01,2.988E+01,3.002E+01,3.038E+01,3.054E+01,3.073E+01,3.092E+01,3.107E+01,& +3.145E+01,3.160E+01,3.180E+01,3.199E+01,3.219E+01,3.238E+01,3.272E+01,3.290E+01,3.311E+01,3.331E+01,& +3.348E+01,3.388E+01,3.404E+01,3.426E+01,3.447E+01,3.468E+01,3.486E+01,3.528E+01,3.547E+01,3.570E+01,& +3.592E+01,3.610E+01,3.656E+01,3.675E+01,3.697E+01,3.716E+01,3.761E+01,3.777E+01,3.801E+01,3.827E+01,& +3.848E+01,3.892E+01,3.913E+01,3.938E+01,3.957E+01,4.007E+01,4.024E+01,4.050E+01,4.078E+01,4.096E+01,& +4.147E+01,4.167E+01,4.196E+01,4.220E+01,4.268E+01,4.293E+01,4.319E+01,4.342E+01,4.388E+01,4.413E+01,& +4.439E+01,4.464E+01,4.513E+01,4.538E+01,4.565E+01,4.590E+01,4.638E+01,4.663E+01,4.690E+01,4.714E+01/ + data (k_Cw(i),i=2001,2101)/& +4.764E+01,4.787E+01,4.817E+01,4.836E+01,4.894E+01,4.917E+01,4.940E+01,4.997E+01,5.021E+01,5.050E+01,& +5.078E+01,5.131E+01,5.159E+01,5.191E+01,5.246E+01,5.275E+01,5.310E+01,5.339E+01,5.401E+01,5.429E+01,& +5.462E+01,5.523E+01,5.555E+01,5.588E+01,5.618E+01,5.686E+01,5.713E+01,5.746E+01,5.808E+01,5.841E+01,& +5.878E+01,5.946E+01,5.976E+01,6.009E+01,6.039E+01,6.107E+01,6.146E+01,6.180E+01,6.250E+01,6.286E+01,& +6.316E+01,6.392E+01,6.427E+01,6.462E+01,6.539E+01,6.574E+01,6.609E+01,6.685E+01,6.725E+01,6.759E+01,& +6.842E+01,6.881E+01,6.918E+01,7.009E+01,7.046E+01,7.084E+01,7.174E+01,7.212E+01,7.249E+01,7.340E+01,& +7.381E+01,7.423E+01,7.514E+01,7.554E+01,7.591E+01,7.675E+01,7.718E+01,7.801E+01,7.839E+01,7.880E+01,& +7.970E+01,8.005E+01,8.046E+01,8.136E+01,8.173E+01,8.215E+01,8.295E+01,8.338E+01,8.423E+01,8.474E+01,& +8.510E+01,8.584E+01,8.617E+01,8.637E+01,8.708E+01,8.762E+01,8.884E+01,8.904E+01,8.945E+01,9.055E+01,& +9.089E+01,9.134E+01,9.204E+01,9.244E+01,9.308E+01,9.333E+01,9.358E+01,9.416E+01,9.448E+01,9.499E+01,& +9.530E+01/ + + +! ******************************************************************************** +! Specific absorption coefficient of dry matter +! ******************************************************************************** + + data (k_Cm(i),i=1,100)/& +1.097E+02,1.037E+02,9.798E+01,9.244E+01,8.713E+01,8.231E+01,7.806E+01,7.404E+01,7.013E+01,6.654E+01,& +6.300E+01,5.954E+01,5.616E+01,5.301E+01,5.001E+01,4.723E+01,4.463E+01,4.220E+01,3.996E+01,3.780E+01,& +3.567E+01,3.362E+01,3.170E+01,2.993E+01,2.832E+01,2.679E+01,2.535E+01,2.402E+01,2.276E+01,2.150E+01,& +2.024E+01,1.901E+01,1.785E+01,1.676E+01,1.575E+01,1.481E+01,1.392E+01,1.312E+01,1.233E+01,1.161E+01,& +1.096E+01,1.041E+01,9.924E+00,9.410E+00,8.947E+00,8.508E+00,8.087E+00,7.640E+00,7.269E+00,6.939E+00,& +6.660E+00,6.422E+00,6.222E+00,6.010E+00,5.782E+00,5.573E+00,5.370E+00,5.173E+00,4.946E+00,4.761E+00,& +4.575E+00,4.419E+00,4.259E+00,4.117E+00,4.006E+00,3.945E+00,3.853E+00,3.784E+00,3.671E+00,3.554E+00,& +3.462E+00,3.364E+00,3.282E+00,3.184E+00,3.102E+00,3.051E+00,2.983E+00,2.947E+00,2.913E+00,2.869E+00,& +2.803E+00,2.777E+00,2.751E+00,2.726E+00,2.702E+00,2.679E+00,2.656E+00,2.634E+00,2.613E+00,2.593E+00,& +2.573E+00,2.554E+00,2.536E+00,2.519E+00,2.502E+00,2.486E+00,2.471E+00,2.457E+00,2.443E+00,2.430E+00/ + data (k_Cm(i),i=101,200)/& +2.417E+00,2.405E+00,2.394E+00,2.384E+00,2.374E+00,2.365E+00,2.356E+00,2.348E+00,2.341E+00,2.334E+00,& +2.328E+00,2.323E+00,2.318E+00,2.314E+00,2.310E+00,2.307E+00,2.304E+00,2.303E+00,2.301E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=201,300)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=301,400)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=401,500)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=501,600)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=601,700)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=701,800)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=801,900)/& +2.300E+00,2.300E+00,2.301E+00,2.301E+00,2.302E+00,2.303E+00,2.305E+00,2.306E+00,2.308E+00,2.310E+00,& +2.312E+00,2.315E+00,2.318E+00,2.320E+00,2.323E+00,2.327E+00,2.330E+00,2.334E+00,2.338E+00,2.342E+00,& +2.346E+00,2.350E+00,2.354E+00,2.359E+00,2.364E+00,2.369E+00,2.374E+00,2.379E+00,2.384E+00,2.389E+00,& +2.395E+00,2.400E+00,2.406E+00,2.412E+00,2.418E+00,2.424E+00,2.430E+00,2.436E+00,2.442E+00,2.448E+00,& +2.454E+00,2.461E+00,2.467E+00,2.473E+00,2.480E+00,2.486E+00,2.493E+00,2.499E+00,2.506E+00,2.512E+00,& +2.519E+00,2.525E+00,2.532E+00,2.538E+00,2.545E+00,2.551E+00,2.558E+00,2.564E+00,2.570E+00,2.577E+00,& +2.583E+00,2.589E+00,2.595E+00,2.601E+00,2.607E+00,2.613E+00,2.619E+00,2.625E+00,2.631E+00,2.636E+00,& +2.642E+00,2.647E+00,2.652E+00,2.657E+00,2.662E+00,2.667E+00,2.672E+00,2.677E+00,2.681E+00,2.685E+00,& +2.689E+00,2.693E+00,2.697E+00,2.701E+00,2.704E+00,2.708E+00,2.711E+00,2.714E+00,2.716E+00,2.719E+00,& +2.721E+00,2.723E+00,2.725E+00,2.726E+00,2.728E+00,2.729E+00,2.730E+00,2.730E+00,2.731E+00,2.731E+00/ + data (k_Cm(i),i=901,1000)/& +2.721E+00,2.736E+00,2.728E+00,2.719E+00,2.712E+00,2.698E+00,2.702E+00,2.691E+00,2.688E+00,2.686E+00,& +2.682E+00,2.676E+00,2.675E+00,2.677E+00,2.670E+00,2.671E+00,2.668E+00,2.670E+00,2.674E+00,2.674E+00,& +2.683E+00,2.674E+00,2.675E+00,2.682E+00,2.683E+00,2.665E+00,2.661E+00,2.668E+00,2.670E+00,2.674E+00,& +2.664E+00,2.661E+00,2.665E+00,2.668E+00,2.681E+00,2.686E+00,2.684E+00,2.697E+00,2.712E+00,2.720E+00,& +2.717E+00,2.726E+00,2.744E+00,2.743E+00,2.751E+00,2.763E+00,2.778E+00,2.793E+00,2.818E+00,2.835E+00,& +2.865E+00,2.879E+00,2.899E+00,2.918E+00,2.936E+00,2.953E+00,2.966E+00,2.977E+00,2.981E+00,2.942E+00,& +2.888E+00,2.864E+00,2.877E+00,2.886E+00,2.888E+00,2.891E+00,2.899E+00,2.887E+00,2.884E+00,2.900E+00,& +2.929E+00,2.969E+00,3.014E+00,3.053E+00,3.075E+00,3.111E+00,3.128E+00,3.130E+00,3.103E+00,3.051E+00,& +2.980E+00,2.941E+00,2.920E+00,2.931E+00,2.950E+00,2.979E+00,3.025E+00,3.048E+00,3.066E+00,3.087E+00,& +3.099E+00,3.090E+00,3.088E+00,3.081E+00,3.086E+00,3.071E+00,3.065E+00,3.069E+00,3.067E+00,3.085E+00/ + data (k_Cm(i),i=1001,1100)/& +3.094E+00,3.110E+00,3.136E+00,3.149E+00,3.158E+00,3.191E+00,3.230E+00,3.266E+00,3.298E+00,3.356E+00,& +3.419E+00,3.476E+00,3.534E+00,3.584E+00,3.632E+00,3.708E+00,3.775E+00,3.847E+00,3.931E+00,3.987E+00,& +4.071E+00,4.156E+00,4.242E+00,4.320E+00,4.395E+00,4.480E+00,4.561E+00,4.638E+00,4.708E+00,4.782E+00,& +4.846E+00,4.906E+00,4.974E+00,5.026E+00,5.071E+00,5.131E+00,5.179E+00,5.220E+00,5.271E+00,5.322E+00,& +5.358E+00,5.403E+00,5.441E+00,5.460E+00,5.481E+00,5.500E+00,5.523E+00,5.548E+00,5.560E+00,5.575E+00,& +5.582E+00,5.597E+00,5.611E+00,5.639E+00,5.653E+00,5.675E+00,5.682E+00,5.685E+00,5.680E+00,5.689E+00,& +5.711E+00,5.723E+00,5.715E+00,5.716E+00,5.732E+00,5.741E+00,5.743E+00,5.752E+00,5.745E+00,5.744E+00,& +5.757E+00,5.766E+00,5.781E+00,5.787E+00,5.798E+00,5.810E+00,5.808E+00,5.815E+00,5.825E+00,5.824E+00,& +5.827E+00,5.854E+00,5.878E+00,5.900E+00,5.908E+00,5.922E+00,5.940E+00,5.962E+00,5.963E+00,5.966E+00,& +5.982E+00,5.990E+00,5.994E+00,6.016E+00,6.014E+00,6.025E+00,6.008E+00,6.022E+00,6.021E+00,6.027E+00/ + data (k_Cm(i),i=1101,1200)/& +6.027E+00,6.035E+00,6.025E+00,6.009E+00,5.990E+00,5.987E+00,5.984E+00,5.971E+00,5.971E+00,5.973E+00,& +5.951E+00,5.952E+00,5.939E+00,5.933E+00,5.931E+00,5.925E+00,5.909E+00,5.897E+00,5.884E+00,5.881E+00,& +5.876E+00,5.856E+00,5.843E+00,5.830E+00,5.818E+00,5.807E+00,5.799E+00,5.792E+00,5.776E+00,5.783E+00,& +5.776E+00,5.767E+00,5.762E+00,5.769E+00,5.756E+00,5.762E+00,5.737E+00,5.740E+00,5.757E+00,5.756E+00,& +5.751E+00,5.754E+00,5.751E+00,5.750E+00,5.744E+00,5.744E+00,5.754E+00,5.744E+00,5.735E+00,5.740E+00,& +5.732E+00,5.728E+00,5.731E+00,5.724E+00,5.724E+00,5.715E+00,5.697E+00,5.693E+00,5.703E+00,5.700E+00,& +5.713E+00,5.728E+00,5.731E+00,5.735E+00,5.743E+00,5.754E+00,5.753E+00,5.744E+00,5.746E+00,5.746E+00,& +5.746E+00,5.750E+00,5.749E+00,5.743E+00,5.740E+00,5.747E+00,5.739E+00,5.755E+00,5.749E+00,5.753E+00,& +5.745E+00,5.732E+00,5.735E+00,5.724E+00,5.725E+00,5.712E+00,5.702E+00,5.700E+00,5.700E+00,5.686E+00,& +5.685E+00,5.672E+00,5.659E+00,5.627E+00,5.613E+00,5.590E+00,5.591E+00,5.563E+00,5.552E+00,5.525E+00/ + data (k_Cm(i),i=1201,1300)/& +5.517E+00,5.506E+00,5.494E+00,5.459E+00,5.450E+00,5.438E+00,5.428E+00,5.407E+00,5.391E+00,5.382E+00,& +5.376E+00,5.358E+00,5.347E+00,5.333E+00,5.319E+00,5.301E+00,5.292E+00,5.284E+00,5.274E+00,5.258E+00,& +5.253E+00,5.249E+00,5.233E+00,5.222E+00,5.211E+00,5.204E+00,5.210E+00,5.200E+00,5.193E+00,5.186E+00,& +5.177E+00,5.175E+00,5.178E+00,5.173E+00,5.152E+00,5.135E+00,5.139E+00,5.128E+00,5.121E+00,5.114E+00,& +5.126E+00,5.107E+00,5.104E+00,5.100E+00,5.109E+00,5.114E+00,5.112E+00,5.128E+00,5.137E+00,5.131E+00,& +5.152E+00,5.175E+00,5.194E+00,5.200E+00,5.244E+00,5.257E+00,5.273E+00,5.289E+00,5.335E+00,5.366E+00,& +5.389E+00,5.427E+00,5.453E+00,5.490E+00,5.522E+00,5.562E+00,5.605E+00,5.652E+00,5.698E+00,5.744E+00,& +5.743E+00,5.642E+00,5.689E+00,5.722E+00,5.755E+00,5.798E+00,5.848E+00,5.875E+00,5.918E+00,5.971E+00,& +6.022E+00,6.061E+00,6.116E+00,6.173E+00,6.214E+00,6.266E+00,6.319E+00,6.382E+00,6.426E+00,6.486E+00,& +6.542E+00,6.579E+00,6.616E+00,6.666E+00,6.728E+00,6.771E+00,6.807E+00,6.858E+00,6.908E+00,6.959E+00/ + data (k_Cm(i),i=1301,1400)/& +7.006E+00,7.052E+00,7.093E+00,7.136E+00,7.164E+00,7.199E+00,7.232E+00,7.266E+00,7.315E+00,7.340E+00,& +7.361E+00,7.399E+00,7.440E+00,7.473E+00,7.505E+00,7.525E+00,7.557E+00,7.579E+00,7.604E+00,7.633E+00,& +7.653E+00,7.674E+00,7.691E+00,7.699E+00,7.708E+00,7.721E+00,7.730E+00,7.729E+00,7.712E+00,7.702E+00,& +7.695E+00,7.670E+00,7.644E+00,7.618E+00,7.585E+00,7.555E+00,7.517E+00,7.479E+00,7.451E+00,7.435E+00,& +7.408E+00,7.379E+00,7.363E+00,7.347E+00,7.332E+00,7.332E+00,7.332E+00,7.304E+00,7.295E+00,7.296E+00,& +7.291E+00,7.292E+00,7.292E+00,7.281E+00,7.283E+00,7.264E+00,7.250E+00,7.240E+00,7.228E+00,7.210E+00,& +7.186E+00,7.164E+00,7.143E+00,7.114E+00,7.101E+00,7.069E+00,7.038E+00,7.003E+00,6.974E+00,6.928E+00,& +6.889E+00,6.839E+00,6.793E+00,6.764E+00,6.729E+00,6.694E+00,6.662E+00,6.613E+00,6.572E+00,6.546E+00,& +6.522E+00,6.507E+00,6.482E+00,6.484E+00,6.479E+00,6.494E+00,6.496E+00,6.491E+00,6.461E+00,6.440E+00,& +6.430E+00,6.413E+00,6.421E+00,6.399E+00,6.379E+00,6.365E+00,6.372E+00,6.346E+00,6.321E+00,6.310E+00/ + data (k_Cm(i),i=1401,1500)/& +6.314E+00,6.282E+00,6.277E+00,6.270E+00,6.258E+00,6.242E+00,6.234E+00,6.221E+00,6.231E+00,6.221E+00,& +6.205E+00,6.193E+00,6.192E+00,6.179E+00,6.159E+00,6.143E+00,6.143E+00,6.120E+00,6.098E+00,6.087E+00,& +6.063E+00,6.056E+00,6.053E+00,6.040E+00,6.044E+00,6.007E+00,5.996E+00,5.994E+00,5.997E+00,5.975E+00,& +5.954E+00,5.946E+00,5.927E+00,5.914E+00,5.890E+00,5.873E+00,5.832E+00,5.794E+00,5.768E+00,5.728E+00,& +5.681E+00,5.680E+00,5.655E+00,5.648E+00,5.620E+00,5.594E+00,5.567E+00,5.557E+00,5.552E+00,5.553E+00,& +5.539E+00,5.524E+00,5.507E+00,5.505E+00,5.487E+00,5.474E+00,5.462E+00,5.450E+00,5.448E+00,5.441E+00,& +5.440E+00,5.442E+00,5.450E+00,5.466E+00,5.461E+00,5.452E+00,5.445E+00,5.412E+00,5.379E+00,5.280E+00,& +5.228E+00,5.199E+00,5.171E+00,5.139E+00,5.124E+00,5.112E+00,5.129E+00,5.145E+00,5.173E+00,5.176E+00,& +5.185E+00,5.183E+00,5.200E+00,5.202E+00,5.204E+00,5.224E+00,5.244E+00,5.297E+00,5.318E+00,5.376E+00,& +5.441E+00,5.491E+00,5.561E+00,5.629E+00,5.687E+00,5.757E+00,5.830E+00,5.911E+00,5.998E+00,6.090E+00/ + data (k_Cm(i),i=1501,1600)/& +6.193E+00,6.330E+00,6.449E+00,6.581E+00,6.710E+00,6.838E+00,6.970E+00,7.107E+00,7.238E+00,7.388E+00,& +7.506E+00,7.635E+00,7.767E+00,7.874E+00,7.977E+00,8.071E+00,8.150E+00,8.220E+00,8.292E+00,8.350E+00,& +8.449E+00,8.521E+00,8.583E+00,8.666E+00,8.723E+00,8.759E+00,8.821E+00,8.864E+00,8.909E+00,8.941E+00,& +8.949E+00,8.955E+00,8.983E+00,9.022E+00,9.043E+00,9.044E+00,9.028E+00,9.034E+00,9.052E+00,9.048E+00,& +9.041E+00,9.037E+00,9.036E+00,9.035E+00,9.021E+00,9.016E+00,9.008E+00,8.970E+00,8.974E+00,8.953E+00,& +8.957E+00,8.937E+00,8.923E+00,8.912E+00,8.895E+00,8.891E+00,8.880E+00,8.867E+00,8.855E+00,8.852E+00,& +8.861E+00,8.864E+00,8.876E+00,8.869E+00,8.873E+00,8.855E+00,8.828E+00,8.839E+00,8.855E+00,8.856E+00,& +8.833E+00,8.842E+00,8.844E+00,8.830E+00,8.808E+00,8.818E+00,8.807E+00,8.797E+00,8.794E+00,8.791E+00,& +8.795E+00,8.772E+00,8.754E+00,8.759E+00,8.760E+00,8.746E+00,8.762E+00,8.778E+00,8.790E+00,8.795E+00,& +8.811E+00,8.848E+00,8.874E+00,8.885E+00,8.913E+00,8.944E+00,8.981E+00,8.988E+00,9.001E+00,9.034E+00/ + data (k_Cm(i),i=1601,1700)/& +9.076E+00,9.111E+00,9.141E+00,9.171E+00,9.214E+00,9.255E+00,9.304E+00,9.356E+00,9.406E+00,9.448E+00,& +9.516E+00,9.578E+00,9.638E+00,9.692E+00,9.763E+00,9.845E+00,9.953E+00,1.004E+01,1.015E+01,1.027E+01,& +1.039E+01,1.052E+01,1.063E+01,1.077E+01,1.091E+01,1.103E+01,1.119E+01,1.135E+01,1.150E+01,1.166E+01,& +1.181E+01,1.201E+01,1.217E+01,1.235E+01,1.251E+01,1.269E+01,1.287E+01,1.307E+01,1.325E+01,1.346E+01,& +1.364E+01,1.384E+01,1.404E+01,1.423E+01,1.441E+01,1.461E+01,1.481E+01,1.499E+01,1.518E+01,1.534E+01,& +1.554E+01,1.571E+01,1.591E+01,1.607E+01,1.622E+01,1.637E+01,1.653E+01,1.667E+01,1.678E+01,1.690E+01,& +1.698E+01,1.709E+01,1.718E+01,1.725E+01,1.734E+01,1.739E+01,1.748E+01,1.755E+01,1.761E+01,1.767E+01,& +1.771E+01,1.777E+01,1.783E+01,1.787E+01,1.794E+01,1.795E+01,1.799E+01,1.805E+01,1.809E+01,1.813E+01,& +1.820E+01,1.827E+01,1.830E+01,1.835E+01,1.841E+01,1.846E+01,1.852E+01,1.856E+01,1.861E+01,1.866E+01,& +1.871E+01,1.876E+01,1.881E+01,1.885E+01,1.890E+01,1.896E+01,1.903E+01,1.907E+01,1.911E+01,1.916E+01/ + data (k_Cm(i),i=1701,1800)/& +1.921E+01,1.927E+01,1.929E+01,1.932E+01,1.935E+01,1.936E+01,1.940E+01,1.943E+01,1.947E+01,1.951E+01,& +1.953E+01,1.956E+01,1.960E+01,1.961E+01,1.962E+01,1.966E+01,1.966E+01,1.969E+01,1.970E+01,1.972E+01,& +1.974E+01,1.974E+01,1.976E+01,1.978E+01,1.979E+01,1.982E+01,1.982E+01,1.983E+01,1.986E+01,1.988E+01,& +1.989E+01,1.989E+01,1.993E+01,1.993E+01,1.997E+01,2.001E+01,2.001E+01,2.004E+01,2.007E+01,2.011E+01,& +2.014E+01,2.015E+01,2.017E+01,2.019E+01,2.022E+01,2.023E+01,2.023E+01,2.026E+01,2.027E+01,2.029E+01,& +2.028E+01,2.027E+01,2.029E+01,2.029E+01,2.031E+01,2.029E+01,2.026E+01,2.030E+01,2.031E+01,2.030E+01,& +2.030E+01,2.031E+01,2.029E+01,2.029E+01,2.026E+01,2.025E+01,2.023E+01,2.020E+01,2.016E+01,2.015E+01,& +2.012E+01,2.009E+01,2.007E+01,2.003E+01,1.998E+01,1.996E+01,1.991E+01,1.986E+01,1.980E+01,1.975E+01,& +1.969E+01,1.964E+01,1.959E+01,1.953E+01,1.947E+01,1.941E+01,1.936E+01,1.931E+01,1.922E+01,1.918E+01,& +1.912E+01,1.906E+01,1.899E+01,1.890E+01,1.885E+01,1.881E+01,1.875E+01,1.867E+01,1.861E+01,1.858E+01/ + data (k_Cm(i),i=1801,1900)/& +1.852E+01,1.846E+01,1.840E+01,1.834E+01,1.829E+01,1.824E+01,1.819E+01,1.813E+01,1.807E+01,1.803E+01,& +1.798E+01,1.792E+01,1.788E+01,1.782E+01,1.780E+01,1.775E+01,1.773E+01,1.768E+01,1.768E+01,1.766E+01,& +1.763E+01,1.762E+01,1.763E+01,1.764E+01,1.764E+01,1.766E+01,1.770E+01,1.774E+01,1.779E+01,1.786E+01,& +1.795E+01,1.803E+01,1.814E+01,1.825E+01,1.836E+01,1.851E+01,1.866E+01,1.881E+01,1.895E+01,1.913E+01,& +1.932E+01,1.951E+01,1.972E+01,1.994E+01,2.017E+01,2.040E+01,2.065E+01,2.089E+01,2.114E+01,2.140E+01,& +2.163E+01,2.186E+01,2.210E+01,2.237E+01,2.262E+01,2.290E+01,2.313E+01,2.339E+01,2.361E+01,2.387E+01,& +2.410E+01,2.435E+01,2.455E+01,2.479E+01,2.499E+01,2.521E+01,2.541E+01,2.562E+01,2.583E+01,2.605E+01,& +2.626E+01,2.643E+01,2.657E+01,2.674E+01,2.689E+01,2.701E+01,2.718E+01,2.732E+01,2.742E+01,2.754E+01,& +2.763E+01,2.777E+01,2.794E+01,2.804E+01,2.821E+01,2.836E+01,2.850E+01,2.863E+01,2.878E+01,2.896E+01,& +2.913E+01,2.922E+01,2.937E+01,2.947E+01,2.960E+01,2.970E+01,2.982E+01,2.997E+01,3.007E+01,3.018E+01/ + data (k_Cm(i),i=1901,2000)/& +3.028E+01,3.040E+01,3.053E+01,3.060E+01,3.066E+01,3.070E+01,3.076E+01,3.078E+01,3.075E+01,3.074E+01,& +3.072E+01,3.065E+01,3.058E+01,3.051E+01,3.045E+01,3.034E+01,3.029E+01,3.023E+01,3.015E+01,3.004E+01,& +3.000E+01,2.998E+01,2.991E+01,2.986E+01,2.984E+01,2.981E+01,2.976E+01,2.973E+01,2.976E+01,2.977E+01,& +2.979E+01,2.981E+01,2.985E+01,2.989E+01,2.999E+01,3.000E+01,3.005E+01,3.007E+01,3.011E+01,3.017E+01,& +3.022E+01,3.023E+01,3.029E+01,3.028E+01,3.029E+01,3.027E+01,3.027E+01,3.024E+01,3.019E+01,3.010E+01,& +3.010E+01,3.003E+01,2.993E+01,2.983E+01,2.984E+01,2.975E+01,2.966E+01,2.958E+01,2.948E+01,2.930E+01,& +2.926E+01,2.920E+01,2.913E+01,2.902E+01,2.890E+01,2.882E+01,2.873E+01,2.873E+01,2.870E+01,2.865E+01,& +2.858E+01,2.854E+01,2.851E+01,2.846E+01,2.838E+01,2.834E+01,2.823E+01,2.820E+01,2.817E+01,2.809E+01,& +2.803E+01,2.803E+01,2.801E+01,2.794E+01,2.791E+01,2.790E+01,2.784E+01,2.779E+01,2.781E+01,2.782E+01,& +2.781E+01,2.781E+01,2.783E+01,2.785E+01,2.785E+01,2.782E+01,2.782E+01,2.780E+01,2.780E+01,2.778E+01/ + data (k_Cm(i),i=2001,2101)/& +2.783E+01,2.784E+01,2.788E+01,2.791E+01,2.799E+01,2.804E+01,2.812E+01,2.811E+01,2.819E+01,2.819E+01,& +2.817E+01,2.817E+01,2.831E+01,2.837E+01,2.848E+01,2.853E+01,2.859E+01,2.870E+01,2.874E+01,2.887E+01,& +2.898E+01,2.910E+01,2.923E+01,2.934E+01,2.944E+01,2.959E+01,2.973E+01,2.987E+01,3.002E+01,3.016E+01,& +3.035E+01,3.043E+01,3.064E+01,3.084E+01,3.098E+01,3.122E+01,3.132E+01,3.152E+01,3.165E+01,3.184E+01,& +3.204E+01,3.221E+01,3.233E+01,3.255E+01,3.282E+01,3.315E+01,3.339E+01,3.360E+01,3.384E+01,3.410E+01,& +3.426E+01,3.452E+01,3.473E+01,3.497E+01,3.519E+01,3.539E+01,3.561E+01,3.579E+01,3.604E+01,3.618E+01,& +3.636E+01,3.660E+01,3.675E+01,3.682E+01,3.699E+01,3.711E+01,3.735E+01,3.758E+01,3.792E+01,3.796E+01,& +3.812E+01,3.822E+01,3.833E+01,3.856E+01,3.874E+01,3.877E+01,3.884E+01,3.883E+01,3.879E+01,3.886E+01,& +3.900E+01,3.900E+01,3.906E+01,3.905E+01,3.916E+01,3.928E+01,3.948E+01,3.943E+01,3.951E+01,3.964E+01,& +3.953E+01,3.960E+01,3.958E+01,3.954E+01,3.940E+01,3.936E+01,3.917E+01,3.926E+01,3.893E+01,3.921E+01,& +3.871E+01/ + +end \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 new file mode 100644 index 0000000000..876f672c79 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 @@ -0,0 +1,204 @@ +#include + +! ******************************************************************************** +! prospect_DB.f90 +! a.k.a. PROSPECT-Dynamic +! version 6.0 (January, 16th 2017) +! subroutines required: tav.f90, dataSpec_PDB.f90 +! _______________________________________________________________________ +! for any question or request, please contact: +! +! Jean-Baptiste FERET +! UMR-TETIS, IRSTEA Montpellier +! Maison de la T�l�d�tection +! 500 rue Jean-Fracois Breton +! 34093 Montpellier cedex 5 +! E-mail: jb.feret@teledetection.fr +! +! St�phane JACQUEMOUD +! Universit� Paris Diderot / Institut de Physique du Globe de Paris +! 35 rue H�l�ne Brion +! 75013 Paris, France +! E-mail: jacquemoud@ipgp.fr +! +! http://teledetection.ipgp.fr/prosail/ +!______________________________________________________________________ +! Plant leaf reflectance and transmittance are calculated from 400 nm to +! 2500 nm (1 nm step) with the following parameters: +! +! - N = leaf structure parameter +! - Cab = chlorophyll a+b content in �g/cm� +! - Car = carotenoids content in �g/cm� +! - Anth = Anthocyanin content in �g/cm� +! - Cbrown= brown pigments content in arbitrary units +! - Cw = equivalent water thickness in g/cm� or cm +! - Cm = dry matter content in g/cm� +! +!Here are some examples observed during the LOPEX'93 experiment on +!fresh (F) and dry (D) leaves : +! +!--------------------------------------------- +! N Cab Cw Cm +!--------------------------------------------- +!min 1.000 0.0 0.004000 0.001900 +! max 3.000 100.0 0.040000 0.016500 +! corn (F) 1.518 58.0 0.013100 0.003662 +! rice (F) 2.275 23.7 0.007500 0.005811 +! clover (F) 1.875 46.7 0.010000 0.003014 +! laurel (F) 2.660 74.1 0.019900 0.013520 +! --------------------------------------------- +! min 1.500 0.0 0.000063 0.0019 +! max 3.600 100.0 0.000900 0.0165 +! bamboo (D) 2.698 70.8 0.000117 0.009327 +! lettuce (D) 2.107 35.2 0.000244 0.002250 +! walnut (D) 2.656 62.8 0.000263 0.006573 +! chestnut (D) 1.826 47.7 0.000307 0.004305 +! --------------------------------------------- +! _______________________________________________________________________! +! if no information about Anth or Cbrown and work on green / mature leaves +! set it to 0 ! +! if no information about Car and work on green / mature leaves ! +! set the Chl / Car ratio between 4 and 5. this is not appropriate for ! +! senescent leaves ! +! _______________________________________________________________________! +! this code includes numerical optimizations proposed in the FLUSPECT code +! Authors: Wout Verhoef, Christiaan van der Tol (c.vandertol@utwente.nl) & +! Joris Timmermans +! Date: 2007 +! Update from PROSPECT to FLUSPECT: January 2011 (CvdT) +! for more info about FLUSPECT, see publication: +! Vilfan, N., van der Tol, C., Muller, O., Rascher, U., Verhoef, W., 2016. +! Fluspect-B: A model for leaf fluorescence, reflectance and transmittance +! spectra. Remote Sens. Environ. 186, 596�615. doi:10.1016/j.rse.2016.09.017 + +MODULE MOD_prospect_DB +USE MOD_Precision +IMPLICIT NONE +SAVE + +PUBLIC :: prospect_DB + +CONTAINS +subroutine prospect_DB(N,Cab,Car,Anth,Cbrown,Cw,Cm,RT) +! ******************************************************************************** +! F�ret, Gitelson, Noble & Jacqumoud (2017). PROSPECT-D: Towards modeling +! leaf optical properties through a complete lifecycle +! Remote Sensing of Environment, 193:204�215 +! DOI: http://doi.org/10.1016/j.rse.2017.03.004 +! Jacquemoud S., Baret F. (1990), PROSPECT: a model of leaf optical properties +! spectra, Remote Sensing of Environment, 34:75-91. +! ******************************************************************************** + +use MOD_dataSpec_PDB +use MOD_tav_abs +implicit none + +real(r8), intent(in) :: N,Cab,Car,Anth,Cbrown,Cw,Cm +real(r8), intent(out) :: RT(nw,2) + +real(r8) :: k(nw), tau(nw), xx(nw), yy(nw) +real(r8) :: ralf(nw),talf(nw),r12(nw),t12(nw),r21(nw),t21(nw) +real(r8) :: theta1, theta2, denom(nw),Ra(nw),Ta(nw),r(nw),t(nw) +real(r8) :: d(nw),rq(nw),tq(nw),a(nw),b(nw) +real(r8) :: bNm1(nw),bN2(nw),a2(nw),Rsub(nw),Tsub(nw) + +k = (Cab*k_Cab+Car*k_Car+Anth*k_Anth+Cbrown*k_Brown+Cw*k_Cw+Cm*k_Cm)/N + +! ******************************************************************************** +! reflectance and transmittance of one layer +! ******************************************************************************** +! Allen W.A., Gausman H.W., Richardson A.J., Thomas J.R. (1969), Interaction of +! isotropic ligth with a compact plant leaf, Journal of the Optical Society of +! American, 59:1376-1379. +! ******************************************************************************** + +! exponential integral: S13AAF routine from the NAG library + +where (k.le.0.0) + tau = 1 +end where +where (k.gt.0.0.and.k.le.4.0) + xx = 0.5*k-1.0 + yy = (((((((((((((((-3.60311230482612224d-13 & + *xx+3.46348526554087424d-12)*xx-2.99627399604128973d-11) & + *xx+2.57747807106988589d-10)*xx-2.09330568435488303d-9) & + *xx+1.59501329936987818d-8)*xx-1.13717900285428895d-7) & + *xx+7.55292885309152956d-7)*xx-4.64980751480619431d-6) & + *xx+2.63830365675408129d-5)*xx-1.37089870978830576d-4) & + *xx+6.47686503728103400d-4)*xx-2.76060141343627983d-3) & + *xx+1.05306034687449505d-2)*xx-3.57191348753631956d-2) & + *xx+1.07774527938978692d-1)*xx-2.96997075145080963d-1 + yy = (yy*xx+8.64664716763387311d-1)*xx+7.42047691268006429d-1 + yy = yy-log(k) + tau = (1.0-k)*exp(-k)+k**2*yy +end where +where (k.gt.4.0.and.k.le.85.0) + xx = 14.5/(k+3.25)-1.0 + yy = (((((((((((((((-1.62806570868460749d-12 & + *xx-8.95400579318284288d-13)*xx-4.08352702838151578d-12) & + *xx-1.45132988248537498d-11)*xx-8.35086918940757852d-11) & + *xx-2.13638678953766289d-10)*xx-1.10302431467069770d-9) & + *xx-3.67128915633455484d-9)*xx-1.66980544304104726d-8) & + *xx-6.11774386401295125d-8)*xx-2.70306163610271497d-7) & + *xx-1.05565006992891261d-6)*xx-4.72090467203711484d-6) & + *xx-1.95076375089955937d-5)*xx-9.16450482931221453d-5) & + *xx-4.05892130452128677d-4)*xx-2.14213055000334718d-3 + yy = ((yy*xx-1.06374875116569657d-2)*xx-8.50699154984571871d-2)*xx+9.23755307807784058d-1 + yy = exp(-k)*yy/k + tau = (1.0-k)*exp(-k)+k**2*yy +end where +where (k.gt.85.0) + tau = 0 +end where + +! transmissivity of the layer + +theta1 = 90. +call tav_abs(theta1,refractive,t12) +theta2 = 40. +call tav_abs(theta2,refractive,talf) +ralf = 1.-talf +r12 = 1.-t12 +t21 = t12/(refractive**2) +r21 = 1-t21 +! top surface side +denom = 1-r21*r21*tau**2 +Ta = talf*tau*t21/denom +Ra = ralf+r21*tau*Ta +! bottom surface side +t = t12*tau*t21/denom +r = r12+r21*tau*t + +! ******************************************************************************** +! reflectance and transmittance of N layers +! ******************************************************************************** +! Stokes G.G. (1862), On the intensity of the light reflected from or transmitted +! through a pile of plates, Proceedings of the Royal Society of London, 11:545-556. +! ******************************************************************************** +D = sqrt((1.+r+t)*(1.+r-t)*(1.-r+t)*(1.-r-t)) +rq = r**2 +tq = t**2 +a = (1.+rq-tq+D)/(2*r) +b = (1.-rq+tq+D)/(2*t) + +bNm1 = b**(N-1) +bN2 = bNm1**2 +a2 = a**2 +denom = a2*bN2-1. +Rsub = a*(bN2-1.)/denom +Tsub = bNm1*(a2-1.)/denom + +! Case of zero absorption +where (r+t.ge.1.0) + Tsub = t/(t+(1.-t)*(N-1)) + Rsub = 1-Tsub +end where + +! Reflectance and transmittance of the leaf: combine top layer with next N-1 layers +denom = 1-Rsub*r +RT(:,2) = Ta*Tsub/denom +RT(:,1) = Ra+Ta*Rsub*t/denom + +end subroutine + +END MODULE \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 new file mode 100644 index 0000000000..f738a7cb57 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 @@ -0,0 +1,67 @@ +#include + +! ******************************************************************************** +! tav_abs.f90 +! ******************************************************************************** +! computation of the average transmittivity at the leaf surface within a given +! solid angle. teta is the incidence solid angle (in radian). The average angle +! that works in most cases is 40deg*pi/180. ref is the refaction index. +! ******************************************************************************** +! Stern F. (1964), Transmission of isotropic radiation across an interface between +! two dielectrics, Applied Optics, 3:111-113. +! Allen W.A. (1973), Transmission of isotropic light across a dielectric surface in +! two and three dimensions, Journal of the Optical Society of America, 63:664-666. +! ******************************************************************************** +! version 5.02 (25 July 2011) +! ******************************************************************************** +MODULE MOD_tav_abs +IMPLICIT NONE +PUBLIC :: tav_abs + +CONTAINS +subroutine tav_abs(theta,nr,tav) +USE MOD_Precision +use MOD_dataSpec_PDB +implicit none + +real(r8), intent(in) :: theta, nr(nw) +real(r8), intent(out) :: tav(nw) + +real(r8) pi,rd +real(r8) n2(nw),np(nw),nm(nw) +real(r8) a(nw),k(nw),sa(nw),b1(nw),b2(nw),b3(nw),b(nw),a3(nw) +real(r8) ts(nw),tp(nw),tp1(nw),tp2(nw),tp3(nw),tp4(nw),tp5(nw) + + +pi = atan(1.)*4. +rd = pi/180. +n2 = nr**2. +np = n2+1. +nm = n2-1. +a = (nr+1)*(nr+1.)/2. +k = -(n2-1)*(n2-1.)/4. +sa = sin(theta*rd) + +if (theta.eq.90.) then + b1=0. +else + b1 = sqrt((sa**2-np/2._r8)*(sa**2-np/2._r8)+k) +endif + +b2 = sa**2-np/2._r8 +b = b1-b2 +b3 = b**3 +a3 = a**3 +ts = (k**2./(6._r8*b3)+k/b-b/2._r8)-(k**2./(6._r8*a3)+k/a-a/2._r8) + +tp1 = -2._r8*n2*(b-a)/(np**2) +tp2 = -2._r8*n2*np*log(b/a)/(nm**2) +tp3 = n2*(1._r8/b-1._r8/a)/2._r8 +tp4 = 16._r8*n2**2._r8*(n2**2._r8+1._r8)*log((2._r8*np*b-nm**2)/(2._r8*np*a-nm**2))/(np**3._r8*nm**2) +tp5 = 16._r8*n2**3._r8*(1._r8/(2._r8*np*b-nm**2)-1._r8/(2._r8*np*a-nm**2))/(np**3._r8) +tp = tp1+tp2+tp3+tp4+tp5 +tav = (ts+tp)/(2._r8*sa**2) + +return +end +END MODULE MOD_tav_abs \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 new file mode 100644 index 0000000000..7a5abebb4a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 @@ -0,0 +1,212 @@ +#include + +MODULE MOD_Opt_Baseflow + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), allocatable :: scale_baseflow (:) + + real(r8), allocatable :: zwt_init (:) + real(r8), allocatable :: rchg_year (:) + real(r8), allocatable :: rsub_year (:) + + integer :: iter_bf_opt + +CONTAINS + + ! ----- + SUBROUTINE Opt_Baseflow_init () + + USE MOD_NetCDFVector + USE MOD_Vars_TimeVariables, only: zwt + USE MOD_LandPatch, only: numpatch, landpatch + IMPLICIT NONE + + ! Local Variables + character(len=256) :: file_restart + + + file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' + CALL ncio_read_vector (file_restart, 'scale_baseflow', landpatch, scale_baseflow, defval = 1.) + + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt') + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (DEF_Optimize_Baseflow) THEN + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (zwt_init (numpatch)); zwt_init (:) = zwt + allocate (rchg_year (numpatch)); rchg_year (:) = spval + allocate (rsub_year (numpatch)); rsub_year (:) = spval + ENDIF + ENDIF + + iter_bf_opt = 0 + + ENDIF + + END SUBROUTINE Opt_Baseflow_init + + ! ----- + SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) + + USE MOD_TimeManager + USE MOD_NetCDFVector + USE MOD_Vars_TimeInvariants, only: patchtype + USE MOD_Vars_TimeVariables, only: wice_soisno, zwt + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl + USE MOD_Vars_1DFluxes, only: fevpa, rsur, rsub + USE MOD_LandPatch, only: numpatch, landpatch + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: is_spinup + + ! Local Variables + real(r8), allocatable :: recharge(:) + integer :: ipatch + character(len=256) :: file_restart + character(len=5) :: strcyc + + IF (DEF_Optimize_Baseflow .and. is_spinup) THEN + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + + allocate (recharge(numpatch)); recharge(:) = spval + WHERE ((forc_prc /= spval) .and. (forc_prl /= spval) .and. (fevpa /= spval) .and. (rsur /= spval)) + recharge = forc_prc + forc_prl - fevpa - rsur + END WHERE + + CALL add_spv (recharge, rchg_year, deltim) + + deallocate (recharge) + + CALL add_spv (rsub, rsub_year, deltim) + + ENDIF + ENDIF + + IF (isendofyear(idate,deltim)) THEN + + iter_bf_opt = iter_bf_opt + 1 + + write(strcyc,'(A1,I4.4)') 'c', iter_bf_opt + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt/'//strcyc) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + file_restart = trim(DEF_dir_restart)//'/ParaOpt/'//strcyc//'/'//trim(DEF_CASE_NAME)//'_baseflow.nc' + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'zwt', 'patch', landpatch, zwt, 1) + CALL ncio_write_vector (file_restart, 'zwt_init', 'patch', landpatch, zwt_init, 1) + CALL ncio_write_vector (file_restart, 'scale_baseflow', 'patch', landpatch, scale_baseflow, 1) + CALL ncio_write_vector (file_restart, 'total_recharge', 'patch', landpatch, rchg_year, 1) + CALL ncio_write_vector (file_restart, 'total_subsurface_runoff', 'patch', landpatch, rsub_year, 1) + + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + IF (patchtype(ipatch) <= 1) THEN + + IF ((rchg_year(ipatch) > 0) .and. (rsub_year(ipatch) > 0)) THEN + + IF ((zwt(ipatch) > zwt_init(ipatch)) .and. (rchg_year(ipatch) < rsub_year(ipatch))) THEN + + scale_baseflow(ipatch) = rchg_year(ipatch)/rsub_year(ipatch) * scale_baseflow(ipatch) + + ENDIF + + IF ((zwt(ipatch) < zwt_init(ipatch)) .and. (rchg_year(ipatch) > rsub_year(ipatch))) THEN + + scale_baseflow(ipatch) = rchg_year(ipatch)/rsub_year(ipatch) * scale_baseflow(ipatch) + + ENDIF + + ENDIF + + scale_baseflow(ipatch) = max(1.e-8, scale_baseflow(ipatch)) + + ENDIF + ENDDO + ENDIF + + file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'scale_baseflow', 'patch', landpatch, scale_baseflow, 1) + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + rchg_year(:) = spval + rsub_year(:) = spval + ENDIF + ENDIF + + ENDIF + + ENDIF + + END SUBROUTINE BaseFlow_Optimize + + ! ----- + SUBROUTINE Opt_Baseflow_final () + + IMPLICIT NONE + + IF (allocated(scale_baseflow)) deallocate(scale_baseflow) + IF (allocated(zwt_init )) deallocate(zwt_init ) + IF (allocated(rchg_year )) deallocate(rchg_year ) + IF (allocated(rsub_year )) deallocate(rsub_year ) + + END SUBROUTINE Opt_Baseflow_final + + !----------------------------------------------------------------------- + SUBROUTINE add_spv (var, s, dt) + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), intent(in) :: var(:) + real(r8), intent(inout) :: s (:) + real(r8), intent(in), optional :: dt + ! Local variables + integer :: i + + IF (present(dt)) THEN + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i)*dt + ELSE + s(i) = var(i)*dt + ENDIF + ENDIF + ENDDO + ELSE + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i) + ELSE + s(i) = var(i) + ENDIF + ENDIF + ENDDO + ENDIF + + END SUBROUTINE add_spv +END MODULE MOD_Opt_Baseflow diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 new file mode 100644 index 0000000000..a9a9f61eb8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 @@ -0,0 +1,44 @@ +#include + +MODULE MOD_ParameterOptimization + + USE MOD_Precision + USE MOD_Opt_Baseflow + IMPLICIT NONE + SAVE + +CONTAINS + + ! ----- + SUBROUTINE ParaOpt_init (ref_date_in, ref_lc_year_in) + + IMPLICIT NONE + integer :: ref_date_in(3), ref_lc_year_in + + CALL Opt_Baseflow_init () + + END SUBROUTINE ParaOpt_init + + ! ----- + SUBROUTINE ParameterOptimization (idate, deltim, is_spinup) + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: is_spinup + + CALL BaseFlow_Optimize (idate, deltim, is_spinup) + + END SUBROUTINE ParameterOptimization + + ! ----- + SUBROUTINE ParaOpt_final () + + IMPLICIT NONE + + CALL Opt_Baseflow_final () + + END SUBROUTINE ParaOpt_final + +END MODULE MOD_ParameterOptimization diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 new file mode 100644 index 0000000000..1949de5906 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 @@ -0,0 +1,1368 @@ +#include + +!----------------------------------------------------------------------- +! +! --- CoLM 3D Building Community Urban Model --- +! +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++|_ AC ______ +! |++++++|_| ___ |++++++| +! ______+++++| ||||| |++++++| +! |++++++|++++| ||||||| |++++++| +! sunlit |[]++[]|++++| ||||| |++++++| shaded +! wall |++++++| | tree |++++++| wall +! |[]++[]| | |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! !DESCRIPTION: +! +! Unlike the traditional urban canyon models, the CoLM urban model is +! based on the assumption of a three-dimensional urban building +! community, including trees and water bodies. We have developed a new +! approach for shortwave and longwave radiation transfer, as well as +! turbulent exchange within the three-dimensional urban buildings. In +! the process of calculating radiation transfer and turbulent exchange, +! we have integrated simulations of vegetation and water bodies. +! +! The CoLM urban model utilizes comprehensive high-resolution data on +! urban cover, geometric structure, vegetation, water bodies, etc. +! Furthermore, it has developed a relatively complete simulation of +! anthropogenic heat processes, including building energy consumption, +! traffic heat, and metabolic heat. +! +! Created by Hua Yuan, 09/2021 +! +! +! !REVISIONS (major): +! +! 03/2022, Hua Yuan: complete the model with full coupling, and make +! it possible to run multiple scenario assumptions through +! macro definitions. +! +! 07/2022, Wenzong Dong: add LUCY model initial version. +! +! 05/2023, Hua Yuan: Initial urban physical codes in MPI version. Add +! some interface or modifications for Urban model coupling. +! +! 05/2023, Wenzong Dong, Hua Yuan, Shupeng Zhang: porting urban making +! surface data codes to MPI parallel version. +! +! 05/2023, Hua Yuan: Rename files and modules align with current +! version. +! +!----------------------------------------------------------------------- + + SUBROUTINE CoLMMAIN_Urban ( & + + ! model running information + ipatch ,idate ,coszen ,deltim ,& + patchlonr ,patchlatr ,patchclass ,patchtype ,& + + ! urban and lake depth + froof ,flake ,hroof ,hlr ,& + fgper ,em_roof ,em_wall ,em_gimp ,& + em_gper ,cv_roof ,cv_wall ,cv_gimp ,& + tk_roof ,tk_wall ,tk_gimp ,z_roof ,& + z_wall ,dz_roof ,dz_wall ,lakedepth ,& + dz_lake ,elvstd ,BVIC ,& + + ! LUCY model input parameters + fix_holiday ,week_holiday ,hum_prof ,pop_den ,& + vehicle ,weh_prof ,wdh_prof ,& + + ! soil ground and wall information + vf_quartz ,vf_gravels ,vf_om ,vf_sand ,& + wf_gravels ,wf_sand ,porsl ,psi0 ,& + bsw ,theta_r ,fsatmax ,fsatdcf ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + hksati ,csol ,k_solids ,dksatu ,& + dksatf ,dkdry ,BA_alpha ,BA_beta ,& + alb_roof ,alb_wall ,alb_gimp ,alb_gper ,& + + ! vegetation information + htop ,hbot ,sqrtdi ,chil ,& + effcon ,vmax25 ,c3c4 ,slti ,hlti,& + shti ,hhti ,trda ,trdm ,& + trop ,g1 ,g0 ,gradm ,& + binter ,extkn ,rho ,tau ,& + rootfr ,lambda ,& + + ! atmospheric forcing + forc_pco2m ,forc_po2m ,forc_us ,forc_vs ,& + forc_t ,forc_q ,forc_prc ,forc_prl ,& + forc_rain ,forc_snow ,forc_psrf ,forc_pbot ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + forc_frl ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,& + forc_rhoair ,Fhac ,Fwst ,Fach ,& + Fahe ,Fhah ,vehc ,meta ,& + + ! land surface variables required for restart + z_sno_roof ,z_sno_gimp ,z_sno_gper ,z_sno_lake ,& + dz_sno_roof ,dz_sno_gimp ,dz_sno_gper ,dz_sno_lake ,& + t_roofsno ,t_gimpsno ,t_gpersno ,t_lakesno ,& + wliq_roofsno ,wliq_gimpsno ,wliq_gpersno ,wliq_lakesno ,& + wice_roofsno ,wice_gimpsno ,wice_gpersno ,wice_lakesno ,& + z_sno ,dz_sno ,wliq_soisno ,wice_soisno ,& + t_soisno ,smp ,hk ,t_wallsun ,& + t_wallsha ,& + + lai ,sai ,fveg ,sigf ,& + green ,tleaf ,ldew ,ldew_rain ,& + ldew_snow ,fwet_snow ,t_grnd ,& + + sag_roof ,sag_gimp ,sag_gper ,sag_lake ,& + scv_roof ,scv_gimp ,scv_gper ,scv_lake ,& + snowdp_roof ,snowdp_gimp ,snowdp_gper ,snowdp_lake ,& + fsno_roof ,fsno_gimp ,fsno_gper ,fsno_lake ,& + sag ,scv ,snowdp ,fsno ,& + extkd ,alb ,ssun ,ssha ,& + sroof ,swsun ,swsha ,sgimp ,& + sgper ,slake ,lwsun ,lwsha ,& + lgimp ,lgper ,lveg ,fwsun ,& + dfwsun ,t_room ,troof_inner ,twsun_inner ,& + twsha_inner ,t_roommax ,t_roommin ,tafu ,& + + zwt ,wdsrf ,wa ,& + t_lake ,lake_icefrac ,savedtke1 ,& + + ! SNICAR snow model related + snw_rds ,ssno ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + +#if (defined CaMa_Flood) + ! flood depth [mm], flood fraction[0-1], + ! flood evaporation [mm/s], flood re-infiltration [mm/s] + flddepth ,fldfrc ,fevpg_fld ,qinfl_fld ,& +#endif + ! additional diagnostic variables for output + laisun ,laisha ,rss ,& + rstfac ,h2osoi ,wat ,& + + ! FLUXES + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + fsen_roof ,fsen_wsun ,fsen_wsha ,fsen_gimp ,& + fsen_gper ,fsen_urbl ,troof ,twall ,& + lfevp_roof ,lfevp_gimp ,lfevp_gper ,lfevp_urbl ,& + trad ,tref ,&!tmax ,tmin ,& + qref ,rsur ,rnof ,qintr ,& + qinfl ,qdrip ,rst ,assim ,& + respc ,sabvsun ,sabvsha ,sabg ,& + sr ,solvd ,solvi ,solnd ,& + solni ,srvd ,srvi ,srnd ,& + srni ,solvdln ,solviln ,solndln ,& + solniln ,srvdln ,srviln ,srndln ,& + srniln ,qcharge ,xerr ,zerr ,& + + ! TUNABLE model constants + zlnd ,zsno ,csoilc ,dewmx ,& + capr ,cnfac ,ssi ,wimp ,& + pondmx ,smpmax ,smpmin ,trsmx0 ,& + tcrit ,& + + ! additional variables required by coupling with WRF model + emis ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,& + fh ,fq ,hpbl ) + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz, denh2o, denice + USE MOD_Vars_TimeVariables, only: tlai, tsai + USE MOD_SnowLayersCombineDivide + USE MOD_LeafInterception + USE MOD_Urban_Albedo + USE MOD_Urban_NetSolar + USE MOD_Urban_Thermal + USE MOD_Urban_Hydrology + USE MOD_Lake + USE MOD_TimeManager + USE MOD_RainSnowTemp, only: rain_snow_temp + USE MOD_NewSnow, only: newsnow + USE MOD_OrbCoszen, only: orb_coszen + USE MOD_SnowFraction, only: snowfraction + USE MOD_ALBEDO, only: snowage + USE MOD_Qsadv, only: qsadv +#ifdef USE_LUCY + USE MOD_Urban_LUCY +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,&! maximum number of snow layers + idate(3) ,&! next time-step /year/julian day/second in a day/ + patchclass ,&! land cover type of USGS classification or others + patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + + real(r8),intent(in) :: & + deltim ,&! seconds in a time step [second] + patchlonr ,&! longitude in radians + patchlatr ! latitude in radians + + real(r8),intent(inout) :: & + coszen ! cosine of solar zenith angle + + ! Parameters + ! ---------------------- + real(r8), intent(in) :: & + fix_holiday(365) ,&! Fixed public holidays, holiday(0) or workday(1) + week_holiday(7) ,&! week holidays + hum_prof(24) ,&! Diurnal metabolic heat profile + weh_prof(24) ,&! Diurnal traffic flow profile of weekend + wdh_prof(24) ,&! Diurnal traffic flow profile of weekday + pop_den ,&! population density + vehicle(3) ! vehicle numbers per thousand people + + real(r8), intent(in) :: & + froof ,&! roof fractional cover [-] + fgper ,&! impervious fraction to ground area [-] + flake ,&! lake fraction to ground area [-] + hroof ,&! average building height [m] + hlr ,&! average building height to their side length [-] + em_roof ,&! emissivity of roof [-] + em_wall ,&! emissivity of walls [-] + em_gimp ,&! emissivity of impervious [-] + em_gper ! emissivity of pervious [-] + + real(r8), intent(in) :: & + cv_roof (1:nl_roof) ,&! heat capacity of roof [J/(m2 K)] + cv_wall (1:nl_wall) ,&! heat capacity of wall [J/(m2 K)] + cv_gimp (1:nl_soil) ,&! heat capacity of impervious [J/(m2 K)] + tk_roof (1:nl_roof) ,&! thermal conductivity of roof [W/m-K] + tk_wall (1:nl_wall) ,&! thermal conductivity of wall [W/m-K] + tk_gimp (1:nl_soil) ! thermal conductivity of impervious [W/m-K] + + real(r8), intent(in) :: & + ! soil physical parameters and lake info + vf_quartz (nl_soil) ,&! volumetric fraction of quartz within mineral soil + vf_gravels (nl_soil) ,&! volumetric fraction of gravels + vf_om (nl_soil) ,&! volumetric fraction of organic matter + vf_sand (nl_soil) ,&! volumetric fraction of sand + wf_gravels (nl_soil) ,&! gravimetric fraction of gravels + wf_sand (nl_soil) ,&! gravimetric fraction of sand + porsl (nl_soil) ,&! fraction of soil that is voids [-] + psi0 (nl_soil) ,&! minimum soil suction [mm] + bsw (nl_soil) ,&! clapp and hornberger "b" parameter [-] + theta_r (nl_soil) ,&! residual water content (cm3/cm3) + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm (1:nl_soil) ,&! parameter correspond approximately to inverse of air-entry value + n_vgm (1:nl_soil) ,&! a shape parameter + L_vgm (1:nl_soil) ,&! pore-connectivity parameter + sc_vgm (1:nl_soil) ,&! saturation at air entry value in classical vanGenuchten model [-] + fc_vgm (1:nl_soil) ,&! a scaling factor by using air entry value in the Mualem model [-] +#endif + hksati (nl_soil) ,&! hydraulic conductivity at saturation [mm h2o/s] + csol (nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] + k_solids (nl_soil) ,&! thermal conductivity of minerals soil [W/m-K] + dksatu (nl_soil) ,&! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (nl_soil) ,&! thermal conductivity of saturated frozen soil [W/m-K] + dkdry (nl_soil) ,&! thermal conductivity for dry soil [J/(K s m)] + + BA_alpha (nl_soil) ,&! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (nl_soil) ,&! beta in Balland and Arp(2005) thermal conductivity scheme + alb_roof(2,2) ,&! albedo of roof [-] + alb_wall(2,2) ,&! albedo of walls [-] + alb_gimp(2,2) ,&! albedo of impervious [-] + alb_gper(2,2) ,&! albedo of pervious [-] + + ! vegetation static, dynamic, derived parameters + sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] + chil ,&! leaf angle distribution factor + effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25 ,&! maximum carboxylation rate at 25 C at canopy top + slti ,&! slope of low temperature inhibition function [s3] + hlti ,&! 1/2 point of low temperature inhibition function [s4] + shti ,&! slope of high temperature inhibition function [s1] + hhti ,&! 1/2 point of high temperature inhibition function [s2] + trda ,&! temperature coefficient in gs-a model [s5] + trdm ,&! temperature coefficient in gs-a model [s6] + trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model + gradm ,&! conductance-photosynthesis slope parameter + binter ,&! conductance-photosynthesis intercep + extkn ,&! coefficient of leaf nitrogen allocation + rho(2,2) ,&! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ,&! leaf transmittance (iw=iband, il=life and dead) + + rootfr (nl_soil) ,&! fraction of roots in each soil layer + lambda ,&! marginal water cost of carbon gain + + ! tunable parameters + zlnd ,&! roughness length for soil [m] + zsno ,&! roughness length for snow [m] + csoilc ,&! drag coefficient for soil under canopy [-] + dewmx ,&! maximum dew + ! wtfact ,&! fraction of model area with high water table + ! (updated to gridded 'fsatmax') + capr ,&! tuning factor to turn first layer T into surface T + cnfac ,&! Crank Nicholson factor between 0 and 1 + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable IF porosity less than wimp + pondmx ,&! ponding depth (mm) + smpmax ,&! wilting point potential in mm + smpmin ,&! restriction for min of soil poten. (mm) + trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] + tcrit ! critical temp. to determine rain or snow + + integer, intent(in) :: c3c4 ! 1 for C3, 0 for C4 + + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + ! Forcing + ! ---------------------- + real(r8), intent(in) :: & + forc_pco2m ,&! partial pressure of CO2 at observational height [pa] + forc_po2m ,&! partial pressure of O2 at observational height [pa] + forc_us ,&! wind speed in eastward direction [m/s] + forc_vs ,&! wind speed in northward direction [m/s] + forc_t ,&! temperature at agcm reference height [kelvin] + forc_q ,&! specific humidity at agcm reference height [kg/kg] + forc_prc ,&! convective precipitation [mm/s] + forc_prl ,&! large scale precipitation [mm/s] + forc_psrf ,&! atmosphere pressure at the surface [pa] + forc_pbot ,&! atmosphere pressure at the bottom of the atmos. model level [pa] + forc_sols ,&! atm vis direct beam solar rad onto srf [W/m2] + forc_soll ,&! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd ,&! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ,&! atm nir diffuse solar rad onto srf [W/m2] + forc_frl ,&! atmospheric infrared (longwave) radiation [W/m2] + forc_hgt_u ,&! observational height of wind [m] + forc_hgt_t ,&! observational height of temperature [m] + forc_hgt_q ,&! observational height of humidity [m] + forc_rhoair ! density air [kg/m3] + +#if (defined CaMa_Flood) + real(r8), intent(in) :: fldfrc !inundation fraction + !--> allow re-evaporation and infiltration![0-1] + real(r8), intent(inout) :: flddepth !inundation depth + !--> allow re-evaporation and infiltration![mm] + real(r8), intent(out) :: fevpg_fld !effective evaporation from inundation [mm/s] + real(r8), intent(out) :: qinfl_fld !effective re-infiltration from inundation [mm/s] +#endif + +! Variables required for restart run +! ---------------------------------------------------------------------- + real(r8), intent(inout) :: & + t_wallsun ( 1:nl_wall) ,&! sunlit wall layer temperature [K] + t_wallsha ( 1:nl_wall) ,&! shaded wall layer temperature [K] + t_soisno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + t_roofsno (maxsnl+1:nl_roof) ,&! soil + snow layer temperature [K] + t_gimpsno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + t_gpersno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + t_lakesno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + wliq_soisno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wliq_roofsno (maxsnl+1:nl_roof) ,&! liquid water (kg/m2) + wliq_gimpsno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wliq_gpersno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wliq_lakesno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wice_soisno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + wice_roofsno (maxsnl+1:nl_roof) ,&! ice lens (kg/m2) + wice_gimpsno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + wice_gpersno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + wice_lakesno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + smp ( 1:nl_soil) ,&! soil matrix potential [mm] + hk ( 1:nl_soil) ,&! hydraulic conductivity [mm h2o/s] + + z_sno (maxsnl+1:0) ,&! node depth [m] + dz_sno (maxsnl+1:0) ,&! interface depth [m] + z_sno_roof (maxsnl+1:0) ,&! node depth of roof [m] + z_sno_gimp (maxsnl+1:0) ,&! node depth of impervious [m] + z_sno_gper (maxsnl+1:0) ,&! node depth pervious [m] + z_sno_lake (maxsnl+1:0) ,&! node depth lake [m] + dz_sno_roof (maxsnl+1:0) ,&! interface depth of roof [m] + dz_sno_gimp (maxsnl+1:0) ,&! interface depth of impervious [m] + dz_sno_gper (maxsnl+1:0) ,&! interface depth pervious [m] + dz_sno_lake (maxsnl+1:0) ,&! interface depth lake [m] + + lakedepth ,&! lake depth (m) + z_roof (nl_roof) ,&! thickness of roof [m] + z_wall (nl_wall) ,&! thickness of wall [m] + dz_roof (nl_roof) ,&! thickness of each layer [m] + dz_wall (nl_wall) ,&! thickness of each layer [m] + dz_lake (nl_lake) ,&! lake layer thickness (m) + t_lake (nl_lake) ,&! lake temperature (kelvin) + lake_icefrac (nl_lake) ,&! lake mass fraction of lake layer that is frozen + savedtke1 ,&! top level eddy conductivity (W/m K) + + elvstd ,&! standard deviation of elevation [m] + BVIC ,&! b parameter in Fraction of saturated soil calculated by VIC + + t_grnd ,&! ground surface temperature [k] + tleaf ,&! sunlit leaf temperature [K] + !tmax ,&! Diurnal Max 2 m height air temperature [kelvin] + !tmin ,&! Diurnal Min 2 m height air temperature [kelvin] + ldew ,&! depth of water on foliage [kg/m2/s] + ldew_rain ,&! depth of rain on foliage[kg/m2/s] + ldew_snow ,&! depth of snow on foliage[kg/m2/s] + fwet_snow ,&! vegetation canopy snow fractional cover [-] + sag ,&! non dimensional snow age [-] + sag_roof ,&! non dimensional snow age [-] + sag_gimp ,&! non dimensional snow age [-] + sag_gper ,&! non dimensional snow age [-] + sag_lake ,&! non dimensional snow age [-] + scv ,&! snow mass (kg/m2) + scv_roof ,&! snow mass (kg/m2) + scv_gimp ,&! snow mass (kg/m2) + scv_gper ,&! snow mass (kg/m2) + scv_lake ,&! snow mass (kg/m2) + snowdp ,&! snow depth (m) + snowdp_roof ,&! snow depth (m) + snowdp_gimp ,&! snow depth (m) + snowdp_gper ,&! snow depth (m) + snowdp_lake ,&! snow depth (m) + zwt ,&! the depth to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ,&! water storage in aquifer [mm] + + snw_rds ( maxsnl+1:0 ) ,&! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ,&! mass of dust species 4 in snow (col,lyr) [kg] + ssno (2,2,maxsnl+1:1 ) ,&! snow layer absorption [-] + + fveg ,&! fraction of vegetation cover + fsno ,&! fractional snow cover + fsno_roof ,&! fractional snow cover + fsno_gimp ,&! fractional snow cover + fsno_gper ,&! fractional snow cover + fsno_lake ,&! fractional snow cover + sigf ,&! fraction of veg cover, excluding snow-covered veg [-] + green ,&! greenness + lai ,&! leaf area index + sai ,&! stem area index + htop ,&! canopy crown top + hbot ,&! canopy crown bottom + + lwsun ,&! net longwave of sunlit wall [W/m2] + lwsha ,&! net longwave of shaded wall [W/m2] + lgimp ,&! net longwave of impervious [W/m2] + lgper ,&! net longwave of pervious [W/m2] + lveg ,&! net longwave of vegetation [W/m2] + fwsun ,&! sunlit fraction of walls [-] + dfwsun ,&! change of sunlit fraction of walls [-] + t_room ,&! temperature of inner building [K] + troof_inner ,&! temperature of inner roof [K] + twsun_inner ,&! temperature of inner sunlit wall [K] + twsha_inner ,&! temperature of inner shaded wall [K] + t_roommax ,&! maximum temperature of inner room [K] + t_roommin ,&! minimum temperature of inner room [K] + tafu ,&! temperature of outer building [K] + Fhac ,&! sensible flux from heat or cool AC [W/m2] + Fwst ,&! waste heat flux from heat or cool AC [W/m2] + Fach ,&! flux from inner and outer air exchange [W/m2] + Fahe ,&! flux from metabolism and vehicle [W/m2] + Fhah ,&! sensible heat flux from heating [W/m2] + vehc ,&! flux from vehicle [W/m2] + meta ,&! flux from metabolism [W/m2] + + extkd ,&! diffuse and scattered diffuse PAR extinction coefficient + alb (2,2) ,&! averaged albedo [-] + ssun (2,2) ,&! sunlit canopy absorption for solar radiation + ssha (2,2) ,&! shaded canopy absorption for solar radiation + sroof(2,2) ,&! shaded canopy absorption for solar radiation + swsun(2,2) ,&! shaded canopy absorption for solar radiation + swsha(2,2) ,&! shaded canopy absorption for solar radiation + sgimp(2,2) ,&! shaded canopy absorption for solar radiation + sgper(2,2) ,&! shaded canopy absorption for solar radiation + slake(2,2) ! shaded canopy absorption for solar radiation + +! additional diagnostic variables for output + real(r8), intent(out) :: & + laisun ,&! sunlit leaf area index + laisha ,&! shaded leaf area index + rstfac ,&! factor of soil water stress + rss ,&! soil surface resistance + wat ,&! total water storage + h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3] + +! Fluxes +! ---------------------------------------------------------------------- + real(r8), intent(out) :: & + taux ,&! wind stress: E-W [kg/m/s**2] + tauy ,&! wind stress: N-S [kg/m/s**2] + fsena ,&! sensible heat from canopy height to atmosphere [W/m2] + fevpa ,&! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa ,&! latent heat flux from canopy height to atmosphere [W/2] + fsenl ,&! sensible heat from leaves [W/m2] + fevpl ,&! evaporation+transpiration from leaves [mm/s] + etr ,&! transpiration rate [mm/s] + fseng ,&! sensible heat flux from ground [W/m2] + fevpg ,&! evaporation heat flux from ground [mm/s] + olrg ,&! outgoing long-wave radiation from ground+canopy + fgrnd ,&! ground heat flux [W/m2] + xerr ,&! water balance error at current time-step [mm/s] + zerr ,&! energy balance error at current time-step [W/m2] + + tref ,&! 2 m height air temperature [K] + qref ,&! 2 m height air specific humidity + trad ,&! radiative temperature [K] + rsur ,&! surface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qintr ,&! interception (mm h2o/s) + qinfl ,&! infiltration (mm h2o/s) + qdrip ,&! throughfall (mm h2o/s) + qcharge ,&! groundwater recharge [mm/s] + + rst ,&! canopy stomatal resistance + assim ,&! canopy assimilation + respc ,&! canopy respiration + + fsen_roof ,&! sensible heat flux from roof [W/m2] + fsen_wsun ,&! sensible heat flux from sunlit wall [W/m2] + fsen_wsha ,&! sensible heat flux from shaded wall [W/m2] + fsen_gimp ,&! sensible heat flux from impervious road [W/m2] + fsen_gper ,&! sensible heat flux from pervious road [W/m2] + fsen_urbl ,&! sensible heat flux from urban vegetation [W/m2] + + lfevp_roof ,&! latent heat flux from roof [W/m2] + lfevp_gimp ,&! latent heat flux from impervious road [W/m2] + lfevp_gper ,&! latent heat flux from pervious road [W/m2] + lfevp_urbl ,&! latent heat flux from urban vegetation [W/m2] + + troof ,&! temperature of roof [K] + twall ,&! temperature of wall [K] + + sabvsun ,&! solar absorbed by sunlit vegetation [W/m2] + sabvsha ,&! solar absorbed by shaded vegetation [W/m2] + sabg ,&! solar absorbed by ground [W/m2] + sr ,&! total reflected solar radiation (W/m2) + solvd ,&! incident direct beam vis solar radiation (W/m2) + solvi ,&! incident diffuse beam vis solar radiation (W/m2) + solnd ,&! incident direct beam nir solar radiation (W/m2) + solni ,&! incident diffuse beam nir solar radiation (W/m2) + srvd ,&! reflected direct beam vis solar radiation (W/m2) + srvi ,&! reflected diffuse beam vis solar radiation (W/m2) + srnd ,&! reflected direct beam nir solar radiation (W/m2) + srni ,&! reflected diffuse beam nir solar radiation (W/m2) + solvdln ,&! incident direct beam vis solar radiation at local noon(W/m2) + solviln ,&! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln ,&! incident direct beam nir solar radiation at local noon(W/m2) + solniln ,&! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln ,&! reflected direct beam vis solar radiation at local noon(W/m2) + srviln ,&! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln ,&! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ,&! reflected diffuse beam nir solar radiation at local noon(W/m2) + + forc_rain ,&! rain [mm/s] + forc_snow ,&! snow [mm/s] + + emis ,&! averaged bulk surface emissivity + z0m ,&! effective roughness [m] + zol ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib ,&! bulk Richardson number in surface layer + ustar ,&! u* in similarity theory [m/s] + qstar ,&! q* in similarity theory [kg/kg] + tstar ,&! t* in similarity theory [K] + fm ,&! integral of profile function for momentum + fh ,&! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + calday ,&! Julian cal day (1.xx to 365.xx) + endwb ,&! water mass at the end of time step + errore ,&! energy balance error (Wm-2) + errorw ,&! water balance error (mm) + fioldr (maxsnl+1:nl_roof), &! fraction of ice relative to the total water + fioldi (maxsnl+1:nl_soil), &! fraction of ice relative to the total water + fioldp (maxsnl+1:nl_soil), &! fraction of ice relative to the total water + fioldl (maxsnl+1:nl_soil), &! fraction of ice relative to the total water + w_old ,&! liquid water mass of the column at the previous time step (mm) + theta ,&! sun zenith angle + sabv ,&! solar absorbed by vegetation [W/m2] + sabroof ,&! solar absorbed by vegetation [W/m2] + sabwsun ,&! solar absorbed by vegetation [W/m2] + sabwsha ,&! solar absorbed by vegetation [W/m2] + sabgimp ,&! solar absorbed by vegetation [W/m2] + sabgper ,&! solar absorbed by vegetation [W/m2] + sablake ,&! solar absorbed by vegetation [W/m2] + par ,&! PAR by leaves [W/m2] + tgimp ,&! temperature of impervious surface [K] + tgper ,&! temperature of pervious surface [K] + tlake ,&! temperature of lake surface [K] + qdrip_gper ,&! throughfall of pervious (mm h2o/s) + qseva_roof ,&! ground surface evaporation rate (mm h2o/s) + qseva_gimp ,&! ground surface evaporation rate (mm h2o/s) + qseva_gper ,&! ground surface evaporation rate (mm h2o/s) + qseva_lake ,&! ground surface evaporation rate (mm h2o/s) + qsdew_roof ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gimp ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gper ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_lake ,&! ground surface dew formation (mm h2o /s) [+] + qsubl_roof ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gimp ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gper ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_lake ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_roof ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_lake ,&! surface dew added to snow pack (mm h2o /s) [+] + scvold_roof ,&! snow mass on roof for previous time step [kg/m2] + scvold_gimp ,&! snow mass on impervious surfaces for previous time step [kg/m2] + scvold_gper ,&! snow mass on pervious surfaces for previous time step [kg/m2] + scvold_lake ,&! snow mass on lake for previous time step [kg/m2] + sm_roof ,&! rate of snowmelt [kg/(m2 s)] + sm_gimp ,&! rate of snowmelt [kg/(m2 s)] + sm_gper ,&! rate of snowmelt [kg/(m2 s)] + sm_lake ,&! rate of snowmelt [kg/(m2 s)] + totwb ,&! water mass at the begining of time step + totwb_roof ,&! water mass at the begining of time step + totwb_gimp ,&! water mass at the begining of time step + totwb_gper ,&! water mass at the begining of time step + wt ,&! fraction of vegetation buried (covered) by snow [-] + rootr (1:nl_soil) ,&! root resistance of a layer, all layers add to 1.0 + rootflux (1:nl_soil) ,&! root resistance of a layer, all layers add to 1.0 + etr_deficit ,&! urban tree etr deficit [mm/s] + urb_irrig ,&! named urban tree irrigation [mm/s] + + zi_wall ( 0:nl_wall) ,&! interface level below a "z" level [m] + z_roofsno (maxsnl+1:nl_roof) ,&! layer depth [m] + z_gimpsno (maxsnl+1:nl_soil) ,&! layer depth [m] + z_gpersno (maxsnl+1:nl_soil) ,&! layer depth [m] + z_lakesno (maxsnl+1:nl_soil) ,&! layer depth [m] + dz_roofsno (maxsnl+1:nl_roof) ,&! layer thickness [m] + dz_gimpsno (maxsnl+1:nl_soil) ,&! layer thickness [m] + dz_gpersno (maxsnl+1:nl_soil) ,&! layer thickness [m] + dz_lakesno (maxsnl+1:nl_soil) ,&! layer thickness [m] + zi_roofsno (maxsnl :nl_roof) ,&! interface level below a "z" level [m] + zi_gimpsno (maxsnl :nl_soil) ,&! interface level below a "z" level [m] + zi_gpersno (maxsnl :nl_soil) ,&! interface level below a "z" level [m] + zi_lakesno (maxsnl :nl_soil) ! interface level below a "z" level [m] + + real(r8) :: & + prc_rain ,&! convective rainfall [kg/(m2 s)] + prc_snow ,&! convective snowfall [kg/(m2 s)] + prl_rain ,&! large scale rainfall [kg/(m2 s)] + prl_snow ,&! large scale snowfall [kg/(m2 s)] + t_precip ,&! snowfall/rainfall temperature [kelvin] + bifall ,&! bulk density of newly fallen dry snow [kg/m3] + pg_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + pgper_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pgper_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + pgimp_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pgimp_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + pg_rain_lake ,&! rainfall onto lake [kg/(m2 s)] + pg_snow_lake ,&! snowfall onto lake [kg/(m2 s)] + qintr_rain ,&! rainfall interception (mm h2o/s) + qintr_snow ,&! snowfall interception (mm h2o/s) + etrgper ,&! etr for pervious ground + fveg_gper ,&! fraction of fveg/fgper + fveg_gimp ! fraction of fveg/fgimp + + real(r8) :: & + ei ,&! vapor pressure on leaf surface [pa] + deidT ,&! derivative of "ei" on "tl" [pa/K] + qsatl ,&! leaf specific humidity [kg/kg] + qsatldT ! derivative of "qsatl" on "tlef" + + integer :: & + snlr ,&! number of snow layers + snli ,&! number of snow layers + snlp ,&! number of snow layers + snll ,&! number of snow layers + imeltr (maxsnl+1:nl_roof), &! flag for: melting=1, freezing=2, Nothing happened=0 + imelti (maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + imeltp (maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + imeltl (maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + lbr ,&! lower bound of arrays + lbi ,&! lower bound of arrays + lbp ,&! lower bound of arrays + lbl ,&! lower bound of arrays + lbsn ,&! lower bound of arrays + j ! DO looping index + + ! For SNICAR snow model + !---------------------------------------------------------------------- + real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8) sabg_lyr (maxsnl+1:1) !snow layer absorption [W/m-2] + + !irrigation + real(r8) :: & + qflx_irrig_drip ,&! drip irrigation rate [mm/s] + qflx_irrig_sprinkler ,&! sprinkler irrigation rate [mm/s] + qflx_irrig_flood ,&! flood irrigation rate [mm/s] + qflx_irrig_paddy ! paddy irrigation rate [mm/s] + + ! A simple urban irrigation scheme accounts for soil water stress of trees + ! a factor represents irrigation efficiency, '1' represents a 50% direct irrigation efficiency. + real(r8), parameter :: wst_irrig = 1.0 + +!----------------------------------------------------------------------- + + theta = acos(max(coszen,0.01)) + forc_aer(:) = 0. !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + +!====================================================================== +! [1] Solar absorbed by vegetation and ground +! and precipitation information (rain/snow fall and precip temperature +!====================================================================== + + CALL netsolar_urban (ipatch,idate,patchlonr,deltim,& + forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& + alb(:,:),ssun(:,:),ssha(:,:),sroof(:,:),swsun(:,:),& + swsha(:,:),sgimp(:,:),sgper(:,:),slake(:,:),& + sr,sabv,par,sabroof,sabwsun,sabwsha,sabgimp,sabgper,sablake,& + solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + + CALL rain_snow_temp (patchtype,forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,& + tcrit,prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) + +#ifdef MPAS_EMBEDDED_COLM + ! MPAS already provides hydrometeor phase; keep it while using CoLM for precipitation temperature. + prc_rain = max(0._r8, min(forc_prc, forc_rain)) + prc_snow = max(0._r8, forc_prc - prc_rain) + prl_rain = max(0._r8, forc_rain - prc_rain) + prl_snow = max(0._r8, forc_snow - prc_snow) +#else + forc_rain = prc_rain + prl_rain + forc_snow = prc_snow + prl_snow +#endif + + sabvsun = sabv * fveg * (1-flake) + sabvsha = 0. + +!====================================================================== + + z_roofsno (maxsnl+1:0) = z_sno_roof (maxsnl+1:0) + z_roofsno (1:nl_roof ) = z_roof (1:nl_roof) + dz_roofsno(maxsnl+1:0) = dz_sno_roof(maxsnl+1:0) + dz_roofsno(1:nl_roof ) = dz_roof(1:nl_roof) + + z_gimpsno (maxsnl+1:0) = z_sno_gimp (maxsnl+1:0) + z_gimpsno (1:nl_soil ) = z_soi (1:nl_soil) + dz_gimpsno(maxsnl+1:0) = dz_sno_gimp(maxsnl+1:0) + dz_gimpsno(1:nl_soil ) = dz_soi(1:nl_soil) + + z_gpersno (maxsnl+1:0) = z_sno_gper (maxsnl+1:0) + z_gpersno (1:nl_soil ) = z_soi (1:nl_soil) + dz_gpersno(maxsnl+1:0) = dz_sno_gper(maxsnl+1:0) + dz_gpersno(1:nl_soil ) = dz_soi(1:nl_soil) + + z_lakesno (maxsnl+1:0) = z_sno_lake (maxsnl+1:0) + z_lakesno (1:nl_soil ) = z_soi (1:nl_soil) + dz_lakesno(maxsnl+1:0) = dz_sno_lake(maxsnl+1:0) + dz_lakesno(1:nl_soil ) = dz_soi(1:nl_soil) + + !============================================================ + zi_wall(0) = 0. + DO j = 1, nl_wall + zi_wall(j) = zi_wall(j-1) + dz_wall(j) + ENDDO + + !============================================================ + scvold_roof = scv_roof !snow mass at previous time step + + snlr = 0 + DO j = maxsnl+1, 0 + IF (wliq_roofsno(j)+wice_roofsno(j) > 0.) snlr = snlr - 1 + ENDDO + + zi_roofsno(0) = 0. + IF (snlr < 0) THEN + DO j = -1, snlr, -1 + zi_roofsno(j) = zi_roofsno(j+1) - dz_roofsno(j+1) + ENDDO + ENDIF + DO j = 1, nl_roof + zi_roofsno(j) = zi_roofsno(j-1) + dz_roofsno(j) + ENDDO + + totwb_roof = scv_roof + wice_roofsno(1) + wliq_roofsno(1) + fioldr(:) = 0.0 + IF (snlr < 0) THEN + fioldr(snlr+1:0) = wice_roofsno(snlr+1:0) / & + (wliq_roofsno(snlr+1:0) + wice_roofsno(snlr+1:0)) + ENDIF + + !============================================================ + scvold_gimp = scv_gimp !snow mass at previous time step + + snli = 0 + DO j = maxsnl+1, 0 + IF (wliq_gimpsno(j)+wice_gimpsno(j) > 0.) snli = snli - 1 + ENDDO + + zi_gimpsno(0) = 0. + IF (snli < 0) THEN + DO j = -1, snli, -1 + zi_gimpsno(j) = zi_gimpsno(j+1) - dz_gimpsno(j+1) + ENDDO + ENDIF + + zi_gimpsno(1:nl_soil) = zi_soi(1:nl_soil) + + totwb_gimp = scv_gimp + wice_gimpsno(1) + wliq_gimpsno(1) + fioldi(:) = 0.0 + IF (snli < 0) THEN + fioldi(snli+1:0) = wice_gimpsno(snli+1:0) / & + (wliq_gimpsno(snli+1:0) + wice_gimpsno(snli+1:0)) + ENDIF + + !============================================================ + scvold_gper = scv_gper !snow mass at previous time step + + snlp = 0 + DO j = maxsnl+1, 0 + IF(wliq_gpersno(j)+wice_gpersno(j) > 0.) snlp = snlp - 1 + ENDDO + + zi_gpersno(0) = 0. + IF (snlp < 0) THEN + DO j = -1, snlp, -1 + zi_gpersno(j) = zi_gpersno(j+1) - dz_gpersno(j+1) + ENDDO + ENDIF + + zi_gpersno(1:nl_soil) = zi_soi(1:nl_soil) + + totwb_gper = ldew + scv_gper + sum(wice_gpersno(1:) + wliq_gpersno(1:)) + wa + fioldp(:) = 0.0 + IF (snlp < 0) THEN + fioldp(snlp+1:0) = wice_gpersno(snlp+1:0) / & + (wliq_gpersno(snlp+1:0) + wice_gpersno(snlp+1:0)) + ENDIF + + !============================================================ + scvold_lake = scv_lake !snow mass at previous time step + + snll = 0 + DO j = maxsnl+1, 0 + IF (wliq_lakesno(j) + wice_lakesno(j) > 0.) snll = snll - 1 + ENDDO + + zi_lakesno(0) = 0. + IF (snll < 0) THEN + DO j = -1, snll, -1 + zi_lakesno(j) = zi_lakesno(j+1) - dz_lakesno(j+1) + ENDDO + ENDIF + + zi_lakesno(1:nl_soil) = zi_soi(1:nl_soil) + + w_old = sum(wliq_lakesno(snll+1:)) + fioldl(:) = 0.0 + IF (snll <0 ) THEN + fioldl(snll+1:0) = wice_lakesno(snll+1:0) / & + (wliq_lakesno(snll+1:0) + wice_lakesno(snll+1:0)) + ENDIF + + !============================================================ + totwb = sum(wice_soisno(1:) + wliq_soisno(1:)) + totwb = totwb + scv + ldew*fveg + wa*(1-froof)*fgper + + etr_deficit = 0. + urb_irrig = 0. + +!---------------------------------------------------------------------- +! [2] Canopy interception and precipitation onto ground surface +!---------------------------------------------------------------------- + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 + + ! with vegetation canopy + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tref,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pgper_rain,pgper_snow,& + qintr,qintr_rain,qintr_snow) + + ! for output, patch scale + qintr = qintr * fveg * (1-flake) + qdrip_gper = pgper_rain + pgper_snow + qdrip = forc_rain + forc_snow + qdrip = qdrip*(1-fveg*(1-flake)) + qdrip_gper*fveg*(1-flake) + + ! without vegetation canopy + pg_rain = prc_rain + prl_rain + pg_snow = prc_snow + prl_snow + pg_rain_lake = prc_rain + prl_rain + pg_snow_lake = prc_snow + prl_snow + + ! for urban hydrology input, only for pervious ground + IF (fgper > 0) THEN + fveg_gper = fveg/((1-froof)*fgper) + ELSE + fveg_gper = 0. + ENDIF + + IF (fgper < 1) THEN + fveg_gimp = (fveg-(1-froof)*fgper)/((1-froof)*(1-fgper)) + ELSE + fveg_gimp = 0. + ENDIF + + IF (fveg_gper .le. 1) THEN + pgper_rain = pgper_rain*fveg_gper + pg_rain*(1-fveg_gper) + pgper_snow = pgper_snow*fveg_gper + pg_snow*(1-fveg_gper) + pgimp_rain = pg_rain + pgimp_snow = pg_snow + ELSE + pgimp_rain = pgper_rain*fveg_gimp + pg_rain*(1-fveg_gimp) + pgimp_snow = pgper_snow*fveg_gimp + pg_snow*(1-fveg_gimp) + ENDIF + +!---------------------------------------------------------------------- +! [3] Initialize new snow nodes for snowfall / sleet +!---------------------------------------------------------------------- + + lbr = snlr + 1 !lower bound of array + lbi = snli + 1 !lower bound of array + lbp = snlp + 1 !lower bound of array + troof = t_roofsno(lbr) + tgimp = t_gimpsno(lbi) + tgper = t_gpersno(lbp) + + CALL newsnow (patchtype,maxsnl,deltim,troof,pg_rain,pg_snow,bifall,& + t_precip,zi_roofsno(:0),z_roofsno(:0),dz_roofsno(:0),t_roofsno(:0),& + wliq_roofsno(:0),wice_roofsno(:0),fioldr(:0),& + snlr,sag_roof,scv_roof,snowdp_roof,fsno_roof) + + CALL newsnow (patchtype,maxsnl,deltim,tgimp,pgimp_rain,pgimp_snow,bifall,& + t_precip,zi_gimpsno(:0),z_gimpsno(:0),dz_gimpsno(:0),t_gimpsno(:0),& + wliq_gimpsno(:0),wice_gimpsno(:0),fioldi(:0),& + snli,sag_gimp,scv_gimp,snowdp_gimp,fsno_gimp) + + CALL newsnow (patchtype,maxsnl,deltim,tgper,pgper_rain,pgper_snow,bifall,& + t_precip,zi_gpersno(:0),z_gpersno(:0),dz_gpersno(:0),t_gpersno(:0),& + wliq_gpersno(:0),wice_gpersno(:0),fioldp(:0),& + snlp,sag_gper,scv_gper,snowdp_gper,fsno_gper) + + CALL newsnow_lake ( DEF_USE_Dynamic_Lake, & + ! "in" arguments + ! --------------- + maxsnl ,nl_lake ,deltim ,dz_lake ,& + pg_rain_lake ,pg_snow_lake ,t_precip ,bifall ,& + + ! "inout" arguments + ! ------------------ + t_lake ,zi_lakesno(:0),z_lakesno(:0) ,& + dz_lakesno(:0),t_lakesno(:0) ,wliq_lakesno(:0),wice_lakesno(:0),& + fioldl(:0) ,snll ,sag_lake ,scv_lake ,& + snowdp_lake ,lake_icefrac ) + +!---------------------------------------------------------------------- +! [4] Energy and Water balance +!---------------------------------------------------------------------- + + lbr = snlr + 1 !lower bound of array + lbi = snli + 1 !lower bound of array + lbp = snlp + 1 !lower bound of array + lbl = snll + 1 !lower bound of array + lbsn= min(lbp,0) + + ! Thermal process + CALL UrbanTHERMAL ( & + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,deltim ,patchlatr ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_psrf ,& + forc_rhoair ,forc_frl ,forc_po2m ,forc_pco2m ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + theta ,sabroof ,sabwsun ,sabwsha ,& + sabgimp ,sabgper ,sablake ,sabv ,& + par ,Fhac ,Fwst ,Fach ,& + Fahe ,Fhah ,vehc ,meta ,& + ! LUCY INPUT PARAMETERS + fix_holiday ,week_holiday ,hum_prof ,pop_den ,& + vehicle ,weh_prof ,wdh_prof ,idate ,& + patchlonr ,& + ! GROUND PARAMETERS + froof ,flake ,hroof ,hlr ,& + fgper ,pondmx ,em_roof ,em_wall ,& + em_gimp ,em_gper ,trsmx0 ,zlnd ,& + zsno ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,& + cv_roof ,cv_wall ,cv_gimp ,& + tk_roof ,tk_wall ,tk_gimp ,dz_roofsno(lbr:) ,& + dz_gimpsno(lbi:) ,dz_gpersno(lbp:) ,dz_lakesno(:) ,dz_wall(:) ,& + z_roofsno(lbr:) ,z_gimpsno(lbi:) ,z_gpersno(lbp:) ,z_lakesno(:) ,& + z_wall(:) ,zi_roofsno(lbr-1:) ,zi_gimpsno(lbi-1:) ,zi_gpersno(lbp-1:) ,& + zi_lakesno(:) ,zi_wall(0:) ,dz_lake(1:) ,lakedepth ,& + dewmx ,sqrtdi ,rootfr(:) ,effcon ,& + vmax25 ,c3c4 ,slti ,hlti ,shti,& + hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,& + extkn ,lambda ,& + ! surface status + fsno_roof ,fsno_gimp ,fsno_gper ,scv_roof ,& + scv_gimp ,scv_gper ,scv_lake ,snowdp_roof ,& + snowdp_gimp ,snowdp_gper ,snowdp_lake ,fwsun ,& + dfwsun ,lai ,sai ,htop ,& + hbot ,fveg ,sigf ,extkd ,& + lwsun ,lwsha ,lgimp ,lgper ,& + t_grnd ,t_roofsno(lbr:) ,t_wallsun(:) ,t_wallsha(:) ,& + t_gimpsno(lbi:) ,t_gpersno(lbp:) ,t_lakesno(:) ,wliq_roofsno(lbr:) ,& + wliq_gimpsno(lbi:) ,wliq_gpersno(lbp:) ,wliq_lakesno(:) ,wice_roofsno(lbr:) ,& + wice_gimpsno(lbi:) ,wice_gpersno(lbp:) ,wice_lakesno(:) ,t_lake(:) ,& + lake_icefrac(:) ,savedtke1 ,lveg ,tleaf ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + t_room ,troof_inner ,twsun_inner ,twsha_inner ,& + t_roommax ,t_roommin ,tafu ,& + +! SNICAR model variables + snofrz(lbsn:0) ,sabg_lyr(lbp:1) ,& +! END SNICAR model variables + + ! output + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + fsen_roof ,fsen_wsun ,fsen_wsha ,fsen_gimp ,& + fsen_gper ,fsen_urbl ,troof ,twall ,& + lfevp_roof ,lfevp_gimp ,lfevp_gper ,lfevp_urbl ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + imeltr(lbr:) ,imelti(lbi:) ,imeltp(lbp:) ,imeltl(:) ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + sabg ,rstfac ,rootr(:) ,etr_deficit ,& + tref ,qref ,trad ,rst ,& + assim ,respc ,errore ,emis ,& + z0m ,zol ,rib ,ustar ,& + qstar ,tstar ,fm ,fh ,& + fq ,hpbl ) + +!---------------------------------------------------------------------- +! [5] Urban hydrology +!---------------------------------------------------------------------- + IF (fveg > 0) THEN + ! convert to unit area + etrgper = (etr-etr_deficit)/(1-froof)/fgper + ELSE + etrgper = 0. + ENDIF + + pgper_rain = pgper_rain + wst_irrig*etr_deficit/(1-froof)/fgper + urb_irrig = etr_deficit + wst_irrig*etr_deficit + + CALL UrbanHydrology ( & + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,snll ,deltim ,& + ! forcing + pg_rain ,pgper_rain ,pgimp_rain ,pg_snow ,& + pg_rain_lake ,pg_snow_lake ,& + froof ,fgper ,flake ,bsw ,& + porsl ,psi0 ,hksati ,pondmx ,& + ssi ,wimp ,smpmin ,theta_r ,& + fsatmax ,fsatdcf ,elvstd ,BVIC ,& + rootr,rootflux ,etrgper ,fseng ,fgrnd ,& + t_gpersno(lbp:) ,t_lakesno(:) ,t_lake ,dz_lake ,& + z_gpersno(lbp:) ,z_lakesno(:) ,zi_gpersno(lbp-1:) ,zi_lakesno(:) ,& + dz_roofsno(lbr:) ,dz_gimpsno(lbi:) ,dz_gpersno(lbp:) ,dz_lakesno(:) ,& + wliq_roofsno(lbr:) ,wliq_gimpsno(lbi:) ,wliq_gpersno(lbp:) ,wliq_lakesno(:) ,& + wice_roofsno(lbr:) ,wice_gimpsno(lbi:) ,wice_gpersno(lbp:) ,wice_lakesno(:) ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + lake_icefrac ,scv_lake ,snowdp_lake ,imeltl ,& + fioldl ,w_old ,& +#if (defined CaMa_Flood) + flddepth ,fldfrc ,qinfl_fld ,& +#endif + forc_us ,forc_vs ,& + +! SNICAR model variables + forc_aer ,& + mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& + mss_dst1 (lbsn:0) ,mss_dst2 (lbsn:0) ,mss_dst3 (lbsn:0) ,mss_dst4 (lbsn:0) ,& +! END SNICAR model variables +! irrigaiton + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ,& +! end irrigation + ! output + rsur ,rnof ,qinfl ,zwt ,& + wdsrf ,wa ,qcharge ,smp ,hk ) + + ! roof + !============================================================ + IF (snlr < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lbr = snlr + 1 ! lower bound of array + CALL snowcompaction (lbr,deltim,& + imeltr(lbr:0),fioldr(lbr:0),t_roofsno(lbr:0),& + wliq_roofsno(lbr:0),wice_roofsno(lbr:0),forc_us,forc_vs,dz_roofsno(lbr:0)) + + ! Combine thin snow elements + lbr = maxsnl + 1 + CALL snowlayerscombine (lbr,snlr,& + z_roofsno(lbr:1),dz_roofsno(lbr:1),zi_roofsno(lbr-1:1),& + wliq_roofsno(lbr:1),wice_roofsno(lbr:1),t_roofsno(lbr:1),& + scv_roof,snowdp_roof) + + ! Divide thick snow elements + IF (snlr < 0) & + CALL snowlayersdivide (lbr,snlr,& + z_roofsno(lbr:0),dz_roofsno(lbr:0),zi_roofsno(lbr-1:0),& + wliq_roofsno(lbr:0),wice_roofsno(lbr:0),t_roofsno(lbr:0)) + ENDIF + + ! Set zero to the empty node + IF (snlr > maxsnl) THEN + wice_roofsno(maxsnl+1:snlr) = 0. + wliq_roofsno(maxsnl+1:snlr) = 0. + t_roofsno (maxsnl+1:snlr) = 0. + z_roofsno (maxsnl+1:snlr) = 0. + dz_roofsno (maxsnl+1:snlr) = 0. + ENDIF + + lbr = snlr + 1 + troof = t_roofsno(lbr) + + ! impervious ground + !============================================================ + IF (snli < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lbi = snli + 1 ! lower bound of array + CALL snowcompaction (lbi,deltim,& + imelti(lbi:0),fioldi(lbi:0),t_gimpsno(lbi:0),& + wliq_gimpsno(lbi:0),wice_gimpsno(lbi:0),forc_us,forc_vs,dz_gimpsno(lbi:0)) + + ! Combine thin snow elements + lbi = maxsnl + 1 + CALL snowlayerscombine (lbi,snli,& + z_gimpsno(lbi:1),dz_gimpsno(lbi:1),zi_gimpsno(lbi-1:1),& + wliq_gimpsno(lbi:1),wice_gimpsno(lbi:1),t_gimpsno(lbi:1),& + scv_gimp,snowdp_gimp) + + ! Divide thick snow elements + IF (snli < 0) & + CALL snowlayersdivide (lbi,snli,& + z_gimpsno(lbi:0),dz_gimpsno(lbi:0),zi_gimpsno(lbi-1:0),& + wliq_gimpsno(lbi:0),wice_gimpsno(lbi:0),t_gimpsno(lbi:0)) + ENDIF + + ! Set zero to the empty node + IF (snli > maxsnl) THEN + wice_gimpsno(maxsnl+1:snli) = 0. + wliq_gimpsno(maxsnl+1:snli) = 0. + t_gimpsno (maxsnl+1:snli) = 0. + z_gimpsno (maxsnl+1:snli) = 0. + dz_gimpsno (maxsnl+1:snli) = 0. + ENDIF + + lbi = snli + 1 + tgimp = t_gimpsno(lbi) + + ! pervious ground + !============================================================ + IF (snlp < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lbp = snlp + 1 ! lower bound of array + CALL snowcompaction (lbp,deltim,& + imeltp(lbp:0),fioldp(lbp:0),t_gpersno(lbp:0),& + wliq_gpersno(lbp:0),wice_gpersno(lbp:0),forc_us,forc_vs,dz_gpersno(lbp:0)) + + ! Combine thin snow elements + lbp = maxsnl + 1 + CALL snowlayerscombine (lbp,snlp,& + z_gpersno(lbp:1),dz_gpersno(lbp:1),zi_gpersno(lbp-1:1),& + wliq_gpersno(lbp:1),wice_gpersno(lbp:1),t_gpersno(lbp:1),& + scv_gper,snowdp_gper) + + ! Divide thick snow elements + IF (snlp < 0) & + CALL snowlayersdivide (lbp,snlp,& + z_gpersno(lbp:0),dz_gpersno(lbp:0),zi_gpersno(lbp-1:0),& + wliq_gpersno(lbp:0),wice_gpersno(lbp:0),t_gpersno(lbp:0)) + ENDIF + + ! Set zero to the empty node + IF (snlp > maxsnl) THEN + wice_gpersno(maxsnl+1:snlp) = 0. + wliq_gpersno(maxsnl+1:snlp) = 0. + t_gpersno (maxsnl+1:snlp) = 0. + z_gpersno (maxsnl+1:snlp) = 0. + dz_gpersno (maxsnl+1:snlp) = 0. + ENDIF + + lbp = snlp + 1 + tgper = t_gpersno(lbp) + + !TODO: temporal, set to t_soisno + t_soisno(:) = t_gpersno(:) + + !TODO: how to set tlake + lbl = snll + 1 + IF (lbl < 1) THEN + tlake = t_lakesno(lbl) + ELSE + tlake = t_lake(1) + ENDIF + + ! ---------------------------------------- + ! energy balance check + ! ---------------------------------------- + zerr=errore +#if (defined CoLMDEBUG) + IF(abs(errore)>.5)THEN + write(6,*) 'Warning: energy balance violation ',errore,patchclass + ENDIF +#endif + + ! ---------------------------------------- + ! water balance check + ! ---------------------------------------- + + wliq_soisno(: ) = 0. + wliq_soisno(:1) = wliq_roofsno(:1)*froof + wliq_soisno(: ) = wliq_soisno(: ) + wliq_gpersno(: )*(1-froof)*fgper + wliq_soisno(:1) = wliq_soisno(:1) + wliq_gimpsno(:1)*(1-froof)*(1-fgper) + !wliq_soisno(:) = wliq_soisno(:)*(1-flake) + wliq_lakesno(:)*flake + + wice_soisno(: ) = 0. + wice_soisno(:1) = wice_roofsno(:1)*froof + wice_soisno(: ) = wice_soisno(: ) + wice_gpersno(: )*(1-froof)*fgper + wice_soisno(:1) = wice_soisno(:1) + wice_gimpsno(:1)*(1-froof)*(1-fgper) + !wice_soisno(:) = wice_soisno(:)*(1-flake) + wice_lakesno(:)*flake + + scv = scv_roof*froof + scv_gper*(1-froof)*fgper + scv_gimp*(1-froof)*(1-fgper) + !scv = scv*(1-flake) + scv_lake*flake + + endwb = sum(wice_soisno(1:) + wliq_soisno(1:)) + endwb = endwb + scv + ldew*fveg + wa*(1-froof)*fgper + errorw = (endwb - totwb) - (forc_prc + forc_prl + urb_irrig - fevpa - rnof)*deltim + xerr = errorw/deltim + +#if (defined CoLMDEBUG) + IF(abs(errorw)>1.e-3) THEN + write(6,*) 'Warning: water balance violation', errorw, ipatch, patchclass + !STOP + ENDIF +#endif + +!====================================================================== +! Preparation for the next time step +! 1) time-varying parameters for vegetation +! 2) fraction of snow cover +! 3) solar zenith angle and +! 4) albedos +!====================================================================== + + ! cosine of solar zenith angle + calday = calendarday(idate) + coszen = orb_coszen(calday,patchlonr,patchlatr) + + ! fraction of snow cover. + CALL snowfraction ( 0., 0.,z0m,zlnd,scv_lake,snowdp_lake,wt,sigf,fsno_lake) + CALL snowfraction ( 0., 0.,z0m,zlnd,scv_roof,snowdp_roof,wt,sigf,fsno_roof) + CALL snowfraction ( 0., 0.,z0m,zlnd,scv_gimp,snowdp_gimp,wt,sigf,fsno_gimp) + CALL snowfraction (lai,sai,z0m,zlnd,scv_gper,snowdp_gper,wt,sigf,fsno_gper) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + ! update the snow age + !TODO: can be moved to UrbanALBEDO.F90 + IF (snlr == 0) sag_roof = 0. + CALL snowage (deltim,troof,scv_roof,scvold_roof,sag_roof) + IF (snli == 0) sag_gimp = 0. + CALL snowage (deltim,tgimp,scv_gimp,scvold_gimp,sag_gimp) + IF (snlp == 0) sag_gper = 0. + CALL snowage (deltim,tgper,scv_gper,scvold_gper,sag_gper) + IF (snll == 0) sag_lake = 0. + CALL snowage (deltim,tlake,scv_lake,scvold_lake,sag_lake) + + ! update snow depth, snow cover and snow age + snowdp = snowdp_roof*froof + snowdp_gper*(1-froof)*fgper + snowdp_gimp*(1-froof)*(1-fgper) + fsno = fsno_roof*froof + fsno_gper*(1-froof)*fgper + fsno_gimp*(1-froof)*(1-fgper) + sag = sag_roof*froof + sag_gper*(1-froof)*fgper + sag_gimp*(1-froof)*(1-fgper) + + ! albedos + ! we supposed call it every time-step, because + ! other vegetation related parameters are needed to create + + CALL alburban (ipatch,froof,fgper,flake,hlr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,(htop+hbot)/2.,lai,sai,fwet_snow,coszen,fwsun,tlake,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,& + sag_roof,sag_gimp,sag_gper,sag_lake,& + dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + + ! zero-filling set for glacier/ice-sheet/land water bodies/ocean components + laisun = lai + laisha = 0.0 + green = 1. + + h2osoi = wliq_soisno(1:)/(dz_soi(1:)*denh2o) + wice_soisno(1:)/(dz_soi(1:)*denice) + wat = sum(wice_soisno(1:)+wliq_soisno(1:)) + wat = wat + scv + ldew*fveg + wa*(1-froof)*fgper + + z_sno_roof (maxsnl+1:0) = z_roofsno (maxsnl+1:0) + z_sno_gimp (maxsnl+1:0) = z_gimpsno (maxsnl+1:0) + z_sno_gper (maxsnl+1:0) = z_gpersno (maxsnl+1:0) + z_sno_lake (maxsnl+1:0) = z_lakesno (maxsnl+1:0) + + dz_sno_roof(maxsnl+1:0) = dz_roofsno(maxsnl+1:0) + dz_sno_gimp(maxsnl+1:0) = dz_gimpsno(maxsnl+1:0) + dz_sno_gper(maxsnl+1:0) = dz_gpersno(maxsnl+1:0) + dz_sno_lake(maxsnl+1:0) = dz_lakesno(maxsnl+1:0) + + z_sno(:) = z_sno_roof(:)*froof + z_sno(:) = z_sno(:) + z_sno_gper(:)*(1-froof)*fgper + z_sno(:) = z_sno(:) + z_sno_gimp(:)*(1-froof)*(1-fgper) + z_sno(:) = z_sno(:)*(1-flake) + z_sno_lake(:)*flake + + dz_sno(:) = dz_sno_roof(:)*froof + dz_sno(:) = dz_sno(:) + dz_sno_gper(:)*(1-froof)*fgper + dz_sno(:) = dz_sno(:) + dz_sno_gimp(:)*(1-froof)*(1-fgper) + dz_sno(:) = dz_sno(:)*(1-flake) + dz_sno_lake(:)*flake + +! diagnostic diurnal temperature + !IF (tref > tmax) tmax = tref + !IF (tref < tmin) tmin = tref + +! 06/05/2022, yuan: RH for output to compare + CALL qsadv(tref,forc_psrf,ei,deiDT,qsatl,qsatlDT) + qref = qref/qsatl + +END SUBROUTINE CoLMMAIN_Urban +! ---------------------------------------------------------------------- +! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 new file mode 100644 index 0000000000..07d568478e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 @@ -0,0 +1,371 @@ +#include + +MODULE MOD_Urban_Albedo +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Calculate the total urban albedo. Prepare albedo values over water, +! roof, ground with snow cover. Then CALL 3D urban radiation transfer +! model. Finally calculate the total albedo weighted by the urban and +! water fractional cover. +! +! Created by Hua Yuan, 09/2021 +! +! +! !REVISIONS: +! +! 07/2023, Hua Yuan: Fix low zenith angle problem for urban radiation +! calculation and urban display height problem when +! considering vegetations. modify limitation for conzen value +! (0.001->0.01) for urban. +! +! 05/2024, Hua Yuan: Account for vegetation snow optical properties. +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: alburban + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE alburban (ipatch,froof,fgper,flake,hlr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,hveg,lai,sai,fwet_snow,coszen,fwsun,tlake,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,& + sag_roof,sag_gimp,sag_gper,sag_lake,& + dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + +!======================================================================= +! Calculates fragmented albedos (direct and diffuse) for urban area in +! wavelength regions split at 0.7um. +! +! (1) snow albedos: as in BATS formulations, which are inferred from +! the calculations of Wiscombe and Warren (1980) and the snow model +! and data of Anderson(1976), and the function of snow age, grain +! size, solar zenith angle, pollution, the amount of the fresh snow +! (2) lake and wetland albedos: as in BATS, which depend on cosine solar +! zenith angle, based on data in Henderson-Sellers (1986). The +! frozen lake and wetland albedos are set to constants (0.6 for +! visible beam, 0.4 for near-infrared) +! (3) over the snow covered surface, the surface albedo is estimated by +! a linear combination of albedos for snow, roof, impervious and +! pervious ground +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_VEG_SNOW + USE MOD_Urban_Shortwave + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- +! ground cover index + integer, intent(in) :: & + ipatch ! patch index + + real(r8), intent(in) :: & + froof, &! roof fraction + fgper, &! impervious ground weight fraction + flake, &! lake fraction + hlr, &! average building height to their side length + hroof ! average building height + + real(r8), intent(in) :: & + alb_roof(2,2), &! roof albedo (iband,direct/diffuse) + alb_wall(2,2), &! wall albedo (iband,direct/diffuse) + alb_gimp(2,2), &! impervious albedo (iband,direct/diffuse) + alb_gper(2,2) ! pervious albedo (iband,direct/diffuse) + + real(r8), intent(in) :: & + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + hveg, &! vegetation central crown height [m] + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + fwet_snow, &! vegetation snow fractional cover [-] + + ! variables + coszen, &! cosine of solar zenith angle [-] + fwsun, &! sunlit wall fraction [-] + tlake, &! lake surface temperature [K] + fsno_roof, &! fraction of soil covered by snow [-] + fsno_gimp, &! fraction of soil covered by snow [-] + fsno_gper, &! fraction of soil covered by snow [-] + fsno_lake, &! fraction of soil covered by snow [-] + scv_roof, &! snow cover, water equivalent [mm] + scv_gimp, &! snow cover, water equivalent [mm] + scv_gper, &! snow cover, water equivalent [mm] + scv_lake, &! snow cover, water equivalent [mm] + sag_roof, &! non dimensional snow age [-] + sag_gimp, &! non dimensional snow age [-] + sag_gper, &! non dimensional snow age [-] + sag_lake ! non dimensional snow age [-] + + real(r8), intent(out) :: & + dfwsun, &! change of fwsun + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + alb (2,2), &! averaged albedo [-] + ssun (2,2), &! sunlit canopy absorption for solar radiation + ssha (2,2), &! shaded canopy absorption for solar radiation, + sroof(2,2), &! roof absorption for solar radiation, + swsun(2,2), &! sunlit wall absorption for solar radiation, + swsha(2,2), &! shaded wall absorption for solar radiation, + sgimp(2,2), &! impervious ground absorption for solar radiation, + sgper(2,2), &! pervious ground absorption for solar radiation, + slake(2,2) ! lake absorption for solar radiation, + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary varaiable [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + theta, &! solar zenith angle + fwsun_, &! sunlit wall fraction + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse visible solar radiation [-] + dralbl, &! snow albedo for visible radiation [-] + dralbs, &! snow albedo for near infrared radiation [-] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1 ! alb for NIR, incident on new snow (zen angle<60) [-] + + real(r8) :: & + erho(2), &! effective reflection of leaf+stem + etau(2), &! effective transmittance of leaf+stem + albsno (2,2), &! snow albedo [-] + albroof(2,2), &! albedo, ground + albgimp(2,2), &! albedo, ground + albgper(2,2), &! albedo, ground + alblake(2,2) ! albedo, ground + + ! vegetation snow optical properties, 1:vis, 2:nir + real(r8) :: rho_sno(2), tau_sno(2) + data rho_sno(1), rho_sno(2) /0.5, 0.2/ + data tau_sno(1), tau_sno(2) /0.3, 0.2/ + +! ---------------------------------------------------------------------- +! 1. Initial set +! ---------------------------------------------------------------------- + +! short and long wave albedo for new snow + snal0 = 0.85 ! shortwave + snal1 = 0.65 ! long wave + +! ---------------------------------------------------------------------- +! set default soil and vegetation albedos and solar absorption + alb (:,:) = 1. ! averaged + ssun (:,:) = 0. + ssha (:,:) = 0. + sroof (:,:) = 0. + swsun (:,:) = 0. + swsha (:,:) = 0. + sgimp (:,:) = 0. + sgper (:,:) = 0. + alblake (:,:) = 1. + slake (:,:) = 0. + + dfwsun = 0. + extkd = 0.718 + + IF(coszen <= -0.3) THEN + !print *, "coszen < 0, ipatch and coszen: ", ipatch, coszen + RETURN !only do albedo when coszen > -0.3 + ENDIF + + czen = max(coszen, 0.01) + albsno(:,:) = 0. !set initial snow albedo + cons = 0.2 !parameter for snow albedo + conn = 0.5 !parameter for snow albedo + sl = 2.0 !sl helps control albedo zenith dependence + + ! effective leaf optical properties: rho and tau. + IF (lai+sai>1.e-6 .and. fveg>0.) THEN + erho(:) = rho(:,1)*lai/(lai+sai) + rho(:,2)*sai/(lai+sai) + etau(:) = tau(:,1)*lai/(lai+sai) + tau(:,2)*sai/(lai+sai) + ENDIF + + ! correct for snow on leaf + IF ( DEF_VEG_SNOW ) THEN + ! modify rho, tau, USE: fwet_snow + erho(:) = (1-fwet_snow)*erho(:) + fwet_snow*rho_sno(:) + etau(:) = (1-fwet_snow)*etau(:) + fwet_snow*tau_sno(:) + ENDIF + +! ---------------------------------------------------------------------- +! 2. get albedo over water, roof, ground +! ---------------------------------------------------------------------- + +! 2.1 albedo for inland water (NOTE: wetland is removed) + albg0 = 0.05/(czen+0.15) + alblake(:,1) = albg0 + alblake(:,2) = 0.1 !Subin (2012) + + IF (tlake < tfrz) THEN !frozen lake and wetland + alblake(1,:) = 0.6 + alblake(2,:) = 0.4 + ENDIF + + IF (scv_lake > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_lake) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + alblake(:,:) = (1.-fsno_lake)*alblake(:,:) + fsno_lake*albsno(:,:) + slake(:,:) = 1. - alblake(:,:) + +! 2.2 roof albedo with snow + IF (scv_roof > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_roof) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + albroof(:,:) = (1.-fsno_roof)*alb_roof(:,:) + fsno_roof*albsno(:,:) + +! 2.3 impervious ground albedo with snow + IF (scv_gimp > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_gimp) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + albgimp(:,:) = (1.-fsno_gimp)*alb_gimp(:,:) + fsno_gimp*albsno(:,:) + +! 2.4 pervious ground albedo with snow + IF (scv_gper > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_gper) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + albgper(:,:) = (1.-fsno_gper)*alb_gper(:,:) + fsno_gper*albsno(:,:) + +! ---------------------------------------------------------------------- +! 3. Urban albedo +! ---------------------------------------------------------------------- + + theta = acos(czen) + + ! Distinguish between no-vegetation and vegetation-included cases + IF (lai+sai>1.e-6 .and. fveg>0.) THEN + + CALL UrbanVegShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(1,1), alb_wall(1,1), albgimp(1,1), albgper(1,1), & + lai, sai, fveg, hveg, erho(1), etau(1), & + fwsun_, sroof(1,:), swsun(1,:), swsha(1,:), sgimp(1,:), & + sgper(1,:), ssun(1,:), alb(1,:)) + + CALL UrbanVegShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(2,1), alb_wall(2,1), albgimp(2,1), albgper(2,1), & + lai, sai, fveg, hveg, erho(2), etau(2), & + fwsun_, sroof(2,:), swsun(2,:), swsha(2,:), sgimp(2,:), & + sgper(2,:), ssun(2,:), alb(2,:)) + ELSE + + CALL UrbanOnlyShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(1,1), alb_wall(1,1), albgimp(1,1), albgper(1,1), & + fwsun_, sroof(1,:), swsun(1,:), swsha(1,:), sgimp(1,:), & + sgper(1,:), alb(1,:)) + + CALL UrbanOnlyShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(2,1), alb_wall(2,1), albgimp(2,1), albgper(2,1), & + fwsun_, sroof(2,:), swsun(2,:), swsha(2,:), sgimp(2,:), & + sgper(2,:), alb(2,:)) + + ssun(:,:) = 0. + ENDIF + + dfwsun = fwsun_ - fwsun + + alb(:,:) = (1.-flake)*alb(:,:) + flake*alblake(:,:) + + END SUBROUTINE alburban + +END MODULE MOD_Urban_Albedo +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 new file mode 100644 index 0000000000..7b817c1bfa --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 @@ -0,0 +1,256 @@ +#include + +MODULE MOD_Urban_BEM + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Urban_Shortwave, only: MatrixInverse + + IMPLICIT NONE + SAVE + PRIVATE + + ! A simple building energy model to calculate room temperature + PUBLIC :: SimpleBEM + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE SimpleBEM (deltim, rhoair, fcover, H, troom_max, troom_min, & + troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & + troof_nl, twsun_nl, twsha_nl, & + tkdz_roof, tkdz_wsun, tkdz_wsha, taf, & + troom, troof_inner, twsun_inner, twsha_inner, & + Fhac, Fwst, Fach, Fhah) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! A simple building energy model to calculate room temperature +! +! The basic approach is as follows: +! +! 1. Predict indoor temperature using the indoor energy balance +! equations (see below) without turning on the air conditioning. +! +! 2. If the indoor temperature falls within the predefined comfort +! range, further energy consumption calculations are not necessary, +! only indoor and outdoor heat exchange is considered. +! +! 3. If the indoor temperature falls outside the predefined comfort +! range, calculate the minimum/maximum heating/cooling capacity +! based on the air conditioning usage strategy. +! +! 4. Calculate the indoor and outdoor heat exchange and waste heat +! discharge (taking into account energy utilization efficiency) +! based on the calculated heating/cooling capacity in step 3. +! +! Finally, energy consumption can be calculated based on the total +! heat flux. +! +! o Solve the following energy balance equations +! o Variables: troom, troof_inner, twsun_inner, twsha_innter +! +! Hc_roof = Fn_roof .................................(1) +! Hc_wsun = Fn_wsun .................................(2) +! Hc_wsha = Fn_wsha .................................(3) +! +! Troom' - Troom +! H*rhoair*cpair*-------------- = +! dt +! ACH +! ------*H*rhoair*cpair*(Taf-Troom') + Hc_roof + Hc_wsun + Hc_wsha +! 3600 +! .................................(4) +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +! 11/2022, Hua Yuan: Add option for constant AC. +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + rhoair, &! density air [kg/m3] + fcover(0:2), &! fractional cover of roof, wall + H, &! average building height [m] + troom_max, &! maximum temperature of inner building + troom_min, &! minimum temperature of inner building + troof_nl_bef, &! roof temperature at layer nl_roof + twsun_nl_bef, &! sunlit wall temperature at layer nl_wall + twsha_nl_bef, &! shaded wall temperature at layer nl_wall + troof_nl, &! roof temperature at layer nl_roof + twsun_nl, &! sunlit wall temperature at layer nl_wall + twsha_nl, &! shaded wall temperature at layer nl_wall + tkdz_roof, &! temporal var for heat transfer of roof + tkdz_wsun, &! temporal var for heat transfer of sunlit wall + tkdz_wsha, &! temporal var for heat transfer of shaded wall + taf ! temperature of urban air + + real(r8), intent(inout) :: & + troom, &! temperature of inner building + troof_inner, &! temperature of inner roof + twsun_inner, &! temperature of inner sunlit wall + twsha_inner ! temperature of inner shaded wall + + real(r8), intent(out) :: & + Fhah, &! flux from heating + Fhac, &! flux from heat or cool AC + Fwst, &! waste heat from cool or heat + Fach ! flux from air exchange + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + ACH, &! air exchange coefficient + hcv_roof, &! convective exchange coefficient for roof<->room + hcv_wall, &! convective exchange coefficient for wall<->room + waste_coef, &! waste coefficient + waste_cool, &! waste heat for AC cooling + waste_heat ! waste heat for AC heating + + real(r8) :: & + f_wsun, &! weight factor for sunlit wall + f_wsha ! weight factor for shaded wall + + real(r8) :: & + A(4,4), &! Heat transfer matrix + Ainv(4,4), &! Inverse of Heat transfer matrix + B(4), &! B for Ax=B + X(4) ! x for Ax=B + + real(r8) :: & + troom_pro, &! projected room temperature + troom_bef, &! temperature of inner building + troof_inner_bef, &! temperature of inner roof + twsun_inner_bef, &! temperature of inner sunlit wall + twsha_inner_bef ! temperature of inner shaded wall + + logical :: cooling, heating + + ! Option for continuous AC + logical, parameter :: Constant_AC = .true. + +!----------------------------------------------------------------------- + + ACH = 0.3 !air exchange coefficient + hcv_roof = 4.040 !convective exchange coefficient for roof<->room (W m-2 K-1) + hcv_wall = 3.076 !convective exchange coefficient for wall<->room (W m-2 K-1) + waste_cool = 0.6 !waste heat for AC cooling + waste_heat = 0.2 !waste heat for AC heating + cooling = .false. !cooling case + heating = .false. !heating case + + f_wsun = fcover(1)/fcover(0) !weight factor for sunlit wall + f_wsha = fcover(2)/fcover(0) !weight factor for shaded wall + + ! initialization + Fhac = 0.; Fwst = 0.; Fach = 0.; Fhah = 0.; + + ! Ax = B + ! set values for heat transfer matrix + ! 1: roof, 2: sunlit wall, 3: shaded wall, 4: room + A(:,:) = 0. + A(1,:) = (/0.5*hcv_roof+0.5*tkdz_roof, 0., 0., -0.5*hcv_roof/) + A(2,:) = (/0., 0.5*hcv_wall+0.5*tkdz_wsun, 0., -0.5*hcv_wall/) + A(3,:) = (/0., 0., 0.5*hcv_wall+0.5*tkdz_wsha, -0.5*hcv_wall/) + + A(4,:) = (/-0.5*hcv_roof, -0.5*hcv_wall*f_wsun, -0.5*hcv_wall*f_wsha, & + 0.5*hcv_roof + 0.5*hcv_wall*f_wsun + 0.5*hcv_wall*f_wsha +& + H*rhoair*cpair/deltim + (ACH/3600.)*H*rhoair*cpair /) + + B(1) = -0.5*hcv_roof*(troof_inner-troom) + 0.5*tkdz_roof*(troof_nl_bef-troof_inner) & + + 0.5*tkdz_roof*troof_nl + B(2) = -0.5*hcv_wall*(twsun_inner-troom) + 0.5*tkdz_wsun*(twsun_nl_bef-twsun_inner) & + + 0.5*tkdz_wsun*twsun_nl + B(3) = -0.5*hcv_wall*(twsha_inner-troom) + 0.5*tkdz_wsha*(twsha_nl_bef-twsha_inner) & + + 0.5*tkdz_wsha*twsha_nl + + B(4) = H*rhoair*cpair*troom/deltim + (ACH/3600.)*H*rhoair*cpair*taf & + + 0.5*hcv_roof*(troof_inner-troom) & + + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun & + + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Matrix computing to resolve multiple reflections + X = matmul(Ainv, B) + + troof_inner_bef = troof_inner + twsun_inner_bef = twsun_inner + twsha_inner_bef = twsha_inner + troom_bef = troom + + troof_inner = X(1) + twsun_inner = X(2) + twsha_inner = X(3) + troom = X(4) + troom_pro = X(4) + + Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) + + IF (troom > troom_max) THEN !cooling case + Fhac = H*rhoair*cpair*(troom-troom_max)/deltim + troom = troom_max + Fwst = Fhac*waste_cool + ENDIF + + IF (troom < troom_min) THEN !heating case + Fhac = H*rhoair*cpair*(troom-troom_min)/deltim + troom = troom_min + Fwst = abs(Fhac)*waste_heat + ! negative value, set it to 0. + Fhac = 0. + ENDIF + + ! for constant cooling or heating + IF ((troom_pro>troom_max .or. troom_pro troom_max) THEN !cooling case + troom = troom_max + waste_coef = waste_cool + cooling = .true. + ENDIF + + IF (troom_pro < troom_min) THEN !heating case + troom = troom_min + waste_coef = waste_heat + heating = .true. + ENDIF + + Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) + + troof_inner = (B(1)-A(1,4)*troom)/A(1,1) + twsun_inner = (B(2)-A(2,4)*troom)/A(2,2) + twsha_inner = (B(3)-A(3,4)*troom)/A(3,3) + + Fhac = 0.5*hcv_roof*(troof_inner_bef-troom_bef) & + + 0.5*hcv_roof*(troof_inner-troom) + Fhac = 0.5*hcv_wall*(twsun_inner_bef-troom_bef)*f_wsun & + + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun + Fhac + Fhac = 0.5*hcv_wall*(twsha_inner_bef-troom_bef)*f_wsha & + + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + Fhac + + IF ( heating ) Fhah = abs(Fhac) + Fhac = abs(Fhac) + abs(Fach) + Fwst = Fhac*waste_coef + IF ( heating ) Fhac = 0. + + ENDIF + + Fhah = Fhah*fcover(0) + Fach = Fach*fcover(0) + Fwst = Fwst*fcover(0) + Fhac = Fhac*fcover(0) + + END SUBROUTINE SimpleBEM + +END MODULE MOD_Urban_BEM +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 new file mode 100644 index 0000000000..0504664be4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 @@ -0,0 +1,125 @@ +#include +MODULE MOD_Urban_Const_LCZ + +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! look-up-table for LCZ morphology and thermal parameters +! - NOTE - +! Each city may have different values for the parameters in this table. +! The default values may not suit any specific city. +! Users could adjust these values based on the city they are working with. +! +! Created by Wenzong Dong, Jun, 2022 +! +! !REFERENCES: +! 1) Stewart, I. D., Oke, T. R., & Krayenhoff, E. S. (2014). Evaluation of +! the 'local climate zone' scheme using temperature observations and model +! simulations. International Journal of Climatology, 34(4), 1062-1080. +! https://doi.org/10.1002/joc.3746 +! +! 2) The URBPARM_LCZ.TBL of WRF, https://github.com/wrf-model/WRF/ +! +! ----------------------------------------------------------------------- +! !USE + USE MOD_Precision + + IMPLICIT NONE + SAVE + + ! roof fraction [-] + real(r8), parameter, dimension(10) :: wtroof_lcz & + = (/0.5 , 0.5 , 0.55, 0.3 , 0.3, 0.3, 0.8 , 0.4 , 0.15, 0.25/) + + ! pervious fraction [-] + real(r8), parameter, dimension(10) :: fgper_lcz & + = (/0.05, 0.1 , 0.15, 0.35, 0.3, 0.4, 0.15, 0.15, 0.7 , 0.45/) + + ! height of roof [m] + real(r8), parameter, dimension(10) :: htroof_lcz & + = (/45., 15. , 5. , 40., 15., 5. , 3. , 7. , 5. , 8.5 /) + + ! H/W [-] + real(r8), parameter, dimension(10) :: hwrbld_lcz & + = (/2.5, 1.25, 1.25, 1. , 0.5, 0.5, 1.5, 0.2, 0.15, 0.35/) + + ! thickness of roof [m] + real(r8), parameter, dimension(10) :: thkroof_lcz & + = (/0.3 , 0.3 , 0.2 , 0.3 , 0.25, 0.15, 0.05, 0.12, 0.15, 0.05/) + + ! thickness of wall [m] + real(r8), parameter, dimension(10) :: thkwall_lcz & + = (/0.3 , 0.25, 0.2 , 0.2 , 0.2 , 0.2 , 0.1 , 0.2 , 0.2 , 0.05/) + + ! thickness of impervious road [m] + real(r8), parameter, dimension(10) :: thkgimp_lcz & + = (/0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/) + + ! albedo of roof [-] + real(r8), parameter, dimension(10) :: albroof_lcz & + = (/0.13, 0.18, 0.15, 0.13, 0.13, 0.13, 0.15, 0.18, 0.13, 0.1 /) + + ! albedo of wall [-] + real(r8), parameter, dimension(10) :: albwall_lcz & + = (/0.25, 0.2 , 0.2 , 0.25, 0.25, 0.25, 0.2 , 0.25, 0.25, 0.2 /) + + ! albedo of impervious road [-] + real(r8), parameter, dimension(10) :: albgimp_lcz & + = (/0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.18, 0.14, 0.14, 0.14/) + + ! albedo of pervious road [-] + real(r8), parameter, dimension(10) :: albgper_lcz & + = (/0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15/) + + ! emissivity of roof [-] + real(r8), parameter, dimension(10) :: emroof_lcz & + = (/0.91, 0.91, 0.91, 0.91, 0.91, 0.91, 0.28, 0.91, 0.91, 0.91/) + + ! emissivity of wall [-] + real(r8), parameter, dimension(10) :: emwall_lcz & + = (/0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90/) + + ! emissivity of road [-] + real(r8), parameter, dimension(10) :: emgimp_lcz & + = (/0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.92, 0.95, 0.95, 0.95/) + + ! emissivity of impervious road [-] + real(r8), parameter, dimension(10) :: emgper_lcz & + = (/0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95/) + + + ! volumetric heat capacity of roof [J/m3*K] + real(r8), parameter, dimension(10) :: cvroof_lcz & + = (/1.8E6 , 1.8E6 , 1.44E6, 1.8E6 , 1.8E6 , 1.44E6, 2.0E6 , 1.8E6 , 1.44E6, 2.0E6 /) + + ! volumetric heat capacity of wall [J/m3*K] + real(r8), parameter, dimension(10) :: cvwall_lcz & + = (/1.8E6 , 2.67E6, 2.05E6, 2.0E6 , 2.0E6 , 2.05E6, 0.72E6, 1.8E6 , 2.56E6, 1.69E6/) + + ! volumetric heat capacity of impervious road [J/m3*K] + real(r8), parameter, dimension(10) :: cvgimp_lcz & + = (/1.75E6, 1.68E6, 1.63E6, 1.54E6, 1.50E6, 1.47E6, 1.67E6, 1.38E6, 1.37E6, 1.49E6/) + + + ! thermal conductivity of roof [W/m*K] + real(r8), parameter, dimension(10) :: tkroof_lcz & + = (/1.25, 1.25, 1.00, 1.25, 1.25, 1.00, 2.0 , 1.25, 1.00, 2.00/) + + ! thermal conductivity of wall [W/m*K] + real(r8), parameter, dimension(10) :: tkwall_lcz & + = (/1.09, 1.5 , 1.25, 1.45, 1.45, 1.25, 0.5 , 1.25, 1.00, 1.33/) + + ! thermal conductivity of impervious road [W/m*K] + real(r8), parameter, dimension(10) :: tkgimp_lcz & + = (/0.77, 0.73, 0.69, 0.64, 0.62, 0.60, 0.72, 0.51, 0.55, 0.61/) + + !TODO:AHE coding + ! maximum temperature of inner room [K] + real(r8), parameter, dimension(10) :: tbldmax_lcz & + = (/297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65/) + + ! minimum temperature of inner room [K] + real(r8), parameter, dimension(10) :: tbldmin_lcz & + = (/290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65/) + +END MODULE MOD_Urban_Const_LCZ +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 new file mode 100644 index 0000000000..c8e307d36d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 @@ -0,0 +1,2644 @@ +#include + +MODULE MOD_Urban_Flux + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The process of urban turbulence exchange is similar to the plant +! community (3D canopy) turbulence exchange. The sensible and latent +! heat exchange of roofs, walls (shaded and sunny sides), ground, and +! vegetation is calculated based on the M-O similarity theory +! similarity. However, the differences lie in the roughness, frontal +! area index, zero-plane displacement height, wind speed/turbulence +! exchange coefficient decay rate, and calculation of boundary layer +! resistance for building surfaces and vegetation. Each layer +! (equivalent height) conservation equation for flux is established and +! solved simultaneously. +! +! The process of solving includes two situations: +! +! 1. not considering vegetation - Subroutine UrbanOnlyFlux() +! +! 2. considering vegetation - Subroutine UrbanVegFlux() +! +! Created by Hua Yuan, 09/2021 +! +! +! !REVISIONS: +! +! 10/2022, Hua Yuan: Add three options of decay coefficient for u and k. +! Add wet fraction for roof and impervious ground, set max +! ponding for roof and impervious from 10mm -> 1mm. +! +! 12/2022, Wenzong Dong: Traffic and metabolism heat flux are considered +! in turbulent flux exchange. +! +! 05/2024, Wenzong Dong: re-write the two- and three-layer flux exchange +! code in resistance style and make it consistant with the +! technical report. [better for incorporating rss and further +! developments] +! +! 05/2024, Hua Yuan: add option to account for vegetation snow process. +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_RSS_SCHEME, DEF_VEG_SNOW + USE MOD_Vars_Global + USE MOD_Qsadv, only: qsadv + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: UrbanOnlyFlux + PUBLIC :: UrbanVegFlux + PUBLIC :: dewfraction + + ! Exponential extinction factor (alpha) options: + ! 1. Masson, 2000; Oleson et al., 2008 + ! 2. Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 + ! 3. Macdonald, 2000 + integer, parameter :: alpha_opt = 3 + + ! Layer number setting, default is false, i.e., 2 layers + logical, parameter :: run_three_layer = .false. + + ! Percent of sensible/latent to AHE (only for Fhac, Fwst, vehc now), + ! 92% heat release as SH, 8% heat release as LH, Pigeon et al., 2007 + real(r8), parameter :: fsh = 0.92 + real(r8), parameter :: flh = 0.08 + + ! A simple urban irrigation scheme accounts for soil water stress of trees + logical, parameter :: DEF_URBAN_Irrigation = .true. + real(r8), parameter :: rstfac_irrig = 1. + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE UrbanOnlyFlux ( & + ! Model running information + ipatch ,deltim ,lbr ,lbi ,& + ! Forcing + hu ,ht ,hq ,us ,& + vs ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,Fhac ,& + Fwst ,Fach ,vehc ,meta ,& + ! Urban parameters + hroof ,hlr ,nurb ,fcover ,& + ! Status of surface + z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno ,wliq_gimpsno ,wice_roofsno ,wice_gimpsno ,& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,rss ,& + ! Output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + +!======================================================================= + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav,hvap + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch, &! patch index [-] + lbr, &! lower bound of array + lbi ! lower bound of array + + real(r8), intent(in) :: & + deltim ! seconds in a time step [second] + + ! atmospherical variables and observational height + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + thm, &! intermediate variable (tm+0.0098*ht) [K] + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at agcm reference height [kg/kg] + psrf, &! atmosphere pressure at the surface [pa] [not used] + rhoair ! density air [kg/m3] + + real(r8), intent(in) :: & + vehc, &! flux from vehicle [W/m2] + meta, &! flux from metabolic [W/m2] + Fhac, &! flux from heat or cool AC [W/m2] + Fwst, &! waste heat from cool or heat [W/m2] + Fach ! flux from air exchange [W/m2] + + integer, intent(in) :: & + nurb ! number of aboveground urban components [-] + + real(r8), intent(in) :: & + hroof, &! average building height [m] + hlr, &! average building height to their side length [-] + fcover(0:4) ! coverage of aboveground urban components [-] + + real(r8), intent(in) :: & + rss, &! bare soil resistance for evaporation [s/m] + z0h_g, &! roughness length for bare ground, sensible heat [m] + obug, &! monin-obukhov length for bare ground (m) + ustarg, &! friction velocity for bare ground [m/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno_roof, &! fraction of ground covered by snow [-] + fsno_gimp, &! fraction of ground covered by snow [-] + fsno_gper, &! fraction of ground covered by snow [-] + wliq_roofsno, &! liqui water [kg/m2] + wliq_gimpsno, &! liqui water [kg/m2] + wice_roofsno, &! ice lens [kg/m2] + wice_gimpsno, &! ice lens [kg/m2] + htvp_roof, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gimp, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gper, &! latent heat of vapor of water (or sublimation) [j/kg] + + troof, &! temperature of roof [K] + twsun, &! temperature of sunlit wall [K] + twsha, &! temperature of shaded wall [K] + tgimp, &! temperature of impervious road [K] + tgper, &! pervious ground temperature [K] + + qroof, &! roof specific humidity [kg/kg] + qgimp, &! imperivous road specific humidity [kg/kg] + qgper, &! pervious ground specific humidity [kg/kg] + dqroofdT, &! d(qroof)/dT + dqgimpdT, &! d(qgimp)/dT + dqgperdT ! d(qgper)/dT + + ! Output + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsenroof, &! sensible heat flux from roof [W/m2] + fsenwsun, &! sensible heat flux from sunlit wall [W/m2] + fsenwsha, &! sensible heat flux from shaded wall [W/m2] + fsengimp, &! sensible heat flux from impervious road [W/m2] + fsengper, &! sensible heat flux from pervious ground [W/m2] + fevproof, &! evaporation heat flux from roof [W/m2] + fevpgimp, &! evaporation heat flux from impervious road [W/m2] + fevpgper, &! evaporation heat flux from pervious ground [mm/s] + + croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + cwsuns, &! deriv of sunlit wall sensible heat flux wrt soil temp [w/m**2/k] + cwshas, &! deriv of shaded wall sensible heat flux wrt soil temp [w/m**2/k] + cgrnds, &! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] + croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + cgimpl, &! deriv of gimp latent heat flux wrt soil temp [w/m**2/k] + cgperl, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + croof, &! deriv of roof total heat flux wrt soil temp [w/m**2/k] + cgimp, &! deriv of gimp total heat flux wrt soil temp [w/m**2/k] + cgper, &! deriv of soil total heat flux wrt soil temp [w/m**2/k] + + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity [kg/kg] + + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq, &! integral of profile function for moisture + tafu ! effective urban air temperature (2nd layer, walls) + +!-------------------------- Local Variables ---------------------------- + integer :: & + niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0hg, &! roughness length over ground, sensible heat [m] + z0qg ! roughness length over ground, latent heat [m] + + real(r8) evplwet, evplwet_dtl, elwmax, elwdif + +!----------------------- definition for 3d run ------------------------- + + integer, parameter :: nlay = 3 ! potential layer number + + integer :: & + clev, &! current layer index + numlay ! available layer number + + real(r8) :: & + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + ktop, &! K value at a specific height + utop, &! u value at a specific height + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + fmtop, &! fm value at a specific height + phih, &! phi(h), similarity function for sensible heat + displa, &! displacement height for urban + displau, &! displacement height for urban building + z0mu, &! roughness length for urban building only + z0h, &! roughness length for sensible heat + z0q, &! roughness length for latent heat + tg, &! ground temperature + qg ! ground specific humidity + + real(r8) :: & + fg, &! ground fractional cover + fgimp, &! weight of impervious ground + fgper, &! weight of pervious ground + hwr, &! average building height to their distance [-] + sqrtdragc, &! sqrt(drag coefficient) + lm, &! mix length within canopy + fai, &! frontal area index + fwet, &! fractional wet area + delta, &! 0 or 1 + alpha ! exponential extinction factor for u/k decline within urban + + real(r8), dimension(0:nurb) :: & + tu, &! temperature array + fc, &! fractional cover array + canlev, &! urban canopy layer lookup table + rb, &! leaf boundary layer resistance [s/m] + cfh, &! heat conductance for leaf [m/s] + cfw, &! latent heat conductance for leaf [m/s] + wtl0, &! normalized heat conductance for air and leaf [-] + wtlq0, &! normalized latent heat cond. for air and leaf [-] + + ei, &! vapor pressure on leaf surface [pa] + deidT, &! derivative of "ei" on "tl" [pa/K] + qsatl, &! leaf specific humidity [kg/kg] + qsatldT ! derivative of "qsatl" on "tlef" + + real(r8), dimension(nlay) :: & + fah, &! weight for thermal resistance to upper layer + faw, &! weight for moisture resistance to upper layer + fgh, &! weight for thermal resistance to lower layer + fgw, &! weight for moisture resistance to lower layer + ueff_lay, &! effective wind speed within canopy layer [m/s] + ueff_lay_, &! effective wind speed within canopy layer [m/s] + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + rd, &! aerodynamic resistance between layers [s/m] + rd_, &! aerodynamic resistance between layers [s/m] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wta0, &! normalized heat conductance for air [-] + wtg0, &! normalized heat conductance for ground [-] + wtaq0, &! normalized latent heat conductance for air [-] + wtgq0, &! normalized heat conductance for ground [-] + wtll, &! sum of normalized heat conductance for air and leaf + wtlql ! sum of normalized heat conductance for air and leaf + + real(r8), dimension(nlay) :: & + Hahe ! anthropogenic heat emission (AHE) + + real(r8) :: & + ra2m, &! aerodynamic resistance between 2m and bottom layer [s/m] + rd2m ! aerodynamic resistance between bottom layer and ground [s/m] + + ! temporal + integer i + real(r8) tmpw3, cgw_per, cgw_imp + real(r8) bee, tmpw1, tmpw2, fact, facq + real(r8) aT, bT, cT + real(r8) aQ, bQ, cQ, Lahe + real(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_, rss_ + real(r8) fwetfac + +!----------------------------------------------------------------------- + +! initialization + tu(0) = troof; tu(1) = twsun; tu(2) = twsha + + fc(:) = fcover(0:nurb) + fg = 1 - fcover(0) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + !hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) + hwr = hlr*sqrt(fcover(0))/(1-sqrt(fcover(0))) + canlev = (/3, 2, 2/) + numlay = 2 + +!----------------------------------------------------------------------- +! initial roughness length for z0mg, z0hg, z0qg +! Roughness of the city ground only (excluding buildings and vegetation) +!----------------------------------------------------------------------- + + !NOTE: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gper > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg + +!----------------------------------------------------------------------- +! initial saturated vapor pressure and humidity and their derivation +! 0: roof, 1: sunlit wall, 2: shaded wall +!----------------------------------------------------------------------- + + qsatl(0) = qroof + qsatldT(0) = dqroofdT + DO i = 1, nurb + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + ENDDO + +!----------------------------------------------------------------------- +! tg, qg and wet fraction calculation +!----------------------------------------------------------------------- + + ! weighted tg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof_ = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof_ = min(1., fwet_roof_) + ENDIF + + ! impervious ground + IF (lbi < 1) THEN + fwet_gimp_ = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp_ = min(1., fwet_gimp_) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as pervious ground + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + +!----------------------------------------------------------------------- +! scaling factor bee +!----------------------------------------------------------------------- +!NOTE: bee value, the default is 1 + bee = 1. + +!----------------------------------------------------------------------- +! calculate z0m and displa +!----------------------------------------------------------------------- + + ! Macdonald et al., 1998, Eq. (23), A=4.43 + displau = hroof * (1 + 4.43**(-fcover(0))*(fcover(0) - 1)) + fai = 4/PI*hlr*fcover(0) + z0mu = (hroof - displau) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) + + ! to compare z0 of urban and only the surface + ! maximum assumption + IF (z0mu < z0mg) z0mu = z0mg + + ! roughness length and displacement height for sensible + ! and latent heat transfer + z0m = z0mu + + displa = displau + displau = max(hroof/2., displau) + +!----------------------------------------------------------------------- +! calculate layer decay coefficient +!----------------------------------------------------------------------- + + !NOTE: the below is for vegetation, may not be suitable for urban + ! Raupach, 1992 + !sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + + ! Kondo, 1971 + !alpha = hroof/(hroof-displa)/(vonkar/sqrtdragc) + + ! Masson, 2000; Oleson et al., 2008 + IF (alpha_opt == 1) alpha = 0.5*hwr + + ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 + IF (alpha_opt == 2) alpha = 0.772*hwr + + ! Macdonald, 2000 + IF (alpha_opt == 3) alpha = 9.6*fai + +!----------------------------------------------------------------------- +! first guess for taf and qaf for each layer +! a large difference from previous schemes +!----------------------------------------------------------------------- + + IF (numlay .eq. 2) THEN + taf(3) = (tg + 2.*thm)/3. + qaf(3) = (qg + 2.*qm )/3. + taf(2) = (2.*tg + thm)/3. + qaf(2) = (2.*qg + qm )/3. + ENDIF + +! initialization and input values for Monin-Obukhov + ! have been set before + z0h = z0m; z0q = z0m + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(2) + dqh = qm - qaf(2) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (trim(HEIGHT_mode) == 'absolute') THEN + + IF (hu <= hroof+1) THEN + hu_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than hroof+1, set it to hroof+1.' + ENDIF + + IF (ht <= hroof+1) THEN + ht_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than hroof+1, set it to hroof+1.' + ENDIF + + IF (hq <= hroof+1) THEN + hq_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than hroof+1, set it to hroof+1.' + ENDIF + + ELSE ! relative height + hu_ = hroof + hu + ht_ = hroof + ht + hq_ = hroof + hq + ENDIF + + zldis = hu_ - displa + + IF (zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL abort + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + + niters=6 + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + ITERATION : DO iter = 1, niters !begin stability iteration + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + + !NOTE: displat=hroof, z0mt=0, are set for roof + ! fmtop is calculated at the same height of fht, fqt + CALL moninobukm(hu_,ht_,hq_,displa,z0m,z0h,z0q,obu,um, & + hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) + +! Aerodynamic resistance + ! 09/16/2017: + ! NOTE that for ram, it is the resistance from Href to z0mv+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! For Urban: from Href to roof height + ! so rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective exchange + ! height) to reference height + ! For Urban: from roof height to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + + ! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + z0h = max(z0hg, z0h) + z0q = max(z0qg, z0q) + +!----------------------------------------------------------------------- +! new method to calculate rd and ueffect +! the kernel part of 3d model +!----------------------------------------------------------------------- + + ! initialization + rd(:) = 0. + rd_(:) = 0. + ueff_lay(:) = 0. + ueff_lay_(:) = 0. + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (hroof-displa) * ustar / phih + + ueff_lay(3) = utop + + ! NOTE: another calculation method for double-check + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, displah, & + ! htop, hbot, obu, ustar, ztop, zbot) + ! rd(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, hroof, displa+z0m) + + ! real(r8) FUNCTION frd(ktop, htop, hbot, ztop, zbot, displah, z0h, & + ! obu, ustar, z0mg, alpha, bee, fc) + rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + ! ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + + ! real(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + + ! rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m. NOTE: not used now. + ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! Masson, 2000: Account for different canyon orientations + ! 2/PI is a factor derived from 0-360deg integration + IF (alpha_opt == 1) THEN + ueff_lay(2) = 2/PI*ueff_lay(2) + rd(:) = PI/2*rd(:) + ENDIF + +!----------------------------------------------------------------------- +! Bulk boundary layer resistance of leaves +!----------------------------------------------------------------------- + + rb(:) = 0. + + DO i = 0, nurb + clev = canlev(i) + rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) + ENDDO + +!----------------------------------------------------------------------- +! Solve taf(:) and qaf(:) +!----------------------------------------------------------------------- + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) & + ! + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) & + ! + AHE/(rho*cp))/ (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2)) + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) & + ! + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) & + ! + AHE/(rho*cp))/(cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0)) & + ! / (1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rss)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg & + ! + AHE/rho)/(1/rd(3) + 1/(rd(2)+rss)*fgper*fg + fwetimp/rd(2)*fgimp*fg) + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) & + ! + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + AHE/rho)/ & + ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg) + + ! 06/20/2021, yuan: account for Anthropogenic heat + ! 92% heat release as SH, Pigeon et al., 2007 + + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + vehc*fsh + meta + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + aT = (tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah)*bT + + taf(2) = (tg*fg/rd(2) + Hahe(2)/(rhoair*cpair) & + + tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) + aT) & + / (cT * (1- bT/(cT*rd(3)))) + + taf(3) = (taf(2)/rd(3) + tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah) & + / (1/rah + 1/rd(3) + fc(0)/rb(0)) + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = (qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw)*bQ + + qaf(2) = (qgper*fgper*fg/(rd(2)+rss_) + qgimp*fwet_gimp*fgimp*fg/rd(2) & + + aQ + Lahe/rhoair/hvap) / (cQ * (1-bQ/(cQ*rd(3)))) + + qaf(3) = (qaf(2)/rd(3) + qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw) & + / (1/raw + 1/rd(3) + fwet_roof*fc(0)/rb(0)) + + ENDIF + + !------------------------------------------------ + ! update fwet for roof and impervious ground + ! to check whether dew happens + IF (qaf(3) > qroof) THEN + fwet_roof = 1. !dew case + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! to check whether dew happens + IF (qaf(2) > qgimp) THEN + fwet_gimp = 1. !dew case + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + ! USE the top layer taf and qaf + dth = thm - taf(2) + dqh = qm - qaf(2) + + tstar = vonkar/(fh)*dth + qstar = vonkar/(fq)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF (zeta .ge. 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta .ge. 0.) THEN + um = max(ur,.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + ENDDO ITERATION !end stability iteration + +! ====================================================================== +! END stability iteration +! ====================================================================== + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + + ! sensible heat fluxes + fsenroof = rhoair*cpair/rb(0)*(troof-taf(3)) + fsenwsun = rhoair*cpair/rb(1)*(twsun-taf(2)) + fsenwsha = rhoair*cpair/rb(2)*(twsha-taf(2)) + + ! latent heat fluxes + fevproof = rhoair/rb(0)*(qsatl(0)-qaf(3)) + fevproof = fevproof*fwet_roof + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + + cwsuns = rhoair*cpair/rb(1) & + * ( 1. - fc(1) / (cT*rb(1)*(1-bT/(cT*rd(3)))) ) + cwshas = rhoair*cpair/rb(2) & + * ( 1. - fc(2) / (cT*rb(2)*(1-bT/(cT*rd(3)))) ) + croofs = rhoair*cpair/rb(0) & + * ( 1. - fc(0)*bT*bT / (cT*rb(0)*(1-bT/(cT*rd(3)))) & + - fc(0) / (rb(0)*(1/rah+1/rd(3)+fc(0)/rb(0))) ) + + croofl = rhoair*fwet_roof/rb(0)*qsatldT(0) & + * ( 1. - fwet_roof*fc(0)*bQ*bQ / (cQ*rb(0)*(1-bQ/(cQ*rd(3)))) & + - fwet_roof*fc(0) / (rb(0)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) ) + + croof = croofs + croofl*htvp_roof + + +#if (defined CoLMDEBUG) +#endif + + tafu = taf(2) + +!----------------------------------------------------------------------- +! wind stresses +!----------------------------------------------------------------------- + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from urban ground to canopy space +!----------------------------------------------------------------------- + + fsengper = cpair*rhoair/rd(2)*(tgper-taf(2)) + fsengimp = cpair*rhoair/rd(2)*(tgimp-taf(2)) + + fevpgper = rhoair/(rd(2)+rss_)*(qgper-qaf(2)) + fevpgimp = rhoair/rd(2) *(qgimp-qaf(2)) + fevpgimp = fevpgimp*fwet_gimp + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature (cgrnd) +!----------------------------------------------------------------------- + + cgrnds = cpair*rhoair/rd(2)*( 1. - fg/(cT*rd(2)*(1-bT/(cT*rd(3)))) ) + + cgperl = rhoair/(rd(2)+rss_) & + * dqgperdT*( 1 - fg*fgper/(cQ*(rd(2)+rss_)*(1-bQ/(cQ*rd(3)))) ) + cgimpl = rhoair*fwet_gimp/rd(2)& + * dqgimpdT*( 1 - fwet_gimp*fg*fgimp/(cQ*rd(2)*(1-bQ/(cQ*rd(3)))) ) + + cgimp = cgrnds + cgimpl*htvp_gimp + cgper = cgrnds + cgperl*htvp_gper + +!----------------------------------------------------------------------- +! 2 m height air temperature above apparent sink height +!----------------------------------------------------------------------- + + !tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + !qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + ! assumption: (tg-t2m):(tg-taf) = 2:(displa+z0m) + tref = ( (displau+z0mu-2.)*tg + 2.*taf(2) ) / (displau+z0mu) + qref = ( (displau+z0mu-2.)*qg + 2.*qaf(2) ) / (displau+z0mu) + + END SUBROUTINE UrbanOnlyFlux + + + SUBROUTINE UrbanVegFlux ( & + ! Model running information + ipatch ,deltim ,lbr ,lbi ,& + ! Forcing + hu ,ht ,hq ,us ,& + vs ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,frl ,& + po2m ,pco2m ,par ,sabv ,& + rstfac ,Fhac ,Fwst ,Fach ,& + vehc ,meta ,& + ! Urban and vegetation parameters + hroof ,hlr ,nurb ,fcover ,& + ewall ,egimp ,egper ,ev ,& + htop ,hbot ,lai ,sai ,& + sqrtdi ,effcon ,vmax25 ,c3c4 ,slti,& + hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,trsmx0 ,lambda_wue ,& + ! Status of surface + z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno ,wliq_gimpsno ,wice_roofsno ,wice_gimpsno ,& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,sigf ,tl ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + dheatl ,rss ,etr_deficit ,& + ! Longwave information + Ainv ,B ,B1 ,dBdT ,& + SkyVF ,VegVF ,& + ! Output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + fsenl ,fevpl ,etr ,rst ,& + assim ,respc ,lwsun ,lwsha ,& + lgimp ,lgper ,lveg ,lout ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar,grav,hvap,cpair,stefnc,cpliq, cpice, & + hfus, tfrz, denice, denh2o + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_AssimStomataConductance + USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch, &! patch index [-] + lbr, &! lower bound of array + lbi ! lower bound of array + + real(r8), intent(in) :: & + deltim ! seconds in a time step [second] + + ! Forcing + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + frl, &! atmospheric infrared (longwave) radiation [W/m2] + par, &! par absorbed per unit sunlit lai [w/m**2] + sabv, &! solar radiation absorbed by vegetation [W/m2] + rstfac, &! factor of soil water stress to plant physiological processes + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + vehc, &! flux from vehicle [W/m2] + meta, &! flux from metabolic [W/m2] + Fhac, &! flux from heat or cool AC [W/m2] + Fwst, &! waste heat from cool or heat [W/m2] + Fach ! flux from air exchange [W/m2] + + ! Urban and vegetation parameters + integer, intent(in) :: & + nurb ! number of aboveground urban components [-] + + real(r8), intent(in) :: & + hroof, &! average building height [m] + hlr, &! average building height to their side length [-] + fcover(0:5) ! coverage of aboveground urban components [-] + + real(r8), intent(in) :: & + ewall, &! emissivity of walls + egimp, &! emissivity of impervious road + egper, &! emissivity of pervious road + ev ! emissivity of vegetation + + real(r8), intent(in) :: & + htop, &! PFT crown top height [m] + hbot, &! PFT crown bottom height [m] + lai, &! adjusted leaf area index for seasonal variation [-] + sai, &! stem area index [-] + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + lambda_wue, &! marginal water cost of carbon gain + + extkn, &! coefficient of leaf nitrogen allocation + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + dewmx, &! maximum dew + trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] + etrc ! maximum possible transpiration rate (mm/s) + + integer, intent(in) :: & + c3c4 ! 1: C3, 0: C4 + + ! Status of surface + real(r8), intent(in) :: & + rss, &! bare soil resistance for evaporation [s/m] + z0h_g, &! roughness length for bare ground, sensible heat [m] + obug, &! monin-obukhov length for bare ground (m) + ustarg, &! friction velocity for bare ground [m/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno_roof, &! fraction of ground covered by snow + fsno_gimp, &! fraction of ground covered by snow + fsno_gper, &! fraction of ground covered by snow + wliq_roofsno, &! liqui water [kg/m2] + wliq_gimpsno, &! liqui water [kg/m2] + wice_roofsno, &! ice lens [kg/m2] + wice_gimpsno, &! ice lens [kg/m2] + htvp_roof, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gimp, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gper, &! latent heat of vapor of water (or sublimation) [j/kg] + + troof, &! temperature of roof [K] + twsun, &! temperature of sunlit wall [K] + twsha, &! temperature of shaded wall [K] + tgimp, &! temperature of impervious road [K] + tgper, &! pervious ground temperature [K] + + qroof, &! roof specific humidity [kg/kg] + qgimp, &! imperivous road specific humidity [kg/kg] + qgper, &! pervious ground specific humidity [kg/kg] + dqroofdT, &! d(qroof)/dT + dqgimpdT, &! d(qgimp)/dT + dqgperdT, &! d(qgper)/dT + sigf ! + + real(r8), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow ! depth of snow on foliage [mm] + + real(r8), intent(out) :: & + fwet_snow, &! vegetation snow fractional cover [-] + dheatl ! vegetation heat change [W/m2] + + real(r8), intent(in) :: Ainv(5,5) !Inverse of Radiation transfer matrix + real(r8), intent(in) :: SkyVF (5) !View factor to sky + real(r8), intent(in) :: VegVF (5) !View factor to veg + real(r8), intent(inout) :: B (5) !Vectors of incident radiation on each surface + real(r8), intent(inout) :: B1 (5) !Vectors of incident radiation on each surface + real(r8), intent(inout) :: dBdT (5) !Vectors of incident radiation on each surface + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsenroof, &! sensible heat flux from roof [W/m2] + fsenwsun, &! sensible heat flux from sunlit wall [W/m2] + fsenwsha, &! sensible heat flux from shaded wall [W/m2] + fsengimp, &! sensible heat flux from impervious road [W/m2] + fsengper, &! sensible heat flux from pervious ground [W/m2] + fevproof, &! evaporation heat flux from roof [mm/s] + fevpgimp, &! evaporation heat flux from impervious road [mm/s] + fevpgper, &! evaporation heat flux from pervious ground [mm/s] + + croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + cwsuns, &! deriv of sunlit wall sensible heat flux wrt soil temp [w/m**2/k] + cwshas, &! deriv of shaded wall sensible heat flux wrt soil temp [w/m**2/k] + cgrnds, &! deriv of ground latent heat flux wrt soil temp [w/m**2/k] + croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + cgimpl, &! deriv of impervious latent heat flux wrt soil temp [w/m**2/k] + cgperl, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + croof, &! deriv of roof total flux wrt soil temp [w/m**2/k] + cgimp, &! deriv of impervious total heat flux wrt soil temp [w/m**2/k] + cgper, &! deriv of soil total heat flux wrt soil temp [w/m**2/k] + + tref, &! 2 m height air temperature [kelvin] + qref ! 2 m height air humidity + + real(r8), intent(out) :: & + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + rst, &! stomatal resistance + assim, &! rate of assimilation + respc ! rate of respiration + + real(r8), intent(inout) :: & + etr_deficit ! urban irrigation [mm/s] + + real(r8), intent(inout) :: & + lwsun, &! net longwave radiation of sunlit wall [W/m2] + lwsha, &! net longwave radiation of shaded wall [W/m2] + lgimp, &! net longwave radiation of impervious road [W/m2] + lgper, &! net longwave radiation of pervious road [W/m2] + lveg, &! net longwave radiation of vegetation [W/m2] + lout ! out-going longwave radiation [W/m2] + + real(r8), intent(inout) :: & + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq, &! integral of profile function for moisture + tafu ! effective urban air temperature (2nd layer, walls) + +!-----------------------Local Variables--------------------------------- +! assign iteration parameters + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + + real(r8) dtl(0:itmax+1) !difference of tl between two iterative step + + real(r8) :: & + zldis, &! reference height "minus" zero displacement height [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length of vegetation only, momentum [m] + z0mu, &! roughness length of building only, momentum [m] + z0h, &! roughness length, sensible heat [m] + z0q, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of convective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + clai, &! canopy heat capacity [Jm-2K-1] + del, &! absolute change in leaf temp in current iteration [K] + del2, &! change in leaf temperature in previous iteration [K] + dele, &! change in heat fluxes from leaf [K] + dele2, &! change in heat fluxes from leaf [K] + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf temp. change in two consecutive iter [K] + + obuold, &! monin-obukhov length from previous iteration + tlbef, &! leaf temperature from previous iteration [K] + err, &! balance error + + rs, &! sunlit leaf stomatal resistance [s/m] + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor ! tf*psur*100./1.013e5 + + integer it, nmozsgn + + real(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif + real(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8) z0mg, z0hg, z0qg, cint(3) + real(r8) fevpl_bef, fevpl_noadj, dtl_noadj, erre + real(r8) qevpl, qdewl, qsubl, qfrol, qmelt, qfrz + +!----------------------- definition for 3d run ------------------------ + integer, parameter :: nlay = 3 + integer, parameter :: uvec(5) = (/0,0,0,0,1/) !unit vector + + integer :: & + clev, &! current layer index + botlay, &! bottom layer index + numlay ! available layer number + + real(r8) :: & + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + ktop, &! K value at a specific height + utop, &! u value at a specific height + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + fmtop, &! fm value at a specific height + phih, &! phi(h), similarity function for sensible heat + displa, &! displacement height for urban + displau, &! displacement height for urban building + displav, &! displacement height for urban vegetation + displav_lay, &! displacement height for urban vegetation layer + z0mv_lay, &! roughness length for vegetation + ueff_veg, &! effective wind speed within canopy layer [m/s] + tg, &! ground temperature + qg ! ground specific humidity + + real(r8) :: & + fg, &! ground fractional cover + fgimp, &! weight of impervious ground + fgper, &! weight of pervious ground + hwr, &! average building height to their distance [-] + sqrtdragc, &! sqrt(drag coefficient) + lm, &! mix length within canopy + fai, &! frontal area index for urban + faiv, &! frontal area index for trees + lsai, &! lai+sai + fwet, &! fractional wet area of foliage [-] + fdry, &! fraction of foliage that is green and dry [-] + delta, &! 0 or 1 + alpha, &! exponential extinction factor for u/k decline within urban + alphav ! exponential extinction factor for u/k decline within trees + + real(r8) :: & + dlwsun, &! change of lw for the last time + dlwsha, &! change of lw for the last time + dlgimp, &! change of lw for the last time + dlgper, &! change of lw for the last time + dlveg ! change of lw for the last time + + real(r8), dimension(0:nurb) :: & + tu, &! temperature array + fc, &! fractional cover array + canlev, &! urban canopy layer lookup table + rb, &! leaf boundary layer resistance [s/m] + cfh, &! heat conductance for leaf [m/s] + cfw, &! latent heat conductance for leaf [m/s] + wtl0, &! normalized heat conductance for air and leaf [-] + wtlq0, &! normalized latent heat cond. for air and leaf [-] + + ei, &! vapor pressure on leaf surface [pa] + deidT, &! derivative of "ei" on "tl" [pa/K] + qsatl, &! leaf specific humidity [kg/kg] + qsatldT ! derivative of "qsatl" on "tlef" + + real(r8), dimension(nlay) :: & + fah, &! weight for thermal resistance to upper layer + faw, &! weight for moisture resistance to upper layer + fgh, &! weight for thermal resistance to lower layer + fgw, &! weight for moisture resistance to lower layer + ueff_lay, &! effective wind speed within canopy layer [m/s] + ueff_lay_, &! effective wind speed within canopy layer [m/s] + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + rd, &! aerodynamic resistance between layers [s/m] + rd_, &! aerodynamic resistance between layers [s/m] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wta0, &! normalized heat conductance for air [-] + wtg0, &! normalized heat conductance for ground [-] + wtaq0, &! normalized latent heat conductance for air [-] + wtgq0, &! normalized heat conductance for ground [-] + wtll, &! sum of normalized heat conductance for air and leaf + wtlql ! sum of normalized heat conductance for air and leaf + + real(r8), dimension(nlay) :: & + Hahe ! anthropogenic heat emission (AHE) + + real(r8) :: & + rv, &! aerodynamic resistance between layers [s/m] + ra2m, &! aerodynamic resistance between 2m and bottom layer [s/m] + rd2m ! aerodynamic resistance between bottom layer and ground [s/m] + + ! temporal + integer i + real(r8) aT, bT, cT, aQ, bQ, cQ, Lahe + real(r8) bee, cf, tmpw1, tmpw2, tmpw3, tmpw4, fact, facq, taftmp + real(r8) B_5, B1_5, dBdT_5, X(5), dX(5) + real(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_, rss_, rs_, etr_ + real(r8) fwetfac, lambda + real(r8) cgw_imp, cgw_per + + ! for interface + real(r8) o3coefv, o3coefg, assim_RuBP, assim_Rubisco, ci, vpd, gammas + +!----------------------------------------------------------------------- + +! initialization of errors and iteration parameters + it = 1 !counter for leaf temperature iteration + del = 0.0 !change in leaf temperature from previous iteration + dele = 0.0 !latent head flux from leaf for previous iteration + + dtl = 0. + fevpl_bef = 0. + +! initial values for z0hg, z0qg + + !TODO: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gper > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg + +!----------------------------------------------------------------------- +! scaling-up coefficients from leaf to canopy +!----------------------------------------------------------------------- + + cint(1) = (1.-exp(-0.110*lai))/0.110 + cint(2) = (1.-exp(-extkd*lai))/extkd + cint(3) = lai + +!----------------------------------------------------------------------- +! initial saturated vapor pressure and humidity and their derivation +!----------------------------------------------------------------------- + + clai = 0.0 + lsai = lai + sai + + ! 0.2mm*LSAI, account for leaf (plus dew) heat capacity + IF ( DEF_VEG_SNOW ) THEN + clai = 0.2*(lai+sai)*cpliq + ldew_rain*cpliq + ldew_snow*cpice + ENDIF + + ! index 0:roof, 1:sunlit wall, 2:shaded wall, 3: vegetation + tu(0) = troof; tu(1) = twsun; tu(2) = twsha; tu(3) = tl + + fg = 1 - fcover(0) + fc(:) = fcover(0:nurb) + fc(3) = fcover(5) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + !hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) + hwr = hlr*sqrt(fcover(0))/(1-sqrt(fcover(0))) + canlev = (/3, 2, 2, 1/) + + B_5 = B(5) + B1_5 = B1(5) + dBdT_5 = dBdT(5) + + CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + + qsatl(0) = qroof + qsatldT(0) = dqroofDT + DO i = 1, nurb + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + ENDDO + + ! Save the longwave for the last time + dlwsun = lwsun + dlwsha = lwsha + dlgimp = lgimp + dlgper = lgper + dlveg = lveg + +!----------------------------------------------------------------------- +! Calculate the weighted qg, tg, and wet fraction +!----------------------------------------------------------------------- + + ! weighted tg and qg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof_ = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof_ = min(1., fwet_roof_) + ENDIF + + ! impervious ground + IF (lbi < 1) THEN + fwet_gimp_ = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp_ = min(1., fwet_gimp_) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + +!----------------------------------------------------------------------- +! scaling factor bee +!----------------------------------------------------------------------- +!NOTE: bee value, the default is 1 + bee = 1. + +!----------------------------------------------------------------------- +! calculate z0m and displa for layers +!----------------------------------------------------------------------- + + ! Calculate z0 and displa for vegetation only and the whole area + CALL cal_z0_displa(lsai, htop, 1., z0mv, displav) + CALL cal_z0_displa(lsai, htop, fc(3), z0mv_lay, displav_lay) + + ! For building only below + ! Macdonald et al., 1998, Eq. (23), A=4.43 + lambda = fcover(0) + displau = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) + fai = 4/PI*hlr*fcover(0) + z0mu = (hroof - displau) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) + + ! account for vegetation + faiv = fc(3)*(1. - exp(-0.5*lsai)) + lambda = fcover(0) + faiv*htop/hroof + displa = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) + displa = min(0.95*hroof, displa) + z0m = (hroof - displa) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displa/hroof)*(fai+faiv*htop/hroof))**(-0.5) ) + + ! to compare z0 of urban and only the surface + ! maximum assumption + IF (z0m < z0mg) z0m = z0mg + IF (displa >= hroof-z0mg) displa = hroof-z0mg + + ! minimum building displa limit + displau = max(hroof/2., displau) + + ! Layer setting + IF ( (.not.run_three_layer) .or. z0mv+displav > 0.5*(z0mu+displau) ) THEN + numlay = 2; botlay = 2; canlev(3) = 2 + ELSE + numlay = 3; botlay = 1 + ENDIF + +!----------------------------------------------------------------------- +! calculate layer decay coefficient +!----------------------------------------------------------------------- + + ! Raupach, 1992 + sqrtdragc = min( (0.003+0.3*faiv)**0.5, 0.3 ) + + ! Kondo, 1971 + alphav = htop/(htop-displav_lay)/(vonkar/sqrtdragc) + alphav = alphav*htop/hroof + + ! Masson, 2000; Oleson et al., 2008 plus tree (+) + IF (alpha_opt == 1) alpha = 0.5*hwr + alphav + + ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008. plus tree (+) + IF (alpha_opt == 2) alpha = 0.772*hwr + alphav + + ! Macdonald, 2000 plus tree (+) + IF (alpha_opt == 3) alpha = 9.6*fai + alphav + +!----------------------------------------------------------------------- +! first guess for taf and qaf for each layer +! a large differece from previous schemes +!----------------------------------------------------------------------- + taf(:) = 0. + qaf(:) = 0. + + IF (numlay .eq. 2) THEN + taf(3) = (tg + 2.*thm)/3. + qaf(3) = (qg + 2.*qm )/3. + taf(2) = (2.*tg + thm)/3. + qaf(2) = (2.*qg + qm )/3. + ENDIF + + IF (numlay .eq. 3) THEN + taf(3) = (tg + 3.*thm)/4. + qaf(3) = (qg + 3.*qm )/4. + taf(2) = (tg + thm )/2. + qaf(2) = (qg + qm )/2. + taf(1) = (3.*tg + thm)/4. + qaf(1) = (3.*qg + qm )/4. + ENDIF + +!----------------------------------------------------------------------- +! some environment variables +! how to calculate rsoil and what is its usage? +!----------------------------------------------------------------------- + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) + !rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) + !rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 + !rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 + +! initialization and input values for Monin-Obukhov + ! have been set before + z0h = z0m; z0q = z0m + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(2) + dqh = qm - qaf(2) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (trim(HEIGHT_mode) == 'absolute') THEN + + IF (hu <= hroof+1) THEN + hu_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than hroof+1, set it to hroof+1.' + ENDIF + + IF (ht <= hroof+1) THEN + ht_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than hroof+1, set it to hroof+1.' + ENDIF + + IF (hq <= hroof+1) THEN + hq_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than hroof+1, set it to hroof+1.' + ENDIF + + ELSE ! relative height + hu_ = hroof + hu + ht_ = hroof + ht + hq_ = hroof + hq + ENDIF + + zldis = hu_ - displa + + IF (zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL abort + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + DO WHILE (it .le. itmax) + + tlbef = tl + + del2 = del + dele2 = dele + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + + CALL moninobukm(hu_,ht_,hq_,displa,z0m,z0h,z0q,obu,um, & + hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) + +! Aerodynamic resistance + ! 09/16/2017: + ! NOTE that for ram, it is the resistance from Href to z0m+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! So rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective + ! exchange height) to reference height. + ! For urban, from roof height to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + +! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + z0h = max(z0hg, z0h) + z0q = max(z0qg, z0q) + +!----------------------------------------------------------------------- +! new method to calculate rd and ueffect +! the kernel part of 3d model +!----------------------------------------------------------------------- + + ! initialization + rd(:) = 0. + rd_(:) = 0. + ueff_lay(:) = 0. + ueff_lay_(:) = 0. + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (hroof-displa) * ustar / phih + + ueff_lay(3) = utop + ueff_lay_(3) = utop + + ! NOTE: another calculation method for double-check + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, displah, & + ! htop, hbot, obu, ustar, ztop, zbot) + ! rd_(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, hroof, displau+z0mu) + + ! real(r8) FUNCTION frd(ktop, htop, hbot, ztop, zbot, displah, z0h, & + ! obu, ustar, z0mg, alpha, bee, fc) + rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + ! ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + + ! real(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + + IF (numlay == 3) THEN + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, displah, & + ! htop, hbot, obu, ustar, ztop, zbot) + ! rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, displav+z0mv) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, displav+z0mv, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! rd(1) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displav+z0mv, z0qg) + rd(1) = frd(ktop, hroof, 0., displav+z0mv, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displav+z0mv, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + ELSE + ! rd_(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + ENDIF + + ! ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + ! ueff_veg = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., htop, hbot) + + ! ueff_lay_(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + ueff_veg = ueffectz(utop, hroof, 0., htop, hbot, z0mg, alpha, bee, 1.) + + ! Masson, 2000: Account for different canyon orientations + ! 2/PI is a factor derived from 0-360deg integration + IF (alpha_opt == 1) THEN + ueff_lay(2) = 2/PI*ueff_lay(2) + ueff_veg = 2/PI*ueff_veg + rd(:) = PI/2*rd(:) + ENDIF + +!----------------------------------------------------------------------- +! Bulk boundary layer resistance of leaves +!----------------------------------------------------------------------- + + rb(:) = 0. + + DO i = 0, nurb + + IF (i == 3) THEN + cf = 0.01*sqrtdi*sqrt(ueff_veg) + rb(i) = 1./cf + CYCLE + ENDIF + + clev = canlev(i) + rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) + + ! Cole & Sturrock (1977) Building and Environment, 12, 207-214. + ! rb(i) = rhoair * cpair / ( 5.8 + 4.1*ueff_lay(clev) ) + ! IF (ueff_lay(clev) > 5.) THEN + ! rb(i) = rhoair * cpair / (7.51*ueff_lay(clev)**0.78) + ! ELSE + ! rb(i) = rhoair * cpair / (5.8 + 4.1*ueff_lay(clev)) + ! ENDIF + ! rb(i) = rhoair * cpair & + ! / ( cpair*vonkar*vonkar*ueff_lay(clev)& + ! / (log(0.1*hroof/)*(2.3+log(0.1*hroof/))) ) + ENDDO + +!----------------------------------------------------------------------- +! stomatal resistances +!----------------------------------------------------------------------- + + IF (lai > 0.) THEN + + clev = canlev(3) + eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa + +!----------------------------------------------------------------------- +! note: calculate resistance for leaves +!----------------------------------------------------------------------- + + CALL stomata (vmax25,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(3) ,tu(3) ,par ,& + o3coefv ,o3coefg ,lambda_wue ,& + rb(3)/lai,raw ,rstfac ,cint(:),& + assim ,respc ,rs & + ) + + rs_ = rs + +IF ( DEF_URBAN_Irrigation .and. rstfac < rstfac_irrig ) THEN + CALL stomata (vmax25,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(3) ,tu(3) ,par ,& + o3coefv ,o3coefg ,lambda_wue ,& + rb(3)/lai,raw ,rstfac_irrig ,cint(:),& + assim ,respc ,rs & + ) +ENDIF + ELSE + rs = 2.e4; assim = 0.; respc = 0. + ENDIF + +! above stomatal resistances are for the canopy, the stomatal rsistances +! and the "rb" in the following calculations are the average for single leaf. thus, + rs = rs * lai + rs_= rs_* lai + +! calculate latent heat resistances + clev = canlev(3) + delta = 0.0 + IF (qsatl(3)-qaf(clev) .gt. 0.) delta = 1.0 + + rv = 1/( (1.-delta*(1.-fwet))*lsai/rb(3) & + + (1.-fwet)*delta*(lai/(rb(3)+rs)) ) + +!----------------------------------------------------------------------- +! Solve taf(:) and qaf(:) +!----------------------------------------------------------------------- + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) & + ! + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) & + ! + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) + ! + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) & + ! + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) & + ! + cfh(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) & + ! + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rss)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg & + ! + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho) & + ! / (1/rd(3) + 1/(rd(2)+rss)*fgper*fg & + ! + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) + ! + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0)) & + ! / (caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg & + ! + cfw(3)*ql*fc(3) + AHE/rho) & + ! / (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) + + ! 06/20/2021, yuan: account for Anthropogenic heat + ! 92% heat release as SH, Pigeon et al., 2007 + + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + vehc*fsh + meta + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + fc(3)*lsai/rb(3) + aT = (tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah)*bT + + taf(2) = (tg*fg/rd(2) + Hahe(2)/(rhoair*cpair) + tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + tu(3)*fc(3)*lsai/rb(3) + aT) / (cT * (1- bT/(cT*rd(3)))) + + taf(3) = (taf(2)/rd(3) + tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah) & + / (1/rah + 1/rd(3) + fc(0)/rb(0)) + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + fc(3)/rv + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = (qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw)*bQ + + qaf(2) = (qgper*fgper*fg/(rd(2)+rss_) + qgimp*fwet_gimp*fgimp*fg/rd(2) & + + qsatl(3)*fc(3)/rv + aQ + Lahe/rhoair/hvap) & + / (cQ * (1-bQ/(cQ*rd(3)))) + + qaf(3) = (qaf(2)/rd(3) + qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw) & + / (1/raw + 1/rd(3) + fwet_roof*fc(0)/rb(0)) + + ENDIF + + IF (numlay .eq. 3) THEN + + ! - Equations: + ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& + ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+& + ! AHE1/rho/cpair)/(1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) + ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& + ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& + ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& + ! (1/rd(3) + 1/rd(2)) + ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rss)*qgper*fgper*fg+& + ! 1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho)/& + ! (1/rd(2)+1/(rd(1)+rss)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) + + Hahe(1) = vehc*fsh + meta + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + cT = 1/rd(3) + 1/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + at = 1/(rd(2)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) + bT = 1/(rd(3)*(1/rah+1/rd(3)+fc(0)/rb(0))) + + taf(2) = (tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + (tu(3)*fc(3)*lsai/rb(3)+tg*fg/rd(1)+Hahe(1)/(rhoair*cpair))*aT & + + (tu(0)*fc(0)/rb(0)+thm/rah+Hahe(3)/(rhoair*cpair))*bT & + + Hahe(2)/(rhoair*cpair)) & + / (cT*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) + + taf(1) = (tu(3)*fc(3)*lsai/rb(3) + tg*fg/rd(1) + taf(2)/rd(2) & + + Hahe(1)/(rhoair*cpair)) / (1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3)) + + taf(3) = (tu(0)*fc(0)/rb(0) + taf(2)/rd(3) + thm/rah + Hahe(3)/(rhoair*cpair)) & + / (1/rah+1/rd(3)+fc(0)/rb(0)) + + IF (qgper < qaf(1)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + 1/rd(2) + bQ = 1/(rd(3)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = 1/(rd(2)*(1/rd(2)+fg*fgimp*fwet_gimp/rd(1)+fg*fgper/(rd(1)+rss_)+fc(3)/rv)) + + qaf(2) = ( (fg*fgimp*fwet_gimp*qgimp/rd(1) + fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv + Lahe/rhoair/hvap)*aQ & + + (qm/raw+fc(0)*fwet_roof*qsatl(0)/rb(0))*bQ ) & + / ( cQ*(1-bQ/(cQ*rd(3))-aQ/(cQ*rd(2))) ) + + qaf(1) = ( fg*fgimp*fwet_gimp*qgimp/rd(1) + fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv + qaf(2)/rd(2) + Lahe/rhoair/hvap ) & + / ( 1/rd(2) + fg*fgimp*fwet_gimp/rd(1) + fg*fgper/(rd(1)+rss_) + fc(3)/rv ) + + qaf(3) = ( fc(0)*fwet_roof*qsatl(0)/rb(0) + qaf(2)/rd(3) + qm/raw ) & + / ( 1/raw + 1/rd(3)+ fwet_roof*fc(0)/rb(0) ) + ENDIF + +!----------------------------------------------------------------------- +! IR radiation, sensible and latent heat fluxes and their derivatives +!----------------------------------------------------------------------- +! the partial derivatives of areodynamical resistance are ignored +! which cannot be determined analytically + + !NOTE: ONLY for vegetation + i = 3 + +! sensible heat fluxes and their derivatives + fsenl = rhoair * cpair * lsai/rb(3) * (tl - taf(botlay)) + + IF (botlay == 2) THEN + fsenl_dtl = rhoair * cpair * lsai/rb(3) & + * ( 1. - fc(3)*lsai/(rb(3)*cT*(1-bT/(cT*rd(3)))) ) + ELSE + fsenl_dtl = rhoair * cpair * lsai/rb(3) & + * ( 1. - fc(3)*lsai/(rb(3)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) & + - fc(3)*lsai*aT*aT/(rb(3)*cT*(1-aT/(cT*rd(2))-bT/(cT*rd(3)))) ) + ENDIF + + +! latent heat fluxes and their derivatives + etr = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * (qsatl(i) - qaf(botlay)) + + IF (botlay == 2) THEN + etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(3)+rs) & + * (1.-fc(3)/(cQ*rv*(1-bQ/(cQ*rd(3))))) & + * qsatldT(3) + ELSE + etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * ( 1. - fc(3)/(rv*(1/rd(2) + fg*fgimp*fwet_gimp/rd(1) + & + fg*fgper/(rss_+rd(1)) + fc(3)/rv)) & + - fc(3)*aQ*aQ/(rv*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + ENDIF + +IF ( DEF_URBAN_Irrigation ) THEN + IF (etr.ge.trsmx0*rstfac_irrig) THEN + etr = trsmx0*rstfac_irrig + etr_dtl = 0. + ENDIF +ELSE + IF (etr.ge.etrc) THEN + etr = etrc + etr_dtl = 0. + ENDIF +ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * (qsatl(i) - qaf(botlay)) + + IF (botlay == 2) THEN + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(3) & + * (1.-fc(3)/(cQ*rv*(1-bQ/(cQ*rd(3))))) & + * qsatldT(3) + ELSE + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * ( 1. - fc(3)/(rv*(1/rd(2) + fg*fgimp*fwet_gimp/rd(1) + & + fg*fgper/(rss_+rd(1)) + fc(3)/rv)) & + - fc(3)*aQ*aQ/(rv*CQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + ENDIF + + IF (evplwet.ge.ldew/deltim) THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + erre = 0. + fevpl_noadj = fevpl + IF ( fevpl*fevpl_bef < 0. ) THEN + erre = -0.9*fevpl + fevpl = 0.1*fevpl + ENDIF + +IF ( DEF_URBAN_Irrigation ) THEN + etr_= rhoair * (1.-fwet) * delta * lai/(rb(i)+rs_) & + * (qsatl(i) - qaf(botlay)) + + IF (etr_.ge.etrc) THEN + etr_ = etrc + ENDIF +ENDIF + + +!----------------------------------------------------------------------- +! difference of temperatures by quasi-newton-raphson method for the non-linear system equations +!----------------------------------------------------------------------- + + ! calculate irab, dirab_dtl + B(5) = B_5*tl**4 + B1(5) = B1_5*tl**4 + dBdT(5) = dBdT_5*tl**3 + X = matmul(Ainv, B) + ! first 5 items of dBdT is 0, dBdT*(0,0,0,0,0,1) + dX = matmul(Ainv, dBdT*uvec) + + ! calculate longwave for vegetation + irab = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5) ) / fcover(5)*fg + irab = irab + dlveg ! plus the previous step dlveg + dirab_dtl = ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) ) / fcover(5)*fg + + ! solve for leaf temperature + dtl(it) = (sabv + irab - fsenl - hvap*fevpl) & + / (clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl) + dtl_noadj = dtl(it) + + ! check magnitude of change in leaf temperature limit to maximum allowed value + + IF (it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF (abs(dtl(it)).gt.delmax) THEN + dtl(it) = delmax*dtl(it)/abs(dtl(it)) + ENDIF + + IF ((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.)) THEN + dtl(it) = 0.5*(dtl(it-1) + dtl(it)) + ENDIF + + ENDIF + + tl = tlbef + dtl(it) + tu(3) = tl + +!----------------------------------------------------------------------- +! square roots differences of temperatures and fluxes for use as the condition of convergences +!----------------------------------------------------------------------- + + del = sqrt( dtl(it)*dtl(it) ) + dele = dtl(it) * dtl(it) * & + ( dirab_dtl**2 + fsenl_dtl**2 + (hvap*fevpl_dtl)**2 ) + dele = sqrt(dele) + +!----------------------------------------------------------------------- +! saturated vapor pressures and canopy air temperature, canopy air humidity +!----------------------------------------------------------------------- +! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature +! and adjust specific humidity (qsatl_) proportionately + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + +! update vegetation/ground surface temperature, canopy air temperature, +! canopy air humidity + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) & + ! + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) & + ! + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) + ! + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) & + ! + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) & + ! + cfh(2)*twsha*fc(2) + cfh(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) & + ! + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rss)*qper*fgper*fg & + ! + fwetimp/rd(2)*qimp*fgimp*fg + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho) & + ! / (1/rd(3) + 1/(rd(2)+rss)*fgper*fg & + ! + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) + ! + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) & + ! + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg & + ! + cfw(3)*ql*fc(3) + AHE/rho) & + ! / (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) + + ! 06/20/2021, yuan: account for AH + ! 92% heat release as SH, Pigeon et al., 2007 + + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + vehc*fsh + meta + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + fc(3)*lsai/rb(3) + aT = (tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah)*bT + + taf(2) = (tg*fg/rd(2) + Hahe(2)/(rhoair*cpair) + tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + tu(3)*fc(3)*lsai/rb(3) + aT) / (cT * (1- bT/(cT*rd(3)))) + + taf(3) = (taf(2)/rd(3) + tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah) & + / (1/rah + 1/rd(3) + fc(0)/rb(0)) + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + fc(3)/rv + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = (qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw)*bQ + + qaf(2) = (qgper*fgper*fg/(rd(2)+rss_) + qgimp*fwet_gimp*fgimp*fg/rd(2) & + + qsatl(3)*fc(3)/rv + aQ + Lahe/rhoair/hvap) / (cQ * (1-bQ/(cQ*rd(3)))) + + qaf(3) = (qaf(2)/rd(3) + qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw) & + / (1/raw + 1/rd(3) + fwet_roof*fc(0)/rb(0)) + + ENDIF + + IF (numlay .eq. 3) THEN + + ! - Equations: + ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& + ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+& + ! AHE1/rho/cpair)/(1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) + ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& + ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& + ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& + ! (1/rd(3) + 1/rd(2)) + ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rss)*qgper*fgper*fg+& + ! 1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho))/& + ! (1/rd(2)+1/(rd(1)+rss)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) + + Hahe(1) = vehc*fsh + meta + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + cT = 1/rd(3) + 1/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + at = 1/(rd(2)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) + bT = 1/(rd(3)*(1/rah+1/rd(3)+fc(0)/rb(0))) + + taf(2) = (tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + (tu(3)*fc(3)*lsai/rb(3)+tg*fg/rd(1)+Hahe(1)/(rhoair*cpair))*aT & + + (tu(0)*fc(0)/rb(0)+thm/rah+Hahe(3)/(rhoair*cpair))*bT & + + Hahe(2)/(rhoair*cpair)) / (cT*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) + + taf(1) = (tu(3)*fc(3)*lsai/rb(3) + tg*fg/rd(1) + taf(2)/rd(2) & + + Hahe(1)/(rhoair*cpair)) / (1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3)) + + taf(3) = (tu(0)*fc(0)/rb(0) + taf(2)/rd(3) + thm/rah + Hahe(3)/(rhoair*cpair)) & + / (1/rah+1/rd(3)+fc(0)/rb(0)) + + IF (qgper < qaf(1)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + 1/rd(2) + bQ = 1/(rd(3)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = 1/(rd(2)*(1/rd(2)+fg*fgimp*fwet_gimp/rd(1)+fg*fgper/(rd(1)+rss_)+fc(3)/rv)) + + qaf(2) = ((fg*fgimp*fwet_gimp*qgimp/rd(1)+fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv+Lahe/rhoair/hvap)*aQ & + + (qm/raw+fc(0)*fwet_roof*qsatl(0)/rb(0))*bQ) & + / (cQ*(1-bQ/(cQ*rd(3))-aQ/(cQ*rd(2)))) + + qaf(1) = (fg*fgimp*fwet_gimp*qgimp/rd(1)+fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv+qaf(2)/rd(2)+Lahe/rhoair/hvap) & + /(1/rd(2)+fg*fgimp*fwet_gimp/rd(1)+fg*fgper/(rd(1)+rss_)+fc(3)/rv) + + qaf(3) = (fc(0)*fwet_roof*qsatl(0)/rb(0)+qaf(2)/rd(3)+qm/raw) & + /(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0)) + + ENDIF + + !------------------------------------------------ + ! account for fwet for roof and impervious ground + IF (qaf(3) > qroof) THEN + fwet_roof = 1. !dew case + ELSE + fwet_roof = fwet_roof_ + ENDIF + + IF (qaf(botlay) > qgimp) THEN + fwet_gimp = 1. !dew case + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac + +! update co2 partial pressure within canopy air + ! 05/02/2016: may have some problem with gdh2o, however, + ! this variable seems never used here. Different height + ! level vegetation should have different gdh2o, i.e., + ! different rd(layer) values. + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + gdh2o = 1.0/rd(botlay) * tprcor/thm !mol m-2 s-1 + + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assim - respc - rsoil) + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + ! USE the top layer taf and qaf + dth = thm - taf(2) + dqh = qm - qaf(2) + + tstar = vonkar/(fh)*dth + qstar = vonkar/(fq)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF (zeta .ge. 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta .ge. 0.) THEN + um = max(ur,.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu + +!----------------------------------------------------------------------- +! Test for convergence +!----------------------------------------------------------------------- + + it = it+1 + + IF (it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + dee = max(dele,dele2) + IF (det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + +! ====================================================================== +! END stability iteration +! ====================================================================== + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! canopy fluxes and total assimilation amd respiration + + IF (lai .gt. 0.001) THEN + rst = rs/lai + ELSE + rs = 2.0e4 + assim = 0. + respc = 0. + rst = 2.0e4 + ENDIF + respc = respc + rsoil + +IF ( DEF_URBAN_Irrigation ) THEN + etr_deficit = max(0., etr - etr_) +ENDIF + +! canopy fluxes and total assimilation and respiration + + fsenl = fsenl + fsenl_dtl*dtl(it-1) & + ! add the imbalanced energy below due to T adjustment to sensible heat + + (dtl_noadj-dtl(it-1)) * (clai/deltim - dirab_dtl & + + fsenl_dtl + hvap*fevpl_dtl) & + ! add the imbalanced energy below due to q adjustment to sensible heat + + hvap*erre + + etr = etr + etr_dtl*dtl(it-1) + evplwet = evplwet + evplwet_dtl*dtl(it-1) + fevpl = fevpl_noadj + fevpl = fevpl + fevpl_dtl*dtl(it-1) + + elwmax = ldew/deltim + + elwdif = max(0., evplwet-elwmax) + evplwet = min(evplwet, elwmax) + + fevpl = fevpl - elwdif + fsenl = fsenl + hvap*elwdif + + +!----------------------------------------------------------------------- +! Update dew accumulation (kg/m2) +!----------------------------------------------------------------------- + + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + IF ( DEF_VEG_SNOW ) THEN + ! update fwet_snow + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((10./(48.*(lai+sai)))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + ! phase change + + qmelt = 0. + qfrz = 0. + + IF (ldew_snow.gt.1.e-6 .and. tl.gt.tfrz) THEN + qmelt = min(ldew_snow/deltim,(tl-tfrz)*cpice*ldew_snow/(deltim*hfus)) + ldew_snow = max(0.,ldew_snow - qmelt*deltim) + ldew_rain = max(0.,ldew_rain + qmelt*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + + IF (ldew_rain.gt.1.e-6 .and. tl.lt.tfrz) THEN + qfrz = min(ldew_rain/deltim,(tfrz-tl)*cpliq*ldew_rain/(deltim*hfus)) + ldew_rain = max(0.,ldew_rain - qfrz*deltim) + ldew_snow = max(0.,ldew_snow + qfrz*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + ENDIF + + ! vegetation heat change + dheatl = clai/deltim*dtl(it-1) + +!----------------------------------------------------------------------- +! balance check +!----------------------------------------------------------------------- + + err = sabv + irab + dirab_dtl*dtl(it-1) & + - fsenl - hvap*fevpl - dheatl + +#if (defined CoLMDEBUG) + IF (abs(err) .gt. .2) THEN + write(6,*) 'energy imbalance in UrbanVegFlux.F90', & + i,it-1,err,sabv,irab,fsenl,hvap*fevpl,dheatl + CALL CoLM_stop() + ENDIF +#endif + + + ! calculate longwave absorption + lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) + lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) + lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) + lgper = ( egper*X(4) - B1(4) ) / (1-egper) + lveg = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5) ) + lout = sum( X * SkyVF ) + + ! longwave absorption due to leaf temperature change + lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl(it-1) + lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl(it-1) + lgimp = lgimp + ( egimp*dX(3) ) / (1-egimp) * dtl(it-1) + lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl(it-1) + lveg = lveg + ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) ) * dtl(it-1) + lout = lout + sum( dX * SkyVF * dtl(it-1) ) + + ! Energy balance check + err = lwsun + lwsha + lgimp + lgper + lveg + lout + + IF (abs(err-frl) > 1e-6) THEN + print *, "Longwave - Energy Balance Check error!", err-frl + ENDIF + + ! convert to per unit area + IF (fcover(1) > 0.) lwsun = lwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) > 0.) lwsha = lwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) > 0.) lgimp = lgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) > 0.) lgper = lgper / fcover(4) * fg !/ fgper + IF (fcover(5) > 0.) lveg = lveg / fcover(5) * fg !/ fv/fg + + ! add previous longwave + lwsun = lwsun + dlwsun + lwsha = lwsha + dlwsha + lgimp = lgimp + dlgimp + lgper = lgper + dlgper + lveg = lveg + dlveg + + tafu = taf(2) + +!----------------------------------------------------------------------- +! wind stresses +!----------------------------------------------------------------------- + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from roof, walls to canopy space +!----------------------------------------------------------------------- + + ! sensible heat fluxes + fsenroof = rhoair*cpair/rb(0)*(troof-taf(3)) + fsenwsun = rhoair*cpair/rb(1)*(twsun-taf(2)) + fsenwsha = rhoair*cpair/rb(2)*(twsha-taf(2)) + + ! latent heat fluxes + fevproof = rhoair/rb(0)*(qsatl(0)-qaf(3)) + fevproof = fevproof*fwet_roof + + IF (botlay == 2) THEN + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + fc(3)*lsai/rb(3) + + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + fc(3)/rv + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + + cwsuns = rhoair*cpair/rb(1) & + *( 1. - fc(1)/(cT*rb(1)*(1-bT/(cT*rd(3)))) ) + + cwshas = rhoair*cpair/rb(2) & + *( 1. - fc(2)/(cT*rb(2)*(1-bT/(cT*rd(3)))) ) + + croofs = rhoair*cpair/rb(0) & + *( 1. - fc(0)*bT*bT / (cT*rb(0)*(1-bT/(cT*rd(3)))) & + - fc(0) / (rb(0)*(1/rah+1/rd(3)+fc(0)/rb(0))) ) + + croofl = rhoair*fwet_roof/rb(0)*qsatldT(0) & + * ( 1. - fwet_roof*fc(0)*bQ*bQ / (cQ*rb(0)*(1-bQ/(cQ*rd(3)))) & + - fwet_roof*fc(0) / (rb(0)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) ) + + croof = croofs + croofl*htvp_roof + ELSE + + cT = 1/rd(3) + 1/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + bT = 1/(rd(3)*(1/rah+1/rd(3)+fc(0)/rb(0))) + + cQ = 1/rd(3) + 1/rd(2) + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + + cwsuns = rhoair*cpair/rb(1) & + *( 1. - fc(1)/(cT*rb(1)*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) ) + + cwshas = rhoair*cpair/rb(2) & + *( 1. - fc(2)/(cT*rb(2)*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) ) + + croofs = rhoair*cpair/rb(0) & + *( 1. - fc(0)*bT*bT/(cT*rb(0)*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) & + - fc(0)/(rb(0)*(1/rah+1/rd(3)+fc(0)/rb(0))) ) + + croofl = rhoair*fwet_roof/rb(0)*qsatldT(0) & + *( 1. - fwet_roof*fc(0)/(rb(0)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) & + - fwet_roof*fc(0)*bQ*bQ/(rb(0)*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + + croof = croofs + croofl*htvp_roof + ENDIF + +!----------------------------------------------------------------------- +! fluxes from urban ground to canopy space +!----------------------------------------------------------------------- + + fsengimp = cpair*rhoair/rd(botlay)*(tgimp-taf(botlay)) + fsengper = cpair*rhoair/rd(botlay)*(tgper-taf(botlay)) + + fevpgper = rhoair/(rd(botlay)+rss_)*(qgper-qaf(botlay)) + fevpgimp = rhoair/rd(botlay) *(qgimp-qaf(botlay)) + + fevpgimp = fevpgimp*fwet_gimp + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature +!----------------------------------------------------------------------- + + IF (botlay == 2) THEN + cgrnds = cpair*rhoair/rd(2)*( 1. - fg/(cT*rd(2)*(1-bT/(cT*rd(3)))) ) + + cgperl = rhoair/(rd(2)+rss_)*dqgperdT*(1-fg*fgper/(cQ*(rd(2)+rss_)*(1-bQ/(cQ*rd(3)))) ) + cgimpl = rhoair/rd(2) *dqgimpdT*(1-fwet_gimp*fg*fgimp/(cQ*rd(2)*(1-bQ/(cQ*rd(3)))) ) + cgimpl = cgimpl*fwet_gimp + + ELSE !botlay == 1 + cgrnds = cpair*rhoair/rd(1)* & + ( 1. - fg/(rd(1)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) & + - fg*aT*aT/(rd(1)*cT*(1-aT/(cT*rd(2))-bT/(cT*rd(3)))) ) + + cgperl = rhoair/(rd(1)+rss_)*dqgperdT & + *( 1. - fg*fgper/((rss_+rd(1))*(1/rd(2)+fg*fgper/(rss_+rd(1)) & + +fg*fgimp*fwet_gimp/rd(1)+fc(3)/rv)) & + - fg*fgper*aQ*aQ/((rss_+rd(1))*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + + cgimpl = rhoair/rd(1)*dqgimpdT & + *( 1. - fg*fgimp*fwet_gimp/(rd(1)*(1/rd(2)+fg*fgper/(rss_+rd(1)) & + +fg*fgimp*fwet_gimp/rd(1)+fc(3)/rv)) & + - fg*fgimp*fwet_gimp*aQ*aQ/(rd(1)*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + cgimpl = cgimpl*fwet_gimp + ENDIF + + cgimp = cgrnds + cgimpl*htvp_gimp + cgper = cgrnds + cgperl*htvp_gper + +!----------------------------------------------------------------------- +! 2 m height air temperature above apparent sink height +!----------------------------------------------------------------------- + + !tref = thm + vonkar/(fh)*dth * (fh2m/vonkar - fh/vonkar) + !qref = qm + vonkar/(fq)*dqh * (fq2m/vonkar - fq/vonkar) + + ! assumption: (tg-t2m):(tg-taf) = 2:(displa+z0m) + IF (numlay == 2) THEN + tref = ( (displau+z0mu-2.)*tg + 2.*taf(2) ) / (displau+z0mu) + qref = ( (displau+z0mu-2.)*qg + 2.*qaf(2) ) / (displau+z0mu) + ELSE + tref = (((displau+z0mu+displav+z0mv)*0.5-2.)*tg + taf(1) + taf(2) ) & + / ( (displau+z0mu+displav+z0mv)*0.5 ) + qref = (((displau+z0mu+displav+z0mv)*0.5-2.)*qg + qaf(1) + qaf(2) ) & + / ( (displau+z0mu+displav+z0mv)*0.5 ) + ENDIF + + END SUBROUTINE UrbanVegFlux +!---------------------------------------------------------------------- + + + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! determine fraction of foliage covered by water and +! fraction of foliage that is dry and transpiring +! +! !REVISIONS: +! +! 2024.04.16, Hua Yuan: add option to account for vegetation snow process +! 2018.06 , Hua Yuan: remove sigf, to compatible with PFT +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water&snow [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) :: lsai !lai + sai + real(r8) :: dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) :: vegt !sigf*lsai, NOTE: remove sigf + real(r8) :: fwet_rain !fraction of foliage covered by water [-] + real(r8) :: fwet_snow !fraction of foliage covered by snow [-] +! +!----------------------------------------------------------------------- +! Fwet is the fraction of all vegetation surfaces which are wet +! including stem area which contribute to evaporation + lsai = lai + sai + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 + ! Check for maximum limit of fwet + fwet = min(fwet,1.0) + ENDIF + + ! account for vegetation snow + ! calculate fwet_rain, fwet_snow, fwet + IF ( DEF_VEG_SNOW ) THEN + + fwet_rain = 0 + IF(ldew_rain > 0.) THEN + fwet_rain = ((dewmxi/vegt)*ldew_rain)**.666666666666 + ! Check for maximum limit of fwet_rain + fwet_rain = min(fwet_rain,1.0) + ENDIF + + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((dewmxi/(48.*vegt))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + fwet = fwet_rain + fwet_snow - fwet_rain*fwet_snow + fwet = min(fwet,1.0) + ENDIF + + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai + + END SUBROUTINE dewfraction + +END MODULE MOD_Urban_Flux +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 new file mode 100644 index 0000000000..53a5cba0e9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 @@ -0,0 +1,229 @@ +#include + +MODULE MOD_Urban_GroundFlux + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanGroundFlux + +CONTAINS + + SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, zlnd, zsno, fsno_gimp, & + lbi, wliq_gimpsno,wice_gimpsno, & + fcover, tgimp, tgper, qgimp, qgper, tref, qref, & + z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) + +!======================================================================= +! +! !DESCRIPTION: +! This is the main subroutine to execute the calculation +! of bare ground fluxes +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! 07/2022, Hua Yuan: Urban 2m T/q -> above bare ground 2m. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: & + lbi + real(r8), intent(in) :: & + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno_gimp, &! fraction of impervious ground covered by snow + fcover(0:5), &! coverage of aboveground urban components [-] + + wliq_gimpsno, &! liqui water [kg/m2] + wice_gimpsno, &! ice lens [kg/m2] + + tgimp, &! ground impervious temperature [K] + tgper, &! ground pervious temperature [K] + qgimp, &! ground impervious specific humidity [kg/kg] + qgper ! ground pervious specific humidity [kg/kg] + + real(r8), intent(out) :: & + tref, &! 2 m height air temperature [kelvin] + qref ! 2 m height air humidity + + real(r8), intent(out) :: & + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + tg, &! ground surface temperature [K] + qg, &! ground specific humidity [kg/kg] + fg, &! ground fractional cover [-] + fgimp, &! weight of impervious ground + fgper, &! weight of pervious ground + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] + + real(r8) fwet_gimp, fwetfac + +!----------------------------------------------------------------------- + +! initial roughness length + !NOTE: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gimp > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg + +! potential temperature at the reference height + beta = 1. !- (in computing W_*) + zii = 1000. !m (pbl height) + z0m = z0mg + + fg = 1 - fcover(0) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + + ! weighted tg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction impervious ground + !------------------------------------------- + IF (lbi < 1) THEN + fwet_gimp = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp = min(1., fwet_gimp) + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ENDIF + + ! weighted qg + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper)/fwetfac + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-tg + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters !begin stability iteration + !---------------------------------------------------------------- + displax = 0. + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF (zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta >= 0.) THEN + um = max(ur,0.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION !end stability iteration + !---------------------------------------------------------------- + + zol = zeta + !rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! 2 m height air temperature + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE UrbanGroundFlux + +END MODULE MOD_Urban_GroundFlux +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 new file mode 100644 index 0000000000..63df6cac35 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 @@ -0,0 +1,419 @@ +#include + +MODULE MOD_Urban_Hydrology +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The urban hydrological processes mainly falls into three categories: +! 1) previous surfaces; 2) roofs and imperious surfaces; 3) urban water +! bodies (lakes). +! +! For pervious surfaces, the process is similar to soil water +! processes, involving the calculation of runoff and soil water +! transport. For urban water bodies, a lake model is used for +! simulation. For roofs and impermeable surfaces, snow accumulation and +! ponding processes are considered. The snow accumulation process is +! consistent with soil snow processes. The ponding process considers +! the surface as an impermeable area, with the maximum capacity of +! liquid water not exceeding a predetermined value (max ponding = 1 kg +! m−2). Any excess water is treated as runoff. The coverage ratio of +! ponded areas is calculated using a similar leaf wetness index +! calculation scheme. +! +! Create by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +! 10/2022, Hua Yuan: Add wet fraction for roof and impervious ground; +! set max ponding for roof and impervious from 10mm -> 1mm. +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanHydrology + +CONTAINS + + SUBROUTINE UrbanHydrology ( & + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,snll ,deltim ,& + ! forcing + pg_rain ,pgper_rain ,pgimp_rain ,pg_snow ,& + pg_rain_lake ,pg_snow_lake ,& + ! surface parameters or status + froof ,fgper ,flake ,bsw ,& + porsl ,psi0 ,hksati ,pondmx ,& + ssi ,wimp ,smpmin ,theta_r ,& + fsatmax ,fsatdcf ,elvstd ,BVIC ,& + rootr,rootflux ,etr ,fseng ,fgrnd ,& + t_gpersno ,t_lakesno ,t_lake ,dz_lake ,& + z_gpersno ,z_lakesno ,zi_gpersno ,zi_lakesno ,& + dz_roofsno ,dz_gimpsno ,dz_gpersno ,dz_lakesno ,& + wliq_roofsno ,wliq_gimpsno ,wliq_gpersno ,wliq_lakesno ,& + wice_roofsno ,wice_gimpsno ,wice_gpersno ,wice_lakesno ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + lake_icefrac ,scv_lake ,snowdp_lake ,imelt_lake ,& + fioldl ,w_old ,& +#if (defined CaMa_Flood) + flddepth ,fldfrc ,qinfl_fld ,& +#endif + forc_us ,forc_vs ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! END SNICAR model variables +! irrigaiton + qflx_irrig_drip,qflx_irrig_flood,qflx_irrig_paddy ,& + ! output + rsur ,rnof ,qinfl ,zwt ,& + wdsrf ,wa ,qcharge ,smp ,hk) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of URBAN +! hydrological processes +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_SoilSnowHydrology + USE MOD_Lake + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,&! patch index + patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=land water bodies, 99=ocean + lbr ,&! lower bound of array + lbi ,&! lower bound of array + lbp ,&! lower bound of array + lbl ! lower bound of array + + integer, intent(inout) :: & + snll ! number of snow layers + + real(r8), intent(in) :: & + deltim ,&! time step (s) + pg_rain ,&! rainfall after removal of interception (mm h2o/s) + pg_snow ,&! snowfall after removal of interception (mm h2o/s) + pgper_rain ,&! rainfall after removal of interception (mm h2o/s) + pgimp_rain ,&! rainfall after removal of interception (mm h2o/s) + pg_rain_lake ,&! rainfall onto lake (mm h2o/s) + pg_snow_lake ,&! snowfall onto lake (mm h2o/s) + froof ,&! roof fractional cover [-] + fgper ,&! weight of impervious ground [-] + flake ,&! lake fractional cover [-] + ! wtfact ,&! fraction of model area with high water table + ! (updated to gridded 'fsatmax' data) + pondmx ,&! ponding depth (mm) + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable IF porosity less than wimp + smpmin ,&! restriction for min of soil poten. (mm) + + elvstd ,&! standard deviation of elevation [m] + BVIC ,&! b parameter in Fraction of saturated soil in a grid calculated by VIC + + bsw (1:nl_soil) ,&! Clapp-Hornberger "B" + porsl (1:nl_soil) ,&! saturated volumetric soil water content(porosity) + psi0 (1:nl_soil) ,&! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil) ,&! hydraulic conductivity at saturation (mm h2o/s) + theta_r(1:nl_soil) ,&! residual moisture content [-] + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + rootr (1:nl_soil) ,&! root resistance of a layer, all layers add to 1.0 + + etr ,&! vegetation transpiration + qseva_roof ,&! ground surface evaporation rate (mm h2o/s) + qseva_gimp ,&! ground surface evaporation rate (mm h2o/s) + qseva_gper ,&! ground surface evaporation rate (mm h2o/s) + qseva_lake ,&! ground surface evaporation rate (mm h2o/s) + qsdew_roof ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gimp ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gper ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_lake ,&! ground surface dew formation (mm h2o /s) [+] + qsubl_roof ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gimp ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gper ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_lake ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_roof ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_lake ,&! surface dew added to snow pack (mm h2o /s) [+] + sm_roof ,&! snow melt (mm h2o/s) + sm_gimp ,&! snow melt (mm h2o/s) + sm_gper ,&! snow melt (mm h2o/s) + w_old ! liquid water mass of the column at the previous time step (mm) + + real(r8), intent(inout) :: rootflux(1:nl_soil) + +#if (defined CaMa_Flood) + real(r8), intent(inout) :: flddepth ! inundation water depth [mm] + real(r8), intent(in) :: fldfrc ! inundation water depth [0-1] + real(r8), intent(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) +#endif + + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023) + ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8), intent(in) :: forc_aer (14) + + real(r8), intent(inout) :: & + mss_bcpho (lbp:0) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lbp:0) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lbp:0) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lbp:0) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lbp:0) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lbp:0) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lbp:0) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lbp:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +! For irrigation + real(r8), intent(in) :: & + qflx_irrig_drip ,&! drip irrigation rate [mm/s] + qflx_irrig_flood ,&! flood irrigation rate [mm/s] + qflx_irrig_paddy ! paddy irrigation rate [mm/s] +! END irrigation + + integer, intent(in) :: & + imelt_lake(maxsnl+1:nl_soil) ! lake flag for melting or freezing snow and soil layer [-] + + real(r8), intent(inout) :: & + lake_icefrac( 1:nl_lake) ,&! lake ice fraction + fioldl (maxsnl+1:nl_soil) ,&! fraction of ice relative to the total water content [-] + dz_lake ( 1:nl_lake) ,&! lake layer depth [m] + z_gpersno (lbp:nl_soil) ,&! layer depth (m) + dz_roofsno (lbr:nl_roof) ,&! layer thickness (m) + dz_gimpsno (lbi:nl_soil) ,&! layer thickness (m) + dz_gpersno (lbp:nl_soil) ,&! layer thickness (m) + zi_gpersno(lbp-1:nl_soil) ,&! interface level below a "z" level (m) + t_lake ( 1:nl_lake) ,&! lake temperature [K] + t_gpersno (lbp:nl_soil) ,&! soil/snow skin temperature (K) + wliq_roofsno(lbr:nl_roof) ,&! liquid water (kg/m2) + wliq_gimpsno(lbi:nl_soil) ,&! liquid water (kg/m2) + wliq_gpersno(lbp:nl_soil) ,&! liquid water (kg/m2) + wice_roofsno(lbr:nl_roof) ,&! ice lens (kg/m2) + wice_gimpsno(lbi:nl_soil) ,&! ice lens (kg/m2) + wice_gpersno(lbp:nl_soil) ,&! ice lens (kg/m2) + + zi_lakesno (maxsnl :nl_soil),&! interface level below a "z" level (m) + t_lakesno (maxsnl+1:nl_soil),&! soil/snow skin temperature (K) + z_lakesno (maxsnl+1:nl_soil),&! layer depth (m) + dz_lakesno (maxsnl+1:nl_soil),&! layer thickness (m) + wliq_lakesno(maxsnl+1:nl_soil),&! liquid water (kg/m2) + wice_lakesno(maxsnl+1:nl_soil),&! ice lens (kg/m2) + + sm_lake ,&! snow melt (mm h2o/s) + scv_lake ,&! lake snow mass (kg/m2) + snowdp_lake ,&! lake snow depth + fseng ,&! sensible heat from ground + fgrnd ,&! ground heat flux + zwt ,&! the depth from ground (soil) surface to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ! water storage in aquifer [mm] + + real(r8), intent(out) :: & + rsur ,&! surface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qinfl ,&! infiltration rate (mm h2o/s) + qcharge ! groundwater recharge (positive to aquifer) [mm/s] + + real(r8), intent(out) :: & + smp(1:nl_soil) ,&! soil matrix potential [mm] + hk (1:nl_soil) ! hydraulic conductivity [mm h2o/m] + +!-------------------------- Local Variables ---------------------------- + + real(r8) :: & + fg ,&! ground fractional cover [-] + gwat ,&! net water input from top (mm/s) + rnof_roof ,&! total runoff (mm h2o/s) + rnof_gimp ,&! total runoff (mm h2o/s) + rnof_gper ,&! total runoff (mm h2o/s) + rnof_lake ,&! total runoff (mm h2o/s) + rsur_roof ,&! surface runoff (mm h2o/s) + rsur_gimp ,&! surface runoff (mm h2o/s) + rsur_gper ,&! surface runoff (mm h2o/s) + rsur_lake ,&! surface runoff (mm h2o/s) + dfseng ,&! change of lake sensible heat [W/m2] + dfgrnd ! change of lake ground heat flux [W/m2] + + real(r8) :: a, aa, xs1 + +!----------------------------------------------------------------------- + + fg = 1 - froof + dfseng = 0. + dfgrnd = 0. + +!======================================================================= +! [1] for pervious road, the same as soil +!======================================================================= + + rootflux(:) = rootr(:)*etr + + CALL WATER_2014 (ipatch,patchtype,lbp ,nl_soil ,deltim ,& + z_gpersno ,dz_gpersno ,zi_gpersno ,bsw ,porsl ,& + psi0 ,hksati ,theta_r ,fsatmax ,fsatdcf ,& + elvstd ,BVIC ,rootr ,rootflux ,t_gpersno ,& + wliq_gpersno,wice_gpersno,smp ,hk ,pgper_rain ,& + sm_gper ,etr ,qseva_gper ,qsdew_gper ,qsubl_gper ,& + qfros_gper ,& + !NOTE: temporal input, as urban mode doesn't support split soil&snow + ! set all the same for soil and snow surface, + ! and fsno=0. (no physical meaning here) + qseva_gper ,qsdew_gper ,qsubl_gper ,qfros_gper ,& + qseva_gper ,qsdew_gper ,qsubl_gper ,qfros_gper ,& + 0. ,& ! fsno, not active + rsur_gper ,rnof_gper ,qinfl ,pondmx ,ssi ,& + wimp ,smpmin ,zwt ,wdsrf ,wa ,qcharge ,& +#if (defined CaMa_Flood) + flddepth ,fldfrc ,qinfl_fld ,& +#endif +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! irrigation variables + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ) + +!======================================================================= +! [2] for roof and impervious road +!======================================================================= + + IF (lbr >= 1) THEN + gwat = pg_rain + sm_roof - qseva_roof + ELSE + CALL snowwater (lbr,deltim,ssi,wimp,& + pg_rain,qseva_roof,qsdew_roof,qsubl_roof,qfros_roof,& + dz_roofsno(lbr:0),wice_roofsno(lbr:0),wliq_roofsno(lbr:0),gwat) + ENDIF + + wliq_roofsno(1) = wliq_roofsno(1) + gwat*deltim + + ! Renew the ice and liquid mass due to condensation + IF (lbr >= 1) THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_roofsno(1) = max(0., wliq_roofsno(1) + qsdew_roof * deltim) + wice_roofsno(1) = max(0., wice_roofsno(1) + (qfros_roof-qsubl_roof) * deltim) + ENDIF + + ! only consider ponding and surface runoff + ! NOTE: set max ponding depth = 1mm (liq+ice) + xs1 = wliq_roofsno(1) - 1. + IF (xs1 > 0.) THEN + wliq_roofsno(1) = 1. + ELSE + xs1 = 0. + ENDIF + + rsur_roof = xs1 / deltim + rnof_roof = rsur_roof + + ! ================================================ + + IF (lbi >= 1) THEN + gwat = pgimp_rain + sm_gimp - qseva_gimp + ELSE + CALL snowwater (lbi,deltim,ssi,wimp,& + pgimp_rain,qseva_gimp,qsdew_gimp,qsubl_gimp,qfros_gimp,& + dz_gimpsno(lbi:0),wice_gimpsno(lbi:0),wliq_gimpsno(lbi:0),gwat) + ENDIF + + wliq_gimpsno(1) = wliq_gimpsno(1) + gwat*deltim + + ! Renew the ice and liquid mass due to condensation + IF (lbi >= 1) THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_gimpsno(1) = max(0., wliq_gimpsno(1) + qsdew_gimp * deltim) + wice_gimpsno(1) = max(0., wice_gimpsno(1) + (qfros_gimp-qsubl_gimp) * deltim) + ENDIF + + ! only consider ponding and surface runoff + ! NOTE: set max ponding depth = 1mm + xs1 = wliq_gimpsno(1) - 1. + IF (xs1 > 0.) THEN + wliq_gimpsno(1) = 1. + ELSE + xs1 = 0. + ENDIF + + rsur_gimp = xs1 / deltim + rnof_gimp = rsur_gimp + +!======================================================================= +! [3] lake hydrology +!======================================================================= + + CALL snowwater_lake ( DEF_USE_Dynamic_Lake, & + ! "in" snowater_lake arguments + ! --------------------------- + maxsnl ,nl_soil ,nl_lake ,deltim ,& + ssi ,wimp ,porsl ,pg_rain_lake ,& + pg_snow_lake ,dz_lake ,imelt_lake(:0) ,fioldl(:0) ,& + qseva_lake ,qsubl_lake ,qsdew_lake ,qfros_lake ,& + + ! "inout" snowater_lake arguments + ! --------------------------- + z_lakesno ,dz_lakesno ,zi_lakesno ,t_lakesno ,& + wice_lakesno ,wliq_lakesno ,t_lake ,lake_icefrac ,& + gwat ,& + dfseng ,dfgrnd ,snll ,scv_lake ,& + snowdp_lake ,sm_lake ,forc_us ,forc_vs ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! END SNICAR model variables + urban_call=.true.) + + ! We assume the land water bodies have zero extra liquid water capacity + ! (i.e.,constant capacity), all excess liquid water are put into the runoff, + ! this unreasonable assumption should be updated in the future version + a = (sum(wliq_lakesno(snll+1:))-w_old)/deltim + aa = qseva_lake-(qsubl_lake-qsdew_lake) + rsur_lake = max(0., pg_rain_lake - aa - a) + rnof_lake = rsur_lake + + ! Set zero to the empty node + IF (snll > maxsnl) THEN + wice_lakesno(maxsnl+1:snll) = 0. + wliq_lakesno(maxsnl+1:snll) = 0. + t_lakesno (maxsnl+1:snll) = 0. + z_lakesno (maxsnl+1:snll) = 0. + dz_lakesno (maxsnl+1:snll) = 0. + ENDIF + + fseng = fseng + dfseng*flake + fgrnd = fgrnd + dfgrnd*flake + +!======================================================================= +! [4] surface and total runoff weighted by fractional coverages +!======================================================================= + + ! 10/01/2021, yuan: exclude lake part + rsur = rsur_roof*froof + rsur_gimp*fg*(1-fgper) + rsur_gper*fg*fgper + !rsur = rsur*(1.-flake) + rsur_lake*flake + rnof = rnof_roof*froof + rnof_gimp*fg*(1-fgper) + rnof_gper*fg*fgper + !rnof = rnof*(1.-flake) + rnof_lake*flake + + END SUBROUTINE UrbanHydrology + +END MODULE MOD_Urban_Hydrology +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 new file mode 100644 index 0000000000..b6fdf67f96 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 @@ -0,0 +1,304 @@ +#include + +MODULE MOD_Urban_ImperviousTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The main difference between calculating the temperature conduction +! for an impervious ground and a pervious surface lies in the need to +! USE the thermal properties (thermal conductivity and heat capacity) +! of the imperious surface layer instead of the soil thermal +! properties. Additionally, when snow, ice, and water are present, the +! heat capacity of the first impervious surface layer needs to be +! adjusted. The impervious surface does not consider the transmission +! of water below the surface, and the phase change process only +! considers the first impervious surface layer (surface water/ice) and +! the overlying snow cover layer. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanImperviousTem + +CONTAINS + + SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& + cv_gimp,tk_gimp,dz_gimpsno,z_gimpsno,zi_gimpsno,& + t_gimpsno,wice_gimpsno,wliq_gimpsno,scv_gimp,snowdp_gimp,& + lgimp,clgimp,sabgimp,fsengimp,fevpgimp,cgimp,htvp,& + imelt,sm,xmf,fact) + +!======================================================================= +! Snow and impervious road temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of road soil is computed from +! the algorithm of Johansen (as reported by Farouki 1981), impervious +! and pervious from LOOK-UP table and of snow is from the formulation +! used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), F = 0 (base of the soil column). +! o Soil / snow temperature is predicted from heat conduction +! in 10 soil layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers (j,j+1) +! are derived from an assumption that the flux across the interface is +! equal to that from the node j to the interface and the flux from the +! interface to the node j+1. The equation is solved using the +! Crank-Nicholson method and resulted in a tridiagonal system +! equation. +! +! Phase change (see MOD_PhaseChange.F90) +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_SoilThermalParameters + USE MOD_PhaseChange, only: meltf_urban + USE MOD_Utils, only: tridia + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor: turn 1st layer T to surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals [W/m-K] + real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] + + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of sat soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal cond. of sat frozen soil [W/m-K] + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric frac of quartz in mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric frac of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric frac of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric frac of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric frac of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric frac of sand + + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal cond. + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal cond. + + real(r8), intent(in) :: cv_gimp (1:nl_soil) !heat capacity of urban impervious [J/m3/K] + real(r8), intent(in) :: tk_gimp (1:nl_soil) !thermal cond. of urban impervious [W/m/K] + + real(r8), intent(in) :: dz_gimpsno(lb :nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_gimpsno (lb :nl_soil) !node depth [m] + real(r8), intent(in) :: zi_gimpsno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabgimp !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: lgimp !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: clgimp !deriv. of longwave wrt to soil temp [w/m2/k] + real(r8), intent(in) :: fsengimp !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpgimp !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgimp !deriv. of gimp energy flux to T [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_gimpsno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_gimpsno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_gimpsno(lb:nl_soil) !liqui water [kg/m2] + real(r8), intent(inout) :: scv_gimp !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_gimp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change in soil + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] + + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + real(r8) rhosnow !partial density of water (ice + liquid) + + real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_gimpsno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_soil) !temporary set + + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice (1:nl_soil) !volumetric fraction ice len within soil + + integer i,j + +!----------------------------------------------------------------------- + + wice_gimpsno(2:) = 0.0 !ice lens [kg/m2] + wliq_gimpsno(2:) = 0.0 !liquid water [kg/m2] + +!======================================================================= +! soil ground and wetland heat capacity + DO i = 1, nl_soil + vf_water(i) = wliq_gimpsno(i)/(dz_gimpsno(i)*denh2o) + vf_ice(i) = wice_gimpsno(i)/(dz_gimpsno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_gimpsno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_gimpsno(i) + ENDDO + IF(lb==1 .and. scv_gimp>0.) cv(1) = cv(1) + cpice*scv_gimp + +! Snow heat capacity + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_gimpsno(:0) + cpice*wice_gimpsno(:0) + ENDIF + +! Snow thermal conductivity + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_gimpsno(i)+wliq_gimpsno(i))/dz_gimpsno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + IF((i==0) .and. (z_gimpsno(i+1)-zi_gimpsno(i) 0.) tk(1:) = tk_gimp(1:) + WHERE (cv_gimp > 0.) cv(1:) = cv_gimp(1:)*dz_gimpsno(1:) + + ! snow exist when there is no snow layer + IF (lb == 1 .and. scv_gimp > 0.0) THEN + cv(1) = cv(1) + cpice*scv_gimp + ENDIF + + ! ponding water or ice exist + cv(1) = cv(1) + cpliq*wliq_gimpsno(1) + cpice*wice_gimpsno(1) + +! net ground heat flux into the surface and its temperature derivative + hs = sabgimp + lgimp - (fsengimp+fevpgimp*htvp) + dhsdT = - cgimp + clgimp + + t_gimpsno_bef(lb:) = t_gimpsno(lb:) + + j = lb + fact(j) = deltim / cv(j) * dz_gimpsno(j) & + / (0.5*(z_gimpsno(j)-zi_gimpsno(j-1)+capr*(z_gimpsno(j+1)-zi_gimpsno(j-1)))) + + DO j = lb + 1, nl_soil + fact(j) = deltim/cv(j) + ENDDO + + DO j = lb, nl_soil - 1 + fn(j) = tk(j)*(t_gimpsno(j+1)-t_gimpsno(j))/(z_gimpsno(j+1)-z_gimpsno(j)) + ENDDO + fn(nl_soil) = 0. + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = lb + dzp = z_gimpsno(j+1)-z_gimpsno(j) + at(j) = 0. + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + rt(j) = t_gimpsno(j) + fact(j)*( hs - dhsdT*t_gimpsno(j) + cnfac*fn(j) ) + + + DO j = lb + 1, nl_soil - 1 + dzm = (z_gimpsno(j)-z_gimpsno(j-1)) + dzp = (z_gimpsno(j+1)-z_gimpsno(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_gimpsno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO + + j = nl_soil + dzm = (z_gimpsno(j)-z_gimpsno(j-1)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*tk(j-1)/dzm + ct(j) = 0. + rt(j) = t_gimpsno(j) - cnfac*fact(j)*fn(j-1) + +! solve for t_gimpsno + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_gimpsno) + +!======================================================================= +! melting or freezing +!======================================================================= + + DO j = lb, nl_soil - 1 + fn1(j) = tk(j)*(t_gimpsno(j+1)-t_gimpsno(j))/(z_gimpsno(j+1)-z_gimpsno(j)) + ENDDO + fn1(nl_soil) = 0. + + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + + DO j = lb + 1, nl_soil + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO + + CALL meltf_urban (lb,1,deltim, & + fact(lb:1),brr(lb:1),hs,dhsdT, & + t_gimpsno_bef(lb:1),t_gimpsno(lb:1), & + wliq_gimpsno(lb:1),wice_gimpsno(lb:1),imelt(lb:1), & + scv_gimp,snowdp_gimp,sm,xmf) + + END SUBROUTINE UrbanImperviousTem + +END MODULE MOD_Urban_ImperviousTemperature +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 new file mode 100644 index 0000000000..11ca8b7c42 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 @@ -0,0 +1,83 @@ +#include + +#ifdef URBAN_MODEL +MODULE MOD_Urban_LAIReadin + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanLAI_readin + +CONTAINS + + SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in urban LAI, SAI and urban tree cover data. +! +! Create by Hua Yuan, 11/2021 +! +! +! !REVISIONS: +! 08/2023, Wenzong Dong: add codes to read urban tree LAI. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global + USE MOD_Const_LC + USE MOD_Vars_TimeVariables + USE MOD_Vars_TimeInvariants + USE MOD_Urban_Vars_TimeInvariants + USE MOD_NetCDFVector + USE MOD_UserDefFun +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: year + integer, intent(in) :: time + character(len=256), intent(in) :: dir_landdata + + character(len=256) :: lndname + character(len=256) :: cyear, ctime + integer :: u, npatch, iyear + + ! READ in Leaf area index and stem area index + write(ctime,'(i2.2)') time + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + +#ifdef SinglePoint + iyear = findloc_ud(SITE_LAI_year == min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year)) ) + urb_lai(:) = SITE_LAI_monthly(time,iyear) + urb_sai(:) = SITE_SAI_monthly(time,iyear) +#else + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_LAI_'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'TREE_LAI', landurban, urb_lai) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_SAI_'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) +#endif + ! loop for urban patch to assign fraction of green leaf + IF (p_is_worker) THEN + DO u = 1, numurban + npatch = urban2patch(u) + tlai(npatch) = urb_lai(u) + tsai(npatch) = urb_sai(u) + urb_green(u) = 1. !TODO: usage? fraction of green leaf + green(npatch)= 1. !fraction of green leaf + ENDDO + ENDIF + + END SUBROUTINE UrbanLAI_readin + +END MODULE MOD_Urban_LAIReadin +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 new file mode 100644 index 0000000000..a07505998b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 @@ -0,0 +1,181 @@ +#include + +MODULE MOD_Urban_LUCY +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! Anthropogenic model to calculate anthropogenic heat flux for the rest +! +! Original: Wenzong Dong, May, 2022 +! +! ----------------------------------------------------------------------- +! !USE + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_TimeManager + IMPLICIT NONE + SAVE + PUBLIC :: LUCY + +CONTAINS + + SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & + week_holiday, hum_prof, wdh_prof , weh_prof , pop_den, & + vehicle , Fahe , vehc , meta ) + +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! Anthropogenic heat fluxes other than building heat were calculated +! +! !REFERENCES: +! 1) Grimmond, C. S. B. (1992). The suburban energy balance: +! Methodological considerations and results for a mid-latitude west +! coast city under winter and spring conditions. International Journal +! of Climatology, 12(5), 481-497. https://doi.org/10.1002/joc.3370120506 +! +! 2) Allen, L., Lindberg, F., & Grimmond, C. S. B. (2011). Global to +! city scale urban anthropogenic heat flux: Model and variability. +! International Journal of Climatology, 31(13), 1990-2005. +! https://doi.org/10.1002/joc.2210 +! +! ----------------------------------------------------------------------- + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: & + idate(3) ! calendar (year, julian day, seconds) + + real(r8), intent(in) :: & + fix_holiday(365) ,&! Fixed public holidays, holiday(0) or workday(1) + week_holiday(7) ! week holidays + + real(r8), intent(in) :: & + deltim ,&! seconds in a time step [second] + patchlonr ,&! longitude of patch [radian] + hum_prof(24) ,&! Diurnal metabolic heat profile [W/person] + wdh_prof(24) ,&! Diurnal traffic flow profile of weekday + weh_prof(24) ,&! Diurnal traffic flow profile of weekend + pop_den ,&! population density [person per square kilometer] + vehicle(3) ! vehicle numbers per thousand people + + real(r8) :: & + vehc_prof(24,2) ,&! + carscell ,&! cars numbers per thousand people + frescell ,&! freights numbers per thousand people + mbkscell ! motobikes numbers per thousand people + + real(r8), intent(out) :: & + Fahe ,&! flux from metabolic and vehicle + vehc ,&! flux from vehicle + meta ! flux from metabolic + + real(r8) :: & + londeg ,&! longitude of path [degree] + car_sp ,&! distance traveled [km] + traf_frac ,&! vehicle heat profile of hour [-] + meta_prof ,&! metabolic heat profile of hour [-] + carflx ,&! flux from car [W/m2] + motflx ,&! flux from motorbike [W/m2] + freflx ! flux from freight [W/m2] + +!-------------------------- Local Variables ---------------------------- + real(r8):: ldate(3) ! local time (year, julian day, seconds) + integer :: & + iweek ,&! day of week + ihour ,&! hour of day + day ,&! day of month + month ,&! month of year + day_inx ,&! holiday index, day=1(workday), day=1(holiday) + EC ,&! emission factor of car [J/m] + EF ,&! emission factor of freight [J/m] + EM ! emission factor of motorbike [J/m] + +!----------------------------------------------------------------------- + + ! initialization + meta = 0. + vehc = 0. + Fahe = 0. + + ! set vehicle distance traveled + car_sp = 50 + + ! emission factor Sailor and Lu (2004), + ! all vehicle are set to same value + EC = 3975 + EM = 3975 + EF = 3975 + + IF (DEF_simulation_time%greenwich) THEN + ! convert GMT time to local time + londeg = patchlonr*180/PI + CALL gmt2local(idate, londeg, ldate) + ENDIF + + vehc_prof(:,1) = wdh_prof + vehc_prof(:,2) = weh_prof + + CALL julian2monthday(int(ldate(1)), int(ldate(2)), month, day) + CALL timeweek(int(ldate(1)), month, day, iweek) + + ihour = CEILING(ldate(3)*1./3600) + + IF (day==366) day=365 + IF (fix_holiday(day)==0 .or. week_holiday(iweek)==0) THEN + day_inx = 1 + ELSE + day_inx = 2 + ENDIF + + ! set traffic flow to be used of this time step + traf_frac = vehc_prof(ihour,day_inx) + ! set heat release per people of this time step + meta_prof = hum_prof (ihour) + + carscell = vehicle(1) + mbkscell = vehicle(2) + frescell = vehicle(3) + + ! heat release of metabolism [W/m2] + meta = pop_den*meta_prof/1e6 + ! heat release of cars [W/m2] + IF (carscell > 0) THEN + carflx = carscell*pop_den/1000 + carflx = carflx*traf_frac & + *EC*(car_sp*1000)/1e6 + carflx = carflx/3600 + ELSE + carflx = 0. + ENDIF + + ! heat release of motorbikes [W/m2] + IF (mbkscell > 0) THEN + motflx = mbkscell*pop_den/1000 + motflx = motflx*traf_frac & + *EM*(car_sp*1000)/1e6 + motflx = motflx/3600 + ELSE + motflx = 0. + ENDIF + + ! heat release of freight [W/m2] + IF (frescell > 0)THEN + freflx = frescell*pop_den/1000 + freflx = freflx*traf_frac & + *EF*(car_sp*1000)/1e6 + freflx = freflx/3600 + ELSE + freflx = 0. + ENDIF + + ! total vehicle heat flux + vehc = carflx + motflx + freflx + ! total anthropogenic heat flux exclude building part + Fahe = meta + vehc + + END Subroutine LUCY + +END MODULE MOD_Urban_LUCY +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 new file mode 100644 index 0000000000..760774abef --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 @@ -0,0 +1,678 @@ +#include + +MODULE MOD_Urban_Longwave + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: stefnc + USE MOD_Urban_Shortwave, only: MatrixInverse + USE MOD_Urban_Shortwave, only: ShadowWall_dir + USE MOD_Urban_Shortwave, only: ShadowWall_dif + USE MOD_Urban_Shortwave, only: ShadowTree + USE MOD_3DCanopyRadiation, only: tee, phi + + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanOnlyLongwave !Urban Longwave radiation transfer + PUBLIC :: UrbanVegLongwave !Urban Longwave radiation transfer with trees + +CONTAINS + + SUBROUTINE UrbanOnlyLongwave (theta, HL, fb, fgper, H, LW, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, & + Ainv, B, B1, dBdT, SkyVF, fcover) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| |++++++| +! ______+++++| |++++++| +! |++++++|++++| |++++++| +! sunlit |[]++[]|++++| |++++++| shaded +! wall |++++++| |++++++| wall +! |[]++[]| |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! +! !DESCRIPTION: +! +! The process of long-wave radiation transmission in the absence of +! vegetation is similar to the incident diffuse case of short-wave +! radiation transmission in the absence of vegetation (where long-wave +! radiation is approximated as a diffuse source). The long-wave +! radiation flux reaching each component surface is calculated, as well +! as the long-wave radiation emitted outward from each component +! surface. Multiple scattering and absorption between components are +! considered, and a long-wave radiation transmission equilibrium +! equation is established for solving. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to ground width [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H, &! Building average height [m] + LW, &! Downward longwave radiation [W/m2] + + twsun, &! Temperature of sunlit wall [K] + twsha, &! Temperature of shaded wall [K] + tgimp, &! Temperature of impervious road [K] + tgper, &! Temperature of pervious road [K] + + ewall, &! Emissivity of walls [-] + egimp, &! Emissivity of ground [-] + egper ! Emissivity of ground [-] + + real(r8), intent(out) :: & + Ainv(4,4), &! Inverse of Radiation transfer matrix + B(4), &! Vectors of incident radiation on each surface + B1(4), &! Vectors of incident radiation on each surface + dBdT(4), &! Vectors of incident radiation on each surface + SkyVF(4), &! View factor to sky + fcover(0:4) ! View factor to sky + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + W, &! Urban ground average width [m] + L, &! Urban building average length [m] + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Fraction of snow ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Sw, &! Shadow of wall [-] + fwsun, &! Fraction of sunlit wall [-] + fwsha, &! Fraction of shaded wall [-] + Iwsun, &! Incident radiation on sunlit wall [W/m2] + Iwsha, &! Incident radiation on shaded wall [W/m2] + Ig, &! Incident radiation on ground [W/m2] + Igimp, &! Incident radiation on impervious ground [W/m2] + Igper ! Incident radiation on pervious ground [W/m2] + + real(r8) :: A(4,4) !Radiation transfer matrix + + ! Temporal + real(r8) :: tmp, eb +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + fgimp = 1. - fgper + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! Adjusted as below: + Fws = Fsw*fg/fb/(4*HL) + Fwg = Fsw*fg/fb/(4*HL) + Fww = 1 - Fws - Fwg + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building shadow on the ground + Sw = ShadowWall_dir(fb/fg, HL, theta) + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + ! o A: radiation transfer matrix + ! o B: incident radiation on each surface + ! o X: radiation emit from each surface + !------------------------------------------------- + A(1,:) = (/1-Fww*fwsun*(1-ewall), -Fww*fwsun*(1-ewall), & + -Fgw*fwsun*(1-ewall), -Fgw*fwsun*(1-ewall) /) + + A(2,:) = (/ -Fww*fwsha*(1-ewall), 1-Fww*fwsha*(1-ewall), & + -Fgw*fwsha*(1-ewall), -Fgw*fwsha*(1-ewall) /) + + A(3,:) = (/ -Fwg*fgimp*(1-egimp), -Fwg*fgimp*(1-egimp), & + 1._r8, 0._r8 /) + + A(4,:) = (/ -Fwg*fgper*(1-egper), -Fwg*fgper*(1-egper), & + 0._r8, 1._r8 /) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Incident LW radiation on sunlit/shaded wall and + ! impervious/pervious ground + Iwsun = LW*Fsw*fwsun + Iwsha = LW*Fsw*fwsha + Ig = LW*Fsg + Igimp = Ig*fgimp + Igper = Ig*fgper + + ! Vector of initial LW radiation on each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + !B(1) = Iwsun*(1.-ewall) + 2*fwsun*HW*stefnc*ewall*twsun**4 + !B(2) = Iwsha*(1.-ewall) + 2*fwsha*HW*stefnc*ewall*twsha**4 + B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 + B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 + + B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + !B1(1) = 2*fwsun*HW*stefnc*ewall*twsun**4 + !B1(2) = 2*fwsha*HW*stefnc*ewall*twsha**4 + B1(3) = fgimp*stefnc*egimp*tgimp**4 + B1(4) = fgper*stefnc*egper*tgper**4 + + dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 + dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 + !dBdT(1) = 2*fwsun*HW*stefnc*ewall*twsun**3 + !dBdT(2) = 2*fwsha*HW*stefnc*ewall*twsha**3 + dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 + dBdT(4) = 4*fgper*stefnc*egper*tgper**3 + + SkyVF(1:2) = Fws + SkyVF(3:4) = Fgs + + fcover(0) = fb + fcover(1) = 4*fwsun*HL*fb + fcover(2) = 4*fwsha*HL*fb + fcover(3) = fg*fgimp + fcover(4) = fg*fgper + + !NOTE: the below codes put into the THERMAL.F90 + ! Equation solve + ! X = matmul(Ainv, B) + + ! LW radiation absorption by each surface (per m^2) + !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper + + ! Out-going LW of urban canopy + !lout = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + !lout = sum( X * SkyVF ) + + ! Energy balance check + !eb = lwsun + lwsha + lgimp + lgper + lout + + !IF (abs(eb-LW) > 1e-6) THEN + ! print *, "Longwave - Energy Balance Check error!", eb-LW + !ENDIF + + !NOTE: put it outside, after temperature change of roof, wall and ground + ! absorption change due to temperature change, as restart variables. + !dX = matmul(Ainv, dBdT*dT) + !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*dX(4) - dBdT(4)*dT(4) ) / (1-egper) !/ fgper + + !lout = lout + sum( dX * SkyVF ) + + END SUBROUTINE UrbanOnlyLongwave + + + SUBROUTINE UrbanVegLongwave (theta, HL, fb, fgper, H, LW, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, lai, sai, fv, hv, & + ev, Ainv, B, B1, dBdT, SkyVF, VegVF, fcover) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| ___ |++++++| +! ______+++++| ||||| |++++++| +! |++++++|++++| ||||||| |++++++| +! sunlit |[]++[]|++++| ||||| |++++++| shaded +! wall |++++++| | tree |++++++| wall +! |[]++[]| | |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|___________________________________ +! +! !DESCRIPTION: +! +! The calculation of longwave radiation when considering vegetation +! (trees only) is similar to the shortwave radiation transmission with +! vegetation. On the basis of the longwave radiation transmission +! balance equation without vegetation, a balanced equation with +! vegetation is constructed, and the solution process is similar. +! +! Created by Hua Yuan, 09/2021 +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to ground width [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H, &! Building average height [m] + LW, &! Downward longwave radiation [W/m2] + + twsun, &! Temperature of sunlit wall [K] + twsha, &! Temperature of shaded wall [K] + tgimp, &! Temperature of impervious road [K] + tgper, &! Temperature of pervious road [K] + + ewall, &! Emissivity of walls [-] + egimp, &! Emissivity of ground [-] + egper, &! Emissivity of ground [-] + lai, &! leaf area index [m2/m2] + sai, &! stem area index [m2/m2] + fv, &! Fraction of tree cover [-] + hv ! Crown central height [m] + + real(r8), intent(out) :: & + ev, &! emissivity of vegetation + Ainv(5,5), &! Inverse of Radiation transfer matrix + B(5), &! Vectors of incident radiation on each surface + B1(5), &! Vectors of incident radiation on each surface + dBdT(5), &! Vectors of incident radiation on each surface + SkyVF(5), &! View factor to sky + VegVF(5), &! View factor to sky + fcover(0:5) ! View factor to sky + +!-------------------------- Local Variables ---------------------------- + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + + real(r8) :: & + W, &! Urban ground average width [m] + L, &! Urban building average length [m] + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Fraction of pervious ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Fvg, &! View factor from tree to ground [-] + Fvs, &! View factor from tree to sky [-] + Fvw, &! View factor from tree to walls (sunlit+shaded) [-] + Fwv, &! View factor from wall to tree [-] + Fgv, &! View factor from ground to tree [-] + Fsv, &! View factor from sky to tree [-] + + Fgvs, &! View factor from ground->|tree|-> to sky [-] + Fgvw, &! View factor from ground->|tree|-> to walls [-] + Fsvg, &! View factor from sky->|tree|-> to ground [-] + Fsvw, &! View factor from sky->|tree|-> to walls [-] + Fwvw, &! View factor from walls->|tree|-> to walls [-] + Fwvs, &! View factor from walls->|tree|-> to sky [-] + Fwvg, &! View factor from walls->|tree|-> to ground [-] + + Fsw_, &! Fsw - Fsvw + Fsvw*Td [-] + Fsg_, &! Fsg - Fsvg + Fsvg*Td [-] + Fgw_, &! Fgw - Fgvw + Fgvw*Td [-] + Fgs_, &! Fgs - Fgvs + Fgvs*Td [-] + Fwg_, &! Fwg - Fwvg + Fwvg*Td [-] + Fww_, &! Fww - Fwvw + Fwvw*Td [-] + Fws_, &! Fws - Fwvs + Fwvs*Td [-] + + Sw, &! Shadow of wall [-] + Sw_, &! Shadow of wall [-] + Sv, &! Shadow of trees [-] + Swv, &! Overlapped shadow between wall and trees [-] + fv_, &! Fraction of trees [-] + Td, &! Transmission of tree [-] + fwsun, &! Fraction of sunlit wall [-] + fwsha, &! Fraction of shaded wall [-] + Iwsun, &! Incident radiation on sunlit wall [W/m2] + Iwsha, &! Incident radiation on shaded wall [W/m2] + Ig, &! Incident radiation on ground [W/m2] + Igimp, &! Incident radiation on impervious ground [W/m2] + Igper, &! Incident radiation on pervious ground [W/m2] + Iv ! Incident radiation on trees [W/m2] + + ! Radiation transfer matrix and vectors + !------------------------------------------------- + real(r8) :: A(5,5) !Radiation transfer matrix + + ! Temporal + real(r8) :: tmp, eb, fac1, fac2, lsai +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) + L = H/HL + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate transmission and albedo of tree + !------------------------------------------------- + lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) + Td = tee(DD1*3/8.*lsai) + ev = 1 - Td + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + Fws = Fsw*fg/fb/(4*HL) + Fwg = Fsw*fg/fb/(4*HL) + Fww = 1 - Fws - Fwg + + ! View factor from tree to walls, ground and sky + !------------------------------------------------- + + Sw = ShadowWall_dif(fb/fg, HL) + Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) + + !NOTE: fg*(fv/fg - fv/fg * Sw_) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Fsv = Sv + Fsvw = Swv + Fsvg = Fsv - Fsvw + + ! View factor from veg to sky and walls above canopy + Fvs = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + + Sw_ = ShadowWall_dif(fb/fg, hv/L) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Fgv = Sv + Fgvw = Swv + Fgvs = Fgv - Fgvw + + ! View factor from veg to sky and walls below+above canopy + Fvg = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + Fvw + + Fvw = 1 - Fvs - Fvg + + !Fvs = Fsv*fg/min(4*fv,2*fg) + !Fvg = Fgv*fg/min(4*fv,2*fg) + !Fvw = 1 - Fvs - Fvg + + ! Canopy mode: + Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) + Fwv = min(0.8, Fwv) + + fac1 = 1.*hv/H + fac2 = 1.*(H-hv)/H + Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) + Fwvs = Fws*fac1/Fww*Fwvw + Fwvg = Fwg*fac2/Fww*Fwvw + + ! set upper limit + Fwvw = min(Fww, Fwvw) + Fwvs = min(Fws, Fwvs) + Fwvg = min(Fwg, Fwvg) + + Fwv = Fwvw + Fwvs + Fwvg + + ! View factors with trees + !--------------------------------------------------------- + Fsw_ = Fsw - Fsvw + Fsvw*Td + Fsg_ = Fsg - Fsvg + Fsvg*Td + Fgw_ = Fgw - Fgvw + Fgvw*Td + Fgs_ = Fgs - Fgvs + Fgvs*Td + Fwg_ = Fwg - Fwvg + Fwvg*Td + Fww_ = Fww - Fwvw + Fwvw*Td + Fws_ = Fws - Fwvs + Fwvs*Td + + ! Calculate wall sunlit fraction + !------------------------------------------------- + + ! Building wall shadow + Sw = ShadowWall_dir(fb/fg, HL, theta) + + Sw_ = Sw; fv_ = fv; + + Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) + fv_ = fv - fv*Sw_ + + ! Tree shadow (to all area) + Sv = ShadowTree(fv_, theta) + + ! Overlapped shadow between tree and building + ! (to ground only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Sw = Sw - Swv + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg+fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + !------------------------------------------------- + A(1,:) = (/1-Fww_*fwsun*(1-ewall), -Fww_*fwsun*(1-ewall), -Fgw_*fwsun*(1-ewall), & + -Fgw_*fwsun*(1-ewall), -Fvw *fwsun*(1-ewall) /) + + A(2,:) = (/ -Fww_*fwsha*(1-ewall), 1-Fww_*fwsha*(1-ewall), -Fgw_*fwsha*(1-ewall), & + -Fgw_*fwsha*(1-ewall), -Fvw *fwsha*(1-ewall) /) + + A(3,:) = (/ -Fwg_*fgimp*(1-egimp), -Fwg_*fgimp*(1-egimp), 1._r8, & + 0._r8, -Fvg *fgimp*(1-egimp) /) + + A(4,:) = (/ -Fwg_*fgper*(1-egper), -Fwg_*fgper*(1-egper), 0._r8, & + 1._r8, -Fvg *fgper*(1-egper) /) + + A(5,:) = (/ 0._r8, 0._r8, 0._r8, & + 0._r8, 1._r8 /) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Incident LW radiation on sunlit/shaded wall and + ! impervious/pervious ground + Iwsun = LW*Fsw_*fwsun + Iwsha = LW*Fsw_*fwsha + Ig = LW*Fsg_ + Igimp = Ig*fgimp + Igper = Ig*fgper + Iv = LW*Fsv + + ! Vector of initial LW radiation on each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 + B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 + ! leaf temperature iteration in urban flux calculation + ! see MOD_Urban_Flux.F90 + ! B(5) = 4*fv/fg*stefnc*ev*tl**4 !NOTE: 4*fv/fg or 2*fv/fg + !4*fv/fg. equivalent to 2fc + B(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + B1(3) = fgimp*stefnc*egimp*tgimp**4 + B1(4) = fgper*stefnc*egper*tgper**4 + ! leaf temperature iteration in urban flux calculation + ! B1(5) = 4*fv/fg*stefnc*ev*tl**4 + B1(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 + dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 + dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 + dBdT(4) = 4*fgper*stefnc*egper*tgper**3 + ! leaf temperature iteration in urban flux calculation + ! dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 + dBdT(5) = 4*max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + SkyVF(1:2) = Fws_ + SkyVF(3:4) = Fgs_ + SkyVF(5) = Fvs + + VegVF(1:2) = Fwv + VegVF(3:4) = Fgv + VegVF(5) = Fsv + + fcover(0) = fb + fcover(1) = 4*fwsun*HL*fb + fcover(2) = 4*fwsha*HL*fb + fcover(3) = fg*fgimp + fcover(4) = fg*fgper + fcover(5) = fv + + !NOTE: the below codes are put in the leaf temperature iteration process + ! after each iteration, update the below iterms + !B(5) = 4*fv/fg*stefnc*ev*tl**4 + !B1(5) = 4*fv/fg*stefnc*ev*tl**4 + !dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 + ! Equation solve + !X = matmul(Ainv, B) + + ! LW radiation absorption by each surface (per m^2) + !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper + + !NOTE: before leaf temperature iteration + !lv = ((X(1)*Fwv + X(2)*Fwv + X(3)*Fgv + X(4)*Fgv + LW*Fsv)*ev - B1(5))!/(fv/fg) + + ! Out-going LW of urban canopy + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + !lout = sum( X * SkyVF ) + + ! Energy balance check + !eb = lwsun + lwsha + lgimp + lgper + lv + lout + + !IF (abs(eb-LW) > 1e-6) THEN + ! print *, "Longwave tree - Energy Balance Check error!", eb-LW + !ENDIF + + ! Radiation difference due to the last temperature change of the leaf + ! dBdT: the first 4 iterms is 0 + !dX = matmul(Ainv, dBdT) + ! Finally solve the first 4 items, the leaf has been solved + !lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl!/ (4*fwsun*HL*fb/fg) + !lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl!/ (4*fwsha*HL*fb/fg) + !lgimp = lwimp + ( egimp*dX(3) ) / (1-egimp) * dtl!/ fgimp + !lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl!/ fgper + + ! update after each temperature iteration + !lv = lv + ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5))*dtl!/(fv/fg) + !dlvdt = (dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5) + + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = lout + sum( dX * SkyVF * dtl ) + + ! put it outside + ! absorption change due to temperature change, as restart variables. + ! now the leaf temperature does not change, the last iterm of dBdT is 0. + !dX = matmul(Ainv, dBdT*dT) + + !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp + !lgper = ( esnow*dX(4) - dBdT(4)*dT(4) ) / (1-esnow) !/ fgper + !lv = ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv + dX(5)*Fgv)*ev)!/(fv/fg) + + !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = lout + sum( dX * SkyVF ) + + END SUBROUTINE UrbanVegLongwave + +END MODULE MOD_Urban_Longwave +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 new file mode 100644 index 0000000000..2992510f3a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 @@ -0,0 +1,184 @@ +#include + +MODULE MOD_Urban_NetSolar + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: netsolar_urban + +CONTAINS + + SUBROUTINE netsolar_urban (ipatch,idate,dlon,deltim,& + forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& + alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake,& + sr,sabv,par,sabroof,sabwsun,sabwsha,sabgimp,sabgper,sablake,& + solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Net solar absorbed by urban surface. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_TimeManager, only: isgreenwich + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch ! patch index + integer, intent(in) :: idate(3) ! model time + + real(r8), intent(in) :: dlon ! longitude in radians + real(r8), intent(in) :: deltim ! seconds in a time step [second] + + real(r8), intent(in) :: & + forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] + forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), dimension(1:2,1:2), intent(in) :: & + alb, &! averaged albedo [-] + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + sroof, &! roof absorption for solar radiation + swsun, &! sunlit wall absorption for solar radiation + swsha, &! shaded wall absorption for solar radiation + sgimp, &! impervious ground absorption for solar radiation + sgper, &! pervious ground absorption for solar radiation + slake ! lake absorption for solar radiation + + + real(r8), intent(out) :: & + sr, &! total reflected solar radiation (W/m2) + par, &! PAR absorbed by sunlit vegetation [W/m2] + sabv, &! solar absorbed by sunlit vegetation [W/m2] + sabroof, &! roof absorbed solar radiation (W/m2) + sabwsun, &! sunlit wall absorbed solar radiation (W/m2) + sabwsha, &! shaded wall absorbed solar radiation (W/m2) + sabgimp, &! impervious ground absorbed solar radiation (W/m2) + sabgper, &! pervious ground absorbed solar radiation (W/m2) + sablake, &! solar absorbed by ground [W/m2] + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + +!-------------------------- Local Variables ---------------------------- + integer :: local_secs + real(r8) :: radpsec + +!----------------------------------------------------------------------- + + sabroof = 0. + sabwsun = 0. + sabwsha = 0. + sabgimp = 0. + sabgper = 0. + sablake = 0. + sabv = 0. + par = 0. + + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + + sabroof = forc_sols *sroof(1,1) + forc_soll *sroof(2,1) & + + forc_solsd*sroof(1,2) + forc_solld*sroof(2,2) + + sabwsun = forc_sols *swsun(1,1) + forc_soll *swsun(2,1) & + + forc_solsd*swsun(1,2) + forc_solld*swsun(2,2) + + sabwsha = forc_sols *swsha(1,1) + forc_soll *swsha(2,1) & + + forc_solsd*swsha(1,2) + forc_solld*swsha(2,2) + + sabgimp = forc_sols *sgimp(1,1) + forc_soll *sgimp(2,1) & + + forc_solsd*sgimp(1,2) + forc_solld*sgimp(2,2) + + sabgper = forc_sols *sgper(1,1) + forc_soll *sgper(2,1) & + + forc_solsd*sgper(1,2) + forc_solld*sgper(2,2) + + sabv = forc_sols *ssun (1,1) + forc_soll *ssun (2,1) & + + forc_solsd*ssun (1,2) + forc_solld*ssun (2,2) + + par = forc_sols *ssun (1,1) + forc_solsd*ssun (1,2) + + ! LAI PAR + !TODO: to distinguish lai and sai + !par = par * lai*(1.-rho(1,1)-tau(1,1)) / & + ! ( lai*(1.-rho(1,1)-tau(1,1)) + & + ! sai*(1.-rho(1,2)-tau(1,2)) ) + + ! for lake + sablake = forc_sols *slake(1,1) + forc_soll *slake(2,1) & + + forc_solsd*slake(1,2) + forc_solld*slake(2,2) + + ENDIF + + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni + + ! calculate the local secs + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + ENDIF + + END SUBROUTINE netsolar_urban + +END MODULE MOD_Urban_NetSolar +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 new file mode 100644 index 0000000000..6943f651fe --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 @@ -0,0 +1,314 @@ +#include + +MODULE MOD_Urban_PerviousTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The urban's pervious ground is equivalent to soil, and the heat +! transfer process of the surface soil is calculated consistently. This +! includes considering 10 layers of soil and up to 5 layers of snow, +! with a layering scheme consistent with the soil (snow). The phase +! change process is considered, and soil thermal parameters are +! obtained from global data. The difference lies in the fact that the +! shortwave and longwave radiation received at the surface, as well as +! the turbulent exchange flux (sensible heat, latent heat), are solved +! by the corresponding MODULE for the urban model. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanPerviousTem + +CONTAINS + + SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_gpersno,z_gpersno,zi_gpersno,& + t_gpersno,wice_gpersno,wliq_gpersno,scv_gper,snowdp_gper,& + lgper,clgper,sabgper,fsengper,fevpgper,cgper,htvp,& + imelt,sm,xmf,fact) + +!======================================================================= +! Snow and pervious road temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of road soil is computed from +! the algorithm of Johansen (as reported by Farouki 1981), impervious +! and perivious from LOOK-UP table and of snow is from the formulation +! used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), F = 0 (base of the soil column). +! o Soil / snow temperature is predicted from heat conduction +! in 10 soil layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers +! (j,j+1) are derived from an assumption that the flux across the +! interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. The equation is solved +! using the Crank-Nicholson method and resulted in a tridiagonal +! system equation. +! +! Phase change (see MOD_PhaseChange.F90) +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_SoilThermalParameters + USE MOD_Utils, only: tridia + USE MOD_PhaseChange, only: meltf + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor: turn 1st layer T to surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal cond. of minerals soil [W/m-K] + real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] + + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal cond. of dry soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal cond. of sat soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal cond. of sat frozen soil [W/m-K] + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric frac of quartz in mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric frac of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric frac of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric frac of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric frac of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric frac of sand + + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal cond. + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal cond. + +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw (1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil),& !soil parameter for vanGenuchten scheme + alpha_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + n_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + L_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + sc_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + fc_vgm (1:nl_soil) !soil parameter for vanGenuchten scheme +#endif + + real(r8), intent(in) :: dz_gpersno(lb :nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_gpersno (lb :nl_soil) !node depth [m] + real(r8), intent(in) :: zi_gpersno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabgper !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: lgper !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: clgper !deriv. of longwave wrt to soil temp [w/m2/k] + real(r8), intent(in) :: fsengper !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpgper !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgper !deriv. of soil energy flux to T [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_gpersno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_gpersno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_gpersno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv_gper !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_gper !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change in soil + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv(lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk(lb:nl_soil) !thermal conductivity [W/(m K)] + + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + real(r8) rhosnow !partial density of water (ice + liquid) + + real(r8) at(lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt(lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct(lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt(lb:nl_soil) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_gpersno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_soil) !temporary set + + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice(1:nl_soil) !volumetric fraction ice len within soil + + integer i,j + +!======================================================================= +! soil ground and wetland heat capacity + DO i = 1, nl_soil + vf_water(i) = wliq_gpersno(i)/(dz_gpersno(i)*denh2o) + vf_ice(i) = wice_gpersno(i)/(dz_gpersno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_gpersno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_gpersno(i) + ENDDO + IF(lb==1 .and. scv_gper>0.) cv(1) = cv(1) + cpice*scv_gper + +! Snow heat capacity + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_gpersno(:0) + cpice*wice_gpersno(:0) + ENDIF + +! Snow thermal conductivity + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_gpersno(i)+wliq_gpersno(i))/dz_gpersno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + IF((i==0) .and. (z_gpersno(i+1)-zi_gpersno(i) + +MODULE MOD_Urban_RoofFlux + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanRoofFlux + +CONTAINS + + + SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, zsno, fsno_roof, hroof, htvp_roof, & + lbr, wliq_roofsno, wice_roofsno, troof, qroof, dqroofdT, & + croofs, croofl, croof, fsenroof, fevproof, & + z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This is the main subroutine to execute the calculation +! of roof fluxes - not used now. +! +! Created by Hua Yuan, 11/2022 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + IMPLICIT NONE + +!----------------------- Dummy argument -------------------------------- + integer, intent(in) :: & + lbr ! lower bound of array + + real(r8), intent(in) :: & + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + zsno, &! roughness length for snow [m] + fsno_roof,&! fraction of impervious ground covered by snow + hroof, &! average building height [m] + + wliq_roofsno,&! liquid water [kg/m2] + wice_roofsno,&! ice lens [kg/m2] + + troof, &! ground impervious temperature [K] + qroof, &! ground impervious specific humidity [kg/kg] + dqroofdT, &! d(qroof)/dT + htvp_roof ! latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(out) :: & + croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + croof ! deriv of roof total heat flux wrt soil temp [w/m**2/k] + + real(r8), intent(out) :: & + fsenroof, &! sensible heat flux from roof [W/m2] + fevproof ! evaporation heat flux from roof [W/m2] + + real(r8), intent(out) :: & + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters,&! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + tg, &! ground surface temperature [K] + qg, &! ground specific humidity [kg/kg] + fg, &! ground fractional cover [-] + froof, &! weight of impervious ground + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] + + real(r8) fwet_roof + +!----------------------------------------------------------------------- +! initial roughness length + !TODO: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_roof > 0) THEN + z0mg = zsno + ELSE + z0mg = 0.01 + ENDIF + z0hg = z0mg + z0qg = z0mg + +! potential temperature at the reference height + beta = 1. !- (in computing W_*) + zii = 1000. !m (pbl height) + z0m = z0mg + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof = min(1., fwet_roof) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ENDIF + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-troof + dqh = qm-qroof + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-hroof-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters !begin stability iteration + !---------------------------------------------------------------- + displax = hroof + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF (zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta >= 0.) THEN + um = max(ur,0.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION !end stability iteration + !---------------------------------------------------------------- + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + raiw = rhoair/raw + croofs = raih + croofl = raiw*dqroofdT*fwet_roof + croof = croofs + htvp_roof*croofl + + zol = zeta + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + !taux = -rhoair*us/ram + !tauy = -rhoair*vs/ram + fsenroof = -raih*dth + fevproof = -raiw*dqh*fwet_roof + + END SUBROUTINE UrbanRoofFlux + +END MODULE MOD_Urban_RoofFlux +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 new file mode 100644 index 0000000000..25d72a226a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 @@ -0,0 +1,252 @@ +#include + +MODULE MOD_Urban_RoofTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The layer division scheme of the roof is the same as the wall (equal +! depth), and the thickness is read from external data. The temperature +! transfer is similar to the wall, but considering the influence of +! snow and water accumulation on the thermal properties of the first +! layer of the roof, as well as impervious surfaces. At the same time, +! the heat exchange between the innermost layer of the roof and the +! indoor roof surface air is considered, and the phase change process +! is only considered for the first layer of the roof and the snow cover +! layer. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanRoofTem + +CONTAINS + + + SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& + cv_roof,tk_roof,dz_roofsno,z_roofsno,zi_roofsno,& + t_roofsno,wice_roofsno,wliq_roofsno,scv_roof,snowdp_roof,& + troof_inner,lroof,clroof,sabroof,fsenroof,fevproof,croof,htvp,& + imelt_roof,sm_roof,xmf_roof,fact,tkdz_roof) + +!======================================================================= +! Snow and roof temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of roof is given by LOOK-UP table, and of +! snow is from the formulation used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), +! For urban sunwall, shadewall, and roof columns, there is a non-zero +! heat flux across the bottom "building inner surface" layer and the +! equations are derived assuming a prescribed or adjusted internal +! building temperature. T = T_roof_inner (at the roof inner surface). +! o Roof / snow temperature is predicted from heat conduction +! in N roof layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers (j, +! j+1) are derived from an assumption that the flux across the +! interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. The equation is solved +! using the Crank-Nicholson method and resulted in a tridiagonal +! system equation. +! +! Phase change (see MOD_PhaseChange.F90) +! +! Original author: Yongjiu Dai, 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Utils, only: tridia + USE MOD_PhaseChange, only: meltf_urban + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: lb !lower bound of array + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor: turn 1st layer T to surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: cv_roof(1:nl_roof) !heat capacity of urban roof [J/m3/K] + real(r8), intent(in) :: tk_roof(1:nl_roof) !thermal conductivity of urban roof [W/m/K] + + real(r8), intent(in) :: dz_roofsno(lb:nl_roof) !layer thickness [m] + real(r8), intent(in) :: z_roofsno (lb:nl_roof) !node depth [m] + real(r8), intent(in) :: zi_roofsno(lb-1:nl_roof) !interface depth [m] + + real(r8), intent(in) :: troof_inner !temperature at the roof inner surface [K] + real(r8), intent(in) :: lroof !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: clroof !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: sabroof !solar radiation absorbed by roof [W/m2] + real(r8), intent(in) :: fsenroof !sensible heat flux from roof [W/m2] + real(r8), intent(in) :: fevproof !evaporation heat flux from roof [mm/s] + real(r8), intent(in) :: croof !deriv. of roof energy flux to T [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_roofsno (lb:nl_roof) !roof layers' temperature [K] + real(r8), intent(inout) :: wice_roofsno(lb:nl_roof) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_roofsno(lb:nl_roof) !liquid water [kg/m2] + real(r8), intent(inout) :: scv_roof !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_roof !snow depth [m] + + real(r8), intent(out) :: sm_roof !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf_roof !total latent heat of phase change of roof + real(r8), intent(out) :: fact(lb:nl_roof) !used in computing tridiagonal matrix + real(r8), intent(out) :: tkdz_roof !heat diffusion with inner room space + integer , intent(out) :: imelt_roof(lb:nl_roof) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv (lb:nl_roof) !heat capacity [J/(m2 K)] + real(r8) thk(lb:nl_roof) !thermal conductivity of layer + real(r8) tk (lb:nl_roof) !thermal conductivity [W/(m K)] + + real(r8) at (lb:nl_roof) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_roof) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_roof) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_roof) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_roof) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_roof) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_roofsno_bef(lb:nl_roof) !roof/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_roof) !temporary set + real(r8) bw !snow density [kg/m3] + + integer i,j + +!----------------------------------------------------------------------- + + wice_roofsno(2:) = 0.0 !ice lens [kg/m2] + wliq_roofsno(2:) = 0.0 !liquid water [kg/m2] + +! heat capacity + IF (lb <= 0) THEN + DO j = lb, 0 + cv(j) = max(1.0e-6_r8,(cpliq*wliq_roofsno(j) + cpice*wice_roofsno(j))) + ENDDO + ENDIF + + cv(1:) = cv_roof(1:)*dz_roofsno(1:) + + ! snow exist when there is no snow layer + IF (lb == 1 .and. scv_roof > 0.0) THEN + cv(1) = cv(1) + cpice*scv_roof + ENDIF + + ! ponding water or ice exist + cv(1) = cv(1) + cpliq*wliq_roofsno(1) + cpice*wice_roofsno(1) + +! thermal conductivity + ! Thermal conductivity of snow, which from Yen (1980) + IF (lb <= 0) THEN + DO j = lb, 0 + bw = (wice_roofsno(j)+wliq_roofsno(j))/(dz_roofsno(j)) + thk(j) = tkair + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkair) ! Yen, 1980 + !thk(j) = 0.024 - 1.23e-4_r8*bw + 2.5e-6_r8*bw*bw ! Calonne et al., 2011 + ENDDO + ENDIF + +! thermal conductivity at the layer interface + thk(1:) = tk_roof(1:) + IF (lb <= 0) THEN + DO j = lb, 0 + tk(j) = thk(j)*thk(j+1)*(z_roofsno(j+1)-z_roofsno(j)) & + /(thk(j)*(z_roofsno(j+1)-zi_roofsno(j))+thk(j+1)*(zi_roofsno(j)-z_roofsno(j))) + ENDDO + ENDIF + + DO j = 1, nl_roof-1 + tk(j) = thk(j)*thk(j+1)*(z_roofsno(j+1)-z_roofsno(j)) & + /(thk(j)*(z_roofsno(j+1)-zi_roofsno(j))+thk(j+1)*(zi_roofsno(j)-z_roofsno(j))) + ENDDO + tk(nl_roof) = thk(nl_roof) + +! net ground heat flux into the roof surface and its temperature derivative + hs = sabroof + lroof - (fsenroof+fevproof*htvp) + dhsdT = - croof + clroof + + t_roofsno_bef(lb:) = t_roofsno(lb:) + + j = lb + fact(j) = deltim / cv(j) * dz_roofsno(j) & + / (0.5*(z_roofsno(j)-zi_roofsno(j-1)+capr*(z_roofsno(j+1)-zi_roofsno(j-1)))) + + DO j = lb + 1, nl_roof + fact(j) = deltim/cv(j) + ENDDO + + DO j = lb, nl_roof - 1 + fn(j) = tk(j)*(t_roofsno(j+1)-t_roofsno(j))/(z_roofsno(j+1)-z_roofsno(j)) + ENDDO + + j = nl_roof + fn(j) = tk(j)*(troof_inner - cnfac*t_roofsno(j))/(zi_roofsno(j)-z_roofsno(j)) + tkdz_roof = tk(j)/(zi_roofsno(j)-z_roofsno(j)) + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = lb + dzp = z_roofsno(j+1)-z_roofsno(j) + at(j) = 0. + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + rt(j) = t_roofsno(j) + fact(j)*( hs - dhsdT*t_roofsno(j) + cnfac*fn(j) ) + + DO j = lb + 1, nl_roof - 1 + dzm = (z_roofsno(j)-z_roofsno(j-1)) + dzp = (z_roofsno(j+1)-z_roofsno(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_roofsno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO + + j = nl_roof + dzm = (z_roofsno(j)-z_roofsno(j-1)) + dzp = (zi_roofsno(j)-z_roofsno(j)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j-1)/dzm+tk(j)/dzp) + ct(j) = 0. + rt(j) = t_roofsno(j) + fact(j)*(fn(j) - cnfac*fn(j-1)) + +! solve for t_roofsno + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_roofsno) + +!======================================================================= +! melting or freezing +!======================================================================= + + DO j = lb, nl_roof - 1 + fn1(j) = tk(j)*(t_roofsno(j+1)-t_roofsno(j))/(z_roofsno(j+1)-z_roofsno(j)) + ENDDO + + j = nl_roof + fn1(j) = tk(j)*(troof_inner - cnfac*t_roofsno(j))/(zi_roofsno(j)-z_roofsno(j)) + + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + + DO j = lb + 1, nl_roof + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO + + CALL meltf_urban (lb,1,deltim, & + fact(lb:1),brr(lb:1),hs,dhsdT, & + t_roofsno_bef(lb:1),t_roofsno(lb:1), & + wliq_roofsno(lb:1),wice_roofsno(lb:1),imelt_roof(lb:1), & + scv_roof,snowdp_roof,sm_roof,xmf_roof) + + END SUBROUTINE UrbanRoofTem + +END MODULE MOD_Urban_RoofTemperature +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 new file mode 100644 index 0000000000..1a8628a5bf --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 @@ -0,0 +1,777 @@ +#include + +MODULE MOD_Urban_Shortwave + + USE MOD_Precision + USE MOD_LandUrban + USE MOD_Vars_Global + USE MOD_3DCanopyRadiation, only: tee, phi + USE MOD_SPMD_Task + + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanOnlyShortwave !Radiation transfer for shortwave radiation without trees + PUBLIC :: UrbanVegShortwave !Radiation transfer for shortwave radiation with trees + + PUBLIC :: MatrixInverse !Inverse of radiation transfer matrix for multiple reflections + PUBLIC :: ShadowWall_dir !Shadow of wall for direct radiation + PUBLIC :: ShadowWall_dif !Shadow of wall for diffuse radiation + PUBLIC :: ShadowTree !Shadow of trees + +CONTAINS + + + SUBROUTINE UrbanOnlyShortwave ( theta, HL, fb, fgper, H, & + aroof, awall, agimp, agper, fwsun, sroof, swsun, swsha, sgimp, sgper, albu) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| |++++++| +! ______+++++| |++++++| +! |++++++|++++| |++++++| +! sunlit |[]++[]|++++| |++++++| shaded +! wall |++++++| |++++++| wall +! |[]++[]| |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! +! !DESCRIPTION: +! +! Calculate the ground shadow area, the area of the sunny and shady +! walls taking into account mutual shading between buildings; +! calculate the visibility factor F between the sky, walls, and +! ground; calculate the initial radiation reaching each component +! surface, considering multiple scattering processes, and establish +! the radiation transfer balance equation for both incident direct +! and diffuse radiation cases for solving. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to their side length [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H ! Building average height [m] + + real(r8), intent(in) :: & + aroof, &! albedo of roof [-] + awall, &! albedo of walls [-] + agimp, &! albedo of impervious road [-] + agper ! albedo of pervious road [-] + + real(r8), intent(out) :: & + fwsun, &! Fraction of sunlit wall [-] + sroof(2), &! Urban building roof absorption [-] + swsun(2), &! Urban sunlit wall absorption [-] + swsha(2), &! Urban shaded wall absorption [-] + sgimp(2), &! Urban impervious ground absorption [-] + sgper(2), &! Urban pervious ground absorption [-] + albu(2) ! Urban overall albedo [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + W, &! Urban ground average width [m] + L, &! Urban building average length [m] + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Weight of pervious ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Sw, &! Shadow of wall [-] + fwsha, &! Fraction of shaded wall [-] + Ewsun, &! Incident radiation on sunlit wall [-] + Ewsha, &! Incident radiation on shaded wall [-] + Eg, &! Incident radiation on ground [-] + Egimp, &! Incident radiation on impervious ground [-] + Egper, &! Incident radiation on pervious ground [-] + + A(4,4), &! Radiation transfer matrix + Ainv(4,4), &! Inverse of Radiation transfer matrix + B(4), &! Vectors of incident radiation on each surface + X(4) ! Radiation emit from each surface in balance condition + + ! Temporal + real(r8) :: fac1, fac2, eb + +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! Adjusted as below: + Fws = Fsw*fg/fb/(2*HL)*0.75 + Fwg = Fsw*fg/fb/(2*HL)*0.25 + Fww = 1 - Fws - Fwg + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building wall shadow on the ground + Sw = ShadowWall_dir(fb/fg, HL, theta) + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + ! o A: radiation transfer matrix + ! o B: incident radiation on each surface + ! o X: radiation emit from each surface + !------------------------------------------------- + A(1,:) = (/1-Fww*fwsun*awall, -Fww*fwsun*awall, -Fgw*fwsun*awall, -Fgw*fwsun*awall/) + A(2,:) = (/ -Fww*fwsha*awall, 1-Fww*fwsha*awall, -Fgw*fwsha*awall, -Fgw*fwsha*awall/) + A(3,:) = (/ -Fwg*fgimp*agimp, -Fwg*fgimp*agimp, 1._r8, 0._r8/) + A(4,:) = (/ -Fwg*fgper*agper, -Fwg*fgper*agper, 0._r8, 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Radiation transfer for incident direct case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Sw + Ewsha = 0. + Eg = 1.-Ewsun + Egimp = Eg*fgimp + Egper = Eg*fgper + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) + + ! Matrix computing to resolve multiple reflections + X = matmul(Ainv, B) + + !------------------------------------------------- + ! SAVE results for output + !------------------------------------------------- + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp + sgper(1) = X(4)/agper*(1-agper)!/fgper + + ! albedo of urban canopy + albu(1) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + + ! Energy balance check + eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + albu(1) + IF (abs(eb-1) > 1e-6) THEN + print *, "Direct - Energy Balance Check error!", eb-1 + ENDIF + + ! Radiation transfer for incident diffuse case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Fsw*fwsun + Ewsha = Fsw*fwsha + Eg = Fsg + Egimp = Eg*fgimp + Egper = Eg*fgper + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) + + ! Equation solve + X = matmul(Ainv, B) + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp + sgper(2) = X(4)/agper*(1-agper)!/fgper + + !albedo of urban canopy + albu(2) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + + ! energy balance check + eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + albu(2) + IF (abs(eb-1) > 1e-6) THEN + print *, "Diffuse - Energy Balance Check error!", eb-1 + ENDIF + + ! convert to per unit area absorption + IF (fb > 0.) THEN + swsun = swsun/(4*fwsun*HL*fb)*fg + swsha = swsha/(4*fwsha*HL*fb)*fg + ENDIF + IF (fgimp > 0.) sgimp = sgimp/fgimp + IF (fgper > 0.) sgper = sgper/fgper + + ! roof absorption + sroof = 1. - aroof + + ! albedo account for both roof and urban's wall and ground + albu = aroof*fb + albu*fg + + END SUBROUTINE UrbanOnlyShortwave + + + SUBROUTINE UrbanVegShortwave ( theta, HL, fb, fgper, H, & + aroof, awall, agimp, agper, lai, sai, fv, hv, rho, tau, & + fwsun, sroof, swsun, swsha, sgimp, sgper, sveg, albu ) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| ___ |++++++| +! ______+++++| ||||| |++++++| +! |++++++|++++| ||||||| |++++++| +! sunlit |[]++[]|++++| ||||| |++++++| shaded +! wall |++++++| | tree |++++++| wall +! |[]++[]| | |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! +! !DESCRIPTION: +! +! The process of shortwave radiation transfer in a city considering +! vegetation (trees only) is based on the radiation transfer without +! vegetation (UrbanOnlyShortwave), taking into account the visibility +! factors F between the various components including the vegetation, in +! order to calculate the radiation transfer matrix during radiation +! balance. A similar method is used to solve the radiation absorption +! of walls, ground, and vegetation. The additional part compared to +! urban radiation transfer without vegetation (UrbanOnlyShortwave) is +! the consideration of the visibility factors and shadow area +! calculation including the vegetation. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to their side length [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H ! Building average height [m] + + real(r8), intent(in) :: & + aroof, &! albedo of roof [-] + awall, &! albedo of walls [-] + agimp, &! albedo of impervious road [-] + agper ! albedo of pervious road [-] + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + fv, &! Fraction of tree cover [-] + hv, &! Central height of vegetation crown + rho, &! effective rho (lai + sai) + tau ! effective tau (lai + sai) + + real(r8), intent(out) :: & + fwsun, &! Fraction of sunlit wall [-] + sroof(2), &! Urban building roof absorption [-] + swsun(2), &! Urban sunlit wall absorption [-] + swsha(2), &! Urban shaded wall absorption [-] + sgimp(2), &! Urban impervious ground absorption [-] + sgper(2), &! Urban pervious ground absorption [-] + sveg(2), &! Urban building tree absorption [-] + albu(2) ! Urban overall albedo [-] + +!-------------------------- Local Variables ---------------------------- + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + + real(r8) :: & + W, &! Urban ground average width + L, &! Urban building average length + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Weight of pervious ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Fvg, &! View factor from tree to ground [-] + Fvs, &! View factor from tree to sky [-] + Fvw, &! View factor from tree to walls (sunlit+shaded) [-] + Fwv, &! View factor from wall to tree [-] + Fgv, &! View factor from ground to tree [-] + Fsv, &! View factor from sky to tree [-] + + Fgvs, &! View factor from ground->|tree|-> to sky [-] + Fgvw, &! View factor from ground->|tree|-> to walls [-] + Fsvg, &! View factor from sky->|tree|-> to ground [-] + Fsvw, &! View factor from sky->|tree|-> to walls [-] + Fwvw, &! View factor from walls->|tree|-> to walls [-] + Fwvs, &! View factor from walls->|tree|-> to sky [-] + Fwvg, &! View factor from walls->|tree|-> to ground [-] + + Fsw_, &! Fsw - Fsvw + Fsvw*Td [-] + Fsg_, &! Fsg - Fsvg + Fsvg*Td [-] + Fgw_, &! Fgw - Fgvw + Fgvw*Td [-] + Fgs_, &! Fgs - Fgvs + Fgvs*Td [-] + Fwg_, &! Fwg - Fwvg + Fwvg*Td [-] + Fww_, &! Fww - Fwvw + Fwvw*Td [-] + Fws_, &! Fws - Fwvs + Fwvs*Td [-] + + Sw, &! Shadow of wall [-] + Sw_, &! Shadow of wall [-] + Sv, &! Shadow of trees [-] + Svw, &! Overlapped shadow between wall and trees [-] + fv_, &! Fraction of trees [-] + Td, &! Transmission of tree [-] + av, &! albedo of tree [-] + fwsha, &! Fraction of shaded wall [-] + Ewsun, &! Incident radiation on sunlit wall [-] + Ewsha, &! Incident radiation on shaded wall [-] + Eg, &! Incident radiation on ground [-] + Egimp, &! Incident radiation on impervious ground [-] + Egper, &! Incident radiation on pervious ground [-] + Ev ! Incident radiation on trees [-] + + ! Radiation transfer matrix and vectors + !------------------------------------------------- + real(r8) :: A(5,5) !Radiation transfer matrix + real(r8) :: Ainv(5,5) !Inverse of Radiation transfer matrix + real(r8) :: B(5) !Vectors of incident radiation on each surface + real(r8) :: X(5) !Radiation emit from each surface in balance condition + + ! Temporal + real(r8) :: fac1, fac2, eb, sumw, ws, wg, ww + + real(r8) :: phi_tot !albedo of a single tree + real(r8) :: phi_dif !Temporal + real(r8) :: pa2 !Temporal + real(r8) :: lsai !lai+sai +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) + L = H/HL + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate transmission and albedo of tree + !------------------------------------------------- + lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) + Td = tee(DD1*3/8.*lsai) + CALL phi(.true., 3/8.*lsai, tau+rho, tau, rho, phi_tot, phi_dif, pa2) + av = phi_tot + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! adjusted as below: + Fws = Fsw*fg/fb/(2*HL)*0.75 + Fwg = Fsw*fg/fb/(2*HL)*0.25 + Fww = 1 - Fws - Fwg + + ! View factor from tree to walls, ground and sky + !------------------------------------------------- + + Sw = ShadowWall_dif(fb/fg, HL) + Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) + + !NOTE: fg*(fv/fg - fv/fg * Sw_) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Svw = Sv * (Sw-Sw_) + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Fsv = Sv + Fsvw = Svw + Fsvg = Fsv - Fsvw + + ! View factor from veg to sky and walls above canopy + Fvs = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + + Sw_ = ShadowWall_dif(fb/fg, hv/L) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Svw = Sv * (Sw-Sw_) + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Fgv = Sv + Fgvw = Svw + Fgvs = Fgv - Fgvw + + ! View factor from veg to sky and walls below+above canopy + Fvg = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + Fvw + + Fvw = 1 - Fvs - Fvg + + !Fvs = Fsv*fg/min(4*fv,2*fg) + !Fvg = Fgv*fg/min(4*fv,2*fg) + !Fvw = 1 - Fvs - Fvg + + !ws = (phi_tot - phi_dif)/2 + !wg = (phi_tot + phi_dif)/2 + !ww = (phi_tot + phi_dif)/2 + !sumw = Fvs*ws + Fvg*wg + Fvw*ww + !Fvs = Fvs*ws/sumw + !Fvg = Fvg*wg/sumw + !Fvw = Fvw*ww/sumw + + ! Canopy mode: + Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) + Fwv = min(0.8, Fwv) + + fac1 = 1.*hv/H + fac2 = 1.*(H-hv)/H + Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) + Fwvs = Fws*fac1/Fww*Fwvw + Fwvg = Fwg*fac2/Fww*Fwvw + + ! set upper limit + Fwvw = min(Fww, Fwvw) + Fwvs = min(Fws, Fwvs) + Fwvg = min(Fwg, Fwvg) + + Fwv = Fwvw + Fwvs + Fwvg + + ! View factors with trees + !--------------------------------------------------------- + Fsw_ = Fsw - Fsvw + Fsvw*Td + Fsg_ = Fsg - Fsvg + Fsvg*Td + Fgw_ = Fgw - Fgvw + Fgvw*Td + Fgs_ = Fgs - Fgvs + Fgvs*Td + Fwg_ = Fwg - Fwvg + Fwvg*Td + Fww_ = Fww - Fwvw + Fwvw*Td + Fws_ = Fws - Fwvs + Fwvs*Td + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building wall shadow + Sw = ShadowWall_dir(fb/fg, HL, theta) + + Sw_ = Sw; fv_ = fv; + + Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) + fv_ = fv - fv*Sw_ + + ! Tree shadow (to all area) + Sv = ShadowTree(fv_, theta) + + ! Overlapped shadow between tree and building + ! (to ground only) + Svw = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Sw = Sw - Svw + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + !------------------------------------------------- + A(1,:) = (/1-Fww_*fwsun*awall, -Fww_*fwsun*awall, & + -Fgw_*fwsun*awall, -Fgw_*fwsun*awall, -Fvw*fwsun*awall/) + + A(2,:) = (/ -Fww_*fwsha*awall, 1-Fww_*fwsha*awall, & + -Fgw_*fwsha*awall, -Fgw_*fwsha*awall, -Fvw*fwsha*awall/) + + A(3,:) = (/ -Fwg_*fgimp*agimp, -Fwg_*fgimp*agimp, & + 1._r8, 0._r8, -Fvg*fgimp*agimp/) + + A(4,:) = (/ -Fwg_*fgper*agper, -Fwg_*fgper*agper, & + 0._r8, 1._r8, -Fvg*fgper*agper/) + + A(5,:) = (/ -Fwv*av , -Fwv*av , & + -Fgv*av , -Fgv*av , 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Radiation transfer for incident direct case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Sw + Ewsha = Svw*Td + Eg = 1-Sw-Sv+(Sv-Svw)*Td + Egimp = Eg*fgimp + Egper = Eg*fgper + Ev = Sv + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) + + ! Matrix computing to resolve multiple reflections + X = matmul(Ainv, B) + + !------------------------------------------------- + ! SAVE results for output + !------------------------------------------------- + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp + sgper(1) = X(4)/agper*(1-agper)!/fgper + sveg (1) = X(5)/av *(1-av-Td)!/(fv/fg) + + ! albedo of urban canopy + albu(1) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + + ! Energy balance check + eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + sveg(1) + albu(1) + IF (abs(eb-1) > 1e-6) THEN + print *, "Direct tree - Energy Balance Check error!", eb-1 + ENDIF + + ! Radiation transfer for incident diffuse case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Fsw_*fwsun + Ewsha = Fsw_*fwsha + Eg = Fsg_ + Egimp = Eg*fgimp + Egper = Eg*fgper + Ev = Fsv + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) + + ! Equation solve + X = matmul(Ainv, B) + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp + sgper(2) = X(4)/agper*(1-agper)!/fgper + sveg (2) = X(5)/ av*(1-av-Td)!/(fv/fg) + + ! albedo of urban canopy + albu(2) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + + ! Energy balance check + eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + sveg(2) + albu(2) + IF (abs(eb-1) > 1e-6) THEN + print *, "Diffuse tree - Energy Balance Check error!", eb-1 + ENDIF + + ! convert to per unit area absorption + IF (fb > 0.) THEN + swsun = swsun/(4*fwsun*HL*fb)*fg + swsha = swsha/(4*fwsha*HL*fb)*fg + ENDIF + IF (fgimp > 0.) sgimp = sgimp/fgimp + IF (fgper > 0.) sgper = sgper/fgper + IF ( fv > 0.) sveg = sveg/fv*fg + + ! roof absorption + sroof = 1. - aroof + + ! albedo account for both roof and urban's wall and ground + albu = aroof*fb + albu*fg + + END SUBROUTINE UrbanVegShortwave + + !------------------------------------------------- + ! calculate shadow of wall for incident direct radiation + FUNCTION ShadowWall_dir(f, HL, theta) result(Sw) + + IMPLICIT NONE + + real(r8), intent(in) :: f + real(r8), intent(in) :: HL + real(r8), intent(in) :: theta + + real(r8) :: Sw + + Sw = 1 - exp( -4/PI*f*HL*tan(theta) ) + + END FUNCTION ShadowWall_dir + + !------------------------------------------------- + ! calculate shadow of wall for incident diffuse radiation + FUNCTION ShadowWall_dif(f, HL) result(Sw) + + IMPLICIT NONE + + real(r8), intent(in) :: f + real(r8), intent(in) :: HL + + real(r8) :: Sw + + Sw = 1 - exp( -4/PI*f*HL*tan( (53-sqrt(f*HL*100))/180*PI ) ) + + END FUNCTION ShadowWall_dif + + !------------------------------------------------- + ! calculate shadow of tree + FUNCTION ShadowTree(f, theta) result(Sv) + + IMPLICIT NONE + + real(r8), intent(in) :: f + real(r8), intent(in) :: theta + + real(r8) :: mu + real(r8) :: Sv + + mu = cos(theta) + Sv = max( f, (1.-exp(-f/mu))/(1.-f*exp(-1./mu)) ) + + END FUNCTION ShadowTree + + + !------------------------------------------------- + ! Returns the inverse of a matrix calculated by finding the LU + ! decomposition. Depends on LAPACK. + FUNCTION MatrixInverse(A) result(Ainv) + + IMPLICIT NONE + + real(r8), dimension(:,:), intent(in) :: A + real(r8), dimension(size(A,1),size(A,2)) :: Ainv + real(r8), dimension(size(A,1)) :: work !work array for LAPACK + integer, dimension(size(A,1)) :: ipiv !pivot indices + integer :: n, info + + ! External procedures defined in LAPACK + external DGETRF + external DGETRI + + ! Store A in Ainv to prevent it from being overwritten by LAPACK + Ainv = A + n = size(A,1) + + ! DGETRF computes an LU factorization of a general M-by-N matrix A + ! using partial pivoting with row interchanges. + CALL DGETRF(n, n, Ainv, n, ipiv, info) + IF (info /= 0) THEN + CALL CoLM_stop('Matrix is numerically singular!') + ENDIF + + ! DGETRI computes the inverse of a matrix using the LU factorization + ! computed by DGETRF. + CALL DGETRI(n, Ainv, n, ipiv, work, n, info) + IF (info /= 0) THEN + CALL CoLM_stop('Matrix inversion failed!') + ENDIF + + END FUNCTION MatrixInverse + +END MODULE MOD_Urban_Shortwave +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 new file mode 100644 index 0000000000..cfd72215e4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 @@ -0,0 +1,1402 @@ +#include + +MODULE MOD_Urban_Thermal + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This is the main subroutine to execute the calculation of urban +! thermal processes and surface fluxes +! +! Created by Hua Yuan, 09/2021 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanTHERMAL + +CONTAINS + + + SUBROUTINE UrbanTHERMAL ( & + + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,deltim ,patchlatr ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_psrf ,& + forc_rhoair ,forc_frl ,forc_po2m ,forc_pco2m ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + theta ,sabroof ,sabwsun ,sabwsha ,& + sabgimp ,sabgper ,sablake ,sabv ,& + par ,Fhac ,Fwst ,Fach ,& + Fahe ,Fhah ,vehc ,meta ,& + ! LUCY model input parameters + fix_holiday ,week_holiday ,hum_prof ,pop_den ,& + vehicle ,weh_prof ,wdh_prof ,idate ,& + patchlonr ,& + ! surface parameters + froof ,flake ,hroof ,hlr ,& + fgper ,pondmx ,eroof ,ewall ,& + egimp ,egper ,trsmx0 ,zlnd ,& + zsno ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,& + cv_roof ,cv_wall ,cv_gimp ,& + tk_roof ,tk_wall ,tk_gimp ,dz_roofsno ,& + dz_gimpsno ,dz_gpersno ,dz_lakesno ,dz_wall ,& + z_roofsno ,z_gimpsno ,z_gpersno ,z_lakesno ,& + z_wall ,zi_roofsno ,zi_gimpsno ,zi_gpersno ,& + zi_lakesno ,zi_wall ,dz_lake ,lakedepth ,& + dewmx ,sqrtdi ,rootfr ,effcon ,& + vmax25 ,c3c4 ,slti ,hlti ,shti,& + hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,& + extkn ,lambda ,& + + ! surface status + fsno_roof ,fsno_gimp ,fsno_gper ,scv_roof ,& + scv_gimp ,scv_gper ,scv_lake ,snowdp_roof ,& + snowdp_gimp ,snowdp_gper ,snowdp_lake ,fwsun ,& + dfwsun ,lai ,sai ,htop ,& + hbot ,fveg ,sigf ,extkd ,& + lwsun ,lwsha ,lgimp ,lgper ,& + t_grnd ,t_roofsno ,t_wallsun ,t_wallsha ,& + t_gimpsno ,t_gpersno ,t_lakesno ,wliq_roofsno ,& + wliq_gimpsno ,wliq_gpersno ,wliq_lakesno ,wice_roofsno ,& + wice_gimpsno ,wice_gpersno ,wice_lakesno ,t_lake ,& + lake_icefrac ,savedtke1 ,lveg ,tleaf ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + troom ,troof_inner ,twsun_inner ,twsha_inner ,& + troommax ,troommin ,tafu ,& + +! SNICAR model variables + snofrz ,sabg_lyr ,& +! END SNICAR model variables + + ! output + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + fsen_roof ,fsen_wsun ,fsen_wsha ,fsen_gimp ,& + fsen_gper ,fsen_urbl ,troof ,twall ,& + lfevp_roof ,lfevp_gimp ,lfevp_gper ,lfevp_urbl ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + imelt_roof ,imelt_gimp ,imelt_gper ,imelt_lake ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + sabg ,rstfac ,rootr ,etr_deficit ,& + tref ,qref ,trad ,rst ,& + assim ,respc ,errore ,emis ,& + z0m ,zol ,rib ,ustar ,& + qstar ,tstar ,fm ,fh ,& + fq ,hpbl ) + + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global + USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& + stefnc,denice,tfrz,vonkar,grav + USE MOD_Urban_Shortwave + USE MOD_Urban_Longwave + USE MOD_Urban_GroundFlux + USE MOD_Urban_Flux + USE MOD_Urban_RoofTemperature + USE MOD_Urban_WallTemperature + USE MOD_Urban_PerviousTemperature + USE MOD_Urban_ImperviousTemperature + USE MOD_Lake + USE MOD_Urban_BEM + USE MOD_Urban_LUCY, only: LUCY + USE MOD_Eroot, only: eroot +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + idate(3) ,& + ipatch ,&! patch index + patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=glacier/ice sheet, 4=land water bodies) + lbr ,&! lower bound of array + lbi ,&! lower bound of array + lbp ,&! lower bound of array + lbl ! lower bound of array + + real(r8), intent(in) :: & + deltim ,&! seconds in a time step [second] + patchlatr ! latitude in radians + + real(r8), intent(in) :: & + patchlonr ,&! longitude of patch [radian] + fix_holiday(365) ,&! Fixed public holidays, holiday(0) or workday(1) + week_holiday(7) ,&! week holidays + hum_prof(24) ,&! Diurnal metabolic heat profile + weh_prof(24) ,&! Diurnal traffic flow profile of weekend + wdh_prof(24) ,&! Diurnal traffic flow profile of weekday + pop_den ,&! population density + vehicle(3) ! vehicle numbers per thousand people + + real(r8), intent(in) :: & + ! atmospherical variables and observational height + forc_hgt_u ,&! observational height of wind [m] + forc_hgt_t ,&! observational height of temperature [m] + forc_hgt_q ,&! observational height of humidity [m] + forc_us ,&! wind component in eastward direction [m/s] + forc_vs ,&! wind component in northward direction [m/s] + forc_t ,&! temperature at agcm reference height [kelvin] + forc_q ,&! specific humidity at agcm reference height [kg/kg] + forc_psrf ,&! atmosphere pressure at the surface [pa] + forc_rhoair ,&! density air [kg/m3] + forc_frl ,&! atmospheric infrared (longwave) radiation [W/m2] + forc_po2m ,&! O2 concentration in atmos. (pascals) + forc_pco2m ,&! CO2 concentration in atmos. (pascals) + forc_sols ,&! atm vis direct beam solar rad onto srf [W/m2] + forc_soll ,&! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd ,&! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ,&! atm nir diffuse solar rad onto srf [W/m2] + theta ,&! sun zenith angle + par ,&! vegetation PAR + sabv ,&! absorbed shortwave radiation by vegetation [W/m2] + sabroof ,&! absorbed shortwave radiation by roof [W/m2] + sabwsun ,&! absorbed shortwave radiation by sunlit wall [W/m2] + sabwsha ,&! absorbed shortwave radiation by shaded wall [W/m2] + sabgimp ,&! absorbed shortwave radiation by impervious road [W/m2] + sabgper ,&! absorbed shortwave radiation by ground snow [W/m2] + sablake ! absorbed shortwave radiation by lake [W/m2] + + real(r8), intent(in) :: & + froof ,&! roof fractional cover [-] + flake ,&! urban lake fractional cover [-] + hroof ,&! average building height [m] + hlr ,&! average building height to their side length [-] + fgper ,&! impervious road fractional cover [-] + pondmx ,&! maximum ponding for soil [mm] + eroof ,&! emissivity of roof + ewall ,&! emissivity of walls + egimp ,&! emissivity of impervious road + egper ,&! emissivity of soil + + trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] + zlnd ,&! roughness length for soil [m] + zsno ,&! roughness length for snow [m] + capr ,&! tuning factor to turn first layer T into surface T + cnfac ,&! Crank Nicholson factor between 0 and 1 + + ! soil physical parameters + vf_quartz (1:nl_soil) ,&! volumetric fraction of quartz within mineral soil + vf_gravels(1:nl_soil) ,&! volumetric fraction of gravels + vf_om (1:nl_soil) ,&! volumetric fraction of organic matter + vf_sand (1:nl_soil) ,&! volumetric fraction of sand + wf_gravels(1:nl_soil) ,&! gravimetric fraction of gravels + wf_sand (1:nl_soil) ,&! gravimetric fraction of sand + csol (1:nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] + porsl (1:nl_soil) ,&! soil porosity [-] + psi0 (1:nl_soil) ,&! soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + bsw (1:nl_soil) ,&! clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil) ,&! residual water content (cm3/cm3) + + alpha_vgm (1:nl_soil) ,&! parameter correspond approximately to inverse of air-entry value + n_vgm (1:nl_soil) ,&! a shape parameter + L_vgm (1:nl_soil) ,&! pore-connectivity parameter + sc_vgm (1:nl_soil) ,&! saturation at air entry value in classical vanGenuchten model [-] + fc_vgm (1:nl_soil) ,&! a scaling factor by using air entry value in the Mualem model [-] +#endif + k_solids (1:nl_soil) ,&! thermal conductivity of minerals soil [W/m-K] + dkdry (1:nl_soil) ,&! thermal conductivity of dry soil [W/m-K] + dksatu (1:nl_soil) ,&! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (1:nl_soil) ,&! thermal conductivity of saturated frozen soil [W/m-K] + + BA_alpha (1:nl_soil) ,&! alpha in Balland and Arp(2005) thermal cond. scheme + BA_beta (1:nl_soil) ,&! beta in Balland and Arp(2005) thermal cond. scheme + cv_roof (1:nl_roof) ,&! heat capacity of roof [J/(m2 K)] + cv_wall (1:nl_wall) ,&! heat capacity of wall [J/(m2 K)] + cv_gimp (1:nl_soil) ,&! heat capacity of impervious [J/(m2 K)] + tk_roof (1:nl_roof) ,&! thermal conductivity of roof [W/m-K] + tk_wall (1:nl_wall) ,&! thermal conductivity of wall [W/m-K] + tk_gimp (1:nl_soil) ,&! thermal conductivity of impervious [W/m-K] + + dz_roofsno(lbr :nl_roof) ,&! layer thickness [m] + dz_gimpsno(lbi :nl_soil) ,&! layer thickness [m] + dz_gpersno(lbp :nl_soil) ,&! layer thickness [m] + dz_wall ( 1:nl_wall) ,&! layer thickness [m] + z_roofsno (lbr :nl_roof) ,&! node depth [m] + z_gimpsno (lbi :nl_soil) ,&! node depth [m] + z_gpersno (lbp :nl_soil) ,&! node depth [m] + z_wall ( 1:nl_wall) ,&! node depth [m] + zi_roofsno(lbr-1:nl_roof) ,&! interface depth [m] + zi_gimpsno(lbi-1:nl_soil) ,&! interface depth [m] + zi_gpersno(lbp-1:nl_soil) ,&! interface depth [m] + zi_wall ( 0:nl_wall) ,&! interface depth [m] + dz_lake ( 1:nl_lake) ,&! lake layer thickness (m) + lakedepth ,&! lake depth (m) + + z_lakesno (maxsnl+1:nl_soil) ,&! node depth [m] + dz_lakesno(maxsnl+1:nl_soil) ,&! layer thickness [m] + zi_lakesno(maxsnl :nl_soil) ,&! interface depth [m] + + ! vegetation parameters + dewmx ,&! maximum dew + sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] + rootfr (1:nl_soil) ,&! root fraction + + effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25 ,&! maximum carboxylation rate at 25 C at canopy top + slti ,&! slope of low temperature inhibition function [s3] + hlti ,&! 1/2 point of low temperature inhibition function [s4] + shti ,&! slope of high temperature inhibition function [s1] + hhti ,&! 1/2 point of high temperature inhibition function [s2] + trda ,&! temperature coefficient in gs-a model [s5] + trdm ,&! temperature coefficient in gs-a model [s6] + trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model + gradm ,&! conductance-photosynthesis slope parameter + binter ,&! conductance-photosynthesis intercept + lambda ,&! marginal water cost of carbon gain + extkn ! coefficient of leaf nitrogen allocation + + integer , intent(in) :: & + c3c4 ! 1 for C3, 0 for C4 + + real(r8), intent(in) :: & + fsno_roof ,&! fraction of ground covered by snow + fsno_gimp ,&! fraction of ground covered by snow + fsno_gper ,&! fraction of ground covered by snow + dfwsun ,&! change of fwsun [%] + lai ,&! adjusted leaf area index for seasonal variation [-] + sai ,&! stem area index [-] + htop ,&! canopy crown top height [m] + hbot ,&! canopy crown bottom height [m] + fveg ,&! fraction of veg cover + sigf ,&! fraction of veg cover, excluding snow-covered veg [-] + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(inout) :: & + fwsun ,&! fraction of sunlit wall [-] + lwsun ,&! net longwave radiation of sunlit wall + lwsha ,&! net longwave radiation of shaded wall + lgimp ,&! net longwave radiation of impervious road + lgper ,&! net longwave radiation of pervious road + t_grnd ,&! ground temperature + t_roofsno ( lbr:nl_wall) ,&! temperatures of roof layers + t_wallsun ( nl_wall) ,&! temperatures of roof layers + t_wallsha ( nl_wall) ,&! temperatures of roof layers + t_gimpsno ( lbi:nl_soil) ,&! temperatures of roof layers + t_gpersno ( lbp:nl_soil) ,&! temperatures of roof layers + wliq_roofsno( lbr:nl_roof) ,&! liquid water [kg/m2] + wliq_gimpsno( lbi:nl_soil) ,&! liquid water [kg/m2] + wliq_gpersno( lbp:nl_soil) ,&! liquid water [kg/m2] + wice_roofsno( lbr:nl_roof) ,&! ice lens [kg/m2] + wice_gimpsno( lbi:nl_soil) ,&! ice lens [kg/m2] + wice_gpersno( lbp:nl_soil) ,&! ice lens [kg/m2] + t_lake ( nl_lake) ,&! lake temperature [K] + lake_icefrac( nl_lake) ,&! lake mass fraction of lake layer that is frozen + t_lakesno (maxsnl+1:nl_soil) ,&! temperatures of roof layers + wliq_lakesno(maxsnl+1:nl_soil) ,&! liquid water [kg/m2] + wice_lakesno(maxsnl+1:nl_soil) ,&! ice lens [kg/m2] + savedtke1 ,&! top level eddy conductivity (W/m K) + scv_roof ,&! snow cover, water equivalent [mm, kg/m2] + scv_gimp ,&! snow cover, water equivalent [mm, kg/m2] + scv_gper ,&! snow cover, water equivalent [mm, kg/m2] + scv_lake ,&! snow cover, water equivalent [mm, kg/m2] + snowdp_roof ,&! snow depth [m] + snowdp_gimp ,&! snow depth [m] + snowdp_gper ,&! snow depth [m] + snowdp_lake ,&! snow depth [m] + lveg ,&! net longwave radiation of vegetation [W/m2] + tleaf ,&! leaf temperature [K] + ldew ,&! depth of water on foliage [kg/(m2 s)] + ldew_rain ,&! depth of rain on foliage [kg/(m2 s)] + ldew_snow ,&! depth of rain on foliage [kg/(m2 s)] + fwet_snow ,&! vegetation canopy snow fractional cover [-] + troom ,&! temperature of inner building + troof_inner ,&! temperature of inner roof + twsun_inner ,&! temperature of inner sunlit wall + twsha_inner ,&! temperature of inner shaded wall + troommax ,&! maximum temperature of inner building + troommin ,&! minimum temperature of inner building + tafu ,&! temperature of outer building + Fahe ,&! flux from metabolic and vehicle + Fhah ,&! flux from heating + Fhac ,&! flux from heat or cool AC + Fwst ,&! waste heat from cool or heat + Fach ,&! flux from air exchange + vehc ,&! flux from vehicle + meta ! flux from metabolic + + real(r8), intent(out) :: & + taux ,&! wind stress: E-W [kg/m/s**2] + tauy ,&! wind stress: N-S [kg/m/s**2] + fsena ,&! sensible heat from canopy height to atm [W/m2] + fevpa ,&! evapotranspiration from canopy height to atm [mm/s] + lfevpa ,&! latent heat flux from canopy height to atm [W/m2] + fsenl ,&! sensible heat from leaves [W/m2] + fevpl ,&! evaporation+transpiration from leaves [mm/s] + etr ,&! transpiration rate [mm/s] + fseng ,&! sensible heat flux from ground [W/m2] + fevpg ,&! evaporation heat flux from ground [mm/s] + olrg ,&! outgoing long-wave radiation from ground+canopy + fgrnd ,&! ground heat flux [W/m2] + + fsen_roof ,&! sensible heat from roof [W/m2] + fsen_wsun ,&! sensible heat from sunlit wall [W/m2] + fsen_wsha ,&! sensible heat from shaded wall [W/m2] + fsen_gimp ,&! sensible heat from impervious road [W/m2] + fsen_gper ,&! sensible heat from pervious road [W/m2] + fsen_urbl ,&! sensible heat from urban vegetation [W/m2] + + lfevp_roof ,&! latent heat flux from roof [W/m2] + lfevp_gimp ,&! latent heat flux from impervious road [W/m2] + lfevp_gper ,&! latent heat flux from pervious road [W/m2] + lfevp_urbl ,&! latent heat flux from urban vegetation [W/m2] + + troof ,&! temperature of roof [K] + twall ,&! temperature of wall [K] + + qseva_roof ,&! ground soil surface evaporation rate (mm h2o/s) + qseva_gimp ,&! ground soil surface evaporation rate (mm h2o/s) + qseva_gper ,&! ground soil surface evaporation rate (mm h2o/s) + qseva_lake ,&! ground soil surface evaporation rate (mm h2o/s) + qsdew_roof ,&! ground soil surface dew formation (mm h2o /s) [+] + qsdew_gimp ,&! ground soil surface dew formation (mm h2o /s) [+] + qsdew_gper ,&! ground soil surface dew formation (mm h2o /s) [+] + qsdew_lake ,&! ground soil surface dew formation (mm h2o /s) [+] + qsubl_roof ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qsubl_gimp ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qsubl_gper ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qsubl_lake ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_roof ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_lake ! surface dew added to snow pack (mm h2o /s) [+] + + integer, intent(out) :: & + imelt_roof(lbr:nl_roof) ,&! flag for melting or freezing [-] + imelt_gimp(lbi:nl_soil) ,&! flag for melting or freezing [-] + imelt_gper(lbp:nl_soil) ,&! flag for melting or freezing [-] + imelt_lake(maxsnl+1:nl_soil) ! flag for melting or freezing [-] + + real(r8), intent(out) :: & + sm_roof ,&! rate of snowmelt [kg/(m2 s)] + sm_gimp ,&! rate of snowmelt [kg/(m2 s)] + sm_gper ,&! rate of snowmelt [kg/(m2 s)] + sm_lake ,&! rate of snowmelt [kg/(m2 s)] + sabg ,&! overall ground solar radiation absorption (+wall) + rstfac ,&! factor of soil water stress + rootr(1:nl_soil) ,&! root resistance of a layer, all layers add to 1 + etr_deficit ,&! urban irrigation [mm/s] + tref ,&! 2 m height air temperature [kelvin] + qref ,&! 2 m height air specific humidity + trad ,&! radiative temperature [K] + rst ,&! stomatal resistance (s m-1) + assim ,&! assimilation + respc ,&! respiration + errore ,&! energy balance error [w/m2] + + ! additional variables required by coupling with WRF or RSM model + emis ,&! averaged bulk surface emissivity + z0m ,&! effective roughness [m] + zol ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib ,&! bulk Richardson number in surface layer + ustar ,&! u* in similarity theory [m/s] + qstar ,&! q* in similarity theory [kg/kg] + tstar ,&! t* in similarity theory [K] + fm ,&! integral of profile function for momentum + fh ,&! integral of profile function for heat + fq ! integral of profile function for moisture + +! SNICAR model variables + real(r8), intent(in) :: sabg_lyr(lbp:1) !snow layer absorption + real(r8), intent(out) :: snofrz (lbp:0) !snow freezing rate (col,lyr) [kg m-2 s-1] +! END SNICAR model variables + +!-------------------------- Local Variables ---------------------------- + + integer :: nurb ! number of aboveground urban components [-] + + logical :: doveg ! run model with vegetation + + real(r8) :: & + fg ,&! ground fraction ( impervious + soil + snow ) + fsenroof ,&! sensible heat flux from roof [W/m2] + fsenwsun ,&! sensible heat flux from sunlit wall [W/m2] + fsenwsha ,&! sensible heat flux from shaded wall [W/m2] + fsengimp ,&! sensible heat flux from impervious road [W/m2] + fsengper ,&! sensible heat flux from ground soil [W/m2] + fevproof ,&! evaporation heat flux from roof [mm/s] + fevpgimp ,&! evaporation heat flux from impervious road [mm/s] + fevpgper ,&! evaporation heat flux from ground soil [mm/s] + + croofs ,&! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + cwsuns ,&! deriv of sunlit wall sensible heat flux wrt soil temp [w/m**2/k] + cwshas ,&! deriv of shaded wall sensible heat flux wrt soil temp [w/m**2/k] + cgrnds ,&! deriv of ground latent heat flux wrt soil temp [w/m**2/k] + croofl ,&! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + cgimpl ,&! deriv of impervious latent heat flux wrt soil temp [w/m**2/k] + cgperl ,&! deriv of pervious latent heat flux wrt soil temp [w/m**2/k] + croof ,&! deriv of roof total flux wrt soil temp [w/m**2/k] + cgimp ,&! deriv of impervious total heat flux wrt soil temp [w/m**2/k] + cgper ,&! deriv of pervious total heat flux wrt soil temp [w/m**2/k] + + dqroofdT ,&! d(qroof)/dT + dqgimpdT ,&! d(qgimp)/dT + dqgperdT ,&! d(qgper)/dT + + degdT ,&! d(eg)/dT + eg ,&! water vapor pressure at temperature T [pa] + egsmax ,&! max. evaporation which soil can provide at one time step + egidif ,&! the excess of evaporation over "egsmax" + emg ,&! ground emissivity (0.97 for snow, + ! glaciers and water surface; 0.96 for soil and wetland) + etrc ,&! maximum possible transpiration rate [mm/s] + fac ,&! soil wetness of surface layer + factr(lbr:nl_roof) ,&! used in computing tridiagonal matrix + facti(lbi:nl_soil) ,&! used in computing tridiagonal matrix + factp(lbp:nl_soil) ,&! used in computing tridiagonal matrix + hr ,&! relative humidity + htvp_roof ,&! latent heat of vapor of water (or sublimation) [J/Kg] + htvp_gimp ,&! latent heat of vapor of water (or sublimation) [J/Kg] + htvp_gper ,&! latent heat of vapor of water (or sublimation) [J/Kg] + olru ,&! olrg excluding downwelling reflection [W/m2] + olrb ,&! olrg assuming black body emission [W/m2] + psit ,&! negative potential of soil + + rss ,&! soil resistance + qroof ,&! roof specific humidity [kg/kg] + qgimp ,&! ground impervious road specific humidity [kg/kg] + qgper ,&! ground pervious specific humidity [kg/kg] + qsatg ,&! saturated humidity [kg/kg] + qsatgdT ,&! d(qsatg)/dT + qred ,&! soil surface relative humidity + thm ,&! intermediate variable (forc_t+0.0098*forc_hgt_t) + th ,&! potential temperature (kelvin) + thv ,&! virtual potential temperature (kelvin) + + twsun ,&! temperature of sunlit wall + twsha ,&! temperature of shaded wall + tgimp ,&! temperature of impervious road + tgper ,&! ground soil temperature + tlake ,&! lake surface temperature + troof_bef ,&! temperature of roof + twsun_bef ,&! temperature of sunlit wall + twsha_bef ,&! temperature of shaded wall + tgimp_bef ,&! temperature of impervious road + tgper_bef ,&! ground soil temperature + troof_nl_bef ,&! temperature of roof + twsun_nl_bef ,&! temperature of sunlit wall + twsha_nl_bef ,&! temperature of shaded wall + tkdz_roof ,&! heat flux from room to roof + tkdz_wsun ,&! heat flux from room to sunlit wall + tkdz_wsha ,&! heat flux from room to shaded wall + tinc ,&! temperature difference of two time step + ev ,&! emissivity of vegetation [-] + lroof ,&! net longwave radiation of roof + rout ,&! out-going longwave radiation from roof + lout ,&! out-going longwave radiation + lnet ,&! overall net longwave radiation + dlw ,&! change of net longwave radiation + dlwbef ,&! change of net longwave radiation + dlwsun ,&! change of net longwave radiation of sunlit wall + dlwsha ,&! change of net longwave radiation of shaded wall + dlgimp ,&! change of net longwave radiation of impervious road + dlgper ,&! change of net longwave radiation of pervious road + dlveg ,&! change of net longwave radiation of vegetation [W/m2] + dlout ,&! change of out-going radiation due to temp change + clroof ,&! deriv of lroof wrt roof temp [w/m**2/k] + clwsun ,&! deriv of lwsun wrt wsun temp [w/m**2/k] + clwsha ,&! deriv of lwsha wrt wsha temp [w/m**2/k] + clgimp ,&! deriv of lgimp wrt gimp temp [w/m**2/k] + clgper ,&! deriv of lgper wrt soil temp [w/m**2/k] + fwsha ,&! fraction of shaded wall [-] + ur ,&! wind speed at reference height [m/s] + wx ,&! partial volume of ice and water of surface layer + xmf ! total latent heat of phase change of ground water + + real(r8) :: & + taux_lake ,&! wind stress: E-W [kg/m/s**2] + tauy_lake ,&! wind stress: N-S [kg/m/s**2] + fsena_lake ,&! sensible heat from canopy height to atmosphere [W/m2] + fevpa_lake ,&! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa_lake ,&! latent heat flux from canopy height to atmosphere [W/m2] + fseng_lake ,&! sensible heat flux from ground [W/m2] + fevpg_lake ,&! evaporation heat flux from ground [mm/s] + olrg_lake ,&! outgoing long-wave radiation from ground+canopy + fgrnd_lake ,&! ground heat flux [W/m2] + tref_lake ,&! 2 m height air temperature [kelvin] + qref_lake ,&! 2 m height air specific humidity + trad_lake ,&! radiative temperature [K] + lnet_lake ,&! net longwave radiation + emis_lake ,&! averaged bulk surface emissivity + z0m_lake ,&! effective roughness [m] + zol_lake ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib_lake ,&! bulk Richardson number in surface layer + ustar_lake ,&! u* in similarity theory [m/s] + qstar_lake ,&! q* in similarity theory [kg/kg] + tstar_lake ,&! t* in similarity theory [K] + fm_lake ,&! integral of profile function for momentum + fh_lake ,&! integral of profile function for heat + fq_lake ,&! integral of profile function for moisture + dheatl ! vegetation heat change [W/m2] + + real(r8) :: z0m_g,z0h_g,zol_g,obu_g,ustar_g,qstar_g,tstar_g + real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu,eb + + ! definition for urban related + real(r8), allocatable :: Ainv(:,:) ! Inverse of Radiation transfer matrix + real(r8), allocatable :: X(:) ! solution + real(r8), allocatable :: dX(:) ! solution + real(r8), allocatable :: B(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: B1(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: dBdT(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: dT(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: SkyVF(:) ! View factor to sky + real(r8), allocatable :: VegVF(:) ! View factor to vegetation + real(r8), allocatable :: fcover(:) ! fractional cover of roof, wall, ground and veg + + +!======================================================================= +! [1] Initial set and propositional variables +!======================================================================= + + ! fluxes + fsenl = 0.; fevpl = 0. + etr = 0.; rst = 2.0e4 + assim = 0.; respc = 0. + + emis = 0.; z0m = 0. + zol = 0.; rib = 0. + ustar = 0.; qstar = 0. + tstar = 0.; rootr = 0. + + dheatl = 0. + + ! latent heat, assumed that the sublimation occurred only as wliq_gpersno=0 + htvp_roof = hvap + htvp_gimp = hvap + htvp_gper = hvap + IF (wliq_roofsno(lbr)<=0. .and. wice_roofsno(lbr)>0.) htvp_roof = hsub + IF (wliq_gimpsno(lbi)<=0. .and. wice_gimpsno(lbi)>0.) htvp_gimp = hsub + IF (wliq_gpersno(lbp)<=0. .and. wice_gpersno(lbp)>0.) htvp_gper = hsub + + ! potential temperature at the reference height + thm = forc_t + 0.0098*forc_hgt_t !intermediate variable equivalent to + !forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) !potential T + thv = th*(1.+0.61*forc_q) !virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) !limit set to 0.1 + + ! Adjust wall temperature, weighted average according to fwsun, dfwsun + !------------------------------------------- + fwsha = 1. - fwsun + + IF (dfwsun > 0) THEN + t_wallsun = (fwsun*t_wallsun + dfwsun*t_wallsha) / (fwsun+dfwsun) + twsun_inner = (fwsun*twsun_inner + dfwsun*twsun_inner) / (fwsun+dfwsun) + lwsun = (fwsun*lwsun + dfwsun*lwsha ) / (fwsun+dfwsun) + ENDIF + + IF (dfwsun < 0) THEN + t_wallsha = (fwsha*t_wallsha - dfwsun*t_wallsun) / (fwsha-dfwsun) + twsha_inner = (fwsha*twsha_inner - dfwsun*twsun_inner) / (fwsha-dfwsun) + lwsha = (fwsha*lwsha - dfwsun*lwsun ) / (fwsha-dfwsun) + ENDIF + + ! update fwsun + fwsun = fwsun + dfwsun + + ! temperature and water mass from previous time step + twsun = t_wallsun( 1 ) + twsha = t_wallsha( 1 ) + troof = t_roofsno(lbr) + tgimp = t_gimpsno(lbi) + tgper = t_gpersno(lbp) + + troof_nl_bef = t_roofsno(nl_roof) + twsun_nl_bef = t_wallsun(nl_wall) + twsha_nl_bef = t_wallsha(nl_wall) + + !TODO: ???how to calculate tlake + IF (lbl < 1) THEN + tlake = t_lakesno(lbl) + ELSE + tlake = t_lake(1) + ENDIF + + ! SAVE temperature + troof_bef = troof + twsun_bef = twsun + twsha_bef = twsha + tgimp_bef = tgimp + tgper_bef = tgper + + ! SAVE longwave for the last time + dlwsun = lwsun + dlwsha = lwsha + dlgimp = lgimp + dlgper = lgper + dlveg = lveg + + fg = 1. - froof + + IF (lai+sai>1.e-6 .and. fveg>0.) THEN + doveg = .true. + ELSE + doveg = .false. + ENDIF + + ! convert AHE to urban area, i.e. (1-flake) + IF ( 1-flake > 0. ) THEN + Fhac = Fhac / (1-flake) + Fwst = Fwst / (1-flake) + Fach = Fach / (1-flake) + vehc = vehc / (1-flake) + meta = meta / (1-flake) + ENDIF + + +!======================================================================= +! [2] specific humidity and its derivative at ground surface +!======================================================================= + + qred = 1. + CALL qsadv(tgper,forc_psrf,eg,degdT,qsatg,qsatgdT) + + ! initialization for rss + rss = 0. + + IF (patchtype <=1 ) THEN !soil ground + wx = (wliq_gpersno(1)/denh2o + wice_gpersno(1)/denice)/dz_gpersno(1) + IF (porsl(1) < 1.e-6) THEN !bed rock + fac = 0.001 + ELSE + fac = min(1.,wx/porsl(1)) + fac = max( fac, 0.001 ) + ENDIF + +#ifdef Campbell_SOIL_MODEL + psit = psi0(1) * fac ** (- bsw(1) ) !psit = max(smpmin, psit) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + psit = soil_psi_from_vliq ( fac*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + psit = max( -1.e8, psit ) + hr = exp(psit/roverg/tgper) + qred = (1.-fsno_gper)*hr + fsno_gper + + IF (lbp == 1) THEN !no snow layer exist + + ! calculate soil resistance for evaporation + wx = (sum(wliq_gpersno(1:2))/denh2o+sum(wice_gpersno(1:2))/denice)/sum(dz_gpersno(1:2)) + IF (sum(porsl(1:2)) < 1.e-6) THEN !bed rock + fac = 0.001 + ELSE + fac = min(1.,sum(dz_gpersno(1:2))*wx/(dz_gpersno(1)*porsl(1)+dz_gpersno(2)*porsl(2))) + fac = max( fac, 0.001 ) + ENDIF + + ! Sellers et al., 1992 + rss = (1-fsno_gper)*exp(8.206-4.255*fac) + ENDIF + ENDIF + + qgper = qred*qsatg + dqgperdT = qred*qsatgdT + + IF (qsatg>forc_q .and. forc_q>qred*qsatg) THEN + qgper = forc_q; dqgperdT = 0. + ENDIF + + CALL qsadv(tgimp,forc_psrf,eg,degdT,qsatg,qsatgdT) + qgimp = qsatg + dqgimpdT = qsatgdT + + CALL qsadv(troof,forc_psrf,eg,degdT,qsatg,qsatgdT) + qroof = qsatg + dqroofdT = qsatgdT + + +!======================================================================= +! [3] calculate longwave radiation +!======================================================================= + + IF ( doveg ) THEN + + allocate ( Ainv(5,5) ) + allocate ( X(5) ) + allocate ( dX(5) ) + allocate ( B(5) ) + allocate ( B1(5) ) + allocate ( dBdT(5) ) + allocate ( SkyVF(5) ) + allocate ( VegVF(5) ) + allocate ( fcover(0:5) ) + allocate ( dT(0:5) ) + + ! call longwave function (vegetation) + CALL UrbanVegLongwave ( & + theta, hlr, froof, fgper, hroof, forc_frl, & + twsun, twsha, tgimp, tgper, ewall, egimp, & + egper, lai, sai, fveg, (htop+hbot)/2., & + ev, Ainv, B, B1, dBdT, SkyVF, VegVF, fcover) + ELSE + + allocate ( Ainv(4,4) ) + allocate ( X(4) ) + allocate ( dX(4) ) + allocate ( B(4) ) + allocate ( B1(4) ) + allocate ( dBdT(4) ) + allocate ( SkyVF(4) ) + allocate ( fcover(0:4) ) + allocate ( dT(0:4) ) + + ! call longwave function, calculate Ainv, B, B1, dBdT + CALL UrbanOnlyLongwave ( & + theta, hlr, froof, fgper, hroof, forc_frl, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, & + Ainv, B, B1, dBdT, SkyVF, fcover) + + ! calculate longwave radiation abs, for UrbanOnlyLongwave + !------------------------------------------- + X = matmul(Ainv, B) + + ! using the longwave radiation transfer matrix to calculate + ! LW radiation absorption by each surface and total absorption. + lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) + lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) + lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) + lgper = ( egper*X(4) - B1(4) ) / (1-egper) + + ! Out-going LW of urban canopy + lout = sum( X * SkyVF ) + + ! Energy balance check + eb = lwsun + lwsha + lgimp + lgper + lout + + IF (abs(eb-forc_frl) > 1e-6) THEN + print *, "Urban Only Longwave - Energy Balance Check error!", eb-forc_frl + ENDIF + + ! fur per unit surface + IF (fcover(1) >0.) lwsun = lwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) >0.) lwsha = lwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) >0.) lgimp = lgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) >0.) lgper = lgper / fcover(4) * fg !/ fsoil + + ! added last time value + lwsun = lwsun + dlwsun + lwsha = lwsha + dlwsha + lgimp = lgimp + dlgimp + lgper = lgper + dlgper + ENDIF + + dlwbef = dlwsun*fcover(1) + dlwsha*fcover(2) + dlgimp*fcover(3) + dlgper*fcover(4) + IF ( doveg ) dlwbef = dlwbef + dlveg*fcover(5) + dlwbef = dlwbef*(1-flake) + + ! roof net longwave + lroof = eroof*forc_frl - eroof*stefnc*troof**4 + + +!======================================================================= +! [4] Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!======================================================================= + + ! bare ground case + CALL UrbanGroundFlux (forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_us, & + forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,zlnd,zsno,fsno_gimp, & + lbi,wliq_gimpsno(1),wice_gimpsno(1), & + fcover,tgimp,tgper,qgimp,qgper,tref,qref, & + z0m_g,z0h_g,zol_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) + + ! SAVE variables for bare ground case + obu_g = forc_hgt_u / zol_g + + +!======================================================================= +! [5] Canopy temperature, fluxes from roof/wall/ground +!======================================================================= + + IF ( doveg ) THEN + + ! soil water stress factor on stomatal resistance + CALL eroot (nl_soil,trsmx0,porsl,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr,dz_gpersno,t_gpersno,wliq_gpersno,rootr,etrc,rstfac) + + nurb = 3 + + CALL UrbanVegFlux ( & + + ! model running information + ipatch ,deltim ,lbr ,lbi ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,& + forc_q ,forc_psrf ,forc_rhoair ,forc_frl ,& + forc_po2m ,forc_pco2m ,par ,sabv ,& + rstfac ,Fhac ,Fwst ,Fach ,& + vehc ,meta ,& + ! urban and vegetation parameters + hroof ,hlr ,nurb ,fcover ,& + ewall ,egimp ,egper ,ev ,& + htop ,hbot ,lai ,sai ,& + sqrtdi ,effcon ,vmax25 ,c3c4 ,slti,& + hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,trsmx0 ,lambda ,& + ! surface status + z0h_g ,obu_g ,ustar_g ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno(1),wliq_gimpsno(1),wice_roofsno(1),wice_gimpsno(1),& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,sigf ,tleaf ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + dheatl ,rss ,etr_deficit ,& + ! longwave related + Ainv ,B ,B1 ,dBdT ,& + SkyVF ,VegVF ,& + ! output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + fsenl ,fevpl ,etr ,rst ,& + assim ,respc ,lwsun ,lwsha ,& + lgimp ,lgper ,lveg ,lout ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + ELSE + + nurb = 2 + + ! CALL urban flux + CALL UrbanOnlyFlux ( & + ! model running information + ipatch ,deltim ,lbr ,lbi ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,& + forc_q ,forc_psrf ,forc_rhoair ,Fhac ,& + Fwst ,Fach ,vehc ,meta ,& + ! surface parameters + hroof ,hlr ,nurb ,fcover ,& + ! surface status + z0h_g ,obu_g ,ustar_g ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno(1),wliq_gimpsno(1),wice_roofsno(1),wice_gimpsno(1),& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,rss ,& + ! output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + + !TODO: check + tleaf = forc_t + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + fwet_snow = 0. + rstfac = 0. + fsenl = 0.0 + fevpl = 0.0 + etr = 0.0 + assim = 0.0 + respc = 0.0 + + ENDIF + +!======================================================================= +! [6] roof/wall/ground temperature +!======================================================================= + + ! Calculate the change rate of long-wave radiation + ! caused by temperature change + clroof = - 4.*eroof*stefnc*troof**3 + clwsun = ( ewall*Ainv(1,1) - 1. ) / (1-ewall) * dBdT(1) + clwsha = ( ewall*Ainv(2,2) - 1. ) / (1-ewall) * dBdT(2) + clgimp = ( egimp*Ainv(3,3) - 1. ) / (1-egimp) * dBdT(3) + clgper = ( egper*Ainv(4,4) - 1. ) / (1-egper) * dBdT(4) + + IF (fcover(1) >0. ) clwsun = clwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) >0. ) clwsha = clwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) >0. ) clgimp = clgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) >0. ) clgper = clgper / fcover(4) * fg !/ fsoil + + ! Calculate the temperature of each component: roof, wall, floor + CALL UrbanRoofTem (lbr,deltim,capr,cnfac,& + cv_roof,tk_roof,dz_roofsno,z_roofsno,zi_roofsno,& + t_roofsno,wice_roofsno,wliq_roofsno,scv_roof,snowdp_roof,& + troof_inner,lroof,clroof,sabroof,fsenroof,fevproof,croof,htvp_roof,& + imelt_roof,sm_roof,xmf,factr,tkdz_roof) + + CALL UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wallsun,dz_wall,z_wall,zi_wall,& + twsun_inner,lwsun,clwsun,sabwsun,fsenwsun,cwsuns,tkdz_wsun) + + CALL UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wallsha,dz_wall,z_wall,zi_wall,& + twsha_inner,lwsha,clwsha,sabwsha,fsenwsha,cwshas,tkdz_wsha) + + CALL UrbanImperviousTem (patchtype,lbi,deltim,& + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& + cv_gimp,tk_gimp,dz_gimpsno,z_gimpsno,zi_gimpsno,& + t_gimpsno,wice_gimpsno,wliq_gimpsno,scv_gimp,snowdp_gimp,& + lgimp,clgimp,sabgimp,fsengimp,fevpgimp,cgimp,htvp_gimp,& + imelt_gimp,sm_gimp,xmf,facti) + + CALL UrbanPerviousTem (patchtype,lbp,deltim,& + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_gpersno,z_gpersno,zi_gpersno,& + t_gpersno,wice_gpersno,wliq_gpersno,scv_gper,snowdp_gper,& + lgper,clgper,sabgper,fsengper,fevpgper,cgper,htvp_gper,& + imelt_gper,sm_gper,xmf,factp) + + ! update temperature + twsun = t_wallsun( 1 ) + twsha = t_wallsha( 1 ) + troof = t_roofsno(lbr) + tgimp = t_gimpsno(lbi) + tgper = t_gpersno(lbp) + twall = (twsun*fwsun + twsha*fwsha)/(fwsun + fwsha) + + ! calculate lake temperature and sensible/latent heat fluxes + CALL laketem ( & + ! "in" laketem arguments + ! --------------------------- + patchtype ,maxsnl ,nl_soil ,nl_lake ,& + patchlatr ,deltim ,forc_hgt_u ,forc_hgt_t ,& + forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + forc_q ,forc_rhoair ,forc_psrf ,forc_sols ,& + forc_soll ,forc_solsd ,forc_solld ,sablake ,& + forc_frl ,dz_lakesno ,z_lakesno ,zi_lakesno ,& + dz_lake ,lakedepth ,vf_quartz ,vf_gravels ,& + vf_om ,vf_sand ,wf_gravels ,wf_sand ,& + porsl ,csol ,k_solids ,& + dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,hpbl ,& + + ! "inout" laketem arguments + ! --------------------------- + tlake ,scv_lake ,snowdp_lake ,t_lakesno ,& + wliq_lakesno ,wice_lakesno ,imelt_lake ,t_lake ,& + lake_icefrac ,savedtke1 ,& + +! SNICAR model variables + snofrz ,sabg_lyr ,& +! END SNICAR model variables + + ! "out" laketem arguments + ! --------------------------- + taux_lake ,tauy_lake ,fsena_lake ,& + fevpa_lake ,lfevpa_lake ,fseng_lake ,fevpg_lake ,& + qseva_lake ,qsubl_lake ,qsdew_lake ,qfros_lake ,& + olrg_lake ,fgrnd_lake ,tref_lake ,qref_lake ,& + trad_lake ,emis_lake ,z0m_lake ,zol_lake ,& + rib_lake ,ustar_lake ,qstar_lake ,tstar_lake ,& + fm_lake ,fh_lake ,fq_lake ,sm_lake ,& + urban_call=.true. ) + + lnet_lake = forc_frl - olrg_lake + +!======================================================================= +! [7] Correct fluxes for temperature change +!======================================================================= + + ! calculate temperature change + dT(0) = troof - troof_bef + dT(1) = twsun - twsun_bef + dT(2) = twsha - twsha_bef + dT(3) = tgimp - tgimp_bef + dT(4) = tgper - tgper_bef + IF ( doveg ) dT(5) = 0. + + ! flux change due to temperature change + fsenroof = fsenroof + dT(0)*croofs + fsenwsun = fsenwsun + dT(1)*cwsuns + fsenwsha = fsenwsha + dT(2)*cwshas + fsengimp = fsengimp + dT(3)*cgrnds + fsengper = fsengper + dT(4)*cgrnds + + fevproof = fevproof + dT(0)*croofl + fevpgimp = fevpgimp + dT(3)*cgimpl + fevpgper = fevpgper + dT(4)*cgperl + +! calculation of evaporative potential; flux in kg m-2 s-1. +! egidif holds the excess energy IF all water is evaporated +! during the timestep. this energy is later added to the sensible heat flux. + + ! --- for pervious ground --- + egsmax = (wice_gpersno(lbp)+wliq_gpersno(lbp)) / deltim + egidif = max( 0., fevpgper - egsmax ) + fevpgper = min ( fevpgper, egsmax ) + fsengper = fsengper + htvp_gper*egidif + + ! --- for impervious ground --- + egsmax = (wice_gimpsno(lbi)+wliq_gimpsno(lbi)) / deltim + egidif = max( 0., fevpgimp - egsmax ) + fevpgimp = min ( fevpgimp, egsmax ) + fsengimp = fsengimp + htvp_gimp*egidif + + ! --- for roof --- + egsmax = (wice_roofsno(lbr)+wliq_roofsno(lbr)) / deltim + egidif = max( 0., fevproof - egsmax ) + fevproof = min ( fevproof, egsmax ) + fsenroof = fsenroof + htvp_roof*egidif + +!======================================================================= +! [8] total fluxes to atmosphere +!======================================================================= + + lnet = lroof *fcover(0) + lwsun *fcover(1) + lwsha *fcover(2) + & + lgimp *fcover(3) + lgper *fcover(4) + + ! 03/30/2022, Wenzong Dong: bug find, sabgwsha->sabgwsun + sabg = sabroof *fcover(0) + sabwsun *fcover(1) + sabwsha *fcover(2) + & + sabgimp *fcover(3) + sabgper *fcover(4) + + ! 03/30/2022, Wenzong Dong: bug find, fsenwsha->fsenwsun + fseng = fsenroof*fcover(0) + fsenwsun*fcover(1) + fsenwsha*fcover(2) + & + fsengimp*fcover(3) + fsengper*fcover(4) + + fsen_roof = fsenroof*fcover(0) + fsen_wsun = fsenwsun*fcover(1) + fsen_wsha = fsenwsha*fcover(2) + fsen_gimp = fsengimp*fcover(3) + fsen_gper = fsengper*fcover(4) + + fevpg = fevproof*fcover(0) + fevpgimp*fcover(3) + fevpgper*fcover(4) + + lfevpa = htvp_roof*fevproof*fcover(0) + & + htvp_gimp*fevpgimp*fcover(3) + & + htvp_gper*fevpgper*fcover(4) + + lfevp_roof = htvp_roof*fevproof*fcover(0) + lfevp_gimp = htvp_gimp*fevpgimp*fcover(3) + lfevp_gper = htvp_gper*fevpgper*fcover(4) + + IF ( doveg ) THEN + assim = assim * fveg + respc = respc * fveg + fsenl = fsenl * fveg + fevpl = fevpl * fveg + etr = etr * fveg + fsena = fsenl + fseng + fevpa = fevpl + fevpg + lfevpa = lfevpa + hvap*fevpl + + fsen_urbl = fsenl + lfevp_urbl = hvap*fevpl + etr_deficit = etr_deficit*fveg + ELSE + fsena = fseng + fevpa = fevpg + ENDIF + + fsena = fsena + (Fhac + Fwst + vehc)*fsh + Fach + meta + lfevpa = lfevpa + (Fhac + Fwst + vehc)*flh + + ! flux/variable average weighted by fractional cover + taux = taux *(1-flake) + taux_lake *flake + tauy = tauy *(1-flake) + tauy_lake *flake + sabg = sabg *(1-flake) + sablake *flake + lnet = lnet *(1-flake) + lnet_lake *flake + fseng = fseng *(1-flake) + fseng_lake *flake + fsena = fsena *(1-flake) + fsena_lake *flake + fevpg = fevpg *(1-flake) + fevpg_lake *flake + lfevpa = lfevpa *(1-flake) + lfevpa_lake *flake + tref = tref *(1-flake) + tref_lake *flake + qref = qref *(1-flake) + qref_lake *flake + z0m = z0m *(1-flake) + z0m_lake *flake + zol = zol *(1-flake) + zol_lake *flake + rib = rib *(1-flake) + rib_lake *flake + ustar = ustar *(1-flake) + ustar_lake *flake + qstar = qstar *(1-flake) + qstar_lake *flake + tstar = tstar *(1-flake) + tstar_lake *flake + fm = fm *(1-flake) + fm_lake *flake + fh = fh *(1-flake) + fh_lake *flake + fq = fq *(1-flake) + fq_lake *flake + + ! 10/01/2021, yuan: exclude lake fevpa. + ! because we don't consider water balance for lake currently. + !fevpa = fevpa *(1-flake) + fevpa_lake *flake + + ! 07/11/2023, yuan: don't not consider lake fraction cover + !fsenl = fsenl *(1-flake) + !fevpl = fevpl *(1-flake) + !etr = etr *(1-flake) + !assim = assim *(1-flake) + !respc = respc *(1-flake) + + ! effective ground temperature, simple average + ! 12/01/2021, yuan: !TODO Bugs. temperature cannot be weighted like below. + !t_grnd = troof*fcover(0) + twsun*fcover(1) + twsha*fcover(2) + & + t_grnd = tgper*fgper + tgimp*(1-fgper) + + !============================================== + qseva_roof = 0. + qsubl_roof = 0. + qfros_roof = 0. + qsdew_roof = 0. + + IF (fevproof >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_roof = min(wliq_roofsno(lbr)/deltim, fevproof) + qsubl_roof = fevproof - qseva_roof + ELSE + IF (troof < tfrz)THEN + qfros_roof = abs(fevproof) + ELSE + qsdew_roof = abs(fevproof) + ENDIF + ENDIF + + !============================================== + qseva_gimp = 0. + qsubl_gimp = 0. + qfros_gimp = 0. + qsdew_gimp = 0. + + IF (fevpgimp >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_gimp = min(wliq_gimpsno(lbi)/deltim, fevpgimp) + qsubl_gimp = fevpgimp - qseva_gimp + ELSE + IF (tgimp < tfrz)THEN + qfros_gimp = abs(fevpgimp) + ELSE + qsdew_gimp = abs(fevpgimp) + ENDIF + ENDIF + + !============================================== + qseva_gper = 0. + qsubl_gper = 0. + qfros_gper = 0. + qsdew_gper = 0. + + IF (fevpgper >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_gper = min(wliq_gpersno(lbp)/deltim, fevpgper) + qsubl_gper = fevpgper - qseva_gper + ELSE + IF (tgper < tfrz)THEN + qfros_gper = abs(fevpgper) + ELSE + qsdew_gper = abs(fevpgper) + ENDIF + ENDIF + +!======================================================================= +! [9] Calculate the change of long-wave radiation caused by temperature change +!======================================================================= + + dX = matmul(Ainv, dBdT*dT(1:)) + dlwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) + dlwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) + dlgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) + dlgper = ( egper*dX(4) - dBdT(4)*dT(4) ) / (1-egper) + + IF ( doveg ) THEN + dlveg = ( sum(dX(1:5)*VegVF(1:5))*ev ) + ELSE + dlveg = 0. + ENDIF + + dlout = sum( dX * SkyVF ) + + ! Energy balance check + eb = dlwsun + dlwsha + dlgimp + dlgper + dlveg + dlout + + IF (abs(eb) > 1e-6) THEN + print *, "Urban Vegetation Longwave - Energy Balance Check error!", eb + ENDIF + + ! for per unit surface + IF (fcover(1) > 0.) dlwsun = dlwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) > 0.) dlwsha = dlwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) > 0.) dlgimp = dlgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) > 0.) dlgper = dlgper / fcover(4) * fg !/ fgper + IF ( doveg ) dlveg = dlveg / fcover(5) * fg !/ fv/fg + + dlw = dlwsun*fcover(1) + dlwsha*fcover(2) + dlgimp*fcover(3) + dlgper*fcover(4) + IF ( doveg) dlw = dlw + dlveg*fcover(5) + dlw = dlw*(1-flake) + + ! calculate out going longwave by added the before value + ! of lout and considered troof change + lout = lout + dlout + rout = (1-eroof)*forc_frl + eroof*stefnc*troof_bef**4 & + + 4.*eroof*stefnc*troof_bef**3*dT(0) + + olrg = lout*fg + rout*froof + olrg = olrg*(1-flake) + olrg_lake*flake + + IF (olrg < 0) THEN + write(6,*) 'Urban_THERMAL.F90: Urban out-going longwave radiation < 0!' + write(6,*) ipatch,olrg,lout,dlout,rout,olrg_lake,fg,froof,flake + CALL CoLM_stop() + ENDIF + + ! radiative temperature + trad = (olrg/stefnc)**0.25 + +! averaged bulk surface emissivity +!TODO: how to calculate for urban case? +! 03/10/2020, yuan: removed below. + !olrb = stefnc*t_soisno_bef(lb)**3*(4.*tinc) + !olrb = stefnc*t_grnd_bef**3*(4.*tinc) + !olru = ulrad + emg*olrb + !olrb = ulrad + olrb + !emis = olru / olrb + + +!======================================================================= +! [10] ground heat flux and energy balance error +!======================================================================= + + ! ground heat flux + fgrnd = sabg + lnet - dlwbef - dlout*fg*(1-flake) & + - 4.*eroof*stefnc*troof_bef**3*dT(0)*froof*(1-flake)& + - fseng - (lfevp_roof + lfevp_gimp + lfevp_gper)*(1-flake) & + - lfevpa_lake*flake + + ! energy balance check + errore = sabg + sabv*fveg*(1-flake) & + + forc_frl - olrg & + + (Fhac + Fwst + Fach + vehc + meta)*(1-flake) & + - fsena - lfevpa - fgrnd & + - dheatl*fveg*(1-flake) + + fgrnd = fgrnd - (Fhac + Fwst + Fach + vehc + meta)*(1-flake) + +#if (defined CoLMDEBUG) + IF (abs(errore)>.5) THEN + write(6,*) 'Urban_THERMAL.F90: Urban energy balance violation' + write(6,*) ipatch,errore,sabg,sabv*fveg*(1-flake) + write(6,*) forc_frl,dlwbef,dlw,olrg + write(6,*) Fhac,Fwst,Fach,vehc,meta,(1-flake) + write(6,*) fsena,lfevpa,fgrnd + write(6,*) dheatl*fveg*(1-flake) + CALL CoLM_stop() + ENDIF +100 format(10(f15.3)) +#endif + + ! diagnostic sabg only for pervious and impervious ground + !sabg = sabgper*fgper + sabgimp*(1-fgper) + + ! SAVE for next time run + lwsun = dlwsun + lwsha = dlwsha + lgimp = dlgimp + lgper = dlgper + lveg = dlveg + + ! deallocate memory + deallocate ( Ainv ) + deallocate ( X ) + deallocate ( dX ) + deallocate ( B ) + deallocate ( B1 ) + deallocate ( dBdT ) + deallocate ( SkyVF ) + deallocate ( dT ) + + IF ( doveg ) THEN + deallocate ( VegVF ) + ENDIF + + +!======================================================================= +! [11] Anthropogenic heat +!======================================================================= + + ! A simple Building energy model + CALL SimpleBEM ( deltim, forc_rhoair, fcover(0:2), hroof, troommax, troommin, & + troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & + t_roofsno(nl_roof), t_wallsun(nl_wall), t_wallsha(nl_wall), & + tkdz_roof, tkdz_wsun, tkdz_wsha, tafu, troom, & + troof_inner, twsun_inner, twsha_inner, & + Fhac, Fwst, Fach, Fhah ) + + ! Anthropogenic heat flux for the rest (vehicle heat flux and metabolic heat flux) + CALL LUCY ( idate , deltim , patchlonr, fix_holiday, & + week_holiday, hum_prof, wdh_prof , weh_prof ,pop_den, & + vehicle , Fahe , vehc , meta ) + + fgrnd = fgrnd + (Fhac + Fwst + Fach)*(1-flake) + vehc + meta + + + ! convert BEM AHE to grid area values + ! NOTE: BEM AHE are assumed only affecting the urban area, + ! but vehc and meta area for the whole grid. + Fhac = Fhac * (1-flake) + Fwst = Fwst * (1-flake) + Fach = Fach * (1-flake) + Fhah = Fhah * (1-flake) + + + deallocate ( fcover ) + + END SUBROUTINE UrbanTHERMAL + +END MODULE MOD_Urban_Thermal +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..1774342d98 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 @@ -0,0 +1,155 @@ +#include + +#if (defined URBAN_MODEL) +MODULE MOD_Urban_Vars_1DFluxes + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Define urban model 1D flux variables. +! +! Created by Hua Yuan, 12/2020 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- +! Fluxes +!----------------------------------------------------------------------- + !real(r8), allocatable :: sabroof (:) !solar absorption of roof [W/m2] + !real(r8), allocatable :: sabwsun (:) !solar absorption of sunlit wall [W/m2] + !real(r8), allocatable :: sabwsha (:) !solar absorption of shaded wall [W/m2] + !real(r8), allocatable :: sabgimp (:) !solar absorption of impervious [W/m2] + !real(r8), allocatable :: sabgper (:) !solar absorption of pervious [W/m2] + + real(r8), allocatable :: fsen_roof (:) !sensible heat flux from roof [W/m2] + real(r8), allocatable :: fsen_wsun (:) !sensible heat flux from sunlit wall [W/m2] + real(r8), allocatable :: fsen_wsha (:) !sensible heat flux from shaded wall [W/m2] + real(r8), allocatable :: fsen_gimp (:) !sensible heat flux from impervious road [W/m2] + real(r8), allocatable :: fsen_gper (:) !sensible heat flux from pervious road [W/m2] + real(r8), allocatable :: fsen_urbl (:) !sensible heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: lfevp_roof (:) !latent heat flux from roof [W/m2] + real(r8), allocatable :: lfevp_gimp (:) !latent heat flux from impervious road [W/m2] + real(r8), allocatable :: lfevp_gper (:) !latent heat flux from pervious road [W/m2] + real(r8), allocatable :: lfevp_urbl (:) !latent heat flux from urban vegetation [W/m2] + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_UrbanFluxes + PUBLIC :: deallocate_1D_UrbanFluxes + PUBLIC :: set_1D_UrbanFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_UrbanFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + !allocate (sabroof (numurban)) + !allocate (sabwsun (numurban)) + !allocate (sabwsha (numurban)) + !allocate (sabgimp (numurban)) + !allocate (sabgper (numurban)) + allocate (fsen_roof (numurban)) ; fsen_roof (:) = spval + allocate (fsen_wsun (numurban)) ; fsen_wsun (:) = spval + allocate (fsen_wsha (numurban)) ; fsen_wsha (:) = spval + allocate (fsen_gimp (numurban)) ; fsen_gimp (:) = spval + allocate (fsen_gper (numurban)) ; fsen_gper (:) = spval + allocate (fsen_urbl (numurban)) ; fsen_urbl (:) = spval + + allocate (lfevp_roof (numurban)) ; lfevp_roof (:) = spval + allocate (lfevp_gimp (numurban)) ; lfevp_gimp (:) = spval + allocate (lfevp_gper (numurban)) ; lfevp_gper (:) = spval + allocate (lfevp_urbl (numurban)) ; lfevp_urbl (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_1D_UrbanFluxes + + SUBROUTINE deallocate_1D_UrbanFluxes + ! -------------------------------------------------------------------- + ! deallocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandUrban + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + + !deallocate (sabroof ) + !deallocate (sabwsun ) + !deallocate (sabwsha ) + !deallocate (sabgimp ) + !deallocate (sabgper ) + deallocate (fsen_roof ) + deallocate (fsen_wsun ) + deallocate (fsen_wsha ) + deallocate (fsen_gimp ) + deallocate (fsen_gper ) + deallocate (fsen_urbl ) + + deallocate (lfevp_roof ) + deallocate (lfevp_gimp ) + deallocate (lfevp_gper ) + deallocate (lfevp_urbl ) + + ENDIF + ENDIF + + END SUBROUTINE deallocate_1D_UrbanFluxes + + SUBROUTINE set_1D_UrbanFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + !sabroof (:) = Values + !sabwsun (:) = Values + !sabwsha (:) = Values + !sabgimp (:) = Values + !sabgper (:) = Values + fsen_roof (:) = Values + fsen_wsun (:) = Values + fsen_wsha (:) = Values + fsen_gimp (:) = Values + fsen_gper (:) = Values + fsen_urbl (:) = Values + + lfevp_roof (:) = Values + lfevp_gimp (:) = Values + lfevp_gper (:) = Values + lfevp_urbl (:) = Values + ENDIF + ENDIF + + END SUBROUTINE set_1D_UrbanFluxes + +END MODULE MOD_Urban_Vars_1DFluxes +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..f63ba79577 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 @@ -0,0 +1,340 @@ +#include + +#ifdef URBAN_MODEL +MODULE MOD_Urban_Vars_TimeInvariants + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Define urban model time invariant variables. +! +! Created by Hua Yuan, 12/2020 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + + !integer , allocatable :: urbclass (:) !urban type + !integer , allocatable :: patch2urb (:) !projection from patch to Urban + !integer , allocatable :: urb2patch (:) !projection from Urban to patch + + real(r8), allocatable :: pop_den (:) !pop density + real(r8), allocatable :: vehicle (:,:) !vehicle numbers per thousand people + real(r8), allocatable :: week_holiday(:,:) !week holidays + real(r8), allocatable :: weh_prof (:,:) !Diurnal traffic flow profile of weekend + real(r8), allocatable :: wdh_prof (:,:) !Diurnal traffic flow profile of weekday + real(r8), allocatable :: hum_prof (:,:) !Diurnal metabolic heat profile + real(r8), allocatable :: fix_holiday (:,:) !Fixed public holidays, holiday (0) or workday(1) + + ! Vegetations + real(r8), allocatable :: fveg_urb (:) !tree coverage of urban patch [-] + real(r8), allocatable :: htop_urb (:) !tree crown top height of urban patch [m] + real(r8), allocatable :: hbot_urb (:) !tree crown bottom height of urban patch [m] + + ! Urban morphology + real(r8), allocatable :: froof (:) !roof fractional cover [-] + real(r8), allocatable :: fgper (:) !impervious fraction to ground area [-] + real(r8), allocatable :: flake (:) !lake fraction to ground area [-] + real(r8), allocatable :: hroof (:) !average building height [m] + real(r8), allocatable :: hlr (:) !average building height to their side length [-] + + real(r8), allocatable :: z_roof (:,:) !depth of each roof layer [m] + real(r8), allocatable :: z_wall (:,:) !depth of each wall layer [m] + real(r8), allocatable :: dz_roof (:,:) !thickness of each roof layer [m] + real(r8), allocatable :: dz_wall (:,:) !thickness of each wall layer [m] + + ! albedo + real(r8), allocatable :: alb_roof (:,:,:) !albedo of roof [-] + real(r8), allocatable :: alb_wall (:,:,:) !albedo of walls [-] + real(r8), allocatable :: alb_gimp (:,:,:) !albedo of impervious [-] + real(r8), allocatable :: alb_gper (:,:,:) !albedo of pervious [-] + + ! emissivity + real(r8), allocatable :: em_roof (:) !emissivity of roof [-] + real(r8), allocatable :: em_wall (:) !emissivity of walls [-] + real(r8), allocatable :: em_gimp (:) !emissivity of impervious [-] + real(r8), allocatable :: em_gper (:) !emissivity of pervious [-] + + ! thermal pars of roof, wall, impervious + real(r8), allocatable :: cv_roof (:,:) !heat capacity of roof [J/(m2 K)] + real(r8), allocatable :: cv_wall (:,:) !heat capacity of wall [J/(m2 K)] + real(r8), allocatable :: cv_gimp (:,:) !heat capacity of impervious [J/(m2 K)] + + real(r8), allocatable :: tk_roof (:,:) !thermal conductivity of roof [W/m-K] + real(r8), allocatable :: tk_wall (:,:) !thermal conductivity of wall [W/m-K] + real(r8), allocatable :: tk_gimp (:,:) !thermal conductivity of impervious [W/m-K] + + ! room maximum and minimum temperature + real(r8), allocatable :: t_roommax (:) !maximum temperature of inner room [K] + real(r8), allocatable :: t_roommin (:) !minimum temperature of inner room [K] + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_UrbanTimeInvariants + PUBLIC :: deallocate_UrbanTimeInvariants + PUBLIC :: READ_UrbanTimeInvariants + PUBLIC :: WRITE_UrbanTimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_UrbanTimeInvariants () +! ------------------------------------------------------ +! Allocates memory for CLM 1d [numurban] variants +! ------------------------------------------------------ + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + allocate (fveg_urb (numurban)) + allocate (htop_urb (numurban)) + allocate (hbot_urb (numurban)) + allocate (froof (numurban)) + allocate (fgper (numurban)) + allocate (flake (numurban)) + allocate (hroof (numurban)) + allocate (hlr (numurban)) + + allocate (alb_roof (2,2,numurban)) + allocate (alb_wall (2,2,numurban)) + allocate (alb_gimp (2,2,numurban)) + allocate (alb_gper (2,2,numurban)) + + allocate (em_roof (numurban)) + allocate (em_wall (numurban)) + allocate (em_gimp (numurban)) + allocate (em_gper (numurban)) + + allocate (z_roof (1:nl_roof,numurban)) + allocate (z_wall (1:nl_wall,numurban)) + allocate (dz_roof (1:nl_roof,numurban)) + allocate (dz_wall (1:nl_wall,numurban)) + + allocate (cv_roof (1:nl_roof,numurban)) + allocate (cv_wall (1:nl_wall,numurban)) + allocate (cv_gimp (1:nl_soil,numurban)) + allocate (tk_roof (1:nl_roof,numurban)) + allocate (tk_wall (1:nl_wall,numurban)) + allocate (tk_gimp (1:nl_soil,numurban)) + + allocate (t_roommax (numurban)) + allocate (t_roommin (numurban)) + allocate (pop_den (numurban)) + + allocate (vehicle (3 ,numurban)) + allocate (week_holiday (7 ,numurban)) + allocate (weh_prof (24 ,numurban)) + allocate (wdh_prof (24 ,numurban)) + allocate (hum_prof (24 ,numurban)) + allocate (fix_holiday (365,numurban)) + ENDIF + ENDIF + + END SUBROUTINE allocate_UrbanTimeInvariants + + SUBROUTINE READ_UrbanTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandUrban + + IMPLICIT NONE + + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + character(len=*), intent(in) :: file_restart + + ! vegetation + CALL ncio_read_vector (file_restart, 'PCT_Tree' , landurban, fveg_urb ) + CALL ncio_read_vector (file_restart, 'URBAN_TREE_TOP', landurban, htop_urb ) + CALL ncio_read_vector (file_restart, 'URBAN_TREE_BOT', landurban, hbot_urb ) + CALL ncio_read_vector (file_restart, 'PCT_Water' , landurban, flake ) + + ! LUCY paras !TODO: variable name can be optimized + CALL ncio_read_vector (file_restart, 'POP_DEN' , landurban, pop_den ) + CALL ncio_read_vector (file_restart, 'VEHC_NUM' , 3 , landurban, vehicle ) + CALL ncio_read_vector (file_restart, 'week_holiday', 7 , landurban, week_holiday ) + CALL ncio_read_vector (file_restart, 'weekendhour' , 24 , landurban, weh_prof ) + CALL ncio_read_vector (file_restart, 'weekdayhour' , 24 , landurban, wdh_prof ) + CALL ncio_read_vector (file_restart, 'metabolism' , 24 , landurban, hum_prof ) + CALL ncio_read_vector (file_restart, 'holiday' , 365, landurban, fix_holiday ) + + ! morphological paras + CALL ncio_read_vector (file_restart, 'WT_ROOF' , landurban, froof ) + CALL ncio_read_vector (file_restart, 'HT_ROOF' , landurban, hroof ) + CALL ncio_read_vector (file_restart, 'BUILDING_HLR' , landurban, hlr ) + CALL ncio_read_vector (file_restart, 'WTROAD_PERV' , landurban, fgper ) + CALL ncio_read_vector (file_restart, 'EM_ROOF' , landurban, em_roof ) + CALL ncio_read_vector (file_restart, 'EM_WALL' , landurban, em_wall ) + CALL ncio_read_vector (file_restart, 'EM_IMPROAD' , landurban, em_gimp ) + CALL ncio_read_vector (file_restart, 'EM_PERROAD' , landurban, em_gper ) + CALL ncio_read_vector (file_restart, 'T_BUILDING_MIN', landurban, t_roommin ) + CALL ncio_read_vector (file_restart, 'T_BUILDING_MAX', landurban, t_roommax ) + + CALL ncio_read_vector (file_restart, 'ROOF_DEPTH_L' , ulev, landurban, z_roof ) + CALL ncio_read_vector (file_restart, 'ROOF_THICK_L' , ulev, landurban, dz_roof ) + CALL ncio_read_vector (file_restart, 'WALL_DEPTH_L' , ulev, landurban, z_wall ) + CALL ncio_read_vector (file_restart, 'WALL_THICK_L' , ulev, landurban, dz_wall ) + + ! thermal paras + CALL ncio_read_vector (file_restart, 'CV_ROOF' , ulev, landurban, cv_roof ) + CALL ncio_read_vector (file_restart, 'CV_WALL' , ulev, landurban, cv_wall ) + CALL ncio_read_vector (file_restart, 'TK_ROOF' , ulev, landurban, tk_roof ) + CALL ncio_read_vector (file_restart, 'TK_WALL' , ulev, landurban, tk_wall ) + CALL ncio_read_vector (file_restart, 'TK_IMPROAD', ulev, landurban, tk_gimp ) + CALL ncio_read_vector (file_restart, 'CV_IMPROAD', ulev, landurban, cv_gimp ) + + CALL ncio_read_vector (file_restart, 'ALB_ROOF' , ns, nr, landurban, alb_roof ) + CALL ncio_read_vector (file_restart, 'ALB_WALL' , ns, nr, landurban, alb_wall ) + CALL ncio_read_vector (file_restart, 'ALB_IMPROAD', ns, nr, landurban, alb_gimp ) + CALL ncio_read_vector (file_restart, 'ALB_PERROAD', ns, nr, landurban, alb_gper ) + + END SUBROUTINE READ_UrbanTimeInvariants + + SUBROUTINE WRITE_UrbanTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandUrban + USE MOD_Namelist + USE MOD_Vars_Global + + IMPLICIT NONE + + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + integer, parameter :: ityp = 3 + integer, parameter :: ihour = 24 + integer, parameter :: iweek = 7 + integer, parameter :: iday = 365 + ! Local variables + character(len=*), intent(in) :: file_restart + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landurban) + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + CALL ncio_define_dimension_vector (file_restart, landurban, 'numsolar', nr ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'numrad' , ns ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ulev' , ulev) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ityp' , 3 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'iweek' , 7 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ihour' , 24 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'iday' , 365 ) + + ! vegetation + CALL ncio_write_vector (file_restart, 'PCT_Tree' , 'urban', landurban, fveg_urb, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'URBAN_TREE_TOP', 'urban', landurban, htop_urb, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'URBAN_TREE_BOT', 'urban', landurban, hbot_urb, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'PCT_Water' , 'urban', landurban, flake , DEF_REST_CompressLevel) + + ! LUCY paras + CALL ncio_write_vector (file_restart, 'POP_DEN' , 'urban', landurban, pop_den , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'VEHC_NUM' , 'ityp' , ityp , 'urban', landurban, vehicle , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'week_holiday', 'iweek', iweek, 'urban', landurban, week_holiday, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'weekendhour' , 'ihour', ihour, 'urban', landurban, weh_prof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'weekdayhour' , 'ihour', ihour, 'urban', landurban, wdh_prof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'metabolism' , 'ihour', ihour, 'urban', landurban, hum_prof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'holiday' , 'iday' , iday , 'urban', landurban, fix_holiday , DEF_REST_CompressLevel) + + ! morphological paras + CALL ncio_write_vector (file_restart, 'WT_ROOF' , 'urban', landurban, froof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'HT_ROOF' , 'urban', landurban, hroof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'BUILDING_HLR' , 'urban', landurban, hlr , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'WTROAD_PERV' , 'urban', landurban, fgper , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_ROOF' , 'urban', landurban, em_roof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_WALL' , 'urban', landurban, em_wall , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_IMPROAD' , 'urban', landurban, em_gimp , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_PERROAD' , 'urban', landurban, em_gper , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'T_BUILDING_MIN', 'urban', landurban, t_roommin, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'T_BUILDING_MAX', 'urban', landurban, t_roommax, DEF_REST_CompressLevel) + + CALL ncio_write_vector (file_restart, 'ROOF_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_roof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ROOF_THICK_L', 'ulev', ulev, 'urban', landurban, dz_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'WALL_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_wall , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'WALL_THICK_L', 'ulev', ulev, 'urban', landurban, dz_wall, DEF_REST_CompressLevel) + + ! thermal paras + CALL ncio_write_vector (file_restart, 'CV_ROOF' , 'ulev', ulev, 'urban', landurban, cv_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'CV_WALL' , 'ulev', ulev, 'urban', landurban, cv_wall, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'TK_ROOF' , 'ulev', ulev, 'urban', landurban, tk_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'TK_WALL' , 'ulev', ulev, 'urban', landurban, tk_wall, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'TK_IMPROAD', 'ulev', ulev, 'urban', landurban, tk_gimp, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'CV_IMPROAD', 'ulev', ulev, 'urban', landurban, cv_gimp, DEF_REST_CompressLevel) + + CALL ncio_write_vector (file_restart, 'ALB_ROOF' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ALB_WALL' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_wall, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ALB_IMPROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gimp, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ALB_PERROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gper, DEF_REST_CompressLevel) + + END SUBROUTINE WRITE_UrbanTimeInvariants + + SUBROUTINE deallocate_UrbanTimeInvariants + + USE MOD_SPMD_Task + USE MOD_LandUrban + + ! deallocate (urbclass ) + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + deallocate (fveg_urb ) + deallocate (htop_urb ) + deallocate (hbot_urb ) + deallocate (froof ) + deallocate (fgper ) + deallocate (flake ) + deallocate (hroof ) + deallocate (hlr ) + + deallocate (alb_roof ) + deallocate (alb_wall ) + deallocate (alb_gimp ) + deallocate (alb_gper ) + + deallocate (em_roof ) + deallocate (em_wall ) + deallocate (em_gimp ) + deallocate (em_gper ) + + deallocate (z_roof ) + deallocate (z_wall ) + deallocate (dz_roof ) + deallocate (dz_wall ) + + deallocate (cv_roof ) + deallocate (cv_wall ) + deallocate (cv_gimp ) + deallocate (tk_roof ) + deallocate (tk_wall ) + deallocate (tk_gimp ) + + deallocate (t_roommax ) + deallocate (t_roommin ) + + deallocate (pop_den ) + deallocate (vehicle ) + deallocate (week_holiday ) + deallocate (weh_prof ) + deallocate (wdh_prof ) + deallocate (hum_prof ) + deallocate (fix_holiday ) + ENDIF + ENDIF + END SUBROUTINE deallocate_UrbanTimeInvariants + +END MODULE MOD_Urban_Vars_TimeInvariants +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..2297a5e5b7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 @@ -0,0 +1,506 @@ +#include + +#if (defined URBAN_MODEL) +MODULE MOD_Urban_Vars_TimeVariables + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Define urban model time variant variables. +! +! Created by Hua Yuan, 12/2020 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE +! ----------------------------------------------------------------- +! Time-varying state variables which required by restart run + + real(r8), allocatable :: fwsun (:) !sunlit fraction of walls [-] + real(r8), allocatable :: dfwsun (:) !change of sunlit fraction of walls [-] + + ! shortwave absorption + real(r8), allocatable :: sroof (:,:,:) !roof absorption [-] + real(r8), allocatable :: swsun (:,:,:) !sunlit wall absorption [-] + real(r8), allocatable :: swsha (:,:,:) !shaded wall absorption [-] + real(r8), allocatable :: sgimp (:,:,:) !impervious absorption [-] + real(r8), allocatable :: sgper (:,:,:) !pervious absorption [-] + real(r8), allocatable :: slake (:,:,:) !urban lake absorption [-] + + ! net longwave radiation for last time temperature change + real(r8), allocatable :: lwsun (:) !net longwave of sunlit wall [W/m2] + real(r8), allocatable :: lwsha (:) !net longwave of shaded wall [W/m2] + real(r8), allocatable :: lgimp (:) !net longwave of impervious [W/m2] + real(r8), allocatable :: lgper (:) !net longwave of pervious [W/m2] + real(r8), allocatable :: lveg (:) !net longwave of vegetation [W/m2] + + real(r8), allocatable :: z_sno_roof (:,:) !node depth of roof [m] + real(r8), allocatable :: z_sno_gimp (:,:) !node depth of impervious [m] + real(r8), allocatable :: z_sno_gper (:,:) !node depth pervious [m] + real(r8), allocatable :: z_sno_lake (:,:) !node depth lake [m] + + real(r8), allocatable :: dz_sno_roof (:,:) !interface depth of roof [m] + real(r8), allocatable :: dz_sno_gimp (:,:) !interface depth of impervious [m] + real(r8), allocatable :: dz_sno_gper (:,:) !interface depth pervious [m] + real(r8), allocatable :: dz_sno_lake (:,:) !interface depth lake [m] + + real(r8), allocatable :: troof_inner (:) !temperature of roof [K] + real(r8), allocatable :: twsun_inner (:) !temperature of sunlit wall [K] + real(r8), allocatable :: twsha_inner (:) !temperature of shaded wall [K] + + real(r8), allocatable :: t_roofsno (:,:) !temperature of roof [K] + real(r8), allocatable :: t_wallsun (:,:) !temperature of sunlit wall [K] + real(r8), allocatable :: t_wallsha (:,:) !temperature of shaded wall [K] + real(r8), allocatable :: t_gimpsno (:,:) !temperature of impervious [K] + real(r8), allocatable :: t_gpersno (:,:) !temperature of pervious [K] + real(r8), allocatable :: t_lakesno (:,:) !temperature of pervious [K] + + real(r8), allocatable :: wliq_roofsno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gimpsno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gpersno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_lakesno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_roofsno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gimpsno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gpersno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_lakesno (:,:) !ice lens in layers [kg/m2] + + real(r8), allocatable :: sag_roof (:) !roof snow age [-] + real(r8), allocatable :: sag_gimp (:) !impervious ground snow age [-] + real(r8), allocatable :: sag_gper (:) !pervious ground snow age [-] + real(r8), allocatable :: sag_lake (:) !urban lake snow age [-] + + real(r8), allocatable :: scv_roof (:) !roof snow mass [kg/m2] + real(r8), allocatable :: scv_gimp (:) !impervious ground snow mass [kg/m2] + real(r8), allocatable :: scv_gper (:) !pervious ground snow mass [kg/m2] + real(r8), allocatable :: scv_lake (:) !urban lake snow mass [kg/m2] + + real(r8), allocatable :: fsno_roof (:) !roof snow fraction [-] + real(r8), allocatable :: fsno_gimp (:) !impervious ground snow fraction [-] + real(r8), allocatable :: fsno_gper (:) !pervious ground snow fraction [-] + real(r8), allocatable :: fsno_lake (:) !urban lake snow fraction [-] + + real(r8), allocatable :: snowdp_roof (:) !roof snow depth [m] + real(r8), allocatable :: snowdp_gimp (:) !impervious ground snow depth [m] + real(r8), allocatable :: snowdp_gper (:) !pervious ground snow depth [m] + real(r8), allocatable :: snowdp_lake (:) !urban lake snow depth [m] + + !TODO: rename the below variables + real(r8), allocatable :: Fhac (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fwst (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fach (:) !flux from inner and outer air exchange [W/m2] + real(r8), allocatable :: Fahe (:) !flux from metabolism and vehicle [W/m2] + real(r8), allocatable :: Fhah (:) !sensible heat flux from heating [W/m2] + real(r8), allocatable :: vehc (:) !flux from vehicle [W/m2] + real(r8), allocatable :: meta (:) !flux from metabolism [W/m2] + + real(r8), allocatable :: t_room (:) !temperature of inner building [K] + real(r8), allocatable :: t_roof (:) !temperature of roof [K] + real(r8), allocatable :: t_wall (:) !temperature of wall [K] + real(r8), allocatable :: tafu (:) !temperature of outer building [K] + + real(r8), allocatable :: urb_green (:) !fractional of green leaf in urban patch [-] + real(r8), allocatable :: urb_lai (:) !urban tree LAI [m2/m2] + real(r8), allocatable :: urb_sai (:) !urban tree SAI [m2/m2] + + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_UrbanTimeVariables + PUBLIC :: deallocate_UrbanTimeVariables + PUBLIC :: READ_UrbanTimeVariables + PUBLIC :: WRITE_UrbanTimeVariables + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_UrbanTimeVariables () +! ------------------------------------------------------ +! Allocates memory for CLM 1d [numurban] variables +! ------------------------------------------------------ + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + allocate (fwsun (numurban)) + allocate (dfwsun (numurban)) + + allocate (sroof (2,2,numurban)) + allocate (swsun (2,2,numurban)) + allocate (swsha (2,2,numurban)) + allocate (sgimp (2,2,numurban)) + allocate (sgper (2,2,numurban)) + allocate (slake (2,2,numurban)) + + allocate (lwsun (numurban)) + allocate (lwsha (numurban)) + allocate (lgimp (numurban)) + allocate (lgper (numurban)) + allocate (lveg (numurban)) + + allocate (z_sno_roof (maxsnl+1:0,numurban)) + allocate (z_sno_gimp (maxsnl+1:0,numurban)) + allocate (z_sno_gper (maxsnl+1:0,numurban)) + allocate (z_sno_lake (maxsnl+1:0,numurban)) + + allocate (dz_sno_roof (maxsnl+1:0,numurban)) + allocate (dz_sno_gimp (maxsnl+1:0,numurban)) + allocate (dz_sno_gper (maxsnl+1:0,numurban)) + allocate (dz_sno_lake (maxsnl+1:0,numurban)) + + allocate (troof_inner (numurban)) + allocate (twsun_inner (numurban)) + allocate (twsha_inner (numurban)) + + allocate (t_roofsno (maxsnl+1:nl_roof,numurban)) + allocate (t_wallsun (maxsnl+1:nl_wall,numurban)) + allocate (t_wallsha (maxsnl+1:nl_wall,numurban)) + allocate (t_gimpsno (maxsnl+1:nl_soil,numurban)) + allocate (t_gpersno (maxsnl+1:nl_soil,numurban)) + allocate (t_lakesno (maxsnl+1:nl_soil,numurban)) + + allocate (wliq_roofsno (maxsnl+1:nl_roof,numurban)) + allocate (wice_roofsno (maxsnl+1:nl_roof,numurban)) + allocate (wliq_gimpsno (maxsnl+1:nl_soil,numurban)) + allocate (wice_gimpsno (maxsnl+1:nl_soil,numurban)) + allocate (wliq_gpersno (maxsnl+1:nl_soil,numurban)) + allocate (wice_gpersno (maxsnl+1:nl_soil,numurban)) + allocate (wliq_lakesno (maxsnl+1:nl_soil,numurban)) + allocate (wice_lakesno (maxsnl+1:nl_soil,numurban)) + + allocate (sag_roof (numurban)) + allocate (sag_gimp (numurban)) + allocate (sag_gper (numurban)) + allocate (sag_lake (numurban)) + allocate (scv_roof (numurban)) + allocate (scv_gimp (numurban)) + allocate (scv_gper (numurban)) + allocate (scv_lake (numurban)) + allocate (fsno_roof (numurban)) + allocate (fsno_gimp (numurban)) + allocate (fsno_gper (numurban)) + allocate (fsno_lake (numurban)) + allocate (snowdp_roof (numurban)) + allocate (snowdp_gimp (numurban)) + allocate (snowdp_gper (numurban)) + allocate (snowdp_lake (numurban)) + + allocate (Fhac (numurban)) + allocate (Fwst (numurban)) + allocate (Fach (numurban)) + allocate (Fahe (numurban)) + allocate (Fhah (numurban)) + allocate (vehc (numurban)) + allocate (meta (numurban)) + + allocate (t_room (numurban)) + allocate (t_roof (numurban)) + allocate (t_wall (numurban)) + allocate (tafu (numurban)) + + allocate (urb_green (numurban)) + allocate (urb_lai (numurban)) + allocate (urb_sai (numurban)) + ENDIF + ENDIF + END SUBROUTINE allocate_UrbanTimeVariables + + SUBROUTINE READ_UrbanTimeVariables (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandUrban + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + CALL ncio_read_vector (file_restart, 'fwsun' , landurban, fwsun ) + CALL ncio_read_vector (file_restart, 'dfwsun', landurban, dfwsun) + + CALL ncio_read_vector (file_restart, 'sroof', 2, 2, landurban, sroof) + CALL ncio_read_vector (file_restart, 'swsun', 2, 2, landurban, swsun) + CALL ncio_read_vector (file_restart, 'swsha', 2, 2, landurban, swsha) + CALL ncio_read_vector (file_restart, 'sgimp', 2, 2, landurban, sgimp) + CALL ncio_read_vector (file_restart, 'sgper', 2, 2, landurban, sgper) + CALL ncio_read_vector (file_restart, 'slake', 2, 2, landurban, slake) + + CALL ncio_read_vector (file_restart, 'lwsun', landurban, lwsun) + CALL ncio_read_vector (file_restart, 'lwsha', landurban, lwsha) + CALL ncio_read_vector (file_restart, 'lgimp', landurban, lgimp) + CALL ncio_read_vector (file_restart, 'lgper', landurban, lgper) + CALL ncio_read_vector (file_restart, 'lveg' , landurban, lveg ) + + CALL ncio_read_vector (file_restart, 'z_sno_roof' , -maxsnl, landurban, z_sno_roof ) + CALL ncio_read_vector (file_restart, 'z_sno_gimp' , -maxsnl, landurban, z_sno_gimp ) + CALL ncio_read_vector (file_restart, 'z_sno_gper' , -maxsnl, landurban, z_sno_gper ) + CALL ncio_read_vector (file_restart, 'z_sno_lake' , -maxsnl, landurban, z_sno_lake ) + + CALL ncio_read_vector (file_restart, 'dz_sno_roof', -maxsnl, landurban, dz_sno_roof) + CALL ncio_read_vector (file_restart, 'dz_sno_gimp', -maxsnl, landurban, dz_sno_gimp) + CALL ncio_read_vector (file_restart, 'dz_sno_gper', -maxsnl, landurban, dz_sno_gper) + CALL ncio_read_vector (file_restart, 'dz_sno_lake', -maxsnl, landurban, dz_sno_lake) + + CALL ncio_read_vector (file_restart, 'troof_inner', landurban, troof_inner) + CALL ncio_read_vector (file_restart, 'twsun_inner', landurban, twsun_inner) + CALL ncio_read_vector (file_restart, 'twsha_inner', landurban, twsha_inner) + + CALL ncio_read_vector (file_restart, 't_roofsno', nl_roof-maxsnl, landurban, t_roofsno) + CALL ncio_read_vector (file_restart, 't_wallsun', nl_wall-maxsnl, landurban, t_wallsun) + CALL ncio_read_vector (file_restart, 't_wallsha', nl_wall-maxsnl, landurban, t_wallsha) + CALL ncio_read_vector (file_restart, 't_gimpsno', nl_soil-maxsnl, landurban, t_gimpsno) + CALL ncio_read_vector (file_restart, 't_gpersno', nl_soil-maxsnl, landurban, t_gpersno) + CALL ncio_read_vector (file_restart, 't_lakesno', nl_soil-maxsnl, landurban, t_lakesno) + + CALL ncio_read_vector (file_restart, 'wliq_roofsno', nl_roof-maxsnl, landurban, wliq_roofsno) + CALL ncio_read_vector (file_restart, 'wliq_gimpsno', nl_soil-maxsnl, landurban, wliq_gimpsno) + CALL ncio_read_vector (file_restart, 'wliq_gpersno', nl_soil-maxsnl, landurban, wliq_gpersno) + CALL ncio_read_vector (file_restart, 'wliq_lakesno', nl_soil-maxsnl, landurban, wliq_lakesno) + CALL ncio_read_vector (file_restart, 'wice_roofsno', nl_roof-maxsnl, landurban, wice_roofsno) + CALL ncio_read_vector (file_restart, 'wice_gimpsno', nl_soil-maxsnl, landurban, wice_gimpsno) + CALL ncio_read_vector (file_restart, 'wice_gpersno', nl_soil-maxsnl, landurban, wice_gpersno) + CALL ncio_read_vector (file_restart, 'wice_lakesno', nl_soil-maxsnl, landurban, wice_lakesno) + + CALL ncio_read_vector (file_restart, 'sag_roof' , landurban, sag_roof ) + CALL ncio_read_vector (file_restart, 'sag_gimp' , landurban, sag_gimp ) + CALL ncio_read_vector (file_restart, 'sag_gper' , landurban, sag_gper ) + CALL ncio_read_vector (file_restart, 'sag_lake' , landurban, sag_lake ) + CALL ncio_read_vector (file_restart, 'scv_roof' , landurban, scv_roof ) + CALL ncio_read_vector (file_restart, 'scv_gimp' , landurban, scv_gimp ) + CALL ncio_read_vector (file_restart, 'scv_gper' , landurban, scv_gper ) + CALL ncio_read_vector (file_restart, 'scv_lake' , landurban, scv_lake ) + CALL ncio_read_vector (file_restart, 'fsno_roof' , landurban, fsno_roof ) + CALL ncio_read_vector (file_restart, 'fsno_gimp' , landurban, fsno_gimp ) + CALL ncio_read_vector (file_restart, 'fsno_gper' , landurban, fsno_gper ) + CALL ncio_read_vector (file_restart, 'fsno_lake' , landurban, fsno_lake ) + CALL ncio_read_vector (file_restart, 'snowdp_roof', landurban, snowdp_roof) + CALL ncio_read_vector (file_restart, 'snowdp_gimp', landurban, snowdp_gimp) + CALL ncio_read_vector (file_restart, 'snowdp_gper', landurban, snowdp_gper) + CALL ncio_read_vector (file_restart, 'snowdp_lake', landurban, snowdp_lake) + CALL ncio_read_vector (file_restart, 'Fhac' , landurban, Fhac ) + CALL ncio_read_vector (file_restart, 'Fwst' , landurban, Fwst ) + CALL ncio_read_vector (file_restart, 'Fach' , landurban, Fach ) + CALL ncio_read_vector (file_restart, 'Fahe' , landurban, Fahe ) + CALL ncio_read_vector (file_restart, 'Fhah' , landurban, Fhah ) + CALL ncio_read_vector (file_restart, 'vehc' , landurban, vehc ) + CALL ncio_read_vector (file_restart, 'meta' , landurban, meta ) + CALL ncio_read_vector (file_restart, 't_room ' , landurban, t_room ) + CALL ncio_read_vector (file_restart, 't_roof' , landurban, t_roof ) + CALL ncio_read_vector (file_restart, 't_wall' , landurban, t_wall ) + CALL ncio_read_vector (file_restart, 'tafu' , landurban, tafu ) + CALL ncio_read_vector (file_restart, 'urb_green' , landurban, urb_green ) + CALL ncio_read_vector (file_restart, 'tree_lai' , landurban, urb_lai ) + CALL ncio_read_vector (file_restart, 'tree_sai' , landurban, urb_sai ) + + END SUBROUTINE READ_UrbanTimeVariables + + SUBROUTINE WRITE_UrbanTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_REST_CompressLevel + USE MOD_LandUrban + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landurban) + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + + CALL ncio_define_dimension_vector (file_restart, landurban, 'snow' , -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'soil' , nl_soil ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'roof' , nl_roof ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'wall' , nl_wall ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landurban, 'roofsnow', nl_roof-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landurban, 'wallsnow', nl_wall-maxsnl) + + CALL ncio_define_dimension_vector (file_restart, landurban, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landurban, 'rtyp', 2) + + CALL ncio_write_vector (file_restart, 'fwsun' , 'urban', landurban, fwsun , compress) + CALL ncio_write_vector (file_restart, 'dfwsun', 'urban', landurban, dfwsun, compress) + + CALL ncio_write_vector (file_restart, 'sroof', 'band', 2, 'rtyp', 2, 'urban', landurban, sroof, compress) + CALL ncio_write_vector (file_restart, 'swsun', 'band', 2, 'rtyp', 2, 'urban', landurban, swsun, compress) + CALL ncio_write_vector (file_restart, 'swsha', 'band', 2, 'rtyp', 2, 'urban', landurban, swsha, compress) + CALL ncio_write_vector (file_restart, 'sgimp', 'band', 2, 'rtyp', 2, 'urban', landurban, sgimp, compress) + CALL ncio_write_vector (file_restart, 'sgper', 'band', 2, 'rtyp', 2, 'urban', landurban, sgper, compress) + CALL ncio_write_vector (file_restart, 'slake', 'band', 2, 'rtyp', 2, 'urban', landurban, slake, compress) + + CALL ncio_write_vector (file_restart, 'lwsun', 'urban', landurban, lwsun, compress) + CALL ncio_write_vector (file_restart, 'lwsha', 'urban', landurban, lwsha, compress) + CALL ncio_write_vector (file_restart, 'lgimp', 'urban', landurban, lgimp, compress) + CALL ncio_write_vector (file_restart, 'lgper', 'urban', landurban, lgper, compress) + CALL ncio_write_vector (file_restart, 'lveg' , 'urban', landurban, lveg , compress) + + CALL ncio_write_vector (file_restart, 'z_sno_roof' , 'snow', -maxsnl, 'urban', landurban, z_sno_roof , compress) + CALL ncio_write_vector (file_restart, 'z_sno_gimp' , 'snow', -maxsnl, 'urban', landurban, z_sno_gimp , compress) + CALL ncio_write_vector (file_restart, 'z_sno_gper' , 'snow', -maxsnl, 'urban', landurban, z_sno_gper , compress) + CALL ncio_write_vector (file_restart, 'z_sno_lake' , 'snow', -maxsnl, 'urban', landurban, z_sno_lake , compress) + + CALL ncio_write_vector (file_restart, 'dz_sno_roof', 'snow', -maxsnl, 'urban', landurban, dz_sno_roof, compress) + CALL ncio_write_vector (file_restart, 'dz_sno_gimp', 'snow', -maxsnl, 'urban', landurban, dz_sno_gimp, compress) + CALL ncio_write_vector (file_restart, 'dz_sno_gper', 'snow', -maxsnl, 'urban', landurban, dz_sno_gper, compress) + CALL ncio_write_vector (file_restart, 'dz_sno_lake', 'snow', -maxsnl, 'urban', landurban, dz_sno_lake, compress) + + CALL ncio_write_vector (file_restart, 'troof_inner', 'urban', landurban, troof_inner, compress) + CALL ncio_write_vector (file_restart, 'twsun_inner', 'urban', landurban, twsun_inner, compress) + CALL ncio_write_vector (file_restart, 'twsha_inner', 'urban', landurban, twsha_inner, compress) + + CALL ncio_write_vector (file_restart, 't_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, t_roofsno, compress) + CALL ncio_write_vector (file_restart, 't_wallsun', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsun, compress) + CALL ncio_write_vector (file_restart, 't_wallsha', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsha, compress) + CALL ncio_write_vector (file_restart, 't_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gimpsno, compress) + CALL ncio_write_vector (file_restart, 't_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gpersno, compress) + CALL ncio_write_vector (file_restart, 't_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_lakesno, compress) + + CALL ncio_write_vector (file_restart, 'wliq_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wliq_roofsno, compress) + CALL ncio_write_vector (file_restart, 'wliq_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gimpsno, compress) + CALL ncio_write_vector (file_restart, 'wliq_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gpersno, compress) + CALL ncio_write_vector (file_restart, 'wliq_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_lakesno, compress) + CALL ncio_write_vector (file_restart, 'wice_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wice_roofsno, compress) + CALL ncio_write_vector (file_restart, 'wice_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gimpsno, compress) + CALL ncio_write_vector (file_restart, 'wice_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gpersno, compress) + CALL ncio_write_vector (file_restart, 'wice_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_lakesno, compress) + + CALL ncio_write_vector (file_restart, 'sag_roof' , 'urban', landurban, sag_roof , compress) + CALL ncio_write_vector (file_restart, 'sag_gimp' , 'urban', landurban, sag_gimp , compress) + CALL ncio_write_vector (file_restart, 'sag_gper' , 'urban', landurban, sag_gper , compress) + CALL ncio_write_vector (file_restart, 'sag_lake' , 'urban', landurban, sag_lake , compress) + CALL ncio_write_vector (file_restart, 'scv_roof' , 'urban', landurban, scv_roof , compress) + CALL ncio_write_vector (file_restart, 'scv_gimp' , 'urban', landurban, scv_gimp , compress) + CALL ncio_write_vector (file_restart, 'scv_gper' , 'urban', landurban, scv_gper , compress) + CALL ncio_write_vector (file_restart, 'scv_lake' , 'urban', landurban, scv_lake , compress) + CALL ncio_write_vector (file_restart, 'fsno_roof' , 'urban', landurban, fsno_roof , compress) + CALL ncio_write_vector (file_restart, 'fsno_gimp' , 'urban', landurban, fsno_gimp , compress) + CALL ncio_write_vector (file_restart, 'fsno_gper' , 'urban', landurban, fsno_gper , compress) + CALL ncio_write_vector (file_restart, 'fsno_lake' , 'urban', landurban, fsno_lake , compress) + CALL ncio_write_vector (file_restart, 'snowdp_roof', 'urban', landurban, snowdp_roof, compress) + CALL ncio_write_vector (file_restart, 'snowdp_gimp', 'urban', landurban, snowdp_gimp, compress) + CALL ncio_write_vector (file_restart, 'snowdp_gper', 'urban', landurban, snowdp_gper, compress) + CALL ncio_write_vector (file_restart, 'snowdp_lake', 'urban', landurban, snowdp_lake, compress) + CALL ncio_write_vector (file_restart, 't_room' , 'urban', landurban, t_room , compress) + CALL ncio_write_vector (file_restart, 't_roof' , 'urban', landurban, t_roof , compress) + CALL ncio_write_vector (file_restart, 't_wall' , 'urban', landurban, t_wall , compress) + CALL ncio_write_vector (file_restart, 'tafu' , 'urban', landurban, tafu , compress) + CALL ncio_write_vector (file_restart, 'Fhac' , 'urban', landurban, Fhac , compress) + CALL ncio_write_vector (file_restart, 'Fwst' , 'urban', landurban, Fwst , compress) + CALL ncio_write_vector (file_restart, 'Fach' , 'urban', landurban, Fach , compress) + CALL ncio_write_vector (file_restart, 'Fahe' , 'urban', landurban, Fahe , compress) + CALL ncio_write_vector (file_restart, 'Fhah' , 'urban', landurban, Fhah , compress) + CALL ncio_write_vector (file_restart, 'vehc' , 'urban', landurban, vehc , compress) + CALL ncio_write_vector (file_restart, 'meta' , 'urban', landurban, meta , compress) + CALL ncio_write_vector (file_restart, 'tree_lai' , 'urban', landurban, urb_lai , compress) + CALL ncio_write_vector (file_restart, 'tree_sai' , 'urban', landurban, urb_sai , compress) + CALL ncio_write_vector (file_restart, 'urb_green' , 'urban', landurban, urb_green , compress) + + END SUBROUTINE WRITE_UrbanTimeVariables + + SUBROUTINE deallocate_UrbanTimeVariables + + USE MOD_SPMD_Task + USE MOD_LandUrban + + IF (p_is_worker) THEN + IF (numurban > 0) THEN + deallocate (fwsun ) + deallocate (dfwsun ) + + deallocate (sroof ) + deallocate (swsun ) + deallocate (swsha ) + deallocate (sgimp ) + deallocate (sgper ) + deallocate (slake ) + + deallocate (lwsun ) + deallocate (lwsha ) + deallocate (lgimp ) + deallocate (lgper ) + deallocate (lveg ) + + deallocate (z_sno_roof ) + deallocate (z_sno_gimp ) + deallocate (z_sno_gper ) + deallocate (z_sno_lake ) + + deallocate (dz_sno_roof ) + deallocate (dz_sno_gimp ) + deallocate (dz_sno_gper ) + deallocate (dz_sno_lake ) + + deallocate (t_roofsno ) + deallocate (t_wallsun ) + deallocate (t_wallsha ) + deallocate (t_gimpsno ) + deallocate (t_gpersno ) + deallocate (t_lakesno ) + + deallocate (troof_inner ) + deallocate (twsun_inner ) + deallocate (twsha_inner ) + + deallocate (wliq_roofsno ) + deallocate (wice_roofsno ) + deallocate (wliq_gimpsno ) + deallocate (wice_gimpsno ) + deallocate (wliq_gpersno ) + deallocate (wice_gpersno ) + deallocate (wliq_lakesno ) + deallocate (wice_lakesno ) + + deallocate (sag_roof ) + deallocate (sag_gimp ) + deallocate (sag_gper ) + deallocate (sag_lake ) + deallocate (scv_roof ) + deallocate (scv_gimp ) + deallocate (scv_gper ) + deallocate (scv_lake ) + deallocate (fsno_roof ) + deallocate (fsno_gimp ) + deallocate (fsno_gper ) + deallocate (fsno_lake ) + deallocate (snowdp_roof ) + deallocate (snowdp_gimp ) + deallocate (snowdp_gper ) + deallocate (snowdp_lake ) + + deallocate (Fhac ) + deallocate (Fwst ) + deallocate (Fach ) + deallocate (Fahe ) + deallocate (Fhah ) + deallocate (vehc ) + deallocate (meta ) + + deallocate (t_room ) + deallocate (t_roof ) + deallocate (t_wall ) + deallocate (tafu ) + + deallocate (urb_green ) + deallocate (urb_lai ) + deallocate (urb_sai ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_UrbanTimeVariables + +END MODULE MOD_Urban_Vars_TimeVariables +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 new file mode 100644 index 0000000000..1821feb6c8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 @@ -0,0 +1,190 @@ +#include + +MODULE MOD_Urban_WallTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The thickness of the wall (including the shady wall and the sunny +! wall) is read from external data. Just like the soil, it is also +! divided into 10 layers, with the same thickness set for each layer, +! and its thermal parameters are also read from external data. Unlike +! pervious/impervious surfaces, the wall does not consider water +! accumulation or snow cover, so its thermal properties are completely +! determined by its own materials. At the same time, it does not +! consider water transfer, phase change processes, and latent heat +! exchange. +! +! Another difference is in the setting of heat exchange for the +! innermost (bottom) layer. For soil and impervious surfaces, the lack +! of heat exchange in the bottom layer is considered. However, for +! walls, the heat exchange between the indoor wall surface air and the +! innermost layer of the wall is considered. Apart from this, the other +! aspects and the solution process are similar to the temperature +! solution for the soil. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanWallTem + +CONTAINS + + + SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wall,dz_wall,z_wall,zi_wall,& + twall_inner,lwall,clwall,sabwall,fsenwall,cwalls,tkdz_wall) + +!======================================================================= +! Wall temperatures +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), +! For urban sunwall, shadewall, and wall columns, there is a non-zero +! heat flux across the bottom "building inner surface" layer and the +! equations are derived assuming a prescribed or adjusted internal +! building temperature. T = T_wall_inner (at the wall inner surface). +! +! o Wall temperature is predicted from heat conduction in N wall layers +! and up to 5 snow layers. The thermal conductivities at the +! interfaces between two neighbor layers (j, j+1) are derived from an +! assumption that the flux across the interface is equal to that from +! the node j to the interface and the flux from the interface to the +! node j+1. The equation is solved using the Crank-Nicholson method +! and resulted in a tridiagonal system equation. +! +! o no Phase change +! +! Original author: Yongjiu Dai, 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Utils, only: tridia + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: cv_wall(1:nl_wall) !heat capacity of urban wall [J/m3/K] + real(r8), intent(in) :: tk_wall(1:nl_wall) !thermal conductivity of urban wall [W/m/K] + + real(r8), intent(in) :: dz_wall(1:nl_wall) !layer thickness [m] + real(r8), intent(in) :: z_wall (1:nl_wall) !node depth [m] + real(r8), intent(in) :: zi_wall(0:nl_wall) !interface depth [m] + + real(r8), intent(in) :: twall_inner !temperature at the wall inner surface [K] + real(r8), intent(in) :: lwall !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: clwall !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: sabwall !solar radiation absorbed by wall [W/m2] + real(r8), intent(in) :: fsenwall !sensible heat flux from wall [W/m2] + real(r8), intent(in) :: cwalls !deriv. of wall energy flux to wall temp [w/m2/k] + + real(r8), intent(inout) :: t_wall(1:nl_wall) !wall layers' temperature [K] + real(r8), intent(inout) :: tkdz_wall !inner wall heat flux [w/m2/k] + +!-------------------------- Local Variables ---------------------------- + real(r8) wice_wall(1:nl_wall) !ice lens [kg/m2] + real(r8) wliq_wall(1:nl_wall) !liquid water [kg/m2] + + real(r8) cv (1:nl_wall) !heat capacity [J/(m2 K)] + real(r8) thk(1:nl_wall) !thermal conductivity of layer + real(r8) tk (1:nl_wall) !thermal conductivity [W/(m K)] + + real(r8) at (1:nl_wall) !"a" vector for tridiagonal matrix + real(r8) bt (1:nl_wall) !"b" vector for tridiagonal matrix + real(r8) ct (1:nl_wall) !"c" vector for tridiagonal matrix + real(r8) rt (1:nl_wall) !"r" vector for tridiagonal solution + + real(r8) fn (1:nl_wall) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(1:nl_wall) !heat diffusion through the layer interface [W/m2] + real(r8) fact(1:nl_wall) !used in computing tridiagonal matrix + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_wall_bef(1:nl_wall) !wall/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + + integer i,j + +!----------------------------------------------------------------------- + + wice_wall(1:) = 0.0 !ice lens [kg/m2] + wliq_wall(1:) = 0.0 !liquid water [kg/m2] + + cv(1:) = cv_wall(1:)*dz_wall(1:) + + thk(1:) = tk_wall(1:) + + DO j = 1, nl_wall-1 + tk(j) = thk(j)*thk(j+1)*(z_wall(j+1)-z_wall(j)) & + /(thk(j)*(z_wall(j+1)-zi_wall(j))+thk(j+1)*(zi_wall(j)-z_wall(j))) + ENDDO + tk(nl_wall) = thk(nl_wall) + +! net ground heat flux into the wall surface and its temperature derivative + hs = sabwall + lwall - fsenwall + dhsdT = - cwalls + clwall + + t_wall_bef(1:) = t_wall(1:) + + j = 1 + fact(j) = deltim / cv(j) * dz_wall(j) & + / (0.5*(z_wall(j)-zi_wall(j-1)+capr*(z_wall(j+1)-zi_wall(j-1)))) + + DO j = 1, nl_wall + fact(j) = deltim/cv(j) + ENDDO + + DO j = 1, nl_wall - 1 + fn(j) = tk(j)*(t_wall(j+1)-t_wall(j))/(z_wall(j+1)-z_wall(j)) + ENDDO + + j = nl_wall + fn(j) = tk(j)*(twall_inner - cnfac*t_wall(j))/(zi_wall(j)-z_wall(j)) + tkdz_wall= tk(j)/(zi_wall(j)-z_wall(j)) + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = 1 + dzp = z_wall(j+1)-z_wall(j) + at(j) = 0. + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + rt(j) = t_wall(j) + fact(j)*( hs - dhsdT*t_wall(j) + cnfac*fn(j) ) + + DO j = 2, nl_wall - 1 + dzm = (z_wall(j)-z_wall(j-1)) + dzp = (z_wall(j+1)-z_wall(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_wall(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO + + j = nl_wall + dzm = (z_wall(j)-z_wall(j-1)) + dzp = (zi_wall(j)-z_wall(j)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j-1)/dzm+tk(j)/dzp) + ct(j) = 0. + rt(j) = t_wall(j) + fact(j)*(fn(j) - cnfac*fn(j-1)) + +! solve for t_wall + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_wall) + + j = nl_wall + fn1(j) = tk(j)*(twall_inner - cnfac*t_wall(j))/(zi_wall(j)-z_wall(j)) + + END SUBROUTINE UrbanWallTem + +END MODULE MOD_Urban_WallTemperature +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 new file mode 100644 index 0000000000..09dbd7cbfc --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 @@ -0,0 +1,72 @@ +#include + +MODULE MOD_DBedrockReadin + + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: dbedrock_readin + +CONTAINS + + SUBROUTINE dbedrock_readin (dir_landdata, lc_year) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_UserDefFun + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_Global, only: nl_soil, dz_soi + USE MOD_Vars_TimeInvariants, only: dbedrock, ibedrock +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year ! which year of data used + character(len=256), intent(in) :: dir_landdata + + ! Local Variables + character(len=256) :: lndname, cyear + integer :: ipatch, L + +#ifdef SinglePoint + dbedrock(:) = SITE_dbedrock +#else + write(cyear,'(i4.4)') lc_year + lndname = trim(dir_landdata)//'/dbedrock/'//trim(cyear)//'/dbedrock_patches.nc' + CALL ncio_read_vector (lndname, 'dbedrock_patches', landpatch, dbedrock) +#endif + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + + L = landpatch%settyp(ipatch) + + IF (L == 0) THEN + ibedrock(ipatch) = 0 + ELSE + + dbedrock(ipatch) = dbedrock(ipatch) / 100.0 ! from cm to meter + dbedrock(ipatch) = max(dbedrock(ipatch), dz_soi(1)) + + IF (dbedrock(ipatch) > zi_soi(1)) THEN + ibedrock(ipatch) = findloc_ud(dbedrock(ipatch)>zi_soi, back=.true.) + 1 + ELSE + ibedrock(ipatch) = 1 + ENDIF + + ENDIF + + ENDDO + + ENDIF + + END SUBROUTINE dbedrock_readin + +END MODULE MOD_DBedrockReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 new file mode 100644 index 0000000000..860dcd9bfe --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 @@ -0,0 +1,152 @@ +#include + +MODULE MOD_HtopReadin + + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: HTOP_readin + +CONTAINS + + SUBROUTINE HTOP_readin (dir_landdata, lc_year) + +! =========================================================== +! Read in the canopy tree top height +! =========================================================== + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global + USE MOD_Const_LC + USE MOD_Const_PFT + USE MOD_Vars_TimeInvariants + USE MOD_LandPatch +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_NetCDFVector +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year ! which year of land cover data used + character(len=256), intent(in) :: dir_landdata + + ! Local Variables + character(len=256) :: c + character(len=256) :: landdir, lndname, cyear + integer :: i,j,t,p,ps,pe,m,n,npatch + + real(r8), allocatable :: htoplc (:) + real(r8), allocatable :: htoppft (:) + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_landdata) // '/htop/' // trim(cyear) + + +#ifdef LULC_USGS + + IF (p_is_worker) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + + htop(npatch) = htop0(m) + hbot(npatch) = hbot0(m) + + ENDDO + ENDIF + +#endif + +#ifdef LULC_IGBP +#ifdef SinglePoint + allocate (htoplc (numpatch)) + htoplc(:) = SITE_htop +#else + lndname = trim(landdir)//'/htop_patches.nc' + CALL ncio_read_vector (lndname, 'htop_patches', landpatch, htoplc) +#endif + + IF (p_is_worker) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + + htop(npatch) = htop0(m) + hbot(npatch) = hbot0(m) + + ! trees or woody savannas + IF ( m<6 .or. m==8 ) THEN + ! 01/06/2020, yuan: adjust htop reading + ! 11/15/2021, yuan: adjust htop setting + htop(npatch) = max(2., htoplc(npatch)) + hbot(npatch) = htoplc(npatch)*hbot0(m)/htop0(m) + hbot(npatch) = max(1., hbot(npatch)) + ENDIF + + ENDDO + ENDIF + + IF (allocated(htoplc)) deallocate ( htoplc ) +#endif + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (numpft > 0) THEN + allocate(htoppft(numpft)) + htoppft = pack(SITE_htop_pfts, SITE_pctpfts > 0.) + ENDIF +#else + lndname = trim(landdir)//'/htop_pfts.nc' + CALL ncio_read_vector (lndname, 'htop_pfts', landpft, htoppft) +#endif + + IF (p_is_worker) THEN + DO npatch = 1, numpatch + t = patchtype(npatch) + m = patchclass(npatch) + + IF (t == 0) THEN + ps = patch_pft_s(npatch) + pe = patch_pft_e(npatch) + + DO p = ps, pe + n = pftclass(p) + + htop_p(p) = htop0_p(n) + hbot_p(p) = hbot0_p(n) + + ! for trees + ! 01/06/2020, yuan: adjust htop reading + ! 11/15/2021, yuan: adjust htop setting + IF ( n>0 .and. n<9 ) THEN + htop_p(p) = max(2., htoppft(p)) + hbot_p(p) = htoppft(p)*hbot0_p(n)/htop0_p(n) + hbot_p(p) = max(1., hbot_p(p)) + ENDIF + ENDDO + + htop(npatch) = sum(htop_p(ps:pe)*pftfrac(ps:pe)) + hbot(npatch) = sum(hbot_p(ps:pe)*pftfrac(ps:pe)) + + ELSE + htop(npatch) = htop0(m) + hbot(npatch) = hbot0(m) + ENDIF + + ENDDO + ENDIF + + IF (allocated(htoppft)) deallocate(htoppft) +#endif + + END SUBROUTINE HTOP_readin + +END MODULE MOD_HtopReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 new file mode 100644 index 0000000000..68725e5078 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 @@ -0,0 +1,1376 @@ +#include + +MODULE MOD_IniTimeVariable + +!----------------------------------------------------------------------- + USE MOD_Precision +#ifdef BGC + USE MOD_BGC_CNSummary, only: CNDriverSummarizeStates, CNDriverSummarizeFluxes +#endif + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: IniTimeVar + + +CONTAINS + + SUBROUTINE IniTimeVar(ipatch, patchtype& + ,porsl,psi0,hksati,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb& + ,z0m,zlnd,htop,z0mr,chil,rho,tau,z_soisno,dz_soisno& + ,t_soisno,wliq_soisno,wice_soisno,smp,hk,zwt,wa& +!Plant Hydraulic parameters + ,vegwp,gs0sun,gs0sha& +!End plant hydraulic parameter + ,t_grnd,tleaf,ldew,ldew_rain,ldew_snow,fwet_snow,sag,scv& + ,snowdp,fveg,fsno,sigf,green,lai,sai,lai_old,coszen& + ,snw_rds,mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi& + ,mss_dst1,mss_dst2,mss_dst3,mss_dst4& + ,alb,ssun,ssha,ssoi,ssno,ssno_lyr& +#ifdef HYPERSPECTRAL + ,alb_hires& +#endif + ,thermk,extkb,extkd& + ,trad,tref,qref,rst,emis,zol,rib& + ,ustar,qstar,tstar,fm,fh,fq& +#ifdef HYPERSPECTRAL + ,clr_frac, cld_frac & + ,reflectance, transmittance, soil_alb, kw, nw& + ,reflectance_out, transmittance_out& + ,patchlatr, patchlonr& + ,urban_albedo, mean_albedo, lat_north, lat_south, lon_east, lon_west& +#endif +!Ozone Variables + ,o3coefv_sun,o3coefv_sha,o3coefg_sun,o3coefg_sha& +#if (defined BGC) + ,use_cnini, totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_veg, ctrunc_soil, ctrunc_vr & + ,totlitn, totsomn, totcwdn, decomp_npools, decomp_npools_vr, ntrunc_veg, ntrunc_soil, ntrunc_vr & + ,totvegc, totvegn, totcolc, totcoln, col_endcb, col_begcb, col_endnb, col_begnb & + ,col_vegendcb, col_vegbegcb, col_soilendcb, col_soilbegcb & + ,col_vegendnb, col_vegbegnb, col_soilendnb, col_soilbegnb & + ,col_sminnendnb, col_sminnbegnb & + ,altmax, altmax_lastyear, altmax_lastyear_indx, lag_npp & + ,sminn_vr, sminn, smin_no3_vr, smin_nh4_vr & + ,prec10, prec60, prec365, prec_today, prec_daily, tsoi17, rh30, accumnstep, skip_balance_check & +!------------------------SASU variables----------------- + ,decomp0_cpools_vr , decomp0_npools_vr & + ,I_met_c_vr_acc , I_cel_c_vr_acc , I_lig_c_vr_acc , I_cwd_c_vr_acc & + ,AKX_met_to_soil1_c_vr_acc , AKX_cel_to_soil1_c_vr_acc , AKX_lig_to_soil2_c_vr_acc , AKX_soil1_to_soil2_c_vr_acc & + ,AKX_cwd_to_cel_c_vr_acc , AKX_cwd_to_lig_c_vr_acc , AKX_soil1_to_soil3_c_vr_acc, AKX_soil2_to_soil1_c_vr_acc & + ,AKX_soil2_to_soil3_c_vr_acc, AKX_soil3_to_soil1_c_vr_acc & + ,AKX_met_exit_c_vr_acc , AKX_cel_exit_c_vr_acc , AKX_lig_exit_c_vr_acc , AKX_cwd_exit_c_vr_acc & + ,AKX_soil1_exit_c_vr_acc , AKX_soil2_exit_c_vr_acc , AKX_soil3_exit_c_vr_acc & + ,diagVX_c_vr_acc , upperVX_c_vr_acc , lowerVX_c_vr_acc & + ,I_met_n_vr_acc , I_cel_n_vr_acc , I_lig_n_vr_acc , I_cwd_n_vr_acc & + ,AKX_met_to_soil1_n_vr_acc , AKX_cel_to_soil1_n_vr_acc , AKX_lig_to_soil2_n_vr_acc , AKX_soil1_to_soil2_n_vr_acc & + ,AKX_cwd_to_cel_n_vr_acc , AKX_cwd_to_lig_n_vr_acc , AKX_soil1_to_soil3_n_vr_acc, AKX_soil2_to_soil1_n_vr_acc & + ,AKX_soil2_to_soil3_n_vr_acc, AKX_soil3_to_soil1_n_vr_acc & + ,AKX_met_exit_n_vr_acc , AKX_cel_exit_n_vr_acc , AKX_lig_exit_n_vr_acc , AKX_cwd_exit_n_vr_acc & + ,AKX_soil1_exit_n_vr_acc , AKX_soil2_exit_n_vr_acc , AKX_soil3_exit_n_vr_acc & + ,diagVX_n_vr_acc , upperVX_n_vr_acc , lowerVX_n_vr_acc & +!------------------------------------------------------------ +#endif + ,use_soilini, nl_soil_ini, soil_z, soil_t, soil_w, use_snowini, snow_d & + ,use_wtd, zwtmm, zc_soimm, zi_soimm, vliq_r, nprms, prms) + +!======================================================================= +! Created by Yongjiu Dai, 09/15/1999 +! Revised by Yongjiu Dai, 08/30/2002 +! 03/2014 +!======================================================================= + + USE MOD_Precision + USE MOD_Utils + USE MOD_Const_Physical, only: tfrz, denh2o, denice + USE MOD_Vars_TimeVariables, only: tlai, tsai + USE MOD_Const_PFT, only: isevg, woody, leafcn, frootcn, livewdcn, deadwdcn, slatop, manure + USE MOD_Vars_TimeInvariants, only: ibedrock, dbedrock +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_Vars_Global +#ifdef HYPERSPECTRAL + USE MOD_Albedo_HiRes +#else + USE MOD_Albedo +#endif + USE MOD_Namelist + USE MOD_Hydro_SoilWater + USE MOD_SnowFraction + USE MOD_SPMD_Task + + IMPLICIT NONE + + integer, intent(in) :: &! + ipatch, &! patch index + patchtype ! index for land cover type [-] + + real(r8), intent(in) :: &! + fveg, &! fraction of vegetation cover + green, &! leaf greenness + coszen, &! cosine of solar zenith angle + soil_s_v_alb, &! albedo of visible of the saturated soil + soil_d_v_alb, &! albedo of visible of the dry soil + soil_s_n_alb, &! albedo of near infrared of the saturated soil + soil_d_n_alb, &! albedo of near infrared of the dry soil + zlnd, &! aerodynamic roughness length over soil surface [m] + z0mr, &! ratio to calculate roughness length z0m + htop, &! canopy top height [m] + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + porsl(1:nl_soil), &! porosity of soil + psi0 (1:nl_soil), &! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil) ! hydraulic conductivity at saturation [mm h2o/s] +#ifdef HYPERSPECTRAL + real(r8), intent(in) :: &! + clr_frac ( 211, 89, 5 ) ,& + cld_frac ( 211, 5 ) ,& + reflectance ( 0:15, 211, 2 ) ,& + transmittance ( 0:15, 211, 2 ) ,& + soil_alb ( 211 ), kw(211), nw(211) + + real(r8), intent(in) :: &! + patchlatr, &! patch latitude + patchlonr ! patch longitude + ! Urban hyperspectral albedo + REAL(r8), ALLOCATABLE :: urban_albedo( :, :, : ) ! (cluster_id, season wavelength) + REAL(r8), ALLOCATABLE :: mean_albedo ( :, : ) ! (season, wavelength) + REAL(r8), ALLOCATABLE :: lat_north ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lat_south ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lon_east ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lon_west ( : ) ! (cluster_id) +#endif + real(r8), intent(inout) :: & + z0m ! aerodynamic roughness length [m] + + logical, intent(in) :: use_soilini +#ifdef BGC + logical, intent(in) :: use_cnini +#endif + integer, intent(in) :: nl_soil_ini + real(r8), intent(in) :: &! + soil_z(nl_soil_ini), &! soil layer depth for initial (m) + soil_t(nl_soil_ini), &! soil temperature from initial file (K) + soil_w(nl_soil_ini) ! soil wetness from initial file (-) + + logical, intent(in) :: use_snowini + real(r8), intent(in) :: snow_d ! snow depth (m) + + logical, intent(in) :: use_wtd + real(r8), intent(in) :: zwtmm + real(r8), intent(in) :: zc_soimm(1:nl_soil) + real(r8), intent(in) :: zi_soimm(0:nl_soil) + real(r8), intent(in) :: vliq_r (1:nl_soil) + integer, intent(in) :: nprms + real(r8), intent(in) :: prms(nprms, 1:nl_soil) + + real(r8), intent(inout) :: &! + z_soisno (maxsnl+1:nl_soil), &! node depth [m] + dz_soisno(maxsnl+1:nl_soil) ! layer thickness [m] + + real(r8), intent(out) :: &! + t_soisno (maxsnl+1:nl_soil), &! soil temperature [K] + wliq_soisno(maxsnl+1:nl_soil), &! liquid water in layers [kg/m2] + wice_soisno(maxsnl+1:nl_soil), &! ice lens in layers [kg/m2] + smp (1:nl_soil) , &! soil matrix potential + hk (1:nl_soil) , &! soil hydraulic conductance +!Plant Hydraulic parameters + vegwp(1:nvegwcs), &! vegetation water potential + gs0sun, &! working copy of sunlit stomata conductance + gs0sha, &! working copy of shaded stomata conductance +!end plant hydraulic parameters + t_grnd, &! ground surface temperature [K] + tleaf, &! sunlit leaf temperature [K] +!#ifdef CLM5_INTERCEPTION + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow, &! depth of snow on foliage [mm] +!#endif + fwet_snow, &! vegetation snow fractional cover [-] + ldew, &! depth of water on foliage [mm] + sag, &! non dimensional snow age [-] + scv, &! snow cover, water equivalent [mm] + snowdp, &! snow depth [meter] + fsno, &! fraction of snow cover on ground + sigf, &! fraction of veg cover, excluding snow-covered veg [-] + lai, &! leaf area index + sai, &! stem area index + lai_old, &! leaf area index + + alb (2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] +#ifdef HYPERSPECTRAL + alb_hires (211,2), &! averaged albedo [-] + reflectance_out (211, 0:15) ,& + transmittance_out(211, 0:15) ,& +#endif + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + wa ! water storage in aquifer [mm] + real(r8), intent(inout) :: &! + zwt ! the depth to water table [m] + + real(r8), intent(out) :: &! + snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] + mss_bcphi( maxsnl+1:0 ), &! mass concentration of hydrophilic BC (col,lyr) [kg/kg] + mss_bcpho( maxsnl+1:0 ), &! mass concentration of hydrophobic BC (col,lyr) [kg/kg] + mss_ocphi( maxsnl+1:0 ), &! mass concentration of hydrophilic OC (col,lyr) [kg/kg] + mss_ocpho( maxsnl+1:0 ), &! mass concentration of hydrophobic OC (col,lyr) [kg/kg] + mss_dst1 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + mss_dst2 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + mss_dst3 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + mss_dst4 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + ssno_lyr (2,2,maxsnl+1:1 ), &! snow layer absorption [-] + + ! Additional variables required by regional model (WRF & RSM) + ! --------------------------------------------------------- + trad, &! radiative temperature of surface [K] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air specific humidity + rst, &! canopy stomatal resistance (s/m) + emis, &! averaged bulk surface emissivity + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! u* in similarity theory [m/s] + qstar, &! q* in similarity theory [kg/kg] + tstar, &! t* in similarity theory [K] + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + real(r8), intent(out) :: & + o3coefv_sun, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun, &! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ! Ozone stress factor for stomata on shaded leaf + +#ifdef BGC + real(r8),intent(out) :: & + totlitc , & + totsomc , & + totcwdc , & + totvegc , & + totcolc , & + totlitn , & + totsomn , & + totcwdn , & + totvegn , & + totcoln , & + col_endcb , & + col_begcb , & + col_vegendcb , & + col_vegbegcb , & + col_soilendcb , & + col_soilbegcb , & + col_endnb , & + col_begnb , & + col_vegendnb , & + col_vegbegnb , & + col_soilendnb , & + col_soilbegnb , & + col_sminnendnb , & + col_sminnbegnb , & + decomp_cpools_vr (nl_soil_full,ndecomp_pools), & + decomp_cpools (ndecomp_pools) , & + ctrunc_vr (nl_soil) , & + ctrunc_veg , & + ctrunc_soil , & + altmax , & + altmax_lastyear , & + lag_npp + integer, intent(out) :: altmax_lastyear_indx + real(r8),intent(out) :: & + decomp_npools_vr (nl_soil_full,ndecomp_pools), & + decomp_npools (ndecomp_pools) , & + ntrunc_vr (nl_soil) , & + ntrunc_veg , & + ntrunc_soil , & + sminn_vr (nl_soil) , & + sminn , & + smin_no3_vr (nl_soil) , & + smin_nh4_vr (nl_soil) , & + prec10 , & + prec60 , & + prec365 , & + prec_today , & + prec_daily (365) , & + tsoi17 , & + rh30 , & + accumnstep + + !---------------SASU variables----------------------- + real(r8),intent(out) :: & + decomp0_cpools_vr (nl_soil,ndecomp_pools) , & + decomp0_npools_vr (nl_soil,ndecomp_pools) , & + + I_met_c_vr_acc (nl_soil) , & + I_cel_c_vr_acc (nl_soil) , & + I_lig_c_vr_acc (nl_soil) , & + I_cwd_c_vr_acc (nl_soil) , & + AKX_met_to_soil1_c_vr_acc (nl_soil) , & + AKX_cel_to_soil1_c_vr_acc (nl_soil) , & + AKX_lig_to_soil2_c_vr_acc (nl_soil) , & + AKX_soil1_to_soil2_c_vr_acc(nl_soil) , & + AKX_cwd_to_cel_c_vr_acc (nl_soil) , & + AKX_cwd_to_lig_c_vr_acc (nl_soil) , & + AKX_soil1_to_soil3_c_vr_acc(nl_soil) , & + AKX_soil2_to_soil1_c_vr_acc(nl_soil) , & + AKX_soil2_to_soil3_c_vr_acc(nl_soil) , & + AKX_soil3_to_soil1_c_vr_acc(nl_soil) , & + AKX_met_exit_c_vr_acc (nl_soil) , & + AKX_cel_exit_c_vr_acc (nl_soil) , & + AKX_lig_exit_c_vr_acc (nl_soil) , & + AKX_cwd_exit_c_vr_acc (nl_soil) , & + AKX_soil1_exit_c_vr_acc (nl_soil) , & + AKX_soil2_exit_c_vr_acc (nl_soil) , & + AKX_soil3_exit_c_vr_acc (nl_soil) , & + + I_met_n_vr_acc (nl_soil) , & + I_cel_n_vr_acc (nl_soil) , & + I_lig_n_vr_acc (nl_soil) , & + I_cwd_n_vr_acc (nl_soil) , & + AKX_met_to_soil1_n_vr_acc (nl_soil) , & + AKX_cel_to_soil1_n_vr_acc (nl_soil) , & + AKX_lig_to_soil2_n_vr_acc (nl_soil) , & + AKX_soil1_to_soil2_n_vr_acc(nl_soil) , & + AKX_cwd_to_cel_n_vr_acc (nl_soil) , & + AKX_cwd_to_lig_n_vr_acc (nl_soil) , & + AKX_soil1_to_soil3_n_vr_acc(nl_soil) , & + AKX_soil2_to_soil1_n_vr_acc(nl_soil) , & + AKX_soil2_to_soil3_n_vr_acc(nl_soil) , & + AKX_soil3_to_soil1_n_vr_acc(nl_soil) , & + AKX_met_exit_n_vr_acc (nl_soil) , & + AKX_cel_exit_n_vr_acc (nl_soil) , & + AKX_lig_exit_n_vr_acc (nl_soil) , & + AKX_cwd_exit_n_vr_acc (nl_soil) , & + AKX_soil1_exit_n_vr_acc (nl_soil) , & + AKX_soil2_exit_n_vr_acc (nl_soil) , & + AKX_soil3_exit_n_vr_acc (nl_soil) , & + + diagVX_c_vr_acc (nl_soil,ndecomp_pools) , & + upperVX_c_vr_acc (nl_soil,ndecomp_pools) , & + lowerVX_c_vr_acc (nl_soil,ndecomp_pools) , & + diagVX_n_vr_acc (nl_soil,ndecomp_pools) , & + upperVX_n_vr_acc (nl_soil,ndecomp_pools) , & + lowerVX_n_vr_acc (nl_soil,ndecomp_pools) + + !---------------------------------------------------- + logical, intent(out) :: & + skip_balance_check + +#endif + + integer j, snl, m, ivt + real(r8) wet(nl_soil), zi_soi_a(0:nl_soil), psi, vliq, wt, ssw, oro, rhosno_ini, a + + ! SNICAR + real(r8) pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8) snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] + + integer ps, pe + + !----------------------------------------------------------------------- + IF(patchtype <= 5)THEN ! land grid + + ! (1) SOIL temperature, water and SNOW + ! Variables: t_soisno, wliq_soisno, wice_soisno, wa, zwt + IF (use_soilini) THEN + ! (1.1) all temperature, water and zwt from data. + + zi_soi_a(:) = (/0., zi_soi/) + + DO j = 1, nl_soil + CALL polint(soil_z,soil_t,nl_soil_ini,z_soisno(j),t_soisno(j)) + ENDDO + + IF (patchtype <= 1) THEN ! soil or urban + + DO j = 1, nl_soil + + CALL polint(soil_z,soil_w,nl_soil_ini,z_soisno(j),wet(j)) + + wet(j) = min(max(wet(j),0.), porsl(j)) + + IF (zwt <= zi_soi_a(j-1)) THEN + wet(j) = porsl(j) + ELSEIF (zwt < zi_soi_a(j)) THEN + wet(j) = ((zi_soi_a(j)-zwt)*porsl(j) + (zwt-zi_soi_a(j-1))*wet(j)) & + / (zi_soi_a(j)-zi_soi_a(j-1)) + ENDIF + + IF(t_soisno(j).ge.tfrz)THEN + wliq_soisno(j) = wet(j)*dz_soisno(j)*denh2o + wice_soisno(j) = 0. + ELSE + wliq_soisno(j) = 0. + wice_soisno(j) = wet(j)*dz_soisno(j)*denice + ENDIF + ENDDO + + ! get wa from zwt + IF (zwt > zi_soi_a(nl_soil)) THEN + psi = psi0(nl_soil) - (zwt*1000. - zi_soi_a(nl_soil)*1000.) * 0.5 + vliq = soil_vliq_from_psi (psi, porsl(nl_soil), vliq_r(nl_soil), psi0(nl_soil), & + nprms, prms(:,nl_soil)) + wa = -(zwt*1000. - zi_soi_a(nl_soil)*1000.)*(porsl(nl_soil)-vliq) + ELSE + wa = 0. + ENDIF + + ELSEIF ((patchtype == 2) .or. (patchtype == 4)) THEN ! (2) wetland or (4) lake + + DO j = 1, nl_soil + IF(t_soisno(j).ge.tfrz)THEN + wliq_soisno(j) = porsl(j)*dz_soisno(j)*denh2o + wice_soisno(j) = 0. + ELSE + wliq_soisno(j) = 0. + wice_soisno(j) = porsl(j)*dz_soisno(j)*denice + ENDIF + ENDDO + + wa = 0. + zwt = 0. + + ELSEIF (patchtype == 3) THEN ! land ice + + DO j = 1, nl_soil + wliq_soisno(j) = 0. + wice_soisno(j) = dz_soisno(j)*denice + ENDDO + + wa = 0. + zwt = 0. + + ENDIF + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = wa + 5000. + ENDIF + + ELSEIF (use_wtd) THEN + ! (1.2) only zwt is from data. + + DO j = 1, nl_soil + IF(patchtype==3)THEN !land ice + t_soisno(j) = 253. + wliq_soisno(j) = 0. + wice_soisno(j) = dz_soisno(j)*denice + ELSE + t_soisno(j) = 283. + wliq_soisno(j) = dz_soisno(j)*porsl(j)*denh2o + wice_soisno(j) = 0. + ENDIF + ENDDO + + IF (patchtype <= 1) THEN + CALL get_water_equilibrium_state (zwtmm, nl_soil, wliq_soisno(1:nl_soil), smp, hk, wa, & + zc_soimm, zi_soimm, porsl, vliq_r, psi0, hksati, nprms, prms) + ELSE + wa = 0. + zwt = 0. + ENDIF + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = wa + 5000. + ENDIF + + ELSE + ! (1.3) cold start + + DO j = 1, nl_soil + IF(patchtype==3)THEN !land ice + t_soisno(j) = 253. + wliq_soisno(j) = 0. + wice_soisno(j) = dz_soisno(j)*denice + ELSE + t_soisno(j) = 283. + wliq_soisno(j) = dz_soisno(j)*porsl(j)*denh2o + wice_soisno(j) = 0. + ENDIF + ENDDO + + IF (patchtype <= 1) THEN + IF (DEF_USE_VariablySaturatedFlow) THEN + wa = 0. + zwt = zi_soimm(nl_soil)/1000. + ELSE + ! water table depth (initially at 1.0 m below the model bottom; wa when zwt + ! is below the model bottom zi(nl_soil) + wa = 4800. !assuming aquifer capacity is 5000 mm + zwt = (25. + z_soisno(nl_soil))+dz_soisno(nl_soil)/2. - wa/1000./0.2 !to result in zwt = zi(nl_soil) + 1.0 m + ENDIF + ELSE + wa = 0. + zwt = 0. + ENDIF + + ENDIF + + + ! (2) snow initialization + ! variables: snowdp, sag, scv, fsno, snl, z_soisno, dz_soisno + z0m = htop * z0mr +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF(patchtype==0)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + IF (ps>0 .and. pe>0) THEN + z0m_p(ps:pe) = htop_p(ps:pe) * z0mr + ENDIF + ENDIF +#endif + + IF (use_snowini) THEN + + rhosno_ini = 250. + snowdp = snow_d + sag = 0. + scv = snowdp*rhosno_ini + + ! 08/02/2019, yuan: NOTE! need to be changed in future. + ! 12/05/2023, yuan: DONE for snowini, change sai. + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + CALL snow_ini (patchtype,maxsnl,snowdp,snl,z_soisno,dz_soisno) + + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + IF(DEF_USE_LAIFEEDBACK)THEN + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ELSE + lai_p(ps:pe) = tlai_p(ps:pe) + lai = tlai(ipatch) + ENDIF + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) +#endif + ENDIF + + IF(snl.lt.0)THEN + DO j = snl+1, 0 + t_soisno(j) = min(tfrz-1., t_soisno(1)) + wliq_soisno(j) = 0. + wice_soisno(j) = dz_soisno(j)*rhosno_ini !m * kg m-3 = kg m-2 + ENDDO + ENDIF + + IF(snl>maxsnl)THEN + t_soisno (maxsnl+1:snl) = -999. + wice_soisno(maxsnl+1:snl) = 0. + wliq_soisno(maxsnl+1:snl) = 0. + z_soisno (maxsnl+1:snl) = 0. + dz_soisno (maxsnl+1:snl) = 0. + ENDIF + + ELSE + + snowdp = 0. + sag = 0. + scv = 0. + fsno = 0. + snl = 0 + + ! snow temperature and water content + t_soisno (maxsnl+1:0) = -999. + wice_soisno(maxsnl+1:0) = 0. + wliq_soisno(maxsnl+1:0) = 0. + z_soisno (maxsnl+1:0) = 0. + dz_soisno (maxsnl+1:0) = 0. + + ENDIF + + + ! (3) soil matrix potential hydraulic conductivity + ! Variables: smp, hk + DO j = 1, nl_soil + IF ((patchtype==3) .or. (t_soisno(j) < tfrz)) THEN !land ice or frozen soil + smp(j) = 1.e3 * 0.3336e6/9.80616*(t_soisno(j)-tfrz)/t_soisno(j) + hk(j) = 0. + ELSE + vliq = wliq_soisno(j) / (zi_soimm(j)-zi_soimm(j-1)) + smp(j) = soil_psi_from_vliq (vliq, porsl(j), vliq_r(j), psi0(j), nprms, prms(:,j)) + hk (j) = soil_hk_from_psi (smp(j), psi0(j), hksati(j), nprms, prms(:,j)) + ENDIF + ENDDO + + ! (4) Vegetation water and temperature + ! Variables: ldew_rain, ldew_snow, ldew, t_leaf, vegwp, gs0sun, gs0sha + ldew_rain = 0. + ldew_snow = 0. + fwet_snow = 0. + ldew = 0. + tleaf = t_soisno(1) + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp(1:nvegwcs) = -2.5e4 + gs0sun = 1.0e4 + gs0sha = 1.0e4 + ENDIF + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + ldew_rain_p(ps:pe) = 0. + ldew_snow_p(ps:pe) = 0. + fwet_snow_p(ps:pe) = 0. + ldew_p(ps:pe) = 0. + tleaf_p(ps:pe)= t_soisno(1) + tref_p(ps:pe) = t_soisno(1) + qref_p(ps:pe) = 0.3 + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp_p(1:nvegwcs,ps:pe) = -2.5e4 + gs0sun_p(ps:pe) = 1.0e4 + gs0sha_p(ps:pe) = 1.0e4 + ENDIF +#endif + ENDIF + + ! (5) Ground + ! Variables: t_grnd + t_grnd = t_soisno(1) + + ! (6) Leaf area + ! Variables: sigf, lai, sai + + IF (.not. use_snowini) THEN + IF (patchtype == 0) THEN +#if (defined LULC_USGS || defined LULC_IGBP) + sigf = fveg + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + IF(DEF_USE_OZONESTRESS)THEN + lai_old = lai + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + sigf_p (ps:pe) = 1. + lai_p(ps:pe) = tlai_p(ps:pe) + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + + sigf = 1. + lai = tlai(ipatch) + sai = sum(sai_p(ps:pe) * pftfrac(ps:pe)) + IF(DEF_USE_OZONESTRESS)THEN + lai_old = lai + lai_old_p(ps:pe) = lai_p(ps:pe) + ENDIF +#endif + ELSE + sigf = fveg + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + IF(DEF_USE_OZONESTRESS)THEN + lai_old = lai + ENDIF + ENDIF + ENDIF + + ! (7) SNICAR + ! Variables: snw_rds, mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi, + ! mss_dst1, mss_dst2, mss_dst3, mss_dst4 + snw_rds (:) = 54.526_r8 + mss_bcpho (:) = 0. + mss_bcphi (:) = 0. + mss_ocpho (:) = 0. + mss_ocphi (:) = 0. + mss_dst1 (:) = 0. + mss_dst2 (:) = 0. + mss_dst3 (:) = 0. + mss_dst4 (:) = 0. + +#ifdef BGC + totlitc = 0.0 + totsomc = 0.0 + totcwdc = 0.0 + totvegc = 0.0 + totcolc = 0.0 + totlitn = 0.0 + totsomn = 0.0 + totcwdn = 0.0 + totvegn = 0.0 + col_endcb = 0.0 + col_begcb = 0.0 + col_vegendcb = 0.0 + col_vegbegcb = 0.0 + col_soilendcb = 0.0 + col_soilbegcb = 0.0 + col_endnb = 0.0 + col_begnb = 0.0 + col_vegendnb = 0.0 + col_vegbegnb = 0.0 + col_soilendnb = 0.0 + col_soilbegnb = 0.0 + IF(.not. use_cnini)THEN + decomp_cpools_vr (:,:) = 0.0 + ENDIF + decomp_cpools (:) = 0.0 + ctrunc_vr (:) = 0.0 + ctrunc_veg = 0.0 + ctrunc_soil = 0.0 + altmax = 10.0 + altmax_lastyear = 10.0 + altmax_lastyear_indx = 10 + lag_npp = 0.0 + IF(.not. use_cnini)THEN + decomp_npools_vr (:,:) = 0.0 + ENDIF + decomp_npools (:) = 0.0 + ntrunc_vr (:) = 0.0 + ntrunc_veg = 0.0 + ntrunc_soil = 0.0 + IF(.not. use_cnini)THEN + smin_no3_vr (:) = 5.0 + smin_nh4_vr (:) = 5.0 + sminn_vr (:) = 10.0 + ENDIF + sminn = 0.0 + DO j = 1, nl_soil + sminn = sminn + sminn_vr(j) * dz_soisno(j) + ENDDO + col_sminnendnb = sminn + col_sminnbegnb = sminn + totcoln = totvegn + totcwdn + totlitn + totsomn + sminn + ntrunc_veg + ntrunc_soil + prec10 = 0._r8 + prec60 = 0._r8 + prec365 = 0._r8 + prec_today = 0._r8 + prec_daily (:) = 0._r8 + tsoi17 = 273.15_r8 + rh30 = 0._r8 + accumnstep = 0._r8 + + !---------------SASU variables----------------------- + decomp0_cpools_vr (:,:) = 0.0 + I_met_c_vr_acc (:) = 0.0 + I_cel_c_vr_acc (:) = 0.0 + I_lig_c_vr_acc (:) = 0.0 + I_cwd_c_vr_acc (:) = 0.0 + AKX_met_to_soil1_c_vr_acc (:) = 0.0 + AKX_cel_to_soil1_c_vr_acc (:) = 0.0 + AKX_lig_to_soil2_c_vr_acc (:) = 0.0 + AKX_soil1_to_soil2_c_vr_acc (:) = 0.0 + AKX_cwd_to_cel_c_vr_acc (:) = 0.0 + AKX_cwd_to_lig_c_vr_acc (:) = 0.0 + AKX_soil1_to_soil3_c_vr_acc (:) = 0.0 + AKX_soil2_to_soil1_c_vr_acc (:) = 0.0 + AKX_soil2_to_soil3_c_vr_acc (:) = 0.0 + AKX_soil3_to_soil1_c_vr_acc (:) = 0.0 + AKX_met_exit_c_vr_acc (:) = 0.0 + AKX_cel_exit_c_vr_acc (:) = 0.0 + AKX_lig_exit_c_vr_acc (:) = 0.0 + AKX_cwd_exit_c_vr_acc (:) = 0.0 + AKX_soil1_exit_c_vr_acc (:) = 0.0 + AKX_soil2_exit_c_vr_acc (:) = 0.0 + AKX_soil3_exit_c_vr_acc (:) = 0.0 + + decomp0_npools_vr (:,:) = 0.0 + I_met_n_vr_acc (:) = 0.0 + I_cel_n_vr_acc (:) = 0.0 + I_lig_n_vr_acc (:) = 0.0 + I_cwd_n_vr_acc (:) = 0.0 + AKX_met_to_soil1_n_vr_acc (:) = 0.0 + AKX_cel_to_soil1_n_vr_acc (:) = 0.0 + AKX_lig_to_soil2_n_vr_acc (:) = 0.0 + AKX_soil1_to_soil2_n_vr_acc (:) = 0.0 + AKX_cwd_to_cel_n_vr_acc (:) = 0.0 + AKX_cwd_to_lig_n_vr_acc (:) = 0.0 + AKX_soil1_to_soil3_n_vr_acc (:) = 0.0 + AKX_soil2_to_soil1_n_vr_acc (:) = 0.0 + AKX_soil2_to_soil3_n_vr_acc (:) = 0.0 + AKX_soil3_to_soil1_n_vr_acc (:) = 0.0 + AKX_met_exit_n_vr_acc (:) = 0.0 + AKX_cel_exit_n_vr_acc (:) = 0.0 + AKX_lig_exit_n_vr_acc (:) = 0.0 + AKX_cwd_exit_n_vr_acc (:) = 0.0 + AKX_soil1_exit_n_vr_acc (:) = 0.0 + AKX_soil2_exit_n_vr_acc (:) = 0.0 + AKX_soil3_exit_n_vr_acc (:) = 0.0 + + diagVX_c_vr_acc (:,:) = 0.0 + upperVX_c_vr_acc (:,:) = 0.0 + lowerVX_c_vr_acc (:,:) = 0.0 + diagVX_n_vr_acc (:,:) = 0.0 + upperVX_n_vr_acc (:,:) = 0.0 + lowerVX_n_vr_acc (:,:) = 0.0 + + !---------------------------------------------------- + skip_balance_check = .false. + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtype == 0) THEN + DO m = ps, pe + ivt = pftclass(m) + IF(ivt .eq. 0)THEN !no vegetation + leafc_p (m) = 0.0 + leafc_storage_p (m) = 0.0 + leafn_p (m) = 0.0 + leafn_storage_p (m) = 0.0 + frootc_p (m) = 0.0 + frootc_storage_p (m) = 0.0 + frootn_p (m) = 0.0 + frootn_storage_p (m) = 0.0 + ELSE + IF(isevg(ivt))THEN + IF(.not. use_cnini)THEN + leafc_p (m) = 100.0 + frootc_p (m) = 0.0 + ENDIF + leafc_storage_p (m) = 0.0 + frootc_storage_p (m) = 0.0 + ELSE IF(ivt >= npcropmin) THEN + leafc_p (m) = 0.0 + leafc_storage_p (m) = 0.0 + frootc_p (m) = 0.0 + frootc_storage_p (m) = 0.0 + ELSE + IF(.not. use_cnini)THEN + leafc_p (m) = 0.0 + leafc_storage_p (m) = 100.0 + frootc_p (m) = 0.0 + frootc_storage_p (m) = 0.0 + ENDIF + ENDIF + leafn_p (m) = leafc_p (m) / leafcn (ivt) + leafn_storage_p (m) = leafc_storage_p(m) / leafcn (ivt) + frootn_p (m) = frootc_p (m) / frootcn (ivt) + frootn_storage_p (m) = frootc_storage_p(m) / frootcn (ivt) + ENDIF + IF(woody(ivt) .eq. 1)THEN + IF(.not. use_cnini)THEN + deadstemc_p (m) = 0.1 + livestemc_p (m) = 0.0 + deadcrootc_p (m) = 0.0 + livecrootc_p (m) = 0.0 + ENDIF + livestemn_p (m) = livestemc_p (m) / livewdcn(ivt) + deadstemn_p (m) = deadstemc_p (m) / deadwdcn(ivt) + livecrootn_p (m) = livecrootc_p (m) / livewdcn(ivt) + deadcrootn_p (m) = deadcrootc_p (m) / deadwdcn(ivt) + ELSE + livestemc_p (m) = 0.0 + deadstemc_p (m) = 0.0 + livestemn_p (m) = 0.0 + deadstemn_p (m) = 0.0 + livecrootc_p (m) = 0.0 + deadcrootc_p (m) = 0.0 + livecrootn_p (m) = 0.0 + deadcrootn_p (m) = 0.0 + ENDIF + ! totcolc = totcolc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) + ! totvegc = totvegc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) + ! totcoln = totcoln + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) + ! totvegn = totvegn + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) + ENDDO + IF(DEF_USE_OZONESTRESS)THEN + o3uptakesun_p (ps:pe) = 0._r8 + o3uptakesha_p (ps:pe) = 0._r8 + o3coefv_sun_p (ps:pe) = 1._r8 + o3coefv_sha_p (ps:pe) = 1._r8 + o3coefg_sun_p (ps:pe) = 1._r8 + o3coefg_sha_p (ps:pe) = 1._r8 + ENDIF + leafc_xfer_p (ps:pe) = 0.0 + frootc_xfer_p (ps:pe) = 0.0 + livestemc_storage_p (ps:pe) = 0.0 + livestemc_xfer_p (ps:pe) = 0.0 + deadstemc_storage_p (ps:pe) = 0.0 + deadstemc_xfer_p (ps:pe) = 0.0 + livecrootc_storage_p (ps:pe) = 0.0 + livecrootc_xfer_p (ps:pe) = 0.0 + deadcrootc_storage_p (ps:pe) = 0.0 + deadcrootc_xfer_p (ps:pe) = 0.0 + grainc_p (ps:pe) = 0.0 + grainc_storage_p (ps:pe) = 0.0 + grainc_xfer_p (ps:pe) = 0.0 + cropseedc_deficit_p (ps:pe) = 0.0 + xsmrpool_p (ps:pe) = 0.0 + gresp_storage_p (ps:pe) = 0.0 + gresp_xfer_p (ps:pe) = 0.0 + cpool_p (ps:pe) = 0.0 + ctrunc_p (ps:pe) = 0.0 + cropprod1c_p (ps:pe) = 0.0 + + leafn_xfer_p (ps:pe) = 0.0 + frootn_xfer_p (ps:pe) = 0.0 + livestemn_storage_p (ps:pe) = 0.0 + livestemn_xfer_p (ps:pe) = 0.0 + deadstemn_storage_p (ps:pe) = 0.0 + deadstemn_xfer_p (ps:pe) = 0.0 + livecrootn_storage_p (ps:pe) = 0.0 + livecrootn_xfer_p (ps:pe) = 0.0 + deadcrootn_storage_p (ps:pe) = 0.0 + deadcrootn_xfer_p (ps:pe) = 0.0 + grainn_p (ps:pe) = 0.0 + grainn_storage_p (ps:pe) = 0.0 + grainn_xfer_p (ps:pe) = 0.0 + npool_p (ps:pe) = 0.0 + ntrunc_p (ps:pe) = 0.0 + cropseedn_deficit_p (ps:pe) = 0.0 + retransn_p (ps:pe) = 0.0 + + harvdate_p (ps:pe) = 99999999 + + tempsum_potential_gpp_p (ps:pe) = 0.0 + tempmax_retransn_p (ps:pe) = 0.0 + tempavg_tref_p (ps:pe) = 0.0 + tempsum_npp_p (ps:pe) = 0.0 + tempsum_litfall_p (ps:pe) = 0.0 + annsum_potential_gpp_p (ps:pe) = 0.0 + annmax_retransn_p (ps:pe) = 0.0 + annavg_tref_p (ps:pe) = 280.0 + annsum_npp_p (ps:pe) = 0.0 + annsum_litfall_p (ps:pe) = 0.0 + + bglfr_p (ps:pe) = 0.0 + bgtr_p (ps:pe) = 0.0 + lgsf_p (ps:pe) = 0.0 + gdd0_p (ps:pe) = 0.0 + gdd8_p (ps:pe) = 0.0 + gdd10_p (ps:pe) = 0.0 + gdd020_p (ps:pe) = 0.0 + gdd820_p (ps:pe) = 0.0 + gdd1020_p (ps:pe) = 0.0 + nyrs_crop_active_p (ps:pe) = 0 + + offset_flag_p (ps:pe) = 0.0 + offset_counter_p (ps:pe) = 0.0 + onset_flag_p (ps:pe) = 0.0 + onset_counter_p (ps:pe) = 0.0 + onset_gddflag_p (ps:pe) = 0.0 + onset_gdd_p (ps:pe) = 0.0 + onset_fdd_p (ps:pe) = 0.0 + onset_swi_p (ps:pe) = 0.0 + offset_fdd_p (ps:pe) = 0.0 + offset_swi_p (ps:pe) = 0.0 + dormant_flag_p (ps:pe) = 1.0 + prev_leafc_to_litter_p (ps:pe) = 0.0 + prev_frootc_to_litter_p (ps:pe) = 0.0 + days_active_p (ps:pe) = 0.0 + + burndate_p (ps:pe) = 10000 + grain_flag_p (ps:pe) = 0.0 + +#ifdef CROP + ! crop variables + croplive_p (ps:pe) = .false. + hui_p (ps:pe) = spval + gddplant_p (ps:pe) = spval + peaklai_p (ps:pe) = 0 + aroot_p (ps:pe) = spval + astem_p (ps:pe) = spval + arepr_p (ps:pe) = spval + aleaf_p (ps:pe) = spval + astemi_p (ps:pe) = spval + aleafi_p (ps:pe) = spval + gddmaturity_p (ps:pe) = spval + + cropplant_p (ps:pe) = .false. + idop_p (ps:pe) = 99999999 + cumvd_p (ps:pe) = spval + vf_p (ps:pe) = 0._r8 + cphase_p (ps:pe) = 4._r8 + fert_counter_p (ps:pe) = 0._r8 + tref_min_p (ps:pe) = 273.15_r8 + tref_max_p (ps:pe) = 273.15_r8 + tref_min_inst_p (ps:pe) = spval + tref_max_inst_p (ps:pe) = spval + latbaset_p (ps:pe) = spval + fert_p (ps:pe) = 0._r8 + IF(DEF_FERT_SOURCE == 1)THEN + manunitro_p (ps:pe) = manure(pftclass(ps:pe)) * 1000 + ENDIF +#endif + + IF(DEF_USE_LAIFEEDBACK)THEN + tlai_p (ps:pe) = slatop(pftclass(ps:pe)) * leafc_p(ps:pe) + tlai_p (ps:pe) = max(0._r8, tlai_p(ps:pe)) + lai_p (ps:pe) = tlai_p(ps:pe) + lai = sum(lai_p(ps:pe) * pftfrac(ps:pe)) + IF(DEF_USE_OZONESTRESS)THEN + lai_old = lai + lai_old_p (ps:pe) = lai_p(ps:pe) + ENDIF + ENDIF + +#ifdef BGC + CALL CNDriverSummarizeStates(ipatch,ps,pe,nl_soil,dz_soi,ndecomp_pools,.true.) +#endif + + ! SASU varaibles + leafc0_p (ps:pe) = 0.0 + leafc0_storage_p (ps:pe) = 0.0 + leafc0_xfer_p (ps:pe) = 0.0 + frootc0_p (ps:pe) = 0.0 + frootc0_storage_p (ps:pe) = 0.0 + frootc0_xfer_p (ps:pe) = 0.0 + livestemc0_p (ps:pe) = 0.0 + livestemc0_storage_p (ps:pe) = 0.0 + livestemc0_xfer_p (ps:pe) = 0.0 + deadstemc0_p (ps:pe) = 0.0 + deadstemc0_storage_p (ps:pe) = 0.0 + deadstemc0_xfer_p (ps:pe) = 0.0 + livecrootc0_p (ps:pe) = 0.0 + livecrootc0_storage_p (ps:pe) = 0.0 + livecrootc0_xfer_p (ps:pe) = 0.0 + deadcrootc0_p (ps:pe) = 0.0 + deadcrootc0_storage_p (ps:pe) = 0.0 + deadcrootc0_xfer_p (ps:pe) = 0.0 + grainc0_p (ps:pe) = 0.0 + grainc0_storage_p (ps:pe) = 0.0 + grainc0_xfer_p (ps:pe) = 0.0 + + leafn0_p (ps:pe) = 0.0 + leafn0_storage_p (ps:pe) = 0.0 + leafn0_xfer_p (ps:pe) = 0.0 + frootn0_p (ps:pe) = 0.0 + frootn0_storage_p (ps:pe) = 0.0 + frootn0_xfer_p (ps:pe) = 0.0 + livestemn0_p (ps:pe) = 0.0 + livestemn0_storage_p (ps:pe) = 0.0 + livestemn0_xfer_p (ps:pe) = 0.0 + deadstemn0_p (ps:pe) = 0.0 + deadstemn0_storage_p (ps:pe) = 0.0 + deadstemn0_xfer_p (ps:pe) = 0.0 + livecrootn0_p (ps:pe) = 0.0 + livecrootn0_storage_p (ps:pe) = 0.0 + livecrootn0_xfer_p (ps:pe) = 0.0 + deadcrootn0_p (ps:pe) = 0.0 + deadcrootn0_storage_p (ps:pe) = 0.0 + deadcrootn0_xfer_p (ps:pe) = 0.0 + grainn0_p (ps:pe) = 0.0 + grainn0_storage_p (ps:pe) = 0.0 + grainn0_xfer_p (ps:pe) = 0.0 + retransn0_p (ps:pe) = 0.0 + + I_leafc_p_acc (ps:pe) = 0._r8 + I_leafc_st_p_acc (ps:pe) = 0._r8 + I_frootc_p_acc (ps:pe) = 0._r8 + I_frootc_st_p_acc (ps:pe) = 0._r8 + I_livestemc_p_acc (ps:pe) = 0._r8 + I_livestemc_st_p_acc (ps:pe) = 0._r8 + I_deadstemc_p_acc (ps:pe) = 0._r8 + I_deadstemc_st_p_acc (ps:pe) = 0._r8 + I_livecrootc_p_acc (ps:pe) = 0._r8 + I_livecrootc_st_p_acc (ps:pe) = 0._r8 + I_deadcrootc_p_acc (ps:pe) = 0._r8 + I_deadcrootc_st_p_acc (ps:pe) = 0._r8 + I_grainc_p_acc (ps:pe) = 0._r8 + I_grainc_st_p_acc (ps:pe) = 0._r8 + I_leafn_p_acc (ps:pe) = 0._r8 + I_leafn_st_p_acc (ps:pe) = 0._r8 + I_frootn_p_acc (ps:pe) = 0._r8 + I_frootn_st_p_acc (ps:pe) = 0._r8 + I_livestemn_p_acc (ps:pe) = 0._r8 + I_livestemn_st_p_acc (ps:pe) = 0._r8 + I_deadstemn_p_acc (ps:pe) = 0._r8 + I_deadstemn_st_p_acc (ps:pe) = 0._r8 + I_livecrootn_p_acc (ps:pe) = 0._r8 + I_livecrootn_st_p_acc (ps:pe) = 0._r8 + I_deadcrootn_p_acc (ps:pe) = 0._r8 + I_deadcrootn_st_p_acc (ps:pe) = 0._r8 + I_grainn_p_acc (ps:pe) = 0._r8 + I_grainn_st_p_acc (ps:pe) = 0._r8 + + AKX_leafc_xf_to_leafc_p_acc (ps:pe) = 0._r8 + AKX_frootc_xf_to_frootc_p_acc (ps:pe) = 0._r8 + AKX_livestemc_xf_to_livestemc_p_acc (ps:pe) = 0._r8 + AKX_deadstemc_xf_to_deadstemc_p_acc (ps:pe) = 0._r8 + AKX_livecrootc_xf_to_livecrootc_p_acc (ps:pe) = 0._r8 + AKX_deadcrootc_xf_to_deadcrootc_p_acc (ps:pe) = 0._r8 + AKX_grainc_xf_to_grainc_p_acc (ps:pe) = 0._r8 + AKX_livestemc_to_deadstemc_p_acc (ps:pe) = 0._r8 + AKX_livecrootc_to_deadcrootc_p_acc (ps:pe) = 0._r8 + + AKX_leafc_st_to_leafc_xf_p_acc (ps:pe) = 0._r8 + AKX_frootc_st_to_frootc_xf_p_acc (ps:pe) = 0._r8 + AKX_livestemc_st_to_livestemc_xf_p_acc (ps:pe) = 0._r8 + AKX_deadstemc_st_to_deadstemc_xf_p_acc (ps:pe) = 0._r8 + AKX_livecrootc_st_to_livecrootc_xf_p_acc (ps:pe) = 0._r8 + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (ps:pe) = 0._r8 + AKX_grainc_st_to_grainc_xf_p_acc (ps:pe) = 0._r8 + + AKX_leafc_exit_p_acc (ps:pe) = 0._r8 + AKX_frootc_exit_p_acc (ps:pe) = 0._r8 + AKX_livestemc_exit_p_acc (ps:pe) = 0._r8 + AKX_deadstemc_exit_p_acc (ps:pe) = 0._r8 + AKX_livecrootc_exit_p_acc (ps:pe) = 0._r8 + AKX_deadcrootc_exit_p_acc (ps:pe) = 0._r8 + AKX_grainc_exit_p_acc (ps:pe) = 0._r8 + + AKX_leafc_st_exit_p_acc (ps:pe) = 0._r8 + AKX_frootc_st_exit_p_acc (ps:pe) = 0._r8 + AKX_livestemc_st_exit_p_acc (ps:pe) = 0._r8 + AKX_deadstemc_st_exit_p_acc (ps:pe) = 0._r8 + AKX_livecrootc_st_exit_p_acc (ps:pe) = 0._r8 + AKX_deadcrootc_st_exit_p_acc (ps:pe) = 0._r8 + AKX_grainc_st_exit_p_acc (ps:pe) = 0._r8 + + AKX_leafc_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_frootc_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_livestemc_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_deadstemc_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_livecrootc_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_deadcrootc_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_grainc_xf_exit_p_acc (ps:pe) = 0._r8 + + AKX_leafn_xf_to_leafn_p_acc (ps:pe) = 0._r8 + AKX_frootn_xf_to_frootn_p_acc (ps:pe) = 0._r8 + AKX_livestemn_xf_to_livestemn_p_acc (ps:pe) = 0._r8 + AKX_deadstemn_xf_to_deadstemn_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_xf_to_livecrootn_p_acc (ps:pe) = 0._r8 + AKX_deadcrootn_xf_to_deadcrootn_p_acc (ps:pe) = 0._r8 + AKX_grainn_xf_to_grainn_p_acc (ps:pe) = 0._r8 + AKX_livestemn_to_deadstemn_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_to_deadcrootn_p_acc (ps:pe) = 0._r8 + + AKX_leafn_st_to_leafn_xf_p_acc (ps:pe) = 0._r8 + AKX_frootn_st_to_frootn_xf_p_acc (ps:pe) = 0._r8 + AKX_livestemn_st_to_livestemn_xf_p_acc (ps:pe) = 0._r8 + AKX_deadstemn_st_to_deadstemn_xf_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_st_to_livecrootn_xf_p_acc (ps:pe) = 0._r8 + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (ps:pe) = 0._r8 + AKX_grainn_st_to_grainn_xf_p_acc (ps:pe) = 0._r8 + + AKX_leafn_to_retransn_p_acc (ps:pe) = 0._r8 + AKX_frootn_to_retransn_p_acc (ps:pe) = 0._r8 + AKX_livestemn_to_retransn_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_to_retransn_p_acc (ps:pe) = 0._r8 + + AKX_retransn_to_leafn_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_frootn_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_livestemn_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_deadstemn_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_livecrootn_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_deadcrootn_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_grainn_p_acc (ps:pe) = 0._r8 + + AKX_retransn_to_leafn_st_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_frootn_st_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_livestemn_st_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_deadstemn_st_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_livecrootn_st_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_deadcrootn_st_p_acc (ps:pe) = 0._r8 + AKX_retransn_to_grainn_st_p_acc (ps:pe) = 0._r8 + + AKX_leafn_exit_p_acc (ps:pe) = 0._r8 + AKX_frootn_exit_p_acc (ps:pe) = 0._r8 + AKX_livestemn_exit_p_acc (ps:pe) = 0._r8 + AKX_deadstemn_exit_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_exit_p_acc (ps:pe) = 0._r8 + AKX_deadcrootn_exit_p_acc (ps:pe) = 0._r8 + AKX_grainn_exit_p_acc (ps:pe) = 0._r8 + AKX_retransn_exit_p_acc (ps:pe) = 0._r8 + + AKX_leafn_st_exit_p_acc (ps:pe) = 0._r8 + AKX_frootn_st_exit_p_acc (ps:pe) = 0._r8 + AKX_livestemn_st_exit_p_acc (ps:pe) = 0._r8 + AKX_deadstemn_st_exit_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_st_exit_p_acc (ps:pe) = 0._r8 + AKX_deadcrootn_st_exit_p_acc (ps:pe) = 0._r8 + AKX_grainn_st_exit_p_acc (ps:pe) = 0._r8 + + AKX_leafn_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_frootn_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_livestemn_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_deadstemn_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_livecrootn_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_deadcrootn_xf_exit_p_acc (ps:pe) = 0._r8 + AKX_grainn_xf_exit_p_acc (ps:pe) = 0._r8 + + ENDIF +#endif +#endif + + ! (8) surface albedo + ! Variables: alb, ssun, ssha, ssno, thermk, extkb, extkd + !NOTE: max(0.001,coszen) will make it always run to calculate initial values for the above. + wt = 0. + pg_snow = 0. + snofrz (:) = 0. + ssw = min(1.,1.e-3*wliq_soisno(1)/dz_soisno(1)) +#ifdef HYPERSPECTRAL + CALL albland_HiRes (ipatch,patchtype,1800.,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,max(0.001,coszen),& + wt,fsno,scv,scv,sag,ssw,pg_snow,273.15,t_grnd,t_soisno(:1),dz_soisno(:1),& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd, & + alb_hires, & + clr_frac(1:, 89, 1), cld_frac(1:, 1), & + reflectance, transmittance, & + soil_alb, kw, nw, 0.8, & + reflectance_out, transmittance_out, & + 1, patchlatr, patchlonr, & + urban_albedo, mean_albedo, lat_north, lat_south, lon_west, lon_east ) + +#else + CALL albland (ipatch,patchtype,1800.,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,max(0.001,coszen),& + wt,fsno,scv,scv,sag,ssw,pg_snow,273.15,t_grnd,t_soisno(:1),dz_soisno(:1),& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) +#endif + ELSE !ocean grid + t_soisno(:) = 300. + wice_soisno(:) = 0. + wliq_soisno(:) = 1000. + z_soisno (maxsnl+1:0) = 0. + dz_soisno(maxsnl+1:0) = 0. + sigf = 0. + fsno = 0. + ldew_rain = 0. + ldew_snow = 0. + ldew = 0. + scv = 0. + sag = 0. + snowdp = 0. + tleaf = 300. + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp(1:nvegwcs) = -2.5e4 + gs0sun = 1.0e4 + gs0sha = 1.0e4 + ENDIF + t_grnd = 300. + + oro = 0 + CALL albocean (oro,scv,coszen,alb) + ssun(:,:) = 0.0 + ssha(:,:) = 0.0 + ssoi(:,:) = 0.0 + ssno(:,:) = 0.0 + ssno_lyr(:,:,:) = 0.0 + thermk = 0.0 + extkb = 0.0 + extkd = 0.0 + ENDIF + + ! Additional variables required by regional model (WRF & RSM) + ! totally arbitrarily assigned here + trad = t_grnd + tref = t_grnd + qref = 0.3 + ! rst = 1.e36 + emis = 1.0 + zol = -1.0 + rib = -0.1 + ustar = 0.25 + qstar = 0.001 + tstar = -1.5 + fm = alog(30.) + fh = alog(30.) + fq = alog(30.) + o3coefv_sun = 1.0 + o3coefv_sha = 1.0 + o3coefg_sun = 1.0 + o3coefg_sha = 1.0 + + END SUBROUTINE IniTimeVar + !----------------------------------------------------------------------- + ! EOP + + + SUBROUTINE snow_ini(patchtype,maxsnl,snowdp,snl,z_soisno,dz_soisno) + + ! Snow spatial discretization initially + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: maxsnl !maximum of snow layers + integer, intent(in) :: patchtype !index for land cover type [-] + real(r8), intent(in) :: snowdp !snow depth [m] + real(r8), intent(out) :: z_soisno (maxsnl+1:0) !node depth [m] + real(r8), intent(out) :: dz_soisno(maxsnl+1:0) !layer thickness [m] + integer, intent(out) :: snl !number of snow layer + real(r8) zi + integer i + + dz_soisno(:0) = 0. + z_soisno(:0) = 0. + snl = 0 + IF(patchtype.le.3)THEN !non water bodies + + IF(snowdp.lt.0.01)THEN + snl = 0 + ELSE + IF(snowdp>=0.01 .and. snowdp<=0.03)THEN + snl = -1 + dz_soisno(0) = snowdp + ELSE IF(snowdp>0.03 .and. snowdp<=0.04)THEN + snl = -2 + dz_soisno(-1) = snowdp/2. + dz_soisno( 0) = dz_soisno(-1) + ELSE IF(snowdp>0.04 .and. snowdp<=0.07)THEN + snl = -2 + dz_soisno(-1) = 0.02 + dz_soisno( 0) = snowdp - dz_soisno(-1) + ELSE IF(snowdp>0.07 .and. snowdp<=0.12)THEN + snl = -3 + dz_soisno(-2) = 0.02 + dz_soisno(-1) = (snowdp - 0.02)/2. + dz_soisno( 0) = dz_soisno(-1) + ELSE IF(snowdp>0.12 .and. snowdp<=0.18)THEN + snl = -3 + dz_soisno(-2) = 0.02 + dz_soisno(-1) = 0.05 + dz_soisno( 0) = snowdp - dz_soisno(-2) - dz_soisno(-1) + ELSE IF(snowdp>0.18 .and. snowdp<=0.29)THEN + snl = -4 + dz_soisno(-3) = 0.02 + dz_soisno(-2) = 0.05 + dz_soisno(-1) = (snowdp - dz_soisno(-3) - dz_soisno(-2))/2. + dz_soisno( 0) = dz_soisno(-1) + ELSE IF(snowdp>0.29 .and. snowdp<=0.41)THEN + snl = -4 + dz_soisno(-3) = 0.02 + dz_soisno(-2) = 0.05 + dz_soisno(-1) = 0.11 + dz_soisno( 0) = snowdp - dz_soisno(-3) - dz_soisno(-2) - dz_soisno(-1) + ELSE IF(snowdp>0.41 .and. snowdp<=0.64)THEN + snl = -5 + dz_soisno(-4) = 0.02 + dz_soisno(-3) = 0.05 + dz_soisno(-2) = 0.11 + dz_soisno(-1) = (snowdp - dz_soisno(-4) - dz_soisno(-3) - dz_soisno(-2))/2. + dz_soisno( 0) = dz_soisno(-1) + ELSE IF(snowdp>0.64)THEN + snl = -5 + dz_soisno(-4) = 0.02 + dz_soisno(-3) = 0.05 + dz_soisno(-2) = 0.11 + dz_soisno(-1) = 0.23 + dz_soisno( 0) = snowdp - dz_soisno(-4) - dz_soisno(-3) - dz_soisno(-2) - dz_soisno(-1) + ENDIF + + zi = 0. + DO i = 0, snl+1, -1 + z_soisno(i) = zi - dz_soisno(i)/2. + zi = -zi-dz_soisno(i) + ENDDO + ENDIF + + ENDIF + + END SUBROUTINE snow_ini + +END MODULE MOD_IniTimeVariable +!----------------------------------------------------------------------- +! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 new file mode 100644 index 0000000000..2aa2525ed0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 @@ -0,0 +1,1662 @@ +#include + +MODULE MOD_Initialize + + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: initialize + +CONTAINS + + SUBROUTINE initialize (casename, dir_landdata, dir_restart, & + idate, lc_year, greenwich, lulcc_call) + +!======================================================================= +! initialization routine for land surface model. +! +! Created by Yongjiu Dai, 09/15/1999 +! Revised by Yongjiu Dai, 08/30/2002 +! Revised by Yongjiu Dai, 03/2014 +! +!======================================================================= + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Pixel + USE MOD_LandPatch +#ifdef URBAN_MODEL + USE MOD_LandUrban + USE MOD_UrbanIniTimeVariable + USE MOD_UrbanReadin + USE MOD_Urban_LAIReadin + USE MOD_Urban_Albedo +#endif + USE MOD_Const_Physical + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif +#ifdef DataAssimilation + USE MOD_DA_Vars_TimeVariables +#endif + USE MOD_Const_LC + USE MOD_Const_PFT + USE MOD_TimeManager + + USE MOD_Grid + USE MOD_DataType + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction +#endif + USE MOD_SpatialMapping +#ifdef CatchLateralFlow + USE MOD_Mesh + USE MOD_Utils + USE MOD_LandHRU + USE MOD_Catch_BasinNetwork + USE MOD_ElementNeighbour + USE MOD_Catch_RiverLakeNetwork +#endif +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeNetwork + USE MOD_Grid_Reservoir +#endif +#ifdef CROP + USE MOD_CropReadin +#endif + USE MOD_LAIEmpirical + USE MOD_LAIReadin + USE MOD_OrbCoszen + USE MOD_DBedrockReadin + USE MOD_HtopReadin + USE MOD_IniTimeVariable + USE MOD_LakeDepthReadin + USE MOD_PercentagesPFTReadin + USE MOD_SoilParametersReadin +#ifdef HYPERSPECTRAL + USE MOD_HighRes_Parameters +#endif + USE MOD_SoilTextureReadin + USE MOD_VicParaReadin +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif +#ifdef EXTERNAL_LAKE + USE MOD_Lake_TimeVars + USE MOD_Lake_Namelist, only: DEF_External_Lake +#endif + + IMPLICIT NONE + + ! ---------------------------------------------------------------------- + character(len=*), intent(in) :: casename ! case name + character(len=*), intent(in) :: dir_landdata + character(len=*), intent(in) :: dir_restart + integer, intent(inout) :: idate(3) ! year, julian day, seconds of the starting time + integer, intent(in) :: lc_year ! year, land cover year + logical, intent(in) :: greenwich ! true: greenwich time, false: local time + logical, optional, intent(in) :: lulcc_call ! whether it is a lulcc CALL + + ! ------------------------ local variables ----------------------------- + real(r8) :: rlon, rlat + + ! for SOIL INIT of water, temperature, snow depth + logical :: use_soilini + logical :: use_cnini + logical :: use_snowini + + character(len=256) :: fsoildat + character(len=256) :: fsnowdat + character(len=256) :: fcndat + character(len=256) :: ftopo, lndname + type(grid_type) :: gsoil + type(grid_type) :: gsnow + type(grid_type) :: gcn + type(spatial_mapping_type) :: ms2p + type(spatial_mapping_type) :: mc2p + type(spatial_mapping_type) :: mc2f + type(spatial_mapping_type) :: msoil2p, msnow2p + + integer :: nl_soil_ini + real(r8) :: missing_value + + real(r8), allocatable :: soil_z(:) + + type(block_data_real8_2d) :: snow_d_grid + type(block_data_real8_3d) :: soil_t_grid + type(block_data_real8_3d) :: soil_w_grid + type(block_data_real8_2d) :: zwt_grid + + type(block_data_real8_3d) :: litr1c_grid + type(block_data_real8_3d) :: litr2c_grid + type(block_data_real8_3d) :: litr3c_grid + type(block_data_real8_3d) :: cwdc_grid + type(block_data_real8_3d) :: soil1c_grid + type(block_data_real8_3d) :: soil2c_grid + type(block_data_real8_3d) :: soil3c_grid + type(block_data_real8_3d) :: litr1n_grid + type(block_data_real8_3d) :: litr2n_grid + type(block_data_real8_3d) :: litr3n_grid + type(block_data_real8_3d) :: cwdn_grid + type(block_data_real8_3d) :: soil1n_grid + type(block_data_real8_3d) :: soil2n_grid + type(block_data_real8_3d) :: soil3n_grid + type(block_data_real8_3d) :: sminn_grid + type(block_data_real8_3d) :: smin_nh4_grid + type(block_data_real8_3d) :: smin_no3_grid + type(block_data_real8_2d) :: leafc_grid + type(block_data_real8_2d) :: leafc_storage_grid + type(block_data_real8_2d) :: frootc_grid + type(block_data_real8_2d) :: frootc_storage_grid + type(block_data_real8_2d) :: livestemc_grid + type(block_data_real8_2d) :: deadstemc_grid + type(block_data_real8_2d) :: livecrootc_grid + type(block_data_real8_2d) :: deadcrootc_grid + + real(r8), allocatable :: snow_d(:) + real(r8), allocatable :: soil_t(:,:) + real(r8), allocatable :: soil_w(:,:) + logical , allocatable :: validval(:) + + real(r8), allocatable :: litr1c_vr(:,:) + real(r8), allocatable :: litr2c_vr(:,:) + real(r8), allocatable :: litr3c_vr(:,:) + real(r8), allocatable :: cwdc_vr (:,:) + real(r8), allocatable :: soil1c_vr(:,:) + real(r8), allocatable :: soil2c_vr(:,:) + real(r8), allocatable :: soil3c_vr(:,:) + real(r8), allocatable :: litr1n_vr(:,:) + real(r8), allocatable :: litr2n_vr(:,:) + real(r8), allocatable :: litr3n_vr(:,:) + real(r8), allocatable :: cwdn_vr (:,:) + real(r8), allocatable :: soil1n_vr(:,:) + real(r8), allocatable :: soil2n_vr(:,:) + real(r8), allocatable :: soil3n_vr(:,:) + real(r8), allocatable :: min_nh4_vr(:,:) + real(r8), allocatable :: min_no3_vr(:,:) + real(r8), allocatable :: leafcin_p(:) + real(r8), allocatable :: leafc_storagein_p(:) + real(r8), allocatable :: frootcin_p(:) + real(r8), allocatable :: frootc_storagein_p(:) + real(r8), allocatable :: livestemcin_p(:) + real(r8), allocatable :: deadstemcin_p(:) + real(r8), allocatable :: livecrootcin_p(:) + real(r8), allocatable :: deadcrootcin_p(:) + ! for SOIL Water INIT by using water table depth + logical :: use_wtd + + character(len=256) :: fwtd + type(grid_type) :: gwtd + type(block_data_real8_2d) :: wtd_xy ! [m] + type(spatial_mapping_type) :: m_wtd2p + + real(r8) :: zwtmm + real(r8) :: zc_soimm(1:nl_soil) + real(r8) :: zi_soimm(0:nl_soil) + real(r8) :: vliq_r (1:nl_soil) +#ifdef Campbell_SOIL_MODEL + integer, parameter :: nprms = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: nprms = 5 +#endif + real(r8) :: prms(nprms, 1:nl_soil) + + real(r8) :: wdsrfm, depthratio + real(r8), dimension(10) :: dzlak = (/0.1, 1., 2., 3., 4., 5., 7., 7., 10.45, 10.45/) ! m +#ifdef CatchLateralFlow + integer :: ip, ie, ipxl + real(r8), allocatable :: patcharea (:) ! m^2 +#endif + + ! CoLM soil layer thickness and depths + real(r8), allocatable :: z_soisno (:,:) + real(r8), allocatable :: dz_soisno(:,:) + + real(r8) :: calday ! Julian cal day (1.xx to 365.xx) + integer :: year, jday ! Julian day and seconds + integer :: month, mday + character(len=4) :: cyear + + integer :: i,j,ipatch,nsl,hs,he,ps,pe,ivt,m, u ! indices + real(r8) :: totalvolume + + integer :: Julian_8day + integer :: ltyp + +#ifdef BGC + real(r8) f_s1s2 (1:nl_soil) + real(r8) f_s1s3 (1:nl_soil) + real(r8) rf_s1s2(1:nl_soil) + real(r8) rf_s1s3(1:nl_soil) + real(r8) f_s2s1 + real(r8) f_s2s3 + real(r8) t +#endif + + integer :: txt_id + real(r8) :: vic_b_infilt_, vic_Dsmax_, vic_Ds_, vic_Ws_, vic_c_ + + logical :: use_soiltext + ! for USDA soil texture class: + ! 0: undefined + ! 1: clay; 2: silty clay; 3: sandy clay; 4: clay loam; 5: silty clay loam; 6: sandy clay loam; & + ! 7: loam; 8: silty loam; 9: sandy loam; 10: silt; 11: loamy sand; 12: sand + + ! original VIC soil texture class in noahmp: + ! 1: SAND 2: LOAMY SAND 3: SANDY LOAM 4: SILT LOAM 5: SILT 6: LOAM 7: SANDY CLAY LOAM 8: SILTY CLAY LOAM 9: CLAY LOAM 10: SANDY CLAY 11: SILTY CLAY 12: CLAY 13: ORGANIC MATERIAL 14: WATER 15: BEDROCK 16: OTHER(land-ice) 17: PLAYA 18: LAVA 19: WHITE SAND + ! 9: CLAY LOAM 10: SANDY CLAY 11: SILTY CLAY 12: CLAY + !soil type 0 1 2 3 4 5 6 7 8 9 10 11 12 + !BVIC = 1.0 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300 + !re-arranged BVIC for USDA soil texture class: + real(r8), parameter :: BVIC_USDA(0:12) = (/ 1., 0.300, 0.280, 0.250, 0.230, 0.220, 0.200, 0.180, 0.100, 0.090, 0.150, 0.080, 0.050/) + + + +#ifdef CatchLateralFlow + CALL build_basin_network () +#endif + +#ifdef GridRiverLakeFlow + CALL build_riverlake_network () + + IF (DEF_Reservoir_Method > 0) THEN + CALL reservoir_init () + ENDIF +#endif + +! -------------------------------------------------------------------- +! Allocates memory for CoLM 1d [numpatch] variables +! -------------------------------------------------------------------- + + CALL allocate_TimeInvariants + CALL allocate_TimeVariables + +! --------------------------------------------------------------- +! 1. INITIALIZE TIME INVARIANT VARIABLES +! --------------------------------------------------------------- + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + patchclass = landpatch%settyp + patchmask = .true. + ENDIF + + DO ipatch = 1, numpatch + + m = patchclass(ipatch) + patchtype(ipatch) = patchtypes(m) + + ! ***** patch mask setting ***** + ! --------------------------------------- + + IF (DEF_URBAN_ONLY .and. m.ne.URBAN) THEN + patchmask(ipatch) = .false. + CYCLE + ENDIF + + ! 2m WMO virtual patch, modeling but not for aggregation +IF (DEF_Output_2mWMO) THEN + IF (landpatch%ipxstt(ipatch) == -1) THEN + patchmask(ipatch) = .false. + CYCLE + ENDIF +ENDIF + + ENDDO + +#ifndef SinglePoint + CALL landpatch%get_lonlat_radian (patchlonr, patchlatr) +#else + patchlonr(:) = SITE_lon_location * pi/180. + patchlatr(:) = SITE_lat_location * pi/180. +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) pftclass = landpft%settyp +#endif + + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL pct_readin (dir_landdata, lc_year) +#endif + +! ------------------------------------------ +! 1.1 Ponding water +! ------------------------------------------ + IF(DEF_USE_BEDROCK)THEN + CALL dbedrock_readin (dir_landdata, lc_year) + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + wdsrf(:) = 0._r8 + + wetwat(:) = 0._r8 + WHERE (patchtype == 2) wetwat = 200._r8 ! for wetland + ENDIF + ENDIF +! ------------------------------------------ +! 1.2 Lake depth and layers' thickness +! ------------------------------------------ + CALL lakedepth_readin (dir_landdata, lc_year) + + IF (p_is_worker .and. (numpatch > 0)) THEN + WHERE (patchtype == 4) wdsrf = lakedepth * 1.e3 + ENDIF + +! ............................................................... +! 1.3 Read in the soil parameters of the patches of the gridcells +! ............................................................... + + CALL soil_parameters_readin (dir_landdata, lc_year) + + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO ipatch = 1, numpatch + DO i = 1, nl_soil + CALL get_derived_parameters_vGM ( & + psi0(i,ipatch), alpha_vgm(i,ipatch), n_vgm(i,ipatch), & + sc_vgm(i,ipatch), fc_vgm(i,ipatch)) + ENDDO + ENDDO + ENDIF + ENDIF +#endif + +#ifdef CatchLateralFlow + use_soiltext = .true. +#else + use_soiltext = (DEF_Runoff_SCHEME == 3) ! only for Simple VIC +#endif + IF (use_soiltext) THEN + CALL soiltext_readin (dir_landdata, lc_year) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO ipatch = 1, numpatch + BVIC(ipatch)=BVIC_USDA(soiltext(ipatch)) + ENDDO + ENDIF + ENDIF + ENDIF + +! ............................................................... +! 1.4 Plant time-invariant variables +! ............................................................... + + ! read global tree top height from nc file + CALL HTOP_readin (dir_landdata, lc_year) +#ifdef URBAN_MODEL + CALL Urban_readin (dir_landdata, lc_year) +#endif +! ................................ +! 1.5 Initialize topography data +! ................................ +#ifdef SinglePoint + elvmean(:) = SITE_elevation + elvstd (:) = SITE_elvstd + slpratio(:) = SITE_sloperatio +#else + write(cyear,'(i4.4)') lc_year + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/elevation_patches.nc' + CALL ncio_read_vector (ftopo, 'elevation_patches', landpatch, elvmean) + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/elvstd_patches.nc' + CALL ncio_read_vector (ftopo, 'elvstd_patches', landpatch, elvstd) + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/sloperatio_patches.nc' + CALL ncio_read_vector (ftopo, 'sloperatio_patches', landpatch, slpratio) +#endif +! ...................................... +! 1.5 Initialize topography factor data +! ...................................... + IF (DEF_USE_Forcing_Downscaling) THEN +#ifdef SinglePoint + slp_type_patches(:,1) = SITE_slp_type + asp_type_patches(:,1) = SITE_asp_type + area_type_patches(:,1) = SITE_area_type + svf_patches(:) = SITE_svf + cur_patches(:) = SITE_cur + sf_lut_patches(:,:,1) = SITE_sf_lut +#else + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/slp_type_patches.nc' ! slope + CALL ncio_read_vector (lndname, 'slp_type_patches', num_slope_type, landpatch, slp_type_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/svf_patches.nc' ! sky view factor + CALL ncio_read_vector (lndname, 'svf_patches', landpatch, svf_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/asp_type_patches.nc' ! aspect + CALL ncio_read_vector (lndname, 'asp_type_patches', num_slope_type, landpatch, asp_type_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/area_type_patches.nc' ! area percent + CALL ncio_read_vector (lndname, 'area_type_patches', num_slope_type, landpatch, area_type_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/sf_curve_patches.nc' ! shadow mask + CALL ncio_read_vector (lndname, 'sf_curve_patches', num_azimuth, num_zenith_parameter, landpatch, sf_curve_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/cur_patches.nc' ! curvature + CALL ncio_read_vector (lndname, 'cur_patches', landpatch, cur_patches) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/slp_type_patches.nc' ! slope + CALL ncio_read_vector (lndname, 'slp_type_patches', num_aspect_type, landpatch, slp_type_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/asp_type_patches.nc' ! aspect + CALL ncio_read_vector (lndname, 'asp_type_patches', num_aspect_type, landpatch, asp_type_patches) + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/cur_patches.nc' ! curvature + CALL ncio_read_vector (lndname, 'cur_patches', landpatch, cur_patches) + ENDIF + +! ................................ +! 1.6 Initialize TUNABLE constants +! ................................ + zlnd = 0.01 !Roughness length for soil [m] + zsno = 0.0024 !Roughness length for snow [m] + csoilc = 0.004 !Drag coefficient for soil under canopy [-] + dewmx = 0.1 !maximum dew + + ! 'wtfact' is updated to gridded 'fsatmax' data. (by Shupeng Zhang) + ! wtfact = 0.38 !Maximum saturated fraction (global mean; see Niu et al., 2005) + + capr = 0.34 !Tuning factor to turn first layer T into surface T + cnfac = 0.5 !Crank Nicholson factor between 0 and 1 + ssi = 0.033 !Irreducible water saturation of snow + wimp = 0.05 !Water impremeable if porosity less than wimp + pondmx = 10.0 !Ponding depth (mm) + smpmax = -1.5e5 !Wilting point potential in mm + smpmin = -1.e8 !Restriction for min of soil poten. (mm) + smpmax_hr = -2.e2 !Wilting point potential in mm + smpmin_hr = -2.e5 !Restriction for min of soil poten. (mm) + trsmx0 = 2.e-4 !Max transpiration for moist soil+100% veg. [mm/s] + tcrit = 2.5 !critical temp. to determine rain or snow + wetwatmax = 200.0 !maximum wetland water (mm) + + ! for TOPMODEL: read saturated fraction parameter data from files. + ! (see Niu et al., 2005) + IF (DEF_Runoff_SCHEME == 0) THEN + + IF (DEF_TOPMOD_method == 0) THEN + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + ! equal to 'wtfact = 0.38' and 'fff = 0.5' + fsatmax(:) = 0.38 + fsatdcf(:) = 0.125 + ENDIF + ENDIF + + ELSEIF (DEF_TOPMOD_method == 1) THEN + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/fsatmax_patches.nc' + CALL ncio_read_vector (ftopo, 'fsatmax_patches', landpatch, fsatmax) + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/fsatdcf_patches.nc' + CALL ncio_read_vector (ftopo, 'fsatdcf_patches', landpatch, fsatdcf) + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/mean_twi_patches.nc' + CALL ncio_read_vector (ftopo, 'mean_twi_patches', landpatch, topoweti) + +#ifdef RangeCheck + CALL check_vector_data ('maximum saturated fraction', fsatmax ) + CALL check_vector_data ('fsat decay factor ', fsatdcf ) + CALL check_vector_data ('topographic wetness index ', topoweti) +#endif + + ELSEIF (DEF_TOPMOD_method == 2) THEN + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/mean_twi_patches.nc' + CALL ncio_read_vector (ftopo, 'mean_twi_patches', landpatch, topoweti) + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/alp_twi_patches.nc' + CALL ncio_read_vector (ftopo, 'alp_twi_patches', landpatch, alp_twi) + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/chi_twi_patches.nc' + CALL ncio_read_vector (ftopo, 'chi_twi_patches', landpatch, chi_twi) + + ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/mu_twi_patches.nc' + CALL ncio_read_vector (ftopo, 'mu_twi_patches', landpatch, mu_twi) + +#ifdef RangeCheck + CALL check_vector_data ('topographic wetness index ', topoweti) + CALL check_vector_data ('twi alpha in three gamma ', alp_twi ) + CALL check_vector_data ('twi chi in three gamma ', chi_twi ) + CALL check_vector_data ('twi mu in three gamma ', mu_twi ) +#endif + + ENDIF + ENDIF + + IF (DEF_Runoff_SCHEME == 1) THEN + IF (DEF_VIC_OPT) THEN + CALL vicpara_readin () + ELSE + IF (p_is_master) THEN + txt_id = 111 + open(txt_id, file=trim(DEF_file_VIC_para), status='old', form='formatted') + READ(txt_id, *) + READ(txt_id, *) vic_b_infilt_, vic_Dsmax_, vic_Ds_, vic_Ws_, vic_c_ + close(txt_id) + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (vic_b_infilt_, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vic_Dsmax_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vic_Ds_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vic_Ws_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vic_c_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vic_b_infilt = vic_b_infilt_ + vic_Dsmax = vic_Dsmax_ + vic_Ds = vic_Ds_ + vic_Ws = vic_Ws_ + vic_c = vic_c_ + ENDIF + ENDIF + ENDIF + ELSE + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + vic_b_infilt = 0 + vic_Dsmax = 0 + vic_Ds = 0 + vic_Ws = 0 + vic_c = 0 + ENDIF + ENDIF + ENDIF + +#ifdef BGC + ! bgc constant + i_met_lit = 1 + i_cel_lit = 2 + i_lig_lit = 3 + i_cwd = 4 + i_soil1 = 5 + i_soil2 = 6 + i_soil3 = 7 + i_atm = 0 + + donor_pool = (/i_met_lit, i_cel_lit, i_lig_lit, i_soil1, i_cwd , i_cwd , i_soil1, i_soil2, i_soil2, i_soil3/) + receiver_pool = (/i_soil1 , i_soil1 , i_soil2 , i_soil2, i_cel_lit, i_lig_lit, i_soil3, i_soil1, i_soil3, i_soil1/) + am = 0.02_r8 + floating_cn_ratio = (/.true., .true., .true., .true., .false. ,.false., .false./) + initial_cn_ratio = (/90._r8, 90._r8, 90._r8, 90._r8, 8._r8, 11._r8, 11._r8/) ! 1:ndecomp_pools + + f_s2s1 = 0.42_r8/(0.45_r8) + f_s2s3 = 0.03_r8/(0.45_r8) + IF (p_is_worker) THEN + IF(numpatch > 0)THEN + DO j=1,nl_soil + DO i = 1, numpatch + t = 0.85_r8 - 0.68_r8 * 0.01_r8 * (100._r8 - 50._r8) + f_s1s2 (j) = 1._r8 - .004_r8 / (1._r8 - t) + f_s1s3 (j) = .004_r8 / (1._r8 - t) + rf_s1s2(j) = t + rf_s1s3(j) = t + rf_decomp(j,:,i) = (/0.55_r8, 0.5_r8, 0.5_r8, rf_s1s2(j), 0._r8 , 0._r8 , rf_s1s3(j), 0.55_r8, 0.55_r8, 0.55_r8/) + pathfrac_decomp(j,:,i) = (/1.0_r8 ,1.0_r8 , 1.0_r8, f_s1s2(j) , 0.76_r8, 0.24_r8, f_s1s3(j) , f_s2s1 , f_s2s3 , 1._r8/) + ENDDO + ENDDO + ENDIF + ENDIF + + is_cwd = (/.false.,.false.,.false.,.true. ,.false.,.false.,.false./) + is_litter = (/.true. ,.true. ,.true. ,.false.,.false.,.false.,.false./) + is_soil = (/.false.,.false.,.false.,.false.,.true. ,.true. ,.true./) + cmb_cmplt_fact = (/0.5_r8,0.25_r8/) + + nitrif_n2o_loss_frac = 6.e-4 !fraction of N lost as N2O in nitrification (Li et al., 2000) + dnp = 0.01_r8 + bdnr = 0.5_r8 + compet_plant_no3 = 1._r8 + compet_plant_nh4 = 1._r8 + compet_decomp_no3 = 1._r8 + compet_decomp_nh4 = 1._r8 + compet_denit = 1._r8 + compet_nit = 1._r8 + surface_tension_water = 0.073 + rij_kro_a = 1.5e-10_r8 + rij_kro_alpha = 1.26_r8 + rij_kro_beta = 0.6_r8 + rij_kro_gamma = 0.6_r8 + rij_kro_delta = 0.85_r8 + IF(DEF_USE_NITRIF)THEN + nfix_timeconst = 10._r8 + ELSE + nfix_timeconst = 0._r8 + ENDIF + organic_max = 130 + d_con_g21 = 0.1759_r8 + d_con_g22 = 0.00117_r8 + d_con_w21 = 1.172_r8 + d_con_w22 = 0.03443_r8 + d_con_w23 = 0.0005048_r8 + denit_resp_coef = 0.1_r8 + denit_resp_exp = 1.3_r8 + denit_nitrate_coef = 1.15_r8 + denit_nitrate_exp = 0.57_r8 + k_nitr_max = 1.1574074e-06_r8 + Q10 = 1.5_r8 + froz_q10 = 1.5_r8 + tau_l1 = 1._r8/18.5_r8 + tau_l2_l3 = 1._r8/4.9_r8 + tau_s1 = 1._r8/7.3_r8 + tau_s2 = 1._r8/0.2_r8 + tau_s3 = 1._r8/.0045_r8 + tau_cwd = 1._r8/0.3_r8 + lwtop = 0.7_r8/31536000.0_r8 + + som_adv_flux = 0._r8 + som_diffus = 3.170979198376459e-12_r8 + cryoturb_diffusion_k = 1.585489599188229e-11_r8 + max_altdepth_cryoturbation = 2._r8 + max_depth_cryoturb = 3._r8 + + br = 2.525e-6_r8 + br_root = 2.000e-6_r8 + + fstor2tran = 0.5 + ndays_on = 30 + ndays_off = 15 + crit_dayl = 39300 + crit_onset_fdd = 15 + crit_onset_swi = 15 + crit_offset_fdd = 15 + crit_offset_swi = 15 + soilpsi_on = -0.6 + soilpsi_off = -0.8 + + ! constant for fire module + occur_hi_gdp_tree = 0.39_r8 + lfuel = 75._r8 + ufuel = 650._r8 + cropfire_a1 = 0.3_r8 + borealat = 40._r8/(4.*atan(1.)) + troplat = 23.5_r8/(4.*atan(1.)) + non_boreal_peatfire_c = 0.001_r8 + boreal_peatfire_c = 4.2e-5_r8 + rh_low = 30.0_r8 + rh_hgh = 80.0_r8 + bt_min = 0.3_r8 + bt_max = 0.7_r8 + pot_hmn_ign_counts_alpha = 0.0035_r8 + g0_fire = 0.05_r8 + + sf = 0.1_r8 + sf_no3 = 1._r8 +#endif + +! ............................................... +! 1.6 Write out as a restart file [histTimeConst] +! ............................................... + +#ifdef RangeCheck + CALL check_TimeInvariants () +#endif + + CALL WRITE_TimeInvariants (lc_year, casename, dir_restart) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) write (6,*) ('Successfully Initialize the Land Time-Invariants') + +! ---------------------------------------------------------------------- +! [2] INITIALIZE TIME-VARYING VARIABLES +! as subgrid vectors of length [numpatch] +! initial run: create the time-varying variables based on : +! i) observation (NOT CODING CURRENTLY), or +! ii) some already-known information (NO CODING CURRENTLY), or +! iii) arbitrarily +! continuation run: time-varying data read in from restart file +! ---------------------------------------------------------------------- + +! 2.1 current time of model run +! ............................ + + CALL initimetype(greenwich) + + IF (p_is_master) THEN + IF(.not. greenwich)THEN + write(*,*) char(27)//"[1;31m"//"Notice: greenwich false, local time is used."//char(27)//"[0m" + ENDIF + ENDIF + + +! ................................ +! 2.2 cosine of solar zenith angle +! ................................ + calday = calendarday(idate) + IF (p_is_worker) THEN + DO i = 1, numpatch + coszen(i) = orb_coszen(calday, patchlonr(i), patchlatr(i)) + ENDDO + ENDIF + +! ........................................... +!2.3 READ in or GUSSES land state information +! ........................................... + + ! for SOIL INIT of water, temperature + IF (DEF_USE_SoilInit) THEN + + fsoildat = DEF_file_SoilInit + + IF (p_is_master) THEN + inquire (file=trim(fsoildat), exist=use_soilini) + IF (use_soilini) THEN + write(*,'(/,2A)') 'Use soil water content, soil temperature and water table depth ' & + // 'to initialize soil state from file ', trim(fsoildat) + ELSE + write(*,*) 'No initial data for soil state from ', trim(fsoildat) + ENDIF + ENDIF +#ifdef USEMPI + CALL mpi_bcast (use_soilini, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#endif + + IF (use_soilini) THEN + + ! soil layer depth (m) + CALL ncio_read_bcast_serial (fsoildat, 'soildepth', soil_z) + + nl_soil_ini = size(soil_z) + + CALL gsoil%define_from_file (fsoildat, latname = 'lat', lonname = 'lon') + + CALL julian2monthday (idate(1), idate(2), month, mday) + + IF (p_is_master) THEN + CALL ncio_get_attr (fsoildat, 'zwt', 'missing_value', missing_value) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + + IF (p_is_io) THEN + ! soil layer temperature (K) + CALL allocate_block_data (gsoil, soil_t_grid, nl_soil_ini) + CALL ncio_read_block_time (fsoildat, 'soiltemp', & + gsoil, nl_soil_ini, month, soil_t_grid) + ! soil layer wetness (-) + CALL allocate_block_data (gsoil, soil_w_grid, nl_soil_ini) + CALL ncio_read_block_time (fsoildat, 'soilwat', & + gsoil, nl_soil_ini, month, soil_w_grid) + ! water table depth (m) + CALL allocate_block_data (gsoil, zwt_grid) + CALL ncio_read_block_time (fsoildat, 'zwt', gsoil, month, zwt_grid) + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (soil_t (nl_soil_ini,numpatch)) + allocate (soil_w (nl_soil_ini,numpatch)) + allocate (validval (numpatch)) + ENDIF + ENDIF + + CALL msoil2p%build_arealweighted (gsoil, landpatch) + CALL msoil2p%set_missing_value (zwt_grid, missing_value, validval) + + CALL msoil2p%grid2pset (soil_t_grid, nl_soil_ini, soil_t) + CALL msoil2p%grid2pset (soil_w_grid, nl_soil_ini, soil_w) + CALL msoil2p%grid2pset (zwt_grid, zwt) + + IF (p_is_worker) THEN + DO i = 1, numpatch + IF (.not. validval(i)) THEN + IF (patchtype(i) == 3) THEN + soil_t(:,i) = 250. + ELSE + soil_t(:,i) = 280. + ENDIF + + soil_w(:,i) = 1. + zwt(i) = 0. + + ENDIF + ENDDO + ENDIF + + IF (allocated(validval)) deallocate(validval) + + ENDIF + + ELSE + use_soilini = .false. + ENDIF + + IF (.not. use_soilini) THEN + !! not used, just for filling arguments + IF (p_is_worker) THEN + allocate (soil_z (nl_soil)) + allocate (soil_t (nl_soil,numpatch)) + allocate (soil_w (nl_soil,numpatch)) + ENDIF + ENDIF + +#ifdef BGC + IF (DEF_USE_CN_INIT) THEN + fcndat = DEF_file_cn_init + IF (p_is_master) THEN + inquire (file=trim(fcndat), exist=use_cnini) + IF (use_cnini) THEN + write(*,'(/, 2A)') 'Use carbon & nitrogen and derived equilibrium state ' & + // ' to initialize soil & vegetation biogeochemistry: ', trim(fcndat) + ELSE + write(*,*) 'no initial data for biogeochemistry: ',trim(fcndat) + ENDIF + ENDIF +#ifdef USEMPI + CALL mpi_bcast (use_cnini, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#endif + + IF (use_cnini) THEN + + CALL gcn%define_from_file (fcndat,"lat","lon") + CALL mc2p%build_arealweighted (gcn, landpatch) + CALL mc2f%build_arealweighted (gcn, landpft) + + IF (p_is_io) THEN + ! soil layer litter & carbon (gC m-3) + CALL allocate_block_data (gcn, litr1c_grid, nl_soil) + CALL ncio_read_block (fcndat, 'litr1c_vr', gcn, nl_soil, litr1c_grid) + + CALL allocate_block_data (gcn, litr2c_grid, nl_soil) + CALL ncio_read_block (fcndat, 'litr2c_vr', gcn, nl_soil, litr2c_grid) + + CALL allocate_block_data (gcn, litr3c_grid, nl_soil) + CALL ncio_read_block (fcndat, 'litr3c_vr', gcn, nl_soil, litr3c_grid) + + CALL allocate_block_data (gcn, cwdc_grid, nl_soil) + CALL ncio_read_block (fcndat, 'cwdc_vr', gcn, nl_soil , cwdc_grid) + + CALL allocate_block_data (gcn, soil1c_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil1c_vr', gcn, nl_soil, soil1c_grid) + + CALL allocate_block_data (gcn, soil2c_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil2c_vr', gcn, nl_soil, soil2c_grid) + + CALL allocate_block_data (gcn, soil3c_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil3c_vr', gcn, nl_soil, soil3c_grid) + + ! soil layer litter & nitrogen (gN m-3) + CALL allocate_block_data (gcn, litr1n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'litr1n_vr', gcn, nl_soil, litr1n_grid) + + CALL allocate_block_data (gcn, litr2n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'litr2n_vr', gcn, nl_soil, litr2n_grid) + + CALL allocate_block_data (gcn, litr3n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'litr3n_vr', gcn, nl_soil, litr3n_grid) + + CALL allocate_block_data (gcn, cwdn_grid, nl_soil) + CALL ncio_read_block (fcndat, 'cwdn_vr', gcn, nl_soil , cwdn_grid) + + CALL allocate_block_data (gcn, soil1n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil1n_vr', gcn, nl_soil, soil1n_grid) + + CALL allocate_block_data (gcn, soil2n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil2n_vr', gcn, nl_soil, soil2n_grid) + + CALL allocate_block_data (gcn, soil3n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil3n_vr', gcn, nl_soil, soil3n_grid) + + CALL allocate_block_data (gcn, soil3n_grid, nl_soil) + CALL ncio_read_block (fcndat, 'soil3n_vr', gcn, nl_soil, soil3n_grid) + + CALL allocate_block_data (gcn, smin_nh4_grid, nl_soil) + CALL ncio_read_block (fcndat, 'smin_nh4_vr', gcn, nl_soil, smin_nh4_grid) + + CALL allocate_block_data (gcn, smin_no3_grid, nl_soil) + CALL ncio_read_block (fcndat, 'smin_no3_vr', gcn, nl_soil, smin_no3_grid) + + CALL allocate_block_data (gcn, leafc_grid) + CALL ncio_read_block (fcndat, 'leafc', gcn, leafc_grid) + + CALL allocate_block_data (gcn, leafc_storage_grid) + CALL ncio_read_block (fcndat, 'leafc_storage', gcn, leafc_storage_grid) + + CALL allocate_block_data (gcn, frootc_grid) + CALL ncio_read_block (fcndat, 'frootc', gcn, frootc_grid) + + CALL allocate_block_data (gcn, frootc_storage_grid) + CALL ncio_read_block (fcndat, 'frootc_storage', gcn, frootc_storage_grid) + + CALL allocate_block_data (gcn, livestemc_grid) + CALL ncio_read_block (fcndat, 'livestemc', gcn, livestemc_grid) + + CALL allocate_block_data (gcn, deadstemc_grid) + CALL ncio_read_block (fcndat, 'deadstemc', gcn, deadstemc_grid) + + CALL allocate_block_data (gcn, livecrootc_grid) + CALL ncio_read_block (fcndat, 'livecrootc', gcn, livecrootc_grid) + + CALL allocate_block_data (gcn, deadcrootc_grid) + CALL ncio_read_block (fcndat, 'deadcrootc', gcn, deadcrootc_grid) + + ENDIF + + IF (p_is_worker) THEN + + allocate (litr1c_vr (nl_soil,numpatch)) + allocate (litr2c_vr (nl_soil,numpatch)) + allocate (litr3c_vr (nl_soil,numpatch)) + allocate (cwdc_vr (nl_soil,numpatch)) + allocate (soil1c_vr (nl_soil,numpatch)) + allocate (soil2c_vr (nl_soil,numpatch)) + allocate (soil3c_vr (nl_soil,numpatch)) + allocate (litr1n_vr (nl_soil,numpatch)) + allocate (litr2n_vr (nl_soil,numpatch)) + allocate (litr3n_vr (nl_soil,numpatch)) + allocate (cwdn_vr (nl_soil,numpatch)) + allocate (soil1n_vr (nl_soil,numpatch)) + allocate (soil2n_vr (nl_soil,numpatch)) + allocate (soil3n_vr (nl_soil,numpatch)) + allocate (min_nh4_vr(nl_soil,numpatch)) + allocate (min_no3_vr(nl_soil,numpatch)) + allocate (leafcin_p (numpft)) + allocate (leafc_storagein_p (numpft)) + allocate (frootcin_p (numpft)) + allocate (frootc_storagein_p (numpft)) + allocate (livestemcin_p (numpft)) + allocate (deadstemcin_p (numpft)) + allocate (livecrootcin_p (numpft)) + allocate (deadcrootcin_p (numpft)) + + ENDIF + + CALL mc2p%grid2pset (litr1c_grid, nl_soil, litr1c_vr) + CALL mc2p%grid2pset (litr2c_grid, nl_soil, litr2c_vr) + CALL mc2p%grid2pset (litr3c_grid, nl_soil, litr3c_vr) + CALL mc2p%grid2pset (cwdc_grid , nl_soil, cwdc_vr ) + CALL mc2p%grid2pset (soil1c_grid, nl_soil, soil1c_vr) + CALL mc2p%grid2pset (soil2c_grid, nl_soil, soil2c_vr) + CALL mc2p%grid2pset (soil3c_grid, nl_soil, soil3c_vr) + CALL mc2p%grid2pset (litr1n_grid, nl_soil, litr1n_vr) + CALL mc2p%grid2pset (litr2n_grid, nl_soil, litr2n_vr) + CALL mc2p%grid2pset (litr3n_grid, nl_soil, litr3n_vr) + CALL mc2p%grid2pset (cwdn_grid , nl_soil, cwdn_vr ) + CALL mc2p%grid2pset (soil1n_grid, nl_soil, soil1n_vr) + CALL mc2p%grid2pset (soil2n_grid, nl_soil, soil2n_vr) + CALL mc2p%grid2pset (soil3n_grid, nl_soil, soil3n_vr) + CALL mc2p%grid2pset (smin_nh4_grid , nl_soil, min_nh4_vr ) + CALL mc2p%grid2pset (smin_no3_grid , nl_soil, min_no3_vr ) + CALL mc2f%grid2pset (leafc_grid, leafcin_p ) + CALL mc2f%grid2pset (leafc_storage_grid, leafc_storagein_p ) + CALL mc2f%grid2pset (frootc_grid, frootcin_p ) + CALL mc2f%grid2pset (frootc_storage_grid, frootc_storagein_p ) + CALL mc2f%grid2pset (livestemc_grid, livestemcin_p ) + CALL mc2f%grid2pset (deadstemc_grid, deadstemcin_p ) + CALL mc2f%grid2pset (livecrootc_grid, livecrootcin_p ) + CALL mc2f%grid2pset (deadcrootc_grid, deadcrootcin_p ) + + IF (p_is_worker) THEN + DO i = 1, numpatch + IF (patchtype(i) == 0)THEN + ps = patch_pft_s(i) + pe = patch_pft_e(i) + DO nsl = 1, nl_soil + decomp_cpools_vr(nsl, i_met_lit, i) = litr1c_vr(nsl, i) + decomp_cpools_vr(nsl, i_cel_lit, i) = litr2c_vr(nsl, i) + decomp_cpools_vr(nsl, i_lig_lit, i) = litr3c_vr(nsl, i) + decomp_cpools_vr(nsl, i_cwd , i) = cwdc_vr (nsl, i) + decomp_cpools_vr(nsl, i_soil1 , i) = soil1c_vr(nsl, i) + decomp_cpools_vr(nsl, i_soil2 , i) = soil2c_vr(nsl, i) + decomp_cpools_vr(nsl, i_soil3 , i) = soil3c_vr(nsl, i) + decomp_npools_vr(nsl, i_met_lit, i) = litr1n_vr(nsl, i) + decomp_npools_vr(nsl, i_cel_lit, i) = litr2n_vr(nsl, i) + decomp_npools_vr(nsl, i_lig_lit, i) = litr3n_vr(nsl, i) + decomp_npools_vr(nsl, i_cwd , i) = cwdn_vr (nsl, i) + decomp_npools_vr(nsl, i_soil1 , i) = soil1n_vr(nsl, i) + decomp_npools_vr(nsl, i_soil2 , i) = soil2n_vr(nsl, i) + decomp_npools_vr(nsl, i_soil3 , i) = soil3n_vr(nsl, i) + smin_nh4_vr (nsl, i) = min_nh4_vr(nsl,i) + smin_no3_vr (nsl, i) = min_no3_vr(nsl,i) + sminn_vr (nsl, i) = min_nh4_vr(nsl,i)+min_no3_vr(nsl,i) + ENDDO + ENDIF + IF (patchtype(i) == 0)THEN + DO m = ps, pe + ivt = pftclass(m) + IF(isevg(ivt))THEN + leafc_p (m) = amin1(leafcin_p(m),300._r8) + frootc_p (m) = frootcin_p(m) + ELSE + leafc_p (m) = amin1(leafcin_p(m),300._r8) + leafc_storage_p (m) = amin1(leafc_storagein_p(m),600._r8) + frootc_p (m) = frootcin_p(m) + frootc_storage_p (m) = frootc_storagein_p(m) + ENDIF + IF(woody(ivt).eq. 1)THEN + deadstemc_p (m) = deadstemcin_p(m) + livestemc_p (m) = livestemcin_p(m) + deadcrootc_p (m) = deadcrootcin_p(m) + livecrootc_p (m) = livecrootcin_p(m) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + + ENDIF + + ELSE + use_cnini = .false. + ENDIF +#endif + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (snow_d (numpatch)) + ENDIF + ENDIF + + IF (DEF_USE_SnowInit) THEN + + fsnowdat = DEF_file_SnowInit + IF (p_is_master) THEN + inquire (file=trim(fsnowdat), exist=use_snowini) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (use_snowini, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#endif + + IF (use_snowini) THEN + + CALL gsnow%define_from_file (fsnowdat, latname = 'lat', lonname = 'lon') + + CALL julian2monthday (idate(1), idate(2), month, mday) + + IF (p_is_master) THEN + CALL ncio_get_attr (fsnowdat, 'snowdepth', 'missing_value', missing_value) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#endif + + IF (p_is_io) THEN + ! snow depth (m) + CALL allocate_block_data (gsnow, snow_d_grid) + CALL ncio_read_block_time (fsnowdat, 'snowdepth', gsnow, month, snow_d_grid) + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (validval (numpatch)) + ENDIF + ENDIF + + CALL msnow2p%build_arealweighted (gsnow, landpatch) + CALL msnow2p%set_missing_value (snow_d_grid, missing_value, validval) + + CALL msnow2p%grid2pset (snow_d_grid, snow_d) + + IF (p_is_worker) THEN + WHERE (.not. validval) + snow_d = 0. + END WHERE + ENDIF + + IF (allocated(validval)) deallocate(validval) + + ENDIF + + ELSE + use_snowini = .false. + ENDIF + + + ! for SOIL Water INIT by using water table depth + use_wtd = (.not. use_soilini) .and. DEF_USE_WaterTableInit + + IF (use_wtd) THEN + + fwtd = DEF_file_WaterTable + + IF (p_is_master) THEN + inquire (file=trim(fwtd), exist=use_wtd) + IF (use_wtd) THEN + write(*,'(/, 2A)') 'Use water table depth and derived equilibrium state ' & + // ' to initialize soil water content from file ', trim(fwtd) + ELSE + write(*,*) 'No initial data for water table depth from ', trim(fwtd) + ENDIF + ENDIF +#ifdef USEMPI + CALL mpi_bcast (use_wtd, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#endif + ENDIF + + IF (use_wtd) THEN + + CALL julian2monthday (idate(1), idate(2), month, mday) + CALL gwtd%define_from_file (fwtd) + + IF (p_is_io) THEN + CALL allocate_block_data (gwtd, wtd_xy) + CALL ncio_read_block_time (fwtd, 'wtd', gwtd, month, wtd_xy) + ENDIF + + CALL m_wtd2p%build_arealweighted (gwtd, landpatch) + CALL m_wtd2p%grid2pset (wtd_xy, zwt) + + ENDIF + +! ................... +! 2.4 LEAF area index +! ................... +#if (defined DYN_PHENOLOGY) + ! CREATE fraction of vegetation cover, greenness, leaf area index, stem index + IF (p_is_worker) THEN + + DO i = 1, numpatch + IF (use_soilini) THEN + DO nsl = 1, nl_soil + CALL polint(soil_z,soil_t(:,i),nl_soil_ini,z_soi(nsl),t_soisno(nsl,i)) + ENDDO + ELSE + t_soisno(1:,i) = 283. + ENDIF + ENDDO + + tlai(:)=0.0; tsai(:)=0.0; green(:)=0.0; fveg(:)=0.0 + DO i = 1, numpatch + ! Call Ecological Model() + ltyp = patchtype(i) + IF(ltyp > 0) THEN + CALL lai_empirical(ltyp, nl_soil,rootfr(1:,i), t_soisno(1:,i),tlai(i),tsai(i),fveg(i),green(i)) + ENDIF + ENDDO + + ENDIF +#else + + year = idate(1) + jday = idate(2) + + IF (DEF_LAI_MONTHLY) THEN + CALL julian2monthday (year, jday, month, mday) + IF (DEF_LAI_CHANGE_YEARLY) THEN + ! 08/03/2019, yuan: read global LAI/SAI data + CALL LAI_readin (year, month, dir_landdata) +#ifdef URBAN_MODEL + CALL UrbanLAI_readin (year, month, dir_landdata) +#endif + ELSE + CALL LAI_readin (lc_year, month, dir_landdata) +#ifdef URBAN_MODEL + CALL UrbanLAI_readin (lc_year, month, dir_landdata) +#endif + ENDIF + ELSE + Julian_8day = int(calendarday(idate)-1)/8*8 + 1 + CALL LAI_readin (year, Julian_8day, dir_landdata) + ENDIF +#ifdef RangeCheck + CALL check_vector_data ('LAI ', tlai) + CALL check_vector_data ('SAI ', tsai) +#endif + +#ifdef CROP + CALL CROP_readin () + IF (p_is_worker) THEN + DO i = 1, numpatch + IF(patchtype(i) .eq. 0)THEN + ps = patch_pft_s(i) + pe = patch_pft_e(i) + DO m = ps, pe + ivt = pftclass(m) + IF(ivt >= npcropmin)THEN + leafc_p (m) = 0._r8 + frootc_p(m) = 0._r8 + tlai (i) = 0._r8 + tsai (i) = 0._r8 + tlai_p (m) = 0._r8 + tsai_p (m) = 0._r8 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + IF (p_is_worker) THEN + IF(DEF_USE_IRRIGATION)THEN + sum_irrig(:) = 0._r8 + sum_deficit_irrig(:) = 0._r8 + sum_irrig_count(:) = 0._r8 + waterstorage(:) = 0._r8 + DO i = 1, numpatch + zwt_stand(i) = zwt(i) + 1._r8 + zwt_stand(i) = max(0., zwt_stand(i)) + zwt_stand(i) = min(80., zwt_stand(i)) + ENDDO + ENDIF + ENDIF +#endif +#endif + +! .............................................................................. +! 2.5 initialize time-varying variables, as subgrid vectors of length [numpatch] +! .............................................................................. + ! ------------------------------------------ + ! PLEASE + ! PLEASE UPDATE + ! PLEASE UPDATE when have the observed lake status + IF (p_is_worker) THEN + + t_lake (:,:) = 285. + lake_icefrac(:,:) = 0. + savedtke1 (:) = tkwat +#ifdef EXTERNAL_LAKE + DO i = 1, numpatch + IF(patchtype(i) == 4) THEN + CALL InitLakeTimeVars(i, lakedepth(i), t_lake(:,i), lake_icefrac(:,i), savedtke1(i)) + ENDIF + ENDDO +#endif + ENDIF + ! ------------------------------------------ + + IF (p_is_worker) THEN + + !TODO: can be removed as CLMDRIVER.F90 yuan@ + allocate ( z_soisno (maxsnl+1:nl_soil,numpatch) ); z_soisno (:,:) = spval + allocate ( dz_soisno(maxsnl+1:nl_soil,numpatch) ); dz_soisno(:,:) = spval + + DO i = 1, numpatch + z_soisno (1:nl_soil ,i) = z_soi (1:nl_soil) + dz_soisno(1:nl_soil ,i) = dz_soi(1:nl_soil) + ENDDO + + zc_soimm = z_soi * 1000. + zi_soimm(0) = 0. + zi_soimm(1:nl_soil) = zi_soi * 1000. + + DO i = 1, numpatch + m = patchclass(i) + + IF (use_wtd) THEN + zwtmm = zwt(i) * 1000. + ENDIF + +#ifdef Campbell_SOIL_MODEL + vliq_r(:) = 0. + prms(1,1:nl_soil) = bsw(1:nl_soil,i) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + vliq_r(:) = theta_r(1:nl_soil,i) + prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,i) + prms(2,1:nl_soil) = n_vgm (1:nl_soil,i) + prms(3,1:nl_soil) = L_vgm (1:nl_soil,i) + prms(4,1:nl_soil) = sc_vgm (1:nl_soil,i) + prms(5,1:nl_soil) = fc_vgm (1:nl_soil,i) +#endif +#ifdef HYPERSPECTRAL + CALL flux_frac_init ( ) + CALL leaf_property_init ( rho_p, tau_p ) + CALL get_water_optical_properties( ) + CALL readin_urban_albedo ( ) +#endif + CALL iniTimeVar(i, patchtype(i)& + ,porsl(1:,i),psi0(1:,i),hksati(1:,i)& + ,soil_s_v_alb(i),soil_d_v_alb(i),soil_s_n_alb(i),soil_d_n_alb(i)& + ,z0m(i),zlnd,htop(i),z0mr(m),chil(m),rho(1:,1:,m),tau(1:,1:,m)& + ,z_soisno(maxsnl+1:,i),dz_soisno(maxsnl+1:,i)& + ,t_soisno(maxsnl+1:,i),wliq_soisno(maxsnl+1:,i),wice_soisno(maxsnl+1:,i)& + ,smp(1:,i),hk(1:,i),zwt(i),wa(i)& +!Plant hydraulic variables + ,vegwp(1:,i),gs0sun(i),gs0sha(i)& +!END plant hydraulic variables + ,t_grnd(i),tleaf(i),ldew(i),ldew_rain(i),ldew_snow(i),fwet_snow(i),sag(i),scv(i)& + ,snowdp(i),fveg(i),fsno(i),sigf(i),green(i),lai(i),sai(i),lai_old(i),coszen(i)& + ,snw_rds(:,i),mss_bcpho(:,i),mss_bcphi(:,i),mss_ocpho(:,i),mss_ocphi(:,i)& + ,mss_dst1(:,i),mss_dst2(:,i),mss_dst3(:,i),mss_dst4(:,i)& + ,alb(1:,1:,i),ssun(1:,1:,i),ssha(1:,1:,i)& + ,ssoi(1:,1:,i),ssno(1:,1:,i),ssno_lyr(1:,1:,:,i)& +#ifdef HYPERSPECTRAL + ,alb_hires(1:,1:,i)& +#endif + ,thermk(i),extkb(i),extkd(i)& + ,trad(i),tref(i),qref(i),rst(i),emis(i),zol(i),rib(i)& + ,ustar(i),qstar(i),tstar(i),fm(i),fh(i),fq(i)& +#ifdef HYPERSPECTRAL + ! New added: hyperspectral scheme + ,clr_frac, cld_frac & + ,reflectance(0:,1:,1:), transmittance(0:,1:,1:), soil_alb(1:,i), kw(1:), nw(1:)& + ,reflectance_out(:,:,i), transmittance_out(:,:,i)& + ,patchlatr(i), patchlonr(i)& + ,urban_albedo, mean_albedo, lat_north, lat_south, lon_east, lon_west& +#endif +!Ozone Vairables + ,o3coefv_sun(i),o3coefv_sha(i),o3coefg_sun(i),o3coefg_sha(i)& +#ifdef BGC + ,use_cnini, totlitc(i), totsomc(i), totcwdc(i), decomp_cpools(:,i), decomp_cpools_vr(:,:,i) & + ,ctrunc_veg(i), ctrunc_soil(i), ctrunc_vr(:,i) & + ,totlitn(i), totsomn(i), totcwdn(i), decomp_npools(:,i), decomp_npools_vr(:,:,i) & + ,ntrunc_veg(i), ntrunc_soil(i), ntrunc_vr(:,i) & + ,totvegc(i), totvegn(i), totcolc(i), totcoln(i), col_endcb(i), col_begcb(i), col_endnb(i), col_begnb(i) & + ,col_vegendcb(i), col_vegbegcb(i), col_soilendcb(i), col_soilbegcb(i) & + ,col_vegendnb(i), col_vegbegnb(i), col_soilendnb(i), col_soilbegnb(i) & + ,col_sminnendnb(i), col_sminnbegnb(i) & + ,altmax(i) , altmax_lastyear(i), altmax_lastyear_indx(i), lag_npp(i) & + ,sminn_vr(:,i), sminn(i), smin_no3_vr (:,i), smin_nh4_vr (:,i)& + ,prec10(i), prec60(i), prec365 (i), prec_today(i), prec_daily(:,i), tsoi17(i), rh30(i), accumnstep(i) , skip_balance_check(i) & +!------------------------SASU variables----------------------- ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & + ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & + ,I_met_c_vr_acc (:,i), I_cel_c_vr_acc (:,i), I_lig_c_vr_acc (:,i), I_cwd_c_vr_acc (:,i) & + ,AKX_met_to_soil1_c_vr_acc (:,i), AKX_cel_to_soil1_c_vr_acc (:,i), AKX_lig_to_soil2_c_vr_acc (:,i), AKX_soil1_to_soil2_c_vr_acc(:,i) & + ,AKX_cwd_to_cel_c_vr_acc (:,i), AKX_cwd_to_lig_c_vr_acc (:,i), AKX_soil1_to_soil3_c_vr_acc(:,i), AKX_soil2_to_soil1_c_vr_acc(:,i) & + ,AKX_soil2_to_soil3_c_vr_acc(:,i), AKX_soil3_to_soil1_c_vr_acc(:,i) & + ,AKX_met_exit_c_vr_acc (:,i), AKX_cel_exit_c_vr_acc (:,i), AKX_lig_exit_c_vr_acc (:,i), AKX_cwd_exit_c_vr_acc (:,i) & + ,AKX_soil1_exit_c_vr_acc (:,i), AKX_soil2_exit_c_vr_acc (:,i), AKX_soil3_exit_c_vr_acc (:,i) & + ,diagVX_c_vr_acc (:,:,i), upperVX_c_vr_acc (:,:,i), lowerVX_c_vr_acc (:,:,i) & + ,I_met_n_vr_acc (:,i), I_cel_n_vr_acc (:,i), I_lig_n_vr_acc (:,i), I_cwd_n_vr_acc (:,i) & + ,AKX_met_to_soil1_n_vr_acc (:,i), AKX_cel_to_soil1_n_vr_acc (:,i), AKX_lig_to_soil2_n_vr_acc (:,i), AKX_soil1_to_soil2_n_vr_acc(:,i) & + ,AKX_cwd_to_cel_n_vr_acc (:,i), AKX_cwd_to_lig_n_vr_acc (:,i), AKX_soil1_to_soil3_n_vr_acc(:,i), AKX_soil2_to_soil1_n_vr_acc(:,i) & + ,AKX_soil2_to_soil3_n_vr_acc(:,i), AKX_soil3_to_soil1_n_vr_acc(:,i) & + ,AKX_met_exit_n_vr_acc (:,i), AKX_cel_exit_n_vr_acc (:,i), AKX_lig_exit_n_vr_acc (:,i), AKX_cwd_exit_n_vr_acc (:,i) & + ,AKX_soil1_exit_n_vr_acc (:,i), AKX_soil2_exit_n_vr_acc (:,i), AKX_soil3_exit_n_vr_acc (:,i) & + ,diagVX_n_vr_acc (:,:,i), upperVX_n_vr_acc (:,:,i), lowerVX_n_vr_acc (:,:,i) & + !------------------------------------------------------------ +#endif + ! for SOIL INIT of water, temperature, snow depth + ,use_soilini, nl_soil_ini, soil_z, soil_t(1:,i), soil_w(1:,i), use_snowini, snow_d(i) & + ! for SOIL Water INIT by using water table depth + ,use_wtd, zwtmm, zc_soimm, zi_soimm, vliq_r, nprms, prms) + +#ifdef EXTERNAL_LAKE + IF(patchtype(i) == 4) THEN + z0m(i) = DEF_External_Lake%DEF_LAKE_Z0M + ENDIF +#endif + +#ifdef URBAN_MODEL + IF (m == URBAN) THEN + + u = patch2urban(i) + lwsun (u) = 0. !net longwave radiation of sunlit wall + lwsha (u) = 0. !net longwave radiation of shaded wall + lgimp (u) = 0. !net longwave radiation of impervious road + lgper (u) = 0. !net longwave radiation of pervious road + lveg (u) = 0. !net longwave radiation of vegetation [W/m2] + + t_roofsno (:,u) = 283. !temperatures of roof layers + t_wallsun (:,u) = 283. !temperatures of sunlit wall layers + t_wallsha (:,u) = 283. !temperatures of shaded wall layers + t_gimpsno (:,u) = 283. !temperatures of impervious road layers + t_gpersno (:,u) = 283. !soil temperature [K] + t_lakesno (:,u) = 283. !lake soil temperature [K] + + wice_roofsno(:,u) = 0. !ice lens [kg/m2] + wice_gimpsno(:,u) = 0. !ice lens [kg/m2] + wice_gpersno(:,u) = 0. !ice lens [kg/m2] + wice_lakesno(:,u) = 0. !ice lens [kg/m2] + wliq_roofsno(:,u) = 0. !liquid water [kg/m2] + wliq_gimpsno(:,u) = 0. !liquid water [kg/m2] + wliq_gpersno(:,u) = wliq_soisno(:,i) !liquid water [kg/m2] + wliq_lakesno(:,u) = wliq_soisno(:,i) !liquid water [kg/m2] + + wliq_soisno(: ,i) = 0. + wliq_soisno(:1,i) = wliq_roofsno(:1,u)*froof(u) + wliq_soisno(: ,i) = wliq_soisno(: ,i) + wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) + wliq_soisno(:1,i) = wliq_soisno(:1,i) + wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + snowdp_roof (u) = 0. !snow depth [m] + snowdp_gimp (u) = 0. !snow depth [m] + snowdp_gper (u) = 0. !snow depth [m] + snowdp_lake (u) = 0. !snow depth [m] + + z_sno_roof (:,u) = 0. !node depth of roof [m] + z_sno_gimp (:,u) = 0. !node depth of impervious [m] + z_sno_gper (:,u) = 0. !node depth pervious [m] + z_sno_lake (:,u) = 0. !node depth lake [m] + + dz_sno_roof (:,u) = 0. !interface depth of roof [m] + dz_sno_gimp (:,u) = 0. !interface depth of impervious [m] + dz_sno_gper (:,u) = 0. !interface depth pervious [m] + dz_sno_lake (:,u) = 0. !interface depth lake [m] + + t_room (u) = 283. !temperature of inner building [K] + troof_inner (u) = 283. !temperature of inner roof [K] + twsun_inner (u) = 283. !temperature of inner sunlit wall [K] + twsha_inner (u) = 283. !temperature of inner shaded wall [K] + Fhac (u) = 0. !sensible flux from heat or cool AC [W/m2] + Fwst (u) = 0. !waste heat flux from heat or cool AC [W/m2] + Fach (u) = 0. !flux from inner and outer air exchange [W/m2] + meta (u) = 0. !flux from metabolic [W/m2] + vehc (u) = 0. !flux from vehicle [W/m2] + + CALL UrbanIniTimeVar(i,froof(u),fgper(u),flake(u),hlr(u),hroof(u),& + alb_roof(:,:,u),alb_wall(:,:,u),alb_gimp(:,:,u),alb_gper(:,:,u),& + rho(:,:,m),tau(:,:,m),fveg(i),htop(i),hbot(i),lai(i),sai(i),coszen(i),& + fsno_roof(u),fsno_gimp(u),fsno_gper(u),fsno_lake(u),& + scv_roof(u),scv_gimp(u),scv_gper(u),scv_lake(u),fwet_snow(u),& + sag_roof(u),sag_gimp(u),sag_gper(u),sag_lake(u),t_lake(1,i),& + fwsun(u),dfwsun(u),extkd(i),alb(:,:,i),ssun(:,:,i),ssha(:,:,i),sroof(:,:,u),& + swsun(:,:,u),swsha(:,:,u),sgimp(:,:,u),sgper(:,:,u),slake(:,:,u)) + + ENDIF +#endif + ENDDO + + DO i = 1, numpatch + z_sno (maxsnl+1:0,i) = z_soisno (maxsnl+1:0,i) + dz_sno(maxsnl+1:0,i) = dz_soisno(maxsnl+1:0,i) + ENDDO + + ENDIF + ! ------------------------------------------ + + ! ----- +#ifdef CatchLateralFlow + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (patcharea (numpatch)) + patcharea(:) = 0. + DO ip = 1, numpatch + ie = landpatch%ielm(ip) + DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) + patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + ENDDO + ENDIF + ENDIF + + CALL element_neighbour_init (patcharea,lc_year) + CALL river_lake_network_init (patcharea) + + IF (p_is_worker) THEN + + ! set variables "veloc_bsnhru", "wdsrf_bsnhru_prev" + DO i = 1, numbasin + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + + wdsrf_bsnhru(hs:he) = 0. + IF (lake_id(i) == 0) THEN + wdsrf_bsnhru(hs) = riverdpth(i) + ELSEIF (lake_id(i) > 0) THEN + wdsrf_bsnhru(hs:he) = lakeinfo(i)%depth0 + ENDIF + + veloc_bsnhru(hs:he) = 0. + wdsrf_bsnhru_prev(hs:he) = wdsrf_bsnhru(hs:he) + ENDDO + + ! set variables "veloc_riv", "wdsrf_bsn_prev" + DO i = 1, numbasin + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + IF (lake_id(i) <= 0) THEN + wdsrf_bsn(i) = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he)) - handmin(i) + ELSE + ! lake + totalvolume = sum(wdsrf_bsnhru(hs:he) * lakeinfo(i)%area0) + wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume) + ENDIF + veloc_riv(i) = 0 + wdsrf_bsn_prev(i) = wdsrf_bsn(i) + ENDDO + + CALL worker_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval) + + ! adjust "wdsrf" according to river and lake water depth + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + wdsrf(ps:pe) = wdsrf_hru(i) * 1.0e3 ! m to mm + ENDDO + + ! adjust lake levels "dz_lake" according to lake depth + DO i = 1, numpatch + IF (wdsrf(i) > 0.) THEN + wdsrfm = wdsrf(i)*1.e-3 + IF(wdsrfm > 1. .and. wdsrfm < 2000.)THEN + depthratio = wdsrfm / sum(dzlak(1:nl_lake)) + dz_lake(1,i) = dzlak(1) + dz_lake(2:nl_lake-1,i) = dzlak(2:nl_lake-1)*depthratio + dz_lake(nl_lake,i) = dzlak(nl_lake)*depthratio - (dz_lake(1,i) - dzlak(1)*depthratio) + ELSEIF(wdsrfm > 0. .and. wdsrfm <= 1.)THEN + dz_lake(:,i) = wdsrfm / nl_lake + ENDIF + ELSE + dz_lake(:,i) = 0. + ENDIF + ENDDO + + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('Basin Water Depth [m] ', wdsrf_bsn) + CALL check_vector_data ('HRU Water Depth [m] ', wdsrf_bsnhru) +#endif + + IF (allocated(patcharea)) deallocate(patcharea) + +#endif + +#ifdef GridRiverLakeFlow + IF (p_is_worker) THEN + IF (numucat > 0) THEN + wdsrf_ucat = topo_rivhgt + veloc_riv = 0 + ENDIF + + IF (DEF_Reservoir_Method > 0) THEN + IF (numresv > 0) THEN + WHERE (idate(1) >= dam_build_year) + volresv = volresv_normal + ELSEWHERE + volresv = spval + END WHERE + ENDIF + ENDIF + ENDIF +#endif + +#ifdef DataAssimilation + IF (p_is_worker) THEN + DO i = 1, DEF_DA_ENS_NUM + z_sno_ens(:, i, :) = z_sno + dz_sno_ens(:, i, :) = dz_sno + t_soisno_ens(:, i, :) = t_soisno + wliq_soisno_ens(:, i, :) = wliq_soisno + wice_soisno_ens(:, i, :) = wice_soisno + smp_ens(:, i, :) = smp + hk_ens(:, i, :) = hk + t_grnd_ens(i, :) = t_grnd + tleaf_ens(i, :) = tleaf + ldew_ens(i, :) = ldew + ldew_rain_ens(i, :) = ldew_rain + ldew_snow_ens(i, :) = ldew_snow + fwet_snow_ens(i, :) = fwet_snow + sag_ens(i, :) = sag + scv_ens(i, :) = scv + snowdp_ens(i, :) = snowdp + fveg_ens(i, :) = fveg + fsno_ens(i, :) = fsno + sigf_ens(i, :) = sigf + green_ens(i, :) = green + tlai_ens(i, :) = tlai + lai_ens(i, :) = lai + sai_ens(i, :) = sai + tsai_ens(i, :) = tsai + alb_ens(:, :, i, :) = alb + ssun_ens(:, :, i, :) = ssun + ssha_ens(:, :, i, :) = ssha + ssoi_ens(:, :, i, :) = ssoi + ssno_ens(:, :, i, :) = ssno + thermk_ens(i, :) = thermk + extkb_ens(i, :) = extkb + extkd_ens(i, :) = extkd + zwt_ens(i, :) = zwt + wdsrf_ens(i, :) = wdsrf + wa_ens(i, :) = wa + wetwat_ens(i, :) = wetwat + t_lake_ens(:, i, :) = t_lake + lake_icefrac_ens(:, i, :) = lake_icefrac + savedtke1_ens(i, :) = savedtke1 + ENDDO + ENDIF +#endif + + +! ............................................................... +! 2.6 Write out the model variables for restart run [histTimeVar] +! ............................................................... + +#ifdef RangeCheck + CALL check_TimeVariables () +#endif + + IF ( .not. present(lulcc_call) ) THEN + ! only be called in running MKINI, LULCC will be executed later + CALL WRITE_TimeVariables (idate, lc_year, casename, dir_restart) + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) write (6,*) ('Successfully Initialize the Land Time-Vraying Variables') + + +! -------------------------------------------------- +! Deallocates memory for CoLM 1d [numpatch] variables +! -------------------------------------------------- + IF ( .not. present(lulcc_call) ) THEN + ! only be called in running MKINI, LULCC will be executed later + CALL deallocate_TimeInvariants + CALL deallocate_TimeVariables + ENDIF + + IF (allocated(z_soisno )) deallocate (z_soisno ) + IF (allocated(dz_soisno)) deallocate (dz_soisno) + + IF (allocated(soil_z)) deallocate (soil_z) + IF (allocated(snow_d)) deallocate (snow_d) + IF (allocated(soil_t)) deallocate (soil_t) + IF (allocated(soil_w)) deallocate (soil_w) + + END SUBROUTINE initialize + +END MODULE MOD_Initialize +! -------------------------------------------------- +! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 new file mode 100644 index 0000000000..087c941de5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 @@ -0,0 +1,110 @@ +#include + +MODULE MOD_LakeDepthReadin + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Read in lakedepth and assign lake thickness of each layer. +! +! Original author: Yongjiu Dai, 03/2018 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: lakedepth_readin + + +CONTAINS + + + SUBROUTINE lakedepth_readin (dir_landdata, lc_year) + + USE MOD_Precision + USE MOD_Vars_Global, only: nl_lake + USE MOD_SPMD_Task + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_TimeInvariants, only: lakedepth, dz_lake +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year ! which year of land cover data used + character(len=256), intent(in) :: dir_landdata + + ! Local Variables + character(len=256) :: lndname, cyear + real(r8) :: depthratio ! ratio of lake depth to standard deep lake depth + integer :: ipatch + + ! ----------------------------------------------------------- + ! For global simulations with 10 body layers, + ! the default (50 m lake) body layer thicknesses are given by : + ! The node depths zlak located at the center of each layer + real(r8), dimension(10) :: dzlak + real(r8), dimension(10) :: zlak + + dzlak = (/0.1, 1., 2., 3., 4., 5., 7., 7., 10.45, 10.45/) ! m + zlak = (/0.05, 0.6, 2.1, 4.6, 8.1, 12.6, 18.6, 25.6, 34.325, 44.775/) + + ! For site simulations with 25 layers, the default thicknesses are (m): + ! real(r8), dimension(25) :: dzlak + ! dzlak = (/0.1, & ! 0.1 for layer 1; + ! 0.25, 0.25, 0.25, 0.25, & ! 0.25 for layers 2-5; + ! 0.50, 0.50, 0.50, 0.50, & ! 0.5 for layers 6-9; + ! 0.75, 0.75, 0.75, 0.75, & ! 0.75 for layers 10-13; + ! 2.00, 2.00, & ! 2 for layers 14-15; + ! 2.50, 2.50, & ! 2.5 for layers 16-17; + ! 3.50, 3.50, 3.50, 3.50, & ! 2.5 for layers 16-17; + ! 5.225, 5.225, 5.225, 5.225/) ! 5.225 for layers 22-25. + ! + ! For lakes with depth d /= 50 m and d >= 1 m, + ! the top layer is kept at 10 cm and + ! the other 9 layer thicknesses are adjusted to maintain fixed + ! proportions. + ! + ! For lakes with d < 1 m, all layers have equal thickness. + ! ----------------------------------------------------------- + + ! Read lakedepth +#ifdef SinglePoint + lakedepth(:) = SITE_lakedepth +#else + write(cyear,'(i4.4)') lc_year + lndname = trim(dir_landdata)//'/lakedepth/'//trim(cyear)//'/lakedepth_patches.nc' + CALL ncio_read_vector (lndname, 'lakedepth_patches', landpatch, lakedepth) +#endif + + ! Define lake levels + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + + ! testing 14/05/2021, Zhang + IF(lakedepth(ipatch) < 0.1) lakedepth(ipatch) = 0.1 + + IF(lakedepth(ipatch) > 1. .and. lakedepth(ipatch) < 2000.)THEN + depthratio = lakedepth(ipatch) / sum(dzlak(1:nl_lake)) + dz_lake(1,ipatch) = dzlak(1) + dz_lake(2:nl_lake-1,ipatch) = dzlak(2:nl_lake-1)*depthratio + dz_lake(nl_lake,ipatch) = dzlak(nl_lake)*depthratio & + - (dz_lake(1,ipatch) - dzlak(1)*depthratio) + ELSEIF(lakedepth(ipatch) > 0. .and. lakedepth(ipatch) <= 1.)THEN + dz_lake(:,ipatch) = lakedepth(ipatch) / nl_lake + ELSE ! non land water bodies or missing value of the lake depth + lakedepth(ipatch) = sum(dzlak(1:nl_lake)) + dz_lake(1:nl_lake,ipatch) = dzlak(1:nl_lake) + ENDIF + + ENDDO + + ENDIF + + END SUBROUTINE lakedepth_readin + +END MODULE MOD_LakeDepthReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 new file mode 100644 index 0000000000..9169b2a0c0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 @@ -0,0 +1,94 @@ +#include + +MODULE MOD_PercentagesPFTReadin + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: pct_readin + +CONTAINS + + SUBROUTINE pct_readin (dir_landdata, lc_year) + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_NetCDFVector + USE MOD_LandPatch +#ifdef RangeCheck + USE MOD_RangeCheck +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants +#endif +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + IMPLICIT NONE + + integer, intent(in) :: lc_year + character(len=256), intent(in) :: dir_landdata + ! Local Variables + character(len=256) :: lndname, cyear + real(r8), allocatable :: sumpct (:) + integer :: npatch, ipatch + + write(cyear,'(i4.4)') lc_year +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) /= 0) RETURN +#endif + +#ifndef SinglePoint + lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_pfts.nc' + CALL ncio_read_vector (lndname, 'pct_pfts', landpft, pftfrac) +#else + pftfrac = pack(SITE_pctpfts, SITE_pctpfts > 0.) +#endif + +#if (defined CROP) +#ifndef SinglePoint + lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_crops.nc' + CALL ncio_read_vector (lndname, 'pct_crops', landpatch, cropfrac) +#else + IF (SITE_landtype == CROPLAND) THEN + cropfrac = pack(SITE_pctcrop, SITE_pctcrop > 0.) + ELSE + cropfrac = 0. + ENDIF +#endif +#endif + +#ifdef RangeCheck + IF (p_is_worker) THEN + npatch = count(patchtypes(landpatch%settyp) == 0) + allocate (sumpct (npatch)) + + npatch = 0 + DO ipatch = 1, numpatch + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN + npatch = npatch + 1 + sumpct(npatch) = sum(pftfrac(patch_pft_s(ipatch):patch_pft_e(ipatch))) + ENDIF + ENDDO + + ENDIF + + CALL check_vector_data ('Sum PFT pct', sumpct) +#if (defined CROP) + CALL check_vector_data ('CROP pct', cropfrac) +#endif +#endif + +#endif + + IF (allocated(sumpct)) deallocate(sumpct) + + END SUBROUTINE pct_readin + +END MODULE MOD_PercentagesPFTReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 new file mode 100644 index 0000000000..f11842481e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 @@ -0,0 +1,115 @@ +#include + +MODULE MOD_SoilColorRefl + +!======================================================================= +! Guess the soil color (reflectance) based on the land cover types +! +! Created by Yongjiu Dai, 03/2014 +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: soil_color_refl + +CONTAINS + + SUBROUTINE soil_color_refl(L,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: L ! land cover types (GLCC USGS/MODIS IGBP) + real(r8), intent(out) :: soil_s_v_alb ! albedo of visible of the saturated soil + real(r8), intent(out) :: soil_d_v_alb ! albedo of visible of the dry soil + real(r8), intent(out) :: soil_s_n_alb ! albedo of near infrared of the saturated soil + real(r8), intent(out) :: soil_d_n_alb ! albedo of near infrared of the dry soil + + integer :: isc ! soil color + + real(r8) soil_s_v_refl(20) ! Saturated visible soil reflectance + real(r8) soil_d_v_refl(20) ! Dry visible soil reflectance + real(r8) soil_s_n_refl(20) ! Saturated near infrared soil reflectance + real(r8) soil_d_n_refl(20) ! Dry near infrared soil reflectance + + ! ---------------------------------------------------------------------- + ! The soil color and reflectance is from the work: + ! Peter J. Lawrence and Thomas N. Chase, 2007: + ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0): + ! Part 1 generating MODIS consistent land surface parameters + + soil_s_v_refl = (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, & + 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /) + + soil_d_v_refl = (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, & + 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /) + + soil_s_n_refl = (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, & + 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /) + + soil_d_n_refl = (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, & + 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /) + + ! Guessed soil color of the Lawrence's classification +#if (defined LULC_USGS) + IF(L.eq. 0) isc = 1 ! 0 Ocean (not used) + IF(L.eq. 1) isc = 16 ! 1 Urban and Built-Up Land + IF(L.eq. 2) isc = 3 ! 2 Dryland Cropland and Pasture + IF(L.eq. 3) isc = 9 ! 3 Irrigated Cropland and Pasture + IF(L.eq. 4) isc = 10 ! 4 Mixed Dryland/Irrigated Cropland and Pasture + IF(L.eq. 5) isc = 4 ! 5 Cropland/Grassland Mosaic + IF(L.eq. 6) isc = 6 ! 6 Cropland/Woodland Mosaic + IF(L.eq. 7) isc = 2 ! 7 Grassland + IF(L.eq. 8) isc = 8 ! 8 Shrubland + IF(L.eq. 9) isc = 7 ! 9 Mixed Shrubland/Grassland + IF(L.eq.10) isc = 5 !10 Savanna + IF(L.eq.11) isc = 19 !11 Deciduous Broadleaf Forest + IF(L.eq.12) isc = 20 !12 Deciduous Needleleaf Forest + IF(L.eq.13) isc = 18 !13 Evergreen Broadleaf Forest + IF(L.eq.14) isc = 17 !14 Evergreen Needleleaf Forest + IF(L.eq.15) isc = 16 !15 Mixed Forest + IF(L.eq.16) isc = 1 !16 Water Bodies (not used) + IF(L.eq.17) isc = 15 !17 Herbaceous Wetland + IF(L.eq.18) isc = 14 !18 Wooded Wetland + IF(L.eq.19) isc = 1 !19 Barren or Sparsely Vegetated + IF(L.eq.20) isc = 12 !20 Herbaceous Tundra + IF(L.eq.21) isc = 12 !21 Wooded Tundra + IF(L.eq.22) isc = 13 !22 Mixed Tundra + IF(L.eq.23) isc = 11 !23 Bare Ground Tundra + IF(L.eq.24) isc = 1 !24 Snow or Ice (not used) +#endif + +#if (defined LULC_IGBP) + IF(L.eq. 0) isc = 1 !0 Ocean (not used) + IF(L.eq. 1) isc = 17 !1 Evergreen Needleleaf Forest + IF(L.eq. 2) isc = 18 !2 Evergreen Broadleaf Forest + IF(L.eq. 3) isc = 20 !3 Deciduous Needleleaf Forest + IF(L.eq. 4) isc = 19 !4 Deciduous Broadleaf Forest + IF(L.eq. 5) isc = 13 !5 Mixed Forest + IF(L.eq. 6) isc = 9 !6 Closed Shrublands + IF(L.eq. 7) isc = 8 !7 Open Shrublands + IF(L.eq. 8) isc = 4 !8 Woody Savannas + IF(L.eq. 9) isc = 3 !9 Savannas + IF(L.eq.10) isc = 2 !10 Grasslands + IF(L.eq.11) isc = 15 !11 Permanent Wetlands + IF(L.eq.12) isc = 6 !12 Croplands + IF(L.eq.13) isc = 16 !13 Urban and Built-Up + IF(L.eq.14) isc = 12 !14 Cropland/Natural Vegetation Mosaic + IF(L.eq.15) isc = 1 !15 Snow and Ice (not used) + IF(L.eq.16) isc = 1 !16 Barren or Sparsely Vegetated + IF(L.eq.17) isc = 1 !17 Land Water Bodies +#endif + + soil_s_v_alb = soil_s_v_refl(isc) + soil_d_v_alb = soil_d_v_refl(isc) + soil_s_n_alb = soil_s_n_refl(isc) + soil_d_n_alb = soil_d_n_refl(isc) + + END SUBROUTINE soil_color_refl + +END MODULE MOD_SoilColorRefl +! ---------------------------------------------------------------------- +! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 new file mode 100644 index 0000000000..6e76162c2b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 @@ -0,0 +1,550 @@ +#include + +MODULE MOD_SoilParametersReadin + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Read in soil parameters; make unit conversion for soil physical process +! modeling; soil parameters 8 layers => 10 layers +! +! Original author: Yongjiu Dai, 03/2014 +! +! !REVISIONS: +! Nan Wei, 01/2019: read more parameters from mksrfdata results +! Shupeng Zhang and Nan Wei, 01/2022: porting codes to parallel version +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: soil_parameters_readin + +CONTAINS + + SUBROUTINE soil_parameters_readin (dir_landdata, lc_year) + + USE MOD_Precision + USE MOD_Vars_Global, only: nl_soil + USE MOD_Namelist, only: DEF_SOIL_REFL_SCHEME + USE MOD_SPMD_Task + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + USE MOD_SoilColorRefl + + IMPLICIT NONE + + ! ---------------------------------------------------------------------- + integer, intent(in) :: lc_year ! which year of land cover data used + character(len=*), intent(in) :: dir_landdata + character(len=4) :: wavelength ! wavelength in nm + + ! Local Variables + + real(r8), allocatable :: soil_vf_quartz_mineral_s_l (:) ! volumetric fraction of quartz within mineral soil + real(r8), allocatable :: soil_vf_gravels_s_l (:) ! volumetric fraction of gravels + real(r8), allocatable :: soil_vf_om_s_l (:) ! volumetric fraction of organic matter + real(r8), allocatable :: soil_vf_sand_s_l (:) ! volumetric fraction of sand + real(r8), allocatable :: soil_vf_clay_s_l (:) ! volumetric fraction of clay + real(r8), allocatable :: soil_wf_gravels_s_l (:) ! gravimetric fraction of gravels + real(r8), allocatable :: soil_wf_sand_s_l (:) ! gravimetric fraction of sand + real(r8), allocatable :: soil_wf_clay_s_l (:) ! gravimetric fraction of clay + real(r8), allocatable :: soil_wf_om_s_l (:) ! gravimetric fraction of om + real(r8), allocatable :: soil_OM_density_s_l (:) ! OM_density (kg/m3) + real(r8), allocatable :: soil_BD_all_s_l (:) ! bulk density of soil (GRAVELS + OM + mineral soils, kg/m3) + real(r8), allocatable :: soil_theta_s_l (:) ! saturated water content (cm3/cm3) + real(r8), allocatable :: soil_psi_s_l (:) ! matric potential at saturation (cm) + real(r8), allocatable :: soil_lambda_l (:) ! pore size distribution index (dimensionless) +#ifdef HYPERSPECTRAL + real(r8), allocatable :: soil_hyper_alb_wl (:) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), allocatable :: soil_theta_r_l (:) ! residual water content (cm3/cm3) + real(r8), allocatable :: soil_alpha_vgm_l (:) + real(r8), allocatable :: soil_L_vgm_l (:) + real(r8), allocatable :: soil_n_vgm_l (:) +#endif + real(r8), allocatable :: soil_k_s_l (:) ! saturated hydraulic conductivity (cm/day) + real(r8), allocatable :: soil_csol_l (:) ! heat capacity of soil solids [J/(m3 K)] + real(r8), allocatable :: soil_k_solids_l(:) ! thermal conductivity of minerals soil [W/m-K] + real(r8), allocatable :: soil_tksatu_l (:) ! thermal conductivity of saturated unfrozen soil [W/m-K] + real(r8), allocatable :: soil_tksatf_l (:) ! thermal conductivity of saturated frozen soil [W/m-K] + real(r8), allocatable :: soil_tkdry_l (:) ! thermal conductivity for dry soil [W/(m-K)] + real(r8), allocatable :: soil_BA_alpha_l(:) ! alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: soil_BA_beta_l (:) ! beta in Balland and Arp(2005) thermal conductivity scheme + + integer :: ipatch, m, nsl, wl ! indices + integer :: wl_nm ! wavelength in nm (integer) + character(len=256) :: c + character(len=256) :: landdir, lndname, cyear, wl_str, hyper_dir + logical :: is_singlepoint + + ! ............................................................... + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_landdata) // '/soil/' // trim(cyear) + + ! write(*,*) 'soil parameter readin',landdir + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate ( soil_vf_quartz_mineral_s_l (numpatch) ) + allocate ( soil_vf_gravels_s_l (numpatch) ) + allocate ( soil_vf_om_s_l (numpatch) ) + allocate ( soil_vf_sand_s_l (numpatch) ) + allocate ( soil_vf_clay_s_l (numpatch) ) + allocate ( soil_wf_gravels_s_l (numpatch) ) + allocate ( soil_wf_sand_s_l (numpatch) ) + allocate ( soil_wf_clay_s_l (numpatch) ) + allocate ( soil_wf_om_s_l (numpatch) ) + allocate ( soil_OM_density_s_l (numpatch) ) + allocate ( soil_BD_all_s_l (numpatch) ) + allocate ( soil_theta_s_l (numpatch) ) + allocate ( soil_psi_s_l (numpatch) ) + allocate ( soil_lambda_l (numpatch) ) +#ifdef HYPERSPECTRAL + allocate ( soil_hyper_alb_wl (numpatch) ) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + allocate ( soil_theta_r_l (numpatch) ) + allocate ( soil_alpha_vgm_l (numpatch) ) + allocate ( soil_L_vgm_l (numpatch) ) + allocate ( soil_n_vgm_l (numpatch) ) +#endif + allocate ( soil_k_s_l (numpatch) ) + allocate ( soil_csol_l (numpatch) ) + allocate ( soil_k_solids_l(numpatch) ) + allocate ( soil_tksatu_l (numpatch) ) + allocate ( soil_tksatf_l (numpatch) ) + allocate ( soil_tkdry_l (numpatch) ) + allocate ( soil_BA_alpha_l(numpatch) ) + allocate ( soil_BA_beta_l (numpatch) ) + ENDIF + + ENDIF ! end if (p_is_worker) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + DO nsl = 1, 8 + +#ifdef SinglePoint + soil_vf_quartz_mineral_s_l (:) = SITE_soil_vf_quartz_mineral (nsl) + soil_vf_gravels_s_l (:) = SITE_soil_vf_gravels (nsl) + soil_vf_om_s_l (:) = SITE_soil_vf_om (nsl) + soil_vf_sand_s_l (:) = SITE_soil_vf_sand (nsl) + soil_vf_clay_s_l (:) = SITE_soil_vf_clay (nsl) + soil_wf_gravels_s_l (:) = SITE_soil_wf_gravels (nsl) + soil_wf_sand_s_l (:) = SITE_soil_wf_sand (nsl) + soil_wf_clay_s_l (:) = SITE_soil_wf_clay (nsl) + soil_wf_om_s_l (:) = SITE_soil_wf_om (nsl) + soil_OM_density_s_l (:) = SITE_soil_OM_density (nsl) + soil_BD_all_s_l (:) = SITE_soil_BD_all (nsl) + soil_theta_s_l (:) = SITE_soil_theta_s (nsl) + soil_psi_s_l (:) = SITE_soil_psi_s (nsl) + soil_lambda_l (:) = SITE_soil_lambda (nsl) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + soil_theta_r_l (:) = SITE_soil_theta_r (nsl) + soil_alpha_vgm_l (:) = SITE_soil_alpha_vgm(nsl) + soil_L_vgm_l (:) = SITE_soil_L_vgm (nsl) + soil_n_vgm_l (:) = SITE_soil_n_vgm (nsl) +#endif + soil_k_s_l (:) = SITE_soil_k_s (nsl) + soil_csol_l (:) = SITE_soil_csol (nsl) + soil_k_solids_l(:) = SITE_soil_k_solids (nsl) + soil_tksatu_l (:) = SITE_soil_tksatu (nsl) + soil_tksatf_l (:) = SITE_soil_tksatf (nsl) + soil_tkdry_l (:) = SITE_soil_tkdry (nsl) + soil_BA_alpha_l(:) = SITE_soil_BA_alpha (nsl) + soil_BA_beta_l (:) = SITE_soil_BA_beta (nsl) + +#else + write(c,'(i1)') nsl + + ! (1) read in the volumetric fraction of quartz within mineral soil + lndname = trim(landdir)//'/vf_quartz_mineral_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'vf_quartz_mineral_s_l'//trim(c)//'_patches', & + landpatch, soil_vf_quartz_mineral_s_l) + + ! (2) read in the volumetric fraction of gravels + lndname = trim(landdir)//'/vf_gravels_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'vf_gravels_s_l'//trim(c)//'_patches', & + landpatch, soil_vf_gravels_s_l) + + ! (3) read in the volumetric fraction of organic matter + lndname = trim(landdir)//'/vf_om_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'vf_om_s_l'//trim(c)//'_patches', & + landpatch, soil_vf_om_s_l) + + ! (4) read in the volumetric fraction of sand + lndname = trim(landdir)//'/vf_sand_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'vf_sand_s_l'//trim(c)//'_patches', & + landpatch, soil_vf_sand_s_l) + + ! (5) read in the gravimetric fraction of gravels + lndname = trim(landdir)//'/wf_gravels_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'wf_gravels_s_l'//trim(c)//'_patches', & + landpatch, soil_wf_gravels_s_l) + + ! (6) read in the gravimetric fraction of sand + lndname = trim(landdir)//'/wf_sand_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'wf_sand_s_l'//trim(c)//'_patches', & + landpatch, soil_wf_sand_s_l) + + ! (7) read in the saturated water content [cm3/cm3] + lndname = trim(landdir)//'/theta_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'theta_s_l'//trim(c)//'_patches', & + landpatch, soil_theta_s_l) + + ! (8) read in the matric potential at saturation [cm] + lndname = trim(landdir)//'/psi_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'psi_s_l'//trim(c)//'_patches', & + landpatch, soil_psi_s_l) + + ! (9) read in the pore size distribution index [dimensionless] + lndname = trim(landdir)//'/lambda_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'lambda_l'//trim(c)//'_patches', & + landpatch, soil_lambda_l) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! (10) read in residual water content [cm3/cm3] + lndname = trim(landdir)//'/theta_r_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'theta_r_l'//trim(c)//'_patches', & + landpatch, soil_theta_r_l) + + ! (11) read in alpha in VGM model + lndname = trim(landdir)//'/alpha_vgm_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'alpha_vgm_l'//trim(c)//'_patches', & + landpatch, soil_alpha_vgm_l) + + ! (12) read in L in VGM model + lndname = trim(landdir)//'/L_vgm_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'L_vgm_l'//trim(c)//'_patches', & + landpatch, soil_L_vgm_l) + + ! (13) read in n in VGM model + lndname = trim(landdir)//'/n_vgm_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'n_vgm_l'//trim(c)//'_patches', & + landpatch, soil_n_vgm_l) +#endif + + ! (14) read in the saturated hydraulic conductivity [cm/day] + lndname = trim(landdir)//'/k_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'k_s_l'//trim(c)//'_patches', & + landpatch, soil_k_s_l) + + ! (15) read in the heat capacity of soil solids [J/(m3 K)] + lndname = trim(landdir)//'/csol_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'csol_l'//trim(c)//'_patches', & + landpatch, soil_csol_l) + + ! (16) read in the thermal conductivity of unfrozen saturated soil [W/m-K] + lndname = trim(landdir)//'/tksatu_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'tksatu_l'//trim(c)//'_patches', & + landpatch, soil_tksatu_l) + + ! (17) read in the thermal conductivity of frozen saturated soil [W/m-K] + lndname = trim(landdir)//'/tksatf_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'tksatf_l'//trim(c)//'_patches', & + landpatch, soil_tksatf_l) + + ! (18) read in the thermal conductivity for dry soil [W/(m-K)] + lndname = trim(landdir)//'/tkdry_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'tkdry_l'//trim(c)//'_patches', & + landpatch, soil_tkdry_l) + + ! (19) read in the thermal conductivity of solid soil [W/m-K] + lndname = trim(landdir)//'/k_solids_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'k_solids_l'//trim(c)//'_patches', & + landpatch, soil_k_solids_l) + + ! (20) read in the parameter alpha in the Balland V. and P. A. Arp (2005) model + lndname = trim(landdir)//'/BA_alpha_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'BA_alpha_l'//trim(c)//'_patches', & + landpatch, soil_BA_alpha_l) + + ! (21) read in the parameter beta in the Balland V. and P. A. Arp (2005) model + lndname = trim(landdir)//'/BA_beta_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'BA_beta_l'//trim(c)//'_patches', & + landpatch, soil_BA_beta_l) + + ! (22) read in the OM density (kg/m3) + lndname = trim(landdir)//'/OM_density_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'OM_density_s_l'//trim(c)//'_patches', & + landpatch, soil_OM_density_s_l) + + ! (23) read in the bulk density of soil (kg/m3) + lndname = trim(landdir)//'/BD_all_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'BD_all_s_l'//trim(c)//'_patches', & + landpatch, soil_BD_all_s_l) + + ! (24) read in the volumetric fraction of clay + lndname = trim(landdir)//'/vf_clay_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'vf_clay_s_l'//trim(c)//'_patches', & + landpatch, soil_vf_clay_s_l, defval = 0.1) + + ! (25) read in the gravimetric fraction of clay + lndname = trim(landdir)//'/wf_clay_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'wf_clay_s_l'//trim(c)//'_patches', & + landpatch, soil_wf_clay_s_l, defval = 0.1) + + ! (26) read in the gravimetric fraction of om + lndname = trim(landdir)//'/wf_om_s_l'//trim(c)//'_patches.nc' + CALL ncio_read_vector (lndname, 'wf_om_s_l'//trim(c)//'_patches', & + landpatch, soil_wf_om_s_l, defval = 0.01) + +#endif + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + m = landpatch%settyp(ipatch) + IF( m == 0 )THEN ! ocean + vf_quartz (nsl,ipatch) = -1.e36 + vf_gravels(nsl,ipatch) = -1.e36 + vf_om (nsl,ipatch) = -1.e36 + vf_sand (nsl,ipatch) = -1.e36 + vf_clay (nsl,ipatch) = -1.e36 + wf_gravels(nsl,ipatch) = -1.e36 + wf_sand (nsl,ipatch) = -1.e36 + wf_clay (nsl,ipatch) = -1.e36 + wf_om (nsl,ipatch) = -1.e36 + OM_density(nsl,ipatch) = -1.e36 + BD_all (nsl,ipatch) = -1.e36 + wfc (nsl,ipatch) = -1.e36 + porsl (nsl,ipatch) = -1.e36 + psi0 (nsl,ipatch) = -1.e36 + bsw (nsl,ipatch) = -1.e36 + theta_r (nsl,ipatch) = -1.e36 +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm (nsl,ipatch) = -1.e36 + L_vgm (nsl,ipatch) = -1.e36 + n_vgm (nsl,ipatch) = -1.e36 +#endif + hksati (nsl,ipatch) = -1.e36 + csol (nsl,ipatch) = -1.e36 + k_solids (nsl,ipatch) = -1.e36 + dksatu (nsl,ipatch) = -1.e36 + dksatf (nsl,ipatch) = -1.e36 + dkdry (nsl,ipatch) = -1.e36 + BA_alpha (nsl,ipatch) = -1.e36 + BA_beta (nsl,ipatch) = -1.e36 + ELSE ! non ocean + vf_quartz (nsl,ipatch) = soil_vf_quartz_mineral_s_l(ipatch) + vf_gravels (nsl,ipatch) = soil_vf_gravels_s_l (ipatch) + vf_om (nsl,ipatch) = soil_vf_om_s_l (ipatch) + vf_sand (nsl,ipatch) = soil_vf_sand_s_l (ipatch) + vf_clay (nsl,ipatch) = soil_vf_clay_s_l (ipatch) + wf_gravels (nsl,ipatch) = soil_wf_gravels_s_l (ipatch) + wf_sand (nsl,ipatch) = soil_wf_sand_s_l (ipatch) + wf_clay (nsl,ipatch) = soil_wf_clay_s_l (ipatch) + wf_om (nsl,ipatch) = soil_wf_om_s_l (ipatch) + OM_density (nsl,ipatch) = soil_OM_density_s_l (ipatch) + BD_all (nsl,ipatch) = soil_BD_all_s_l (ipatch) + porsl (nsl,ipatch) = soil_theta_s_l (ipatch) ! cm/cm + psi0 (nsl,ipatch) = soil_psi_s_l (ipatch) * 10. ! cm -> mm + bsw (nsl,ipatch) = 1./soil_lambda_l (ipatch) ! dimensionless + wfc (nsl,ipatch) = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch))& + * soil_theta_s_l(ipatch) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + psi0 (nsl,ipatch) = -10. ! mm + theta_r (nsl,ipatch) = soil_theta_r_l (ipatch) + alpha_vgm (nsl,ipatch) = soil_alpha_vgm_l(ipatch) + L_vgm (nsl,ipatch) = soil_L_vgm_l (ipatch) + n_vgm (nsl,ipatch) = soil_n_vgm_l (ipatch) + wfc (nsl,ipatch) = soil_theta_r_l (ipatch)+(soil_theta_s_l(ipatch)-soil_theta_r_l(ipatch))*& + (1+(soil_alpha_vgm_l(ipatch)*339.9)**soil_n_vgm_l(ipatch))**(1.0/soil_n_vgm_l(ipatch)-1) +#else + theta_r (nsl,ipatch) = 0. +#endif + hksati (nsl,ipatch) = soil_k_s_l (ipatch) * 10./86400. ! cm/day -> mm/s + csol (nsl,ipatch) = soil_csol_l (ipatch) ! J/(m2 K) + k_solids (nsl,ipatch) = soil_k_solids_l (ipatch) ! W/(m K) + dksatu (nsl,ipatch) = soil_tksatu_l (ipatch) ! W/(m K) + dksatf (nsl,ipatch) = soil_tksatf_l (ipatch) ! W/(m K) + dkdry (nsl,ipatch) = soil_tkdry_l (ipatch) ! W/(m K) + BA_alpha (nsl,ipatch) = soil_BA_alpha_l (ipatch) + BA_beta (nsl,ipatch) = soil_BA_beta_l (ipatch) + ENDIF + ENDDO + + ENDIF + + ENDDO + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + deallocate ( soil_vf_quartz_mineral_s_l ) + deallocate ( soil_vf_gravels_s_l ) + deallocate ( soil_vf_om_s_l ) + deallocate ( soil_vf_sand_s_l ) + deallocate ( soil_vf_clay_s_l ) + deallocate ( soil_wf_gravels_s_l ) + deallocate ( soil_wf_sand_s_l ) + deallocate ( soil_wf_clay_s_l ) + deallocate ( soil_wf_om_s_l ) + deallocate ( soil_OM_density_s_l ) + deallocate ( soil_BD_all_s_l ) + deallocate ( soil_theta_s_l ) + deallocate ( soil_psi_s_l ) + deallocate ( soil_lambda_l ) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + deallocate ( soil_theta_r_l ) + deallocate ( soil_alpha_vgm_l ) + deallocate ( soil_L_vgm_l ) + deallocate ( soil_n_vgm_l ) +#endif + deallocate ( soil_k_s_l ) + deallocate ( soil_csol_l ) + deallocate ( soil_k_solids_l) + deallocate ( soil_tksatu_l ) + deallocate ( soil_tksatf_l ) + deallocate ( soil_tkdry_l ) + deallocate ( soil_BA_alpha_l) + deallocate ( soil_BA_beta_l ) + ENDIF + + ENDIF + + ! The parameters of the top NINTH soil layers were given by datasets + ! [0-0.045 (LAYER 1-2), 0.045-0.091, 0.091-0.166, 0.166-0.289, + ! 0.289-0.493, 0.493-0.829, 0.829-1.383 and 1.383-2.296 m]. + ! The NINTH layer's soil parameters will assigned to the bottom soil layer (2.296 - 3.8019m). + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + DO nsl = 9, 2, -1 + vf_quartz (nsl,:) = vf_quartz (nsl-1,:) + vf_gravels (nsl,:) = vf_gravels(nsl-1,:) + vf_om (nsl,:) = vf_om (nsl-1,:) + vf_sand (nsl,:) = vf_sand (nsl-1,:) + vf_clay (nsl,:) = vf_clay (nsl-1,:) + wf_gravels (nsl,:) = wf_gravels(nsl-1,:) + wf_sand (nsl,:) = wf_sand (nsl-1,:) + wf_clay (nsl,:) = wf_clay (nsl-1,:) + wf_om (nsl,:) = wf_om (nsl-1,:) + OM_density (nsl,:) = OM_density(nsl-1,:) + BD_all (nsl,:) = BD_all (nsl-1,:) + wfc (nsl,:) = wfc (nsl-1,:) + porsl (nsl,:) = porsl (nsl-1,:) + psi0 (nsl,:) = psi0 (nsl-1,:) + bsw (nsl,:) = bsw (nsl-1,:) + theta_r (nsl,:) = theta_r (nsl-1,:) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm (nsl,:) = alpha_vgm (nsl-1,:) + L_vgm (nsl,:) = L_vgm (nsl-1,:) + n_vgm (nsl,:) = n_vgm (nsl-1,:) +#endif + hksati (nsl,:) = hksati (nsl-1,:) + csol (nsl,:) = csol (nsl-1,:) + k_solids (nsl,:) = k_solids (nsl-1,:) + dksatu (nsl,:) = dksatu (nsl-1,:) + dksatf (nsl,:) = dksatf (nsl-1,:) + dkdry (nsl,:) = dkdry (nsl-1,:) + BA_alpha (nsl,:) = BA_alpha (nsl-1,:) + BA_beta (nsl,:) = BA_beta (nsl-1,:) + ENDDO + + DO nsl = nl_soil, 10, -1 + vf_quartz (nsl,:) = vf_quartz (9,:) + vf_gravels (nsl,:) = vf_gravels(9,:) + vf_om (nsl,:) = vf_om (9,:) + vf_sand (nsl,:) = vf_sand (9,:) + vf_clay (nsl,:) = vf_clay (9,:) + wf_gravels (nsl,:) = wf_gravels(9,:) + wf_sand (nsl,:) = wf_sand (9,:) + wf_clay (nsl,:) = wf_clay (9,:) + wf_om (nsl,:) = wf_om (9,:) + OM_density (nsl,:) = OM_density(9,:) + BD_all (nsl,:) = BD_all (9,:) + wfc (nsl,:) = wfc (9,:) + porsl (nsl,:) = porsl (9,:) + psi0 (nsl,:) = psi0 (9,:) + bsw (nsl,:) = bsw (9,:) + theta_r (nsl,:) = theta_r (9,:) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm (nsl,:) = alpha_vgm (9,:) + L_vgm (nsl,:) = L_vgm (9,:) + n_vgm (nsl,:) = n_vgm (9,:) +#endif + hksati (nsl,:) = hksati (9,:) + csol (nsl,:) = csol (9,:) + k_solids (nsl,:) = k_solids (9,:) + dksatu (nsl,:) = dksatu (9,:) + dksatf (nsl,:) = dksatf (9,:) + dkdry (nsl,:) = dkdry (9,:) + BA_alpha (nsl,:) = BA_alpha (9,:) + BA_beta (nsl,:) = BA_beta (9,:) + ENDDO + + ENDIF + ENDIF + + ! Soil reflectance of broadband of visible(_v) and near-infrared(_n) of + ! the saturated(_s) and dry(_d) soil + ! SCHEME 1: Guessed soil color type according to land cover classes + IF (DEF_SOIL_REFL_SCHEME .eq. 1) THEN + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + m = landpatch%settyp(ipatch) + CALL soil_color_refl(m,soil_s_v_alb(ipatch),soil_d_v_alb(ipatch),& + soil_s_n_alb(ipatch),soil_d_n_alb(ipatch)) + ENDDO + ENDIF + ENDIF + + ! SCHEME 2: Read a global soil color map from CLM + IF (DEF_SOIL_REFL_SCHEME .eq. 2) THEN + +#ifdef SinglePoint + soil_s_v_alb(:) = SITE_soil_s_v_alb + soil_d_v_alb(:) = SITE_soil_d_v_alb + soil_s_n_alb(:) = SITE_soil_s_n_alb + soil_d_n_alb(:) = SITE_soil_d_n_alb +#else + ! (1) Read in the albedo of visible of the saturated soil + lndname = trim(landdir)//'/soil_s_v_alb_patches.nc' + CALL ncio_read_vector (lndname, 'soil_s_v_alb', landpatch, soil_s_v_alb) + + ! (2) Read in the albedo of visible of the dry soil + lndname = trim(landdir)//'/soil_d_v_alb_patches.nc' + CALL ncio_read_vector (lndname, 'soil_d_v_alb', landpatch, soil_d_v_alb) + + ! (3) Read in the albedo of near infrared of the saturated soil + lndname = trim(landdir)//'/soil_s_n_alb_patches.nc' + CALL ncio_read_vector (lndname, 'soil_s_n_alb', landpatch, soil_s_n_alb) + + ! (4) Read in the albedo of near infrared of the dry soil + lndname = trim(landdir)//'/soil_d_n_alb_patches.nc' + CALL ncio_read_vector (lndname, 'soil_d_n_alb', landpatch, soil_d_n_alb) +#endif + ENDIF ! end of DEF_SOIL_REFL_SCHEME +#ifdef HYPERSPECTRAL + ! Hyper spectral soil albedo + ! special treatment for the hyper spectral soil albedo + hyper_dir = trim(dir_landdata) // '/HyperAlbedo/' // trim(cyear) + + DO wl = 1, 211 + ! 计算波长编号并读取对应单波段文件 + wl_nm = 400 + 10 * (wl - 1) + write(wavelength,'(i0)') wl_nm + lndname = trim(hyper_dir)//'/soil_hyper_alb_'//trim(wavelength)//'nm_patches.nc' + CALL ncio_read_vector (lndname, 'soil_hyper_alb', landpatch, soil_hyper_alb_wl) + + ! 存储至波段矩阵 + soil_alb(wl, :) = soil_hyper_alb_wl(:) + ENDDO +#endif + END SUBROUTINE soil_parameters_readin + +END MODULE MOD_SoilParametersReadin +! -------------------------------------------------- +! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 new file mode 100644 index 0000000000..69f52071b7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 @@ -0,0 +1,54 @@ +#include + +MODULE MOD_SoilTextureReadin + + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: soiltext_readin + +CONTAINS + + SUBROUTINE soiltext_readin (dir_landdata, lc_year) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_UserDefFun + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_TimeInvariants, only: soiltext +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + character(len=256), intent(in) :: dir_landdata + integer, intent(in) :: lc_year ! which year of land cover data used + + ! Local Variables + character(len=256) :: lndname + character(len=4) :: cyear + integer :: ipatch + +#ifdef SinglePoint + soiltext(:) = SITE_soil_texture +#else + write(cyear,'(i4.4)') lc_year + lndname = trim(dir_landdata)// '/soil/' // trim(cyear) // '/soiltexture_patches.nc' + CALL ncio_read_vector (lndname, 'soiltext_patches', landpatch, soiltext) +#endif + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + WHERE (soiltext < 0 ) soiltext = 0 + WHERE (soiltext > 12) soiltext = 0 + ENDIF + ENDIF + + END SUBROUTINE soiltext_readin + +END MODULE MOD_SoilTextureReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 new file mode 100644 index 0000000000..173f2cf402 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 @@ -0,0 +1,132 @@ +#include + +#ifdef URBAN_MODEL +MODULE MOD_UrbanIniTimeVariable + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Initialize urban model time variables. +! +! Created by Hua Yuan, 09/16/2021 +! +! !REVISIONS: +! 05/2023, Wenzong Dong, Hua Yuan: porting codes to MPI parallel version. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanIniTimeVar + +CONTAINS + + SUBROUTINE UrbanIniTimeVar(ipatch,froof,fgper,flake,hlr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,htop,hbot,lai,sai,coszen,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,fwet_snow,& + sag_roof,sag_gimp,sag_gper,sag_lake,tlake,fwsun,dfwsun,& + extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Urban_Albedo + + IMPLICIT NONE + + integer, intent(in) :: & + ipatch ! patch index + + real(r8), intent(in) :: & + froof, &! roof fraction + fgper, &! impervious ground weight fraction + flake, &! lake fraction + hlr, &! average building height to their side length + hroof ! average building height + + real(r8), intent(in) :: & + alb_roof(2,2), &! roof albedo (iband,direct/diffuse) + alb_wall(2,2), &! wall albedo (iband,direct/diffuse) + alb_gimp(2,2), &! impervious albedo (iband,direct/diffuse) + alb_gper(2,2) ! pervious albedo (iband,direct/diffuse) + + real(r8), intent(in) :: & + fveg, &! fraction of vegetation cover + lai, &! leaf area index + sai, &! stem area index + htop, &! canopy crown top height + hbot, &! canopy crown bottom height + coszen, &! cosine of solar zenith angle + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), intent(out) :: & + fsno_roof, &! fraction of soil covered by snow [-] + fsno_gimp, &! fraction of soil covered by snow [-] + fsno_gper, &! fraction of soil covered by snow [-] + fsno_lake, &! fraction of soil covered by snow [-] + scv_roof, &! snow cover, water equivalent [mm] + scv_gimp, &! snow cover, water equivalent [mm] + scv_gper, &! snow cover, water equivalent [mm] + scv_lake, &! snow cover, water equivalent [mm] + sag_roof, &! non dimensional snow age [-] + sag_gimp, &! non dimensional snow age [-] + sag_gper, &! non dimensional snow age [-] + sag_lake, &! non dimensional snow age [-] + fwet_snow, &! vegetation snow fractional cover [-] + tlake ! lake temperature + + real(r8), intent(out) :: & + fwsun, &! sunlit wall fraction [-] + dfwsun, &! change of fwsun + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + alb (2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation + sroof(2,2), &! roof absorption for solar radiation, + swsun(2,2), &! sunlit wall absorption for solar radiation, + swsha(2,2), &! shaded wall absorption for solar radiation, + sgimp(2,2), &! impervious ground absorption for solar radiation, + sgper(2,2), &! pervious ground absorption for solar radiation, + slake(2,2) ! lake absorption for solar radiation, + + !----------------------------------------------------------------------- + real(r8) :: hveg ! height of crown central hight + + fsno_roof = 0. ! fraction of ground covered by snow + fsno_gimp = 0. ! fraction of ground covered by snow + fsno_gper = 0. ! fraction of ground covered by snow + fsno_lake = 0. ! fraction of soil covered by snow [-] + scv_roof = 0. ! snow cover, water equivalent [mm, kg/m2] + scv_gimp = 0. ! snow cover, water equivalent [mm, kg/m2] + scv_gper = 0. ! snow cover, water equivalent [mm, kg/m2] + scv_lake = 0. ! snow cover, water equivalent [mm] + sag_roof = 0. ! roof snow age [-] + sag_gimp = 0. ! impervious ground snow age [-] + sag_gper = 0. ! pervious ground snow age [-] + sag_lake = 0. ! urban lake snow age [-] + fwet_snow = 0. ! vegetation snow fractional cover [-] + + fwsun = 0.5 ! Fraction of sunlit wall [-] + dfwsun = 0. ! change of fwsun + + hveg = min(hroof, (htop+hbot)/2.) + + ! urban surface albedo + CALL alburban (ipatch,froof,fgper,flake,hlr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,hveg,lai,sai,fwet_snow,max(0.01,coszen),fwsun,tlake,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,& + sag_roof,sag_gimp,sag_gper,sag_lake,& + dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + + END SUBROUTINE UrbanIniTimeVar + +END MODULE MOD_UrbanIniTimeVariable +!----------------------------------------------------------------------- +! EOP +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 new file mode 100644 index 0000000000..2d960095fc --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 @@ -0,0 +1,321 @@ +#include + +#ifdef URBAN_MODEL + +MODULE MOD_UrbanReadin + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Urban dataset. +! +! Created by Hua Yuan, 11/26/2021 +! +! !REVISIONS: +! 05/2023, Wenzong Dong, Hua Yuan: porting codes to MPI parallel version. +! +! 08/2025, Wenzong Dong, Hua Yuan: unifying the urban surface data +! code for different urban type schemes. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Urban_readin + +CONTAINS + + SUBROUTINE Urban_readin (dir_landdata, lc_year) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global + USE MOD_Namelist + USE MOD_Const_LC + USE MOD_Vars_TimeVariables + USE MOD_Vars_TimeInvariants + USE MOD_Urban_Vars_TimeInvariants + USE MOD_NetCDFVector + USE MOD_NetCDFSerial + USE MOD_LandPatch + USE MOD_LandUrban + USE MOD_Urban_Const_LCZ +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year ! which year of land cover data used + character(len=256), intent(in) :: dir_landdata + character(len=256) :: dir_rawdata, dir_runtime + character(len=256) :: lndname + character(len=256) :: cyear + + integer :: i, u, m, l, lucy_id, ns, nr + + real(r8) :: thick_roof, thick_wall + + ! parameters for LUCY + integer , allocatable :: lucyid(:) ! LUCY region id + real(r8), allocatable :: popden(:) ! population density [person/km2] + + integer , allocatable :: lweek_holiday(:,:) ! week holidays + real(r8), allocatable :: lwdh_prof (:,:) ! Diurnal traffic flow profile [-] + real(r8), allocatable :: lweh_prof (:,:) ! Diurnal traffic flow profile [-] + real(r8), allocatable :: lhum_prof (:,:) ! Diurnal metabolic heat profile profile [W/person] + real(r8), allocatable :: lfix_holiday (:,:) ! Fixed public holidays, holiday(0) or workday(1) + real(r8), allocatable :: lvehicle (:,:) ! vehicle numbers per thousand people + + ! thickness of roof and wall + real(r8), allocatable :: thickroof(:) ! thickness of roof [m] + real(r8), allocatable :: thickwall(:) ! thickness of wall [m] + + write(cyear,'(i4.4)') lc_year + + allocate (lucyid (numurban)) + allocate (thickroof (numurban)) + allocate (thickwall (numurban)) + +#ifdef SinglePoint + froof (:) = SITE_froof + hroof (:) = SITE_hroof + hlr (:) = SITE_hlr + fgper (:) = SITE_fgper + + flake (:) = SITE_flake_urb + fveg_urb (:) = SITE_fveg_urb + htop_urb (:) = SITE_htop_urb + + em_roof (:) = SITE_em_roof + em_wall (:) = SITE_em_wall + em_gimp (:) = SITE_em_gimp + em_gper (:) = SITE_em_gper + + t_roommax (:) = SITE_t_roommax + t_roommin (:) = SITE_t_roommin + thickroof (:) = SITE_thickroof + thickwall (:) = SITE_thickwall + + alb_roof (:,:,1) = SITE_alb_roof + alb_wall (:,:,1) = SITE_alb_wall + alb_gimp (:,:,1) = SITE_alb_gimp + alb_gper (:,:,1) = SITE_alb_gper + + cv_roof (:,1) = SITE_cv_roof + cv_wall (:,1) = SITE_cv_wall + cv_gimp (:,1) = SITE_cv_gimp + tk_roof (:,1) = SITE_tk_roof + tk_wall (:,1) = SITE_tk_wall + tk_gimp (:,1) = SITE_tk_gimp + + lucyid (:) = SITE_lucyid + pop_den (:) = SITE_popden + +#else + ! READ in urban data + !----------------------------------- + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/WT_ROOF.nc' + CALL ncio_read_vector (lndname, 'WT_ROOF' , landurban, froof ) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/HT_ROOF.nc' + CALL ncio_read_vector (lndname, 'HT_ROOF' , landurban, hroof ) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/HLR_BLD.nc' + CALL ncio_read_vector (lndname, 'BUILDING_HLR' , landurban, hlr ) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/PCT_Tree.nc' + CALL ncio_read_vector (lndname, 'PCT_Tree' , landurban, fveg_urb) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/htop_urb.nc' + CALL ncio_read_vector (lndname, 'URBAN_TREE_TOP', landurban, htop_urb) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/PCT_Water.nc' + CALL ncio_read_vector (lndname, 'PCT_Water' , landurban, flake ) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LUCY_region_id.nc' + CALL ncio_read_vector (lndname, 'LUCY_id' , landurban, lucyid ) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/POP.nc' + CALL ncio_read_vector (lndname, 'POP_DEN' , landurban, pop_den ) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/urban.nc' + + ! pervious fraction to ground area + CALL ncio_read_vector (lndname, 'WTROAD_PERV' , landurban, fgper ) + + ! emissivity of roof + CALL ncio_read_vector (lndname, 'EM_ROOF' , landurban, em_roof) + ! emissivity of wall + CALL ncio_read_vector (lndname, 'EM_WALL' , landurban, em_wall) + ! emissivity of impervious road + CALL ncio_read_vector (lndname, 'EM_IMPROAD' , landurban, em_gimp) + ! emissivity of pervious road + CALL ncio_read_vector (lndname, 'EM_PERROAD' , landurban, em_gper) + + ! maximum temperature of inner room [K] + CALL ncio_read_vector (lndname, 'T_BUILDING_MAX', landurban, t_roommax) + ! minimum temperature of inner room [K] + CALL ncio_read_vector (lndname, 'T_BUILDING_MIN', landurban, t_roommin) + ! thickness of roof [m] + CALL ncio_read_vector (lndname, 'THICK_ROOF' , landurban, thickroof) + ! thickness of wall [m] + CALL ncio_read_vector (lndname, 'THICK_WALL' , landurban, thickwall) + + ! albedo of roof + CALL ncio_read_vector (lndname, 'ALB_ROOF' , 2, 2, landurban, alb_roof) + ! albedo of wall + CALL ncio_read_vector (lndname, 'ALB_WALL' , 2, 2, landurban, alb_wall) + ! albedo of impervious + CALL ncio_read_vector (lndname, 'ALB_IMPROAD' , 2, 2, landurban, alb_gimp) + ! albedo of pervious road + CALL ncio_read_vector (lndname, 'ALB_PERROAD' , 2, 2, landurban, alb_gper) + + ! heat capacity of roof [J/(m2 K)] + CALL ncio_read_vector (lndname, 'CV_ROOF' , nl_roof, landurban, cv_roof) + ! heat capacity of wall [J/(m2 K)] + CALL ncio_read_vector (lndname, 'CV_WALL' , nl_wall, landurban, cv_wall) + ! heat capacity of impervious road [J/(m2 K)] + CALL ncio_read_vector (lndname, 'CV_IMPROAD' , nl_soil, landurban, cv_gimp) + ! thermal conductivity of roof [W/m-K] + CALL ncio_read_vector (lndname, 'TK_ROOF' , nl_roof, landurban, tk_roof) + ! thermal conductivity of wall [W/m-K] + CALL ncio_read_vector (lndname, 'TK_WALL' , nl_wall, landurban, tk_wall) + ! thermal conductivity of impervious road [W/m-K] + CALL ncio_read_vector (lndname, 'TK_IMPROAD' , nl_soil, landurban, tk_gimp) + +#endif + + dir_runtime = DEF_dir_runtime + lndname = trim(dir_runtime)//'/urban/'//'/LUCY_rawdata.nc' + + CALL ncio_read_bcast_serial (lndname, "NUMS_VEHC" , lvehicle ) + CALL ncio_read_bcast_serial (lndname, "WEEKEND_DAY" , lweek_holiday) + CALL ncio_read_bcast_serial (lndname, "TraffProf_24hr_holiday", lweh_prof ) + CALL ncio_read_bcast_serial (lndname, "TraffProf_24hr_work" , lwdh_prof ) + CALL ncio_read_bcast_serial (lndname, "HumMetabolic_24hr" , lhum_prof ) + CALL ncio_read_bcast_serial (lndname, "FIXED_HOLIDAY" , lfix_holiday ) + + IF (p_is_worker) THEN + + DO u = 1, numurban + + i = urban2patch (u) + lucy_id = lucyid (u) + + IF (all(cv_gimp(:,u)==0)) THEN + fgper(u) = 1. + ENDIF + + IF (DEF_URBAN_WATER) THEN + flake(u) = flake(u)/100. !urban water fractional cover + ELSE + flake(u) = 0. + ENDIF + + IF (DEF_URBAN_TREE) THEN + ! set tree fractional cover (<= 1.-froof) + fveg_urb(u) = fveg_urb(u)/100. !urban tree percent + IF (flake(u) < 1.) THEN + fveg_urb(u) = fveg_urb(u)/(1.-flake(u)) + ELSE + fveg_urb(u) = 0. + ENDIF + + ! Assuming that the tree coverage is less than or equal + ! to the ground cover (assume no trees on the roof) + fveg_urb(u) = min(fveg_urb(u), 1.-froof(u)) + fveg (i) = fveg_urb(u) + ELSE + fveg_urb(u) = 0. + fveg (i) = fveg_urb(u) + ENDIF + + ! set urban tree crown top and bottom [m] + htop_urb(u) = min(hroof(u), htop_urb(u)) + htop_urb(u) = max(2., htop_urb(u)) + + hbot_urb(u) = htop_urb(u)*hbot0(URBAN)/htop0(URBAN) + hbot_urb(u) = max(1., hbot_urb(u)) + + htop (i) = htop_urb (u) + hbot (i) = hbot_urb (u) + + thick_roof = thickroof (u) !thickness of roof [m] + thick_wall = thickwall (u) !thickness of wall [m] + + ! roof and wall layer node depth + DO l=1, nl_roof + z_roof(l,u) = (l-0.5)*(thickroof(u)/nl_roof) + ENDDO + + DO l=1, nl_wall + z_wall(l,u) = (l-0.5)*(thickwall(u)/nl_wall) + ENDDO + + ! roof and wall layer depth + dz_roof(1,u) = 0.5*(z_roof(1,u)+z_roof(2,u)) + DO l = 2, nl_roof-1 + dz_roof(l,u) = 0.5*(z_roof(l+1,u)-z_roof(l-1,u)) + ENDDO + dz_roof(nl_roof,u) = z_roof(nl_roof,u)-z_roof(nl_roof-1,u) + + dz_wall(1,u) = 0.5*(z_wall(1,u)+z_wall(2,u)) + DO l = 2, nl_wall-1 + dz_wall(l,u) = 0.5*(z_wall(l+1,u)-z_wall(l-1,u)) + ENDDO + dz_wall(nl_wall,u) = z_wall(nl_wall,u)-z_wall(nl_wall-1,u) + + ! lake depth and layer depth + !NOTE: USE global lake depth right now, the below set to 1m + !lakedepth(npatch) = 1. + !dz_lake(:,npatch) = lakedepth(npatch) / nl_lake + + IF ( .not. DEF_URBAN_BEM) THEN + t_roommax(u) = 373.16 + t_roommin(u) = 180.00 + ENDIF + + IF (DEF_URBAN_LUCY) THEN + IF (lucy_id > 0) THEN + vehicle (:,u) = lvehicle (lucy_id,:) + week_holiday (:,u) = lweek_holiday (lucy_id,:) + weh_prof (:,u) = lweh_prof (lucy_id,:) + wdh_prof (:,u) = lwdh_prof (lucy_id,:) + hum_prof (:,u) = lhum_prof (lucy_id,:) + fix_holiday (:,u) = lfix_holiday (lucy_id,:) + ENDIF + ELSE + pop_den (u) = 0. + vehicle (:,u) = 0. + week_holiday (:,u) = 0. + weh_prof (:,u) = 0. + wdh_prof (:,u) = 0. + hum_prof (:,u) = 0. + fix_holiday (:,u) = 0. + ENDIF + + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (allocated(lvehicle )) deallocate ( lvehicle ) + IF (allocated(lwdh_prof )) deallocate ( lwdh_prof ) + IF (allocated(lweh_prof )) deallocate ( lweh_prof ) + IF (allocated(lhum_prof )) deallocate ( lhum_prof ) + IF (allocated(lweek_holiday )) deallocate ( lweek_holiday ) + IF (allocated(lfix_holiday )) deallocate ( lfix_holiday ) + IF (allocated(thickroof )) deallocate ( thickroof ) + IF (allocated(thickwall )) deallocate ( thickwall ) + IF (allocated(lucyid )) deallocate ( lucyid ) + ENDIF + + END SUBROUTINE Urban_readin + +END MODULE MOD_UrbanReadin + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 new file mode 100644 index 0000000000..fb20db1e19 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 @@ -0,0 +1,129 @@ +#include + +SUBROUTINE Aggregation_DBedrock ( & + gland, dir_rawdata, dir_model_landdata, lc_year) + +!----------------------------------------------------------------------- +! Depth to bedrock +! +! Shangguan, W., Hengl, T., Mendes de Jesus, J., Yuan, H., Dai, Y. (2017). +! Mapping the global depth to bedrock for land surface modeling. +! Journal of Advances in Modeling Earth Systems, 9(1), 65-88. +! +! Created by Shupeng Zhang, 05/2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_RangeCheck + USE MOD_AggregationRequestData + +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + character(len=256) :: landdir, lndname, cyear + + type (block_data_real8_2d) :: dbedrock + real(r8), allocatable :: dbedrock_patches(:) + real(r8), allocatable :: dbedrock_one(:), area_one(:) + integer :: ipatch + integer :: wmo_src + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/dbedrock/' //trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate depth to bedrock ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_io) THEN + + CALL allocate_block_data (gland, dbedrock) + + lndname = trim(dir_rawdata)//'/bedrock.nc' + CALL ncio_read_block (lndname, 'dbedrock', gland, dbedrock) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = dbedrock) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (dbedrock_patches (numpatch)) + + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + dbedrock_patches (ipatch) = dbedrock_patches (wmo_src) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = dbedrock, data_r8_2d_out1 = dbedrock_one) + dbedrock_patches (ipatch) = sum(dbedrock_one * area_one) / sum(area_one) + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('dbedrock_patches ', dbedrock_patches, -9999.0) +#endif + + ! Write-out the depth of the pacth in the gridcell + lndname = trim(landdir)//'/dbedrock_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'dbedrock_patches', 'patch', & + landpatch, dbedrock_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/dbedrock_patch_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (dbedrock_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'dbedrock', compress = 1, write_mode = 'one', create_mode=.true.) +#endif + + IF (p_is_worker) THEN + deallocate ( dbedrock_patches ) + ENDIF + +END SUBROUTINE Aggregation_DBedrock diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 new file mode 100644 index 0000000000..f8dc1ab7af --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 @@ -0,0 +1,332 @@ +#include + +SUBROUTINE Aggregation_ForestHeight ( & + gland, dir_rawdata, dir_model_landdata, lc_year) + +!----------------------------------------------------------------------- +! Global Forest Height +! (http://lidarradar.jpl.nasa.gov/) +! Simard, M., N. Pinto, J. B. Fisher, and A. Baccini, 2011: Mapping +! forest canopy height globally with spaceborne lidar. +! J. Geophys. Res., 116, G04021. +! +! Created by Yongjiu Dai, 02/2014 +! +! !REVISIONS: +! Hua Yuan, ?/2020 : for land cover land use classifications +! Shupeng Zhang, 01/2022: porting codes to MPI parallel version +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils + + USE MOD_Const_LC + USE MOD_5x5DataReadin +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif + +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + integer :: L, ipatch, p + integer :: wmo_src + + type (block_data_real8_2d) :: tree_height + real(r8), allocatable :: tree_height_patches(:), tree_height_one(:) + + ! for IGBP data + character(len=256) :: dir_5x5, suffix + type (block_data_real8_2d) :: htop + type (block_data_real8_3d) :: pftPCT + real(r8), allocatable :: htop_patches(:), htop_pfts(:), htop_pcs(:,:) + real(r8), allocatable :: htop_one(:), area_one(:), pct_one(:,:) + integer :: ip, ipft + real(r8) :: sumarea + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#ifndef CROP + integer :: typpft (N_PFT) +#else + integer :: typpft (N_PFT+N_CFT) +#endif + integer :: typpc (N_land_classification+1) +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/htop/' //trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate forest height ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef LULC_USGS + lndname = trim(dir_rawdata)//'/Forest_Height.nc' + + IF (p_is_io) THEN + CALL allocate_block_data (gland, tree_height) + CALL ncio_read_block (lndname, 'forest_height', gland, tree_height) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tree_height) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (tree_height_patches (numpatch)) + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF(L/=0 .and. L/=1 .and. L/=16 .and. L/=24)THEN + ! NOT OCEAN(0)/URBAN and BUILT-UP(1)/WATER BODIES(16)/ICE(24) + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = tree_height, data_r8_2d_out1 = tree_height_one) + tree_height_patches (ipatch) = median (tree_height_one, size(tree_height_one)) + ELSE + tree_height_patches (ipatch) = -1.0e36_r8 + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('htop_patches ', tree_height_patches) +#endif + + lndname = trim(landdir)//'/htop_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, tree_height_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (tree_height_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) +#endif + + IF (p_is_worker) THEN + deallocate ( tree_height_patches ) + ENDIF +#endif + + +#ifdef LULC_IGBP + IF (p_is_io) THEN + CALL allocate_block_data (gland, htop) + ENDIF + + IF (p_is_io) THEN + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(cyear) + CALL read_5x5_data (dir_5x5, suffix, gland, 'HTOP', htop) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = htop) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (htop_patches (numpatch)) + + DO ipatch = 1, numpatch + + IF (landpatch%settyp(ipatch) /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one) + htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('HTOP_patches ', htop_patches) +#endif + + lndname = trim(landdir)//'/htop_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, htop_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (htop_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) +#endif + + IF (p_is_worker) THEN + IF (allocated(htop_patches)) deallocate (htop_patches) + IF (allocated(htop_one )) deallocate (htop_one ) + IF (allocated(area_one )) deallocate (area_one ) + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (p_is_io) THEN + CALL allocate_block_data (gland, htop) + CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) + ENDIF + + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(cyear) + + IF (p_is_io) THEN + CALL read_5x5_data (dir_5x5, suffix, gland, 'HTOP', htop ) + CALL read_5x5_data_pft (dir_5x5, suffix, gland, 'PCT_PFT', pftPCT) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, & + data_r8_2d_in1 = htop, data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (htop_patches (numpatch)) + allocate (htop_pfts (numpft )) + + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + ! set patch htop + htop_patches(ipatch) = htop_patches(wmo_src) + + ! set pft htop at the same time + ip = patch_pft_s(ipatch) + htop_pfts(ip) = htop_patches(ipatch) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one, & + data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0) + + htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) + pct_one = max(pct_one , 0.0) + +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) + p = landpft%settyp(ip) + sumarea = sum(pct_one(p,:) * area_one) + IF (sumarea > 0) THEN + htop_pfts(ip) = sum(htop_one * pct_one(p,:) * area_one) / sumarea + ELSE + htop_pfts(ip) = htop_patches(ipatch) + ENDIF + ENDDO +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + ip = patch_pft_s(ipatch) + htop_pfts(ip) = htop_patches(ipatch) +#endif + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('HTOP_patches ', htop_patches) + CALL check_vector_data ('HTOP_pfts ', htop_pfts ) +#endif + + lndname = trim(landdir)//'/htop_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, htop_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (htop_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) +#endif + + lndname = trim(landdir)//'/htop_pfts.nc' + CALL ncio_create_file_vector (lndname, landpft) + CALL ncio_define_dimension_vector (lndname, landpft, 'pft') + CALL ncio_write_vector (lndname, 'htop_pfts', 'pft', landpft, htop_pfts, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag +#ifndef CROP + typpft = (/(ityp, ityp = 0, N_PFT-1)/) +#else + typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) +#endif + lndname = trim(dir_model_landdata) // '/diag/htop_pft_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (htop_pfts, landpft%settyp, typpft, m_pft2diag, & + -1.0e36_r8, lndname, 'htop_pft', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) +#endif + + IF (p_is_worker) THEN + IF (allocated(htop_patches)) deallocate (htop_patches) + IF (allocated(htop_pfts )) deallocate (htop_pfts ) + IF (allocated(htop_one )) deallocate (htop_one ) + IF (allocated(pct_one )) deallocate (pct_one ) + IF (allocated(area_one )) deallocate (area_one ) + ENDIF +#endif + +END SUBROUTINE Aggregation_ForestHeight diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 new file mode 100644 index 0000000000..cfc7679cfe --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 @@ -0,0 +1,759 @@ +#include + +SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! 1. Global Plant Leaf Area Index (http://globalchange.bnu.edu.cn) +! +! !REFERENCES: +! Yuan H., et al., 2011: +! Reprocessing the MODIS Leaf Area Index products for land surface +! and climate modelling. Remote Sensing of Environment, 115: 1171-1187. +! +! Lin, W., Yuan, H., Dong, W., Zhang, S., Liu, S., Wei, N., et al. +! (2023). Reprocessed MODIS version 6.1 leaf area index dataset and +! its evaluation for land surface and climate modeling. Remote +! Sensing, 15(7), 1780. https://doi.org/10.3390/rs15071780 +! +! Created by Yongjiu Dai, 02/2014 +! +! !REVISIONS: +! Hua Yuan, ?/2020 : for land cover land use classifications +! Shupeng Zhang, 01/2022: porting codes to MPI parallel version +! Hua Yuan, 05/2023: TODO +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_TimeManager + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFBlock + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + + USE MOD_AggregationRequestData + + USE MOD_Const_LC + USE MOD_5x5DataReadin +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gridlai + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! ---------------------------------------------------------------------- + character(len=256) :: landdir, lndname + + integer :: simulation_lai_year_start, simulation_lai_year_end + integer :: idate(3) + + type (block_data_real8_2d) :: LAI ! plant leaf area index (m2/m2) + real(r8), allocatable :: LAI_patches(:), lai_one(:), area_one(:) + integer :: itime, ntime, Julian_day, ipatch + character(len=4) :: c2, c3, cyear, cyear_bk + integer :: start_year, end_year, iy + + ! for IGBP data + character(len=256) :: dir_5x5, suffix + integer :: month + type (block_data_real8_2d) :: SAI ! plant stem area index (m2/m2) + real(r8), allocatable :: SAI_patches(:), sai_one(:) + + ! for PFT and PC + type (block_data_real8_3d) :: pftLSAI, pftPCT + real(r8), allocatable :: pct_one (:), pct_pft_one(:,:) + real(r8), allocatable :: LAI_pfts(:), lai_pft_one(:,:) + real(r8), allocatable :: SAI_pfts(:), sai_pft_one(:,:) + integer :: p, ip + integer :: wmo_src, ip_, p_ + real(r8) :: sumarea + logical :: first_call_LAI_patch, first_call_SAI_patch + logical :: first_call_LAI_pft, first_call_SAI_pft + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#ifndef CROP + integer :: typpft (N_PFT) +#else + integer :: typpft (N_PFT+N_CFT) +#endif + character(len=256) :: varname +#endif + + ! LAI data root directory->case/landdata/LAI + landdir = trim(dir_model_landdata) // '/LAI/' + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate LAI ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + idate(1) = DEF_simulation_time%start_year + IF (.not. isgreenwich) THEN + idate(3) = DEF_simulation_time%start_sec + CALL monthday2julian (idate(1), & + DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2)) + CALL localtime2gmt(idate) + ENDIF + + simulation_lai_year_start = idate(1) + + idate(1) = DEF_simulation_time%end_year + IF (.not. isgreenwich) THEN + idate(3) = DEF_simulation_time%end_sec + CALL monthday2julian (idate(1), & + DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2)) + CALL localtime2gmt(idate) + ENDIF + + simulation_lai_year_end = idate(1) + + first_call_LAI_patch = .true. + first_call_SAI_patch = .true. + first_call_LAI_pft = .true. + first_call_SAI_pft = .true. + +! ................................................ +! ... global plant leaf area index +! ................................................ + +#if (defined LULC_USGS || defined LULC_IGBP) + ! add time variation of LAI + IF (DEF_LAI_MONTHLY) THEN + ! monthly average LAI + ! if use lai change, LAI data of simulation start year and end year will be made + ! if do not use lai change, only make LAI data of defined lc year +#ifdef LULCC + ! 07/2023, NOTE: if defined LULCC, only one year (lc_year) lai processed. + start_year = lc_year + end_year = lc_year + ntime = 12 +#else + IF (DEF_LAI_CHANGE_YEARLY) THEN + start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) + start_year = min(start_year, DEF_LAI_END_YEAR ) + end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) + end_year = max(end_year, DEF_LAI_START_YEAR ) + ntime = 12 + ELSE + start_year = lc_year + end_year = lc_year + ntime = 12 + ENDIF +#endif + ! 8-day LAI + ELSE + start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR) + end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) + ntime = 46 + ENDIF + + ! ----- LAI ----- + IF (p_is_io) THEN + CALL allocate_block_data (gridlai, LAI) + ENDIF + + IF (p_is_worker) THEN + allocate (LAI_patches (numpatch)) + ENDIF + + + IF(.not. DEF_USE_LAIFEEDBACK)THEN + DO iy = start_year, end_year + + write(cyear,'(i4.4)') iy + CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) + + ! loop for month or 8-day + DO itime = 1, ntime + ! ----------------------- + ! read in leaf area index + ! ----------------------- + IF (DEF_LAI_MONTHLY) THEN + write(c3, '(i2.2)') itime + ELSE + Julian_day = 1 + (itime-1)*8 + write(c3, '(i3.3)') Julian_day + ENDIF + + IF (p_is_master) THEN + write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate LAI :', iy, ':', itime, '/', ntime + ENDIF + + IF (p_is_io) THEN + IF (DEF_LAI_MONTHLY) THEN + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + IF (iy < 2000) THEN + ! every 5 years one file + write(cyear_bk,'(i4.4)') (iy / 5) * 5 + suffix = 'MOD'//trim(cyear_bk) + CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_LC_LAI_'//trim(cyear), itime, LAI) + ELSE + suffix = 'MOD'//trim(cyear) + CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_LC_LAI', itime, LAI) + ENDIF + ELSE + lndname = trim(dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc' + CALL ncio_read_block_time (lndname, 'lai', gridlai, itime, LAI) + CALL block_data_linear_transform (LAI, scl = 0.1) + ENDIF + +#ifdef USEMPI + CALL aggregation_data_daemon (gridlai, data_r8_2d_in1 = LAI) +#endif + ENDIF + +! ------------------------------------------------------------------------------------------- +! aggregate the plant leaf area index from the resolution of raw data to modelling resolution +! ------------------------------------------------------------------------------------------- + + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + CALL aggregation_request_data (landpatch, ipatch, gridlai, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = LAI, data_r8_2d_out1 = lai_one) + LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('LAI value '//trim(c3), LAI_patches) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif +! --------------------------------------------------- +! write out the plant leaf area index of grid patches +! --------------------------------------------------- + IF (DEF_LAI_MONTHLY) THEN + lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' + ELSE + !TODO: rename filename of 8-day LAI + lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' + ENDIF + + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', & + landpatch, LAI_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' + IF (DEF_LAI_MONTHLY) THEN + varname = 'LAI' + ELSE + !TODO: rename file name of 8-day LAI + varname = 'LAI_8-day' + ENDIF + CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & + lastdimname = 'Itime', lastdimvalue = itime, create_mode=first_call_LAI_patch) + IF ( first_call_LAI_patch ) first_call_LAI_patch = .false. +#endif + ENDDO + first_call_LAI_patch = .true. + ENDDO + ENDIF + + ! ----- SAI ----- + IF (DEF_LAI_MONTHLY) THEN + + IF (p_is_io) THEN + CALL allocate_block_data (gridlai, SAI) + ENDIF + + IF (p_is_worker) THEN + allocate (SAI_patches (numpatch)) + ENDIF + + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + DO iy = start_year, end_year + write(cyear,'(i4.4)') iy + IF (iy < 2000) THEN + write(cyear_bk,'(i4.4)') (iy / 5) * 5 + suffix = 'MOD'//trim(cyear_bk) + ELSE + suffix = 'MOD'//trim(cyear) + ENDIF + + DO itime = 1, 12 + write(c3, '(i2.2)') itime + + IF (p_is_master) THEN + write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate SAI :', iy, ':', itime, '/', ntime + ENDIF + + IF (p_is_io) THEN + IF (iy < 2000) THEN + CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_LC_SAI_'//trim(cyear), itime, SAI) + ELSE + CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_LC_SAI', itime, SAI) + ENDIF + +#ifdef USEMPI + CALL aggregation_data_daemon (gridlai, data_r8_2d_in1 = SAI) +#endif + ENDIF + +! ------------------------------------------------------------------------------------------- +! aggregate the plant stem area index from the resolution of raw data to modelling resolution +! ------------------------------------------------------------------------------------------- + + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + + CALL aggregation_request_data (landpatch, ipatch, gridlai, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = SAI, data_r8_2d_out1 = sai_one) + SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('SAI value '//trim(c3), SAI_patches) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif +! --------------------------------------------------- +! write out the plant leaf area index of grid patches +! --------------------------------------------------- + lndname = trim(landdir) // trim(cyear) // '/SAI_patches' // trim(c3) // '.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'SAI_patches', 'patch', landpatch, SAI_patches, & + DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/SAI_patch_'// trim(cyear) // '.nc' + IF (DEF_LAI_MONTHLY) THEN + varname = 'SAI' + ELSE + !TODO: rename varname + varname = 'SAI_8-day' + ENDIF + CALL srfdata_map_and_write (SAI_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & + lastdimname = 'Itime', lastdimvalue = itime, create_mode=first_call_SAI_patch) + IF ( first_call_SAI_patch ) first_call_SAI_patch = .false. + +#endif + ENDDO + first_call_SAI_patch = .true. + ENDDO + ENDIF +#endif + +! For both PFT and PC run LAI!!!!! +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ! add time variation of LAI + ! monthly average LAI + ! if use lai change, LAI data of simulation start year and end year will be made + ! if not use lai change, only make LAI data of defined lc year +#ifdef LULCC + ! 07/2023, NOTE: if defined LULCC, only one year (lc_year) lai processed. + start_year = lc_year + end_year = lc_year + ntime = 12 +#else + IF (DEF_LAI_CHANGE_YEARLY) THEN + start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) + start_year = min(start_year, DEF_LAI_END_YEAR ) + end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) + end_year = max(end_year, DEF_LAI_START_YEAR ) + ntime = 12 + ELSE + start_year = lc_year + end_year = lc_year + ntime = 12 + ENDIF +#endif + + IF (p_is_io) THEN + CALL allocate_block_data (gridlai, pftLSAI, N_PFT_modis, lb1 = 0) + CALL allocate_block_data (gridlai, pftPCT, N_PFT_modis, lb1 = 0) + ENDIF + + IF (p_is_worker) THEN + allocate(LAI_patches (numpatch)) + allocate(LAI_pfts (numpft )) + allocate(SAI_patches (numpatch)) + allocate(SAI_pfts (numpft )) + ENDIF + + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + DO iy = start_year, end_year + write(cyear,'(i4.4)') iy + CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) + + IF (iy < 2000) THEN + write(cyear_bk,'(i4.4)') (iy / 5) * 5 + suffix = 'MOD'//trim(cyear_bk) + ELSE + suffix = 'MOD'//trim(cyear) + ENDIF + + IF (p_is_master) THEN + write(*,'(A,I4)') 'Aggregate LAI : ', iy + ENDIF + + IF (p_is_io) THEN + CALL read_5x5_data_pft (dir_5x5, suffix, gridlai, 'PCT_PFT', pftPCT) + ENDIF + + IF(.not. DEF_USE_LAIFEEDBACK)THEN + DO month = 1, 12 + IF (p_is_io) THEN + IF (iy < 2000) THEN + CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_PFT_LAI_'//trim(cyear), month, pftLSAI) + ELSE + CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_PFT_LAI', month, pftLSAI) + ENDIF +#ifdef USEMPI + CALL aggregation_data_daemon (gridlai, & + data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & + data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) +#endif + ENDIF + +! ------------------------------------------------------------------------------------------- +! aggregate the plant leaf area index from the resolution of raw data to modelling resolution +! ------------------------------------------------------------------------------------------- + + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + ip = patch_pft_s(ipatch) + p = landpft%settyp(ip) + + IF (p>=12 .and. p<=14) THEN + DO ip_ = patch_pft_s(wmo_src), patch_pft_e(wmo_src) + p_ = landpft%settyp(ip_) + IF (p_ == p) LAI_pfts(ip) = LAI_pfts(ip_) + ENDDO + ELSE + LAI_pfts(ip) = 0. + ENDIF + + LAI_patches(ipatch) = LAI_pfts(ip) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gridlai, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, & + n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & + data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = lai_pft_one, & + n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) + + IF (allocated(lai_one)) deallocate(lai_one) + allocate(lai_one(size(area_one))) + + IF (allocated(pct_one)) deallocate(pct_one) + allocate(pct_one(size(area_one))) + + pct_pft_one = max(pct_pft_one , 0.0) + pct_one = sum(pct_pft_one,dim=1) + pct_one = max(pct_one, 1.0e-6) + + lai_one = sum(lai_pft_one * pct_pft_one, dim=1) / pct_one + LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) + +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 & + .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) + p = landpft%settyp(ip) + sumarea = sum(pct_pft_one(p,:) * area_one) + IF (sumarea > 0) THEN + LAI_pfts(ip) = sum(lai_pft_one(p,:) * pct_pft_one(p,:) * area_one) & + / sumarea + ELSE + ! 07/2023, yuan: bug may exist below + !LAI_pfts(ip) = LAI_patches(ipatch) + LAI_pfts(ip) = 0. + ENDIF + ENDDO +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + ip = patch_pft_s(ipatch) + LAI_pfts(ip) = LAI_patches(ipatch) +#endif + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + write(c2,'(i2.2)') month +#ifdef RangeCheck + CALL check_vector_data ('LAI_patches ' // trim(c2), LAI_patches) + CALL check_vector_data ('LAI_pfts ' // trim(c2), LAI_pfts ) +#endif +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +! --------------------------------------------------- +! write out the plant leaf area index of grid patches +! --------------------------------------------------- + lndname = trim(landdir)//trim(cyear)//'/LAI_patches'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', & + landpatch, LAI_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' + varname = 'LAI' + CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & + lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_LAI_patch) + IF ( first_call_LAI_patch ) first_call_LAI_patch = .false. +#endif + + lndname = trim(landdir)//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpft) + CALL ncio_define_dimension_vector (lndname, landpft, 'pft') + CALL ncio_write_vector (lndname, 'LAI_pfts', 'pft', & + landpft, LAI_pfts, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag +#ifndef CROP + typpft = (/(ityp, ityp = 0, N_PFT-1)/) +#else + typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) +#endif + lndname = trim(dir_model_landdata) // '/diag/LAI_pft_'// trim(cyear) // '.nc' + varname = 'LAI_pft' + CALL srfdata_map_and_write (LAI_pfts, landpft%settyp, typpft, m_pft2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & + lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_LAI_pft) + IF ( first_call_LAI_pft ) first_call_LAI_pft = .false. +#endif + ! loop end of month + ENDDO + + ENDIF + + DO month = 1, 12 + IF (p_is_io) THEN + IF (iy < 2000) THEN + CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_PFT_SAI_'//trim(cyear), month, pftLSAI) + ELSE + CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & + 'MONTHLY_PFT_SAI', month, pftLSAI) + ENDIF +#ifdef USEMPI + CALL aggregation_data_daemon (gridlai, & + data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & + data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) +#endif + ENDIF + +! ------------------------------------------------------------------------------------------- +! aggregate the plant leaf area index from the resolution of raw data to modelling resolution +! ------------------------------------------------------------------------------------------- + + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + ip = patch_pft_s(ipatch) + p = landpft%settyp(ip) + + IF (p>=12 .and. p<=14) THEN + DO ip_ = patch_pft_s(wmo_src), patch_pft_e(wmo_src) + p_ = landpft%settyp(ip_) + IF (p_ == p) SAI_pfts(ip) = SAI_pfts(ip_) + ENDDO + ELSE + SAI_pfts (ip) = 0. + ENDIF + + SAI_patches(ipatch) = SAI_pfts(ip) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gridlai, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, & + n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & + data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = sai_pft_one, & + n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) + + IF (allocated(sai_one)) deallocate(sai_one) + allocate(sai_one(size(area_one))) + + IF (allocated(pct_one)) deallocate(pct_one) + allocate(pct_one(size(area_one))) + + pct_pft_one = max(pct_pft_one , 0.0) + pct_one = sum(pct_pft_one,dim=1) + pct_one = max(pct_one, 1.0e-6) + + sai_one = sum(sai_pft_one * pct_pft_one, dim=1) / pct_one + SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) + +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 & + .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) + p = landpft%settyp(ip) + sumarea = sum(pct_pft_one(p,:) * area_one) + IF (sumarea > 0) THEN + SAI_pfts(ip) = sum(sai_pft_one(p,:) * pct_pft_one(p,:) * area_one) & + / sumarea + ELSE + ! 07/2023, yuan: bug may exist below + !SAI_pfts(ip) = SAI_patches(ipatch) + SAI_pfts(ip) = 0. + ENDIF + ENDDO +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + ip = patch_pft_s(ipatch) + SAI_pfts(ip) = SAI_patches(ipatch) +#endif + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + write(c2,'(i2.2)') month +#ifdef RangeCheck + CALL check_vector_data ('SAI_patches ' // trim(c2), SAI_patches) + CALL check_vector_data ('SAI_pfts ' // trim(c2), SAI_pfts ) +#endif +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +! --------------------------------------------------- +! write out the plant stem area index of grid patches +! --------------------------------------------------- + lndname = trim(landdir)//trim(cyear)//'/SAI_patches'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'SAI_patches', 'patch', & + landpatch, SAI_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/SAI_patch_'// trim(cyear) // '.nc' + varname = 'SAI' + CALL srfdata_map_and_write (SAI_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & + lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_SAI_patch) + IF ( first_call_SAI_patch ) first_call_SAI_patch = .false. +#endif + + lndname = trim(landdir)//trim(cyear)//'/SAI_pfts'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpft) + CALL ncio_define_dimension_vector (lndname, landpft, 'pft') + CALL ncio_write_vector (lndname, 'SAI_pfts', 'pft', & + landpft, SAI_pfts, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag +#ifndef CROP + typpft = (/(ityp, ityp = 0, N_PFT-1)/) +#else + typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) +#endif + lndname = trim(dir_model_landdata) // '/diag/SAI_pft_'// trim(cyear) // '.nc' + varname = 'SAI_pft' + CALL srfdata_map_and_write (SAI_pfts, landpft%settyp, typpft, m_pft2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & + lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_SAI_pft) + IF ( first_call_SAI_pft ) first_call_SAI_pft = .false. +#endif + ! loop end of month + ENDDO + + ! new year, new data file + first_call_LAI_patch = .true. + first_call_SAI_patch = .true. + first_call_LAI_pft = .true. + first_call_SAI_pft = .true. + + ! loop end of year + ENDDO + + IF (p_is_worker) THEN + + IF (allocated(LAI_patches)) deallocate(LAI_patches) + IF (allocated(LAI_pfts )) deallocate(LAI_pfts ) + IF (allocated(lai_one )) deallocate(lai_one ) + + IF (allocated(SAI_patches)) deallocate(SAI_patches) + IF (allocated(SAI_pfts )) deallocate(SAI_pfts ) + IF (allocated(sai_one )) deallocate(sai_one ) + IF (allocated(pct_one )) deallocate(pct_one ) + IF (allocated(pct_pft_one)) deallocate(pct_pft_one) + IF (allocated(area_one )) deallocate(area_one ) + + ENDIF +#endif + +END SUBROUTINE Aggregation_LAI diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 new file mode 100644 index 0000000000..7f2b991614 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 @@ -0,0 +1,145 @@ +#include + +SUBROUTINE Aggregation_LakeDepth ( & + gland, dir_rawdata, dir_model_landdata, lc_year) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Aggregate lake depth of multiple pixels within a lake patch based on +! Global land cover types (updated with the specific dataset) +! +! Global Lake Coverage and Lake Depth (1km resolution) +! (http://nwpi.krc.karelia.run/flake/) +! Lake depth data legend +! Value Description +! 0 no lake indicated in this pixel +! 1 no any information about this lake and set the default value of 10 m +! 2 no information about depth for this lake and set the default value of 10 m +! 3 have the information about lake depth in this pixel +! 4 this is the river pixel according to our map, set the default value of 3 m +! +! !REFERENCES: +! Kourzeneva, E., H. Asensio, E. Martin, and S. Faroux, 2012: Global gridded +! dataset of lake coverage and lake depth for USE in numerical weather +! prediction and climate modelling. Tellus A, 64, 15640. +! +! Created by Yongjiu Dai, 02/2014 +! +! !REVISIONS: +! Shupeng Zhang, 01/2022: porting codes to MPI parallel version +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + ! arguments: + + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + integer :: L, ipatch + + type (block_data_real8_2d) :: lakedepth + real(r8), allocatable :: lakedepth_patches(:), lakedepth_one(:) +#ifdef SrfdataDiag + integer :: typlake(1) = (/17/) +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/lakedepth/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate lake depth ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +! ................................................ +! global lake coverage and lake depth +! ................................................ + lndname = trim(dir_rawdata)//'/lake_depth.nc' + + IF (p_is_io) THEN + CALL allocate_block_data (gland, lakedepth) + CALL ncio_read_block (lndname, 'lake_depth', gland, lakedepth) + CALL block_data_linear_transform (lakedepth, scl = 0.1) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = lakedepth) +#endif + ENDIF + +! ---------------------------------------------------------------------------------- +! aggregate the lake depth from the resolution of raw data to modelling resolution +! ---------------------------------------------------------------------------------- + + IF (p_is_worker) THEN + + allocate (lakedepth_patches (numpatch)) + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + IF(L==WATERBODY)THEN ! LAND WATER BODIES (17) + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = lakedepth, data_r8_2d_out1 = lakedepth_one) + lakedepth_patches (ipatch) = median (lakedepth_one, size(lakedepth_one)) + ELSE + lakedepth_patches (ipatch) = -1.0e36_r8 + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('lakedepth_patches ', lakedepth_patches) +#endif + + lndname = trim(landdir)//'/lakedepth_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'lakedepth_patches', 'patch', & + landpatch, lakedepth_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + lndname = trim(dir_model_landdata)//'/diag/lakedepth_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (lakedepth_patches, landpatch%settyp, typlake, m_patch2diag, & + -1.0e36_r8, lndname, 'lakedepth', compress = 1, write_mode = 'one', create_mode=.true.) +#endif + + IF (p_is_worker) THEN + deallocate ( lakedepth_patches ) + ENDIF + +END SUBROUTINE Aggregation_LakeDepth diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 new file mode 100644 index 0000000000..9245af9bbd --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 @@ -0,0 +1,218 @@ +#include + +SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, lc_year) + +!----------------------------------------------------------------------- +! Percentage of Plant Function Types +! +! Original from Hua Yuan's OpenMP version. +! +! !REVISIONS: +! Hua Yuan, ?/2020 : for land cover land use classifications +! Shupeng Zhang, 01/2022: porting codes to MPI parallel version +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO +#ifdef CROP + USE MOD_LandCrop +#endif + USE MOD_NetCDFBlock + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + + USE MOD_Const_LC + USE MOD_5x5DataReadin + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! ---------------------------------------------------------------------- + character(len=256) :: landdir, lndname + + ! for IGBP data + character(len=256) :: dir_5x5, suffix, cyear + ! for PFT + type (block_data_real8_3d) :: pftPCT + real(r8), allocatable :: pct_one(:), area_one(:) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + real(r8), allocatable :: pct_pft_one(:,:) + real(r8), allocatable :: pct_pfts(:) +#endif + integer :: ipatch, ipc, ipft, p + integer :: wmo_pth + real(r8) :: sumarea, sum_pct_pfts +#ifdef SrfdataDiag + integer :: typpft(0:N_PFT-1) +#ifdef CROP + integer :: typcrop(N_CFT), ityp +#endif +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/pctpft/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A43)') 'Aggregate plant function type fractions ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + ! add parameter input for time year + !write(cyear,'(i4.4)') lc_year + suffix = 'MOD'//trim(cyear) + + IF (p_is_io) THEN + CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) + CALL read_5x5_data_pft (dir_5x5, suffix, gland, 'PCT_PFT', pftPCT) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = N_PFT_modis) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate(pct_pfts (numpft)) + pct_pfts(:) = 0. + + DO ipatch = 1, numpatch + + wmo_pth = wmo_patch(landpatch%ielm(ipatch)) + IF (ipatch == wmo_pth) THEN + ipft = patch_pft_s(ipatch) + + pct_pfts(ipft) = 1. + + CYCLE + ENDIF + +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 & + .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, & + n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) + +#ifdef CROP + pct_pft_one(N_PFT_modis-1,:) = 0. +#endif + + pct_pft_one = max(pct_pft_one , 0.0) + pct_one = sum(pct_pft_one, dim=1) + pct_one = max(pct_one, 1.0e-6) + sumarea = sum(area_one) + + DO ipft = patch_pft_s(ipatch), patch_pft_e(ipatch) + p = landpft%settyp(ipft) + pct_pfts(ipft) = sum(pct_pft_one(p,:) / pct_one * area_one) / sumarea + ENDDO + + sum_pct_pfts = sum(pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch))) + + IF (sum_pct_pfts > 0) THEN + pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) = & + pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) / sum_pct_pfts + ELSE + ! in case of no PFT exist, but there is a patch type: + ! set bare soil 100%, be consistent with MOD_LandPFT.F90 + pct_pfts(patch_pft_s(ipatch)) = 1. + ENDIF + +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) = 1. +#endif + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + +#ifdef RangeCheck + CALL check_vector_data ('PCT_PFTs ', pct_pfts) +#endif + + lndname = trim(landdir)//'/pct_pfts.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpft, 'pft') + CALL ncio_write_vector (lndname, 'pct_pfts', 'pft', & + landpft, pct_pfts, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpft = (/(ipft, ipft = 0, N_PFT-1)/) + lndname = trim(dir_model_landdata)//'/diag/pftfrac_elm_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (pct_pfts, landpft%settyp, typpft, m_pft2diag, & + -1.0e36_r8, lndname, 'pftfrac_elm', compress = 1, write_mode = 'one', & + defval=0._r8, stat_mode = 'fraction', pctshared = landpft%pctshared, & + create_mode=.true.) +#endif + + IF (p_is_worker) THEN + IF (allocated(pct_pfts )) deallocate(pct_pfts ) + IF (allocated(pct_one )) deallocate(pct_one ) + IF (allocated(area_one )) deallocate(area_one ) + IF (allocated(pct_pft_one)) deallocate(pct_pft_one) + ENDIF + +#if (defined CROP) + lndname = trim(landdir)//'/pct_crops.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'pct_crops', 'patch', & + landpatch, cropfrac, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typcrop = (/(ityp, ityp = 1, N_CFT)/) + lndname = trim(dir_model_landdata) // '/diag/cropfrac_elm_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (cropfrac, cropclass, typcrop, m_patch2diag, & + -1.0e36_r8, lndname, 'cropfrac_elm', compress = 1, write_mode = 'one', & + defval=0._r8, stat_mode = 'fraction', pctshared = landpatch%pctshared, & + create_mode=.true.) +#endif +#endif + +#endif + +END SUBROUTINE Aggregation_PercentagesPFT diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 new file mode 100644 index 0000000000..1c6286cbd4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 @@ -0,0 +1,409 @@ +#include + +SUBROUTINE Aggregation_SoilBrightness ( & + gland, dir_rawdata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! Creates land model surface dataset from original "raw" data files - +! data with 30 arc seconds resolution +! +! Created by Yongjiu Dai, 03/2014 +! +! !REVISIONS: +! Shupeng Zhang, 01/2022: porting codes to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFBlock + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + USE MOD_Vars_Global, only: spval + + IMPLICIT NONE + + ! arguments: + + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + + type (block_data_int32_2d) :: isc + type (block_data_real8_2d) :: a_s_v_refl + type (block_data_real8_2d) :: a_d_v_refl + type (block_data_real8_2d) :: a_s_n_refl + type (block_data_real8_2d) :: a_d_n_refl + + real(r8), allocatable :: soil_s_v_alb (:) + real(r8), allocatable :: soil_d_v_alb (:) + real(r8), allocatable :: soil_s_n_alb (:) + real(r8), allocatable :: soil_d_n_alb (:) + + integer :: ii, L + integer :: ipatch, iblkme, iblk, jblk, ix, iy + integer :: wmo_src + real(r8), allocatable :: soil_one(:) + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#endif + + ! ---------------------------------------------------------------------- + ! The soil color and reflectance is from the work: + ! Peter J. Lawrence and Thomas N. Chase, 2007: + ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0): + ! Part 1 generating MODIS consistent land surface parameters + real(r8) soil_s_v_refl(20) ! Saturated visible soil reflectance + real(r8) soil_d_v_refl(20) ! Dry visible soil reflectance + real(r8) soil_s_n_refl(20) ! Saturated near infrared soil reflectance + real(r8) soil_d_n_refl(20) ! Dry near infrared soil reflectance + + soil_s_v_refl = (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, & + 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /) + + soil_d_v_refl = (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, & + 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /) + + soil_s_n_refl = (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, & + 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /) + + soil_d_n_refl = (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, & + 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /) + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A29)') 'Aggregate Soil Brightness ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +! ------------------------------------------------------------------------------------- +! aggregate the soil parameters from the resolution of raw data to modelling resolution +! ------------------------------------------------------------------------------------- + + lndname = trim(dir_rawdata)//'/soil_brightness.nc' + + IF (p_is_io) THEN + + CALL allocate_block_data (gland, isc) + CALL allocate_block_data (gland, a_s_v_refl) + CALL allocate_block_data (gland, a_d_v_refl) + CALL allocate_block_data (gland, a_s_n_refl) + CALL allocate_block_data (gland, a_d_n_refl) + + ! Read in the index of soil brightness (color) + CALL ncio_read_block (lndname, 'soil_brightness', gland, isc) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + DO iy = 1, gland%ycnt(jblk) + DO ix = 1, gland%xcnt(iblk) + + ii = isc%blk(iblk,jblk)%val(ix,iy) + IF ((ii >= 1) .and. (ii <= 20)) THEN + a_s_v_refl%blk(iblk,jblk)%val(ix,iy) = soil_s_v_refl( ii ) + a_d_v_refl%blk(iblk,jblk)%val(ix,iy) = soil_d_v_refl( ii ) + a_s_n_refl%blk(iblk,jblk)%val(ix,iy) = soil_s_n_refl( ii ) + a_d_n_refl%blk(iblk,jblk)%val(ix,iy) = soil_d_n_refl( ii ) + ELSE + a_s_v_refl%blk(iblk,jblk)%val(ix,iy) = spval + a_d_v_refl%blk(iblk,jblk)%val(ix,iy) = spval + a_s_n_refl%blk(iblk,jblk)%val(ix,iy) = spval + a_d_n_refl%blk(iblk,jblk)%val(ix,iy) = spval + ENDIF + + ENDDO + ENDDO + + ENDDO + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_io) THEN + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_s_v_refl) + ENDIF +#endif + + IF (p_is_worker) THEN + + allocate ( soil_s_v_alb (numpatch) ) + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + soil_s_v_alb(ipatch) = soil_s_v_alb(wmo_src) + + CYCLE + ENDIF + +#ifdef LULC_USGS + IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = a_s_v_refl, data_r8_2d_out1 = soil_one) + soil_s_v_alb (ipatch) = median (soil_one, size(soil_one), spval) + + ELSE + soil_s_v_alb (ipatch) = spval + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_io) THEN + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_d_v_refl) + ENDIF +#endif + + IF (p_is_worker) THEN + + allocate ( soil_d_v_alb (numpatch) ) + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + soil_d_v_alb(ipatch) = soil_d_v_alb(wmo_src) + + CYCLE + ENDIF + +#ifdef LULC_USGS + IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = a_d_v_refl, data_r8_2d_out1 = soil_one) + soil_d_v_alb (ipatch) = median (soil_one, size(soil_one), spval) + + ELSE + soil_d_v_alb (ipatch) = spval + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_io) THEN + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_s_n_refl) + ENDIF +#endif + + IF (p_is_worker) THEN + + allocate ( soil_s_n_alb (numpatch) ) + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + soil_s_n_alb(ipatch) = soil_s_n_alb(wmo_src) + + CYCLE + ENDIF + +#ifdef LULC_USGS + IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = a_s_n_refl, data_r8_2d_out1 = soil_one) + soil_s_n_alb (ipatch) = median (soil_one, size(soil_one), spval) + + ELSE + soil_s_n_alb (ipatch) = spval + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_io) THEN + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_d_n_refl) + ENDIF +#endif + + IF (p_is_worker) THEN + + allocate ( soil_d_n_alb (numpatch) ) + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + soil_d_n_alb(ipatch) = soil_d_n_alb(wmo_src) + + CYCLE + ENDIF + +#ifdef LULC_USGS + IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = a_d_n_refl, data_r8_2d_out1 = soil_one) + soil_d_n_alb (ipatch) = median (soil_one, size(soil_one), spval) + + ELSE + soil_d_n_alb (ipatch) = spval + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('s_v_alb ', soil_s_v_alb) + CALL check_vector_data ('d_v_alb ', soil_d_v_alb) + CALL check_vector_data ('s_n_alb ', soil_s_n_alb) + CALL check_vector_data ('d_n_alb ', soil_d_n_alb) +#endif + + ! (1) Write-out the albedo of visible of the saturated soil + lndname = trim(landdir)//'/soil_s_v_alb_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'soil_s_v_alb', 'patch', & + landpatch, soil_s_v_alb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (soil_s_v_alb, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'soil_s_v_alb', compress = 1, write_mode = 'one', create_mode=.true.) +#endif + + ! (2) Write-out the albedo of visible of the dry soil + lndname = trim(landdir)//'/soil_d_v_alb_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'soil_d_v_alb', 'patch', & + landpatch, soil_d_v_alb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (soil_d_v_alb, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'soil_d_v_alb', compress = 1, write_mode = 'one') +#endif + + ! (3) Write-out the albedo of near infrared of the saturated soil + lndname = trim(landdir)//'/soil_s_n_alb_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'soil_s_n_alb', 'patch', & + landpatch, soil_s_n_alb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (soil_s_n_alb, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'soil_s_n_alb', compress = 1, write_mode = 'one') +#endif + + ! (4) Write-out the albedo of near infrared of the dry soil + lndname = trim(landdir)//'/soil_d_n_alb_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'soil_d_n_alb', 'patch', & + landpatch, soil_d_n_alb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (soil_d_n_alb, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'soil_d_n_alb', compress = 1, write_mode = 'one') +#endif + + ! Deallocate the allocatable array + ! -------------------------------- + IF (p_is_worker) THEN + deallocate ( soil_s_v_alb ) + deallocate ( soil_d_v_alb ) + deallocate ( soil_s_n_alb ) + deallocate ( soil_d_n_alb ) + ENDIF + +END SUBROUTINE Aggregation_SoilBrightness +!----------------------------------------------------------------------- +!EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 new file mode 100644 index 0000000000..b7e0c1966a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 @@ -0,0 +1,166 @@ +#include + +SUBROUTINE Aggregation_SoilHyperAlbedo ( & + gland, dir_rawdata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! Creates land model surface dataset from original "raw" data files - +! data with 30 arc seconds resolution +! +! Created by Yongjiu Dai, 03/2014 +! +! !REVISIONS: +! Shupeng Zhang, 01/2022: porting codes to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_LandPatch + USE MOD_NetCDFBlock + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + character(len=4) :: wavelength ! wavelength in nm + + ! type (block_data_real8_2d) :: a_s_v_refl + type (block_data_real8_2d) :: a_soil_hyper_alb + + ! real(r8), allocatable :: soil_s_v_alb (:) + real(r8), allocatable :: soil_hyper_alb (:) + + integer :: ii, L + integer :: ipatch, iblkme, iblk, jblk, ix, iy, wl + real(r8), allocatable :: soil_one(:) + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/HyperAlbedo/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A29)') 'Aggregate Hyper Albedo ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ! 为 worker 在循环外分配一次，避免每次循环重复分配引发错误 + IF (p_is_worker) THEN + IF (.NOT. ALLOCATED(soil_hyper_alb)) ALLOCATE(soil_hyper_alb(numpatch)) + ENDIF + + DO wl = 400, 2500, 10 + IF (p_is_master) write(*,'(A, i0, A)') ' Processing wavelength (nm): ', wl, ' ...' + write(wavelength,'(i0)') wl + + ! Read in the hyper albedo + IF (p_is_io) THEN + + CALL allocate_block_data (gland, a_soil_hyper_alb) + lndname = trim(dir_rawdata)//'/colm_input_ghsad/colm_soil_albedo_'//trim(wavelength)//'nm.nc' + ! Read in the soil albedo + CALL ncio_read_block (lndname, 'albedo', gland, a_soil_hyper_alb) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + DO iy = 1, gland%ycnt(jblk) + DO ix = 1, gland%xcnt(iblk) + a_soil_hyper_alb%blk(iblk,jblk)%val(ix,iy) = a_soil_hyper_alb%blk(iblk,jblk)%val(ix,iy) / 10000.0 + END DO + END DO + END DO + + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_soil_hyper_alb) +#endif + + ENDIF + + IF (p_is_worker) THEN + + ! allocate 已在循环外完成，移除这里的重复分配 + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) +#ifdef LULC_USGS + IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = a_soil_hyper_alb, data_r8_2d_out1 = soil_one) + soil_hyper_alb (ipatch) = median (soil_one, size(soil_one)) + + ELSE + soil_hyper_alb (ipatch) = -1.0e36_r8 + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF ! IF (p_is_worker) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('soil_hyper_alb ', soil_hyper_alb) +#endif + + ! Write-out the hyper spectral soil albedo + lndname = trim(landdir)//'/soil_hyper_alb_'//trim(wavelength)//'nm_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'soil_hyper_alb', 'patch', & + landpatch, soil_hyper_alb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_hyper_alb_' // trim(wavelength) // 'nm_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (soil_hyper_alb, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'soil_hyper_alb', compress = 1, write_mode = 'one') +#endif + + END DO ! loop over "wl" + + ! Deallocate the allocatable array + ! -------------------------------- + IF (p_is_worker) THEN + deallocate ( soil_hyper_alb ) + ENDIF + +END SUBROUTINE Aggregation_SoilHyperAlbedo +!----------------------------------------------------------------------- +!EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 new file mode 100644 index 0000000000..2c30ba0244 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 @@ -0,0 +1,2042 @@ +#include + +SUBROUTINE Aggregation_SoilParameters ( & + gland, dir_rawdata, dir_model_landdata, lc_year) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Create soil hydraulic and thermal parameters for the modeling reolustion +! +! !REFERENCES: +! 1) Dai, Y., Q. Xin, N. Wei, Y. Zhang, W. Shangguan, H. Yuan, S. Zhang, S. +! Liu, X. Lu, 2019. A global high-resolution dataset of soil hydraulic and +! thermal properties for land surface modeling. Journal of Advances in +! Modeling Earth Systems,11, 2996-3023. +! +! 2) Dai, Y., N. Wei, H. Yuan, S. Zhang, W. Shangguan, S. Liu, and X. Lu, 2019. +! Evaluation of soil thermal conductivity schemes for use in land surface +! modelling, Journal of Advances in Modeling Earth Systems, 11, 3454-3473. +! +! 3) Dai, Y., W. Shangguan, Q. Duan, B. Liu, S. Fu, and G. Niu, 2013. +! Development of a China dataset of soil hydraulic parameters using +! pedotransfer functions for land surface modeling. Journal of +! Hydrometeorology 14, 869-887 +! +! Original author: Yongjiu Dai and Wei Shangguan, 02/2014 +! +! !REVISIONS: +! 06/2019, Nan Wei: add algorithms of fitting soil water retention curves to +! aggregate soil hydraulic parameters from pixels to a patch. +! +! 01/2022, Shupeng Zhang and Nan Wei: porting codes to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFBlock + USE MOD_NetCDFVector + USE MOD_AggregationRequestData +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_Utils + USE MOD_UserDefFun +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + character(len=256) :: c + integer :: nsl, ipatch, L, np, LL, ipxstt, ipxend + integer :: wmo_src + + type (block_data_real8_2d) :: vf_quartz_mineral_s_grid + type (block_data_real8_2d) :: vf_gravels_s_grid + type (block_data_real8_2d) :: vf_om_s_grid + type (block_data_real8_2d) :: vf_sand_s_grid + type (block_data_real8_2d) :: vf_clay_s_grid + type (block_data_real8_2d) :: wf_gravels_s_grid + type (block_data_real8_2d) :: wf_sand_s_grid + type (block_data_real8_2d) :: wf_om_s_grid + type (block_data_real8_2d) :: wf_clay_s_grid + type (block_data_real8_2d) :: OM_density_s_grid + type (block_data_real8_2d) :: BD_all_s_grid + type (block_data_real8_2d) :: theta_s_grid + type (block_data_real8_2d) :: psi_s_grid + type (block_data_real8_2d) :: lambda_grid +#ifdef vanGenuchten_Mualem_SOIL_MODEL + type (block_data_real8_2d) :: theta_r_grid + type (block_data_real8_2d) :: alpha_vgm_grid + type (block_data_real8_2d) :: L_vgm_grid + type (block_data_real8_2d) :: n_vgm_grid +#endif + type (block_data_real8_2d) :: k_s_grid + type (block_data_real8_2d) :: csol_grid + type (block_data_real8_2d) :: tksatu_grid + type (block_data_real8_2d) :: tksatf_grid + type (block_data_real8_2d) :: tkdry_grid + type (block_data_real8_2d) :: k_solids_grid + + real(r8), allocatable :: vf_quartz_mineral_s_patches (:) + real(r8), allocatable :: vf_gravels_s_patches (:) + real(r8), allocatable :: vf_om_s_patches (:) + real(r8), allocatable :: vf_sand_s_patches (:) + real(r8), allocatable :: vf_clay_s_patches (:) + real(r8), allocatable :: wf_gravels_s_patches (:) + real(r8), allocatable :: wf_sand_s_patches (:) + real(r8), allocatable :: wf_om_s_patches (:) + real(r8), allocatable :: wf_clay_s_patches (:) + real(r8), allocatable :: OM_density_s_patches (:) + real(r8), allocatable :: BD_all_s_patches (:) + real(r8), allocatable :: theta_s_patches (:) + real(r8), allocatable :: psi_s_patches (:) + real(r8), allocatable :: lambda_patches (:) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), allocatable :: theta_r_patches (:) + real(r8), allocatable :: alpha_vgm_patches (:) + real(r8), allocatable :: L_vgm_patches (:) + real(r8), allocatable :: n_vgm_patches (:) +#endif + real(r8), allocatable :: k_s_patches (:) + real(r8), allocatable :: csol_patches (:) + real(r8), allocatable :: tksatu_patches (:) + real(r8), allocatable :: tksatf_patches (:) + real(r8), allocatable :: tkdry_patches (:) + real(r8), allocatable :: k_solids_patches (:) + real(r8), allocatable :: BA_alpha_patches (:) + real(r8), allocatable :: BA_beta_patches (:) + + real(r8), allocatable :: vf_quartz_mineral_s_one (:) + real(r8), allocatable :: vf_gravels_s_one (:) + real(r8), allocatable :: vf_om_s_one (:) + real(r8), allocatable :: vf_sand_s_one (:) + real(r8), allocatable :: vf_clay_s_one (:) + real(r8), allocatable :: wf_gravels_s_one (:) + real(r8), allocatable :: wf_sand_s_one (:) + real(r8), allocatable :: wf_om_s_one (:) + real(r8), allocatable :: wf_clay_s_one (:) + real(r8), allocatable :: OM_density_s_one (:) + real(r8), allocatable :: BD_all_s_one (:) + real(r8), allocatable :: theta_s_one (:) + real(r8), allocatable :: psi_s_one (:) + real(r8), allocatable :: lambda_one (:) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), allocatable :: theta_r_one (:) + real(r8), allocatable :: alpha_vgm_one (:) + real(r8), allocatable :: L_vgm_one (:) + real(r8), allocatable :: n_vgm_one (:) +#endif + real(r8), allocatable :: k_s_one (:) + real(r8), allocatable :: csol_one (:) + real(r8), allocatable :: tksatu_one (:) + real(r8), allocatable :: tksatf_one (:) + real(r8), allocatable :: tkdry_one (:) + real(r8), allocatable :: k_solids_one (:) + real(r8), allocatable :: area_one (:) + real(r8), allocatable :: BA_alpha_one (:) + real(r8), allocatable :: BA_beta_one (:) + +! local variables for estimating the upscaled soil parameters using the Levenberg-Marquardt fitting method +! --------------------------------------------------------------- + integer, parameter :: npointw = 24 + integer, parameter :: npointb = 20 + real(r8),parameter :: xdat(npointw) = (/1.,5.,10.,20.,30.,40.,50.,60.,70.,90.,110.,130.,150.,& + 170.,210.,300.,345.,690.,1020.,5100.,15300.,20000.,100000.,1000000./) + ! points of soil pressure heads used for fitting SW retention curves + + real(r8),parameter :: xdatsr(npointb)=(/0.05,0.1,0.15,0.2,0.25,0.3,0.35,0.4,0.45,0.5,0.55,0.6,& + 0.65,0.7,0.75,0.8,0.85,0.9,0.95,1.0/) + ! points of soil saturation levels (Sr) used for fitting Ke-Sr relationship + + real(r8),allocatable :: ydatc (:,:) ! the Campbell SW retentions at fine grids + real(r8),allocatable :: ydatcks(:,:) ! the Campbell SW hydraulic conductivity at fine grids + real(r8),allocatable :: ydatv (:,:) ! the van Genuchten & Mualem SW retentions at fine grids + real(r8),allocatable :: ydatvks(:,:) ! the van Genuchten & Mualem SW hydraulic conductivity at fine grids + real(r8),allocatable :: THETA (:) ! the van Genuchten & Mualem relative SW at fine grids + real(r8),allocatable :: ydatb(:,:) ! the Balland and Arp (2005) Ke-Sr relationship at fine grids + + integer, parameter :: nc = 3 ! the number of fitted parameters in Campbell SW retention curve (psi and lambda) + integer, parameter :: nv = 4 ! the number of fitted parameters in van Genuchten SW retention curve + ! (theta_r, alpha and n) + integer, parameter :: nb = 2 ! the number of fitted parameters in Ke-Sr relationship (alpha and beta) + +! Variables needed for Levenberg-Marquardt algorithm in MINPACK library + real(r8),parameter :: factor = 0.1 + real(r8),parameter :: ftol = 1.0e-5 + real(r8),parameter :: xtol = 1.0e-4 + real(r8),parameter :: gtol = 0.0 + integer, parameter :: mode = 1 + integer, parameter :: nprint = 0 + integer :: ldfjac,info,ipvtc(nc),ipvtv(nv),ipvtb(nb),maxfev,nfev,njev + real(r8) :: xc(nc),xv(nv),xb(nb),diagc(nc),diagv(nv),diagb(nb),qtfc(nc),qtfv(nv),qtfb(nb) + real(r8),allocatable :: fjacc(:,:),fvecc(:),fjacv(:,:),fvecv(:),fjacb(:,:),fvecb(:) + integer isiter ! flags to tell whether the iteration is completed, 1=Yes, 0=No + + ! Parameters to fill water body patches + real(r8), parameter :: vf_quartz_mineral_fill_water(8) = 0.1 + real(r8), parameter :: vf_gravels_fill_water(8) = 0.0 + real(r8), parameter :: vf_sand_fill_water(8) = 0.09 + real(r8), parameter :: vf_clay_fill_water(8) = 0.189 + real(r8), parameter :: vf_om_fill_water(8) = 0.102 + real(r8), parameter :: wf_gravels_fill_water(8) = 0.0 + real(r8), parameter :: wf_sand_fill_water(8) = 0.1 + real(r8), parameter :: wf_om_fill_water(8) = 0.1 + real(r8), parameter :: wf_clay_fill_water(8) = 0.2 + real(r8), parameter :: theta_r_fill_water(8) = 0.116 + real(r8), parameter :: alpha_vgm_fill_water(8) = 0.01 + real(r8), parameter :: n_vgm_fill_water(8) = 1.352 + real(r8), parameter :: theta_s_fill_water(8) = 0.532 + real(r8), parameter :: k_s_fill_water(8) = 11.616 + real(r8), parameter :: L_vgm_fill_water(8) = 0.5 + real(r8), parameter :: psi_s_fill_water(8) = -35.446 + real(r8), parameter :: lambda_fill_water(8) = 0.108 + real(r8), parameter :: csol_fill_water(8) = 1.102e6 + real(r8), parameter :: tksatu_fill_water(8) = 1.145 + real(r8), parameter :: tksatf_fill_water(8) = 2.401 + real(r8), parameter :: tkdry_fill_water(8) = 0.136 + real(r8), parameter :: k_solids_fill_water(8) = 1.545 + real(r8), parameter :: OM_density_fill_water(8) = 62.064 + real(r8), parameter :: BD_all_fill_water(8) = 1200 + real(r8), parameter :: BA_alpha_fill_water(8) = 0.2 + real(r8), parameter :: BA_beta_fill_water (8) = 10 + + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#endif + + external SW_CB_dist ! the objective function to be fitted for Campbell SW retention curve + external SW_VG_dist ! the objective function to be fitted for van Genuchten SW retention curve +! external Ke_Sr_dist ! the objective function to be fitted for Balland and Arp (2005) Ke-Sr relationship + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) + +! --------------------------------------------------------------------------------------------- +! ... [2] aggregate the soil parameters from the resolution of raw data to modelling resolution +! --------------------------------------------------------------------------------------------- +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A29)') 'Aggregate Soil Parameters ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + + allocate ( vf_quartz_mineral_s_patches(numpatch) ) + allocate ( vf_gravels_s_patches (numpatch) ) + allocate ( vf_om_s_patches (numpatch) ) + allocate ( vf_sand_s_patches (numpatch) ) + allocate ( vf_clay_s_patches (numpatch) ) + allocate ( wf_gravels_s_patches (numpatch) ) + allocate ( wf_sand_s_patches (numpatch) ) + allocate ( wf_om_s_patches (numpatch) ) + allocate ( wf_clay_s_patches (numpatch) ) + allocate ( OM_density_s_patches (numpatch) ) + allocate ( BD_all_s_patches (numpatch) ) + allocate ( theta_s_patches (numpatch) ) + allocate ( psi_s_patches (numpatch) ) + allocate ( lambda_patches (numpatch) ) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + allocate ( theta_r_patches (numpatch) ) + allocate ( alpha_vgm_patches (numpatch) ) + allocate ( L_vgm_patches (numpatch) ) + allocate ( n_vgm_patches (numpatch) ) +#endif + allocate ( k_s_patches (numpatch) ) + allocate ( csol_patches (numpatch) ) + allocate ( tksatu_patches (numpatch) ) + allocate ( tksatf_patches (numpatch) ) + allocate ( tkdry_patches (numpatch) ) + allocate ( k_solids_patches (numpatch) ) + allocate ( BA_alpha_patches (numpatch) ) + allocate ( BA_beta_patches (numpatch) ) + + ENDIF + + DO nsl = 1, 8 + + write(c,'(i1)') nsl + + ! (1) volumetric fraction of quartz within mineral soil + IF (p_is_io) THEN + + CALL allocate_block_data (gland, vf_quartz_mineral_s_grid) + lndname = trim(dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' + CALL ncio_read_block (lndname, 'vf_quartz_mineral_s_l'//trim(c), gland, vf_quartz_mineral_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_quartz_mineral_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + vf_quartz_mineral_s_patches (ipatch) = vf_quartz_mineral_s_patches (wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = vf_quartz_mineral_s_grid, data_r8_2d_out1 = vf_quartz_mineral_s_one) + CALL fillnan (vf_quartz_mineral_s_one, L == WATERBODY, vf_quartz_mineral_fill_water(nsl)) + CALL fillnan (vf_quartz_mineral_s_one, L == GLACIERS , vf_quartz_mineral_fill_water(nsl)) + vf_quartz_mineral_s_patches (ipatch) = sum (vf_quartz_mineral_s_one * (area_one/sum(area_one))) + ELSE + vf_quartz_mineral_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(vf_quartz_mineral_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in vf_quartz_mineral_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('vf_quartz_mineral_s lev '//trim(c), vf_quartz_mineral_s_patches) +#endif + + lndname = trim(landdir)//'/vf_quartz_mineral_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'vf_quartz_mineral_s_l'//trim(c)//'_patches', 'patch',& + landpatch, vf_quartz_mineral_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (vf_quartz_mineral_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'vf_quartz_mineral_s_l'//trim(c), compress = 1, write_mode = 'one', & + create_mode = (nsl==1)) +#endif + + ! (2) volumetric fraction of gravels + ! (3) volumetric fraction of sand + ! (4) volumetric fraction of organic matter + ! with the parameter alpha and beta in the Balland V. and P. A. Arp (2005) model + IF (p_is_io) THEN + + CALL allocate_block_data (gland, vf_gravels_s_grid) + lndname = trim(dir_rawdata)//'/soil/vf_gravels_s.nc' + CALL ncio_read_block (lndname, 'vf_gravels_s_l'//trim(c), gland, vf_gravels_s_grid) + + CALL allocate_block_data (gland, vf_sand_s_grid) + lndname = trim(dir_rawdata)//'/soil/vf_sand_s.nc' + CALL ncio_read_block (lndname, 'vf_sand_s_l'//trim(c), gland, vf_sand_s_grid) + + CALL allocate_block_data (gland, vf_om_s_grid) + lndname = trim(dir_rawdata)//'/soil/vf_om_s.nc' + CALL ncio_read_block (lndname, 'vf_om_s_l'//trim(c), gland, vf_om_s_grid) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_gravels_s_grid, & + data_r8_2d_in2 = vf_sand_s_grid, data_r8_2d_in3 = vf_om_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + vf_gravels_s_patches (ipatch) = vf_gravels_s_patches (wmo_src) + vf_sand_s_patches (ipatch) = vf_sand_s_patches (wmo_src) + vf_om_s_patches (ipatch) = vf_om_s_patches (wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = vf_gravels_s_grid, data_r8_2d_out1 = vf_gravels_s_one, & + data_r8_2d_in2 = vf_sand_s_grid, data_r8_2d_out2 = vf_sand_s_one, & + data_r8_2d_in3 = vf_om_s_grid, data_r8_2d_out3 = vf_om_s_one) + + CALL fillnan (vf_gravels_s_one, L == WATERBODY, vf_gravels_fill_water(nsl)) + CALL fillnan (vf_sand_s_one , L == WATERBODY, vf_sand_fill_water(nsl) ) + CALL fillnan (vf_om_s_one , L == WATERBODY, vf_om_fill_water(nsl) ) + + CALL fillnan (vf_gravels_s_one, L == GLACIERS , vf_gravels_fill_water(nsl)) + CALL fillnan (vf_sand_s_one , L == GLACIERS , vf_sand_fill_water(nsl) ) + CALL fillnan (vf_om_s_one , L == GLACIERS , vf_om_fill_water(nsl) ) + + vf_gravels_s_patches (ipatch) = sum (vf_gravels_s_one * (area_one/sum(area_one))) + vf_sand_s_patches (ipatch) = sum (vf_sand_s_one * (area_one/sum(area_one))) + vf_om_s_patches (ipatch) = sum (vf_om_s_one * (area_one/sum(area_one))) + + ! the parameter values of Balland and Arp (2005) Ke-Sr relationship, + ! modified by Barry-Macaulay et al.(2015), Evaluation of soil thermal conductivity models + + allocate(BA_alpha_one (size(area_one))) + allocate(BA_beta_one (size(area_one))) + WHERE ((vf_gravels_s_one + vf_sand_s_one) > 0.4) + BA_alpha_one = 0.38 + BA_beta_one = 35.0 + ELSEWHERE ((vf_gravels_s_one + vf_sand_s_one) > 0.25) + BA_alpha_one = 0.24 + BA_beta_one = 26.0 + ELSEWHERE + BA_alpha_one = 0.2 + BA_beta_one = 10.0 + END WHERE + + BA_alpha_patches (ipatch) = median (BA_alpha_one, size(BA_alpha_one), spval) + BA_beta_patches (ipatch) = median (BA_beta_one, size(BA_beta_one), spval) + + deallocate(BA_alpha_one) + deallocate(BA_beta_one) + + ELSE + vf_gravels_s_patches (ipatch) = -1.0e36_r8 + vf_sand_s_patches (ipatch) = -1.0e36_r8 + vf_om_s_patches (ipatch) = -1.0e36_r8 + BA_alpha_patches (ipatch) = -1.0e36_r8 + BA_beta_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(vf_gravels_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in vf_gravels_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(vf_sand_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in vf_sand_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(vf_om_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in vf_om_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(BA_alpha_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in BA_alpha_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(BA_beta_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in BA_beta_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('vf_gravels_s lev '//trim(c), vf_gravels_s_patches) + CALL check_vector_data ('vf_sand_s lev '//trim(c), vf_sand_s_patches) + CALL check_vector_data ('vf_om_s lev '//trim(c), vf_om_s_patches) + CALL check_vector_data ('BA_alpha lev '//trim(c), BA_alpha_patches) + CALL check_vector_data ('BA_beta lev '//trim(c), BA_beta_patches) +#endif + + lndname = trim(landdir)//'/vf_gravels_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'vf_gravels_s_l'//trim(c)//'_patches', 'patch',& + landpatch, vf_gravels_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (vf_gravels_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'vf_gravels_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/vf_sand_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'vf_sand_s_l'//trim(c)//'_patches', 'patch',& + landpatch, vf_sand_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (vf_sand_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'vf_sand_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/vf_om_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'vf_om_s_l'//trim(c)//'_patches', 'patch',& + landpatch, vf_om_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (vf_om_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'vf_om_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/BA_alpha_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'BA_alpha_l'//trim(c)//'_patches', 'patch',& + landpatch, BA_alpha_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (BA_alpha_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'BA_alpha_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/BA_beta_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'BA_beta_l'//trim(c)//'_patches', 'patch',& + landpatch, BA_beta_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (BA_beta_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'BA_beta_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (5) gravimetric fraction of gravels + IF (p_is_io) THEN + + CALL allocate_block_data (gland, wf_gravels_s_grid) + lndname = trim(dir_rawdata)//'/soil/wf_gravels_s.nc' + CALL ncio_read_block (lndname, 'wf_gravels_s_l'//trim(c), gland, wf_gravels_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_gravels_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + wf_gravels_s_patches (ipatch) = wf_gravels_s_patches (wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = wf_gravels_s_grid, data_r8_2d_out1 = wf_gravels_s_one) + CALL fillnan (wf_gravels_s_one, L == WATERBODY, wf_gravels_fill_water(nsl)) + CALL fillnan (wf_gravels_s_one, L == GLACIERS , wf_gravels_fill_water(nsl)) + wf_gravels_s_patches (ipatch) = sum (wf_gravels_s_one * (area_one/sum(area_one))) + ELSE + wf_gravels_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(wf_gravels_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in wf_gravels_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('wf_gravels_s lev '//trim(c), wf_gravels_s_patches) +#endif + + lndname = trim(landdir)//'/wf_gravels_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'wf_gravels_s_l'//trim(c)//'_patches', 'patch',& + landpatch, wf_gravels_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (wf_gravels_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'wf_gravels_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (6) gravimetric fraction of sand + IF (p_is_io) THEN + + CALL allocate_block_data (gland, wf_sand_s_grid) + lndname = trim(dir_rawdata)//'/soil/wf_sand_s.nc' + CALL ncio_read_block (lndname, 'wf_sand_s_l'//trim(c), gland, wf_sand_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_sand_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + wf_sand_s_patches (ipatch) = wf_sand_s_patches (wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = wf_sand_s_grid, data_r8_2d_out1 = wf_sand_s_one) + CALL fillnan (wf_sand_s_one, L == WATERBODY, wf_sand_fill_water(nsl)) + CALL fillnan (wf_sand_s_one, L == GLACIERS , wf_sand_fill_water(nsl)) + wf_sand_s_patches (ipatch) = sum (wf_sand_s_one * (area_one/sum(area_one))) + ELSE + wf_sand_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(wf_sand_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in wf_sand_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('wf_sand_s lev '//trim(c), wf_sand_s_patches) +#endif + + lndname = trim(landdir)//'/wf_sand_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'wf_sand_s_l'//trim(c)//'_patches', 'patch',& + landpatch, wf_sand_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (wf_sand_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'wf_sand_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + + ! (7) VGM's pore-connectivity parameter (L) + ! (8) VGM's residual water content (theta_r) [cm3/cm3] + ! (9) VGM's parameter corresponding approximately to the inverse of the air-entry value (alpha) + ! (10) VGM's shape parameter (n) + ! (11) saturated water content [cm3/cm3] + ! (12) saturated hydraulic conductivity [cm/day] + + IF (p_is_io) THEN + + CALL allocate_block_data (gland, L_vgm_grid) + lndname = trim(dir_rawdata)//'/soil/VGM_L.nc' + CALL ncio_read_block (lndname, 'VGM_L_l'//trim(c), gland, L_vgm_grid) + + CALL allocate_block_data (gland, theta_r_grid) + lndname = trim(dir_rawdata)//'/soil/VGM_theta_r.nc' + CALL ncio_read_block (lndname, 'VGM_theta_r_l'//trim(c), gland, theta_r_grid) + + CALL allocate_block_data (gland, alpha_vgm_grid) + lndname = trim(dir_rawdata)//'/soil/VGM_alpha.nc' + CALL ncio_read_block (lndname, 'VGM_alpha_l'//trim(c), gland, alpha_vgm_grid) + + CALL allocate_block_data (gland, n_vgm_grid) + lndname = trim(dir_rawdata)//'/soil/VGM_n.nc' + CALL ncio_read_block (lndname, 'VGM_n_l'//trim(c), gland, n_vgm_grid) + + CALL allocate_block_data (gland, theta_s_grid) + lndname = trim(dir_rawdata)//'/soil/theta_s.nc' + CALL ncio_read_block (lndname, 'theta_s_l'//trim(c), gland, theta_s_grid) + + CALL allocate_block_data (gland, k_s_grid) + lndname = trim(dir_rawdata)//'/soil/k_s.nc' + CALL ncio_read_block (lndname, 'k_s_l'//trim(c), gland, k_s_grid) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, & + data_r8_2d_in1 = theta_r_grid, data_r8_2d_in2 = alpha_vgm_grid, & + data_r8_2d_in3 = n_vgm_grid, data_r8_2d_in4 = theta_s_grid, & + data_r8_2d_in5 = k_s_grid, data_r8_2d_in6 = L_vgm_grid ) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + theta_r_patches (ipatch) = theta_r_patches (wmo_src) + alpha_vgm_patches (ipatch) = alpha_vgm_patches (wmo_src) + n_vgm_patches (ipatch) = n_vgm_patches (wmo_src) + theta_s_patches (ipatch) = theta_s_patches (wmo_src) + k_s_patches (ipatch) = k_s_patches (wmo_src) + L_vgm_patches (ipatch) = L_vgm_patches (wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = theta_r_grid, data_r8_2d_out1 = theta_r_one, & + data_r8_2d_in2 = alpha_vgm_grid, data_r8_2d_out2 = alpha_vgm_one, & + data_r8_2d_in3 = n_vgm_grid, data_r8_2d_out3 = n_vgm_one, & + data_r8_2d_in4 = theta_s_grid, data_r8_2d_out4 = theta_s_one, & + data_r8_2d_in5 = k_s_grid, data_r8_2d_out5 = k_s_one, & + data_r8_2d_in6 = L_vgm_grid, data_r8_2d_out6 = L_vgm_one ) + + CALL fillnan (theta_r_one , L == WATERBODY, theta_r_fill_water(nsl) ) + CALL fillnan (alpha_vgm_one, L == WATERBODY, alpha_vgm_fill_water(nsl)) + CALL fillnan (n_vgm_one , L == WATERBODY, n_vgm_fill_water(nsl) ) + CALL fillnan (theta_s_one , L == WATERBODY, theta_s_fill_water(nsl) ) + CALL fillnan (k_s_one , L == WATERBODY, k_s_fill_water(nsl) ) + CALL fillnan (L_vgm_one , L == WATERBODY, L_vgm_fill_water(nsl) ) + + CALL fillnan (theta_r_one , L == GLACIERS , theta_r_fill_water(nsl) ) + CALL fillnan (alpha_vgm_one, L == GLACIERS , alpha_vgm_fill_water(nsl)) + CALL fillnan (n_vgm_one , L == GLACIERS , n_vgm_fill_water(nsl) ) + CALL fillnan (theta_s_one , L == GLACIERS , theta_s_fill_water(nsl) ) + CALL fillnan (k_s_one , L == GLACIERS , k_s_fill_water(nsl) ) + CALL fillnan (L_vgm_one , L == GLACIERS , L_vgm_fill_water(nsl) ) + + theta_r_patches (ipatch) = sum (theta_r_one * (area_one/sum(area_one))) + alpha_vgm_patches (ipatch) = median (alpha_vgm_one, size(alpha_vgm_one), spval) + n_vgm_patches (ipatch) = median (n_vgm_one, size(n_vgm_one), spval) + theta_s_patches (ipatch) = sum (theta_s_one * (area_one/sum(area_one))) + k_s_patches (ipatch) = product(k_s_one**(area_one/sum(area_one))) + L_vgm_patches (ipatch) = median (L_vgm_one, size(L_vgm_one), spval) + + IF (DEF_USE_SOILPAR_UPS_FIT) THEN + np = size(theta_r_one) + + IF( np > 1 ) THEN + allocate ( ydatv (1:np,npointw) ) + allocate ( ydatvks(1:np,npointw) ) + allocate ( THETA ( npointw) ) +! the jacobian matrix required in Levenberg-Marquardt fitting method + allocate ( fjacv (npointw,nv) ) ! calculated in SW_VG_dist +! the values of objective functions to be fitted + allocate ( fvecv (npointw) ) ! calculated in SW_VG_dist + +! SW VG retentions and hydraulic conductivity at fine grids for each patch + DO LL = 1,np + THETA = (1 + (alpha_vgm_one(LL)*xdat)**n_vgm_one(LL))**(1.0/n_vgm_one(LL)-1) + ydatv(LL,:) = theta_r_one(LL)+(theta_s_one(LL) - theta_r_one(LL)) * THETA + ydatvks(LL,:) = k_s_one(LL) * THETA**L_vgm_one(LL) & + * (1-(1-THETA**(n_vgm_one(LL)/(n_vgm_one(LL)-1)))**(1.0-1.0/n_vgm_one(LL)))**2 + ENDDO + +! Fitting the van Genuchten SW retention parameters + ldfjac = npointw + xv(1) = theta_r_patches (ipatch) + xv(2) = alpha_vgm_patches (ipatch) + xv(3) = n_vgm_patches (ipatch) + xv(4) = k_s_patches (ipatch) + maxfev = 100 * ( nv + 1 ) + isiter = 1 + + CALL lmder ( SW_VG_dist, npointw, nv, xv, fvecv, fjacv, ldfjac, ftol, xtol, gtol, maxfev, & + diagv, mode, factor, nprint, info, nfev, njev, ipvtv, qtfv,& + xdat, npointw, ydatv, ydatvks, np, theta_s_patches(ipatch),& + k_s_patches (ipatch), isiter, L_vgm_patches (ipatch)) + + IF ( xv(1) >= 0.0 .and. xv(1) <= theta_s_patches(ipatch) .and. xv(2) >= 1.0e-5 .and. xv(2) <= 1.0 .and. & + xv(3) >= 1.1 .and. xv(3) <= 10.0 .and. xv(4) > 0.0 .and. xv(4) <= 1.0e7 .and. isiter == 1) THEN + theta_r_patches(ipatch) = xv(1) + alpha_vgm_patches(ipatch) = xv(2) + n_vgm_patches(ipatch) = xv(3) + k_s_patches (ipatch) = xv(4) + ENDIF + + deallocate(ydatv) + deallocate(ydatvks) + deallocate(THETA) + deallocate(fjacv) + deallocate(fvecv) + + ENDIF + ENDIF + + ELSE + theta_r_patches (ipatch) = -1.0e36_r8 + alpha_vgm_patches (ipatch) = -1.0e36_r8 + n_vgm_patches (ipatch) = -1.0e36_r8 + theta_s_patches (ipatch) = -1.0e36_r8 + k_s_patches (ipatch) = -1.0e36_r8 + L_vgm_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(theta_r_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in theta_r_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(alpha_vgm_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in alpha_vgm_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(n_vgm_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in n_vgm_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(theta_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in theta_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(k_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in k_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(L_vgm_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in L_vgm_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('theta_r lev '//trim(c), theta_r_patches) + CALL check_vector_data ('alpha VGM lev '//trim(c), alpha_vgm_patches) + CALL check_vector_data ('n VGM lev '//trim(c), n_vgm_patches) + CALL check_vector_data ('theta_s lev '//trim(c), theta_s_patches) + CALL check_vector_data ('k_s lev '//trim(c), k_s_patches) + CALL check_vector_data ('L VGM lev '//trim(c), L_vgm_patches) +#endif + + lndname = trim(landdir)//'/theta_r_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'theta_r_l'//trim(c)//'_patches', 'patch', landpatch, & + theta_r_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (theta_r_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'theta_r_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/alpha_vgm_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'alpha_vgm_l'//trim(c)//'_patches', 'patch', landpatch, & + alpha_vgm_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (alpha_vgm_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'alpha_vgm_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/n_vgm_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'n_vgm_l'//trim(c)//'_patches', 'patch', landpatch, & + n_vgm_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (n_vgm_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'n_vgm_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/theta_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'theta_s_l'//trim(c)//'_patches', 'patch', landpatch, & + theta_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (theta_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'theta_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/k_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'k_s_l'//trim(c)//'_patches', 'patch', landpatch, & + k_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (k_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'k_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/L_vgm_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'L_vgm_l'//trim(c)//'_patches', 'patch', landpatch, & + L_vgm_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (L_vgm_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'L_vgm_l'//trim(c), compress = 1, write_mode = 'one') +#endif + +#endif + + ! (11) saturated water content [cm3/cm3] + ! (12) saturated hydraulic conductivity [cm/day] + ! (13) matric potential at saturation (psi_s) [cm] + ! (14) pore size distribution index [dimensionless] + + IF (p_is_io) THEN + + CALL allocate_block_data (gland, theta_s_grid) + lndname = trim(dir_rawdata)//'/soil/theta_s.nc' + CALL ncio_read_block (lndname, 'theta_s_l'//trim(c), gland, theta_s_grid) + + CALL allocate_block_data (gland, k_s_grid) + lndname = trim(dir_rawdata)//'/soil/k_s.nc' + CALL ncio_read_block (lndname, 'k_s_l'//trim(c), gland, k_s_grid) + + CALL allocate_block_data (gland, psi_s_grid) + lndname = trim(dir_rawdata)//'/soil/psi_s.nc' + CALL ncio_read_block (lndname, 'psi_s_l'//trim(c), gland, psi_s_grid) + + CALL allocate_block_data (gland, lambda_grid) + lndname = trim(dir_rawdata)//'/soil/lambda.nc' + CALL ncio_read_block (lndname, 'lambda_l'//trim(c), gland, lambda_grid) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = theta_s_grid, data_r8_2d_in2 = k_s_grid, & + data_r8_2d_in3 = psi_s_grid, data_r8_2d_in4 = lambda_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + theta_s_patches (ipatch) = theta_s_patches (wmo_src) + k_s_patches (ipatch) = k_s_patches (wmo_src) + psi_s_patches (ipatch) = psi_s_patches (wmo_src) + lambda_patches (ipatch) = lambda_patches (wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = theta_s_grid, data_r8_2d_out1 = theta_s_one, & + data_r8_2d_in2 = k_s_grid, data_r8_2d_out2 = k_s_one, & + data_r8_2d_in3 = psi_s_grid, data_r8_2d_out3 = psi_s_one, & + data_r8_2d_in4 = lambda_grid, data_r8_2d_out4 = lambda_one) + + CALL fillnan (theta_s_one, L == WATERBODY, theta_s_fill_water(nsl)) + CALL fillnan (k_s_one , L == WATERBODY, k_s_fill_water(nsl) ) + CALL fillnan (psi_s_one , L == WATERBODY, psi_s_fill_water(nsl) ) + CALL fillnan (lambda_one , L == WATERBODY, lambda_fill_water(nsl) ) + + CALL fillnan (theta_s_one, L == GLACIERS , theta_s_fill_water(nsl)) + CALL fillnan (k_s_one , L == GLACIERS , k_s_fill_water(nsl)) + CALL fillnan (psi_s_one , L == GLACIERS , psi_s_fill_water(nsl) ) + CALL fillnan (lambda_one , L == GLACIERS , lambda_fill_water(nsl) ) + + theta_s_patches (ipatch) = sum (theta_s_one * (area_one/sum(area_one))) + k_s_patches (ipatch) = product(k_s_one**(area_one/sum(area_one))) + psi_s_patches (ipatch) = median (psi_s_one, size(psi_s_one), spval) + lambda_patches (ipatch) = median (lambda_one, size(lambda_one), spval) + + IF (DEF_USE_SOILPAR_UPS_FIT) THEN + np = size(psi_s_one) + + IF( np > 1 ) THEN + allocate ( ydatc (1:np,npointw-7) ) + allocate ( ydatcks(1:np,npointw-7) ) +! the jacobian matrix required in Levenberg-Marquardt fitting method + allocate ( fjacc (npointw-7,nc) ) ! calculated in SW_CB_dist +! the values of objective functions to be fitted + allocate ( fvecc (npointw-7) ) ! calculated in SW_CB_dist + +! SW CB retentions at fine grids for each patch + DO LL = 1,np + ydatc(LL,:) = (-1.0*xdat(8:)/psi_s_one(LL))**(-1.0*lambda_one(LL)) * theta_s_one(LL) + ydatcks(LL,:) = (-1.0*xdat(8:)/psi_s_one(LL))**(-3.0*lambda_one(LL)-2) * k_s_one(LL) + ENDDO + +! Fitting the Campbell SW retention parameters + ldfjac = npointw-7 + xc(1) = psi_s_patches (ipatch) + xc(2) = lambda_patches (ipatch) + xc(3) = k_s_patches (ipatch) + maxfev = 100 * ( nc + 1 ) + isiter = 1 + + CALL lmder ( SW_CB_dist, npointw-7, nc, xc, fvecc, fjacc, ldfjac, ftol, xtol, gtol, maxfev, & + diagc, mode, factor, nprint, info, nfev, njev, ipvtc, qtfc,& + xdat(8:), npointw-7, ydatc, ydatcks, np, theta_s_patches(ipatch),k_s_patches(ipatch), isiter) + + IF( xc(1) >= -300. .and. xc(1) < 0.0 .and. xc(2) > 0.0 .and. xc(2) <= 1.0 .and. & + xc(3) > 0.0 .and. xc(3) <= 1.0e7 .and. isiter == 1) THEN + psi_s_patches (ipatch) = xc(1) + lambda_patches(ipatch) = xc(2) + k_s_patches (ipatch) = xc(3) + ENDIF + + deallocate(ydatc) + deallocate(ydatcks) + deallocate(fjacc) + deallocate(fvecc) + + ENDIF + ENDIF + + ELSE + theta_s_patches (ipatch) = -1.0e36_r8 + k_s_patches (ipatch) = -1.0e36_r8 + psi_s_patches (ipatch) = -1.0e36_r8 + lambda_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(theta_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in theta_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(k_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in k_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(psi_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in psi_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + IF (isnan_ud(lambda_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in lambda_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('theta_s lev '//trim(c), theta_s_patches) + CALL check_vector_data ('k_s lev '//trim(c), k_s_patches) + CALL check_vector_data ('psi_s lev '//trim(c), psi_s_patches) + CALL check_vector_data ('lambda lev '//trim(c), lambda_patches) +#endif + +#ifndef vanGenuchten_Mualem_SOIL_MODEL + lndname = trim(landdir)//'/theta_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'theta_s_l'//trim(c)//'_patches', 'patch', landpatch, & + theta_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (theta_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'theta_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/k_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'k_s_l'//trim(c)//'_patches', 'patch', landpatch, & + k_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (k_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'k_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif +#endif + + lndname = trim(landdir)//'/psi_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'psi_s_l'//trim(c)//'_patches', 'patch', landpatch, & + psi_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (psi_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'psi_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + lndname = trim(landdir)//'/lambda_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'lambda_l'//trim(c)//'_patches', 'patch', landpatch, & + lambda_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (lambda_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'lambda_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (15) heat capacity of soil solids [J/(m3 K)] + IF (p_is_io) THEN + CALL allocate_block_data (gland, csol_grid) + lndname = trim(dir_rawdata)//'/soil/csol.nc' + CALL ncio_read_block (lndname, 'csol_l'//trim(c), gland, csol_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = csol_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + csol_patches(ipatch) = csol_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = csol_grid, data_r8_2d_out1 = csol_one) + CALL fillnan (csol_one, L == WATERBODY, csol_fill_water(nsl)) + CALL fillnan (csol_one, L == GLACIERS , csol_fill_water(nsl)) + csol_patches (ipatch) = sum(csol_one*(area_one/sum(area_one))) + ELSE + csol_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(csol_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in csol_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('csol lev '//trim(c), csol_patches) +#endif + + lndname = trim(landdir)//'/csol_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'csol_l'//trim(c)//'_patches', 'patch', landpatch, & + csol_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (csol_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'csol_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (16) thermal conductivity of unfrozen saturated soil [W/m-K] + IF (p_is_io) THEN + CALL allocate_block_data (gland, tksatu_grid) + lndname = trim(dir_rawdata)//'/soil/tksatu.nc' + CALL ncio_read_block (lndname, 'tksatu_l'//trim(c), gland, tksatu_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tksatu_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + tksatu_patches(ipatch) = tksatu_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = tksatu_grid, data_r8_2d_out1 = tksatu_one) + CALL fillnan (tksatu_one, L == WATERBODY, tksatu_fill_water(nsl)) + CALL fillnan (tksatu_one, L == GLACIERS , tksatu_fill_water(nsl)) + tksatu_patches (ipatch) = product(tksatu_one**(area_one/sum(area_one))) + ELSE + tksatu_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(tksatu_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in tksatu_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('tksatu lev '//trim(c), tksatu_patches) +#endif + + lndname = trim(landdir)//'/tksatu_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'tksatu_l'//trim(c)//'_patches', 'patch', landpatch, & + tksatu_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (tksatu_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'tksatu_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (17) thermal conductivity of frozen saturated soil [W/m-K] + IF (p_is_io) THEN + CALL allocate_block_data (gland, tksatf_grid) + lndname = trim(dir_rawdata)//'/soil/tksatf.nc' + CALL ncio_read_block (lndname, 'tksatf_l'//trim(c), gland, tksatf_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tksatf_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + tksatf_patches(ipatch) = tksatf_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = tksatf_grid, data_r8_2d_out1 = tksatf_one) + CALL fillnan (tksatf_one, L == WATERBODY, tksatf_fill_water(nsl)) + CALL fillnan (tksatf_one, L == GLACIERS , tksatf_fill_water(nsl)) + tksatf_patches (ipatch) = product(tksatf_one**(area_one/sum(area_one))) + ELSE + tksatf_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(tksatf_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in tksatf_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('tksatf lev '//trim(c), tksatf_patches) +#endif + + lndname = trim(landdir)//'/tksatf_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'tksatf_l'//trim(c)//'_patches', 'patch', landpatch, & + tksatf_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (tksatf_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'tksatf_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (18) thermal conductivity for dry soil [W/(m-K)] + IF (p_is_io) THEN + CALL allocate_block_data (gland, tkdry_grid) + lndname = trim(dir_rawdata)//'/soil/tkdry.nc' + CALL ncio_read_block (lndname, 'tkdry_l'//trim(c), gland, tkdry_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tkdry_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + tkdry_patches(ipatch) = tkdry_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = tkdry_grid, data_r8_2d_out1 = tkdry_one) + CALL fillnan (tkdry_one, L == WATERBODY, tkdry_fill_water(nsl)) + CALL fillnan (tkdry_one, L == GLACIERS , tkdry_fill_water(nsl)) + tkdry_patches (ipatch) = product(tkdry_one**(area_one/sum(area_one))) + ELSE + tkdry_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(tkdry_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in tkdry_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('tkdry lev '//trim(c), tkdry_patches) +#endif + + lndname = trim(landdir)//'/tkdry_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'tkdry_l'//trim(c)//'_patches', 'patch', landpatch, & + tkdry_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (tkdry_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'tkdry_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (19) thermal conductivity of soil solids [W/m-K] + IF (p_is_io) THEN + CALL allocate_block_data (gland, k_solids_grid) + lndname = trim(dir_rawdata)//'/soil/k_solids.nc' + CALL ncio_read_block (lndname, 'k_solids_l'//trim(c), gland, k_solids_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = k_solids_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + k_solids_patches(ipatch) = k_solids_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = k_solids_grid, data_r8_2d_out1 = k_solids_one) + CALL fillnan (k_solids_one, L == WATERBODY, k_solids_fill_water(nsl)) + CALL fillnan (k_solids_one, L == GLACIERS , k_solids_fill_water(nsl)) + k_solids_patches (ipatch) = product(k_solids_one**(area_one/sum(area_one))) + ELSE + k_solids_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(k_solids_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in k_solids_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('k_solids lev '//trim(c), k_solids_patches) +#endif + + lndname = trim(landdir)//'/k_solids_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'k_solids_l'//trim(c)//'_patches', 'patch', landpatch, & + k_solids_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (k_solids_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'k_solids_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (20) OM_density [kg/m3] + IF (p_is_io) THEN + + CALL allocate_block_data (gland, OM_density_s_grid) + lndname = trim(dir_rawdata)//'/soil/OM_density_s.nc' + CALL ncio_read_block (lndname, 'OM_density_s_l'//trim(c), gland, OM_density_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = OM_density_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + OM_density_s_patches(ipatch) = OM_density_s_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = OM_density_s_grid, data_r8_2d_out1 = OM_density_s_one) + CALL fillnan (OM_density_s_one, L == WATERBODY, OM_density_fill_water(nsl)) + CALL fillnan (OM_density_s_one, L == GLACIERS , OM_density_fill_water(nsl)) + OM_density_s_patches (ipatch) = sum (OM_density_s_one * (area_one/sum(area_one))) + ELSE + OM_density_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(OM_density_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in OM_density_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('OM_density_s lev '//trim(c), OM_density_s_patches) +#endif + + lndname = trim(landdir)//'/OM_density_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'OM_density_s_l'//trim(c)//'_patches', 'patch',& + landpatch, OM_density_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (OM_density_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'OM_density_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (21) bulk density of soil (GRAVELS + OM + Mineral Soils) + IF (p_is_io) THEN + + CALL allocate_block_data (gland, BD_all_s_grid) + lndname = trim(dir_rawdata)//'/soil/BD_all_s.nc' + CALL ncio_read_block (lndname, 'BD_all_s_l'//trim(c), gland, BD_all_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = BD_all_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + BD_all_s_patches(ipatch) = BD_all_s_patches(wmo_src) + + CYCLE + ENDIF + + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = BD_all_s_grid, data_r8_2d_out1 = BD_all_s_one) + CALL fillnan (BD_all_s_one, L == WATERBODY, BD_all_fill_water(nsl)) + CALL fillnan (BD_all_s_one, L == GLACIERS , BD_all_fill_water(nsl)) + BD_all_s_patches (ipatch) = sum (BD_all_s_one * (area_one/sum(area_one))) + ELSE + BD_all_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(BD_all_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in BD_all_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('BD_all_s lev '//trim(c), BD_all_s_patches) +#endif + + lndname = trim(landdir)//'/BD_all_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'BD_all_s_l'//trim(c)//'_patches', 'patch',& + landpatch, BD_all_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (BD_all_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'BD_all_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + ! (22) volumetric fraction of clay + IF (p_is_io) THEN + + CALL allocate_block_data (gland, vf_clay_s_grid) + lndname = trim(dir_rawdata)//'/soil/vf_clay_s.nc' + CALL ncio_read_block (lndname, 'vf_clay_s_l'//trim(c), gland, vf_clay_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_clay_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + vf_clay_s_patches(ipatch) = vf_clay_s_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = vf_clay_s_grid, data_r8_2d_out1 = vf_clay_s_one) + CALL fillnan (vf_clay_s_one, L == WATERBODY, vf_clay_fill_water(nsl)) + CALL fillnan (vf_clay_s_one, L == GLACIERS , vf_clay_fill_water(nsl)) + vf_clay_s_patches (ipatch) = sum (vf_clay_s_one * (area_one/sum(area_one))) + ELSE + vf_clay_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(vf_clay_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in vf_clay_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('vf_clay_s lev '//trim(c), vf_clay_s_patches) +#endif + + lndname = trim(landdir)//'/vf_clay_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'vf_clay_s_l'//trim(c)//'_patches', 'patch',& + landpatch, vf_clay_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (vf_clay_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'vf_clay_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + + ! (23) gravimetric fraction of om + IF (p_is_io) THEN + + CALL allocate_block_data (gland, wf_om_s_grid) + lndname = trim(dir_rawdata)//'/soil/wf_om_s.nc' + CALL ncio_read_block (lndname, 'wf_om_s_l'//trim(c), gland, wf_om_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_om_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + wf_om_s_patches(ipatch) = wf_om_s_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = wf_om_s_grid, data_r8_2d_out1 = wf_om_s_one) + CALL fillnan (wf_om_s_one, L == WATERBODY, wf_om_fill_water(nsl)) + CALL fillnan (wf_om_s_one, L == GLACIERS , wf_om_fill_water(nsl)) + wf_om_s_patches (ipatch) = sum (wf_om_s_one * (area_one/sum(area_one))) + ELSE + wf_om_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(wf_om_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in wf_om_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('wf_om_s lev '//trim(c), wf_om_s_patches) +#endif + + lndname = trim(landdir)//'/wf_om_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'wf_om_s_l'//trim(c)//'_patches', 'patch',& + landpatch, wf_om_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (wf_om_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'wf_om_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + + + ! (24) gravimetric fraction of clay + IF (p_is_io) THEN + + CALL allocate_block_data (gland, wf_clay_s_grid) + lndname = trim(dir_rawdata)//'/soil/wf_clay_s.nc' + CALL ncio_read_block (lndname, 'wf_clay_s_l'//trim(c), gland, wf_clay_s_grid) +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_clay_s_grid) +#endif + ENDIF + + IF (p_is_worker) THEN + + DO ipatch = 1, numpatch + L = landpatch%settyp(ipatch) + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + wf_clay_s_patches(ipatch) = wf_clay_s_patches(wmo_src) + + CYCLE + ENDIF + + IF (L /= 0) THEN + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = wf_clay_s_grid, data_r8_2d_out1 = wf_clay_s_one) + CALL fillnan (wf_clay_s_one, L == WATERBODY, wf_clay_fill_water(nsl)) + CALL fillnan (wf_clay_s_one, L == GLACIERS , wf_clay_fill_water(nsl)) + wf_clay_s_patches (ipatch) = sum (wf_clay_s_one * (area_one/sum(area_one))) + ELSE + wf_clay_s_patches (ipatch) = -1.0e36_r8 + ENDIF + + IF (isnan_ud(wf_clay_s_patches(ipatch))) THEN + write(*,*) "Warning: NAN appears in wf_clay_s_patches." + write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('wf_clay_s lev '//trim(c), wf_clay_s_patches) +#endif + + lndname = trim(landdir)//'/wf_clay_s_l'//trim(c)//'_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'wf_clay_s_l'//trim(c)//'_patches', 'patch',& + landpatch, wf_clay_s_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (wf_clay_s_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'wf_clay_s_l'//trim(c), compress = 1, write_mode = 'one') +#endif + ENDDO + + + ! Deallocate the allocatable array + ! -------------------------------- + + IF (p_is_worker) THEN + + deallocate ( vf_quartz_mineral_s_patches ) + deallocate ( vf_gravels_s_patches ) + deallocate ( vf_om_s_patches ) + deallocate ( vf_sand_s_patches ) + deallocate ( vf_clay_s_patches ) + deallocate ( wf_gravels_s_patches ) + deallocate ( wf_sand_s_patches ) + deallocate ( wf_om_s_patches ) + deallocate ( wf_clay_s_patches ) + deallocate ( OM_density_s_patches ) + deallocate ( BD_all_s_patches ) + deallocate ( theta_s_patches ) + deallocate ( psi_s_patches ) + deallocate ( lambda_patches ) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + deallocate ( theta_r_patches ) + deallocate ( alpha_vgm_patches) + deallocate ( L_vgm_patches ) + deallocate ( n_vgm_patches ) +#endif + deallocate ( k_s_patches ) + deallocate ( csol_patches ) + deallocate ( tksatu_patches ) + deallocate ( tkdry_patches ) + deallocate ( tksatf_patches ) + deallocate ( k_solids_patches) + deallocate ( BA_alpha_patches) + deallocate ( BA_beta_patches ) + + IF (allocated(vf_quartz_mineral_s_one)) deallocate (vf_quartz_mineral_s_one) + IF (allocated(vf_gravels_s_one)) deallocate (vf_gravels_s_one) + IF (allocated(vf_om_s_one)) deallocate (vf_om_s_one) + IF (allocated(vf_sand_s_one)) deallocate (vf_sand_s_one) + IF (allocated(vf_clay_s_one)) deallocate (vf_clay_s_one) + IF (allocated(wf_gravels_s_one)) deallocate (wf_gravels_s_one) + IF (allocated(wf_sand_s_one)) deallocate (wf_sand_s_one) + IF (allocated(wf_om_s_one)) deallocate (wf_om_s_one) + IF (allocated(wf_clay_s_one)) deallocate (wf_clay_s_one) + IF (allocated(OM_density_s_one)) deallocate (OM_density_s_one) + IF (allocated(BD_all_s_one)) deallocate (BD_all_s_one) + IF (allocated(theta_s_one)) deallocate (theta_s_one) + IF (allocated(psi_s_one )) deallocate (psi_s_one ) + IF (allocated(lambda_one )) deallocate (lambda_one ) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + IF (allocated ( theta_r_one )) deallocate ( theta_r_one ) + IF (allocated ( alpha_vgm_one)) deallocate ( alpha_vgm_one) + IF (allocated ( L_vgm_one )) deallocate ( L_vgm_one ) + IF (allocated ( n_vgm_one )) deallocate ( n_vgm_one ) +#endif + IF (allocated(k_s_one )) deallocate (k_s_one ) + IF (allocated(csol_one )) deallocate (csol_one ) + IF (allocated(tksatu_one )) deallocate (tksatu_one ) + IF (allocated(tkdry_one )) deallocate (tkdry_one ) + IF (allocated(tksatf_one )) deallocate (tksatf_one) + IF (allocated(k_solids_one)) deallocate (k_solids_one) + IF (allocated(area_one)) deallocate (area_one) + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +END SUBROUTINE Aggregation_SoilParameters + + +SUBROUTINE SW_CB_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatc, ydatcks, nptf, phi, k_s, isiter) + +!================================================================= +! DESCRIPTION: +! This is the subroutine for calculating the function/jacobian matrix +! of the distance between the fitted and prescribed SW retention and +! hydraulic conductivity curves for the Campbell model. +! +! Created by Nan Wei, 01/2019 +! ---------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + integer m,n,ldfjac,iflag,i,nptf,isiter,npoint + real(r8) x(n),fjac(ldfjac,n),fvec(m),xdat(npoint),ydatc(nptf,npoint),ydatcks(nptf,npoint),phi,k_s + + IF ( iflag == 0 ) THEN + + print*,x + + ELSEIF ( iflag == 1 ) THEN + + IF (x(1) >= 0.0 .or. abs(x(2)) >= 100. .or. x(3) <= 0.0) THEN + isiter = 0 + RETURN + ENDIF + + DO i = 1, m + fvec(i) = sum((((-1.0*xdat(i)/x(1))**(-1.0*x(2)) * phi - ydatc(:,i))/phi)**2) & + + sum(((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))**2) + ENDDO + + ELSEIF ( iflag == 2 ) THEN + + IF (x(1) >= 0.0 .or. abs(x(2)) >= 100. .or. x(3) <= 0.0) THEN + isiter = 0 + RETURN + ENDIF + + DO i = 1, m + fjac(i,1) = sum(2.0*(((-1.0*xdat(i)/x(1))**(-1.0*x(2)) * phi - ydatc(:,i))/phi)*& + x(2) * (-1.0*xdat(i)/x(1))**(-1.0*x(2)) / x(1)) & + + sum(2.0*((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))*& + (3.0*x(2)+2)/(x(1)*log(10.))/log10(k_s)) + fjac(i,2) = sum(-2.0*(((-1.0*xdat(i)/x(1))**(-1.0*x(2)) * phi - ydatc(:,i))/phi)*& + (-1.0*xdat(i)/x(1))**(-1.0*x(2)) * log(-1.0*xdat(i)/x(1))) & + + sum(-6.0*((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))*& + log10(-1.0*xdat(i)/x(1))/log10(k_s)) + fjac(i,3) = sum(2.0*((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))/& + (x(3)*log(10.)*log10(k_s))) + ENDDO + + ENDIF + +END SUBROUTINE SW_CB_dist + +SUBROUTINE SW_VG_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatv, ydatvks, nptf, phi, k_s, isiter, L_vgm) + +!================================================================= +! DESCRIPTION: +! This is the subroutine for calculating the function/jacobian matrix +! of the distance between the fitted and prescribed SW retention and +! hydraulic conductivity curves for the van Genuchten model. +! +! Created by Nan Wei, 01/2019 +! ---------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + integer m,n,ldfjac,iflag,i,nptf,isiter,npoint + real(r8) x(n),fjac(ldfjac,n),fvec(m),xdat(npoint),ydatv(nptf,npoint),ydatvks(nptf,npoint),phi,k_s,L_vgm + + IF ( iflag == 0 ) THEN + + print*,x + + ELSEIF ( iflag == 1 ) THEN + + IF (x(2) <= 0.0 .or. x(3) <= 0.1 .or. x(3) >= 100. .or. x(4) <= 0.0) THEN + isiter = 0 + RETURN + ENDIF + + DO i = 1, m + fvec(i) = sum(((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)**2) & + + sum(((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & + log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s))**2) + ENDDO + + ELSEIF ( iflag == 2 ) THEN + + IF (x(2) <= 0.0 .or. x(3) <= 0.1 .or. x(3) >= 100. .or. x(4) <= 0.0) THEN + isiter = 0 + RETURN + ENDIF + + DO i = 1, m + fjac(i,1) = sum(2*((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)*& + (1 - (1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1))/phi) + fjac(i,2) = sum(2*((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)/phi*& + (phi - x(1)) * (1 - x(3)) * (1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-2) * x(2)**(x(3)-1) * xdat(i)**x(3)) & + + sum(2*((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & + log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s)) * & + (L_vgm*(1.0-x(3))*x(2)**(x(3)-1)*xdat(i)**x(3)/((1+(x(2)*xdat(i))**x(3))*log(10.)) + & + 2.0*(1.0-x(3))*(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(-1.0/x(3))* & + x(2)**(x(3)-1)*xdat(i)**x(3)*(1+(x(2)*xdat(i))**x(3))**(-2)/ & + ((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))*log(10.)))/log10(k_s)) + fjac(i,3) = sum(2*((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)/phi*& + (phi - x(1)) * (1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) *& + ((1.0-x(3))*(x(2)*xdat(i))**x(3)*log(x(2)*xdat(i))/(x(3)*(1+(x(2)*xdat(i))**x(3))) & + - log(1+(x(2)*xdat(i))**x(3))/x(3)**2)) & + + sum(2*((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & + log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s)) * & + (-1.0*L_vgm*log10(1+(x(2)*xdat(i))**x(3))/x(3)**2 + & + (1.0/x(3)-1)*L_vgm*(x(2)*xdat(i))**x(3)*log10(x(2)*xdat(i))/(1+(x(2)*xdat(i))**x(3)) - & + 2.0*(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3))/ & + (1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3))) * & + (log10(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))/x(3)**2 + & + (1-1.0/x(3))*log10(x(2)*xdat(i))/(1+(x(2)*xdat(i))**x(3))))/log10(k_s)) + fjac(i,4) = sum(2*((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & + log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s)) / & + (x(4)*log(10.))/log10(k_s)) + ENDDO + + ENDIF + +END SUBROUTINE SW_VG_dist + +!----------------------------------------------------------------------- +!EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 new file mode 100644 index 0000000000..789741a153 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 @@ -0,0 +1,139 @@ +#include + +SUBROUTINE Aggregation_SoilTexture ( & + gland, dir_rawdata, dir_model_landdata, lc_year) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Aggregate soil texture class within a patch. +! +! Use the USDA soil texture triangle (using the amount of sand, clay, and +! silt contents) to identify the soil texture in fine grid resolution and +! then finding the major soil type in a patch by counting number of fine +! grids with each type of soil and adopting the major one. +! +! Created by Shupeng Zhang, 01/2025 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils, only: num_max_frequency +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + ! arguments: + + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gland + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + integer :: ipatch + integer :: wmo_src + + type(block_data_int32_2d) :: soiltext + integer, allocatable :: soiltext_patches(:), soiltext_one(:) +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp + real(r8), allocatable :: soiltext_r8 (:) +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate soil texture ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + lndname = trim(dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc' + + IF (p_is_io) THEN + CALL allocate_block_data (gland, soiltext) + CALL ncio_read_block (lndname, 'soiltexture', gland, soiltext) + +#ifdef USEMPI + CALL aggregation_data_daemon (gland, data_i4_2d_in1 = soiltext) +#endif + ENDIF + + IF (p_is_worker) THEN + + IF (numpatch > 0) allocate (soiltext_patches (numpatch)) + + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + soiltext_patches(ipatch) = soiltext_patches(wmo_src) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gland, & + zip = USE_zip_for_aggregation, & + data_i4_2d_in1 = soiltext, data_i4_2d_out1 = soiltext_one) + soiltext_patches(ipatch) = num_max_frequency (soiltext_one) + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('soiltext_patches ', soiltext_patches) +#endif + + lndname = trim(landdir)//'/soiltexture_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'soiltext_patches', 'patch', & + landpatch, soiltext_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata)//'/diag/soiltexture_'//trim(cyear)//'.nc' + IF (allocated(soiltext_patches)) THEN + allocate (soiltext_r8 (size(soiltext_patches))) + soiltext_r8 = real(soiltext_patches,r8) + ENDIF + + CALL srfdata_map_and_write (soiltext_r8, landpatch%settyp, typpatch, & + m_patch2diag, -1., lndname, 'soiltexture', compress = 1, write_mode = 'one', & + create_mode=.true.) + + IF (allocated(soiltext_r8)) deallocate(soiltext_r8) +#endif + + IF (p_is_worker) THEN + IF (numpatch > 0) deallocate ( soiltext_patches ) + ENDIF + +END SUBROUTINE Aggregation_SoilTexture diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 new file mode 100644 index 0000000000..1d5f6aadd8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 @@ -0,0 +1,345 @@ +#include + +SUBROUTINE Aggregation_TopoWetness ( & + gridtwi, dir_rawdata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! Topographic Wetness Index data ln(a/tanB), calculated by using +! +! Yamazaki, D., Ikeshima, D., Sosa, J.,Bates, P. D., Allen, G. H., +! Pavelsky, T. M. (2019). +! MERIT Hydro: ahigh‐resolution global hydrographymap based on +! latest topography dataset.Water Resources Research, 55, 5053-5073. +! +! Created by Shupeng Zhang, 06/2025 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_CatchmentDataReadin +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + ! arguments: + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gridtwi + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + integer :: ipatch, npxl, i, im, ielm, istt, iend + integer :: wmo_src + real(r8) :: mean_twi, sigma_twi, skew_twi, fsatmax, fsatdcf, alp_twi, chi_twi, mu_twi + + type (block_data_real8_3d) :: twi + + real(r8), allocatable :: twi_one (:,:) + logical, allocatable :: mask (:,:) + + real(r8), allocatable :: mean_twi_patches(:) + real(r8), allocatable :: fsatmax_patches (:), fsatdcf_patches (:) + real(r8), allocatable :: alp_twi_patches (:), chi_twi_patches (:), mu_twi_patches (:) + + real(r8), allocatable :: twi_sort(:), xx(:), yy(:) + integer, allocatable :: order (:) + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate topographic wetness index ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +! ----------------------------------------------------------------------------------------- +! aggregate the topographic index from the resolution of raw data to modelling resolution +! ----------------------------------------------------------------------------------------- + + IF (p_is_io) THEN + + lndname = trim(dir_rawdata)//'/TWI.nc' + CALL allocate_block_data (gridtwi, twi, 25) + CALL ncio_read_block (lndname, 'twi', gridtwi, 25, twi) + +#ifdef USEMPI + CALL aggregation_data_daemon (gridtwi, data_r8_3d_in1 = twi, n1_r8_3d_in1 = 25) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (mean_twi_patches (numpatch)); mean_twi_patches(:) = spval + allocate (fsatmax_patches (numpatch)); fsatmax_patches (:) = spval + allocate (fsatdcf_patches (numpatch)); fsatdcf_patches (:) = spval + allocate (alp_twi_patches (numpatch)); alp_twi_patches (:) = spval + allocate (chi_twi_patches (numpatch)); chi_twi_patches (:) = spval + allocate (mu_twi_patches (numpatch)); mu_twi_patches (:) = spval + + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + fsatmax_patches(ipatch) = fsatmax_patches(wmo_src) + fsatdcf_patches(ipatch) = fsatdcf_patches(wmo_src) + alp_twi_patches(ipatch) = alp_twi_patches(wmo_src) + chi_twi_patches(ipatch) = chi_twi_patches(wmo_src) + mu_twi_patches (ipatch) = mu_twi_patches (wmo_src) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gridtwi, zip = USE_zip_for_aggregation, & + data_r8_3d_in1 = twi, data_r8_3d_out1 = twi_one, n1_r8_3d_in1 = 25, lb1_r8_3d_in1 = 1 ) + + allocate (mask (size(twi_one,1),size(twi_one,2))) + mask = (twi_one > -1.e3) + npxl = count(mask) + + IF (npxl >= 25) THEN + + allocate (twi_sort (npxl)) + allocate (order (npxl)) + + twi_sort = pack(twi_one, mask) + + CALL quicksort (npxl, twi_sort, order) + + mean_twi_patches(ipatch) = sum(twi_sort) / npxl + + im = 1 + DO WHILE ((twi_sort(im) < mean_twi_patches(ipatch)) .and. (im < npxl-1)) + im = im + 1 + ENDDO + + fsatmax_patches(ipatch) = 1 - real(im-1)/npxl + + allocate (xx (npxl-im)) + allocate (yy (npxl-im)) + + xx = -(twi_sort(im:(npxl-1)) - mean_twi_patches(ipatch)) + yy = (/(log((1-real(i)/npxl)/fsatmax_patches(ipatch)), i = im, npxl-1)/) + + fsatdcf_patches(ipatch) = sum(xx*yy)/sum(xx**2) + + mean_twi = mean_twi_patches(ipatch) + sigma_twi = sqrt(sum((twi_sort-mean_twi)**2) / (npxl-1)) + + IF (sigma_twi > 0) THEN + skew_twi = real(npxl)/((npxl-1)*(npxl-2)) * sum((twi_sort-mean_twi)**3) / sigma_twi**3 + IF (skew_twi > 0) THEN + alp_twi_patches(ipatch) = (2./skew_twi)**2 + chi_twi_patches(ipatch) = sigma_twi*skew_twi/2 + mu_twi_patches (ipatch) = mean_twi - 2.*sigma_twi/skew_twi + ENDIF + ENDIF + + fsatmax_patches(ipatch) = min(max(fsatmax_patches(ipatch), 0.1), 1.0) + fsatdcf_patches(ipatch) = min(max(fsatdcf_patches(ipatch), 0.2), 2.0) + alp_twi_patches(ipatch) = min(max(alp_twi_patches(ipatch), 0.1), 50.) + chi_twi_patches(ipatch) = min(max(chi_twi_patches(ipatch), 0.01), 4.0) + mu_twi_patches (ipatch) = min(max(mu_twi_patches (ipatch), 0.), 12.) + + deallocate (twi_sort) + deallocate (order ) + deallocate (xx ) + deallocate (yy ) + + ENDIF + + deallocate (mask) + + ENDDO + + DO ielm = 1, numelm + + ! default value is set as global median at 0.1 degree resolution + mean_twi = 9.27 + fsatmax = 0.38 + fsatdcf = 0.55 + alp_twi = 1.34 + chi_twi = 1.61 + mu_twi = 6.95 + + CALL aggregation_request_data (landelm, ielm, gridtwi, zip = USE_zip_for_aggregation, & + data_r8_3d_in1 = twi, data_r8_3d_out1 = twi_one, n1_r8_3d_in1 = 25, lb1_r8_3d_in1 = 1 ) + + allocate (mask (size(twi_one,1),size(twi_one,2))) + mask = (twi_one > -1.e3) + npxl = count(mask) + + IF (npxl >= 25) THEN + + allocate (twi_sort (npxl)) + allocate (order (npxl)) + + twi_sort = pack(twi_one, mask) + + CALL quicksort (npxl, twi_sort, order) + + mean_twi = sum(twi_sort) / npxl + + im = 1 + DO WHILE ((twi_sort(im) < mean_twi) .and. (im < npxl-1)) + im = im + 1 + ENDDO + + fsatmax = 1 - real(im-1)/npxl + + allocate (xx (npxl-im)) + allocate (yy (npxl-im)) + + xx = -(twi_sort(im:(npxl-1)) - mean_twi) + yy = (/(log((1-real(i)/npxl)/fsatmax), i = im, npxl-1)/) + + fsatdcf = sum(xx*yy)/sum(xx**2) + + sigma_twi = sqrt(sum((twi_sort-mean_twi)**2) / (npxl-1)) + + IF (sigma_twi > 0) THEN + skew_twi = real(npxl)/((npxl-1)*(npxl-2)) * sum((twi_sort-mean_twi)**3) / sigma_twi**3 + IF (skew_twi > 0) THEN + alp_twi = (2./skew_twi)**2 + chi_twi = sigma_twi*skew_twi/2 + mu_twi = mean_twi - 2.*sigma_twi/skew_twi + ENDIF + ENDIF + + fsatmax = min(max(fsatmax, 0.1), 1.0) + fsatdcf = min(max(fsatdcf, 0.2), 2.0) + alp_twi = min(max(alp_twi, 0.1), 50.) + chi_twi = min(max(chi_twi, 0.01), 4.0) + mu_twi = min(max(mu_twi , 0.), 12.) + + deallocate (twi_sort) + deallocate (order ) + deallocate (xx ) + deallocate (yy ) + + ENDIF + + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + DO ipatch = istt, iend + IF (mean_twi_patches(ipatch) == spval) mean_twi_patches(ipatch) = mean_twi + IF (fsatmax_patches (ipatch) == spval) fsatmax_patches (ipatch) = fsatmax + IF (fsatdcf_patches (ipatch) == spval) fsatdcf_patches (ipatch) = fsatdcf + IF (alp_twi_patches (ipatch) == spval) alp_twi_patches (ipatch) = alp_twi + IF (chi_twi_patches (ipatch) == spval) chi_twi_patches (ipatch) = chi_twi + IF (mu_twi_patches (ipatch) == spval) mu_twi_patches (ipatch) = mu_twi + ENDDO + + deallocate (mask) + + ENDDO + + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('mean_twi_patches ', mean_twi_patches) + CALL check_vector_data ('fsatmax_patches ', fsatmax_patches ) + CALL check_vector_data ('fsatdcf_patches ', fsatdcf_patches ) + CALL check_vector_data ('alp_twi_patches ', alp_twi_patches ) + CALL check_vector_data ('chi_twi_patches ', chi_twi_patches ) + CALL check_vector_data ('mu_twi_patches ', mu_twi_patches ) +#endif + + lndname = trim(landdir)//'/mean_twi_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'mean_twi_patches', 'patch', landpatch, & + mean_twi_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/fsatmax_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'fsatmax_patches', 'patch', landpatch, & + fsatmax_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/fsatdcf_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'fsatdcf_patches', 'patch', landpatch, & + fsatdcf_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/alp_twi_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'alp_twi_patches', 'patch', landpatch, & + alp_twi_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/chi_twi_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'chi_twi_patches', 'patch', landpatch, & + chi_twi_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/mu_twi_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'mu_twi_patches', 'patch', landpatch, & + mu_twi_patches, DEF_Srfdata_CompressLevel) + + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + + lndname = trim(dir_model_landdata) // '/diag/twi_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (mean_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'mean_twi', compress = 1, write_mode = 'one', create_mode=.true.) + CALL srfdata_map_and_write (fsatmax_patches, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'fsatmax', compress = 1, write_mode = 'one') + CALL srfdata_map_and_write (fsatdcf_patches, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'fsatdcf', compress = 1, write_mode = 'one') + CALL srfdata_map_and_write (alp_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'alp_twi', compress = 1, write_mode = 'one') + CALL srfdata_map_and_write (chi_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'chi_twi', compress = 1, write_mode = 'one') + CALL srfdata_map_and_write (mu_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & + spval, lndname, 'mu_twi', compress = 1, write_mode = 'one') +#endif + + IF (p_is_worker) THEN + deallocate ( mean_twi_patches ) + deallocate ( fsatmax_patches ) + deallocate ( fsatdcf_patches ) + deallocate ( alp_twi_patches ) + deallocate ( chi_twi_patches ) + deallocate ( mu_twi_patches ) + ENDIF + +END SUBROUTINE Aggregation_TopoWetness diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 new file mode 100644 index 0000000000..7e8585a14c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 @@ -0,0 +1,206 @@ +#include + +SUBROUTINE Aggregation_Topography ( & + gtopo, dir_rawdata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! Global Topography data +! +! Yamazaki, D., Ikeshima, D., Sosa, J.,Bates, P. D., Allen, G. H., +! Pavelsky, T. M. (2019). +! MERIT Hydro: a high‐resolution global hydrographymap based on +! latest topography dataset.Water Resources Research, 55, 5053-5073. +! +! Created by Shupeng Zhang, 05/2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils + +#ifdef SrfdataDiag + USE MOD_Mesh, only: numelm + USE MOD_LandElm + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + ! arguments: + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: gtopo + character(len=*), intent(in) :: dir_rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + integer :: ipatch, i, ps, pe + integer :: wmo_src + real(r8) :: sumarea + + type (block_data_real8_2d) :: landarea + type (block_data_real8_2d) :: elevation + type (block_data_real8_2d) :: elvstd + type (block_data_real8_2d) :: sloperatio + + real(r8), allocatable :: elevation_one (:), elvstd_one (:), sloperatio_one (:) + real(r8), allocatable :: elevation_patches(:), elvstd_patches(:), sloperatio_patches(:) + real(r8), allocatable :: landarea_one (:) + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp +#endif + + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate topography ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + lndname = trim(dir_rawdata)//'/topography.nc' + +! --------------------------------------------------------------------------------- +! aggregate the elevation from the resolution of raw data to modelling resolution +! --------------------------------------------------------------------------------- + + IF (p_is_io) THEN + + CALL allocate_block_data (gtopo, landarea) + CALL ncio_read_block (lndname, 'landarea', gtopo, landarea) + + CALL allocate_block_data (gtopo, elevation) + CALL ncio_read_block (lndname, 'elevation', gtopo, elevation) + + CALL allocate_block_data (gtopo, elvstd) + CALL ncio_read_block (lndname, 'elvstd', gtopo, elvstd) + + CALL allocate_block_data (gtopo, sloperatio) + CALL ncio_read_block (lndname, 'slope', gtopo, sloperatio) + +#ifdef USEMPI + CALL aggregation_data_daemon (gtopo, & + data_r8_2d_in1 = landarea, data_r8_2d_in2 = elevation, & + data_r8_2d_in3 = elvstd , data_r8_2d_in4 = sloperatio ) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (elevation_patches (numpatch)) + allocate (elvstd_patches (numpatch)) + allocate (sloperatio_patches (numpatch)) + + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + elevation_patches (ipatch) = elevation_patches (wmo_src) + elvstd_patches (ipatch) = elvstd_patches (wmo_src) + sloperatio_patches(ipatch) = sloperatio_patches(wmo_src) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, gtopo, & + zip = USE_zip_for_aggregation, & + data_r8_2d_in1 = landarea , data_r8_2d_out1 = landarea_one , & + data_r8_2d_in2 = elevation , data_r8_2d_out2 = elevation_one , & + data_r8_2d_in3 = elvstd , data_r8_2d_out3 = elvstd_one , & + data_r8_2d_in4 = sloperatio, data_r8_2d_out4 = sloperatio_one ) + + IF (any(elevation_one /= -9999.0)) THEN + + sumarea = sum(landarea_one, mask = elevation_one /= -9999.0) + + elevation_patches(ipatch) = & + sum(elevation_one * landarea_one, mask = elevation_one /= -9999.0) / sumarea + + elvstd_patches(ipatch) = sqrt( & + sum(((elevation_one - elevation_patches(ipatch))**2 + elvstd_one**2) * landarea_one, & + mask = elevation_one /= -9999.0) / sumarea) + + sloperatio_patches(ipatch) = & + sum(sloperatio_one * landarea_one, mask = elevation_one /= -9999.0) / sumarea + + ELSE + elevation_patches (ipatch) = 0. + elvstd_patches (ipatch) = 0. + sloperatio_patches(ipatch) = 0. + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('elevation_patches ', elevation_patches ) + CALL check_vector_data ('elvstd_patches ', elvstd_patches ) + CALL check_vector_data ('sloperatio_patches', sloperatio_patches) +#endif + + lndname = trim(landdir)//'/elevation_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'elevation_patches', 'patch', landpatch, & + elevation_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/elvstd_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'elvstd_patches', 'patch', landpatch, & + elvstd_patches, DEF_Srfdata_CompressLevel) + + lndname = trim(landdir)//'/sloperatio_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'sloperatio_patches', 'patch', landpatch, & + sloperatio_patches, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/topography_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (elevation_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'elevation', compress = 1, write_mode = 'one', create_mode=.true.) + + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/topography_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (elvstd_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'elvstd', compress = 1, write_mode = 'one') + + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/topography_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (sloperatio_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'sloperatio', compress = 1, write_mode = 'one') +#endif + + IF (p_is_worker) THEN + deallocate ( elevation_patches ) + deallocate ( elvstd_patches ) + deallocate ( sloperatio_patches ) + ENDIF + +END SUBROUTINE Aggregation_Topography diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 new file mode 100644 index 0000000000..6437a2be13 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 @@ -0,0 +1,522 @@ +#include + +SUBROUTINE Aggregation_TopographyFactors ( & + grid_topo_factor , dir_topodata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! Global topography-based factors data +! +! Created by Sisi Chen, Lu Li, 06/2024 +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_Mesh, only: numelm + USE MOD_LandElm + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + ! --------------------------------------------------------------- + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: grid_topo_factor ! Grid structure for high resolution topography factors + character(len=*), intent(in) :: dir_topodata ! Direct of Rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + character(len=3) :: sdir, sdir1 + + type (block_data_real8_2d) :: slp_grid ! slope + type (block_data_real8_2d) :: asp_grid ! aspect + type (block_data_real8_2d) :: svf_grid ! sky view factor + type (block_data_real8_2d) :: cur_grid ! curvature + type (block_data_real8_3d) :: tea_f_grid ! sine of terrain elevation angle at front of grid + type (block_data_real8_3d) :: tea_b_grid ! sine of terrain elevation angle at back of grid + + ! patch + real(r8), allocatable :: svf_patches (:) + real(r8), allocatable :: cur_patches (:) + real(r8), allocatable :: tea_f_azi_patches (:,:) ! shape as (azimuth, patches) + real(r8), allocatable :: tea_b_azi_patches (:,:) + real(r8), allocatable :: sf_lut_patches (:,:,:) ! shape as (azimuth, zenith, patches) + real(r8), allocatable :: sf_curve_patches(:,:,:) ! shape as (azimuth, parameters, patches) + + ! four defined types at all patches + real(r8), allocatable :: asp_type_patches (:,:) ! shape as (type, patches) + real(r8), allocatable :: slp_type_patches (:,:) + real(r8), allocatable :: area_type_patches (:,:) + + ! pixelsets + real(r8), allocatable :: slp_one (:) + real(r8), allocatable :: asp_one (:) + real(r8), allocatable :: svf_one (:) + real(r8), allocatable :: cur_one (:) + real(r8), allocatable :: area_one (:) + real(r8), allocatable :: sf_one (:) + real(r8), allocatable :: tea_f_azi_one (:,:) + real(r8), allocatable :: tea_b_azi_one (:,:) + real(r8), allocatable :: tea_f_one (:) + real(r8), allocatable :: tea_b_one (:) + logical , allocatable :: sf_mask_one (:) + logical , allocatable :: asp_mask_one (:) + logical , allocatable :: area_mask_one (:) + logical , allocatable :: slp_mask_one (:) + + ! pixelsets of four defined types at each patch + real(r8), allocatable :: asp_type_one (:,:) + real(r8), allocatable :: slp_type_one (:,:) + real(r8), allocatable :: area_type_one (:,:) + + real(r8) :: sum_area_one ! sum of pixel area of a patch + real(r8) :: zenith_angle(num_zenith) ! sine of sun zenith angle (divided by num_zenith part) + + ! Intermediate variables used in reducing the dimensionality of masking factors + real(r8) :: x2_sum + real(r8) :: x_sum + real(r8) :: y_sum + real(r8) :: xy_sum + real(r8) :: a1 ! Function Parameters + real(r8) :: a2 ! Function Parameters + real(r8) :: y(num_zenith) ! shadow factor under a single azimuth and single patch + real(r8) :: x(num_zenith) ! Solar zenith angle used as a predictor + real(r8), allocatable :: y_train(:) ! The part of y used to fit the function + real(r8), allocatable :: x_train(:) ! The part of x used to fit the function + real(r8), allocatable :: y_train_transform(:) ! The transform function of y_train + + ! local variables + integer :: ipatch, i, ps, pe, type, a, z, count_pixels, num_pixels, j, index, n + integer :: wmo_src + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp ! number of land classification +#endif + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate topography factor ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ! ------------------------------------------------------------------- + ! read topography-based factor data + ! ------------------------------------------------------------------- + IF (p_is_io) THEN + lndname = trim(dir_topodata)//"/slope.nc" + CALL allocate_block_data (grid_topo_factor, slp_grid) + CALL ncio_read_block (lndname, 'slope', grid_topo_factor, slp_grid) + + lndname = trim(dir_topodata)//"/aspect.nc" + CALL allocate_block_data (grid_topo_factor, asp_grid) + CALL ncio_read_block (lndname, 'aspect', grid_topo_factor, asp_grid) + + lndname = trim(dir_topodata)//"/terrain_elev_angle_front.nc" + CALL allocate_block_data (grid_topo_factor, tea_f_grid, num_azimuth) + CALL ncio_read_block (lndname, 'tea_front', grid_topo_factor, num_azimuth, tea_f_grid) + + lndname = trim(dir_topodata)//"/terrain_elev_angle_back.nc" + CALL allocate_block_data (grid_topo_factor, tea_b_grid, num_azimuth) + CALL ncio_read_block (lndname, 'tea_back', grid_topo_factor, num_azimuth, tea_b_grid) + + lndname = trim(dir_topodata)//"/sky_view_factor.nc" + CALL allocate_block_data (grid_topo_factor, svf_grid) + CALL ncio_read_block (lndname, 'svf', grid_topo_factor, svf_grid) + + lndname = trim(dir_topodata)//"/curvature.nc" + CALL allocate_block_data (grid_topo_factor, cur_grid) + CALL ncio_read_block (lndname, 'curvature', grid_topo_factor, cur_grid) + + ! -------------------------------------------------------------------------- + ! aggregate the terrain factor data from the resolution of raw data to patch + ! -------------------------------------------------------------------------- +#ifdef USEMPI + ! mpi send + CALL aggregation_data_daemon ( grid_topo_factor, & + data_r8_2d_in1 = slp_grid, data_r8_2d_in2 = asp_grid, & + data_r8_2d_in3 = svf_grid, data_r8_2d_in4 = cur_grid, & + data_r8_3d_in1 = tea_f_grid, n1_r8_3d_in1 = num_azimuth, & + data_r8_3d_in2 = tea_b_grid, n1_r8_3d_in2 = num_azimuth) +#endif + ENDIF + + + IF (p_is_worker) THEN + ! allocate for output variables at patches + allocate (svf_patches (numpatch)) + allocate (cur_patches (numpatch)) + allocate (asp_type_patches (num_slope_type, numpatch)) + allocate (slp_type_patches (num_slope_type, numpatch)) + allocate (area_type_patches(num_slope_type, numpatch)) + allocate (sf_lut_patches (num_azimuth, num_zenith, numpatch)) + ! generate sine of sun zenith angles at equal intervals + DO i = 1, num_zenith + zenith_angle(i) = pi/(2*num_zenith)*(i-1) + ENDDO + + ! aggregate loop + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + svf_patches (ipatch) = svf_patches (wmo_src) + cur_patches (ipatch) = cur_patches (wmo_src) + asp_type_patches (:, ipatch) = asp_type_patches (:, wmo_src) + slp_type_patches (:, ipatch) = slp_type_patches (:, wmo_src) + area_type_patches(:, ipatch) = area_type_patches(:, wmo_src) + sf_lut_patches (:, :, ipatch) = sf_lut_patches(:, :, wmo_src) + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, grid_topo_factor, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = slp_grid, data_r8_2d_out1 = slp_one, & + data_r8_2d_in2 = asp_grid, data_r8_2d_out2 = asp_one, & + data_r8_2d_in3 = svf_grid, data_r8_2d_out3 = svf_one, & + data_r8_2d_in4 = cur_grid, data_r8_2d_out4 = cur_one, & + data_r8_3d_in1 = tea_f_grid, data_r8_3d_out1 = tea_f_azi_one, n1_r8_3d_in1 = num_azimuth, & + data_r8_3d_in2 = tea_b_grid, data_r8_3d_out2 = tea_b_azi_one, n1_r8_3d_in2 = num_azimuth) + + ! ------------------------------------------------------------------ + ! aggregate sky view factor, curvature at patches + ! ------------------------------------------------------------------ + IF (any(svf_one /= -9999.0)) THEN + svf_patches (ipatch) = & + sum(svf_one * area_one, mask = svf_one /= -9999.0) & + / sum(area_one, mask = svf_one /= -9999.0) + ELSE + svf_patches (ipatch) = -1.0e36 + ENDIF + + IF (any(cur_one /= -9999.0)) THEN + cur_patches (ipatch) = & + sum(cur_one * area_one, mask = cur_one /= -9999.0) & + / sum(area_one, mask = cur_one /= -9999.0) + ELSE + cur_patches (ipatch) = -1.0e36 + ENDIF + + ! ------------------------------------------------------------------------------ + ! aggregate look up table of shadow factor at patches + ! ------------------------------------------------------------------------------ + ! number of pixels + num_pixels = size(area_one) + + ! allocate pixel variables + allocate(tea_f_one (num_pixels)) + allocate(tea_b_one (num_pixels)) + allocate(sf_one (num_pixels)) + allocate(sf_mask_one (num_pixels)) + + ! sum of areas of one patch + sum_area_one = sum(area_one, mask = area_one>0) + + DO a = 1, num_azimuth + DO z = 1, num_zenith + ! terrain elevation angle at each azimuth + tea_f_one(:) = tea_f_azi_one(a,:) + tea_b_one(:) = tea_b_azi_one(a,:) + + ! count the pixels which are not missing value + count_pixels = 0 + + DO i = 1, num_pixels + IF ((isnan(tea_f_one(i))).or.(isnan(tea_b_one(i)))) THEN + sf_one(i) = 1 ! Not consider the effect of casting shadows + ELSE + IF (tea_f_one(i)>1) tea_f_one(i) = 1 + IF (tea_f_one(i)<-1) tea_f_one(i) = -1 + IF (tea_b_one(i)>1) tea_b_one(i) = 1 + IF (tea_b_one(i)<-1) tea_b_one(i) = -1 + tea_f_one(i) = asin(tea_f_one(i)) + tea_b_one(i) = asin(tea_b_one(i)) + + ! Compare the sun's altitude angle to the terrain's altitude angle + ! to determine the value of the shadow factor. + ! ----------------------------------------------------------------- + ! Sisi Chen, Lu Li, Yongjiu Dai, et al. Exploring Topography Downscaling + ! Methods for Hyper-Resolution Land Surface Modeling. + ! DOI: 10.22541/au.171403656.68476353/v1 + ! ----------------------------------------------------------------- + IF ((tea_b_one(i) /= -9999).and.(tea_f_one(i) /= -9999)) THEN + count_pixels = count_pixels+1 + + IF (pi*0.5 - zenith_angle(z) < tea_b_one(i)) THEN + sf_one(i) = 0 + ELSEIF (pi*0.5 - zenith_angle(z) > tea_f_one(i)) THEN + sf_one(i) = 1 + ELSE + IF (tea_f_one(i).eq.tea_b_one(i)) tea_f_one(i) = tea_b_one(i)+0.001 + sf_one(i) = (0.5*pi - zenith_angle(z) - tea_b_one(i))/(tea_f_one(i) - tea_b_one(i)) + ENDIF + + ENDIF + ENDIF + ENDDO + sf_mask_one(:) = sf_one(:) /= -9999 + sf_lut_patches(a,z,ipatch) = sum(sf_one(:), mask = sf_mask_one)/count_pixels + ENDDO + ENDDO + + ! deallocate + deallocate(tea_f_one) + deallocate(tea_b_one) + deallocate(sf_one) + deallocate(sf_mask_one) + + ! ----------------------------------------------------------------------------------------------- + ! aggregate slope and aspect at four defined types at patches + ! ----------------------------------------------------------------------------------------------- + ! allocate pixelsets variables + allocate(asp_type_one(1:num_slope_type,1:num_pixels)) + allocate(slp_type_one(1:num_slope_type,1:num_pixels)) + allocate(area_type_one(1:num_slope_type,1:num_pixels)) + allocate(slp_mask_one(1:num_pixels)) + allocate(asp_mask_one(1:num_pixels)) + allocate(area_mask_one(1:num_pixels)) + + DO i = 1, num_slope_type + asp_type_one(i,:) = -9999 + slp_type_one(i,:) = -9999 + area_type_one(i,:) = -9999 + ENDDO + + DO i = 1, num_pixels + ! Define the south slope, north slope, abrupt slope and gentle lope of target pixel + IF (((asp_one(i).ge.0 .and. asp_one(i).le.90*pi/180) .or. (asp_one(i).ge.270*pi/180 .and. & + asp_one(i).le.360*pi/180)).and.(slp_one(i).ge.15*pi/180)) THEN ! north abrupt slope + type = 1 + ELSEIF (((asp_one(i).ge.0 .and. asp_one(i).le.90*pi/180) .or. (asp_one(i).ge.270*pi/180 .and. & + asp_one(i).le.360*pi/180)).and.(slp_one(i)<15*pi/180)) THEN ! north gentle slope + type = 2 + ELSEIF ((asp_one(i).gt.90*pi/180) .and. (asp_one(i).lt.270*pi/180) .and. & + (slp_one(i).ge.15*pi/180)) THEN ! south abrupt slope + type = 3 + ELSEIF ((asp_one(i).gt.90*pi/180) .and. (asp_one(i).lt.270*pi/180) .and. & + (slp_one(i).lt.15*pi/180)) THEN ! south gentle slope + type = 4 + ELSE ! missing value=-9999 + CYCLE + ENDIF + + IF ((area_one(i)>0).and.(area_one(i)<=sum_area_one)) THEN ! quality control + area_type_one(type,i) = area_one(i) + asp_type_one (type,i) = asp_one(i)*area_one(i) + slp_type_one (type,i) = slp_one(i)*area_one(i) + ENDIF + ENDDO + + ! assign value to four types at patches + DO i = 1, num_slope_type + IF (sum_area_one.eq.0.0) THEN + area_type_patches(i,ipatch) = 0 + asp_type_patches(i,ipatch) = 0 + slp_type_patches(i,ipatch) = 0 + ELSE + area_mask_one(:) = area_type_one(i,:) /= -9999 + area_type_patches(i,ipatch) = sum(area_type_one(i,:), mask = area_mask_one(:))/sum_area_one + asp_mask_one(:) = asp_type_one(i,:) /= -9999 + asp_type_patches(i,ipatch) = sum(asp_type_one(i,:), mask = asp_mask_one(:))/sum_area_one + slp_mask_one(:) = slp_type_one(i,:) /= -9999 + slp_type_patches(i,ipatch) = sum(slp_type_one(i,:), mask = slp_mask_one(:))/sum_area_one + ENDIF + ENDDO + + ! deallocate + deallocate(asp_type_one) + deallocate(slp_type_one) + deallocate(area_type_one) + deallocate(slp_mask_one) + deallocate(asp_mask_one) + deallocate(area_mask_one) + ENDDO + + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('svf_patches ', svf_patches ) + CALL check_vector_data ('cur_patches ', cur_patches ) + CALL check_vector_data ('slp_type_patches ', slp_type_patches ) + CALL check_vector_data ('asp_type_patches ', asp_type_patches ) + CALL check_vector_data ('area_type_patches ', area_type_patches) + CALL check_vector_data ('sf_lut_patches ', sf_lut_patches ) +#endif + +! Reduce the dimension of the shadow factor array +! Construct a new array with dimensions of sf_curve_patches(azimuth, shadow factor parameters, patches) + IF (p_is_worker) THEN + allocate(sf_curve_patches(num_azimuth,num_zenith_parameter,numpatch)) + DO a = 1, num_azimuth + DO ipatch = 1, numpatch + y(:) = sf_lut_patches(a,:,ipatch) + x(:) = zenith_angle(:) + + ! Obtain the last position of y==1 + index = 1 + DO z = 1, num_zenith-1 + IF ((y(z)==1.).and.(y(z+1)<1.)) THEN + index = z+1 + ENDIF + ENDDO + + ! allocate Allocate memory to dynamic arrays + n = num_zenith - index +1 + allocate(y_train(n)) + allocate(x_train(n)) + allocate(y_train_transform(n)) + + ! Obtain the predicted value y_train and prediction factor x_train for fitting, + ! the form of the fitting function is + ! ln(-ln(y_train)) = a1*x_train+a2 + y_train(:) = y(index:) + x_train(:) = x(index:) + + ! Transform y_train to enable linear regression fitting + DO i = 1, n + IF (y_train(i) <= 0.) y_train(i) = 0.001 + IF (y_train(i) >= 1.) y_train(i) = 0.999 + ENDDO + y_train_transform(:) = log(-1*log(y_train(:))) + + ! Obtain parameters a1 and a2 using the least squares method + x_sum = 0. + xy_sum = 0. + y_sum = 0. + x2_sum = 0. + DO z = 1, n + xy_sum = xy_sum + x_train(z)*y_train_transform(z) + x_sum = x_sum + x_train(z) + y_sum = y_sum + y_train_transform(z) + x2_sum = x2_sum + x_train(z)*x_train(z) + ENDDO + IF (n*x2_sum - x_sum*x_sum == 0.) THEN + a1 = 0 + a2 = 0 + ELSE + a1 = (n*xy_sum - x_sum*y_sum)/(n*x2_sum - x_sum*x_sum) + a2 = (y_sum - a1*x_sum)/n + ENDIF + sf_curve_patches(a,1,ipatch) = x(index-1) ! Minimum zenith angle at which occlusion begins + sf_curve_patches(a,2,ipatch) = a1 + sf_curve_patches(a,3,ipatch) = a2 + + ! deallocate + deallocate(y_train) + deallocate(x_train) + deallocate(y_train_transform) + ENDDO + ENDDO + ENDIF + + lndname = trim(landdir)//'/svf_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'svf_patches', 'patch', landpatch, svf_patches, 1) + + lndname = trim(landdir)//'/cur_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'cur_patches', 'patch', landpatch, cur_patches, 1) + + lndname = trim(landdir)//'/slp_type_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_slope_type) + CALL ncio_write_vector (lndname, 'slp_type_patches', 'slope_type', num_slope_type, 'patch', landpatch, slp_type_patches, 1) + + lndname = trim(landdir)//'/asp_type_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_slope_type) + CALL ncio_write_vector (lndname, 'asp_type_patches', 'slope_type', num_slope_type, 'patch', landpatch, asp_type_patches, 1) + + lndname = trim(landdir)//'/area_type_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_slope_type) + CALL ncio_write_vector (lndname, 'area_type_patches', 'slope_type', num_slope_type, 'patch', landpatch, area_type_patches, 1) + + lndname = trim(landdir)//'/sf_curve_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_define_dimension_vector (lndname, landpatch, 'azimuth', num_azimuth) + CALL ncio_define_dimension_vector (lndname, landpatch, 'zenith_p', num_zenith_parameter) + CALL ncio_write_vector (lndname, 'sf_curve_patches', 'azimuth', num_azimuth, 'zenith_p', num_zenith_parameter, 'patch', & + landpatch, sf_curve_patches, 1) + +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + + ! only write the first type of slope and aspect at patches + lndname = trim(dir_model_landdata) // '/diag/topo_factor_slp_' // trim(cyear) // '.nc' + DO i = 1, num_slope_type + write(sdir,'(I0)') i + CALL srfdata_map_and_write (slp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'slp_'//trim(sdir), compress = 1, write_mode = 'one') + ENDDO + + lndname = trim(dir_model_landdata) // '/diag/topo_factor_asp_' // trim(cyear) // '.nc' + DO i = 1, num_slope_type + write(sdir,'(I0)') i + CALL srfdata_map_and_write (asp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'asp_'//trim(sdir), compress = 1, write_mode = 'one') + ENDDO + + lndname = trim(dir_model_landdata) // '/diag/topo_factor_svf_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (svf_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'svf', compress = 1, write_mode = 'one') + + lndname = trim(dir_model_landdata) // '/diag/topo_factor_cur_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (cur_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'cur', compress = 1, write_mode = 'one') + + lndname = trim(dir_model_landdata) // '/diag/topo_factor_sf_lut_' // trim(cyear) // '.nc' + + DO j = 1, num_azimuth + DO i = 1, num_zenith + write(sdir,'(I0)') j + write(sdir1,'(I0)') i + CALL srfdata_map_and_write (sf_lut_patches(j,i,:), landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'sf_'//trim(sdir)//'_'//trim(sdir1), compress = 1, write_mode = 'one') + ENDDO + ENDDO +#endif + + IF (p_is_worker) THEN + IF (allocated(slp_type_patches)) deallocate ( slp_type_patches ) + IF (allocated(asp_type_patches)) deallocate ( asp_type_patches ) + IF (allocated(sf_lut_patches )) deallocate ( sf_lut_patches ) + IF (allocated(sf_curve_patches)) deallocate ( sf_curve_patches ) + IF (allocated(svf_patches )) deallocate ( svf_patches ) + IF (allocated(cur_patches )) deallocate ( cur_patches ) + ENDIF + +END SUBROUTINE Aggregation_TopographyFactors diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 new file mode 100644 index 0000000000..1eea5400f4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 @@ -0,0 +1,242 @@ +#include + +SUBROUTINE Aggregation_TopographyFactors_Simple ( & + grid_topo_factor , dir_topodata, dir_model_landdata, lc_year) +!----------------------------------------------------------------------- +! Global topography-based factors data +! +! Created by Sisi Chen, 08/2025 +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_AggregationRequestData + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_Mesh, only: numelm + USE MOD_LandElm + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + ! arguments: + ! --------------------------------------------------------------- + integer, intent(in) :: lc_year + type(grid_type), intent(in) :: grid_topo_factor ! Grid structure for high resolution topography factors + character(len=*), intent(in) :: dir_topodata ! Direct of Rawdata + character(len=*), intent(in) :: dir_model_landdata + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: landdir, lndname, cyear + character(len=3) :: sdir, sdir1 + integer :: wmo_src + + type (block_data_real8_3d) :: slp_grid ! slope + type (block_data_real8_3d) :: asp_grid ! aspect + type (block_data_real8_2d) :: cur_grid ! curvature + + ! patch + real(r8), allocatable :: cur_patches (:) + + ! nine defined types at all patches + real(r8), allocatable :: asp_type_patches (:,:) ! shape as (type, patches) + real(r8), allocatable :: slp_type_patches (:,:) + + ! pixelsets + real(r8), allocatable :: cur_one (:) + real(r8), allocatable :: area_one (:) + + ! pixelsets of nine defined types at each patch + real(r8), allocatable :: slp_one (:,:) + real(r8), allocatable :: asp_one (:,:) + + ! local variables + integer :: ipatch, i + +#ifdef SrfdataDiag + integer :: typpatch(N_land_classification+1), ityp ! number of land classification +#endif + write(cyear,'(i4.4)') lc_year + landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Aggregate topography factor ...' + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ! ------------------------------------------------------------------- + ! read topography-based factor data + ! ------------------------------------------------------------------- + IF (p_is_io) THEN + lndname = trim(dir_topodata)//"/topography_MERITHydro.nc" + CALL allocate_block_data (grid_topo_factor, slp_grid, num_aspect_type) + CALL ncio_read_block (lndname, 'slp_aspect', grid_topo_factor, num_aspect_type, slp_grid) + + lndname = trim(dir_topodata)//"/topography_MERITHydro.nc" + CALL allocate_block_data (grid_topo_factor, asp_grid, num_aspect_type) + CALL ncio_read_block (lndname, 'pct_aspect', grid_topo_factor, num_aspect_type, asp_grid) + + lndname = trim(dir_topodata)//"/curvature_MERITHydro.nc" + CALL allocate_block_data (grid_topo_factor, cur_grid) + CALL ncio_read_block (lndname, 'curvature', grid_topo_factor, cur_grid) + + ! -------------------------------------------------------------------------- + ! aggregate the terrain factor data from the resolution of raw data to patch + ! -------------------------------------------------------------------------- +#ifdef USEMPI + ! mpi send + CALL aggregation_data_daemon ( grid_topo_factor, & + data_r8_2d_in1 = cur_grid, & + data_r8_3d_in1 = slp_grid, n1_r8_3d_in1 = num_aspect_type, & + data_r8_3d_in2 = asp_grid, n1_r8_3d_in2 = num_aspect_type) +#endif + ENDIF + + + IF (p_is_worker) THEN + ! allocate for output variables at patches + allocate (cur_patches (numpatch)) + allocate (asp_type_patches (num_aspect_type, numpatch)) + allocate (slp_type_patches (num_aspect_type, numpatch)) + + ! aggregate loop + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + wmo_src = wmo_source (landpatch%ielm(ipatch)) + + cur_patches ( ipatch) = cur_patches ( wmo_src) + asp_type_patches(:,ipatch) = asp_type_patches(:,wmo_src) + slp_type_patches(:,ipatch) = slp_type_patches(:,wmo_src) + + CYCLE + ENDIF + + CALL aggregation_request_data (landpatch, ipatch, grid_topo_factor, & + zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = cur_grid, data_r8_2d_out1 = cur_one, & + data_r8_3d_in1 = slp_grid, data_r8_3d_out1 = slp_one, n1_r8_3d_in1 = num_aspect_type, & + data_r8_3d_in2 = asp_grid, data_r8_3d_out2 = asp_one, n1_r8_3d_in2 = num_aspect_type) + + ! ------------------------------------------------------------------ + ! aggregate curvature at patches + ! ------------------------------------------------------------------ + + IF (any(cur_one /= -9999.0)) THEN + cur_patches (ipatch) = & + sum(cur_one * area_one, mask = cur_one /= -9999.0) & + / sum(area_one, mask = cur_one /= -9999.0) + ELSE + cur_patches (ipatch) = -1.0e36 + ENDIF + + ! ------------------------------------------------------------------ + ! aggregate slope and aspect at each direction of aspect of patches. + ! num_aspect_type = 1:north, 2:northeast, 3:east, 4:southeast, 5:south, 6:southwest, 7:west, 8:northwest, 9:flat + ! ------------------------------------------------------------------ + DO i = 1, num_aspect_type + IF (any(asp_one(i,:) /= -9999.0)) THEN + asp_type_patches (i, ipatch) = & + sum(asp_one(i,:) * area_one(:), mask = asp_one(i,:) /= -9999.0) & + / sum(area_one, mask = asp_one(i,:) /= -9999.0) + ELSE + asp_type_patches (i, ipatch) = -1.0e36 + ENDIF + IF (any(slp_one(i,:) /= -9999.0)) THEN + slp_type_patches (i, ipatch) = & + sum(slp_one(i,:) * area_one(:), mask = slp_one(i,:) /= -9999.0) & + / sum(area_one, mask = slp_one(i,:) /= -9999.0) + ELSE + slp_type_patches (i, ipatch) = -1.0e36 + ENDIF + + ENDDO + + ENDDO + + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('cur_patches ', cur_patches ) + CALL check_vector_data ('slp_type_patches ', slp_type_patches ) + CALL check_vector_data ('asp_type_patches ', asp_type_patches ) +#endif + + ! -------------------------------------------------------------------------- + ! write aggregated data to netcdf files + ! -------------------------------------------------------------------------- + + lndname = trim(landdir)//'/cur_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'cur_patches', 'patch', landpatch, cur_patches, 1) + + lndname = trim(landdir)//'/slp_type_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_aspect_type) + CALL ncio_write_vector (lndname, 'slp_type_patches', 'slope_type', num_aspect_type, 'patch', landpatch, slp_type_patches, 1) + + lndname = trim(landdir)//'/asp_type_patches.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_aspect_type) + CALL ncio_write_vector (lndname, 'asp_type_patches', 'slope_type', num_aspect_type, 'patch', landpatch, asp_type_patches, 1) + + ! -------------------------------------------------------------------------- +#ifdef SrfdataDiag + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + + ! only write the first type of slope and aspect at patches + lndname = trim(dir_model_landdata) // '/diag/topo_factor_slp_' // trim(cyear) // '.nc' + DO i = 1, num_aspect_type + write(sdir,'(I0)') i + CALL srfdata_map_and_write (slp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'slp_'//trim(sdir), compress = 1, write_mode = 'one') + ENDDO + + lndname = trim(dir_model_landdata) // '/diag/topo_factor_asp_' // trim(cyear) // '.nc' + DO i = 1, num_aspect_type + write(sdir,'(I0)') i + CALL srfdata_map_and_write (asp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'asp_'//trim(sdir), compress = 1, write_mode = 'one') + ENDDO + + ! write curvature at patches + lndname = trim(dir_model_landdata) // '/diag/topo_factor_cur_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (cur_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, 'cur', compress = 1, write_mode = 'one') + +#endif + + IF (p_is_worker) THEN + IF (allocated(slp_type_patches)) deallocate ( slp_type_patches ) + IF (allocated(asp_type_patches)) deallocate ( asp_type_patches ) + IF (allocated(cur_patches )) deallocate ( cur_patches ) + ENDIF + +END SUBROUTINE Aggregation_TopographyFactors_Simple diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 new file mode 100644 index 0000000000..8dd0d9d677 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 @@ -0,0 +1,1293 @@ +#include + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Aggregate/screen high-resolution urban dataset to a lower +! resolution/subset data, suitable for running regional or point +! cases. +! +! Original authors: Hua Yuan and Wenzong Dong, 2021, OpenMP version. +! +! !REVISIONS: +! 05/2023, Wenzong Dong, Hua Yuan, Shupeng Zhang: porting codes to MPI +! parallel version. +! +! 08/2025, Wenzong Dong, Hua Yuan: unifying the urban surface data +! code for different urban type schemes. +!----------------------------------------------------------------------- + +#ifdef URBAN_MODEL +SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & + grid_urban_5km, grid_urban_500m) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_AggregationRequestData + USE MOD_5x5DataReadin + USE MOD_DataType + USE MOD_Utils, only: num_max_frequency + USE MOD_LandUrban + USE MOD_LandElm + USE MOD_Mesh + USE MOD_Vars_Global, only: N_URB, nl_roof, nl_wall, nl_soil + USE MOD_Urban_Const_LCZ +#ifdef RangeCheck + USE MOD_RangeCheck +#endif +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif + + IMPLICIT NONE + + character(len=256), intent(in) :: dir_rawdata + character(len=256), intent(in) :: dir_srfdata + + integer , intent(in) :: lc_year + + type(grid_type), intent(in) :: grid_urban_5km + !type(grid_type), intent(in) :: grid_urban_100m + type(grid_type), intent(in) :: grid_urban_500m + + ! dimensions + integer, parameter :: rid = 33 + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + + ! input variables + type(block_data_int32_2d) :: LUCY_reg + type(block_data_real8_2d) :: pop + type(block_data_real8_2d) :: fvegu + type(block_data_real8_2d) :: htopu + type(block_data_real8_2d) :: flakeu + type(block_data_real8_2d) :: wtroof + type(block_data_real8_2d) :: htroof + type(block_data_real8_2d) :: ulai + type(block_data_real8_2d) :: usai + type(block_data_int32_2d) :: reg_typid + + ! output variables + integer , ALLOCATABLE, dimension(:) :: LUCY_rid + real(r8), ALLOCATABLE, dimension(:) :: pop_den + real(r8), ALLOCATABLE, dimension(:) :: pct_tree + real(r8), ALLOCATABLE, dimension(:) :: htop_urb + real(r8), ALLOCATABLE, dimension(:) :: pct_water + real(r8), ALLOCATABLE, dimension(:) :: wt_roof + real(r8), ALLOCATABLE, dimension(:) :: ht_roof + real(r8), ALLOCATABLE, dimension(:) :: lai_urb + real(r8), ALLOCATABLE, dimension(:) :: sai_urb + + ! delete variables not used + integer , allocatable, dimension(:) :: reg_typid_one + integer , allocatable, dimension(:) :: LUCY_reg_one + real(r8), allocatable, dimension(:) :: area_one + real(r8), allocatable, dimension(:) :: pop_one + real(r8), allocatable, dimension(:) :: fvegu_one + real(r8), allocatable, dimension(:) :: htopu_one + real(r8), allocatable, dimension(:) :: flakeu_one + real(r8), allocatable, dimension(:) :: wt_roof_one + real(r8), allocatable, dimension(:) :: ht_roof_one + real(r8), allocatable, dimension(:) :: hlr_bld_one + real(r8), allocatable, dimension(:) :: ulai_one + real(r8), allocatable, dimension(:) :: slai_one + + ! urban morphological and thermal paras of NCAR data + ! input variables, NCAR look-up-table data + real(r8), allocatable, dimension(:,:) :: hwrbld_ncar , fgper_ncar , & + htroof_ncar , wtroof_ncar + real(r8), allocatable, dimension(:,:) :: emroof_ncar , emwall_ncar , & + emgimp_ncar , emgper_ncar + real(r8), allocatable, dimension(:,:) :: thkroof_ncar, thkwall_ncar, & + tbldmin_ncar, tbldmax_ncar + real(r8), allocatable, dimension(:,:,:) :: cvroof_ncar , cvwall_ncar , cvgimp_ncar , & + tkroof_ncar , tkwall_ncar , tkgimp_ncar + real(r8), allocatable, dimension(:,:,:,:) :: albroof_ncar, albwall_ncar, & + albgimp_ncar, albgper_ncar + + ! output variables, vector data + real(r8), ALLOCATABLE, dimension(:) :: area_urb + real(r8), ALLOCATABLE, dimension(:) :: sarea_urb + real(r8), ALLOCATABLE, dimension(:) :: urb_pct + + real(r8), ALLOCATABLE, dimension(:) :: hlr_bld + real(r8), ALLOCATABLE, dimension(:) :: fgper + real(r8), ALLOCATABLE, dimension(:) :: em_roof + real(r8), ALLOCATABLE, dimension(:) :: em_wall + real(r8), ALLOCATABLE, dimension(:) :: em_gimp + real(r8), ALLOCATABLE, dimension(:) :: em_gper + real(r8), ALLOCATABLE, dimension(:) :: thk_roof + real(r8), ALLOCATABLE, dimension(:) :: thk_wall + real(r8), ALLOCATABLE, dimension(:) :: tbld_min + real(r8), ALLOCATABLE, dimension(:) :: tbld_max + + real(r8), ALLOCATABLE, dimension(:,:) :: cv_wgt + real(r8), ALLOCATABLE, dimension(:,:) :: tk_wgt + real(r8), ALLOCATABLE, dimension(:,:) :: cv_roof + real(r8), ALLOCATABLE, dimension(:,:) :: cv_wall + real(r8), ALLOCATABLE, dimension(:,:) :: cv_gimp + real(r8), ALLOCATABLE, dimension(:,:) :: tk_roof + real(r8), ALLOCATABLE, dimension(:,:) :: tk_wall + real(r8), ALLOCATABLE, dimension(:,:) :: tk_gimp + + real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_roof + real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_wall + real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_gimp + real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_gper + + integer , allocatable, dimension(:) :: locpth + + ! landfile variables + character(len=256) landsrfdir, landdir, landname, suffix + character(len=4 ) cyear, c5year, cmonth, clay, c1, iyear + + ! local vars + real(r8) :: sumarea + real(r8) :: hlrbld, fgper_, thkroof, thkwall, tbldmin, tbldmax + real(r8) :: emroof, emwall, emgper , emgimp + real(r8) :: cvroof(nl_roof), cvwall(nl_wall), cvgimp(nl_soil) + real(r8) :: tkroof(nl_roof), tkwall(nl_wall), tkgimp(nl_soil) + real(r8) :: albroof(nr,ns), albwall(nr,ns), albgper(nr,nr), albgimp(nr,ns) + + ! index + integer :: iurban, urb_typidx, urb_regidx + integer :: pop_i, imonth, start_year, end_year + integer :: ipth, ipxl, il, iy, ielm, numpth, urb_s, urb_e + + ! for surface data diag +#ifdef SrfdataDiag + integer :: ityp + integer , allocatable, dimension(:) :: typindex + real(r8), allocatable :: LUCY_rid_r8 (:) +#endif + logical :: first_call_LSAI_urban + +#ifdef SrfdataDiag + allocate( typindex(N_URB) ) +#endif + + write(cyear,'(i4.4)') lc_year + landsrfdir = trim(dir_srfdata) // '/urban/' // trim(cyear) + + first_call_LSAI_urban = .true. + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Making urban data ('//trim(cyear)//') ...' + CALL system('mkdir -p ' // trim(adjustl(landsrfdir))) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + write(c5year, '(i4.4)') int(lc_year/5)*5 + + + ! ******* Building morphology: WT_ROOF, HT_ROOF, and HL ******* + ! if building data is missing, how to use look-up-table? + ! a new array with urban type was used for look-up-table +IF (DEF_URBAN_type_scheme == 1) THEN + ! only used when urban patch have nan data of building height, building fraction and HL + landname = TRIM(dir_rawdata)//'urban/NCAR_urban_properties.nc' + + CALL ncio_read_bcast_serial (landname, "WTLUNIT_ROOF", wtroof_ncar ) + CALL ncio_read_bcast_serial (landname, "HT_ROOF" , htroof_ncar ) + CALL ncio_read_bcast_serial (landname, "CANYON_HWR" , hwrbld_ncar ) +ENDIF + + ! allocate and read grided building height and fraction raw data + IF (p_is_io) THEN + CALL allocate_block_data (grid_urban_500m, reg_typid) + CALL allocate_block_data (grid_urban_500m, wtroof ) + CALL allocate_block_data (grid_urban_500m, htroof ) + +IF (DEF_URBAN_type_scheme == 1) THEN + landdir = TRIM(dir_rawdata)//'urban_type/' + suffix = 'URBTYP' + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "REGION_ID", reg_typid) +ENDIF + + landdir = TRIM(dir_rawdata)//'/urban/' + suffix = 'URBSRF'//trim(c5year) +IF (DEF_Urban_geom_data == 1) THEN + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_ROOF_GHSL", wtroof) + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HT_ROOF_GHSL" , htroof) +ELSE + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_ROOF_Li", wtroof) + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HT_ROOF_Li" , htroof) +ENDIF + +#ifdef USEMPI +IF (DEF_URBAN_type_scheme == 1) THEN + CALL aggregation_data_daemon (grid_urban_500m, data_i4_2d_in1 = reg_typid, & + data_r8_2d_in1 = wtroof, data_r8_2d_in2 = htroof) +ELSE + CALL aggregation_data_daemon (grid_urban_500m, data_r8_2d_in1 = wtroof, data_r8_2d_in2 = htroof) +ENDIF +#endif + ENDIF + + IF (p_is_worker) THEN + allocate (wt_roof (numurban)) + allocate (ht_roof (numurban)) + allocate (hlr_bld (numurban)) + + ! loop for urban patch to aggregate building height and fraction data with area-weighted average + DO iurban = 1, numurban + + ! when urban patch has no data, use table data to fill gap + ! urban type and region id for look-up-table + urb_typidx = landurban%settyp(iurban) + +IF (DEF_URBAN_type_scheme == 1) THEN + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & + data_i4_2d_in1 = reg_typid, data_i4_2d_out1 = reg_typid_one, & + data_r8_2d_in1 = wtroof, data_r8_2d_out1 = wt_roof_one, & + data_r8_2d_in2 = htroof, data_r8_2d_out2 = ht_roof_one) + + IF (.not. allocated(hlr_bld_one)) THEN + allocate (hlr_bld_one (size(area_one))) + hlr_bld_one = 0. + ELSE + deallocate (hlr_bld_one) + allocate (hlr_bld_one (size(area_one))) + hlr_bld_one = 0. + ENDIF + + ! RG_-45_65_-50_70 of NCAR has no urban data, + ! all urban patches of this area are assigned to region 30 + IF (all(reg_typid_one==0)) THEN + reg_typid_one(:) = 30 + ENDIF + + IF (any(reg_typid_one==0)) THEN + WHERE(reg_typid_one==0) reg_typid_one = num_max_frequency(reg_typid_one) + ENDIF + + WHERE (wt_roof_one <= 0) + wt_roof_one = wtroof_ncar(urb_typidx,reg_typid_one) + END WHERE + + WHERE (ht_roof_one <= 0) + ht_roof_one = htroof_ncar(urb_typidx,reg_typid_one) + END WHERE + +IF (DEF_USE_CANYON_HWR) THEN + WHERE (hlr_bld_one <= 0) + hlr_bld_one = hwrbld_ncar(urb_typidx,reg_typid_one) + END WHERE +ELSE + WHERE (hlr_bld_one <= 0) + hlr_bld_one = hwrbld_ncar(urb_typidx,reg_typid_one) & + *(1-sqrt(wtroof_ncar(urb_typidx,reg_typid_one))) & + /sqrt(wtroof_ncar(urb_typidx,reg_typid_one)) + END WHERE +ENDIF + +ELSE IF (DEF_URBAN_type_scheme == 2) THEN + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = wtroof, data_r8_2d_out1 = wt_roof_one, & + data_r8_2d_in2 = htroof, data_r8_2d_out2 = ht_roof_one) + + IF (.not. allocated(hlr_bld_one)) THEN + allocate (hlr_bld_one (size(area_one))) + hlr_bld_one = 0. + ELSE + deallocate (hlr_bld_one) + allocate (hlr_bld_one (size(area_one))) + hlr_bld_one = 0. + ENDIF + + WHERE (wt_roof_one <= 0) + wt_roof_one = wtroof_lcz(urb_typidx) + END WHERE + + WHERE (ht_roof_one <= 0) + ht_roof_one = htroof_lcz(urb_typidx) + END WHERE + +IF (DEF_USE_CANYON_HWR) THEN + WHERE (hlr_bld_one <= 0) + hlr_bld_one = hwrbld_lcz(urb_typidx) + END WHERE +ELSE + WHERE (hlr_bld_one <= 0) + hlr_bld_one = hwrbld_lcz(urb_typidx) & + *(1-sqrt(wtroof_lcz(urb_typidx))) & + /sqrt(wtroof_lcz(urb_typidx)) + END WHERE +ENDIF + +ENDIF + ! area-weight average + wt_roof(iurban) = sum(wt_roof_one * area_one) / sum(area_one) + ht_roof(iurban) = sum(ht_roof_one * area_one) / sum(area_one) + hlr_bld(iurban) = sum(hlr_bld_one * area_one) / sum(area_one) + +IF (DEF_USE_CANYON_HWR) THEN + ! IF the parameter read is canyon H/W ratio, convert it to H/R ratio + hlr_bld(iurban) = hlr_bld(iurban)*(1-sqrt(wt_roof(iurban)))/sqrt(wt_roof(iurban)) +ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/WT_ROOF.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'WT_ROOF', 'urban', landurban, wt_roof, DEF_Srfdata_CompressLevel) + + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/HT_ROOF.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'HT_ROOF', 'urban', landurban, ht_roof, DEF_Srfdata_CompressLevel) + + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/HLR_BLD.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'BUILDING_HLR' , 'urban', landurban, hlr_bld, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/ht_roof_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (ht_roof, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'HT_ROOF', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) + + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/wt_roof_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (wt_roof, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'WT_ROOF', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) + + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/hlr_bld_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (wt_roof, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'BUILDING_HLR', compress = 0, write_mode = 'one', defval=0._r8, create_mode = .true.) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('Urban Roof Fraction ', wt_roof) + CALL check_vector_data ('Urban Roof Height ' , ht_roof) + CALL check_vector_data ('Urban Building HLR ' , hlr_bld) +#endif + + + ! ******* Tree : PCT_Tree, HTOP ******* + ! allocate and read the grided tree cover and tree height raw data(500m) + ! NOTE, tree cover raw data is available every five years, + ! tree height raw data is same from year to year + IF (p_is_io) THEN + + landdir = TRIM(dir_rawdata)//'/urban/' + suffix = 'URBSRF'//trim(c5year) + + CALL allocate_block_data (grid_urban_500m, fvegu) + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_Tree", fvegu) + + CALL allocate_block_data (grid_urban_500m, htopu) + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HTOP", htopu) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_urban_500m, & + data_r8_2d_in1 = fvegu, data_r8_2d_in2 = htopu) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (pct_tree(numurban)) + allocate (htop_urb(numurban)) + + pct_tree(:) = 0. + htop_urb(:) = 0. + + ! loop for urban patch to aggregate tree cover and height data with area-weighted average + DO iurban = 1, numurban + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = fvegu, data_r8_2d_out1 = fvegu_one, & + data_r8_2d_in2 = htopu, data_r8_2d_out2 = htopu_one) + + ! missing tree cover and tree height data (-999) were filtered + WHERE (fvegu_one < 0) + area_one = 0 + END WHERE + + WHERE (htopu_one < 0) + area_one = 0 + END WHERE + + ! area-weighted average + IF (sum(area_one) > 0._r8) THEN + ! print*, sum(area_one) + pct_tree(iurban) = sum(fvegu_one * area_one) / sum(area_one) + htop_urb(iurban) = sum(htopu_one * area_one) / sum(area_one) + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/PCT_Tree.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'PCT_Tree', 'urban', landurban, pct_tree, DEF_Srfdata_CompressLevel) + + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/htop_urb.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'URBAN_TREE_TOP', 'urban', landurban, htop_urb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/pct_urban_tree_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (pct_tree, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'PCT_Urban_Tree', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) + + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/htop_urban_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (htop_urb, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'Urban_Tree_HTOP', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('Urban Tree Cover ', pct_tree) + CALL check_vector_data ('Urban Tree Top ' , htop_urb) +#endif + + + ! ******* LAI, SAI ******* +#ifndef LULCC +IF (DEF_LAI_CHANGE_YEARLY) THEN + start_year = max(DEF_LAI_START_YEAR, DEF_simulation_time%start_year) + end_year = min(DEF_LAI_END_YEAR, DEF_simulation_time%end_year ) +ELSE + start_year = lc_year + end_year = lc_year +ENDIF +#else + start_year = lc_year + end_year = lc_year +#endif + + IF (p_is_io) THEN + CALL allocate_block_data (grid_urban_500m, ulai) + CALL allocate_block_data (grid_urban_500m, usai) + ENDIF + + IF (p_is_worker) THEN + allocate (lai_urb (numurban)) + allocate (sai_urb (numurban)) + + lai_urb(:) = 0. + sai_urb(:) = 0. + ENDIF + + DO iy = start_year, end_year + + IF (iy < 2000) THEN + write(iyear,'(i4.4)') 2000 + ELSE + write(iyear,'(i4.4)') iy + ENDIF + + landsrfdir = trim(dir_srfdata) // '/urban/' // trim(iyear) // '/LAI' + CALL system('mkdir -p ' // trim(adjustl(landsrfdir))) + + ! allocate and read grided LSAI raw data + landdir = trim(dir_rawdata)//'/urban_lai_500m/' + suffix = 'URBLAI_'//trim(iyear) + + ! loop for month + DO imonth = 1, 12 + + write(cmonth, '(i2.2)') imonth + + IF (p_is_master) THEN + write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate LAI&SAI :', iy, ':', imonth, '/', 12 + ENDIF + + IF (p_is_io) THEN + + CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "URBAN_TREE_LAI", imonth, ulai) + CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "URBAN_TREE_SAI", imonth, usai) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_urban_500m, & + data_r8_2d_in1 = fvegu, data_r8_2d_in2 = ulai, data_r8_2d_in3 = usai) +#endif + ENDIF + + IF (p_is_worker) THEN + + ! loop for urban patch to aggregate LSAI data + DO iurban = 1, numurban + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = fvegu, data_r8_2d_out1 = fvegu_one, & + data_r8_2d_in2 = ulai , data_r8_2d_out2 = ulai_one , & + data_r8_2d_in3 = usai , data_r8_2d_out3 = slai_one ) + + WHERE (fvegu_one < 0) + area_one = 0 + END WHERE + + ! area-weight average + IF (sum(fvegu_one * area_one) > 0) THEN + lai_urb(iurban) = sum(ulai_one * fvegu_one * area_one) / & + sum(fvegu_one * area_one) + sai_urb(iurban) = sum(slai_one * fvegu_one * area_one) / & + sum(fvegu_one * area_one) + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(iyear)//'/LAI/urban_LAI_'//trim(cmonth)//'.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'TREE_LAI', 'urban', landurban, lai_urb, DEF_Srfdata_CompressLevel) + + landname = trim(dir_srfdata) // '/urban/'//trim(iyear)//'/LAI/urban_SAI_'//trim(cmonth)//'.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'TREE_SAI', 'urban', landurban, sai_urb, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/LAI_urban_'//trim(iyear)//'.nc' + CALL srfdata_map_and_write (lai_urb, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'Urban_Tree_LAI', compress = 0, write_mode = 'one', & + lastdimname = 'Itime', lastdimvalue = imonth, defval = 0._r8, create_mode = first_call_LSAI_urban) + + landname = trim(dir_srfdata) // '/diag/SAI_urban_'//trim(iyear)//'.nc' + CALL srfdata_map_and_write (sai_urb, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'Urban_Tree_SAI', compress = 0, write_mode = 'one', & + lastdimname = 'Itime', lastdimvalue = imonth, defval = 0._r8, create_mode = first_call_LSAI_urban) + + IF (first_call_LSAI_urban) first_call_LSAI_urban = .false. +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + write(c1,'(i2.2)') imonth + +#ifdef RangeCheck + CALL check_vector_data ('Urban Tree LAI '//trim(c1), lai_urb) + CALL check_vector_data ('Urban Tree SAI '//trim(c1), sai_urb) +#endif + ENDDO + first_call_LSAI_urban = .true. + ENDDO + + + ! ******* PCT_Water ******* + ! allocate and read grided water cover raw data + IF (p_is_io) THEN + + CALL allocate_block_data (grid_urban_500m, flakeu) + + landdir = TRIM(dir_rawdata)//'/urban/' + suffix = 'URBSRF'//trim(c5year) + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_Water", flakeu) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_urban_500m, flakeu) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (pct_water (numurban)) + + pct_water (:) = 0. + ! loop for urban patch to aggregate water cover data with area-weighted average + DO iurban = 1, numurban + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_2d_in1 = flakeu, data_r8_2d_out1 = flakeu_one) + + WHERE (flakeu_one < 0) + area_one = 0 + END WHERE + ! only calculate when urban patch have water cover + IF (sum(area_one) > 0) THEN + pct_water(iurban) = sum(flakeu_one * area_one) / sum(area_one) + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/PCT_Water.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'PCT_Water', 'urban', landurban, pct_water, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/pct_urban_water_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (pct_water, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'PCT_Urban_Water', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('Urban Water Cover ', pct_water) +#endif + + + ! ******* LUCY_id ******* + ! allocate and read the LUCY id + IF (p_is_io) THEN + + landname = TRIM(dir_rawdata)//'urban/LUCY_regionid.nc' + CALL allocate_block_data (grid_urban_5km, LUCY_reg) + CALL ncio_read_block (landname, 'LUCY_REGION_ID', grid_urban_5km, LUCY_reg) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_urban_5km, data_i4_2d_in1 = LUCY_reg) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate ( LUCY_rid (numurban)) + + LUCY_rid (:) = 0 + + ! loop for each urban patch to get the LUCY id of all fine grid + ! of iurban patch, then assign the most frequency id to this urban patch + DO iurban = 1, numurban + + CALL aggregation_request_data (landurban, iurban, grid_urban_5km, & + zip = USE_zip_for_aggregation, & + data_i4_2d_in1 = LUCY_reg, data_i4_2d_out1 = LUCY_reg_one) + ! the most frequency id to this urban patch + LUCY_rid(iurban) = num_max_frequency (LUCY_reg_one) + ENDDO +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/LUCY_region_id.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'LUCY_id', 'urban', landurban, LUCY_rid, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/LUCY_region_id_'//trim(cyear)//'.nc' + + IF (allocated(LUCY_rid)) THEN + allocate (LUCY_rid_r8 (size(LUCY_rid))) + LUCY_rid_r8 = real(LUCY_rid, r8) + ENDIF + + CALL srfdata_map_and_write (LUCY_rid_r8, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'LUCY_id', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('LUCY_ID ', LUCY_rid) +#endif + + + ! ******* POP_DEN ******* + ! allocate and read the grided population raw data(500m) + ! NOTE, the population is year-by-year + IF (p_is_io) THEN + + CALL allocate_block_data (grid_urban_500m, pop) + + landdir = TRIM(dir_rawdata)//'/urban/' + suffix = 'URBSRF'//trim(c5year) + + ! population data is year by year, + ! so pop_i is calculated to determine the dimension of POP data reads + IF (mod(lc_year,5) == 0) THEN + pop_i = 1 + ELSE + pop_i = 5 - (ceiling(lc_year*1./5.)*5 - lc_year) + 1 + ENDIF + + ! read the population data of total 5x5 region + CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "POP_DEN", pop_i, pop) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_urban_500m, data_r8_2d_in1 = pop) +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (pop_den (numurban)) + + pop_den (:) = 0. + + ! loop for urban patch to aggregate population data with area-weighted average + DO iurban = 1, numurban + ! request all fine grid data and area of the iurban urban patch + ! a one dimension vector will be returned + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = pop, data_r8_2d_out1 = pop_one) + + WHERE (pop_one < 0) + area_one = 0 + END WHERE + ! area-weighted average + IF (sum(area_one) > 0._r8) THEN + pop_den(iurban) = sum(pop_one * area_one) / sum(area_one) + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/POP.nc' + CALL ncio_create_file_vector (landname, landurban) + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_write_vector (landname, 'POP_DEN', 'urban', landurban, pop_den, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/population_urban_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (pop_den, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'POP_DEN', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('POP_DEN ', pop_den) +#endif + + +IF (DEF_URBAN_type_scheme == 1) THEN + ! look up table of NCAR urban properties (using look-up tables) + landname = TRIM(dir_rawdata)//'urban/NCAR_urban_properties.nc' + + CALL ncio_read_bcast_serial (landname, "WTROAD_PERV" , fgper_ncar ) + CALL ncio_read_bcast_serial (landname, "EM_ROOF" , emroof_ncar ) + CALL ncio_read_bcast_serial (landname, "EM_WALL" , emwall_ncar ) + CALL ncio_read_bcast_serial (landname, "EM_IMPROAD" , emgimp_ncar ) + CALL ncio_read_bcast_serial (landname, "EM_PERROAD" , emgper_ncar ) + CALL ncio_read_bcast_serial (landname, "ALB_ROOF" , albroof_ncar) + CALL ncio_read_bcast_serial (landname, "ALB_WALL" , albwall_ncar) + CALL ncio_read_bcast_serial (landname, "ALB_IMPROAD" , albgimp_ncar) + CALL ncio_read_bcast_serial (landname, "ALB_PERROAD" , albgper_ncar) + CALL ncio_read_bcast_serial (landname, "TK_ROOF" , tkroof_ncar ) + CALL ncio_read_bcast_serial (landname, "TK_WALL" , tkwall_ncar ) + CALL ncio_read_bcast_serial (landname, "TK_IMPROAD" , tkgimp_ncar ) + CALL ncio_read_bcast_serial (landname, "CV_ROOF" , cvroof_ncar ) + CALL ncio_read_bcast_serial (landname, "CV_WALL" , cvwall_ncar ) + CALL ncio_read_bcast_serial (landname, "CV_IMPROAD" , cvgimp_ncar ) + CALL ncio_read_bcast_serial (landname, "THICK_ROOF" , thkroof_ncar) + CALL ncio_read_bcast_serial (landname, "THICK_WALL" , thkwall_ncar) + CALL ncio_read_bcast_serial (landname, "T_BUILDING_MIN", tbldmin_ncar) + CALL ncio_read_bcast_serial (landname, "T_BUILDING_MAX", tbldmax_ncar) +ENDIF + + IF (p_is_io) THEN + +#ifdef USEMPI +IF (DEF_URBAN_type_scheme == 1) THEN + CALL aggregation_data_daemon (grid_urban_500m, data_i4_2d_in1 = reg_typid) +ENDIF +#endif + ENDIF + + IF (p_is_worker) THEN + + allocate (fgper (numurban)) + allocate (em_roof (numurban)) + allocate (em_wall (numurban)) + allocate (em_gimp (numurban)) + allocate (em_gper (numurban)) + allocate (thk_roof (numurban)) + allocate (thk_wall (numurban)) + allocate (tbld_min (numurban)) + allocate (tbld_max (numurban)) + allocate (tk_wgt (ulev, numurban)) + allocate (cv_wgt (ulev, numurban)) + allocate (cv_roof (ulev, numurban)) + allocate (cv_wall (ulev, numurban)) + allocate (cv_gimp (ulev, numurban)) + allocate (tk_roof (ulev, numurban)) + allocate (tk_wall (ulev, numurban)) + allocate (tk_gimp (ulev, numurban)) + allocate (alb_roof (nr, ns, numurban)) + allocate (alb_wall (nr, ns, numurban)) + allocate (alb_gimp (nr, ns, numurban)) + allocate (alb_gper (nr, ns, numurban)) + + allocate (urb_pct (numurban)) + allocate (sarea_urb (numurban)) + allocate (area_urb (numurban)) + + ! initialization + urb_pct (:) = 0. + sarea_urb(:) = 0. + area_urb (:) = 0. + + fgper (:) = 0. + em_roof (:) = 0. + em_wall (:) = 0. + em_gimp (:) = 0. + em_gper (:) = 0. + thk_roof (:) = 0. + thk_wall (:) = 0. + tbld_min (:) = 0. + tbld_max (:) = 0. + tk_wgt (:,:) = 0. + cv_wgt (:,:) = 0. + cv_roof (:,:) = 0. + cv_wall (:,:) = 0. + cv_gimp (:,:) = 0. + tk_roof (:,:) = 0. + tk_wall (:,:) = 0. + tk_gimp (:,:) = 0. + alb_roof (:,:,:) = 0. + alb_wall (:,:,:) = 0. + alb_gimp (:,:,:) = 0. + alb_gper (:,:,:) = 0. + + ! loop for each urban patch to aggregate urban morphological and thermal paras with area-weighted average + DO iurban = 1, numurban + ! urban region and type id for look-up-table + urb_typidx = landurban%settyp(iurban) + +IF (DEF_URBAN_type_scheme == 1) THEN + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, & + area = area_one, data_i4_2d_in2 = reg_typid, data_i4_2d_out2 = reg_typid_one) +ENDIF + + sumarea = sum(area_one) + area_urb(iurban) = sumarea + + ! loop for each finer grid to aggregate data + DO ipxl = 1, size(area_one) + +IF (DEF_URBAN_type_scheme == 1) THEN + ! same for above, assign reg id for RG_-45_65_-50_70 + IF (all(reg_typid_one==0)) THEN + reg_typid_one(:) = 30 + ENDIF + + IF (any(reg_typid_one==0)) THEN + WHERE(reg_typid_one==0) reg_typid_one = num_max_frequency(reg_typid_one) + ENDIF + + urb_regidx = reg_typid_one(ipxl) + + fgper_ = fgper_ncar (urb_typidx,urb_regidx) + + emroof = emroof_ncar (urb_typidx,urb_regidx) + emwall = emwall_ncar (urb_typidx,urb_regidx) + emgper = emgper_ncar (urb_typidx,urb_regidx) + emgimp = emgimp_ncar (urb_typidx,urb_regidx) + + thkroof = thkroof_ncar(urb_typidx,urb_regidx) + thkwall = thkwall_ncar(urb_typidx,urb_regidx) + tbldmax = tbldmax_ncar(urb_typidx,urb_regidx) + tbldmin = tbldmin_ncar(urb_typidx,urb_regidx) + + cvroof (:) = cvroof_ncar (urb_typidx,urb_regidx,:) + cvwall (:) = cvwall_ncar (urb_typidx,urb_regidx,:) + cvgimp (:) = cvgimp_ncar (urb_typidx,urb_regidx,:) + + tkroof (:) = tkroof_ncar (urb_typidx,urb_regidx,:) + tkwall (:) = tkwall_ncar (urb_typidx,urb_regidx,:) + tkgimp (:) = tkgimp_ncar (urb_typidx,urb_regidx,:) + + albroof(:,:) = albroof_ncar(urb_typidx,urb_regidx,:,:) + albwall(:,:) = albwall_ncar(urb_typidx,urb_regidx,:,:) + albgper(:,:) = albgper_ncar(urb_typidx,urb_regidx,:,:) + albgimp(:,:) = albgimp_ncar(urb_typidx,urb_regidx,:,:) + +ELSE IF (DEF_URBAN_type_scheme == 2) THEN + + fgper_ = fgper_lcz (urb_typidx) / (1-wtroof_lcz(urb_typidx)) + + emroof = emroof_lcz (urb_typidx) + emwall = emwall_lcz (urb_typidx) + emgper = emgper_lcz (urb_typidx) + emgimp = emgimp_lcz (urb_typidx) + + thkroof = thkroof_lcz(urb_typidx) + thkwall = thkwall_lcz(urb_typidx) + tbldmax = tbldmax_lcz(urb_typidx) + tbldmin = tbldmin_lcz(urb_typidx) + + cvroof (:) = cvroof_lcz (urb_typidx) + cvwall (:) = cvwall_lcz (urb_typidx) + cvgimp (:) = cvgimp_lcz (urb_typidx) + + tkroof (:) = tkroof_lcz (urb_typidx) + tkwall (:) = tkwall_lcz (urb_typidx) + tkgimp (:) = tkgimp_lcz (urb_typidx) + + albroof(:,:) = albroof_lcz(urb_typidx) + albwall(:,:) = albwall_lcz(urb_typidx) + albgper(:,:) = albgper_lcz(urb_typidx) + albgimp(:,:) = albgimp_lcz(urb_typidx) +ENDIF + + fgper (iurban) = fgper (iurban) + fgper_ * area_one(ipxl) + + em_roof (iurban) = em_roof (iurban) + emroof * area_one(ipxl) + em_wall (iurban) = em_wall (iurban) + emwall * area_one(ipxl) + em_gimp (iurban) = em_gimp (iurban) + emgimp * area_one(ipxl) + em_gper (iurban) = em_gper (iurban) + emgper * area_one(ipxl) + + thk_roof(iurban) = thk_roof (iurban) + thkroof * area_one(ipxl) + thk_wall(iurban) = thk_wall (iurban) + thkwall * area_one(ipxl) + tbld_min(iurban) = tbld_min (iurban) + tbldmin * area_one(ipxl) + tbld_max(iurban) = tbld_max (iurban) + tbldmax * area_one(ipxl) + + ! tkgimp and cvgimp may have nan-values, and need to be calculated separately + DO il = 1, 10 + IF (tkgimp(il) .ne. -999.) THEN + tk_gimp(il,iurban) = tk_gimp(il,iurban) + tkgimp(il) * area_one(ipxl) + tk_wgt (il,iurban) = tk_wgt (il,iurban) + area_one(ipxl) + ENDIF + + IF (cvgimp(il) .ne. -999.) THEN + cv_gimp(il,iurban) = cv_gimp(il,iurban) + cvgimp(il) * area_one(ipxl) + cv_wgt (il,iurban) = cv_wgt (il,iurban) + area_one(ipxl) + ENDIF + ENDDO + + cv_roof (:,iurban) = cv_roof (:,iurban) + cvroof(:) * area_one(ipxl) + cv_wall (:,iurban) = cv_wall (:,iurban) + cvwall(:) * area_one(ipxl) + tk_roof (:,iurban) = tk_roof (:,iurban) + tkroof(:) * area_one(ipxl) + tk_wall (:,iurban) = tk_wall (:,iurban) + tkwall(:) * area_one(ipxl) + + alb_roof(:,:,iurban) = alb_roof(:,:,iurban) + albroof(:,:) * area_one(ipxl) + alb_wall(:,:,iurban) = alb_wall(:,:,iurban) + albwall(:,:) * area_one(ipxl) + alb_gimp(:,:,iurban) = alb_gimp(:,:,iurban) + albgimp(:,:) * area_one(ipxl) + alb_gper(:,:,iurban) = alb_gper(:,:,iurban) + albgper(:,:) * area_one(ipxl) + + ENDDO + + fgper (iurban) = fgper (iurban) / sumarea + em_roof (iurban) = em_roof (iurban) / sumarea + em_wall (iurban) = em_wall (iurban) / sumarea + em_gimp (iurban) = em_gimp (iurban) / sumarea + em_gper (iurban) = em_gper (iurban) / sumarea + thk_roof (iurban) = thk_roof (iurban) / sumarea + thk_wall (iurban) = thk_wall (iurban) / sumarea + tbld_min (iurban) = tbld_min (iurban) / sumarea + tbld_max (iurban) = tbld_max (iurban) / sumarea + + cv_roof(:,iurban) = cv_roof (:,iurban) / sumarea + cv_wall(:,iurban) = cv_wall (:,iurban) / sumarea + tk_roof(:,iurban) = tk_roof (:,iurban) / sumarea + tk_wall(:,iurban) = tk_wall (:,iurban) / sumarea + + DO il = 1, 10 + IF (tk_wgt(il,iurban) > 0.) THEN + tk_gimp(il,iurban) = tk_gimp(il,iurban) / tk_wgt(il,iurban) + ENDIF + + IF (cv_wgt(il,iurban) > 0.) THEN + cv_gimp(il,iurban) = cv_gimp(il,iurban) / cv_wgt(il,iurban) + ENDIF + ENDDO + + alb_roof(:,:,iurban) = alb_roof(:,:,iurban) / sumarea + alb_wall(:,:,iurban) = alb_wall(:,:,iurban) / sumarea + alb_gimp(:,:,iurban) = alb_gimp(:,:,iurban) / sumarea + alb_gper(:,:,iurban) = alb_gper(:,:,iurban) / sumarea + + ENDDO + + DO ielm = 1, numelm + numpth = count(landurban%eindex==landelm%eindex(ielm)) + + IF (allocated(locpth)) deallocate(locpth) + allocate(locpth(numpth)) + + locpth = pack([(ipth, ipth=1, numurban)], & + landurban%eindex==landelm%eindex(ielm)) + + urb_s = minval(locpth) + urb_e = maxval(locpth) + + DO iurban = urb_s, urb_e + sarea_urb(urb_s:urb_e) = sarea_urb(urb_s:urb_e) + area_urb(iurban) + ENDDO + ENDDO + + urb_pct(:) = area_urb(:)/sarea_urb(:) + +#ifdef USEMPI +IF (DEF_URBAN_type_scheme == 1) THEN + CALL aggregation_worker_done () +ENDIF +#endif + ENDIF + + !output + write(cyear,'(i4.4)') lc_year + landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/urban.nc' + CALL ncio_create_file_vector (landname, landurban) + + CALL ncio_define_dimension_vector (landname, landurban, 'urban') + CALL ncio_define_dimension_vector (landname, landurban, 'numsolar', ns) + CALL ncio_define_dimension_vector (landname, landurban, 'numrad' , nr) + CALL ncio_define_dimension_vector (landname, landurban, 'ulev' , ulev) + + CALL ncio_write_vector (landname, 'WTROAD_PERV' , 'urban', landurban, fgper , DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'EM_ROOF' , 'urban', landurban, em_roof , DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'EM_WALL' , 'urban', landurban, em_wall , DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'EM_IMPROAD' , 'urban', landurban, em_gimp , DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'EM_PERROAD' , 'urban', landurban, em_gper , DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'THICK_ROOF' , 'urban', landurban, thk_roof, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'THICK_WALL' , 'urban', landurban, thk_wall, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'T_BUILDING_MIN', 'urban', landurban, tbld_min, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'T_BUILDING_MAX', 'urban', landurban, tbld_max, DEF_Srfdata_CompressLevel) + + CALL ncio_write_vector (landname, 'CV_ROOF' , 'ulev', ulev, 'urban', landurban, cv_roof, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'CV_WALL' , 'ulev', ulev, 'urban', landurban, cv_wall, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'TK_ROOF' , 'ulev', ulev, 'urban', landurban, tk_roof, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'TK_WALL' , 'ulev', ulev, 'urban', landurban, tk_wall, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'TK_IMPROAD', 'ulev', ulev, 'urban', landurban, tk_gimp, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'CV_IMPROAD', 'ulev', ulev, 'urban', landurban, cv_gimp, DEF_Srfdata_CompressLevel) + + CALL ncio_write_vector (landname, 'ALB_ROOF' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_roof, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'ALB_WALL' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_wall, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'ALB_IMPROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gimp, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (landname, 'ALB_PERROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gper, DEF_Srfdata_CompressLevel) + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/pct_urban_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (urb_pct, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'URBAN_PCT', compress = 0, write_mode = 'one', & + stat_mode = 'fraction', defval = 0._r8, pctshared = urb_pct, create_mode = .true.) + + typindex = (/(ityp, ityp = 1, N_URB)/) + landname = trim(dir_srfdata) // '/diag/urban_phyical_paras_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (fgper, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'WTROAD_PERV', compress = 0, write_mode = 'one', & + stat_mode = 'fraction', defval = 0._r8, create_mode = .true.) + + CALL srfdata_map_and_write (em_roof, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'EM_ROOF', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (em_wall, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'EM_WALL', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (em_gper, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'EM_PERROAD', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (em_gimp, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'EM_IMPROAD', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (thk_roof, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'THICK_ROOF', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (thk_wall, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'THICK_WALL', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (tbld_min, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'T_BUILDING_MIN', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (tbld_max, landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'T_BUILDING_MAX', compress = 0, write_mode = 'one', defval = 0._r8) + + DO il = 1, nl_roof + CALL srfdata_map_and_write (cv_roof(il,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'CV_ROOF', compress = 0, write_mode = 'one', & + lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) + + CALL srfdata_map_and_write (tk_roof(il,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'TK_ROOF', compress = 0, write_mode = 'one', & + lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) + ENDDO + + DO il = 1, nl_wall + CALL srfdata_map_and_write (cv_wall(il,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'CV_WALL', compress = 0, write_mode = 'one', & + lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) + + CALL srfdata_map_and_write (tk_wall(il,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'TK_WALL', compress = 0, write_mode = 'one', & + lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) + ENDDO + + DO il = 1, nl_soil + CALL srfdata_map_and_write (cv_gimp(il,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'CV_IMPROAD', compress = 0, write_mode = 'one', & + lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) + + CALL srfdata_map_and_write (tk_gimp(il,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'TK_IMPROAD', compress = 0, write_mode = 'one', & + lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) + ENDDO + + CALL srfdata_map_and_write (alb_roof(1,1,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'ALB_ROOF', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (alb_wall(1,1,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'ALB_WALL', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (alb_gper(1,1,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'ALB_PERROAD', compress = 0, write_mode = 'one', defval = 0._r8) + + CALL srfdata_map_and_write (alb_gimp(1,1,:), landurban%settyp, typindex, m_urb2diag, & + -1.0e36_r8, landname, 'ALB_IMPROAD', compress = 0, write_mode = 'one', defval = 0._r8) + + deallocate (typindex) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('WTROAD_PERV ' , fgper ) + CALL check_vector_data ('EM_ROOF ' , em_roof ) + CALL check_vector_data ('EM_WALL ' , em_wall ) + CALL check_vector_data ('EM_IMPROAD ' , em_gimp ) + CALL check_vector_data ('EM_PERROAD ' , em_gper ) + CALL check_vector_data ('ALB_ROOF ' , alb_roof) + CALL check_vector_data ('ALB_WALL ' , alb_wall) + CALL check_vector_data ('ALB_IMPROAD ' , alb_gimp) + CALL check_vector_data ('ALB_PERROAD ' , alb_gper) + CALL check_vector_data ('TK_ROOF ' , tk_roof ) + CALL check_vector_data ('TK_WALL ' , tk_wall ) + CALL check_vector_data ('TK_IMPROAD ' , tk_gimp ) + CALL check_vector_data ('CV_ROOF ' , cv_roof ) + CALL check_vector_data ('CV_WALL ' , cv_wall ) + CALL check_vector_data ('CV_IMPROAD ' , cv_gimp ) + CALL check_vector_data ('THICK_ROOF ' , thk_roof) + CALL check_vector_data ('THICK_WALL ' , thk_wall) + CALL check_vector_data ('T_BUILDING_MIN ', tbld_min) + CALL check_vector_data ('T_BUILDING_MAX ', tbld_max) +#endif + + IF (p_is_worker) THEN + + IF ( allocated (LUCY_rid ) ) deallocate (LUCY_rid ) + IF ( allocated (pop_den ) ) deallocate (pop_den ) + IF ( allocated (pct_tree ) ) deallocate (pct_tree ) + IF ( allocated (htop_urb ) ) deallocate (htop_urb ) + IF ( allocated (pct_water) ) deallocate (pct_water ) + IF ( allocated (wt_roof ) ) deallocate (wt_roof ) + IF ( allocated (ht_roof ) ) deallocate (ht_roof ) + IF ( allocated (lai_urb ) ) deallocate (lai_urb ) + IF ( allocated (sai_urb ) ) deallocate (sai_urb ) + IF ( allocated (area_urb ) ) deallocate (area_urb ) + IF ( allocated (sarea_urb) ) deallocate (sarea_urb ) + IF ( allocated (urb_pct ) ) deallocate (urb_pct ) + +IF (DEF_URBAN_type_scheme == 1) THEN + IF ( allocated (htroof_ncar ) ) deallocate (htroof_ncar ) + IF ( allocated (wtroof_ncar ) ) deallocate (wtroof_ncar ) + IF ( allocated (hwrbld_ncar ) ) deallocate (hwrbld_ncar ) + IF ( allocated (fgper_ncar ) ) deallocate (fgper_ncar ) + IF ( allocated (emroof_ncar ) ) deallocate (emroof_ncar ) + IF ( allocated (emwall_ncar ) ) deallocate (emwall_ncar ) + IF ( allocated (emgper_ncar ) ) deallocate (emgper_ncar ) + IF ( allocated (emgimp_ncar ) ) deallocate (emgimp_ncar ) + IF ( allocated (albroof_ncar) ) deallocate (albroof_ncar) + IF ( allocated (albwall_ncar) ) deallocate (albwall_ncar) + IF ( allocated (albgper_ncar) ) deallocate (albgper_ncar) + IF ( allocated (albgimp_ncar) ) deallocate (albgimp_ncar) + IF ( allocated (thkroof_ncar) ) deallocate (thkroof_ncar) + IF ( allocated (thkwall_ncar) ) deallocate (thkwall_ncar) + IF ( allocated (tbldmin_ncar) ) deallocate (tbldmin_ncar) + IF ( allocated (tbldmax_ncar) ) deallocate (tbldmax_ncar) + IF ( allocated (cvroof_ncar ) ) deallocate (cvroof_ncar ) + IF ( allocated (cvwall_ncar ) ) deallocate (cvwall_ncar ) + IF ( allocated (cvgimp_ncar ) ) deallocate (cvgimp_ncar ) + IF ( allocated (tkroof_ncar ) ) deallocate (tkroof_ncar ) + IF ( allocated (tkwall_ncar ) ) deallocate (tkwall_ncar ) + IF ( allocated (tkgimp_ncar ) ) deallocate (tkgimp_ncar ) +ENDIF + + IF ( allocated (hlr_bld ) ) deallocate (hlr_bld ) + IF ( allocated (fgper ) ) deallocate (fgper ) + IF ( allocated (em_roof ) ) deallocate (em_roof ) + IF ( allocated (em_wall ) ) deallocate (em_wall ) + IF ( allocated (em_gimp ) ) deallocate (em_gimp ) + IF ( allocated (em_gper ) ) deallocate (em_gper ) + IF ( allocated (thk_roof) ) deallocate (thk_roof) + IF ( allocated (thk_wall) ) deallocate (thk_wall) + IF ( allocated (tbld_min) ) deallocate (tbld_min) + IF ( allocated (tbld_max) ) deallocate (tbld_max) + IF ( allocated (tk_wgt ) ) deallocate (tk_wgt ) + IF ( allocated (cv_wgt ) ) deallocate (cv_wgt ) + IF ( allocated (cv_roof ) ) deallocate (cv_roof ) + IF ( allocated (cv_wall ) ) deallocate (cv_wall ) + IF ( allocated (cv_gimp ) ) deallocate (cv_gimp ) + IF ( allocated (cv_wgt ) ) deallocate (cv_wgt ) + IF ( allocated (tk_roof ) ) deallocate (tk_roof ) + IF ( allocated (tk_wall ) ) deallocate (tk_wall ) + IF ( allocated (tk_gimp ) ) deallocate (tk_gimp ) + IF ( allocated (tk_wgt ) ) deallocate (tk_wgt ) + IF ( allocated (alb_roof) ) deallocate (alb_roof) + IF ( allocated (alb_wall) ) deallocate (alb_wall) + IF ( allocated (alb_gimp) ) deallocate (alb_gimp) + IF ( allocated (alb_gper) ) deallocate (alb_gper) + + IF ( allocated (area_one ) ) deallocate (area_one ) + IF ( allocated (LUCY_reg_one ) ) deallocate (LUCY_reg_one ) + IF ( allocated (pop_one ) ) deallocate (pop_one ) + IF ( allocated (fvegu_one ) ) deallocate (fvegu_one ) + IF ( allocated (htopu_one ) ) deallocate (htopu_one ) + IF ( allocated (flakeu_one ) ) deallocate (flakeu_one ) + IF ( allocated (wt_roof_one ) ) deallocate (wt_roof_one ) + IF ( allocated (ht_roof_one ) ) deallocate (ht_roof_one ) + IF ( allocated (ulai_one ) ) deallocate (ulai_one ) + IF ( allocated (slai_one ) ) deallocate (slai_one ) + + ENDIF + +END SUBROUTINE Aggregation_Urban +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 new file mode 100644 index 0000000000..311a976d5a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 @@ -0,0 +1,701 @@ +#include + +MODULE MOD_AggregationRequestData + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Aggregation Utilities. +! +! On IO processes, a data daemon is running to provide data +! at fine resolutions for worker processes. +! On worker processes, request is sent to IO processes and +! data is returned from IO processes. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + IMPLICIT NONE + + PUBLIC :: aggregation_request_data + +#ifdef USEMPI + PUBLIC :: aggregation_data_daemon + PUBLIC :: aggregation_worker_done +#endif + +! ---- subroutines ---- +CONTAINS + +#ifdef USEMPI + SUBROUTINE aggregation_data_daemon (grid_in, & + data_r8_2d_in1, data_r8_2d_in2, data_r8_2d_in3, data_r8_2d_in4, & + data_r8_2d_in5, data_r8_2d_in6, & + data_r8_3d_in1, n1_r8_3d_in1 , data_r8_3d_in2, n1_r8_3d_in2, & + data_i4_2d_in1, data_i4_2d_in2) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_DataType + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid_in + + ! 2D REAL data + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in1 + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in2 + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in3 + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in4 + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in5 + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in6 + + ! 3D REAL data + integer, intent(in), optional :: n1_r8_3d_in1 + type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in1 + + integer, intent(in), optional :: n1_r8_3d_in2 + type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in2 + + ! 2D INTEGER data + type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in1 + type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in2 + + ! Local Variables + integer :: nreq, ireq, rmesg(2), isrc, idest + integer :: xblk, yblk, xloc, yloc + integer, allocatable :: ylist(:), xlist(:) + + real(r8), allocatable :: sbuf_r8_1d(:), sbuf_r8_2d(:,:) + integer , allocatable :: sbuf_i4_1d(:) + + logical, allocatable :: worker_done (:) + + IF (p_is_io) THEN + + allocate (worker_done (0:p_np_worker-1)) + + worker_done(:) = .false. + DO WHILE (any(.not. worker_done)) + + CALL mpi_recv (rmesg, 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nreq = rmesg(2) + + IF (nreq > 0) THEN + + allocate (xlist (nreq)) + allocate (ylist (nreq)) + + CALL mpi_recv (xlist, nreq, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (ylist, nreq, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + idest = isrc + + allocate (sbuf_r8_1d (nreq)) + + IF (present(data_r8_2d_in1)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_1d(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + IF (present(data_r8_2d_in2)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_1d(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + IF (present(data_r8_2d_in3)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_1d(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + IF (present(data_r8_2d_in4)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_1d(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + IF (present(data_r8_2d_in5)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_1d(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + IF (present(data_r8_2d_in6)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_1d(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + + deallocate (sbuf_r8_1d) + + IF (present(data_r8_3d_in1) .and. present(n1_r8_3d_in1)) THEN + + allocate (sbuf_r8_2d (n1_r8_3d_in1,nreq)) + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_2d(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_2d, n1_r8_3d_in1*nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (sbuf_r8_2d) + ENDIF + + IF (present(data_r8_3d_in2) .and. present(n1_r8_3d_in2)) THEN + + allocate (sbuf_r8_2d (n1_r8_3d_in2,nreq)) + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_r8_2d(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_r8_2d, n1_r8_3d_in2*nreq, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (sbuf_r8_2d) + ENDIF + + allocate (sbuf_i4_1d (nreq)) + + IF (present(data_i4_2d_in1)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_i4_1d(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_i4_1d, nreq, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + IF (present(data_i4_2d_in2)) THEN + DO ireq = 1, nreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + sbuf_i4_1d(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc) + ENDDO + + CALL mpi_send (sbuf_i4_1d, nreq, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + + deallocate (sbuf_i4_1d) + + deallocate (ylist) + deallocate (xlist) + + ELSE + worker_done(p_itis_worker(isrc)) = .true. + ENDIF + + ENDDO + + deallocate (worker_done) + + ENDIF + + END SUBROUTINE aggregation_data_daemon + +#endif + + !---------------------------------------------------- + SUBROUTINE aggregation_request_data ( & + pixelset, iset, grid_in, zip, area, & + data_r8_2d_in1, data_r8_2d_out1, & + data_r8_2d_in2, data_r8_2d_out2, & + data_r8_2d_in3, data_r8_2d_out3, & + data_r8_2d_in4, data_r8_2d_out4, & + data_r8_2d_in5, data_r8_2d_out5, & + data_r8_2d_in6, data_r8_2d_out6, & + data_r8_3d_in1, data_r8_3d_out1, n1_r8_3d_in1, lb1_r8_3d_in1, & + data_r8_3d_in2, data_r8_3d_out2, n1_r8_3d_in2, lb1_r8_3d_in2, & + data_i4_2d_in1, data_i4_2d_out1, & + data_i4_2d_in2, data_i4_2d_out2, & + filledvalue_i4) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_Pixelset + USE MOD_Utils + + IMPLICIT NONE + + type (pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iset + + type (grid_type), intent(in) :: grid_in + logical, intent(in) :: zip + + real(r8), allocatable, intent(out), optional :: area(:) + + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in1 + real(r8), allocatable, intent(out), optional :: data_r8_2d_out1 (:) + + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in2 + real(r8), allocatable, intent(out), optional :: data_r8_2d_out2 (:) + + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in3 + real(r8), allocatable, intent(out), optional :: data_r8_2d_out3 (:) + + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in4 + real(r8), allocatable, intent(out), optional :: data_r8_2d_out4 (:) + + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in5 + real(r8), allocatable, intent(out), optional :: data_r8_2d_out5 (:) + + type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in6 + real(r8), allocatable, intent(out), optional :: data_r8_2d_out6 (:) + + integer, intent(in), optional :: n1_r8_3d_in1, lb1_r8_3d_in1 + type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in1 + real(r8), allocatable, intent(out), optional :: data_r8_3d_out1 (:,:) + + integer, intent(in), optional :: n1_r8_3d_in2, lb1_r8_3d_in2 + type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in2 + real(r8), allocatable, intent(out), optional :: data_r8_3d_out2 (:,:) + + type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in1 + integer, allocatable, intent(out), optional :: data_i4_2d_out1 (:) + + type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in2 + integer, allocatable, intent(out), optional :: data_i4_2d_out2 (:) + + integer, intent(in), optional :: filledvalue_i4 + + ! Local Variables + integer :: totalreq, ireq, nreq, smesg(2), isrc, idest, iproc + integer :: ilon, ilat, xblk, yblk, xloc, yloc, iloc, nx, ny, ix, iy, ig + integer :: ie, ipxstt, ipxend, npxl, ipxl, lb1, xgrdthis, ygrdthis + integer, allocatable :: ylist(:), xlist(:), ipt(:), ibuf(:), rbuf_i4_1d(:) + integer, allocatable :: xsorted(:), ysorted(:), xy2d(:,:) + real(r8), allocatable :: area2d(:,:), rbuf_r8_1d(:), rbuf_r8_2d(:,:) + logical, allocatable :: msk(:) + + + ie = pixelset%ielm (iset) + ipxstt = pixelset%ipxstt(iset) + ipxend = pixelset%ipxend(iset) + npxl = ipxend - ipxstt + 1 + + IF (zip) THEN + + allocate (xsorted(npxl)) + allocate (ysorted(npxl)) + + nx = 0; ny = 0 + DO ipxl = ipxstt, ipxend + xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl)) + ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl)) + CALL insert_into_sorted_list1 (xgrdthis, nx, xsorted, iloc) + CALL insert_into_sorted_list1 (ygrdthis, ny, ysorted, iloc) + ENDDO + + allocate (xy2d (nx,ny)); xy2d(:,:) = 0 + + IF (present(area)) THEN + allocate(area2d(nx,ny)); area2d(:,:) = 0. + ENDIF + + DO ipxl = ipxstt, ipxend + xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl)) + ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl)) + + ix = find_in_sorted_list1(xgrdthis, nx, xsorted) + iy = find_in_sorted_list1(ygrdthis, ny, ysorted) + + xy2d(ix,iy) = xy2d(ix,iy) + 1 + + IF (present(area)) THEN + area2d(ix,iy) = area2d(ix,iy) + areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDIF + ENDDO + + totalreq = count(xy2d > 0) + + allocate (xlist (totalreq)) + allocate (ylist (totalreq)) + + IF (present(area)) allocate(area(totalreq)) + + ig = 0 + DO ix = 1, nx + DO iy = 1, ny + IF (xy2d(ix,iy) > 0) THEN + ig = ig + 1 + xlist(ig) = xsorted(ix) + ylist(ig) = ysorted(iy) + IF (present(area)) area (ig) = area2d(ix,iy) + ENDIF + ENDDO + ENDDO + + deallocate (xsorted, ysorted, xy2d) + IF (present(area)) deallocate (area2d) + + ELSE + + allocate(xlist (npxl)) + allocate(ylist (npxl)) + + IF (present(area)) allocate (area (npxl)) + + totalreq = npxl + DO ipxl = ipxstt, ipxend + xlist(ipxl-ipxstt+1) = grid_in%xgrd(mesh(ie)%ilon(ipxl)) + ylist(ipxl-ipxstt+1) = grid_in%ygrd(mesh(ie)%ilat(ipxl)) + IF (present(area)) THEN + area(ipxl-ipxstt+1) = areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDIF + ENDDO + + ENDIF + + IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) allocate (data_r8_2d_out1 (totalreq)) + IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) allocate (data_r8_2d_out2 (totalreq)) + IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) allocate (data_r8_2d_out3 (totalreq)) + IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) allocate (data_r8_2d_out4 (totalreq)) + IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) allocate (data_r8_2d_out5 (totalreq)) + IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) allocate (data_r8_2d_out6 (totalreq)) + + IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN + IF (present(lb1_r8_3d_in1)) THEN + lb1 = lb1_r8_3d_in1 + ELSE + lb1 = 1 + ENDIF + allocate (data_r8_3d_out1 (lb1:lb1-1+n1_r8_3d_in1,totalreq)) + ENDIF + + IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN + IF (present(lb1_r8_3d_in2)) THEN + lb1 = lb1_r8_3d_in2 + ELSE + lb1 = 1 + ENDIF + allocate (data_r8_3d_out2 (lb1:lb1-1+n1_r8_3d_in2,totalreq)) + ENDIF + + IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN + allocate (data_i4_2d_out1 (totalreq)) + IF (present(filledvalue_i4)) THEN + data_i4_2d_out1 = filledvalue_i4 + ENDIF + ENDIF + + IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN + allocate (data_i4_2d_out2 (totalreq)) + IF (present(filledvalue_i4)) THEN + data_i4_2d_out2 = filledvalue_i4 + ENDIF + ENDIF + +#ifdef USEMPI + + allocate (ipt (totalreq)) + allocate (msk (totalreq)) + + ipt(:) = -1 + + DO ireq = 1, totalreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + ipt(ireq) = gblock%pio(xblk,yblk) + ENDDO + + DO iproc = 0, p_np_io-1 + msk = (ipt == p_address_io(iproc)) + nreq = count(msk) + + IF (nreq > 0) THEN + + smesg = (/p_iam_glb, nreq/) + idest = p_address_io(iproc) + CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) + + allocate (ibuf (nreq)) + + ibuf = pack(xlist(1:totalreq), msk) + CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + ibuf = pack(ylist(1:totalreq), msk) + CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) + + isrc = idest + + allocate (rbuf_r8_1d (nreq)) + + IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN + CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out1) + ENDIF + + IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN + CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out2) + ENDIF + + IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN + CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out3) + ENDIF + + IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN + CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out4) + ENDIF + + IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN + CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out5) + ENDIF + + IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN + CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out6) + ENDIF + + deallocate (rbuf_r8_1d) + + IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN + allocate (rbuf_r8_2d (n1_r8_3d_in1,nreq)) + CALL mpi_recv (rbuf_r8_2d, n1_r8_3d_in1*nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_2d, msk, data_r8_3d_out1) + deallocate (rbuf_r8_2d) + ENDIF + + IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN + allocate (rbuf_r8_2d (n1_r8_3d_in2,nreq)) + CALL mpi_recv (rbuf_r8_2d, n1_r8_3d_in2*nreq, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_r8_2d, msk, data_r8_3d_out2) + deallocate (rbuf_r8_2d) + ENDIF + + allocate (rbuf_i4_1d (nreq)) + IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN + CALL mpi_recv (rbuf_i4_1d, nreq, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_i4_1d, msk, data_i4_2d_out1) + ENDIF + + IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN + CALL mpi_recv (rbuf_i4_1d, nreq, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL unpack_inplace (rbuf_i4_1d, msk, data_i4_2d_out2) + ENDIF + + deallocate (rbuf_i4_1d) + + deallocate (ibuf) + ENDIF + ENDDO + + deallocate (xlist) + deallocate (ylist) + deallocate (ipt ) + deallocate (msk ) + +#else + + DO ireq = 1, totalreq + + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) + + IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN + data_r8_2d_out1(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN + data_r8_2d_out2(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN + data_r8_2d_out3(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN + data_r8_2d_out4(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN + data_r8_2d_out5(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN + data_r8_2d_out6(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN + data_r8_3d_out1(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc) + ENDIF + + IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN + data_r8_3d_out2(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc) + ENDIF + + IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN + data_i4_2d_out1(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN + data_i4_2d_out2(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc) + ENDIF + + ENDDO + +#endif + + END SUBROUTINE aggregation_request_data + +#ifdef USEMPI + + SUBROUTINE aggregation_worker_done () + + USE MOD_SPMD_Task + + IMPLICIT NONE + + integer :: smesg(2), iproc, idest + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + smesg = (/p_iam_glb, -1/) + idest = p_address_io(iproc) + CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) + ENDDO + ENDIF + + END SUBROUTINE aggregation_worker_done + +#endif + + + SUBROUTINE fillnan (vec, fill, defval) + + USE MOD_Precision + USE MOD_UserDefFun, only: isnan_ud + IMPLICIT NONE + + real(r8), intent(inout) :: vec(:) + logical, intent(in) :: fill + real(r8), intent(in) :: defval + + ! local variables + integer :: i, n + real(r8) :: s + + n = 0 + s = 0. + DO i = lbound(vec,1), ubound(vec,1) + IF (.not. isnan_ud(vec(i))) THEN + n = n + 1 + s = s + vec(i) + ENDIF + ENDDO + + IF ((n > 0) .and. (n < size(vec))) THEN + s = s/n + DO i = lbound(vec,1), ubound(vec,1) + IF (isnan_ud(vec(i))) vec(i) = s + ENDDO + ENDIF + + IF ((n == 0) .and. fill) THEN + vec(:) = defval + ENDIF + + END SUBROUTINE fillnan + +END MODULE MOD_AggregationRequestData diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 new file mode 100644 index 0000000000..00a96729c4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 @@ -0,0 +1,168 @@ +#include + +#if (defined UNSTRUCTURED || defined CATCHMENT) +MODULE MOD_ElmVector + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Address of Data associated with land element. +! +! To output a vector, Data is gathered from worker processes directly to +! master. "elm_data_address" stores information on how to reorganize data +! gathered. The output data in vector is sorted by global element index. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_DataType + IMPLICIT NONE + + integer :: totalnumelm + type(pointer_int32_1d), allocatable :: elm_data_address (:) + + integer*8, allocatable :: eindex_glb (:) + +CONTAINS + + ! -------- + SUBROUTINE elm_vector_init + + USE MOD_SPMD_Task + USE MOD_Utils + USE MOD_Pixelset + USE MOD_Utils + USE MOD_UserDefFun + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif + IMPLICIT NONE + + ! Local Variables + integer :: mesg(2), iwork, isrc, ndata + integer, allocatable :: numelm_worker (:) + + integer :: i, idsp + integer, allocatable :: vec_worker_dsp (:) + + integer*8, allocatable :: indexelm (:) + integer, allocatable :: order (:) + + IF (p_is_worker) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + ENDIF + + IF (p_is_worker) THEN +#ifdef USEMPI + IF (numelm > 0) THEN + allocate (indexelm (numelm)) + indexelm = landelm%eindex + ENDIF + + IF (p_iam_worker == p_root) allocate (numelm_worker (0:p_np_worker-1)) + CALL mpi_gather (numelm, 1, MPI_INTEGER, & + numelm_worker, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + CALL mpi_send (numelm_worker, p_np_worker, MPI_INTEGER, & + p_address_master, mpi_tag_size, p_comm_glb, p_err) + ENDIF + + mesg = (/p_iam_glb, numelm/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numelm > 0) THEN + CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#else + IF (numelm > 0) THEN + allocate (eindex_glb (numelm)) + eindex_glb = landelm%eindex + ENDIF +#endif + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + allocate (numelm_worker (0:p_np_worker-1)) + CALL mpi_recv (numelm_worker, p_np_worker, MPI_INTEGER, p_address_worker(p_root), & + mpi_tag_size, p_comm_glb, p_stat, p_err) + + allocate (vec_worker_dsp (0:p_np_worker-1)) + vec_worker_dsp(0) = 0 + DO iwork = 1, p_np_worker-1 + vec_worker_dsp(iwork) = vec_worker_dsp(iwork-1) + numelm_worker(iwork-1) + ENDDO + + totalnumelm = sum(numelm_worker) + + allocate (eindex_glb (totalnumelm)) + + allocate (elm_data_address(0:p_np_worker-1)) + DO iwork = 0, p_np_worker-1 + IF (numelm_worker(iwork) > 0) THEN + allocate (elm_data_address(iwork)%val (numelm_worker(iwork))) + ENDIF + ENDDO + + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + idsp = vec_worker_dsp(p_itis_worker(isrc)) + CALL mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDDO +#else + totalnumelm = numelm + allocate (elm_data_address(0:0)) + allocate (elm_data_address(0)%val (totalnumelm)) +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (totalnumelm, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + allocate (order (totalnumelm)) + order = (/(i, i=1,totalnumelm)/) + + CALL quicksort (totalnumelm, eindex_glb, order) + +#ifdef USEMPI + DO i = 1, totalnumelm + iwork = findloc_ud(order(i) > vec_worker_dsp, back=.true.) - 1 + elm_data_address(iwork)%val(order(i)-vec_worker_dsp(iwork)) = i + ENDDO +#else + elm_data_address(0)%val (order) = (/(i, i=1,totalnumelm)/) +#endif + ENDIF + + IF (allocated(numelm_worker)) deallocate(numelm_worker) + IF (allocated(vec_worker_dsp)) deallocate(vec_worker_dsp) + IF (allocated(indexelm)) deallocate(indexelm) + IF (allocated(order)) deallocate(order) + + END SUBROUTINE elm_vector_init + + ! ---------- + SUBROUTINE elm_vector_final () + + IMPLICIT NONE + + IF (allocated(elm_data_address)) deallocate (elm_data_address) + IF (allocated(eindex_glb)) deallocate (eindex_glb) + + END SUBROUTINE elm_vector_final + +END MODULE MOD_ElmVector +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 new file mode 100644 index 0000000000..cb71887b90 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 @@ -0,0 +1,215 @@ +#include + +#if (defined CATCHMENT) +MODULE MOD_HRUVector + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Address of Data associated with HRU. +! +! To output a vector, Data is gathered from worker processes directly to +! master. "hru_data_address" stores information on how to reorganize data +! gathered. The output data in vector is sorted by global element index +! (i.e. catchment index) +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_DataType + IMPLICIT NONE + + integer :: totalnumhru + type(pointer_int32_1d), allocatable :: hru_data_address (:) + + integer*8, allocatable :: eindx_hru (:) + integer, allocatable :: htype_hru (:) + +CONTAINS + + ! -------- + SUBROUTINE hru_vector_init + + USE MOD_SPMD_Task + USE MOD_Utils + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandHRU + USE MOD_LandPatch + USE MOD_ElmVector +#ifdef CROP + USE MOD_LandCrop +#endif + IMPLICIT NONE + + ! Local Variables + integer :: mesg(2), iwork, isrc, ndata + + integer, allocatable :: nhru_bsn (:) + integer, allocatable :: nhru_bsn_glb (:) + integer, allocatable :: rbuff (:) + + integer, allocatable :: hru_dsp_glb (:) + integer :: ielm, i, ielm_glb + + integer :: nhru, nelm, hru_dsp_loc + + IF (p_is_worker) THEN + + CALL elm_hru%build (landelm, landhru, use_frac = .true.) + + CALL hru_patch%build (landhru, landpatch, use_frac = .true.) + + IF (numelm > 0) THEN + allocate (nhru_bsn (numelm)) + nhru_bsn = elm_hru%subend - elm_hru%substt + 1 + ENDIF + +#ifdef USEMPI + mesg = (/p_iam_glb, numelm/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numelm > 0) THEN + CALL mpi_send (nhru_bsn, numelm, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#endif + ENDIF + + IF (p_is_master) THEN + + allocate (hru_data_address (0:p_np_worker-1)) + + allocate (nhru_bsn_glb (totalnumelm)) + +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate (rbuff (ndata)) + + CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + nhru_bsn_glb(elm_data_address(p_itis_worker(isrc))%val) = rbuff + + IF (sum(rbuff) > 0) THEN + allocate(hru_data_address(p_itis_worker(isrc))%val (sum(rbuff))) + ENDIF + + deallocate(rbuff) + ENDIF + ENDDO +#else + nhru_bsn_glb(elm_data_address(0)%val) = nhru_bsn + IF (sum(nhru_bsn) > 0) THEN + allocate(hru_data_address(0)%val (sum(nhru_bsn))) + ENDIF +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + + totalnumhru = sum(nhru_bsn_glb) + + allocate (hru_dsp_glb (totalnumelm)) + hru_dsp_glb(1) = 0 + DO ielm = 2, totalnumelm + hru_dsp_glb(ielm) = hru_dsp_glb(ielm-1) + nhru_bsn_glb(ielm-1) + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (allocated(elm_data_address(iwork)%val)) THEN + nelm = size(elm_data_address(iwork)%val) + hru_dsp_loc = 0 + DO ielm = 1, nelm + ielm_glb = elm_data_address(iwork)%val(ielm) + nhru = nhru_bsn_glb(ielm_glb) + IF (nhru > 0) THEN + hru_data_address(iwork)%val (hru_dsp_loc+1:hru_dsp_loc+nhru) = & + (/ (i, i = hru_dsp_glb(ielm_glb)+1, hru_dsp_glb(ielm_glb)+nhru) /) + hru_dsp_loc = hru_dsp_loc + nhru + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF +#ifdef USEMPI + CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_worker) THEN + mesg = (/p_iam_glb, numhru/) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (numhru > 0) THEN + CALL mpi_send (landhru%settyp, numhru, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDIF +#endif + + IF (p_is_master) THEN + + allocate (eindx_hru (totalnumhru)) + + DO ielm = 1, totalnumelm + eindx_hru(hru_dsp_glb(ielm)+1:hru_dsp_glb(ielm)+nhru_bsn_glb(ielm)) = & + eindex_glb(ielm) + ENDDO + + allocate (htype_hru (totalnumhru)) + +#ifdef USEMPI + DO iwork = 0, p_np_worker-1 + CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate (rbuff (ndata)) + + CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + htype_hru(hru_data_address(p_itis_worker(isrc))%val) = rbuff + + deallocate(rbuff) + ENDIF + ENDDO +#else + htype_hru(hru_data_address(0)%val) = landhru%settyp +#endif + + ! To distinguish between lake HRUs and hillslopes, the program sets the + ! type of lake HRUs as a negative number. + ! Set it as a positive number for output. + htype_hru = abs(htype_hru) + + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#endif + + END SUBROUTINE hru_vector_init + + ! ---------- + SUBROUTINE hru_vector_final () + + IMPLICIT NONE + + IF (allocated(hru_data_address)) deallocate (hru_data_address) + IF (allocated(eindx_hru)) deallocate (eindx_hru) + IF (allocated(htype_hru)) deallocate (htype_hru) + + END SUBROUTINE hru_vector_final + +END MODULE MOD_HRUVector +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 new file mode 100644 index 0000000000..6a181d8195 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 @@ -0,0 +1,249 @@ +#include + +MODULE MOD_Land2mWMO + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Build a virtual patch "land2mWMO" for output 2 m WMO temperature. +! +! Created by Wenzong Dong and Hua Yuan, 2025/08 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_LandPatch + USE MOD_LandElm + USE MOD_Vars_Global + USE MOD_Const_LC + IMPLICIT NONE + + ! ---- Instance ---- + integer, allocatable :: wmo_patch (:) !2m wmo patch index + integer, allocatable :: wmo_source (:) !source patch of a wmo patch + +CONTAINS + + ! ------------------------------- + SUBROUTINE land2mwmo_build (lc_year) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Utils + USE MOD_UserDefFun + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandElm + USE MOD_Namelist + USE MOD_NetCDFBlock + + IMPLICIT NONE + + integer, intent(in) :: lc_year + character(len=255) :: cyear + + integer :: numpatch_ + integer :: numset + integer :: iset + integer :: spatch, epatch, ipatch, jpatch + integer :: ipth, numpxl, numpth + integer :: src_pth, pthtype, maxpxl + integer*8, allocatable :: eindex_(:) + integer, allocatable :: settyp_(:), ipxstt_(:), ipxend_(:), ielm_(:) + integer, allocatable :: locpth(:) + + integer :: npatch_glb + integer :: numwmo + + write(cyear,'(i4.4)') lc_year + IF (p_is_master) THEN + write(*,'(A)') 'Making land 2 m wmo patches:' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + + numset = numelm + + numwmo = 0 + numpatch_ = 0 + jpatch = 0 + + ! Count for 2 m WMO patches need to be set virtually + DO iset = 1, numset + + numpth = count(landpatch%eindex==landelm%eindex(iset)) + IF (allocated(locpth)) deallocate(locpth) + allocate(locpth(numpth)) + locpth = pack([(ipth, ipth=1, numpatch)], & + landpatch%eindex==landelm%eindex(iset)) + + spatch = minval(locpth) ! elm_patch%substt(iset) + epatch = maxval(locpth) ! elm_patch%subend(iset) + + maxpxl = 0 + src_pth = -1 + + DO ipatch = spatch, epatch + + pthtype = patchtypes(landpatch%settyp(ipatch)) + numpxl = landpatch%ipxend(ipatch) - landpatch%ipxstt(ipatch) + 1 + + IF (numpxl>maxpxl .and. pthtype==0) THEN + maxpxl = numpxl + src_pth = ipatch + ENDIF + ENDDO + + ! a new 2m WMO patch + IF (src_pth /= -1) THEN + wmo_source (iset) = src_pth + numwmo = numwmo + 1 + landelm%settyp(iset) = 1 + ELSE + wmo_source (iset) = -1 + ENDIF + + ENDDO + + ! allocate new temporal patches memory + IF (numpatch > 0) THEN + ! a numpatch with WMO patch number + numpatch_ = numpatch + numwmo + + allocate (eindex_ (numpatch_ )) + allocate (ipxstt_ (numpatch_ )) + allocate (ipxend_ (numpatch_ )) + allocate (settyp_ (numpatch_ )) + allocate (ielm_ (numpatch_ )) + + ENDIF + + numwmo = 0 + + ! set for new 2 m WMO patch + DO iset = 1, numset + numpth = count(landpatch%eindex==landelm%eindex(iset)) + + IF (allocated(locpth)) deallocate(locpth) + allocate(locpth(numpth)) + + locpth = pack([(ipth, ipth=1, numpatch)], & + landpatch%eindex==landelm%eindex(iset)) + + spatch = minval(locpth) ! elm_patch%substt(iset) + epatch = maxval(locpth) ! elm_patch%subend(iset) + + DO ipatch = spatch, epatch + jpatch = jpatch + 1 + eindex_(jpatch) = landpatch%eindex(ipatch) + settyp_(jpatch) = landpatch%settyp(ipatch) + ipxstt_(jpatch) = landpatch%ipxstt(ipatch) + ipxend_(jpatch) = landpatch%ipxend(ipatch) + ielm_ (jpatch) = landpatch%ielm (ipatch) + ENDDO + + IF (wmo_source(iset) > 0) THEN + jpatch = jpatch + 1 + eindex_(jpatch) = landpatch%eindex(epatch) + settyp_(jpatch) = landpatch%settyp(wmo_source(iset)) + ipxstt_(jpatch) = -1 + ipxend_(jpatch) = -1 + ielm_ (jpatch) = landpatch%ielm (epatch) + + ! update the newly 2m WMO source/patch index + wmo_patch (iset) = jpatch + wmo_source(iset) = wmo_source(iset) + numwmo + numwmo = numwmo + 1 + ENDIF + ENDDO + + ! 2m WMO patch number check + IF (jpatch .ne. numpatch_) THEN + write(*,'(A)') 'Count land 2 m WMO patches error! See MOD_Land2mWMO.F90.' + ENDIF + + ! set the new patch number + numpatch = numpatch_ + + ! allocate and save the new patches info + IF (numpatch > 0) THEN + ! update landpath with new patch number + IF (allocated (landpatch%eindex)) deallocate (landpatch%eindex) + IF (allocated (landpatch%ipxstt)) deallocate (landpatch%ipxstt) + IF (allocated (landpatch%ipxend)) deallocate (landpatch%ipxend) + IF (allocated (landpatch%settyp)) deallocate (landpatch%settyp) + IF (allocated (landpatch%ielm )) deallocate (landpatch%ielm ) + + allocate (landpatch%eindex (numpatch)) + allocate (landpatch%ipxstt (numpatch)) + allocate (landpatch%ipxend (numpatch)) + allocate (landpatch%settyp (numpatch)) + allocate (landpatch%ielm (numpatch)) + + ! update all information of landpatch + landpatch%eindex = eindex_(1:numpatch) + landpatch%ipxstt = ipxstt_(1:numpatch) + landpatch%ipxend = ipxend_(1:numpatch) + landpatch%settyp = settyp_(1:numpatch) + landpatch%ielm = ielm_ (1:numpatch) + + ENDIF + ENDIF + + landpatch%nset = numpatch + + CALL landpatch%set_vecgs + + IF (allocated (eindex_ )) deallocate (eindex_ ) + IF (allocated (settyp_ )) deallocate (settyp_ ) + IF (allocated (ipxstt_ )) deallocate (ipxstt_ ) + IF (allocated (ipxend_ )) deallocate (ipxend_ ) + IF (allocated (ielm_ )) deallocate (ielm_ ) + IF (allocated (locpth )) deallocate (locpth ) + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' +#endif + + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + + CALL write_patchfrac (DEF_dir_landdata, lc_year) + + END SUBROUTINE land2mwmo_build + + SUBROUTINE land2mwmo_init + USE MOD_Mesh + IMPLICIT NONE + + allocate (wmo_patch (numelm)) + allocate (wmo_source (numelm)) + + wmo_patch = -1 + wmo_source = -1 + + END SUBROUTINE land2mwmo_init + + SUBROUTINE land2mwmo_final + IMPLICIT NONE + + IF (allocated (wmo_patch )) deallocate (wmo_patch ) + IF (allocated (wmo_source)) deallocate (wmo_source) + + END SUBROUTINE land2mwmo_final + +END MODULE MOD_Land2mWMO diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 new file mode 100644 index 0000000000..9e743711d1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 @@ -0,0 +1,152 @@ +#include + +#ifdef CROP +MODULE MOD_LandCrop + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build crop patches. +! +! Created by Shupeng Zhang, Sep 2023 +! porting codes from Hua Yuan's OpenMP version to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Grid + IMPLICIT NONE + + ! ---- Instance ---- + type(grid_type) :: grid_crop + integer, allocatable :: cropclass (:) + real(r8), allocatable :: cropfrac (:) + +CONTAINS + + ! ------------------------------- + SUBROUTINE landcrop_build (lc_year) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Block + USE MOD_DataType + USE MOD_LandElm +#ifdef CATCHMENT + USE MOD_LandHRU +#endif + USE MOD_LandPatch + USE MOD_NetCDFBlock + USE MOD_PixelsetShared + USE MOD_5x5DataReadin + + IMPLICIT NONE + + integer, intent(in) :: lc_year + + ! Local Variables + character(len=255) :: cyear, file_patch, dir_5x5, suffix + integer :: npatch_glb + type(block_data_real8_2d) :: pctcrop_xy + type(block_data_real8_3d) :: pctshared_xy + type(block_data_real8_3d) :: cropdata + integer :: sharedfilter(1), cropfilter(1) + integer :: iblkme, ib, jb + real(r8), allocatable :: pctshared (:) + integer , allocatable :: classshared(:) + + write(cyear,'(i4.4)') lc_year + IF (p_is_master) THEN + write(*,'(A)') 'Making patches (crop shared):' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_io) THEN + + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(cyear) + + CALL allocate_block_data (grid_patch, pctcrop_xy) + CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'PCT_CROP', pctcrop_xy) + + CALL allocate_block_data (grid_patch, pctshared_xy, 2) + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + pctshared_xy%blk(ib,jb)%val(1,:,:) = 1. - pctcrop_xy%blk(ib,jb)%val/100. + pctshared_xy%blk(ib,jb)%val(2,:,:) = pctcrop_xy%blk(ib,jb)%val/100. + ENDDO + ENDIF + + sharedfilter = (/ 1 /) + + IF (landpatch%has_shared) then + CALL pixelsetshared_build (landpatch, grid_patch, pctshared_xy, 2, sharedfilter, & + pctshared, classshared, fracin = landpatch%pctshared) + ELSE + CALL pixelsetshared_build (landpatch, grid_patch, pctshared_xy, 2, sharedfilter, & + pctshared, classshared) + ENDIF + + IF (p_is_worker) THEN + IF (landpatch%nset > 0) THEN + WHERE (classshared == 2) landpatch%settyp = CROPLAND + ENDIF + ENDIF + + IF (p_is_io) THEN + file_patch = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc' + CALL allocate_block_data (grid_crop, cropdata, N_CFT) + CALL ncio_read_block (file_patch, 'PCT_CFT', grid_crop, N_CFT, cropdata) + ENDIF + + cropfilter = (/ CROPLAND /) + + CALL pixelsetshared_build (landpatch, grid_crop, cropdata, N_CFT, cropfilter, & + cropfrac, cropclass, fracin = pctshared) + + numpatch = landpatch%nset + + landpatch%has_shared = .true. + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + IF (allocated(landpatch%pctshared)) THEN + deallocate(landpatch%pctshared) + ENDIF + + allocate(landpatch%pctshared(numpatch)) + landpatch%pctshared = cropfrac + ENDIF + ENDIF + + IF (allocated(pctshared )) deallocate(pctshared ) + IF (allocated(classshared)) deallocate(classshared) + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches (with crop).' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' +#endif + +IF ( .not. DEF_Output_2mWMO ) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) +#ifdef CATCHMENT + CALL hru_patch%build (landhru, landpatch, use_frac = .true.) +#endif + + CALL write_patchfrac (DEF_dir_landdata, lc_year) +ENDIF + + END SUBROUTINE landcrop_build + +END MODULE MOD_LandCrop +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 new file mode 100644 index 0000000000..290039b763 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 @@ -0,0 +1,84 @@ +#include + +MODULE MOD_LandElm + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landelm". +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landelm" refers to pixelset ELEMENT. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Pixelset + IMPLICIT NONE + + ! ---- Instance ---- + type(pixelset_type) :: landelm + +CONTAINS + + ! ------------------------------- + SUBROUTINE landelm_build + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Mesh + IMPLICIT NONE + + ! Local Variables + integer :: ielm, nelm_glb + + IF (p_is_master) THEN + write(*,'(A)') 'Making land elements:' + ENDIF + + IF (p_is_worker) THEN + + allocate (landelm%eindex (numelm)) + allocate (landelm%ipxstt (numelm)) + allocate (landelm%ipxend (numelm)) + allocate (landelm%settyp (numelm)) + allocate (landelm%ielm (numelm)) + + DO ielm = 1, numelm + landelm%eindex(ielm) = mesh(ielm)%indx + landelm%ipxstt(ielm) = 1 + landelm%ipxend(ielm) = mesh(ielm)%npxl + landelm%settyp(ielm) = 0 + landelm%ielm (ielm) = ielm + ENDDO + + ENDIF + + landelm%nset = numelm + CALL landelm%set_vecgs + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_worker) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numelm, ' elements.' +#endif + + END SUBROUTINE landelm_build + +END MODULE MOD_LandElm diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 new file mode 100644 index 0000000000..01c3832a21 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 @@ -0,0 +1,222 @@ +#include + +#ifdef CATCHMENT + +MODULE MOD_LandHRU + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landhru". +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landhru" refers to pixelset HRU. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Pixelset + USE MOD_Grid + IMPLICIT NONE + + ! ---- Instance ---- + integer :: numhru + type(grid_type) :: grid_hru + type(pixelset_type) :: landhru + + type(subset_type) :: elm_hru + +CONTAINS + + ! ------------------------------- + SUBROUTINE landhru_build () + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_NetcdfSerial + USE MOD_Utils + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandElm + USE MOD_CatchmentDataReadin + USE MOD_Namelist + USE MOD_AggregationRequestData + + IMPLICIT NONE + + ! Local Variables + type (block_data_int32_2d) :: hrudata + integer :: iwork, ncat, nhru, ie, typsgn, npxl, ipxl + integer*8, allocatable :: catnum(:) + integer, allocatable :: numhru_all_g(:), lakeid(:) + integer, allocatable :: types(:), order(:), ibuff(:) + integer :: nhru_glb + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,'(A)') 'Making land hydro units:' + ENDIF + + IF (p_is_master) THEN + CALL ncio_read_serial (DEF_CatchmentMesh_data, 'basin_numhru', numhru_all_g) + CALL ncio_read_serial (DEF_CatchmentMesh_data, 'lake_id', lakeid) + ENDIF + +#ifdef USEMPI + IF (p_is_master) THEN + DO iwork = 0, p_np_worker-1 + + CALL mpi_recv (ncat, 1, MPI_INTEGER, p_address_worker(iwork), mpi_tag_size, & + p_comm_glb, p_stat, p_err) + + IF (ncat > 0) THEN + allocate (catnum(ncat)) + allocate (ibuff (ncat)) + + CALL mpi_recv (catnum, ncat, MPI_INTEGER8, p_address_worker(iwork), mpi_tag_data, & + p_comm_glb, p_stat, p_err) + + nhru = sum(numhru_all_g(catnum)) + CALL mpi_send (nhru, 1, MPI_INTEGER, & + p_address_worker(iwork), mpi_tag_size, p_comm_glb, p_err) + + ibuff = lakeid(catnum) + CALL mpi_send (ibuff, ncat, MPI_INTEGER, & + p_address_worker(iwork), mpi_tag_data, p_comm_glb, p_err) + + deallocate(catnum) + deallocate(ibuff ) + ENDIF + ENDDO + ENDIF + + IF (p_is_worker) THEN + CALL mpi_send (numelm, 1, MPI_INTEGER, p_address_master, mpi_tag_size, p_comm_glb, p_err) + IF (numelm > 0) THEN + allocate (lakeid (numelm)) + CALL mpi_send (landelm%eindex, numelm, MPI_INTEGER8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_recv (numhru, 1, MPI_INTEGER, p_address_master, mpi_tag_size, p_comm_glb, p_stat, p_err) + CALL mpi_recv (lakeid, numelm, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + ELSE + numhru = 0 + ENDIF + ENDIF +#else + numhru = sum(numhru_all_g) +#endif + + IF (p_is_master) THEN + IF (allocated(numhru_all_g)) deallocate(numhru_all_g) + ENDIF + + IF (p_is_io) CALL allocate_block_data (grid_hru, hrudata) + CALL catchment_data_read (DEF_CatchmentMesh_data, 'ihydrounit2d', grid_hru, hrudata) + +#ifdef USEMPI + IF (p_is_io) THEN + CALL aggregation_data_daemon (grid_hru, data_i4_2d_in1 = hrudata) + ENDIF +#endif + + IF (p_is_worker) THEN + + IF (numhru > 0) THEN + allocate (landhru%eindex (numhru)) + allocate (landhru%settyp (numhru)) + allocate (landhru%ipxstt (numhru)) + allocate (landhru%ipxend (numhru)) + allocate (landhru%ielm (numhru)) + ENDIF + + numhru = 0 + + DO ie = 1, numelm + + IF (lakeid(ie) > 0) THEN + typsgn = -1 + ELSE + typsgn = 1 + ENDIF + + npxl = mesh(ie)%npxl + + allocate (types (1:npxl)) + + CALL aggregation_request_data (landelm, ie, grid_hru, zip = .false., & + data_i4_2d_in1 = hrudata, data_i4_2d_out1 = ibuff) + + types = ibuff + + allocate (order (1:npxl)) + order = (/ (ipxl, ipxl = 1, npxl) /) + + CALL quicksort (npxl, types, order) + + mesh(ie)%ilon(1:npxl) = mesh(ie)%ilon(order) + mesh(ie)%ilat(1:npxl) = mesh(ie)%ilat(order) + + DO ipxl = 1, npxl + IF (ipxl == 1) THEN + numhru = numhru + 1 + landhru%eindex (numhru) = mesh(ie)%indx + landhru%settyp (numhru) = types(ipxl) * typsgn + landhru%ipxstt (numhru) = ipxl + landhru%ielm (numhru) = ie + ELSEIF (types(ipxl) /= types(ipxl-1)) THEN + landhru%ipxend(numhru) = ipxl - 1 + + numhru = numhru + 1 + landhru%eindex (numhru) = mesh(ie)%indx + landhru%settyp (numhru) = types(ipxl) * typsgn + landhru%ipxstt (numhru) = ipxl + landhru%ielm (numhru) = ie + ENDIF + ENDDO + landhru%ipxend(numhru) = npxl + + deallocate (ibuff) + deallocate (types) + deallocate (order) + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + landhru%nset = numhru + CALL landhru%set_vecgs + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numhru, nhru_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', nhru_glb, ' hydro units.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numhru, ' hydro units.' +#endif + + IF (allocated(lakeid)) deallocate(lakeid) + + END SUBROUTINE landhru_build + +END MODULE MOD_LandHRU +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 new file mode 100644 index 0000000000..e7be9e00df --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 @@ -0,0 +1,326 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_LandPFT + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landpft" (Plant Function Type). +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landpft" refers to pixelset PFT. +! +! Created by Shupeng Zhang, May 2023 +! porting codes from Hua Yuan's OpenMP version to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Namelist + USE MOD_Pixelset + USE MOD_Const_LC + USE MOD_Vars_Global + IMPLICIT NONE + + ! ---- Instance ---- + integer :: numpft + type(pixelset_type) :: landpft + + integer , allocatable :: pft2patch (:) !patch index of a PFT + integer , allocatable :: patch_pft_s (:) !start PFT index of a patch + integer , allocatable :: patch_pft_e (:) !end PFT index of a patch + + ! ---- PUBLIC routines ---- + PUBLIC :: landpft_build + +CONTAINS + + ! ------------------------------- + SUBROUTINE landpft_build (lc_year) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_DataType + USE MOD_Namelist + USE MOD_5x5DataReadin + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_AggregationRequestData + USE MOD_Const_LC +#ifdef CROP + USE MOD_LandCrop +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year + ! Local Variables + character(len=256) :: dir_5x5, suffix, cyear + type (block_data_real8_3d) :: pctpft + real(r8), allocatable :: pctpft_patch(:,:), pctpft_one(:,:) + real(r8), allocatable :: area_one (:) + logical, allocatable :: patchmask (:) + integer :: ipatch, ipft, npatch, npft, npft_glb + integer :: wmo_src, ipft_grass + real(r8) :: sumarea, maxgrass + + IF (p_is_master) THEN + write(*,'(A)') 'Making land plant function type tiles:' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + landpft%has_shared = .true. + + IF (p_is_io) THEN + + CALL allocate_block_data (grid_patch, pctpft, N_PFT_modis, lb1 = 0) + CALL flush_block_data (pctpft, 1.0) + + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + ! add parameter input for time year + write(cyear,'(i4.4)') lc_year + suffix = 'MOD'//trim(cyear) + CALL read_5x5_data_pft (dir_5x5, suffix, grid_patch, 'PCT_PFT', pctpft) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_patch, data_r8_3d_in1 = pctpft, n1_r8_3d_in1 = N_PFT_modis) +#endif + ENDIF + + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + allocate (pctpft_patch (0:N_PFT-1,numpatch)) + allocate (patchmask (numpatch)) + + pctpft_patch(:,:) = 0 + patchmask (:) = .true. + ENDIF + + DO ipatch = 1, numpatch + + IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN + + wmo_src = wmo_source(landpatch%ielm(ipatch)) + maxgrass = maxval(pctpft_patch(12:14,wmo_src)) + + IF (maxgrass > 0) THEN + ipft_grass = maxloc(pctpft_patch(12:14,wmo_src), dim=1) + 11 + pctpft_patch(:,ipatch) = 0 + pctpft_patch(ipft_grass,ipatch) = 1. + ELSE + pctpft_patch(0,ipatch) = 1. + ENDIF + + CYCLE + ENDIF +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + CALL aggregation_request_data (landpatch, ipatch, grid_patch, zip = .false., area = area_one, & + data_r8_3d_in1 = pctpft, data_r8_3d_out1 = pctpft_one, n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) + + sumarea = sum(area_one * sum(pctpft_one(0:N_PFT-1,:),dim=1)) + + ! in case of no PFT data, set to 100% bare when patchtype=0, + ! be consistent with Aggregation_PercentagesPFT.F90. + IF (sumarea <= 0.0) THEN + pctpft_patch(0,ipatch) = 1. + ELSE + DO ipft = 0, N_PFT-1 + pctpft_patch(ipft,ipatch) = sum(pctpft_one(ipft,:) * area_one) / sumarea + ENDDO + ENDIF + + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + + IF (numpatch > 0) THEN + npatch = count(patchmask) + numpft = count(pctpft_patch > 0.) +#ifdef CROP + numpft = numpft + count(landpatch%settyp == CROPLAND) +#endif + IF (npatch > 0) THEN + allocate (patch_pft_s (npatch)) + allocate (patch_pft_e (npatch)) + ENDIF + ELSE + numpft = 0 + ENDIF + + IF (numpft > 0) THEN + + allocate (pft2patch (numpft)) + + allocate (landpft%eindex (numpft)) + allocate (landpft%settyp (numpft)) + allocate (landpft%ipxstt (numpft)) + allocate (landpft%ipxend (numpft)) + allocate (landpft%ielm (numpft)) + + allocate (landpft%pctshared (numpft)) + landpft%pctshared(:) = 1. + + npft = 0 + npatch = 0 + DO ipatch = 1, numpatch + IF (patchmask(ipatch)) THEN + npatch = npatch + 1 + +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + patch_pft_s(npatch) = npft + 1 + patch_pft_e(npatch) = npft + count(pctpft_patch(:,ipatch) > 0) + + DO ipft = 0, N_PFT-1 + IF (pctpft_patch(ipft,ipatch) > 0) THEN + npft = npft + 1 + + landpft%ielm (npft) = landpatch%ielm (ipatch) + landpft%eindex(npft) = landpatch%eindex(ipatch) + landpft%ipxstt(npft) = landpatch%ipxstt(ipatch) + landpft%ipxend(npft) = landpatch%ipxend(ipatch) + landpft%settyp(npft) = ipft + + landpft%pctshared(npft) = pctpft_patch(ipft,ipatch) + + pft2patch(npft) = npatch + ENDIF + ENDDO +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + npft = npft + 1 + patch_pft_s(npatch) = npft + patch_pft_e(npatch) = npft + + landpft%ielm (npft) = landpatch%ielm (ipatch) + landpft%eindex(npft) = landpatch%eindex(ipatch) + landpft%ipxstt(npft) = landpatch%ipxstt(ipatch) + landpft%ipxend(npft) = landpatch%ipxend(ipatch) + landpft%settyp(npft) = cropclass(ipatch) + N_PFT - 1 + + landpft%pctshared(npft) = landpatch%pctshared(ipatch) + + pft2patch(npft) = npatch +#endif + ELSE + patch_pft_s(npatch) = -1 + patch_pft_e(npatch) = -1 + ENDIF + ENDIF + ENDDO + + ENDIF + + ENDIF + + CALL landpatch%pset_pack(patchmask, numpatch) + + landpft%nset = numpft + CALL landpft%set_vecgs + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numpft, npft_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', npft_glb, ' plant function type tiles.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numpft, ' plant function type tiles.' +#endif + + IF (allocated(pctpft_patch)) deallocate (pctpft_patch) + IF (allocated(pctpft_one )) deallocate (pctpft_one ) + IF (allocated(area_one )) deallocate (area_one ) + IF (allocated(patchmask )) deallocate (patchmask ) + + END SUBROUTINE landpft_build + + ! ---------------------- + SUBROUTINE map_patch_to_pft + + USE MOD_SPMD_Task + USE MOD_LandPatch + USE MOD_Const_LC + IMPLICIT NONE + + integer :: ipatch, ipft + + IF (p_is_worker) THEN + + IF ((numpatch <= 0) .or. (numpft <= 0)) RETURN + + IF (allocated(patch_pft_s)) deallocate(patch_pft_s) + IF (allocated(patch_pft_e)) deallocate(patch_pft_e) + IF (allocated(pft2patch )) deallocate(pft2patch ) + + allocate (patch_pft_s (numpatch)) + allocate (patch_pft_e (numpatch)) + allocate (pft2patch (numpft )) + + ipft = 1 + DO ipatch = 1, numpatch +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + + patch_pft_s(ipatch) = ipft + + DO WHILE (ipft <= numpft) + IF ((landpft%eindex(ipft) == landpatch%eindex(ipatch)) & + .and. (landpft%ipxstt(ipft) == landpatch%ipxstt(ipatch)) & + .and. (landpft%settyp(ipft) < N_PFT)) THEN + pft2patch (ipft ) = ipatch + patch_pft_e(ipatch) = ipft + ipft = ipft + 1 + ELSE + EXIT + ENDIF + ENDDO +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + patch_pft_s(ipatch) = ipft + patch_pft_e(ipatch) = ipft + pft2patch (ipft ) = ipatch + ipft = ipft + 1 +#endif + ELSE + patch_pft_s(ipatch) = -1 + patch_pft_e(ipatch) = -1 + ENDIF + + ENDDO + + ENDIF + + END SUBROUTINE map_patch_to_pft + +END MODULE MOD_LandPFT +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 new file mode 100644 index 0000000000..d3bf9f1387 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 @@ -0,0 +1,319 @@ +#include + +MODULE MOD_LandPatch + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landpatch". +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landpatch" refers to pixelset PATCH. +! +! Created by Shupeng Zhang, May 2023 +! porting codes from Hua Yuan's OpenMP version to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_Vars_Global + USE MOD_Const_LC + IMPLICIT NONE + + ! ---- Instance ---- + integer :: numpatch + type(grid_type) :: grid_patch + type(pixelset_type) :: landpatch + + type(subset_type) :: elm_patch + type(superset_type) :: patch2elm + +#ifdef CATCHMENT + type(subset_type) :: hru_patch + type(superset_type) :: patch2hru +#endif + + +CONTAINS + + ! ------------------------------- + SUBROUTINE landpatch_build (lc_year) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Utils + USE MOD_UserDefFun + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandElm +#ifdef CATCHMENT + USE MOD_LandHRU +#endif + USE MOD_Namelist + USE MOD_NetCDFBlock + USE MOD_AggregationRequestData + + IMPLICIT NONE + + integer, intent(in) :: lc_year + ! Local Variables + character(len=256) :: file_patch + character(len=255) :: cyear + type (block_data_int32_2d) :: patchdata + integer :: iloc, npxl, ipxl, numset + integer :: ie, iset, ipxstt, ipxend + integer, allocatable :: types(:), order(:), ibuff(:) + integer*8, allocatable :: eindex_tmp(:) + integer, allocatable :: settyp_tmp(:), ipxstt_tmp(:), ipxend_tmp(:), ielm_tmp(:) + logical, allocatable :: msk(:) + integer :: npatch_glb + integer :: dominant_type + integer, allocatable :: npxl_types (:) + + write(cyear,'(i4.4)') lc_year + IF (p_is_master) THEN + write(*,'(A)') 'Making land patches:' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_io) THEN + + CALL allocate_block_data (grid_patch, patchdata) + +#ifndef LULC_USGS + ! add parameter input for time year + file_patch = trim(DEF_dir_rawdata)//'landtypes/landtype-igbp-modis-'//trim(cyear)//'.nc' +#else + !TODO: need usgs land cover type data + file_patch = trim(DEF_dir_rawdata) //'/landtypes/landtype-usgs-update.nc' +#endif + CALL ncio_read_block (file_patch, 'landtype', grid_patch, patchdata) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_patch, data_i4_2d_in1 = patchdata) +#endif + ENDIF + + IF (p_is_worker) THEN + +#ifdef CATCHMENT + numset = numhru +#else + numset = numelm +#endif + + IF (numset > 0) THEN + allocate (eindex_tmp (numset*N_land_classification)) + allocate (settyp_tmp (numset*N_land_classification)) + allocate (ipxstt_tmp (numset*N_land_classification)) + allocate (ipxend_tmp (numset*N_land_classification)) + allocate (ielm_tmp (numset*N_land_classification)) + ENDIF + + numpatch = 0 + + DO iset = 1, numset +#ifdef CATCHMENT + ie = landhru%ielm (iset) + ipxstt = landhru%ipxstt(iset) + ipxend = landhru%ipxend(iset) +#else + ie = landelm%ielm (iset) + ipxstt = landelm%ipxstt(iset) + ipxend = landelm%ipxend(iset) +#endif + + npxl = ipxend - ipxstt + 1 + + allocate (types (ipxstt:ipxend)) + +#ifdef CATCHMENT + CALL aggregation_request_data (landhru, iset, grid_patch, zip = .false., & +#else + CALL aggregation_request_data (landelm, iset, grid_patch, zip = .false., & +#endif + data_i4_2d_in1 = patchdata, data_i4_2d_out1 = ibuff) + + + types(:) = ibuff + deallocate (ibuff) + +#ifdef CATCHMENT + IF (landhru%settyp(iset) <= 0) THEN + types(ipxstt:ipxend) = WATERBODY + ENDIF + WHERE (types == 0) + ! set land in MERITHydro while ocean in landtype data as water body + types = WATERBODY + END WHERE + WHERE (types == 11) + types = 10 + END WHERE +#endif + + IF ((DEF_USE_PFT .and. (.not. DEF_SOLO_PFT)) .or. DEF_FAST_PC) THEN + ! For classification of plant function types or fast PC, + ! merge all land types with soil ground + DO ipxl = ipxstt, ipxend + IF (types(ipxl) > 0) THEN + IF (patchtypes(types(ipxl)) == 0) THEN + ! Deal with cropland separately for fast PC + IF (DEF_FAST_PC .and. & + (types(ipxl)==CROPLAND .or. types(ipxl)==14)) THEN + types(ipxl) = CROPLAND + ELSE + types(ipxl) = 1 + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + + allocate (order (ipxstt:ipxend)) + order = (/ (ipxl, ipxl = ipxstt, ipxend) /) + + CALL quicksort (npxl, types, order) + + mesh(ie)%ilon(ipxstt:ipxend) = mesh(ie)%ilon(order) + mesh(ie)%ilat(ipxstt:ipxend) = mesh(ie)%ilat(order) + + IF (DEF_USE_DOMINANT_PATCHTYPE) THEN + allocate (npxl_types (0:maxval(types))) + npxl_types(:) = 0 + DO ipxl = ipxstt, ipxend + npxl_types(types(ipxl)) = npxl_types(types(ipxl)) + 1 + ENDDO + + IF (any(types > 0)) THEN + iloc = findloc_ud(types > 0) + ipxstt - 1 + dominant_type = maxloc(npxl_types(1:), dim=1) + types(iloc:ipxend) = dominant_type + ENDIF + + deallocate(npxl_types) + ENDIF + + DO ipxl = ipxstt, ipxend + IF (ipxl == ipxstt) THEN + numpatch = numpatch + 1 + eindex_tmp(numpatch) = mesh(ie)%indx + settyp_tmp(numpatch) = types(ipxl) + ipxstt_tmp(numpatch) = ipxl + ielm_tmp (numpatch) = ie + ELSEIF (types(ipxl) /= types(ipxl-1)) THEN + ipxend_tmp(numpatch) = ipxl - 1 + + numpatch = numpatch + 1 + eindex_tmp(numpatch) = mesh(ie)%indx + settyp_tmp(numpatch) = types(ipxl) + ipxstt_tmp(numpatch) = ipxl + ielm_tmp (numpatch) = ie + ENDIF + ENDDO + ipxend_tmp(numpatch) = ipxend + + deallocate (types) + deallocate (order) + + ENDDO + + IF (numpatch > 0) THEN + allocate (landpatch%eindex (numpatch)) + allocate (landpatch%settyp (numpatch)) + allocate (landpatch%ipxstt (numpatch)) + allocate (landpatch%ipxend (numpatch)) + allocate (landpatch%ielm (numpatch)) + + landpatch%eindex = eindex_tmp(1:numpatch) + landpatch%ipxstt = ipxstt_tmp(1:numpatch) + landpatch%ipxend = ipxend_tmp(1:numpatch) + landpatch%settyp = settyp_tmp(1:numpatch) + landpatch%ielm = ielm_tmp (1:numpatch) + ENDIF + + IF (numset > 0) THEN + deallocate (eindex_tmp) + deallocate (ipxstt_tmp) + deallocate (ipxend_tmp) + deallocate (settyp_tmp) + deallocate (ielm_tmp ) + ENDIF + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + + ENDIF + + landpatch%nset = numpatch + + CALL landpatch%set_vecgs + + +#if (!defined(URBAN_MODEL) && !defined(CROP)) +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' +#endif + +IF ( .not. DEF_Output_2mWMO ) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) +#ifdef CATCHMENT + CALL hru_patch%build (landhru, landpatch, use_frac = .true.) +#endif + + CALL write_patchfrac (DEF_dir_landdata, lc_year) +ENDIF +#endif + + END SUBROUTINE landpatch_build + + ! ----- + SUBROUTINE write_patchfrac (dir_landdata, lc_year) + + USE MOD_Namelist + USE MOD_NetCDFVector + IMPLICIT NONE + + integer, intent(in) :: lc_year + character(len=*), intent(in) :: dir_landdata + character(len=256) :: lndname, cyear + + write(cyear,'(i4.4)') lc_year + CALL system('mkdir -p ' // trim(dir_landdata) // '/landpatch/' // trim(cyear)) + + lndname = trim(dir_landdata)//'/landpatch/'//trim(cyear)//'/patchfrac_elm.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'patchfrac_elm', 'patch', landpatch, elm_patch%subfrc, DEF_Srfdata_CompressLevel) + +#ifdef CATCHMENT + lndname = trim(dir_landdata)//'/landpatch/'//trim(cyear)//'/patchfrac_hru.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'patchfrac_hru', 'patch', landpatch, hru_patch%subfrc, DEF_Srfdata_CompressLevel) +#endif + + END SUBROUTINE write_patchfrac + +END MODULE MOD_LandPatch diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 new file mode 100644 index 0000000000..3a57e5acfc --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 @@ -0,0 +1,409 @@ +#include + +MODULE MOD_LandUrban +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Build pixelset "landurban". +! +! Original authors: Hua Yuan and Wenzong Dong, 2021, OpenMP version. +! +! +! !REVISIONS: +! 05/2023, Wenzong Dong, Hua Yuan, Shupeng Zhang: porting codes to MPI +! parallel version. +! +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_Pixelset + USE MOD_Vars_Global, only: N_URB, URBAN + + IMPLICIT NONE + + ! ---- Instance ---- + type(grid_type) :: grid_urban + + integer :: numurban + type(pixelset_type) :: landurban + + integer , allocatable :: urban_reg (:) !region index of a urban + integer , allocatable :: urban2patch (:) !patch index of a urban + integer , allocatable :: patch2urban (:) !urban index of a patch + + ! ---- PUBLIC routines ---- + PUBLIC :: landurban_build + PUBLIC :: map_patch_to_urban + +CONTAINS + + ! ------------------------------- + SUBROUTINE landurban_build (lc_year) + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_NetCDFBlock + USE MOD_Grid + USE MOD_DataType + USE MOD_Namelist + USE MOD_5x5DataReadin + USE MOD_Mesh + USE MOD_LandPatch + USE MOD_LandElm +#ifdef CATCHMENT + USE MOD_LandHRU +#endif + USE MOD_AggregationRequestData + USE MOD_Utils + + IMPLICIT NONE + + integer, intent(in) :: lc_year + ! Local Variables + character(len=256) :: dir_urban + type (block_data_int32_2d) :: data_urb_class ! urban type index + + ! local vars + integer, allocatable :: ibuff(:), types(:), order(:) + + ! index + integer :: ipatch, jpatch, iurban + integer :: ie, ipxstt, ipxend, npxl, ipxl + integer :: nurb_glb, npatch_glb + + ! local vars for landpath and landurban + integer :: numpatch_ + integer*8, allocatable :: eindex_(:) + integer, allocatable :: ipxstt_(:) + integer, allocatable :: ipxend_(:) + integer, allocatable :: settyp_(:) + integer, allocatable :: ielm_ (:) + + integer :: numurban_ + integer :: iurb, ib, imiss + integer :: buff_count(N_URB) + real(r8) :: buff_p(N_URB) + + integer , allocatable :: urbclass (:) + real(r8), allocatable :: area_one (:) + + character(len=256) :: suffix, cyear + + IF (p_is_master) THEN + write(*,'(A)') 'Making urban type tiles:' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ! allocate and read the grided LCZ/NCAR urban type + IF (p_is_io) THEN + + dir_urban = trim(DEF_dir_rawdata) // '/urban_type' + + CALL allocate_block_data (grid_urban, data_urb_class) + CALL flush_block_data (data_urb_class, 0) + + ! read urban type data + suffix = 'URBTYP' +IF (DEF_URBAN_type_scheme == 1) THEN + CALL read_5x5_data (dir_urban, suffix, grid_urban, 'URBAN_DENSITY_CLASS', data_urb_class) +ELSE IF (DEF_URBAN_type_scheme == 2) THEN + CALL read_5x5_data (dir_urban, suffix, grid_urban, 'LCZ_DOM', data_urb_class) +ENDIF + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_urban, data_i4_2d_in1 = data_urb_class) +#endif + ENDIF + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + ! a temporary numpatch with max urban patch number + numpatch_ = numpatch + count(landpatch%settyp == URBAN) * (N_URB-1) + + allocate (eindex_ (numpatch_ )) + allocate (ipxstt_ (numpatch_ )) + allocate (ipxend_ (numpatch_ )) + allocate (settyp_ (numpatch_ )) + allocate (ielm_ (numpatch_ )) + + ! max urban patch number (temporary) + numurban_ = count(landpatch%settyp == URBAN) * N_URB + IF (numurban_ > 0) THEN + allocate (urbclass(numurban_)) + ENDIF + ENDIF + + jpatch = 0 + iurban = 0 + + ! loop for temporary numpatch to filter duplicate urban patch + DO ipatch = 1, numpatch + IF (landpatch%settyp(ipatch) == URBAN) THEN + + ie = landpatch%ielm (ipatch) + ipxstt = landpatch%ipxstt(ipatch) + ipxend = landpatch%ipxend(ipatch) + + CALL aggregation_request_data (landpatch, ipatch, grid_urban, zip = .false., area = area_one, & + data_i4_2d_in1 = data_urb_class, data_i4_2d_out1 = ibuff) + + ! when there is missing urban types + !NOTE@tungwz: need double check below and add appropriate annotations + ! check if there is urban pixel without URBAN ID + imiss = count(ibuff<1 .or. ibuff>N_URB) + IF (imiss > 0) THEN + ! Calculate the relative ratio of each urban types by excluding urban pixels without URBAN ID + WHERE (ibuff<1 .or. ibuff>N_URB) + area_one = 0 + END WHERE + + buff_p = 0 + IF (sum(area_one) > 0) THEN + DO ib = 1, size(area_one) + IF (ibuff(ib)>1 .and. ibuff(ib)N_URB) THEN + type_loop: DO iurb = 1, N_URB + IF (buff_count(iurb) > 0) THEN + ibuff(ib) = iurb + buff_count(iurb) = buff_count(iurb) - 1 + EXIT type_loop + ENDIF + ENDDO type_loop + ENDIF + ENDDO + ENDIF + ENDIF + + npxl = ipxend - ipxstt + 1 + + allocate (types (ipxstt:ipxend)) + + types(:) = ibuff + + deallocate (ibuff) + + allocate (order (ipxstt:ipxend)) + order = (/ (ipxl, ipxl = ipxstt, ipxend) /) + + ! change order vars, types->regid ? still types below + ! add region information, because urban type may be same, + ! but from different region in this urban patch + ! relative code is changed + CALL quicksort (npxl, types, order) + + mesh(ie)%ilon(ipxstt:ipxend) = mesh(ie)%ilon(order) + mesh(ie)%ilat(ipxstt:ipxend) = mesh(ie)%ilat(order) + + DO ipxl = ipxstt, ipxend + IF (ipxl /= ipxstt) THEN + IF (types(ipxl) /= types(ipxl-1)) THEN + ipxend_(jpatch) = ipxl - 1 + ELSE + CYCLE + ENDIF + ENDIF + + jpatch = jpatch + 1 + eindex_(jpatch) = mesh(ie)%indx + settyp_(jpatch) = URBAN + ipxstt_(jpatch) = ipxl + ielm_ (jpatch) = ie + + iurban = iurban + 1 + urbclass(iurban) = types(ipxl) + ENDDO + + ipxend_(jpatch) = ipxend + + deallocate (types) + deallocate (order) + + ELSE + jpatch = jpatch + 1 + eindex_(jpatch) = landpatch%eindex(ipatch) + ipxstt_(jpatch) = landpatch%ipxstt(ipatch) + ipxend_(jpatch) = landpatch%ipxend(ipatch) + settyp_(jpatch) = landpatch%settyp(ipatch) + ielm_ (jpatch) = landpatch%ielm (ipatch) + ENDIF + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + + numpatch = jpatch + + IF (numpatch > 0) THEN + ! update landpath with new patch number + ! all urban type patch are included + IF (allocated (landpatch%eindex)) deallocate (landpatch%eindex) + IF (allocated (landpatch%ipxstt)) deallocate (landpatch%ipxstt) + IF (allocated (landpatch%ipxend)) deallocate (landpatch%ipxend) + IF (allocated (landpatch%settyp)) deallocate (landpatch%settyp) + IF (allocated (landpatch%ielm )) deallocate (landpatch%ielm ) + + allocate (landpatch%eindex (numpatch)) + allocate (landpatch%ipxstt (numpatch)) + allocate (landpatch%ipxend (numpatch)) + allocate (landpatch%settyp (numpatch)) + allocate (landpatch%ielm (numpatch)) + + ! update all information of landpatch + landpatch%eindex = eindex_(1:jpatch) + landpatch%ipxstt = ipxstt_(1:jpatch) + landpatch%ipxend = ipxend_(1:jpatch) + landpatch%settyp = settyp_(1:jpatch) + landpatch%ielm = ielm_ (1:jpatch) + ENDIF + + ! update urban patch number + IF (numpatch > 0) THEN + numurban = count(landpatch%settyp == URBAN) + ELSE + numurban = 0 + ENDIF + + IF (numurban > 0) THEN + allocate (landurban%eindex (numurban)) + allocate (landurban%settyp (numurban)) + allocate (landurban%ipxstt (numurban)) + allocate (landurban%ipxend (numurban)) + allocate (landurban%ielm (numurban)) + + ! copy urban path information from landpatch for landurban + landurban%eindex = pack(landpatch%eindex, landpatch%settyp == URBAN) + landurban%ipxstt = pack(landpatch%ipxstt, landpatch%settyp == URBAN) + landurban%ipxend = pack(landpatch%ipxend, landpatch%settyp == URBAN) + landurban%ielm = pack(landpatch%ielm , landpatch%settyp == URBAN) + + ! assign urban region id and type for each urban patch + landurban%settyp = urbclass(1:numurban) + ENDIF + + ! update land patch with urban type patch + ! set numurban + landurban%nset = numurban + landpatch%nset = numpatch + ENDIF + + CALL landpatch%set_vecgs + CALL landurban%set_vecgs + + CALL map_patch_to_urban + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numurban, nurb_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', nurb_glb, ' urban tiles.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numurban, ' urban tiles.' +#endif + +#ifndef CROP +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' +#endif + +IF ( .not. DEF_Output_2mWMO ) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) +#ifdef CATCHMENT + CALL hru_patch%build (landhru, landpatch, use_frac = .true.) +#endif + CALL write_patchfrac (DEF_dir_landdata, lc_year) +ENDIF +#endif + + IF (allocated (ibuff )) deallocate (ibuff ) + IF (allocated (types )) deallocate (types ) + IF (allocated (order )) deallocate (order ) + + IF (allocated (eindex_ )) deallocate (eindex_ ) + IF (allocated (ipxstt_ )) deallocate (ipxstt_ ) + IF (allocated (ipxend_ )) deallocate (ipxend_ ) + IF (allocated (settyp_ )) deallocate (settyp_ ) + IF (allocated (ielm_ )) deallocate (ielm_ ) + + IF (allocated (urbclass)) deallocate (urbclass ) + IF (allocated (area_one)) deallocate (area_one ) + + END SUBROUTINE landurban_build + + ! ---------------------- + SUBROUTINE map_patch_to_urban + + USE MOD_SPMD_Task + USE MOD_LandPatch + IMPLICIT NONE + + integer :: ipatch, iurban + + IF (p_is_worker) THEN + + IF ((numpatch <= 0) .or. (numurban <= 0)) RETURN + + IF (allocated(patch2urban)) deallocate(patch2urban) + IF (allocated(urban2patch)) deallocate(urban2patch) + allocate (patch2urban (numpatch)) + allocate (urban2patch (numurban)) + + iurban = 0 + DO ipatch = 1, numpatch + IF (landpatch%settyp(ipatch) == URBAN) THEN + iurban = iurban + 1 + patch2urban(ipatch) = iurban + urban2patch(iurban) = ipatch + ELSE + patch2urban(ipatch) = -1 + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE map_patch_to_urban + +END MODULE MOD_LandUrban diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 new file mode 100644 index 0000000000..70cba64e16 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 @@ -0,0 +1,293 @@ +#include + +MODULE MOD_Lulcc_TransferTrace + +!------------------------------------------------------------------------ +! +! !DESCRIPTION: +! The transfer matrix and patch tracing vector were created using the +! land cover type data of the adjacent two years. Based on next year's +! patch, the pixels within the patch and last years' land cover type of +! these pixels were obtained. Then the percent of source land cover +! type of each patch was derived. +! +! Created by Wanyi Lin, Shupeng Zhang and Hua Yuan, 07/2023 +! +! !HISTORY: +! 05/2025, Wanyi Lin and Hua Yuan: code moved from main/LULCC/, now generate +! the transfer matrix and patch tracing vector when making surface +! data and SAVE it to a type (lulcc) of surface data. +!------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE + + real(r8), allocatable, dimension(:,:) :: lccpct_patches(:,:) !frac of source patches in a patch + real(r8), allocatable, dimension(:,:) :: lccpct_matrix (:,:) !frac of source patches in a grid + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_LulccTransferTrace + PUBLIC :: deallocate_LulccTransferTrace + PUBLIC :: MAKE_LulccTransferTrace + + ! PRIVATE MEMBER FUNCTIONS: + + +CONTAINS + + + SUBROUTINE allocate_LulccTransferTrace + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time invariant variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_SPMD_Task + + IMPLICIT NONE + + integer :: nlc = N_land_classification + + IF (p_is_worker) THEN + allocate (lccpct_patches (numpatch, 0:nlc)) + lccpct_patches (:,:) = 0 + allocate (lccpct_matrix (numpatch, 0:nlc)) + lccpct_matrix (:,:) = 0 + ENDIF + + END SUBROUTINE allocate_LulccTransferTrace + + + SUBROUTINE MAKE_LulccTransferTrace (lc_year) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_Land2mWMO + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_AggregationRequestData + USE MOD_Mesh + USE MOD_MeshFilter + USE MOD_LandElm + USE MOD_DataType + USE MOD_Block + USE MOD_Pixel + USE MOD_5x5DataReadin + USE MOD_RegionClip + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year + +!-------------------------- Local Variables ---------------------------- + character(len=256) :: dir_5x5, suffix, lastyr, thisyr, dir_landdata, lndname + character(len=4) :: c2 + integer :: i,ipatch,ipxl,ipxstt,ipxend,numpxl,ilc + integer, allocatable, dimension(:) :: locpxl + type (block_data_int32_2d) :: lcdatafr !land cover data of last year + integer, allocatable, dimension(:) :: lcdatafr_one(:), lcfrbuff(:) + real(r8),allocatable, dimension(:) :: area_one(:) , areabuff(:) + real(r8) :: sum_areabuff, gridarea + integer, allocatable, dimension(:) :: grid_patch_s, grid_patch_e + logical :: first_call +! for surface data diag +#ifdef SrfdataDiag + integer :: ityp + integer, allocatable, dimension(:) :: typindex +#endif +!----------------------------------------------------------------------- + + IF ( (lc_year < 1990) .or. (lc_year < 2000 .and. MOD(lc_year, 5) /= 0) ) RETURN + + write(thisyr,'(i4.4)') lc_year + IF (lc_year <= 2000 .and. MOD(lc_year, 5) == 0) THEN + write(lastyr,'(i4.4)') MAX(1985, lc_year-5) + ELSE + write(lastyr,'(i4.4)') MAX(1985, lc_year-1) + ENDIF + + first_call = .true. + +#ifdef SrfdataDiag + allocate( typindex(N_land_classification+1) ) +#endif + + CALL allocate_LulccTransferTrace + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + CALL grid_patch%define_by_name ('colm_500m') + CALL pixel%assimilate_grid (grid_patch) + CALL pixel%map_to_grid (grid_patch) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_patch, lcdatafr) + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(lastyr) + ! read the previous year land cover data + ! TODO: Add IF statement for using different LC products + ! IF use MODIS data THEN + CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'LC', lcdatafr) + ! ELSE + ! 'LC_GLC' is not recomended for IGBP + !CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'LC_GLC', lcdatafr) + +#ifdef USEMPI + CALL aggregation_data_daemon (grid_patch, data_i4_2d_in1 = lcdatafr) +#endif + ENDIF + + ! ----------------------------------------------------------------- + ! extract the land cover type of pixels of last year for each patch + ! ----------------------------------------------------------------- + IF (p_is_worker) THEN + + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + + grid_patch_e (:) = -1 + grid_patch_s (:) = -1 + + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO + + DO i=1, numelm + ipatch = grid_patch_s (i) + + IF (ipatch.le.0) CYCLE + gridarea = 0 + + DO WHILE (ipatch.le.grid_patch_e(i)) + + !TODO-done: need to skip the 2m WMO patches + IF (ipatch == wmo_patch(landpatch%ielm(ipatch)) ) THEN + ipatch = ipatch + 1 + CYCLE + ENDIF + + ! using this year patch mapping to aggregate the previous year land cover data + CALL aggregation_request_data (landpatch, ipatch, grid_patch, zip = .true., & + area = area_one, data_i4_2d_in1 = lcdatafr, data_i4_2d_out1 = lcdatafr_one) + + ipxstt = landpatch%ipxstt(ipatch) + ipxend = landpatch%ipxend(ipatch) + + IF (allocated(lcfrbuff)) deallocate(lcfrbuff) + allocate(lcfrbuff(ipxstt:ipxend)) + lcfrbuff(:) = lcdatafr_one(:) + + IF (allocated(areabuff)) deallocate(areabuff) + allocate(areabuff(ipxstt:ipxend)) + areabuff(:) = area_one(:) + + sum_areabuff = sum(areabuff) + DO ipxl = ipxstt, ipxend + ! Transfer trace - the key codes to count for the source land cover types of LULCC + lccpct_patches(ipatch, lcfrbuff(ipxl)) = lccpct_patches(ipatch, lcfrbuff(ipxl)) & + + areabuff(ipxl) / sum_areabuff + lccpct_matrix (ipatch, lcfrbuff(ipxl)) = lccpct_matrix (ipatch, lcfrbuff(ipxl)) & + + areabuff(ipxl) + ENDDO + gridarea = gridarea + sum_areabuff + ipatch = ipatch + 1 + ENDDO + + lccpct_matrix(grid_patch_s(i):grid_patch_e(i), :) = & + lccpct_matrix (grid_patch_s(i):grid_patch_e(i), :) / gridarea + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + dir_landdata = DEF_dir_landdata + CALL system('mkdir -p ' // trim(dir_landdata) // '/lulcc/' // trim(thisyr)) + DO ilc = 0, N_land_classification + write(c2, '(i2.2)') ilc + lndname = trim(dir_landdata)//'/lulcc/'//trim(thisyr)//& + '/lccpct_patches_lc'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'lccpct_patches', 'patch', & + landpatch, lccpct_patches(:,ilc), DEF_Srfdata_CompressLevel) + ENDDO + +#ifdef SrfdataDiag + typindex = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_landdata) // & + '/diag/lccpct_matrix_' // trim(thisyr) // '.nc' + DO ilc = 0, N_land_classification + CALL srfdata_map_and_write (lccpct_matrix(:,ilc), landpatch%settyp, typindex, & + m_patch2diag, -1.0e36_r8, lndname, 'lccpct_matrix', compress = 0, & + write_mode = 'one', defval=0._r8, lastdimname = 'source_patch', lastdimvalue = ilc, & + create_mode=first_call) + IF ( first_call ) first_call = .false. + ENDDO + deallocate(typindex) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('lccpct_patches', lccpct_patches) + CALL check_vector_data ('lccpct_matrix' , lccpct_matrix ) +#endif + + IF (p_is_worker) THEN + IF (allocated(area_one)) deallocate (area_one) + ENDIF + + CALL deallocate_LulccTransferTrace + + END SUBROUTINE MAKE_LulccTransferTrace + + + + SUBROUTINE deallocate_LulccTransferTrace + ! -------------------------------------------------- + ! Deallocates memory for Lulcc time invariant variables + ! -------------------------------------------------- + USE MOD_SPMD_Task + + IF (p_is_worker) THEN + IF (allocated(lccpct_patches)) deallocate (lccpct_patches) + IF (allocated(lccpct_matrix )) deallocate (lccpct_matrix ) + ENDIF + + END SUBROUTINE deallocate_LulccTransferTrace + +END MODULE MOD_Lulcc_TransferTrace +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 new file mode 100644 index 0000000000..6ba1cc228b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 @@ -0,0 +1,181 @@ +#include + +MODULE MOD_MeshFilter + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Mesh filter. +! Mesh filter can be used to mask part of region or globe as needed. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Grid + IMPLICIT NONE + + logical :: has_mesh_filter + type(grid_type) :: grid_filter + +CONTAINS + + logical FUNCTION inquire_mesh_filter () + + USE MOD_SPMD_Task + USE MOD_Namelist + IMPLICIT NONE + logical :: fexists + + IF (p_is_master) THEN + + inquire (file=trim(DEF_file_mesh_filter), exist=fexists) + + IF (.not. fexists) THEN + write(*,'(/, 2A)') 'Note: Mesh Filter not used: file ', trim(DEF_file_mesh_filter) + ELSE + write(*,'(/, 2A)') 'Note: Mesh Filter from file ', trim(DEF_file_mesh_filter) + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (fexists, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#endif + + inquire_mesh_filter = fexists + + END FUNCTION inquire_mesh_filter + + ! ------------- + SUBROUTINE mesh_filter (gridf, ffilter, fvname) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFBlock + USE MOD_DataType + USE MOD_LandElm + USE MOD_Mesh + USE MOD_AggregationRequestData + USE MOD_Block + IMPLICIT NONE + + type(grid_type), intent(in) :: gridf + character(len=*), intent(in) :: ffilter + character(len=*), intent(in) :: fvname + + ! local variables: + ! --------------------------------------------------------------- + type (block_data_int32_2d) :: datafilter + integer, allocatable :: ifilter(:), xtemp(:), ytemp(:) + logical, allocatable :: filter(:) + integer :: ielm, jelm, npxl, nelm_glb + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,'(/, A)') 'Filtering pixels ...' + ENDIF + + IF (p_is_io) THEN + CALL allocate_block_data (gridf, datafilter) + CALL ncio_read_block (trim(ffilter), trim(fvname), gridf, datafilter) + +#ifdef USEMPI + CALL aggregation_data_daemon (gridf, data_i4_2d_in1 = datafilter) +#endif + ENDIF + + IF (p_is_worker) THEN + + jelm = 0 + DO ielm = 1, numelm + CALL aggregation_request_data (landelm, ielm, gridf, zip = .false., & + data_i4_2d_in1 = datafilter, data_i4_2d_out1 = ifilter, & + filledvalue_i4 = -1) + + allocate (filter (mesh(ielm)%npxl)) + filter = ifilter > 0 + + IF (any(filter)) THEN + jelm = jelm + 1 + IF (.not. all(filter)) THEN + + npxl = count(filter) + + allocate (xtemp(npxl)) + allocate (ytemp(npxl)) + xtemp = pack(mesh(ielm)%ilon, filter) + ytemp = pack(mesh(ielm)%ilat, filter) + + deallocate(mesh(ielm)%ilon) + deallocate(mesh(ielm)%ilat) + + mesh(ielm)%npxl = npxl + + allocate(mesh(ielm)%ilon(npxl)) + allocate(mesh(ielm)%ilat(npxl)) + mesh(ielm)%ilon = xtemp + mesh(ielm)%ilat = ytemp + + deallocate (xtemp) + deallocate (ytemp) + ENDIF + + IF (jelm /= ielm) THEN + CALL copy_elm (mesh(ielm), mesh(jelm)) + ENDIF + + ENDIF + + deallocate (filter) + ENDDO + + numelm = jelm + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + IF (p_is_worker) THEN + IF (allocated(landelm%eindex)) deallocate (landelm%eindex) + IF (allocated(landelm%ipxstt)) deallocate (landelm%ipxstt) + IF (allocated(landelm%ipxend)) deallocate (landelm%ipxend) + IF (allocated(landelm%settyp)) deallocate (landelm%settyp) + IF (allocated(landelm%ielm )) deallocate (landelm%ielm ) + ENDIF + + CALL landelm_build () + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements after mesh filtering.' + ENDIF + ENDIF +#else + write(*,'(A,I12,A)') 'Total: ', numelm, ' elements after mesh filtering.' +#endif + + ! Update nelm_blk + nelm_blk(:,:) = 0 + IF (p_is_worker) THEN + DO ielm = 1, numelm + nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) = & + nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) + 1 + ENDDO + ENDIF +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, & + MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE mesh_filter + +END MODULE MOD_MeshFilter diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 new file mode 100644 index 0000000000..b6de6c5bac --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 @@ -0,0 +1,213 @@ +#include + +MODULE MOD_PixelsetShared +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Shared pixelset refer to two or more pixelsets sharing the same geographic area. +! +! For example, for patch of crops, multiple crops can be planted on a piece of land. +! When planting these crops, different irrigation schemes may be used. Thus the water +! and energy processes have difference in crops and should be modeled independently. +! By using shared pixelset, crop patch is splitted to two or more shared patches. +! Each shared patch is assigned with a percentage of area and has its own states. +! +! Example of shared pixelsets +! |<------------------- ELEMENT ------------------>| <-- level 1 +! | subset 1 | subset 2 | subset 3 | <-- level 2 +! | subset 2 shared 1 50% | +! | subset 2 shared 2 20% | <-- subset 2 shares +! | subset 2 shared 3 30% | +! +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + IMPLICIT NONE + +CONTAINS + + SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typfilter, & + fracout, sharedclass, fracin) + + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_DataType + USE MOD_Pixel + USE MOD_Pixelset + USE MOD_Mesh + USE MOD_Utils + USE MOD_AggregationRequestData + IMPLICIT NONE + + type(pixelset_type), intent(inout) :: pixelset + type(grid_type), intent(in) :: gshared + type(block_data_real8_3d), intent(in) :: datashared + integer, intent(in) :: nmaxshared + integer, intent(in) :: typfilter(:) + + real(r8), intent(out), allocatable :: fracout(:) + integer, intent(out), allocatable :: sharedclass(:) + real(r8), intent(in), optional :: fracin (:) + + ! Local Variables + real(r8), allocatable :: pctshared(:,:) + real(r8), allocatable :: datashared1d(:,:), areapixel(:), rbuff(:,:) + integer :: nsetshared, ipset, jpset + integer :: ipxl, ie, ipxstt, ipxend, ishared + integer*8,allocatable :: eindex1(:) + integer, allocatable :: ielm1(:), ipxstt1(:), ipxend1(:), settyp1(:) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_io) THEN + CALL aggregation_data_daemon (gshared, data_r8_3d_in1 = datashared, n1_r8_3d_in1 = nmaxshared) + ENDIF +#endif + + IF (p_is_worker) THEN + + nsetshared = 0 + + allocate (pctshared(nmaxshared,pixelset%nset)) + + DO ipset = 1, pixelset%nset + IF (any(typfilter(:) == pixelset%settyp(ipset))) THEN + + ie = pixelset%ielm (ipset) + ipxstt = pixelset%ipxstt(ipset) + ipxend = pixelset%ipxend(ipset) + + allocate (datashared1d (nmaxshared, ipxstt:ipxend)) + + CALL aggregation_request_data (pixelset, ipset, gshared, zip = .false., & + data_r8_3d_in1 = datashared, data_r8_3d_out1 = rbuff, n1_r8_3d_in1 = nmaxshared) + + datashared1d = rbuff + + allocate (areapixel(ipxstt:ipxend)) + DO ipxl = ipxstt, ipxend + areapixel(ipxl) = areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + + DO ishared = 1, nmaxshared + pctshared(ishared,ipset) = sum(datashared1d(ishared,:) * areapixel) + ENDDO + + IF (any(pctshared(:,ipset) > 0.)) THEN + nsetshared = nsetshared + count(pctshared(:,ipset) > 0.) + pctshared(:,ipset) = pctshared(:,ipset) / sum(pctshared(:,ipset)) + ENDIF + + deallocate (rbuff ) + deallocate (areapixel ) + deallocate (datashared1d) + + ELSE + nsetshared = nsetshared + 1 + ENDIF + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + + IF (p_is_worker) THEN + + IF (pixelset%nset > 0) THEN + + allocate (eindex1(pixelset%nset)) + allocate (ipxstt1(pixelset%nset)) + allocate (ipxend1(pixelset%nset)) + allocate (settyp1(pixelset%nset)) + allocate (ielm1 (pixelset%nset)) + + eindex1 = pixelset%eindex + ipxstt1 = pixelset%ipxstt + ipxend1 = pixelset%ipxend + settyp1 = pixelset%settyp + ielm1 = pixelset%ielm + + deallocate (pixelset%eindex) + deallocate (pixelset%ipxstt) + deallocate (pixelset%ipxend) + deallocate (pixelset%settyp) + deallocate (pixelset%ielm ) + + allocate (pixelset%eindex(nsetshared)) + allocate (pixelset%ipxstt(nsetshared)) + allocate (pixelset%ipxend(nsetshared)) + allocate (pixelset%settyp(nsetshared)) + allocate (pixelset%ielm (nsetshared)) + + allocate (fracout (nsetshared)) + allocate (sharedclass(nsetshared)) + + fracout(:) = 1.0 + + jpset = 0 + DO ipset = 1, pixelset%nset + IF (any(typfilter(:) == settyp1(ipset))) THEN + IF (any(pctshared(:,ipset) > 0.)) THEN + DO ishared = 1, nmaxshared + IF (pctshared(ishared,ipset) > 0.) THEN + jpset = jpset + 1 + pixelset%eindex(jpset) = eindex1(ipset) + pixelset%ipxstt(jpset) = ipxstt1(ipset) + pixelset%ipxend(jpset) = ipxend1(ipset) + pixelset%settyp(jpset) = settyp1(ipset) + pixelset%ielm (jpset) = ielm1 (ipset) + + IF (present(fracin)) THEN + fracout(jpset) = fracin(ipset) * pctshared(ishared,ipset) + ELSE + fracout(jpset) = pctshared(ishared,ipset) + ENDIF + + sharedclass(jpset) = ishared + ENDIF + ENDDO + ENDIF + ELSE + jpset = jpset + 1 + pixelset%eindex(jpset) = eindex1(ipset) + pixelset%ipxstt(jpset) = ipxstt1(ipset) + pixelset%ipxend(jpset) = ipxend1(ipset) + pixelset%settyp(jpset) = settyp1(ipset) + pixelset%ielm (jpset) = ielm1 (ipset) + + IF (present(fracin)) THEN + fracout(jpset) = fracin(ipset) + ELSE + fracout(jpset) = 1. + ENDIF + + sharedclass(jpset) = 0 ! no meaning + ENDIF + ENDDO + + pixelset%nset = nsetshared + + deallocate (eindex1) + deallocate (ipxstt1) + deallocate (ipxend1) + deallocate (settyp1) + deallocate (ielm1 ) + deallocate (pctshared) + + ENDIF + + ENDIF + + CALL pixelset%set_vecgs + + END SUBROUTINE pixelsetshared_build + +END MODULE MOD_PixelsetShared diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 new file mode 100644 index 0000000000..de6d9bb6c5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 @@ -0,0 +1,809 @@ +#include + +MODULE MOD_RegionClip +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! This module includes subroutines to clip surface data from an existing +! data in a larger region. +! +! Please use namelist variable "USE_srfdata_from_larger_region" to call +! these subroutines. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + +CONTAINS + + ! ----- region clip ----- + SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Utils + USE MOD_Pixel + USE MOD_Block + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=*), intent(in) :: dir_landdata_in, dir_landdata_out + + ! Local Variables + real(r8) :: edges, edgen, edgew, edgee + character(len=256) :: file_in, file_out, fileblock + integer :: iproc, iblk, jblk, ie, ipxl, ilon, ilat, i1 + integer :: nelm_in, nelm_out + integer, allocatable :: nelm_blk(:,:), IOproc(:,:) + integer*8, allocatable :: elmindex(:) + integer, allocatable :: elmnpxl(:), elmpixels(:,:,:) + + logical, allocatable :: elmmask (:) + logical, allocatable :: patchmask(:) +#ifdef CATCHMENT + logical, allocatable :: hrumask (:) +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + logical, allocatable :: pftmask (:) +#endif + + integer :: month, YY, itime, Julian_day, nsl + integer :: start_year, end_year + character(len=1) :: c1 + character(len=2) :: c2, cx + character(len=3) :: c3 + character(len=4) :: cyear + + + IF (p_is_master) THEN + IF (trim(adjustl(dir_landdata_in)) == trim(adjustl(dir_landdata_out))) THEN + write(*,*) 'Warning : Surface Data from ', trim(adjustl(dir_landdata_in)), & + ' to ', trim(adjustl(dir_landdata_out)) + write(*,*) 'Data will be overwritten, please CHANGE directory.' +#ifdef USEMPI + CALL mpi_abort (p_comm_glb, 1, p_err) +#else + CALL EXIT(1) +#endif + ELSE + CALL system('mkdir -p ' // trim(dir_landdata_out)) + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + edges = DEF_domain%edges + edgen = DEF_domain%edgen + edgew = DEF_domain%edgew + edgee = DEF_domain%edgee + + CALL normalize_longitude (edgew) + CALL normalize_longitude (edgee) + + CALL pixel%load_from_file (dir_landdata_in) + + file_in = trim(dir_landdata_in) // '/block.nc' + CALL ncio_read_bcast_serial (file_in, 'lat_s', gblock%lat_s) + CALL ncio_read_bcast_serial (file_in, 'lat_n', gblock%lat_n) + CALL ncio_read_bcast_serial (file_in, 'lon_w', gblock%lon_w) + CALL ncio_read_bcast_serial (file_in, 'lon_e', gblock%lon_e) + + gblock%nyblk = size(gblock%lat_s) + gblock%nxblk = size(gblock%lon_w) + + IF (p_is_master) THEN + + file_in = trim(dir_landdata_in ) // '/mesh/mesh.nc' + file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' + CALL system('cp ' // trim(file_in) // ' ' // trim(file_out)) + + file_in = trim(dir_landdata_in ) // '/pixel.nc' + file_out = trim(dir_landdata_out) // '/pixel.nc' + CALL system('cp ' // trim(file_in) // ' ' // trim(file_out)) + + file_in = trim(dir_landdata_in ) // '/block.nc' + file_out = trim(dir_landdata_out) // '/block.nc' + CALL system('cp ' // trim(file_in) // ' ' // trim(file_out)) + + ENDIF + + file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' + CALL ncio_read_bcast_serial (file_in, 'nelm_blk', nelm_blk) + + allocate (IOproc (gblock%nxblk, gblock%nyblk)) + IOproc (:,:) = -1 + + iproc = -1 + DO jblk = 1, gblock%nyblk + IF ((gblock%lat_s(jblk) >= edgen) .or. (gblock%lat_n(jblk) <= edges)) THEN + CYCLE + ENDIF + + DO iblk = 1, gblock%nxblk + IF ((gblock%lon_w(iblk) == gblock%lon_e(iblk)) .or. (edgew == edgee)) THEN + IF (nelm_blk(iblk,jblk) > 0) THEN + iproc = mod(iproc + 1, p_np_glb) + IOproc(iblk,jblk) = iproc + ENDIF + ELSE + IF ( lon_between_floor(gblock%lon_w(iblk), edgew, edgee) & + .or. lon_between_ceil (gblock%lon_e(iblk), edgew, edgee) & + .or. lon_between_floor(edgew, gblock%lon_w(iblk), gblock%lon_e(iblk)) & + .or. lon_between_ceil (edgee, gblock%lon_w(iblk), gblock%lon_e(iblk))) THEN + IF (nelm_blk(iblk,jblk) > 0) THEN + iproc = mod(iproc + 1, p_np_glb) + IOproc(iblk,jblk) = iproc + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + + WHERE (IOproc /= p_iam_glb) + nelm_blk = 0 + END WHERE + + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (IOproc(iblk,jblk) == p_iam_glb) THEN + + file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' + CALL get_filename_block (file_in, iblk, jblk, fileblock) + + CALL ncio_read_serial (fileblock, 'elmindex' , elmindex ) + CALL ncio_read_serial (fileblock, 'elmnpxl' , elmnpxl ) + CALL ncio_read_serial (fileblock, 'elmpixels', elmpixels) + + nelm_in = nelm_blk(iblk,jblk) + + allocate (elmmask (nelm_in)) + elmmask(:) = .false. + + DO ie = 1, nelm_in + DO ipxl = 1, elmnpxl(ie) + ilon = elmpixels(1,ipxl,ie) + ilat = elmpixels(2,ipxl,ie) + + IF (((pixel%lat_s(ilat) < edgen) .and. (pixel%lat_n(ilat) > edges)) & + .and. (lon_between_floor(pixel%lon_w(ilon), edgew, edgee) & + .or. lon_between_ceil(pixel%lon_e(ilon), edgew, edgee))) THEN + + elmmask(ie) = .true. + + EXIT + ELSE + CYCLE + ENDIF + ENDDO + ENDDO + + nelm_out = count(elmmask) + nelm_blk(iblk,jblk) = nelm_out + + IF (nelm_out > 0) THEN + + CALL clip_pixelset (dir_landdata_in, 'landpatch', iblk, jblk, elmmask, elmindex, patchmask) +#ifdef CATCHMENT + CALL clip_pixelset (dir_landdata_in, 'landhru' , iblk, jblk, elmmask, elmindex, hrumask ) +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL clip_pixelset (dir_landdata_in, 'landpft' , iblk, jblk, elmmask, elmindex, pftmask ) +#endif + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/mesh') + file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' + file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'elmindex' , elmmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'elmnpxl' , elmmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'elmpixels', elmmask) + + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landelm') + file_in = trim(dir_landdata_in) // '/landelm/landelm.nc' + file_out = trim(dir_landdata_out) // '/landelm/landelm.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', elmmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', elmmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', elmmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', elmmask) + + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landpatch') + file_in = trim(dir_landdata_in) // '/landpatch/landpatch.nc' + file_out = trim(dir_landdata_out) // '/landpatch/landpatch.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', patchmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', patchmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', patchmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', patchmask) + + file_in = trim(dir_landdata_in) // '/landpatch/patchfrac_elm.nc' + file_out = trim(dir_landdata_out) // '/landpatch/patchfrac_elm.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'patchfrac_elm', patchmask) + +#ifdef CATCHMENT + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landhru') + file_in = trim(dir_landdata_in) // '/landhru/landhru.nc' + file_out = trim(dir_landdata_out) // '/landhru/landhru.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', hrumask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', hrumask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', hrumask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', hrumask) + + file_in = trim(dir_landdata_in) // '/landpatch/patchfrac_hru.nc' + file_out = trim(dir_landdata_out) // '/landpatch/patchfrac_hru.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'patchfrac_hru', patchmask) +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landpft') + file_in = trim(dir_landdata_in) // '/landpft/landpft.nc' + file_out = trim(dir_landdata_out) // '/landpft/landpft.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', pftmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', pftmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', pftmask) + CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', pftmask) +#endif + ENDIF + + ! Leaf Area Index + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/LAI') + + IF (DEF_LAI_CHANGE_YEARLY) THEN + start_year = DEF_simulation_time%start_year + end_year = DEF_simulation_time%end_year + ELSE + start_year = DEF_LC_YEAR + end_year = DEF_LC_YEAR + ENDIF + + DO YY = start_year, end_year + + write(cyear,'(i4.4)') YY + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/LAI/' // trim(cyear)) + + IF (DEF_LAI_MONTHLY) THEN + DO month = 1, 12 + write(c2,'(i2.2)') month + + file_in = trim(dir_landdata_in) // '/LAI/' // trim(cyear) // '/LAI_patches' // trim(c2) // '.nc' + file_out = trim(dir_landdata_out) // '/LAI/' // trim(cyear) // '/LAI_patches' // trim(c2) // '.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_patches', patchmask) + + file_in = trim(dir_landdata_in) // '/LAI/' // trim(cyear) // '/SAI_patches' // trim(c2) // '.nc' + file_out = trim(dir_landdata_out) // '/LAI/' // trim(cyear) // '/SAI_patches' // trim(c2) // '.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'SAI_patches', patchmask) + ENDDO + ELSE + DO itime = 1, 46 + Julian_day = 1 + (itime-1)*8 + write(c3, '(i3.3)') Julian_day + file_in = trim(dir_landdata_in) //'/LAI/'//trim(cyear)//'/LAI_patches'//trim(c3)// '.nc' + file_out = trim(dir_landdata_out)//'/LAI/'//trim(cyear)//'/LAI_patches'//trim(c3)// '.nc' + + CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_patches', patchmask) + ENDDO + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + DO month = 1, 12 + write(c2,'(i2.2)') month + + file_in = trim(dir_landdata_in) //'/LAI/'//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' + file_out = trim(dir_landdata_out)//'/LAI/'//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_pfts', pftmask) + + file_in = trim(dir_landdata_in) //'/LAI/'//trim(cyear)//'/SAI_pfts'//trim(c2)//'.nc' + file_out = trim(dir_landdata_out)//'/LAI/'//trim(cyear)//'/SAI_pfts'//trim(c2)//'.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'SAI_pfts', pftmask) + ENDDO +#endif + ENDDO + + ! depth to bedrock + IF(DEF_USE_BEDROCK)THEN + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/dbedrock') + file_in = trim(dir_landdata_in) // '/dbedrock/dbedrock_patches.nc' + file_out = trim(dir_landdata_out) // '/dbedrock/dbedrock_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'dbedrock_patches', patchmask) + ENDIF + + ! forest height + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/htop') + file_in = trim(dir_landdata_in) // '/htop/htop_patches.nc' + file_out = trim(dir_landdata_out) // '/htop/htop_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_patches', patchmask) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_in = trim(dir_landdata_in) // '/htop/htop_pfts.nc' + file_out = trim(dir_landdata_out) // '/htop/htop_pfts.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_pfts', pftmask) +#endif + + ! lake depth + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/lakedepth') + file_in = trim(dir_landdata_in) // '/lakedepth/lakedepth_patches.nc' + file_out = trim(dir_landdata_out) // '/lakedepth/lakedepth_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'lakedepth_patches', patchmask) + + ! plant function type percentage + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/pctpft') +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_in = trim(dir_landdata_in) // '/pctpft/pct_pfts.nc' + file_out = trim(dir_landdata_out) // '/pctpft/pct_pfts.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_pfts', pftmask) +#ifdef CROP + file_in = trim(dir_landdata_in) // '/pctpft/pct_crops.nc' + file_out = trim(dir_landdata_out) // '/pctpft/pct_crops.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_crops', patchmask) +#endif +#endif + + ! soil + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/soil') + + file_in = trim(dir_landdata_in) // '/soil/soil_s_v_alb_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/soil_s_v_alb_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_s_v_alb', patchmask) + + file_in = trim(dir_landdata_in) // '/soil/soil_d_v_alb_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/soil_d_v_alb_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_d_v_alb', patchmask) + + file_in = trim(dir_landdata_in) // '/soil/soil_s_n_alb_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/soil_s_n_alb_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_s_n_alb', patchmask) + + file_in = trim(dir_landdata_in) // '/soil/soil_d_n_alb_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/soil_d_n_alb_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_d_n_alb', patchmask) + + DO nsl = 1, 8 + + write(c1,'(i1)') nsl + + ! (1) volumetric fraction of quartz within mineral soil + file_in = trim(dir_landdata_in) // '/soil/vf_quartz_mineral_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/vf_quartz_mineral_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'vf_quartz_mineral_s_l'//trim(c1)//'_patches', patchmask) + + ! (2) volumetric fraction of gravels + file_in = trim(dir_landdata_in) // '/soil/vf_gravels_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/vf_gravels_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'vf_gravels_s_l'//trim(c1)//'_patches', patchmask) + + ! (3) volumetric fraction of sand + file_in = trim(dir_landdata_in) // '/soil/vf_sand_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/vf_sand_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'vf_sand_s_l'//trim(c1)//'_patches', patchmask) + + ! (4) volumetric fraction of organic matter with the parameter alpha and beta in the Balland V. and P. A. Arp (2005) model + file_in = trim(dir_landdata_in) // '/soil/vf_om_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/vf_om_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'vf_om_s_l'//trim(c1)//'_patches', patchmask) + + file_in = trim(dir_landdata_in) // '/soil/BA_alpha_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/BA_alpha_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'BA_alpha_l'//trim(c1)//'_patches', patchmask) + + file_in = trim(dir_landdata_in) // '/soil/BA_beta_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/BA_beta_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'BA_beta_l'//trim(c1)//'_patches', patchmask) + + ! (5) gravimetric fraction of gravels + file_in = trim(dir_landdata_in) // '/soil/wf_gravels_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/wf_gravels_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'wf_gravels_s_l'//trim(c1)//'_patches', patchmask) + + ! (6) gravimetric fraction of sand + file_in = trim(dir_landdata_in) // '/soil/wf_sand_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/wf_sand_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'wf_sand_s_l'//trim(c1)//'_patches', patchmask) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! (7) VGM's pore-connectivity parameter (L) + file_in = trim(dir_landdata_in) // '/soil/L_vgm_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/L_vgm_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'L_vgm_l'//trim(c1)//'_patches', patchmask) + + ! (8) VGM's residual water content (theta_r) [cm3/cm3] + file_in = trim(dir_landdata_in) // '/soil/theta_r_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/theta_r_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'theta_r_l'//trim(c1)//'_patches', patchmask) + + ! (9) VGM's parameter corresponding approximately to the inverse of the air-entry value (alpha) + file_in = trim(dir_landdata_in) // '/soil/alpha_vgm_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/alpha_vgm_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'alpha_vgm_l'//trim(c1)//'_patches', patchmask) + + ! (10) VGM's shape parameter (n) + file_in = trim(dir_landdata_in) // '/soil/n_vgm_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/n_vgm_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'n_vgm_l'//trim(c1)//'_patches', patchmask) +#endif + ! (11) saturated water content [cm3/cm3] + file_in = trim(dir_landdata_in) // '/soil/theta_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/theta_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'theta_s_l'//trim(c1)//'_patches', patchmask) + + ! (12) matric potential at saturation (psi_s) [cm] + file_in = trim(dir_landdata_in) // '/soil/psi_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/psi_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'psi_s_l'//trim(c1)//'_patches', patchmask) + + ! (13) pore size distribution index [dimensionless] + file_in = trim(dir_landdata_in) // '/soil/lambda_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/lambda_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'lambda_l'//trim(c1)//'_patches', patchmask) + + ! (14) saturated hydraulic conductivity [cm/day] + file_in = trim(dir_landdata_in) // '/soil/k_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/k_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'k_s_l'//trim(c1)//'_patches', patchmask) + + ! (15) heat capacity of soil solids [J/(m3 K)] + file_in = trim(dir_landdata_in) // '/soil/csol_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/csol_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'csol_l'//trim(c1)//'_patches', patchmask) + + ! (16) thermal conductivity of unfrozen saturated soil [W/m-K] + file_in = trim(dir_landdata_in) // '/soil/tksatu_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/tksatu_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'tksatu_l'//trim(c1)//'_patches', patchmask) + + ! (17) thermal conductivity of frozen saturated soil [W/m-K] + file_in = trim(dir_landdata_in) // '/soil/tksatf_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/tksatf_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'tksatf_l'//trim(c1)//'_patches', patchmask) + + ! (18) thermal conductivity for dry soil [W/(m-K)] + file_in = trim(dir_landdata_in) // '/soil/tkdry_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/tkdry_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'tkdry_l'//trim(c1)//'_patches', patchmask) + + ! (19) thermal conductivity of soil solids [W/m-K] + file_in = trim(dir_landdata_in) // '/soil/k_solids_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/k_solids_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'k_solids_l'//trim(c1)//'_patches', patchmask) + + ! (20) OM_density [kg/m3] + file_in = trim(dir_landdata_in) // '/soil/OM_density_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/OM_density_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'OM_density_s_l'//trim(c1)//'_patches', patchmask) + + ! (21) bulk density of soil (GRAVELS + OM + Mineral Soils) + file_in = trim(dir_landdata_in) // '/soil/BD_all_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/BD_all_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'BD_all_s_l'//trim(c1)//'_patches', patchmask) + + ! (22) volumetric fraction of clay + file_in = trim(dir_landdata_in) // '/soil/vf_clay_s_l'//trim(c1)//'_patches.nc' + file_out = trim(dir_landdata_out) // '/soil/vf_clay_s_l'//trim(c1)//'_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, & + 'vf_clay_s_l'//trim(c1)//'_patches', patchmask) + + ENDDO + + ! topography + CALL system('mkdir -p ' // trim(dir_landdata_out) // '/topography') + file_in = trim(dir_landdata_in) // '/topography/topography_patches.nc' + file_out = trim(dir_landdata_out) // '/topography/topography_patches.nc' + CALL clip_vector (file_in, file_out, iblk, jblk, 'topography_patches', patchmask) + + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, & + MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' + CALL ncio_write_serial (file_out, 'nelm_blk', nelm_blk, 'xblk', 'yblk') + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,*) 'Clip surface data from large region successful.' + ENDIF + + IF (allocated(nelm_blk )) deallocate(nelm_blk ) + IF (allocated(IOproc )) deallocate(IOproc ) + IF (allocated(elmindex )) deallocate(elmindex ) + IF (allocated(elmnpxl )) deallocate(elmnpxl ) + IF (allocated(elmpixels)) deallocate(elmpixels) + IF (allocated(elmmask )) deallocate(elmmask ) + IF (allocated(patchmask)) deallocate(patchmask) +#ifdef CATCHMENT + IF (allocated(hrumask )) deallocate(hrumask ) +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (allocated(pftmask )) deallocate(pftmask ) +#endif + + END SUBROUTINE srfdata_region_clip + + ! ----- pixelset clip ----- + SUBROUTINE clip_pixelset (dir_landdata_in, psetname, iblk, jblk, elmmask, elmindex, psetmask) + + USE MOD_NetCDFSerial + USE MOD_Block + + IMPLICIT NONE + + character(len=*), intent(in) :: dir_landdata_in + character(len=*), intent(in) :: psetname + integer, intent(in) :: iblk, jblk + logical, intent(in) :: elmmask (:) + + integer*8, intent(in) :: elmindex(:) + + logical, allocatable, intent(out) :: psetmask (:) + + ! Local Variables + character(len=256) :: filename, fileblock + logical :: fexists + integer :: nset, ie, iset + integer*8, allocatable :: eindex_p(:) + + filename = trim(dir_landdata_in) // '/' // trim(psetname) // '/' // trim(psetname) // '.nc' + CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file=trim(fileblock), exist=fexists) + IF (fexists) THEN + CALL ncio_inquire_length (fileblock, 'eindex', nset) + + IF (nset > 0) THEN + + CALL ncio_read_serial (fileblock, 'eindex', eindex_p) + + allocate (psetmask (nset)) + psetmask(:) = .false. + + ie = 1 + DO iset = 1, nset + DO WHILE ((eindex_p(iset) /= elmindex(ie))) + ie = ie + 1 + ENDDO + psetmask(iset) = elmmask(ie) + ENDDO + + deallocate(eindex_p) + ENDIF + ENDIF + + END SUBROUTINE clip_pixelset + + ! ----- vector clip ----- + SUBROUTINE clip_vector (file_in, file_out, iblk, jblk, varname, vecmask) + + USE netcdf + USE MOD_NetCDFSerial + USE MOD_Block + IMPLICIT NONE + + character(len=*), intent(in) :: file_in, file_out + character(len=*), intent(in) :: varname + integer, intent(in) :: iblk, jblk + logical, intent(in) :: vecmask(:) + + ! Local Variables + character(len=256) :: input, output + integer :: ncidin, ncidout + integer :: varidin, varidout + integer :: vlen_in, vlen_out, xtype, ndims, id, i1, i2 + logical :: fexists, dim_exist + integer, allocatable :: dimids (:), dimlens (:) + character(len=256), allocatable :: dimnames (:) + + integer, allocatable :: data_i4_in1 (:) + integer, allocatable :: data_i4_in2 (:,:) + integer, allocatable :: data_i4_in3 (:,:,:) + + integer, allocatable :: data_i4_out1 (:) + integer, allocatable :: data_i4_out2 (:,:) + integer, allocatable :: data_i4_out3 (:,:,:) + + integer*8, allocatable :: data_i8_in1 (:) + integer*8, allocatable :: data_i8_out1 (:) + + real(r8), allocatable :: data_r8_in1 (:) + real(r8), allocatable :: data_r8_in2 (:,:) + real(r8), allocatable :: data_r8_in3 (:,:,:) + + real(r8), allocatable :: data_r8_out1 (:) + real(r8), allocatable :: data_r8_out2 (:,:) + real(r8), allocatable :: data_r8_out3 (:,:,:) + + CALL get_filename_block (file_in, iblk, jblk, input ) + CALL get_filename_block (file_out, iblk, jblk, output) + + write(*,*) 'Copy and clip ', trim(varname), ' from ', trim(input), ' to ', trim(output) + + IF (.not. ncio_var_exist(input, varname)) THEN + write(*,*) 'Variable ', trim(varname), ' in ', trim(input), ' not found.' + ENDIF + + vlen_in = size (vecmask) + vlen_out = count(vecmask) + + CALL nccheck( nf90_open (trim(input), NF90_NOWRITE, ncidin) ) + CALL nccheck( nf90_inq_varid (ncidin, trim(varname), varidin) ) + CALL nccheck( nf90_inquire_variable (ncidin, varidin, xtype = xtype, ndims = ndims) ) + allocate (dimids (ndims)) + allocate (dimnames (ndims)) + allocate (dimlens (ndims)) + CALL nccheck( nf90_inquire_variable (ncidin, varidin, dimids = dimids) ) + DO id = 1, ndims + CALL nccheck( nf90_inquire_dimension (ncidin, dimids(id), dimnames(id), dimlens(id)) ) + ENDDO + CALL nccheck( nf90_close (ncidin) ) + + inquire (file=trim(output), exist=fexists) + IF (.not. fexists) THEN + CALL ncio_create_file (output) + ENDIF + + DO id = 1, ndims + CALL nccheck( nf90_open (trim(output), NF90_NOWRITE, ncidout) ) + dim_exist = (nf90_inq_dimid (ncidout, trim(dimnames(id)), dimids(id)) == NF90_NOERR) + CALL nccheck( nf90_close (ncidout) ) + + IF (.not. dim_exist) THEN + IF (id < ndims) THEN + CALL nccheck( nf90_open (trim(input), NF90_NOWRITE, ncidin) ) + CALL nccheck( nf90_inq_dimid (ncidin, trim(dimnames(id)), dimids(id)) ) + CALL nccheck( nf90_inquire_dimension (ncidin, dimids(id), len = dimlens(id)) ) + CALL nccheck( nf90_close (ncidin) ) + ELSE + dimlens(ndims) = vlen_out + ENDIF + + CALL nccheck( nf90_open (trim(output), NF90_WRITE, ncidout) ) + CALL nccheck( nf90_redef (ncidout) ) + CALL nccheck( nf90_def_dim (ncidout, trim(dimnames(id)), dimlens(id), dimids(id)) ) + CALL nccheck( nf90_enddef (ncidout) ) + CALL nccheck( nf90_close (ncidout) ) + ENDIF + ENDDO + + CALL nccheck( nf90_open (trim(output), NF90_WRITE, ncidout) ) + DO id = 1, ndims + CALL nccheck( nf90_inq_dimid (ncidout, dimnames(id), dimids(id)) ) + ENDDO + + IF (nf90_inq_varid(ncidout,trim(varname),varidout) /= nf90_noerr) THEN + CALL nccheck( nf90_redef (ncidout) ) + CALL nccheck( nf90_def_var (ncidout, trim(varname), xtype, dimids, varidout, deflate_level = 1) ) + CALL nccheck( nf90_enddef (ncidout) ) + ENDIF + + CALL nccheck( nf90_open (trim(input), NF90_NOWRITE, ncidin) ) + CALL nccheck( nf90_inq_varid (ncidin, trim(varname), varidin ) ) + + SELECTCASE (ndims) + CASE (1) + IF (xtype == NF90_INT) THEN + allocate (data_i4_in1 (vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_i4_in1) ) + + allocate (data_i4_out1 (vlen_out)) + data_i4_out1 = pack(data_i4_in1, vecmask) + CALL nccheck( nf90_put_var (ncidout, varidout, data_i4_out1) ) + + deallocate (data_i4_in1 ) + deallocate (data_i4_out1) + ELSEIF (xtype == NF90_INT64) THEN + allocate (data_i8_in1 (vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_i8_in1) ) + + allocate (data_i8_out1 (vlen_out)) + data_i8_out1 = pack(data_i8_in1, vecmask) + CALL nccheck( nf90_put_var (ncidout, varidout, data_i8_out1) ) + + deallocate (data_i8_in1 ) + deallocate (data_i8_out1) + ELSEIF (xtype == NF90_DOUBLE) THEN + allocate (data_r8_in1 (vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in1) ) + + allocate (data_r8_out1 (vlen_out)) + data_r8_out1 = pack(data_r8_in1, vecmask) + CALL nccheck( nf90_put_var (ncidout, varidout, data_r8_out1) ) + + deallocate (data_r8_in1 ) + deallocate (data_r8_out1) + ENDIF + + CASE (2) + IF (xtype == NF90_INT) THEN + allocate (data_i4_in2 (dimlens(1),vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_i4_in2) ) + + allocate (data_i4_out2 (dimlens(1),vlen_out)) + DO i1 = 1, dimlens(1) + data_i4_out2(i1,:) = pack(data_i4_in2(i1,:), vecmask) + ENDDO + CALL nccheck( nf90_put_var (ncidout, varidout, data_i4_out2) ) + + deallocate (data_i4_in2 ) + deallocate (data_i4_out2) + ELSEIF (xtype == NF90_DOUBLE) THEN + allocate (data_r8_in2 (dimlens(1),vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in2) ) + + allocate (data_r8_out2 (dimlens(1),vlen_out)) + DO i1 = 1, dimlens(1) + data_r8_out2(i1,:) = pack(data_r8_in2(i1,:), vecmask) + ENDDO + CALL nccheck( nf90_put_var (ncidout, varidout, data_r8_out2) ) + + deallocate (data_r8_in2 ) + deallocate (data_r8_out2) + ENDIF + + CASE (3) + IF (xtype == NF90_INT) THEN + allocate (data_i4_in3 (dimlens(1),dimlens(2),vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_i4_in3) ) + + allocate (data_i4_out3 (dimlens(1),dimlens(2),vlen_out)) + DO i1 = 1, dimlens(1) + DO i2 = 1, dimlens(2) + data_i4_out3(i1,i2,:) = pack(data_i4_in3(i1,i2,:), vecmask) + ENDDO + ENDDO + CALL nccheck( nf90_put_var (ncidout, varidout, data_i4_out3) ) + + deallocate (data_i4_in3 ) + deallocate (data_i4_out3) + ELSEIF (xtype == NF90_DOUBLE) THEN + allocate (data_r8_in3 (dimlens(1),dimlens(2),vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in3) ) + + allocate (data_r8_out3 (dimlens(1),dimlens(2),vlen_out)) + DO i1 = 1, dimlens(1) + DO i2 = 1, dimlens(2) + data_r8_out3(i1,i2,:) = pack(data_r8_in3(i1,i2,:), vecmask) + ENDDO + ENDDO + CALL nccheck( nf90_put_var (ncidout, varidout, data_r8_out3) ) + + deallocate (data_r8_in3 ) + deallocate (data_r8_out3) + ENDIF + + CASE default + write(*,*) 'Warning: there is no case for variable: ', trim(varname) + ENDSELECT + + CALL nccheck( nf90_close (ncidin) ) + CALL nccheck( nf90_close (ncidout) ) + + END SUBROUTINE clip_vector + +END MODULE MOD_RegionClip diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SingleSrfdata.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SingleSrfdata.F90 new file mode 100644 index 0000000000..5318e75a93 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SingleSrfdata.F90 @@ -0,0 +1,3472 @@ +#include + +#ifdef SinglePoint +MODULE MOD_SingleSrfdata +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! This module includes subroutines to read or write surface data for +! "SinglePoint". +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision, only: r8 + USE MOD_Vars_Global + USE MOD_Const_LC + USE MOD_Namelist + USE MOD_SPMD_Task + IMPLICIT NONE + SAVE + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + integer, allocatable :: SITE_pfttyp (:) + real(r8), allocatable :: SITE_pctpfts (:) +#endif + +#ifdef CROP + integer, allocatable :: SITE_croptyp (:) + real(r8), allocatable :: SITE_pctcrop (:) +#endif + + real(r8) :: SITE_htop +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + real(r8), allocatable :: SITE_htop_pfts (:) +#endif + + real(r8), allocatable :: SITE_LAI_monthly (:,:) + real(r8), allocatable :: SITE_SAI_monthly (:,:) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + real(r8), allocatable :: SITE_LAI_pfts_monthly (:,:,:) + real(r8), allocatable :: SITE_SAI_pfts_monthly (:,:,:) +#endif + + integer, allocatable :: SITE_LAI_year (:) + real(r8), allocatable :: SITE_LAI_8day (:,:) + + real(r8) :: SITE_lakedepth = 1. + + real(r8) :: SITE_soil_s_v_alb + real(r8) :: SITE_soil_d_v_alb + real(r8) :: SITE_soil_s_n_alb + real(r8) :: SITE_soil_d_n_alb + + real(r8), allocatable :: SITE_soil_vf_quartz_mineral (:) + real(r8), allocatable :: SITE_soil_vf_gravels (:) + real(r8), allocatable :: SITE_soil_vf_sand (:) + real(r8), allocatable :: SITE_soil_vf_clay (:) + real(r8), allocatable :: SITE_soil_vf_om (:) + real(r8), allocatable :: SITE_soil_wf_gravels (:) + real(r8), allocatable :: SITE_soil_wf_sand (:) + real(r8), allocatable :: SITE_soil_wf_clay (:) + real(r8), allocatable :: SITE_soil_wf_om (:) + real(r8), allocatable :: SITE_soil_OM_density (:) + real(r8), allocatable :: SITE_soil_BD_all (:) + real(r8), allocatable :: SITE_soil_theta_s (:) + real(r8), allocatable :: SITE_soil_k_s (:) + real(r8), allocatable :: SITE_soil_csol (:) + real(r8), allocatable :: SITE_soil_tksatu (:) + real(r8), allocatable :: SITE_soil_tksatf (:) + real(r8), allocatable :: SITE_soil_tkdry (:) + real(r8), allocatable :: SITE_soil_k_solids (:) + real(r8), allocatable :: SITE_soil_psi_s (:) + real(r8), allocatable :: SITE_soil_lambda (:) + real(r8), allocatable :: SITE_soil_theta_r (:) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), allocatable :: SITE_soil_alpha_vgm (:) + real(r8), allocatable :: SITE_soil_L_vgm (:) + real(r8), allocatable :: SITE_soil_n_vgm (:) +#endif + real(r8), allocatable :: SITE_soil_BA_alpha (:) + real(r8), allocatable :: SITE_soil_BA_beta (:) + + integer :: SITE_soil_texture + + real(r8) :: SITE_dbedrock = 0. + + real(r8) :: SITE_elevation = 0. + real(r8) :: SITE_elvstd = 0. + real(r8) :: SITE_sloperatio = 0. + + ! topography factors used for downscaling + real(r8) :: SITE_svf = 0. + real(r8) :: SITE_cur = 0. + real(r8), allocatable :: SITE_slp_type (:) + real(r8), allocatable :: SITE_asp_type (:) + real(r8), allocatable :: SITE_area_type(:) + real(r8), allocatable :: SITE_sf_lut (:,:) + + logical :: u_site_landtype, u_site_crop, u_site_pfts, u_site_htop, & + u_site_lai, u_site_lakedepth, u_site_soil_bright, u_site_vf_quartz_mineral, & + u_site_vf_gravels, u_site_vf_sand, u_site_vf_clay, u_site_vf_om, & + u_site_wf_gravels, u_site_wf_sand, u_site_wf_clay, u_site_wf_om, & + u_site_OM_density, u_site_BD_all, u_site_theta_s, u_site_k_s, & + u_site_csol, u_site_tksatu, u_site_tksatf, u_site_tkdry, & + u_site_k_solids, u_site_psi_s, u_site_lambda, u_site_theta_r, & + u_site_alpha_vgm, u_site_L_vgm, u_site_n_vgm, u_site_BA_alpha, & + u_site_BA_beta, u_site_soil_texture, u_site_dbedrock, u_site_elevation, & + u_site_elvstd, u_site_svf, u_site_cur, u_site_slp_type, & + u_site_asp_type, u_site_area_type, u_site_sf_lut, u_site_sloperatio + + + integer :: SITE_ncar_rid + integer :: SITE_urbtyp + + real(r8) :: SITE_lucyid + + real(r8) :: SITE_fveg_urb + real(r8) :: SITE_htop_urb + real(r8) :: SITE_flake_urb + real(r8) :: SITE_froof + real(r8) :: SITE_hroof + real(r8) :: SITE_fgimp + real(r8) :: SITE_fgper + real(r8) :: SITE_hlr + real(r8) :: SITE_lambdaw + real(r8) :: SITE_popden + + real(r8) :: SITE_em_roof + real(r8) :: SITE_em_wall + real(r8) :: SITE_em_gimp + real(r8) :: SITE_em_gper + real(r8) :: SITE_t_roommax + real(r8) :: SITE_t_roommin + + real(r8) :: SITE_thickroof + real(r8) :: SITE_thickwall + + real(r8), allocatable :: SITE_cv_roof (:) + real(r8), allocatable :: SITE_cv_wall (:) + real(r8), allocatable :: SITE_cv_gimp (:) + real(r8), allocatable :: SITE_tk_roof (:) + real(r8), allocatable :: SITE_tk_wall (:) + real(r8), allocatable :: SITE_tk_gimp (:) + + real(r8), allocatable :: SITE_alb_roof (:,:) + real(r8), allocatable :: SITE_alb_wall (:,:) + real(r8), allocatable :: SITE_alb_gimp (:,:) + real(r8), allocatable :: SITE_alb_gper (:,:) + + logical :: u_site_froof, u_site_hroof, u_site_fgper , u_site_hlr , & + u_site_fveg , u_site_htopu, u_site_urblai , u_site_urbsai , & + u_site_flake, u_site_utype, & + u_site_albr , u_site_albw , u_site_albgimp, u_site_albgper, & + u_site_emr , u_site_emw , u_site_emgimp , u_site_emgper , & + u_site_cvr , u_site_cvw , u_site_cvgimp , & + u_site_tkr , u_site_tkw , u_site_tkgimp , & + u_site_tbmax, u_site_tbmin, u_site_thickr , u_site_thickw , & + u_site_pop , u_site_lucy + + ! ----------------------------------------------------------------------------------- + ! The soil color and reflectance is from the work: + ! Peter J. Lawrence and Thomas N. Chase, 2007: + ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0): + ! Part 1 generating MODIS consistent land surface parameters + ! ----------------------------------------------------------------------------------- + real(r8), parameter :: soil_s_v_refl(20) = & ! Saturated visible soil reflectance + (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, & + 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /) + real(r8), parameter :: soil_d_v_refl(20) = & ! Dry visible soil reflectance + (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, & + 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /) + real(r8), parameter :: soil_s_n_refl(20) = & ! Saturated near infrared soil reflectance + (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, & + 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /) + real(r8), parameter :: soil_d_n_refl(20) = & ! Dry near infrared soil reflectance + (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, & + 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /) + +CONTAINS + + +!----------------------------------------------------------------------- + SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) + + USE MOD_TimeManager + USE MOD_Grid + USE MOD_Block + USE MOD_NetCDFSerial + USE MOD_NetCDFPoint + USE MOD_Namelist + USE MOD_Utils + USE MOD_Vars_Global, only: PI + USE MOD_Const_LC + USE MOD_Const_PFT + USE MOD_SPMD_Task + USE MOD_LandPatch +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif + USE MOD_Mesh, only: numelm + USE MOD_LandElm + IMPLICIT NONE + + character(len=*), intent(in) :: fsrfdata + logical, intent(in) :: mksrfdata + + ! Local Variables + real(r8) :: lat_in, lon_in + real(r8) :: LAI, lakedepth, slp, asp, zenith_angle + integer :: i, isc, nsl, typ, a, z, arraysize + integer :: iyear, idate(3), simulation_lai_year_start, simulation_lai_year_end + integer :: start_year, end_year, ntime, itime + + character(len=256) :: filename, dir_5x5, fmt_str + character(len=4) :: cyear, c + + type(grid_type) :: gridpatch, gridcrop, gridpft, gridhtop, gridlai, gridlake, & + gridbright, gridsoil, gridrock, gridtopo, grid_topo_factor + + integer, allocatable :: croptyp(:), pfttyp (:) + real(r8), allocatable :: pctcrop(:), pctpfts(:), pftLAI(:), pftSAI(:), tea_f(:), tea_b(:) + + integer, parameter :: N_PFT_modis = 16 + logical :: readflag + + CALL Init_GlobalVars + CALL Init_LC_Const + + IF (mksrfdata) THEN + write(*,*) + write(*,*) ' ---------------- Make Single Point Surface Data ---------------- ' + ENDIF + + IF (ncio_var_exist(fsrfdata, 'latitude')) THEN + CALL ncio_read_serial (fsrfdata, 'latitude', lat_in) + IF ((lat_in /= SITE_lat_location) .and. (SITE_lat_location /= -1.e36_r8)) THEN + write(*,*) 'Warning: Latitude mismatch: ', & + lat_in, ' in data file and ', SITE_lat_location, 'in namelist.' + ENDIF + SITE_lat_location = lat_in + ENDIF + + IF (ncio_var_exist(fsrfdata, 'longitude')) THEN + CALL ncio_read_serial (fsrfdata, 'longitude', lon_in) + IF ((lon_in /= SITE_lon_location) .and. (SITE_lon_location /= -1.e36_r8)) THEN + write(*,*) 'Warning: Longitude mismatch: ', & + lon_in, ' in data file and ', SITE_lon_location, 'in namelist.' + ENDIF + SITE_lon_location = lon_in + ENDIF + + CALL normalize_longitude (SITE_lon_location) + + IF (.not. isgreenwich) THEN + LocalLongitude = SITE_lon_location + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location + write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location + ENDIF + + + DEF_domain%edges = floor(SITE_lat_location) + DEF_domain%edgen = floor(SITE_lat_location) + 1. + DEF_domain%edgew = floor(SITE_lon_location) + DEF_domain%edgee = floor(SITE_lon_location) + 1. + + CALL gblock%set () + gblock%nblkme = 1 + allocate(gblock%xblkme(1)) + allocate(gblock%yblkme(1)) + gblock%xblkme(1) = find_nearest_west (SITE_lon_location, gblock%nxblk, gblock%lon_w) + gblock%yblkme(1) = find_nearest_south (SITE_lat_location, gblock%nyblk, gblock%lat_s) + + + ! (1) build/read "land patch" by using land cover type data + numpatch = 1 + +#ifdef LULC_USGS + u_site_landtype = (.not. mksrfdata) .or. (SITE_landtype >= 0) & + .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'USGS_classification')) + + IF (u_site_landtype) THEN + IF (SITE_landtype == -1) THEN + CALL ncio_read_serial (fsrfdata, 'USGS_classification', SITE_landtype) + ENDIF + ELSE + CALL gridpatch%define_by_name ('colm_1km') + filename = trim(DEF_dir_rawdata)//'/landtypes/landtype-usgs-update.nc' + CALL read_point_var_2d_int32 (gridpatch, filename, 'landtype', & + SITE_lon_location, SITE_lat_location, SITE_landtype) + ENDIF +#else + u_site_landtype = (.not. mksrfdata) .or. (SITE_landtype >= 0) & + .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'IGBP_classification')) + + IF (u_site_landtype) THEN + IF (SITE_landtype == -1) THEN + CALL ncio_read_serial (fsrfdata, 'IGBP_classification', SITE_landtype) + ENDIF + ELSE + CALL gridpatch%define_by_name ('colm_500m') + write(cyear,'(i4.4)') DEF_LC_YEAR + filename = trim(DEF_dir_rawdata)//'landtypes/landtype-igbp-modis-'//trim(cyear)//'.nc' + CALL read_point_var_2d_int32 (gridpatch, filename, 'landtype', & + SITE_lon_location, SITE_lat_location, SITE_landtype) + ENDIF +#endif + + IF (SITE_landtype < 0) THEN + write(*,*) 'Error! Please set SITE_landtype in namelist file !' + CALL CoLM_stop() + ENDIF + +#ifdef URBAN_MODEL + IF (SITE_landtype /= URBAN) THEN + write(*,*) 'Error! Please set SITE_landtype to URBAN in namelist file !' + CALL CoLM_stop() + ENDIF +#endif + + IF (mksrfdata) THEN + write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), & + ' (from ',trim(datasource(u_site_landtype)),')' + ENDIF + + ! (2) build/read "land crop" by using crop data +#ifdef CROP + IF (SITE_landtype == CROPLAND) THEN + + readflag = ((.not. mksrfdata) .or. USE_SITE_pctcrop) + u_site_crop = readflag & + .and. ncio_var_exist(fsrfdata,'croptyp',readflag) .and. ncio_var_exist(fsrfdata,'pctcrop',readflag) + + IF (u_site_crop) THEN + CALL ncio_read_serial (fsrfdata, 'croptyp', croptyp) + CALL ncio_read_serial (fsrfdata, 'pctcrop', pctcrop) + ELSE + allocate (croptyp (N_CFT)) + croptyp = (/(i, i = 1, N_CFT)/) + + filename = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc' + CALL gridcrop%define_from_file (filename, 'lat', 'lon') + CALL read_point_var_3d_first_real8 (gridcrop, filename, 'PCT_CFT', & + SITE_lon_location, SITE_lat_location, N_CFT, pctcrop) + ENDIF + + numpatch = count(pctcrop > 0.) + + IF (numpatch == 0) THEN + write(*,*) 'There is no crop at this point!' + CALL CoLM_stop() + ENDIF + + allocate (SITE_croptyp (numpatch)) + allocate (SITE_pctcrop (numpatch)) + + SITE_croptyp = pack(croptyp, pctcrop > 0.) + SITE_pctcrop = pack(pctcrop, pctcrop > 0.) / sum(pctcrop) + + IF (mksrfdata) THEN + write(c,'(I0)') numpatch + write(*,'(A,'//trim(c)//'I5,3A)') 'crop type : ', SITE_croptyp, ' (from ',trim(datasource(u_site_crop)),')' + write(*,'(A,'//trim(c)//'F5.2,3A)') 'crop frac : ', SITE_pctcrop, ' (from ',trim(datasource(u_site_crop)),')' + ENDIF + + ENDIF +#endif + + + ! (3) build/read "land pft" or "land pc" by using plant functional type data +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifndef CROP + IF (patchtypes(SITE_landtype) == 0) THEN +#else + IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN +#endif + readflag = ((.not. mksrfdata) .or. USE_SITE_pctpfts) + u_site_pfts = readflag & + .and. ncio_var_exist(fsrfdata,'pfttyp',readflag) .and. ncio_var_exist(fsrfdata,'pctpfts',readflag) + + IF (u_site_pfts) THEN + CALL ncio_read_serial (fsrfdata, 'pfttyp', pfttyp ) + CALL ncio_read_serial (fsrfdata, 'pctpfts', pctpfts) + ELSE + allocate (pfttyp (N_PFT_modis)) + pfttyp = (/(i, i = 0, N_PFT_modis-1)/) + + CALL gridpft%define_by_name ('colm_500m') + + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + write(cyear,'(i4.4)') DEF_LC_YEAR + CALL read_point_5x5_var_3d_real8 (gridpft, dir_5x5, 'MOD'//trim(cyear), 'PCT_PFT', & + SITE_lon_location, SITE_lat_location, N_PFT_modis, pctpfts) + ENDIF + + numpft = count(pctpfts > 0.) + + allocate (SITE_pfttyp (numpft)) + allocate (SITE_pctpfts (numpft)) + + SITE_pfttyp = pack(pfttyp, pctpfts > 0.) + SITE_pctpfts = pack(pctpfts, pctpfts > 0.) / sum(pctpfts) + +#ifdef CROP + ELSEIF (SITE_landtype == CROPLAND) THEN + u_site_pfts = .false. + numpft = numpatch + allocate (SITE_pfttyp (numpft)) + allocate (SITE_pctpfts (numpft)) + SITE_pfttyp = SITE_croptyp + N_PFT - 1 + SITE_pctpfts = 1. +#endif + ELSE + numpft = 0 + ENDIF + + IF ((patchtypes(SITE_landtype) == 0) .and. (numpft == 0)) THEN + write(*,*) 'Warning : There is no plant functional type at this site ! ' + CALL CoLM_stop() + ENDIF + + IF (mksrfdata) THEN + IF (numpft > 0) THEN + write(*,'(4A)') 'PFT type and fraction : ', ' (from ',trim(datasource(u_site_pfts)),')' + DO i = 1, numpft + write(*,'(A,F5.2)') ' '//trim(pftclassname(SITE_pfttyp(i))), SITE_pctpfts(i) + ENDDO + ENDIF + ENDIF + +#endif + + + ! (4) forest height + readflag = (.not. mksrfdata) .or. USE_SITE_htop +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtypes(SITE_landtype) == 0) THEN + u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height_pfts',readflag) + ELSE + u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height',readflag) + ENDIF +#else + u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height',readflag) +#endif + + IF (u_site_htop) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtypes(SITE_landtype) == 0) THEN + CALL ncio_read_serial (fsrfdata, 'canopy_height_pfts', SITE_htop_pfts) + ELSE + CALL ncio_read_serial (fsrfdata, 'canopy_height', SITE_htop) + ENDIF +#else + CALL ncio_read_serial (fsrfdata, 'canopy_height', SITE_htop) +#endif + ELSE +#ifdef LULC_USGS + CALL gridhtop%define_by_name ('colm_1km') + filename = trim(DEF_dir_rawdata)//'/Forest_Height.nc' + CALL read_point_var_2d_real8 (gridhtop, filename, 'forest_height', & + SITE_lon_location, SITE_lat_location, SITE_htop) +#else + + CALL gridhtop%define_by_name ('colm_500m') + + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + write(cyear,'(i4.4)') DEF_LC_YEAR + CALL read_point_5x5_var_2d_real8 (gridhtop, dir_5x5, 'MOD'//trim(cyear), 'HTOP', & + SITE_lon_location, SITE_lat_location, SITE_htop) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + allocate (SITE_htop_pfts (numpft)) + SITE_htop_pfts(:) = SITE_htop + ENDIF +#endif +#endif + ENDIF + + IF (mksrfdata) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtypes(SITE_landtype) == 0) THEN + arraysize = size(SITE_htop_pfts) + write(fmt_str, '("(A,", I0, "F8.2,3A)")') arraysize + write(*,fmt_str) 'Forest height : ', SITE_htop_pfts, ' (from ',trim(datasource(u_site_htop)),')' + ELSE + write(*,'(A,F8.2,3A)') 'Forest height : ', SITE_htop, ' (from ',trim(datasource(u_site_htop)),')' + ENDIF +#else + write(*,'(A,F8.2,3A)') 'Forest height : ', SITE_htop, ' (from ',trim(datasource(u_site_htop)),')' +#endif + ENDIF + + + ! (5) LAI + readflag = ((.not. mksrfdata) .or. USE_SITE_LAI) + readflag = readflag .and. ncio_var_exist(fsrfdata,'LAI_year',readflag) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtypes(SITE_landtype) == 0) THEN + u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_pfts_monthly',readflag) & + .and. ncio_var_exist(fsrfdata,'SAI_pfts_monthly',readflag) + ELSE + u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_monthly',readflag) & + .and. ncio_var_exist(fsrfdata,'SAI_monthly',readflag) + ENDIF +#else + IF (DEF_LAI_MONTHLY) THEN + u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_monthly',readflag) & + .and. ncio_var_exist(fsrfdata,'SAI_monthly',readflag) + ELSE + u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_8day',readflag) + ENDIF +#endif + + IF (u_site_lai) THEN + CALL ncio_read_serial (fsrfdata, 'LAI_year', SITE_LAI_year) + start_year = 1 + end_year = size(SITE_LAI_year) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtypes(SITE_landtype) == 0) THEN + CALL ncio_read_serial (fsrfdata, 'LAI_pfts_monthly', SITE_LAI_pfts_monthly) + CALL ncio_read_serial (fsrfdata, 'SAI_pfts_monthly', SITE_SAI_pfts_monthly) + ntime = size(SITE_LAI_pfts_monthly,2) + ELSE + CALL ncio_read_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly) + CALL ncio_read_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly) + ntime = size(SITE_LAI_monthly,1) + ENDIF +#else + IF (DEF_LAI_MONTHLY) THEN + CALL ncio_read_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly) + CALL ncio_read_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly) + ntime = size(SITE_LAI_monthly,1) + ELSE + CALL ncio_read_serial (fsrfdata, 'LAI_8day', SITE_LAI_8day) + ntime = size(SITE_LAI_8day,1) + ENDIF +#endif + ELSE + + idate(1) = DEF_simulation_time%start_year + IF (.not. isgreenwich) THEN + idate(3) = DEF_simulation_time%start_sec + CALL monthday2julian (idate(1), & + DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2)) + CALL localtime2gmt(idate) + ENDIF + + simulation_lai_year_start = idate(1) + + idate(1) = DEF_simulation_time%end_year + IF (.not. isgreenwich) THEN + idate(3) = DEF_simulation_time%end_sec + CALL monthday2julian (idate(1), & + DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2)) + CALL localtime2gmt(idate) + ENDIF + + simulation_lai_year_end = idate(1) + + IF (DEF_LAI_CHANGE_YEARLY) THEN + start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) + start_year = min(start_year, DEF_LAI_END_YEAR ) + end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) + end_year = max(end_year, DEF_LAI_START_YEAR ) + ELSE + start_year = DEF_LC_YEAR + end_year = DEF_LC_YEAR + ENDIF + + allocate (SITE_LAI_year (start_year:end_year)) + SITE_LAI_year = (/(iyear, iyear = start_year, end_year)/) + + IF (DEF_LAI_MONTHLY) THEN + ntime = 12 + allocate (SITE_LAI_monthly (12,start_year:end_year)) + allocate (SITE_SAI_monthly (12,start_year:end_year)) + ELSE + ntime = 46 + allocate (SITE_LAI_8day (46,start_year:end_year)) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + allocate (SITE_LAI_pfts_monthly (numpft,12,start_year:end_year)) + allocate (SITE_SAI_pfts_monthly (numpft,12,start_year:end_year)) + ENDIF +#endif + + CALL gridlai%define_by_name ('colm_500m') + + DO iyear = start_year, end_year + + write(cyear,'(i4.4)') iyear + + DO itime = 1, ntime +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + CALL read_point_5x5_var_3d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'MONTHLY_PFT_LAI', & + SITE_lon_location, SITE_lat_location, N_PFT_modis, itime, pftLAI) + CALL read_point_5x5_var_3d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'MONTHLY_PFT_SAI', & + SITE_lon_location, SITE_lat_location, N_PFT_modis, itime, pftSAI) + +#ifndef CROP + IF (patchtypes(SITE_landtype) == 0) THEN +#else + IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN +#endif + IF (allocated(pctpfts)) deallocate (pctpfts) + allocate(pctpfts (0:N_PFT_modis-1)); pctpfts(:) = 0. + pctpfts(SITE_pfttyp) = SITE_pctpfts + + SITE_LAI_pfts_monthly(:,itime,iyear) = pack(pftLAI, pctpfts > 0.) + SITE_SAI_pfts_monthly(:,itime,iyear) = pack(pftSAI, pctpfts > 0.) +#ifdef CROP + ELSEIF (SITE_landtype == CROPLAND) THEN + CALL read_point_5x5_var_3d_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'PCT_PFT', & + SITE_lon_location, SITE_lat_location, N_PFT_modis, pctpfts) + SITE_LAI_pfts_monthly(:,itime,iyear) = sum(pftLAI * pctpfts) / sum(pctpfts) + SITE_SAI_pfts_monthly(:,itime,iyear) = sum(pftSAI * pctpfts) / sum(pctpfts) +#endif + ELSE + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & + 'MONTHLY_LC_LAI', SITE_lon_location, SITE_lat_location, itime, & + SITE_LAI_monthly(itime,iyear)) + CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & + 'MONTHLY_LC_SAI', SITE_lon_location, SITE_lat_location, itime, & + SITE_SAI_monthly(itime,iyear)) + ENDIF + +#else + IF (DEF_LAI_MONTHLY) THEN + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & + 'MONTHLY_LC_LAI', SITE_lon_location, SITE_lat_location, itime, & + SITE_LAI_monthly(itime,iyear)) + CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & + 'MONTHLY_LC_SAI', SITE_lon_location, SITE_lat_location, itime, & + SITE_SAI_monthly(itime,iyear)) + ELSE + filename = trim(DEF_dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc' + CALL read_point_var_2d_time_real8 (gridlai, filename, 'lai', & + SITE_lon_location, SITE_lat_location, itime, LAI) + SITE_LAI_8day(itime,iyear) = LAI * 0.1 + ENDIF +#endif + ENDDO + ENDDO + ENDIF + + IF (mksrfdata) THEN + DO iyear = start_year, end_year + write(c,'(i2)') ntime +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (patchtypes(SITE_landtype) == 0) THEN + DO i = 1, numpft + write(*,'(A,I4,A,I2,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), & + ', pft ', SITE_pfttyp(i),') : ', SITE_LAI_pfts_monthly(i,:,iyear), & + ' (from ',trim(datasource(u_site_lai)),')' + write(*,'(A,I4,A,I2,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), & + ', pft ', SITE_pfttyp(i),') : ', SITE_SAI_pfts_monthly(i,:,iyear), & + ' (from ',trim(datasource(u_site_lai)),')' + ENDDO + ELSE + write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', & + SITE_LAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' + write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), ') : ', & + SITE_SAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' + ENDIF +#else + IF (DEF_LAI_MONTHLY) THEN + write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', & + SITE_LAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' + write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), ') : ', & + SITE_SAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' + ELSE + write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', & + SITE_LAI_8day(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' + ENDIF +#endif + ENDDO + ENDIF + + + ! (6) lake depth + readflag = ((.not. mksrfdata) .or. USE_SITE_lakedepth) + u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag) + + IF (u_site_lakedepth) THEN + CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth) + ELSE + CALL gridlake%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/lake_depth.nc' + CALL read_point_var_2d_real8 (gridlake, filename, 'lake_depth', & + SITE_lon_location, SITE_lat_location, lakedepth) + SITE_lakedepth = lakedepth * 0.1 + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',trim(datasource(u_site_lakedepth)),')' + ENDIF + + + ! (7) soil brightness parameters + readflag = ((.not. mksrfdata) .or. USE_SITE_soilreflectance) + u_site_soil_bright = readflag & + .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) & + .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) & + .and. ncio_var_exist(fsrfdata,'soil_s_n_alb',readflag) & + .and. ncio_var_exist(fsrfdata,'soil_d_n_alb',readflag) + + IF (u_site_soil_bright) THEN + CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) + ELSE + SITE_soil_s_v_alb = spval + SITE_soil_d_v_alb = spval + SITE_soil_s_n_alb = spval + SITE_soil_d_n_alb = spval + + CALL gridbright%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/soil_brightness.nc' + CALL read_point_var_2d_int32 (gridbright, filename, 'soil_brightness', & + SITE_lon_location, SITE_lat_location, isc) + +#ifdef LULC_USGS + IF(SITE_landtype /= 16 .and. SITE_landtype /= 24)THEN ! NOT WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(SITE_landtype /= 17 .and. SITE_landtype /= 15)THEN ! NOT WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + IF ((isc >= 1) .and. (isc <= 20)) THEN + SITE_soil_s_v_alb = soil_s_v_refl( isc ) + SITE_soil_d_v_alb = soil_d_v_refl( isc ) + SITE_soil_s_n_alb = soil_s_n_refl( isc ) + SITE_soil_d_n_alb = soil_d_n_refl( isc ) + ENDIF + ENDIF + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + write(*,'(A,F8.2,3A)') 'Soil brightness d_n : ', SITE_soil_d_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + ENDIF + + + ! (8) soil parameters + + CALL gridsoil%define_by_name ('colm_500m') + + readflag = ((.not. mksrfdata) .or. USE_SITE_soilparameters) + u_site_vf_quartz_mineral = readflag & + .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag) + IF (u_site_vf_quartz_mineral) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) + ELSE + allocate (SITE_soil_vf_quartz_mineral (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_quartz_mineral_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_quartz_mineral(nsl)) + ENDDO + ENDIF + + u_site_vf_gravels = readflag & + .and. ncio_var_exist(fsrfdata,'soil_vf_gravels',readflag) + IF (u_site_vf_gravels) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels) + ELSE + allocate (SITE_soil_vf_gravels (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_gravels_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_gravels_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_gravels(nsl)) + ENDDO + ENDIF + + u_site_vf_sand = readflag & + .and. ncio_var_exist(fsrfdata,'soil_vf_sand',readflag) + IF (u_site_vf_sand) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand) + ELSE + allocate (SITE_soil_vf_sand (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_sand_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_sand_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_sand(nsl)) + ENDDO + ENDIF + + u_site_vf_clay = readflag & + .and. ncio_var_exist(fsrfdata,'soil_vf_clay',readflag) + IF (u_site_vf_clay) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay) + ELSE + allocate (SITE_soil_vf_clay (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_clay_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_clay_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_clay(nsl)) + ENDDO + ENDIF + + u_site_vf_om = readflag & + .and. ncio_var_exist(fsrfdata,'soil_vf_om',readflag) + IF (u_site_vf_om) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om) + ELSE + allocate (SITE_soil_vf_om (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_om_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_om_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_om(nsl)) + ENDDO + ENDIF + + u_site_wf_gravels = readflag & + .and. ncio_var_exist(fsrfdata,'soil_wf_gravels',readflag) + IF (u_site_wf_gravels) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels) + ELSE + allocate (SITE_soil_wf_gravels (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_gravels_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_gravels_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_gravels(nsl)) + ENDDO + ENDIF + + u_site_wf_sand = readflag & + .and. ncio_var_exist(fsrfdata,'soil_wf_sand',readflag) + IF (u_site_wf_sand) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand) + ELSE + allocate (SITE_soil_wf_sand (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_sand_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_sand_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_sand(nsl)) + ENDDO + ENDIF + + u_site_wf_clay = readflag & + .and. ncio_var_exist(fsrfdata,'soil_wf_clay',readflag) + IF (u_site_wf_clay) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay) + ELSE + allocate (SITE_soil_wf_clay (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_clay_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_clay_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_clay(nsl)) + ENDDO + ENDIF + + u_site_wf_om = readflag & + .and. ncio_var_exist(fsrfdata,'soil_wf_om',readflag) + IF (u_site_wf_om) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om) + ELSE + allocate (SITE_soil_wf_om (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_om_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_om_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_om(nsl)) + ENDDO + ENDIF + + u_site_OM_density = readflag & + .and. ncio_var_exist(fsrfdata,'soil_OM_density',readflag) + IF (u_site_OM_density) THEN + CALL ncio_read_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density) + ELSE + allocate (SITE_soil_OM_density (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/OM_density_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'OM_density_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_OM_density(nsl)) + ENDDO + ENDIF + + u_site_BD_all = readflag & + .and. ncio_var_exist(fsrfdata,'soil_BD_all',readflag) + IF (u_site_BD_all) THEN + CALL ncio_read_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all) + ELSE + allocate (SITE_soil_BD_all (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/BD_all_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'BD_all_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_BD_all(nsl)) + ENDDO + ENDIF + + u_site_theta_s = readflag & + .and. ncio_var_exist(fsrfdata,'soil_theta_s',readflag) + IF (u_site_theta_s) THEN + CALL ncio_read_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s) + ELSE + allocate (SITE_soil_theta_s (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/theta_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'theta_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_theta_s(nsl)) + ENDDO + ENDIF + + u_site_k_s = readflag & + .and. ncio_var_exist(fsrfdata,'soil_k_s',readflag) + IF (u_site_k_s) THEN + CALL ncio_read_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s) + ELSE + allocate (SITE_soil_k_s (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/k_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'k_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_k_s(nsl)) + ENDDO + ENDIF + + u_site_csol = readflag & + .and. ncio_var_exist(fsrfdata,'soil_csol',readflag) + IF (u_site_csol) THEN + CALL ncio_read_serial (fsrfdata, 'soil_csol', SITE_soil_csol) + ELSE + allocate (SITE_soil_csol (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/csol.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'csol_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_csol(nsl)) + ENDDO + ENDIF + + u_site_tksatu = readflag & + .and. ncio_var_exist(fsrfdata,'soil_tksatu',readflag) + IF (u_site_tksatu) THEN + CALL ncio_read_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu) + ELSE + allocate (SITE_soil_tksatu (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/tksatu.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatu_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_tksatu(nsl)) + ENDDO + ENDIF + + u_site_tksatf = readflag & + .and. ncio_var_exist(fsrfdata,'soil_tksatf',readflag) + IF (u_site_tksatf) THEN + CALL ncio_read_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf) + ELSE + allocate (SITE_soil_tksatf (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/tksatf.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatf_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_tksatf(nsl)) + ENDDO + ENDIF + + u_site_tkdry = readflag & + .and. ncio_var_exist(fsrfdata,'soil_tkdry',readflag) + IF (u_site_tkdry) THEN + CALL ncio_read_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry) + ELSE + allocate (SITE_soil_tkdry (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/tkdry.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'tkdry_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_tkdry(nsl)) + ENDDO + ENDIF + + u_site_k_solids = readflag & + .and. ncio_var_exist(fsrfdata,'soil_k_solids',readflag) + IF (u_site_k_solids) THEN + CALL ncio_read_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids) + ELSE + allocate (SITE_soil_k_solids (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/k_solids.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'k_solids_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_k_solids(nsl)) + ENDDO + ENDIF + + u_site_psi_s = readflag & + .and. ncio_var_exist(fsrfdata,'soil_psi_s',readflag) + IF (u_site_psi_s) THEN + CALL ncio_read_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s) + ELSE + allocate (SITE_soil_psi_s (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/psi_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'psi_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_psi_s(nsl)) + ENDDO + ENDIF + + u_site_lambda = readflag & + .and. ncio_var_exist(fsrfdata,'soil_lambda',readflag) + IF (u_site_lambda) THEN + CALL ncio_read_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda) + ELSE + allocate (SITE_soil_lambda (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/lambda.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'lambda_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_lambda(nsl)) + ENDDO + ENDIF + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + u_site_theta_r = readflag & + .and. ncio_var_exist(fsrfdata,'soil_theta_r',readflag) + IF (u_site_theta_r) THEN + CALL ncio_read_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r) + ELSE + allocate (SITE_soil_theta_r (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_theta_r.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_theta_r_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_theta_r(nsl)) + ENDDO + ENDIF + + u_site_alpha_vgm = readflag & + .and. ncio_var_exist(fsrfdata,'soil_alpha_vgm',readflag) + IF (u_site_alpha_vgm) THEN + CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm) + ELSE + allocate (SITE_soil_alpha_vgm (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_alpha.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_alpha_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_alpha_vgm(nsl)) + ENDDO + ENDIF + + u_site_L_vgm = readflag & + .and. ncio_var_exist(fsrfdata,'soil_L_vgm',readflag) + IF (u_site_L_vgm) THEN + CALL ncio_read_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm) + ELSE + allocate (SITE_soil_L_vgm (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_L.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_L_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_L_vgm(nsl)) + ENDDO + ENDIF + + u_site_n_vgm = readflag & + .and. ncio_var_exist(fsrfdata,'soil_n_vgm',readflag) + IF (u_site_n_vgm) THEN + CALL ncio_read_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm) + ELSE + allocate (SITE_soil_n_vgm (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_n.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_n_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_n_vgm(nsl)) + ENDDO + ENDIF +#endif + + u_site_BA_alpha = u_site_vf_gravels .and. u_site_vf_sand + u_site_BA_beta = u_site_vf_gravels .and. u_site_vf_sand + allocate (SITE_soil_BA_alpha (8)) + allocate (SITE_soil_BA_beta (8)) + DO nsl = 1, 8 + IF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.4) THEN + SITE_soil_BA_alpha(nsl) = 0.38 + SITE_soil_BA_beta (nsl) = 35.0 + ELSEIF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.25) THEN + SITE_soil_BA_alpha(nsl) = 0.24 + SITE_soil_BA_beta (nsl) = 26.0 + ELSE + SITE_soil_BA_alpha(nsl) = 0.20 + SITE_soil_BA_beta (nsl) = 10.0 + ENDIF + ENDDO + + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + u_site_soil_texture = readflag & + .and. ncio_var_exist(fsrfdata,'soil_texture',readflag) + IF (u_site_soil_texture) THEN + CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture) + ELSE + filename = trim(DEF_dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc' + CALL read_point_var_2d_int32 (gridsoil, filename, 'soiltexture', & + SITE_lon_location, SITE_lat_location, SITE_soil_texture) + ENDIF + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_clay : ', SITE_soil_vf_clay (1:8), ' (from ',trim(datasource(u_site_vf_clay )),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_om : ', SITE_soil_vf_om (1:8), ' (from ',trim(datasource(u_site_vf_om )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_gravels : ', SITE_soil_wf_gravels (1:8), ' (from ',trim(datasource(u_site_wf_gravels )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_sand : ', SITE_soil_wf_sand (1:8), ' (from ',trim(datasource(u_site_wf_sand )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_clay : ', SITE_soil_wf_clay (1:8), ' (from ',trim(datasource(u_site_wf_clay )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_om : ', SITE_soil_wf_om (1:8), ' (from ',trim(datasource(u_site_wf_om )),')' + write(*,'(A,8ES10.2,3A)') 'soil_OM_density : ', SITE_soil_OM_density (1:8), ' (from ',trim(datasource(u_site_OM_density )),')' + write(*,'(A,8ES10.2,3A)') 'soil_BD_all : ', SITE_soil_BD_all (1:8), ' (from ',trim(datasource(u_site_BD_all )),')' + write(*,'(A,8ES10.2,3A)') 'soil_theta_s : ', SITE_soil_theta_s (1:8), ' (from ',trim(datasource(u_site_theta_s )),')' + write(*,'(A,8ES10.2,3A)') 'soil_k_s : ', SITE_soil_k_s (1:8), ' (from ',trim(datasource(u_site_k_s )),')' + write(*,'(A,8ES10.2,3A)') 'soil_csol : ', SITE_soil_csol (1:8), ' (from ',trim(datasource(u_site_csol )),')' + write(*,'(A,8ES10.2,3A)') 'soil_tksatu : ', SITE_soil_tksatu (1:8), ' (from ',trim(datasource(u_site_tksatu )),')' + write(*,'(A,8ES10.2,3A)') 'soil_tksatf : ', SITE_soil_tksatf (1:8), ' (from ',trim(datasource(u_site_tksatf )),')' + write(*,'(A,8ES10.2,3A)') 'soil_tkdry : ', SITE_soil_tkdry (1:8), ' (from ',trim(datasource(u_site_tkdry )),')' + write(*,'(A,8ES10.2,3A)') 'soil_k_solids : ', SITE_soil_k_solids (1:8), ' (from ',trim(datasource(u_site_k_solids )),')' + write(*,'(A,8ES10.2,3A)') 'soil_psi_s : ', SITE_soil_psi_s (1:8), ' (from ',trim(datasource(u_site_psi_s )),')' + write(*,'(A,8ES10.2,3A)') 'soil_lambda : ', SITE_soil_lambda (1:8), ' (from ',trim(datasource(u_site_lambda )),')' +#ifdef vanGenuchten_Mualem_SOIL_MODEL + write(*,'(A,8ES10.2,3A)') 'soil_theta_r : ', SITE_soil_theta_r (1:8), ' (from ',trim(datasource(u_site_theta_r )),')' + write(*,'(A,8ES10.2,3A)') 'soil_alpha_vgm : ', SITE_soil_alpha_vgm (1:8), ' (from ',trim(datasource(u_site_alpha_vgm )),')' + write(*,'(A,8ES10.2,3A)') 'soil_L_vgm : ', SITE_soil_L_vgm (1:8), ' (from ',trim(datasource(u_site_L_vgm )),')' + write(*,'(A,8ES10.2,3A)') 'soil_n_vgm : ', SITE_soil_n_vgm (1:8), ' (from ',trim(datasource(u_site_n_vgm )),')' +#endif + write(*,'(A,8ES10.2,3A)') 'soil_BA_alpha : ', SITE_soil_BA_alpha (1:8), ' (from ',trim(datasource(u_site_BA_alpha )),')' + write(*,'(A,8ES10.2,3A)') 'soil_BA_beta : ', SITE_soil_BA_beta (1:8), ' (from ',trim(datasource(u_site_BA_beta )),')' + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + write(*,'(A,I3,3A)') 'soil texture : ', SITE_soil_texture, ' (from ',trim(datasource(u_site_soil_texture)),')' + ENDIF + ENDIF + + + ! (9) depth to bedrock + IF (DEF_USE_BEDROCK) THEN + readflag = ((.not. mksrfdata) .or. USE_SITE_dbedrock) + u_site_dbedrock = readflag & + .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag) + IF (u_site_dbedrock) THEN + CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + ELSE + CALL gridrock%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/bedrock.nc' + CALL read_point_var_2d_real8 (gridrock, filename, 'dbedrock', & + SITE_lon_location, SITE_lat_location, SITE_dbedrock) + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',trim(datasource(u_site_dbedrock)),')' + ENDIF + + ENDIF + + ! (10) topography + readflag = ((.not. mksrfdata) .or. USE_SITE_topography) + + u_site_elevation = readflag & + .and. ncio_var_exist (fsrfdata, 'elevation',readflag) + IF (u_site_elevation) THEN + CALL ncio_read_serial (fsrfdata, 'elevation', SITE_elevation) + ELSE + CALL gridtopo%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/topography.nc' + CALL read_point_var_2d_real8 (gridtopo, filename, 'elevation', & + SITE_lon_location, SITE_lat_location, SITE_elevation) + ENDIF + + u_site_elvstd = readflag & + .and. ncio_var_exist (fsrfdata, 'elvstd',readflag) + IF (u_site_elvstd) THEN + CALL ncio_read_serial (fsrfdata, 'elvstd', SITE_elvstd) + ELSE + CALL gridtopo%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/topography.nc' + CALL read_point_var_2d_real8 (gridtopo, filename, 'elvstd', & + SITE_lon_location, SITE_lat_location, SITE_elvstd) + ENDIF + + u_site_sloperatio = readflag & + .and. ncio_var_exist (fsrfdata, 'sloperatio',readflag) + IF (u_site_sloperatio) THEN + CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio) + ELSE + CALL gridtopo%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/topography.nc' + CALL read_point_var_2d_real8 (gridtopo, filename, 'slope', & + SITE_lon_location, SITE_lat_location, SITE_sloperatio) + ENDIF + + IF (DEF_USE_Forcing_Downscaling) THEN + + filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" + IF (ncio_var_exist(filename,'lat') .and. ncio_var_exist(filename,'lon')) THEN + CALL grid_topo_factor%define_from_file (filename, "lat", "lon") + ENDIF + + u_site_svf = readflag & + .and. ncio_var_exist (fsrfdata, 'SITE_svf',readflag) + IF (u_site_svf) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/sky_view_factor.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'svf', & + SITE_lon_location, SITE_lat_location, SITE_svf) + ENDIF + + u_site_cur = readflag & + .and. ncio_var_exist (fsrfdata, 'SITE_cur',readflag) + IF (u_site_cur) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/curvature.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'curvature', & + SITE_lon_location, SITE_lat_location, SITE_cur) + ENDIF + + u_site_slp_type = readflag & + .and. ncio_var_exist (fsrfdata, 'SITE_slp_type', readflag) & + .and. ncio_var_exist (fsrfdata, 'SITE_asp_type', readflag) & + .and. ncio_var_exist (fsrfdata, 'SITE_area_type',readflag) + u_site_asp_type = u_site_slp_type + u_site_area_type = u_site_slp_type + + IF (u_site_slp_type) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type ) + CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type ) + CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type ) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'slope', & + SITE_lon_location, SITE_lat_location, slp) + + filename = trim(DEF_DS_HiresTopographyDataDir)//"/aspect.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'aspect', & + SITE_lon_location, SITE_lat_location, asp) + + allocate (SITE_slp_type (num_slope_type)); SITE_slp_type (:) = 0. + allocate (SITE_asp_type (num_slope_type)); SITE_asp_type (:) = 0. + allocate (SITE_area_type (num_slope_type)); SITE_area_type(:) = 0. + + IF ((asp.ge.0 .and. asp.le.90*pi/180) .or. (asp.ge.270*pi/180 .and. asp.le.360*pi/180)) THEN + IF ((slp.ge.15*pi/180)) THEN ! north abrupt slope + typ = 1 + ELSE ! north gentle slope + typ = 2 + ENDIF + ELSE + IF ((slp.ge.15*pi/180)) THEN ! south abrupt slope + typ = 3 + ELSE ! south gentle slope + typ = 4 + ENDIF + ENDIF + + SITE_slp_type (typ) = slp + SITE_asp_type (typ) = asp + SITE_area_type(typ) = 1. + + ENDIF + + u_site_sf_lut = readflag & + .and. ncio_var_exist (fsrfdata, 'SITE_sf_lut',readflag) + IF (u_site_sf_lut) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_front.nc" + CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_front', & + SITE_lon_location, SITE_lat_location, num_azimuth, tea_f) + + filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_back.nc" + CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_back', & + SITE_lon_location, SITE_lat_location, num_azimuth, tea_b) + + allocate (SITE_sf_lut (num_azimuth, num_zenith)) + + DO a = 1, num_azimuth + + tea_f(a) = asin(max(min(tea_f(a),1.),-1.)) + tea_b(a) = asin(max(min(tea_b(a),1.),-1.)) + + IF (tea_f(a) <= tea_b(a)) tea_f(a) = tea_b(a) + 0.001 + + DO z = 1, num_zenith + zenith_angle = pi/(2*num_zenith)*(z-1) + + IF (pi*0.5 - zenith_angle < tea_b(a)) THEN + SITE_sf_lut(a,z) = 0 + ELSE IF (pi*0.5 - zenith_angle > tea_f(a)) THEN + SITE_sf_lut(a,z) = 1 + ELSE + SITE_sf_lut(a,z) = (0.5*pi - zenith_angle - tea_b(a))/(tea_f(a) - tea_b(a)) + ENDIF + + ENDDO + ENDDO + + ENDIF + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation , ' (from ',trim(datasource(u_site_elevation)),')' + write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd , ' (from ',trim(datasource(u_site_elvstd)),')' + write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio, ' (from ',trim(datasource(u_site_sloperatio)),')' + + IF (DEF_USE_Forcing_Downscaling) THEN + write(*,'(A,F8.2,3A)') 'Sky view factor : ', SITE_svf, ' (from ',trim(datasource(u_site_svf)),')' + write(*,'(A,F8.2,3A)') 'Curvature : ', SITE_cur, ' (from ',trim(datasource(u_site_cur)),')' + write(c,'(I0)') num_slope_type + write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type : ', SITE_slp_type, ' (from ',trim(datasource(u_site_slp_type)),')' + write(*,'(A,'//trim(c)//'F8.2,3A)') 'Aspect type : ', SITE_asp_type, ' (from ',trim(datasource(u_site_slp_type)),')' + write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type area : ', SITE_area_type, ' (from ',trim(datasource(u_site_slp_type)),')' + write(c,'(I0)') num_azimuth*num_zenith + write(*,'(A,A,I3,A,I3,A,'//trim(c)//'F8.2,3A)') 'Shadow lookup table : ', & + '(', num_azimuth, ' in azimuth,', num_zenith, ' in zenith)', & + SITE_sf_lut , ' (from ',trim(datasource(u_site_sf_lut)),')' + ENDIF + ENDIF + + + IF (.not. mksrfdata) THEN + + landpatch%nset = numpatch + + allocate (landpatch%settyp (numpatch)); landpatch%settyp = SITE_landtype + + landpatch%nblkgrp = 1 + allocate (landpatch%xblkgrp(1)); landpatch%xblkgrp(1) = 1 + allocate (landpatch%yblkgrp(1)); landpatch%yblkgrp(1) = 1 + + allocate (landpatch%vecgs%vlen(1,1)); landpatch%vecgs%vlen(1,1) = numpatch + allocate (landpatch%vecgs%vstt(1,1)); landpatch%vecgs%vstt(1,1) = 1 + allocate (landpatch%vecgs%vend(1,1)); landpatch%vecgs%vend(1,1) = numpatch + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + IF (numpft > 0) THEN + + landpft%nset = numpft + + allocate (landpft%settyp (numpft)); landpft%settyp = SITE_pfttyp + + landpft%nblkgrp = 1 + allocate (landpft%xblkgrp(1)); landpft%xblkgrp(1) = 1 + allocate (landpft%yblkgrp(1)); landpft%yblkgrp(1) = 1 + + allocate (landpft%vecgs%vlen(1,1)); landpft%vecgs%vlen(1,1) = numpft + allocate (landpft%vecgs%vstt(1,1)); landpft%vecgs%vstt(1,1) = 1 + allocate (landpft%vecgs%vend(1,1)); landpft%vecgs%vend(1,1) = numpft + + allocate (patch_pft_s (numpatch)) + allocate (patch_pft_e (numpatch)) + allocate (pft2patch (numpft )) +#ifdef CROP + IF (SITE_landtype == CROPLAND) THEN + patch_pft_s = (/(i, i = 1, numpatch)/) + patch_pft_e = (/(i, i = 1, numpatch)/) + pft2patch = (/(i, i = 1, numpatch)/) + ELSE + patch_pft_s = 1 + patch_pft_e = numpft + pft2patch = 1 + ENDIF +#else + patch_pft_s = 1 + patch_pft_e = numpft + pft2patch = 1 +#endif + ENDIF +#endif + + numelm = 1 + allocate (landelm%settyp (1)); landelm%settyp (1) = 0 + allocate (elm_patch%substt (1)); elm_patch%substt(1) = 1 + allocate (elm_patch%subend (1)); elm_patch%subend(1) = numpatch + + allocate (elm_patch%subfrc (numpatch)); elm_patch%subfrc = 1./numpatch +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef CROP + elm_patch%subfrc = SITE_pctcrop +#endif +#endif + + ENDIF + + END SUBROUTINE read_surface_data_single + +!----------------------------------------------------------------------- + SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) + + USE MOD_TimeManager + USE MOD_Grid + USE MOD_Block + USE MOD_NetCDFSerial + USE MOD_NetCDFPoint + USE MOD_Namelist + USE MOD_Utils + USE MOD_SPMD_Task + USE MOD_LandPatch + USE MOD_LandUrban + USE MOD_Urban_Const_LCZ + USE MOD_Vars_Global, only: PI, URBAN + USE MOD_Mesh, only: numelm + USE MOD_LandElm + IMPLICIT NONE + + character(len=*), intent(in) :: fsrfdata + logical, intent(in) :: mksrfdata + logical, intent(in), optional :: mkrun + + ! Local Variables + real(r8), allocatable, dimension(:,:) :: hwrbld_ncar , fgper_ncar , htroof_ncar , wtroof_ncar + real(r8), allocatable, dimension(:,:) :: emroof_ncar , emwall_ncar , emgimp_ncar , emgper_ncar + real(r8), allocatable, dimension(:,:) :: thkroof_ncar, thkwall_ncar, tbldmin_ncar, tbldmax_ncar + real(r8), allocatable, dimension(:,:,:) :: cvroof_ncar , cvwall_ncar , cvgimp_ncar , & + tkroof_ncar , tkwall_ncar , tkgimp_ncar + real(r8), allocatable, dimension(:,:,:,:) :: albroof_ncar, albwall_ncar, albgimp_ncar, albgper_ncar + + real(r8) :: lat_in, lon_in + real(r8) :: LAI, lakedepth, slp, asp, zenith_angle + integer :: i, isc, nsl, typ, a, z, rid, utyp + integer :: iyear, idate(3), simulation_lai_year_start, simulation_lai_year_end + integer :: start_year, end_year, ntime, itime, pop_i + logical :: readflag + + character(len=256) :: filename, dir_5x5 + character(len=4) :: cyear, c, c5year + + type(grid_type) :: gridupatch, gridhroof, gridfroof , gridhtopu, gridfvegu, gridflakeu, gridlaiu, & + gridpopu , gridlucy , gridbright, gridsoil , gridrock , gridtopo , gridlake, & + grid_topo_factor + + real(r8), allocatable :: tea_f(:), tea_b(:) + + u_site_froof = .false.; u_site_hroof = .false.; u_site_fgper = .false.; u_site_hlr = .false.; + u_site_fveg = .false.; u_site_htopu = .false.; u_site_urblai = .false.; u_site_urbsai = .false.; + u_site_flake = .false.; + + u_site_albr = .false.; u_site_albw = .false.; u_site_albgimp = .false.; u_site_albgper = .false.; + u_site_emr = .false.; u_site_emw = .false.; u_site_emgimp = .false.; u_site_emgper = .false.; + + u_site_cvr = .false.; u_site_cvw = .false.; u_site_cvgimp = .false.; + u_site_tkr = .false.; u_site_tkw = .false.; u_site_tkgimp = .false.; + + u_site_tbmax = .false.; u_site_tbmin = .false.; u_site_thickr = .false.; u_site_thickw = .false.; + u_site_pop = .false.; u_site_lucy = .false.; + + IF (mksrfdata) THEN + write(*,*) + write(*,*) ' ---------------- Make Single Point Surface Data ---------------- ' + ENDIF + + IF (ncio_var_exist(fsrfdata, 'latitude')) THEN + CALL ncio_read_serial (fsrfdata, 'latitude', lat_in) + IF (lat_in /= SITE_lat_location) THEN + write(*,*) 'Warning: Latitude mismatch: ', & + lat_in, ' in data file and ', SITE_lat_location, 'in namelist.' + ENDIF + SITE_lat_location = lat_in + ENDIF + + IF (ncio_var_exist(fsrfdata, 'longitude')) THEN + CALL ncio_read_serial (fsrfdata, 'longitude', lon_in) + IF (lon_in /= SITE_lon_location) THEN + write(*,*) 'Warning: Longitude mismatch: ', & + lon_in, ' in data file and ', SITE_lon_location, 'in namelist.' + ENDIF + SITE_lon_location = lon_in + ENDIF + + CALL normalize_longitude (SITE_lon_location) + + IF (.not. isgreenwich) THEN + LocalLongitude = SITE_lon_location + ENDIF + + IF (mksrfdata) THEN + write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location + write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location + ENDIF + + DEF_domain%edges = floor(SITE_lat_location) + DEF_domain%edgen = floor(SITE_lat_location) + 1. + DEF_domain%edgew = floor(SITE_lon_location) + DEF_domain%edgee = floor(SITE_lon_location) + 1. + + CALL gblock%set () + gblock%nblkme = 1 + allocate(gblock%xblkme(1)) + allocate(gblock%yblkme(1)) + gblock%xblkme(1) = find_nearest_west (SITE_lon_location, gblock%nxblk, gblock%lon_w) + gblock%yblkme(1) = find_nearest_south (SITE_lat_location, gblock%nyblk, gblock%lat_s) + + ! (1) build/read "land patch" by using land cover type data + IF (trim(fsrfdata) /= 'null') THEN + SITE_landtype = URBAN + ELSEIF (SITE_landtype /= URBAN) THEN + write(*,*) 'Error! Please set SITE_landtype to URBAN in namelist file !' + CALL CoLM_stop() + ENDIF + + numpatch = 1 + numurban = 1 + u_site_landtype = (SITE_landtype >= 0) + IF (mksrfdata) THEN + write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), & + ' (from ',trim(datasource(u_site_landtype)),')' + ENDIF + + IF (mksrfdata) THEN + ! (2) build/read "urban type" by using land cover type data +IF (DEF_URBAN_type_scheme == 1) THEN + u_site_utype = ncio_var_exist(fsrfdata,'URBAN_DENSITY_CLASS') + + IF ( u_site_utype ) THEN + CALL ncio_read_serial (fsrfdata, 'URBTYP' , SITE_ncar_rid) + CALL ncio_read_serial (fsrfdata, 'URBAN_DENSITY_CLASS', SITE_urbtyp ) + ELSE + CALL gridupatch%define_by_name ('colm_500m') + + dir_5x5 = trim(DEF_dir_rawdata) // '/urban_type/' + CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'REGION_ID', & + SITE_lon_location, SITE_lat_location, SITE_ncar_rid) + + CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'URBAN_DENSITY_CLASS', & + SITE_lon_location, SITE_lat_location, SITE_urbtyp) + + write(*,'(A,I0,A,I0,3A)') 'Urban type : NCAR ', SITE_urbtyp, ' of Region ', SITE_ncar_rid, & + ' (from ',trim(datasource(u_site_utype)),')' + ENDIF +ELSE + u_site_utype = ncio_var_exist(fsrfdata,'LCZ_DOM') + IF ( u_site_utype ) THEN + CALL ncio_read_serial (fsrfdata, 'LCZ_DOM', SITE_urbtyp ) + ELSE + CALL gridupatch%define_by_name ('colm_500m') + + dir_5x5 = trim(DEF_dir_rawdata) // '/urban_type/' + CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'LCZ_DOM', & + SITE_lon_location, SITE_lat_location, SITE_urbtyp) + ENDIF + write(*,'(A,I0,3A)') 'Urban type : LCZ ', SITE_urbtyp, & + ' (from ',trim(datasource(u_site_utype)),')' +ENDIF + + + ! (4) urban geometry + readflag = USE_SITE_urban_geometry + u_site_hroof = ncio_var_exist(fsrfdata,'building_mean_height',readflag) + IF ( u_site_hroof ) THEN + CALL ncio_read_serial (fsrfdata, 'building_mean_height', SITE_hroof ) + ELSE + CALL gridhroof%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' + write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 + +IF (DEF_Urban_geom_data == 1) THEN + CALL read_point_5x5_var_2d_real8 (gridhroof, dir_5x5, 'URBSRF'//trim(c5year), 'HT_ROOF_GHSL', & + SITE_lon_location, SITE_lat_location, SITE_hroof) +ELSE + CALL read_point_5x5_var_2d_real8 (gridhroof, dir_5x5, 'URBSRF'//trim(c5year), 'HT_ROOF_Li', & + SITE_lon_location, SITE_lat_location, SITE_hroof) +ENDIF + ENDIF + + u_site_froof = readflag .and. ncio_var_exist(fsrfdata,'roof_area_fraction',readflag) + IF ( u_site_froof ) THEN + CALL ncio_read_serial (fsrfdata, 'roof_area_fraction', SITE_froof ) + ELSE + CALL gridfroof%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' + write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 +IF (DEF_Urban_geom_data == 1) THEN + CALL read_point_5x5_var_2d_real8 (gridfroof, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_ROOF_GHSL', & + SITE_lon_location, SITE_lat_location, SITE_froof) +ELSE + CALL read_point_5x5_var_2d_real8 (gridfroof, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_ROOF_Li', & + SITE_lon_location, SITE_lat_location, SITE_froof) +ENDIF + ENDIF + + u_site_fgper = readflag .and. ncio_var_exist(fsrfdata,'impervious_area_fraction',readflag) + IF ( u_site_fgper ) THEN + CALL ncio_read_serial (fsrfdata, 'impervious_area_fraction', SITE_fgimp ) + ENDIF + + u_site_thickr = readflag .and. ncio_var_exist(fsrfdata,'THICK_ROOF',readflag) + IF ( u_site_thickr ) THEN + CALL ncio_read_serial (fsrfdata, 'THICK_ROOF', SITE_thickroof ) + ENDIF + + u_site_thickw = readflag .and. ncio_var_exist(fsrfdata,'THICK_WALL',readflag) + IF ( u_site_thickw ) THEN + CALL ncio_read_serial (fsrfdata, 'THICK_WALL', SITE_thickwall ) + ENDIF + +IF (DEF_USE_CANYON_HWR) THEN + u_site_hlr = readflag .and. ncio_var_exist(fsrfdata,'canyon_height_width_ratio',readflag) + IF ( u_site_hlr ) THEN + CALL ncio_read_serial (fsrfdata, 'canyon_height_width_ratio', SITE_hlr ) + ENDIF +ELSE + u_site_hlr = readflag .and. ncio_var_exist(fsrfdata,'wall_to_plan_area_ratio',readflag) + IF ( u_site_hlr ) THEN + CALL ncio_read_serial (fsrfdata, 'wall_to_plan_area_ratio', SITE_lambdaw ) + SITE_hlr = SITE_lambdaw/4/SITE_froof + ENDIF +ENDIF + ! (5) urban ecology + readflag = USE_SITE_urban_ecology + u_site_htopu = readflag .and. ncio_var_exist(fsrfdata,'tree_mean_height',readflag) + IF ( u_site_htopu ) THEN + CALL ncio_read_serial (fsrfdata, 'tree_mean_height', SITE_htop_urb ) + ELSE + CALL gridhtopu%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' + write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 + + CALL read_point_5x5_var_2d_real8 (gridhtopu, dir_5x5, 'URBSRF'//trim(c5year), 'HTOP', & + SITE_lon_location, SITE_lat_location, SITE_htop_urb) + ENDIF + + u_site_flake = readflag .and. ncio_var_exist(fsrfdata,'water_area_fraction',readflag) + IF ( u_site_flake ) THEN + CALL ncio_read_serial (fsrfdata, 'water_area_fraction', SITE_flake_urb ) + ELSE + CALL gridflakeu%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' + write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 + + CALL read_point_5x5_var_2d_real8 (gridflakeu, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_Water', & + SITE_lon_location, SITE_lat_location, SITE_flake_urb) + + SITE_flake_urb = SITE_flake_urb/100 + ENDIF + + u_site_fveg = readflag .and. ncio_var_exist(fsrfdata,'tree_area_fraction',readflag) + IF ( u_site_fveg ) THEN + CALL ncio_read_serial (fsrfdata, 'tree_area_fraction', SITE_fveg_urb ) + ELSE + CALL gridfvegu%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' + write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 + + CALL read_point_5x5_var_2d_real8 (gridfvegu, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_Tree', & + SITE_lon_location, SITE_lat_location, SITE_fveg_urb) + + SITE_fveg_urb = SITE_fveg_urb/100 + ENDIF + + u_site_urblai = readflag .and. ncio_var_exist(fsrfdata,'TREE_LAI',readflag) + IF ( u_site_urblai) THEN + CALL ncio_read_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly ) + CALL ncio_read_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly ) + ELSE + + idate(1) = DEF_simulation_time%start_year + IF (.not. isgreenwich) THEN + idate(3) = DEF_simulation_time%start_sec + CALL monthday2julian (idate(1), & + DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2)) + CALL localtime2gmt(idate) + ENDIF + simulation_lai_year_start = idate(1) + + idate(1) = DEF_simulation_time%end_year + IF (.not. isgreenwich) THEN + idate(3) = DEF_simulation_time%end_sec + CALL monthday2julian (idate(1), & + DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2)) + CALL localtime2gmt(idate) + ENDIF + simulation_lai_year_end = idate(1) + + IF (DEF_LAI_CHANGE_YEARLY) THEN + start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) + start_year = min(start_year, DEF_LAI_END_YEAR ) + end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) + end_year = max(end_year, DEF_LAI_START_YEAR ) + ELSE + start_year = DEF_LC_YEAR + end_year = DEF_LC_YEAR + ENDIF + + allocate (SITE_LAI_year (start_year:end_year)) + SITE_LAI_year = (/(iyear, iyear = start_year, end_year)/) + + ntime = 12 + allocate (SITE_LAI_monthly (12,start_year:end_year)) + allocate (SITE_SAI_monthly (12,start_year:end_year)) + + CALL gridlaiu%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban_lai_500m/' + + DO iyear = start_year, end_year + write(cyear,'(i4.4)') iyear + DO itime = 1, ntime + CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBLAI_'//trim(cyear), & + 'URBAN_TREE_LAI', SITE_lon_location, SITE_lat_location, itime, & + SITE_LAI_monthly(itime,iyear)) + + CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBLAI_'//trim(cyear), & + 'URBAN_TREE_SAI', SITE_lon_location, SITE_lat_location, itime, & + SITE_SAI_monthly(itime,iyear)) + ENDDO + ENDDO + ENDIF + + ! (6) urban radiation + readflag = USE_SITE_urban_radiation + u_site_albr = readflag .and. ncio_var_exist(fsrfdata,'ALB_ROOF',readflag) + IF ( u_site_albr ) THEN + CALL ncio_read_serial (fsrfdata, 'ALB_ROOF', SITE_alb_roof ) + ENDIF + + u_site_albw = readflag .and. ncio_var_exist(fsrfdata,'ALB_WALL',readflag) + IF ( u_site_albw ) THEN + CALL ncio_read_serial (fsrfdata, 'ALB_WALL', SITE_alb_wall ) + ENDIF + + u_site_albgper = readflag .and. ncio_var_exist(fsrfdata,'ALB_GPER',readflag) + IF ( u_site_albgper ) THEN + CALL ncio_read_serial (fsrfdata, 'ALB_GPER', SITE_alb_gper ) + ENDIF + + u_site_albgimp = readflag .and. ncio_var_exist(fsrfdata,'ALB_GIMP',readflag) + IF ( u_site_albgimp ) THEN + CALL ncio_read_serial (fsrfdata, 'ALB_GIMP', SITE_alb_gimp ) + ENDIF + + u_site_emr = readflag .and. ncio_var_exist(fsrfdata,'EM_ROOF',readflag) + IF ( u_site_emr ) THEN + CALL ncio_read_serial (fsrfdata, 'EM_ROOF', SITE_em_roof ) + ENDIF + + u_site_emw = readflag .and. ncio_var_exist(fsrfdata,'EM_WALL',readflag) + IF ( u_site_emw ) THEN + CALL ncio_read_serial (fsrfdata, 'EM_WALL', SITE_em_wall ) + ENDIF + + u_site_emgper = readflag .and. ncio_var_exist(fsrfdata,'EM_GPER',readflag) + IF ( u_site_emgper ) THEN + CALL ncio_read_serial (fsrfdata, 'EM_GPER', SITE_em_gper ) + ENDIF + + u_site_emgimp = readflag .and. ncio_var_exist(fsrfdata,'EM_GIMP',readflag) + IF ( u_site_emgimp ) THEN + CALL ncio_read_serial (fsrfdata, 'EM_GIMP', SITE_em_gimp ) + ENDIF + + ! (6) urban thermal + readflag = USE_SITE_urban_thermal + u_site_cvr = readflag .and. ncio_var_exist(fsrfdata,'CV_ROOF',readflag) + IF ( u_site_cvr ) THEN + CALL ncio_read_serial (fsrfdata, 'CV_ROOF', SITE_cv_roof ) + ENDIF + + u_site_cvw = readflag .and. ncio_var_exist(fsrfdata,'CV_WALL',readflag) + IF ( u_site_cvw ) THEN + CALL ncio_read_serial (fsrfdata, 'CV_WALL', SITE_cv_wall ) + ENDIF + + u_site_cvgimp = readflag .and. ncio_var_exist(fsrfdata,'CV_GIMP',readflag) + IF ( u_site_cvgimp ) THEN + CALL ncio_read_serial (fsrfdata, 'CV_GIMP', SITE_cv_gimp ) + ENDIF + + u_site_tkr = readflag .and. ncio_var_exist(fsrfdata,'TK_ROOF',readflag) + IF ( u_site_tkr ) THEN + CALL ncio_read_serial (fsrfdata, 'TK_ROOF', SITE_tk_roof ) + ENDIF + + u_site_tkw = readflag .and. ncio_var_exist(fsrfdata,'TK_WALL',readflag) + IF ( u_site_tkw ) THEN + CALL ncio_read_serial (fsrfdata, 'TK_WALL', SITE_tk_wall ) + ENDIF + + u_site_tkgimp = readflag .and. ncio_var_exist(fsrfdata,'TK_GIMP',readflag) + IF ( u_site_tkgimp ) THEN + CALL ncio_read_serial (fsrfdata, 'TK_GIMP', SITE_tk_gimp ) + ENDIF + + ! (6) urban human + readflag = USE_SITE_urban_human + u_site_pop= readflag .and. ncio_var_exist(fsrfdata,'resident_population_density',readflag) + IF ( u_site_pop) THEN + CALL ncio_read_serial (fsrfdata, 'resident_population_density', SITE_popden ) + ELSE + CALL gridpopu%define_by_name ('colm_500m') + dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' + write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 + + IF (mod(DEF_LC_YEAR,5) == 0) THEN + pop_i = 1 + ELSE + pop_i = 5 - (ceiling(DEF_LC_YEAR*1./5.)*5 - DEF_LC_YEAR) + 1 + ENDIF + + CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBSRF'//trim(c5year), & + 'POP_DEN', SITE_lon_location, SITE_lat_location, pop_i, & + SITE_popden) + ENDIF + + u_site_lucy= readflag .and. ncio_var_exist(fsrfdata,'LUCY_ID',readflag) + IF ( u_site_lucy) THEN + CALL ncio_read_serial (fsrfdata, 'LUCY_ID', SITE_lucyid ) + ELSE + CALL gridlucy%define_by_name ('colm_5km') + filename = trim(DEF_dir_rawdata) // '/urban/LUCY_regionid.nc' + + CALL read_point_var_2d_real8 (gridlucy, filename, 'LUCY_REGION_ID', & + SITE_lon_location, SITE_lat_location, SITE_lucyid) + ENDIF + + u_site_tbmax= readflag .and. ncio_var_exist(fsrfdata,'T_BUILDING_MAX',readflag) + IF ( u_site_tbmax) THEN + CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) + ENDIF + + u_site_tbmin= readflag .and. ncio_var_exist(fsrfdata,'T_BUILDING_MIN',readflag) + IF ( u_site_tbmin) THEN + CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) + ENDIF + +IF (DEF_URBAN_type_scheme == 1) THEN + filename = trim(DEF_dir_rawdata)//'urban/NCAR_urban_properties.nc' + + CALL ncio_read_bcast_serial (filename, "WTLUNIT_ROOF" , wtroof_ncar ) + CALL ncio_read_bcast_serial (filename, "HT_ROOF" , htroof_ncar ) + CALL ncio_read_bcast_serial (filename, "CANYON_HWR" , hwrbld_ncar ) + CALL ncio_read_bcast_serial (filename, "WTROAD_PERV" , fgper_ncar ) + CALL ncio_read_bcast_serial (filename, "EM_ROOF" , emroof_ncar ) + CALL ncio_read_bcast_serial (filename, "EM_WALL" , emwall_ncar ) + CALL ncio_read_bcast_serial (filename, "EM_IMPROAD" , emgimp_ncar ) + CALL ncio_read_bcast_serial (filename, "EM_PERROAD" , emgper_ncar ) + CALL ncio_read_bcast_serial (filename, "ALB_ROOF" , albroof_ncar) + CALL ncio_read_bcast_serial (filename, "ALB_WALL" , albwall_ncar) + CALL ncio_read_bcast_serial (filename, "ALB_IMPROAD" , albgimp_ncar) + CALL ncio_read_bcast_serial (filename, "ALB_PERROAD" , albgper_ncar) + CALL ncio_read_bcast_serial (filename, "TK_ROOF" , tkroof_ncar ) + CALL ncio_read_bcast_serial (filename, "TK_WALL" , tkwall_ncar ) + CALL ncio_read_bcast_serial (filename, "TK_IMPROAD" , tkgimp_ncar ) + CALL ncio_read_bcast_serial (filename, "CV_ROOF" , cvroof_ncar ) + CALL ncio_read_bcast_serial (filename, "CV_WALL" , cvwall_ncar ) + CALL ncio_read_bcast_serial (filename, "CV_IMPROAD" , cvgimp_ncar ) + CALL ncio_read_bcast_serial (filename, "THICK_ROOF" , thkroof_ncar) + CALL ncio_read_bcast_serial (filename, "THICK_WALL" , thkwall_ncar) + CALL ncio_read_bcast_serial (filename, "T_BUILDING_MIN", tbldmin_ncar) + CALL ncio_read_bcast_serial (filename, "T_BUILDING_MAX", tbldmax_ncar) + + rid = SITE_ncar_rid + utyp = SITE_urbtyp + + IF (.not. u_site_emr ) SITE_em_roof = emroof_ncar(utyp, rid) + IF (.not. u_site_emw ) SITE_em_wall = emwall_ncar(utyp, rid) + IF (.not. u_site_emgimp ) SITE_em_gimp = emgimp_ncar(utyp, rid) + IF (.not. u_site_emgper ) SITE_em_gper = emgper_ncar(utyp, rid) + + IF (.not. u_site_tbmax ) SITE_t_roommax = tbldmax_ncar (utyp, rid) + IF (.not. u_site_tbmin ) SITE_t_roommin = tbldmin_ncar (utyp, rid) + + IF (.not. u_site_thickr ) SITE_thickroof = thkroof_ncar(utyp, rid) + IF (.not. u_site_thickw ) SITE_thickwall = thkwall_ncar(utyp, rid) + + IF (.not. u_site_cvr ) THEN + allocate( SITE_cv_roof (nl_roof) ) + SITE_cv_roof(:) = cvroof_ncar(utyp, rid, :) + ENDIF + + IF (.not. u_site_cvw ) THEN + allocate( SITE_cv_wall (nl_wall) ) + SITE_cv_wall(:) = cvwall_ncar(utyp, rid, :) + ENDIF + + IF (.not. u_site_cvgimp) THEN + allocate( SITE_cv_gimp (nl_soil) ) + SITE_cv_gimp(:) = cvgimp_ncar(utyp, rid, :) + ENDIF + + IF (.not. u_site_tkr ) THEN + allocate( SITE_tk_roof (nl_roof) ) + SITE_tk_roof(:) = tkroof_ncar(utyp, rid, :) + ENDIF + + IF (.not. u_site_tkw ) THEN + allocate( SITE_tk_wall (nl_wall) ) + SITE_tk_wall(:) = tkwall_ncar(utyp, rid, :) + ENDIF + + IF (.not. u_site_tkgimp) THEN + allocate( SITE_tk_gimp (nl_soil) ) + SITE_tk_gimp(:) = tkgimp_ncar(utyp, rid, :) + ENDIF + + IF (.not. u_site_albr ) THEN + allocate( SITE_alb_roof (2, 2) ) + SITE_alb_roof(:,:) = albroof_ncar(utyp, rid, :, :) + ENDIF + + IF (.not. u_site_albw ) THEN + allocate( SITE_alb_wall (2, 2) ) + SITE_alb_wall(:,:) = albwall_ncar(utyp, rid, :, :) + ENDIF + + IF (.not. u_site_albgimp) THEN + allocate( SITE_alb_gimp (2, 2) ) + SITE_alb_gimp(:,:) = albgimp_ncar(utyp, rid, :, :) + ENDIF + + IF (.not. u_site_albgper) THEN + allocate( SITE_alb_gper (2, 2) ) + SITE_alb_gper(:,:) = albgper_ncar(utyp, rid, :, :) + ENDIF + + IF (.not. u_site_hlr ) SITE_hlr = hwrbld_ncar(utyp, rid) + IF (.not. u_site_fgper) SITE_fgimp = 1-fgper_ncar(utyp, rid) +ELSE + utyp = SITE_urbtyp + IF (.not. u_site_emr ) SITE_em_roof = emroof_lcz(utyp) + IF (.not. u_site_emw ) SITE_em_wall = emwall_lcz(utyp) + IF (.not. u_site_emgimp) SITE_em_gimp = emgimp_lcz(utyp) + IF (.not. u_site_emgper) SITE_em_gper = emgper_lcz(utyp) + + IF (.not. u_site_tbmax) SITE_t_roommax = tbldmax_lcz(utyp) + IF (.not. u_site_tbmin) SITE_t_roommin = tbldmin_lcz(utyp) + + IF (.not. u_site_thickr) SITE_thickroof = thkroof_lcz(utyp) + IF (.not. u_site_thickw) SITE_thickwall = thkwall_lcz(utyp) + + IF (.not. u_site_cvr ) THEN + allocate( SITE_cv_roof (nl_roof) ) + SITE_cv_roof(:) = cvroof_lcz(utyp) + ENDIF + + IF (.not. u_site_cvw ) THEN + allocate( SITE_cv_wall (nl_wall) ) + SITE_cv_wall(:) = cvwall_lcz(utyp) + ENDIF + + IF (.not. u_site_cvgimp) THEN + allocate( SITE_cv_gimp (nl_soil) ) + SITE_cv_gimp(:) = cvgimp_lcz(utyp) + ENDIF + + IF (.not. u_site_tkr ) THEN + allocate( SITE_tk_roof (nl_roof) ) + SITE_tk_roof(:) = tkroof_lcz(utyp) + ENDIF + + IF (.not. u_site_tkw ) THEN + allocate( SITE_tk_wall (nl_wall) ) + SITE_tk_wall(:) = tkwall_lcz(utyp) + ENDIF + + IF (.not. u_site_tkgimp) THEN + allocate( SITE_tk_gimp (nl_soil) ) + SITE_tk_gimp(:) = tkgimp_lcz(utyp) + ENDIF + + IF (.not. u_site_albr ) THEN + allocate( SITE_alb_roof (2, 2) ) + SITE_alb_roof(:,:) = albroof_lcz(utyp) + ENDIF + + IF (.not. u_site_albw ) THEN + allocate( SITE_alb_wall (2, 2) ) + SITE_alb_wall(:,:) = albwall_lcz(utyp) + ENDIF + + IF (.not. u_site_albgimp) THEN + allocate( SITE_alb_gimp (2, 2) ) + SITE_alb_gimp(:,:) = albgimp_lcz(utyp) + ENDIF + + IF (.not. u_site_albgper) THEN + allocate( SITE_alb_gper (2, 2) ) + SITE_alb_gper(:,:) = albgper_lcz(utyp) + ENDIF + + IF (.not. u_site_hlr ) SITE_hlr = hwrbld_lcz(utyp) + + IF (.not. u_site_fgper) SITE_fgimp = 1-fgper_lcz(utyp)/(1-SITE_froof) +ENDIF + +IF (DEF_USE_CANYON_HWR) THEN + SITE_hlr =SITE_hlr*(1-sqrt(SITE_froof))/sqrt(SITE_froof) +ENDIF + + ! (6) lake depth + readflag = u_site_lakedepth + u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag) + IF (u_site_lakedepth) THEN + CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth) + ELSE + CALL gridlake%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/lake_depth.nc' + CALL read_point_var_2d_real8 (gridlake, filename, 'lake_depth', & + SITE_lon_location, SITE_lat_location, lakedepth) + SITE_lakedepth = lakedepth * 0.1 + ENDIF + + write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',datasource(u_site_lakedepth),')' + + ! (7) soil brightness parameters + readflag = USE_SITE_soilreflectance + u_site_soil_bright = readflag & + .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) & + .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) & + .and. ncio_var_exist(fsrfdata,'soil_s_n_alb',readflag) & + .and. ncio_var_exist(fsrfdata,'soil_d_n_alb',readflag) + + IF (u_site_soil_bright) THEN + CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) + ELSE + SITE_soil_s_v_alb = spval + SITE_soil_d_v_alb = spval + SITE_soil_s_n_alb = spval + SITE_soil_d_n_alb = spval + + CALL gridbright%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/soil_brightness.nc' + CALL read_point_var_2d_int32 (gridbright, filename, 'soil_brightness', & + SITE_lon_location, SITE_lat_location, isc) + +#ifdef LULC_USGS + IF(SITE_landtype /= 16 .and. SITE_landtype /= 24)THEN ! NOT WATER BODIES(16)/GLACIER and ICESHEET(24) +#else + IF(SITE_landtype /= 17 .and. SITE_landtype /= 15)THEN ! NOT WATER BODIES(17)/GLACIER and ICE SHEET(15) +#endif + IF ((isc >= 1) .and. (isc <= 20)) THEN + SITE_soil_s_v_alb = soil_s_v_refl( isc ) + SITE_soil_d_v_alb = soil_d_v_refl( isc ) + SITE_soil_s_n_alb = soil_s_n_refl( isc ) + SITE_soil_d_n_alb = soil_d_n_refl( isc ) + ENDIF + ENDIF + ENDIF + + write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + write(*,'(A,F8.2,3A)') 'Soil brightness d_n : ', SITE_soil_d_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' + + ! (8) soil parameters + CALL gridsoil%define_by_name ('colm_500m') + + readflag = USE_SITE_soilparameters + u_site_vf_quartz_mineral = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag) + IF (u_site_vf_quartz_mineral) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) + ELSE + allocate (SITE_soil_vf_quartz_mineral (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_quartz_mineral_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_quartz_mineral(nsl)) + ENDDO + ENDIF + + u_site_vf_gravels = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_gravels',readflag) + IF (u_site_vf_gravels) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels) + ELSE + allocate (SITE_soil_vf_gravels (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_gravels_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_gravels_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_gravels(nsl)) + ENDDO + ENDIF + + u_site_vf_sand = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_sand',readflag) + IF (u_site_vf_sand) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand) + ELSE + allocate (SITE_soil_vf_sand (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_sand_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_sand_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_sand(nsl)) + ENDDO + ENDIF + + u_site_vf_clay = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_clay',readflag) + IF (u_site_vf_clay) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay) + ELSE + allocate (SITE_soil_vf_clay (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_clay_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_clay_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_clay(nsl)) + ENDDO + ENDIF + + u_site_vf_om = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_om',readflag) + IF (u_site_vf_om) THEN + CALL ncio_read_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om) + ELSE + allocate (SITE_soil_vf_om (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/vf_om_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_om_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_vf_om(nsl)) + ENDDO + ENDIF + + u_site_wf_gravels = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_gravels',readflag) + IF (u_site_wf_gravels) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels) + ELSE + allocate (SITE_soil_wf_gravels (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_gravels_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_gravels_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_gravels(nsl)) + ENDDO + ENDIF + + u_site_wf_sand = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_sand',readflag) + IF (u_site_wf_sand) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand) + ELSE + allocate (SITE_soil_wf_sand (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_sand_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_sand_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_sand(nsl)) + ENDDO + ENDIF + + u_site_wf_clay = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_clay',readflag) + IF (u_site_wf_clay) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay) + ELSE + allocate (SITE_soil_wf_clay (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_clay_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_clay_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_clay(nsl)) + ENDDO + ENDIF + + u_site_wf_om = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_om',readflag) + IF (u_site_wf_om) THEN + CALL ncio_read_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om) + ELSE + allocate (SITE_soil_wf_om (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/wf_om_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_om_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_wf_om(nsl)) + ENDDO + ENDIF + + u_site_OM_density = readflag .and. ncio_var_exist(fsrfdata,'soil_OM_density',readflag) + IF (u_site_OM_density) THEN + CALL ncio_read_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density) + ELSE + allocate (SITE_soil_OM_density (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/OM_density_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'OM_density_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_OM_density(nsl)) + ENDDO + ENDIF + + u_site_BD_all = readflag .and. ncio_var_exist(fsrfdata,'soil_BD_all',readflag) + IF (u_site_BD_all) THEN + CALL ncio_read_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all) + ELSE + allocate (SITE_soil_BD_all (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/BD_all_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'BD_all_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_BD_all(nsl)) + ENDDO + ENDIF + + u_site_theta_s = readflag .and. ncio_var_exist(fsrfdata,'soil_theta_s',readflag) + IF (u_site_theta_s) THEN + CALL ncio_read_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s) + ELSE + allocate (SITE_soil_theta_s (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/theta_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'theta_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_theta_s(nsl)) + ENDDO + ENDIF + + u_site_k_s = readflag .and. ncio_var_exist(fsrfdata,'soil_k_s',readflag) + IF (u_site_k_s) THEN + CALL ncio_read_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s) + ELSE + allocate (SITE_soil_k_s (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/k_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'k_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_k_s(nsl)) + ENDDO + ENDIF + + u_site_csol = readflag .and. ncio_var_exist(fsrfdata,'soil_csol',readflag) + IF (u_site_csol) THEN + CALL ncio_read_serial (fsrfdata, 'soil_csol', SITE_soil_csol) + ELSE + allocate (SITE_soil_csol (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/csol.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'csol_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_csol(nsl)) + ENDDO + ENDIF + + u_site_tksatu = readflag .and. ncio_var_exist(fsrfdata,'soil_tksatu',readflag) + IF (u_site_tksatu) THEN + CALL ncio_read_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu) + ELSE + allocate (SITE_soil_tksatu (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/tksatu.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatu_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_tksatu(nsl)) + ENDDO + ENDIF + + u_site_tksatf = readflag .and. ncio_var_exist(fsrfdata,'soil_tksatf',readflag) + IF (u_site_tksatf) THEN + CALL ncio_read_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf) + ELSE + allocate (SITE_soil_tksatf (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/tksatf.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatf_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_tksatf(nsl)) + ENDDO + ENDIF + + u_site_tkdry = readflag .and. ncio_var_exist(fsrfdata,'soil_tkdry',readflag) + IF (u_site_tkdry) THEN + CALL ncio_read_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry) + ELSE + allocate (SITE_soil_tkdry (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/tkdry.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'tkdry_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_tkdry(nsl)) + ENDDO + ENDIF + + u_site_k_solids = readflag .and. ncio_var_exist(fsrfdata,'soil_k_solids',readflag) + IF (u_site_k_solids) THEN + CALL ncio_read_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids) + ELSE + allocate (SITE_soil_k_solids (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/k_solids.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'k_solids_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_k_solids(nsl)) + ENDDO + ENDIF + + u_site_psi_s = readflag .and. ncio_var_exist(fsrfdata,'soil_psi_s',readflag) + IF (u_site_psi_s) THEN + CALL ncio_read_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s) + ELSE + allocate (SITE_soil_psi_s (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/psi_s.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'psi_s_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_psi_s(nsl)) + ENDDO + ENDIF + + u_site_lambda = readflag .and. ncio_var_exist(fsrfdata,'soil_lambda',readflag) + IF (u_site_lambda) THEN + CALL ncio_read_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda) + ELSE + allocate (SITE_soil_lambda (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/lambda.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'lambda_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_lambda(nsl)) + ENDDO + ENDIF + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + u_site_theta_r = readflag .and. ncio_var_exist(fsrfdata,'soil_theta_r',readflag) + IF (u_site_theta_r) THEN + CALL ncio_read_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r) + ELSE + allocate (SITE_soil_theta_r (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_theta_r.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_theta_r_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_theta_r(nsl)) + ENDDO + ENDIF + + u_site_alpha_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_alpha_vgm',readflag) + IF (u_site_alpha_vgm) THEN + CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm) + ELSE + allocate (SITE_soil_alpha_vgm (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_alpha.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_alpha_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_alpha_vgm(nsl)) + ENDDO + ENDIF + + u_site_L_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_L_vgm',readflag) + IF (u_site_L_vgm) THEN + CALL ncio_read_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm) + ELSE + allocate (SITE_soil_L_vgm (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_L.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_L_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_L_vgm(nsl)) + ENDDO + ENDIF + + u_site_n_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_n_vgm',readflag) + IF (u_site_n_vgm) THEN + CALL ncio_read_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm) + ELSE + allocate (SITE_soil_n_vgm (8)) + DO nsl = 1, 8 + write(c,'(i1)') nsl + filename = trim(DEF_dir_rawdata)//'/soil/VGM_n.nc' + CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_n_l'//trim(c), & + SITE_lon_location, SITE_lat_location, SITE_soil_n_vgm(nsl)) + ENDDO + ENDIF +#endif + + u_site_BA_alpha = .false. + u_site_BA_beta = .false. + allocate (SITE_soil_BA_alpha (8)) + allocate (SITE_soil_BA_beta (8)) + DO nsl = 1, 8 + IF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.4) THEN + SITE_soil_BA_alpha(nsl) = 0.38 + SITE_soil_BA_beta (nsl) = 35.0 + ELSEIF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.25) THEN + SITE_soil_BA_alpha(nsl) = 0.24 + SITE_soil_BA_beta (nsl) = 26.0 + ELSE + SITE_soil_BA_alpha(nsl) = 0.20 + SITE_soil_BA_beta (nsl) = 10.0 + ENDIF + ENDDO + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + u_site_soil_texture = readflag .and. ncio_var_exist(fsrfdata,'soil_texture',readflag) + IF (u_site_soil_texture) THEN + CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture) + ELSE + filename = trim(DEF_dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc' + CALL read_point_var_2d_int32 (gridsoil, filename, 'soiltexture', & + SITE_lon_location, SITE_lat_location, SITE_soil_texture) + ENDIF + ENDIF + + write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_clay : ', SITE_soil_vf_clay (1:8), ' (from ',trim(datasource(u_site_vf_clay )),')' + write(*,'(A,8ES10.2,3A)') 'soil_vf_om : ', SITE_soil_vf_om (1:8), ' (from ',trim(datasource(u_site_vf_om )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_gravels : ', SITE_soil_wf_gravels (1:8), ' (from ',trim(datasource(u_site_wf_gravels )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_sand : ', SITE_soil_wf_sand (1:8), ' (from ',trim(datasource(u_site_wf_sand )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_clay : ', SITE_soil_wf_clay (1:8), ' (from ',trim(datasource(u_site_wf_clay )),')' + write(*,'(A,8ES10.2,3A)') 'soil_wf_om : ', SITE_soil_wf_om (1:8), ' (from ',trim(datasource(u_site_wf_om )),')' + write(*,'(A,8ES10.2,3A)') 'soil_OM_density : ', SITE_soil_OM_density (1:8), ' (from ',trim(datasource(u_site_OM_density )),')' + write(*,'(A,8ES10.2,3A)') 'soil_BD_all : ', SITE_soil_BD_all (1:8), ' (from ',trim(datasource(u_site_BD_all )),')' + write(*,'(A,8ES10.2,3A)') 'soil_theta_s : ', SITE_soil_theta_s (1:8), ' (from ',trim(datasource(u_site_theta_s )),')' + write(*,'(A,8ES10.2,3A)') 'soil_k_s : ', SITE_soil_k_s (1:8), ' (from ',trim(datasource(u_site_k_s )),')' + write(*,'(A,8ES10.2,3A)') 'soil_csol : ', SITE_soil_csol (1:8), ' (from ',trim(datasource(u_site_csol )),')' + write(*,'(A,8ES10.2,3A)') 'soil_tksatu : ', SITE_soil_tksatu (1:8), ' (from ',trim(datasource(u_site_tksatu )),')' + write(*,'(A,8ES10.2,3A)') 'soil_tksatf : ', SITE_soil_tksatf (1:8), ' (from ',trim(datasource(u_site_tksatf )),')' + write(*,'(A,8ES10.2,3A)') 'soil_tkdry : ', SITE_soil_tkdry (1:8), ' (from ',trim(datasource(u_site_tkdry )),')' + write(*,'(A,8ES10.2,3A)') 'soil_k_solids : ', SITE_soil_k_solids (1:8), ' (from ',trim(datasource(u_site_k_solids )),')' + write(*,'(A,8ES10.2,3A)') 'soil_psi_s : ', SITE_soil_psi_s (1:8), ' (from ',trim(datasource(u_site_psi_s )),')' + write(*,'(A,8ES10.2,3A)') 'soil_lambda : ', SITE_soil_lambda (1:8), ' (from ',trim(datasource(u_site_lambda )),')' +#ifdef vanGenuchten_Mualem_SOIL_MODEL + write(*,'(A,8ES10.2,3A)') 'soil_theta_r : ', SITE_soil_theta_r (1:8), ' (from ',trim(datasource(u_site_theta_r )),')' + write(*,'(A,8ES10.2,3A)') 'soil_alpha_vgm : ', SITE_soil_alpha_vgm (1:8), ' (from ',trim(datasource(u_site_alpha_vgm )),')' + write(*,'(A,8ES10.2,3A)') 'soil_L_vgm : ', SITE_soil_L_vgm (1:8), ' (from ',trim(datasource(u_site_L_vgm )),')' + write(*,'(A,8ES10.2,3A)') 'soil_n_vgm : ', SITE_soil_n_vgm (1:8), ' (from ',trim(datasource(u_site_n_vgm )),')' +#endif + write(*,'(A,8ES10.2,3A)') 'soil_BA_alpha : ', SITE_soil_BA_alpha (1:8), ' (from ',trim(datasource(u_site_BA_alpha )),')' + write(*,'(A,8ES10.2,3A)') 'soil_BA_beta : ', SITE_soil_BA_beta (1:8), ' (from ',trim(datasource(u_site_BA_beta )),')' + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + write(*,'(A,I3,3A)') 'soil texture : ', SITE_soil_texture, ' (from ',trim(datasource(u_site_soil_texture)),')' + ENDIF + + ! (9) depth to bedrock + IF (DEF_USE_BEDROCK) THEN + readflag = USE_SITE_dbedrock + u_site_dbedrock = readflag .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag) + IF (u_site_dbedrock) THEN + CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + ELSE + CALL gridrock%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/bedrock.nc' + CALL read_point_var_2d_real8 (gridrock, filename, 'dbedrock', & + SITE_lon_location, SITE_lat_location, SITE_dbedrock) + ENDIF + + write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',datasource(u_site_dbedrock),')' + ENDIF + + ! (10) topography + readflag = USE_SITE_topography + + u_site_elevation = readflag .and. ncio_var_exist (fsrfdata, 'elevation',readflag) + IF (u_site_elevation) THEN + CALL ncio_read_serial (fsrfdata, 'elevation', SITE_elevation) + ELSE + CALL gridtopo%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/elevation.nc' + CALL read_point_var_2d_real8 (gridtopo, filename, 'elevation', & + SITE_lon_location, SITE_lat_location, SITE_elevation) + ENDIF + + u_site_elvstd = readflag & + .and. ncio_var_exist (fsrfdata, 'elvstd',readflag) + IF (u_site_elvstd) THEN + CALL ncio_read_serial (fsrfdata, 'elvstd', SITE_elvstd) + ELSE + CALL gridtopo%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/topography.nc' + CALL read_point_var_2d_real8 (gridtopo, filename, 'elvstd', & + SITE_lon_location, SITE_lat_location, SITE_elvstd) + ENDIF + + u_site_sloperatio = readflag & + .and. ncio_var_exist (fsrfdata, 'sloperatio',readflag) + IF (u_site_sloperatio) THEN + CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio) + ELSE + CALL gridtopo%define_by_name ('colm_500m') + filename = trim(DEF_dir_rawdata)//'/topography.nc' + CALL read_point_var_2d_real8 (gridtopo, filename, 'slope', & + SITE_lon_location, SITE_lat_location, SITE_sloperatio) + ENDIF + + IF (DEF_USE_Forcing_Downscaling) THEN + + filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" + IF (ncio_var_exist(filename,'lat') .and. ncio_var_exist(filename,'lon')) THEN + CALL grid_topo_factor%define_from_file (filename, "lat", "lon") + ENDIF + + u_site_svf = readflag .and. ncio_var_exist (fsrfdata, 'SITE_svf',readflag) + IF (u_site_svf) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/sky_view_factor.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'svf', & + SITE_lon_location, SITE_lat_location, SITE_svf) + ENDIF + + u_site_cur = readflag .and. ncio_var_exist (fsrfdata, 'SITE_cur',readflag) + IF (u_site_cur) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/curvature.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'curvature', & + SITE_lon_location, SITE_lat_location, SITE_cur) + ENDIF + + u_site_slp_type = readflag & + .and. ncio_var_exist (fsrfdata, 'SITE_slp_type' ,readflag) & + .and. ncio_var_exist (fsrfdata, 'SITE_asp_type' ,readflag) & + .and. ncio_var_exist (fsrfdata, 'SITE_area_type',readflag) + u_site_asp_type = u_site_slp_type + u_site_area_type = u_site_slp_type + + IF (u_site_slp_type) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type ) + CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type ) + CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type ) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'slope', & + SITE_lon_location, SITE_lat_location, slp) + + filename = trim(DEF_DS_HiresTopographyDataDir)//"/aspect.nc" + CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'aspect', & + SITE_lon_location, SITE_lat_location, asp) + + allocate (SITE_slp_type (num_slope_type)); SITE_slp_type (:) = 0. + allocate (SITE_asp_type (num_slope_type)); SITE_asp_type (:) = 0. + allocate (SITE_area_type (num_slope_type)); SITE_area_type(:) = 0. + + IF ((asp.ge.0 .and. asp.le.90*pi/180) .or. (asp.ge.270*pi/180 .and. asp.le.360*pi/180)) THEN + IF ((slp.ge.15*pi/180)) THEN ! north abrupt slope + typ = 1 + ELSE ! north gentle slope + typ = 2 + ENDIF + ELSE + IF ((slp.ge.15*pi/180)) THEN ! south abrupt slope + typ = 3 + ELSE ! south gentle slope + typ = 4 + ENDIF + ENDIF + + SITE_slp_type (typ) = slp + SITE_asp_type (typ) = asp + SITE_area_type(typ) = 1. + + ENDIF + + u_site_sf_lut = readflag .and. ncio_var_exist (fsrfdata, 'SITE_sf_lut',readflag) + IF (u_site_sf_lut) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut) + ELSE + filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_front.nc" + CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_front', & + SITE_lon_location, SITE_lat_location, num_azimuth, tea_f) + + filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_back.nc" + CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_back', & + SITE_lon_location, SITE_lat_location, num_azimuth, tea_b) + + allocate (SITE_sf_lut (num_azimuth, num_zenith)) + + DO a = 1, num_azimuth + + tea_f(a) = asin(max(min(tea_f(a),1.),-1.)) + tea_b(a) = asin(max(min(tea_b(a),1.),-1.)) + + IF (tea_f(a) <= tea_b(a)) tea_f(a) = tea_b(a) + 0.001 + + DO z = 1, num_zenith + zenith_angle = pi/(2*num_zenith)*(z-1) + + IF (pi*0.5 - zenith_angle < tea_b(a)) THEN + SITE_sf_lut(a,z) = 0 + ELSE IF (pi*0.5 - zenith_angle > tea_f(a)) THEN + SITE_sf_lut(a,z) = 1 + ELSE + SITE_sf_lut(a,z) = (0.5*pi - zenith_angle - tea_b(a))/(tea_f(a) - tea_b(a)) + ENDIF + + ENDDO + ENDDO + + ENDIF + ENDIF + + write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation, ' (from ',datasource(u_site_elevation),')' + write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd, ' (from ',datasource(u_site_elvstd),')' + write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio,' (from ',datasource(u_site_sloperatio),')' + + IF (DEF_USE_Forcing_Downscaling) THEN + write(*,'(A,F8.2,3A)') 'Sky view factor : ', SITE_svf, ' (from ',datasource(u_site_svf),')' + write(*,'(A,F8.2,3A)') 'Curvature : ', SITE_cur, ' (from ',datasource(u_site_cur),')' + write(c,'(I0)') num_slope_type + write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type : ', SITE_slp_type, ' (from ',datasource(u_site_slp_type),')' + write(*,'(A,'//trim(c)//'F8.2,3A)') 'Aspect type : ', SITE_asp_type, ' (from ',datasource(u_site_slp_type),')' + write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type area : ', SITE_area_type, ' (from ',datasource(u_site_slp_type),')' + write(c,'(I0)') num_azimuth*num_zenith + write(*,'(A,A,I3,A,I3,A,'//trim(c)//'F8.2,3A)') 'Shadow lookup table : ', & + '(', num_azimuth, ' in azimuth,', num_zenith, ' in zenith)', & + SITE_sf_lut , ' (from ',datasource(u_site_sf_lut),')' + ENDIF + + ELSE + CALL ncio_read_serial (fsrfdata, 'LAI_year' , SITE_LAI_year ) + CALL ncio_read_serial (fsrfdata, 'TREE_LAI' , SITE_LAI_monthly) + CALL ncio_read_serial (fsrfdata, 'TREE_SAI' , SITE_SAI_monthly) + + CALL ncio_read_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp ) + CALL ncio_read_serial (fsrfdata, 'LUCY_id' , SITE_lucyid ) + CALL ncio_read_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb ) + CALL ncio_read_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb ) + CALL ncio_read_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb ) + CALL ncio_read_serial (fsrfdata, 'WT_ROOF' , SITE_froof ) + CALL ncio_read_serial (fsrfdata, 'HT_ROOF' , SITE_hroof ) + CALL ncio_read_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper ) + CALL ncio_read_serial (fsrfdata, 'BUILDING_HLR' , SITE_hlr ) + CALL ncio_read_serial (fsrfdata, 'POP_DEN' , SITE_popden ) + + CALL ncio_read_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof ) + CALL ncio_read_serial (fsrfdata, 'EM_WALL' , SITE_em_wall ) + CALL ncio_read_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp ) + CALL ncio_read_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper ) + CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) + CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) + CALL ncio_read_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof ) + CALL ncio_read_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall ) + + CALL ncio_read_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof ) + CALL ncio_read_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall ) + CALL ncio_read_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp ) + CALL ncio_read_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper ) + + CALL ncio_read_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof ) + CALL ncio_read_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall ) + CALL ncio_read_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp ) + CALL ncio_read_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof ) + CALL ncio_read_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall ) + CALL ncio_read_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp ) + + CALL ncio_read_serial (fsrfdata, 'lakedepth' , SITE_lakedepth ) + + CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb' , SITE_soil_s_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb' , SITE_soil_d_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb' , SITE_soil_s_n_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb' , SITE_soil_d_n_alb) + + CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) + CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels' , SITE_soil_vf_gravels ) + CALL ncio_read_serial (fsrfdata, 'soil_vf_sand' , SITE_soil_vf_sand ) + CALL ncio_read_serial (fsrfdata, 'soil_vf_clay' , SITE_soil_vf_clay ) + CALL ncio_read_serial (fsrfdata, 'soil_vf_om' , SITE_soil_vf_om ) + CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels' , SITE_soil_wf_gravels ) + CALL ncio_read_serial (fsrfdata, 'soil_wf_sand' , SITE_soil_wf_sand ) + CALL ncio_read_serial (fsrfdata, 'soil_wf_clay' , SITE_soil_wf_clay ) + CALL ncio_read_serial (fsrfdata, 'soil_wf_om' , SITE_soil_wf_om ) + + CALL ncio_read_serial (fsrfdata, 'soil_OM_density' , SITE_soil_OM_density) + CALL ncio_read_serial (fsrfdata, 'soil_BD_all' , SITE_soil_BD_all ) + CALL ncio_read_serial (fsrfdata, 'soil_theta_s' , SITE_soil_theta_s ) + CALL ncio_read_serial (fsrfdata, 'soil_k_s' , SITE_soil_k_s ) + CALL ncio_read_serial (fsrfdata, 'soil_csol' , SITE_soil_csol ) + CALL ncio_read_serial (fsrfdata, 'soil_tksatu' , SITE_soil_tksatu ) + CALL ncio_read_serial (fsrfdata, 'soil_tksatf' , SITE_soil_tksatf ) + CALL ncio_read_serial (fsrfdata, 'soil_tkdry' , SITE_soil_tkdry ) + CALL ncio_read_serial (fsrfdata, 'soil_k_solids' , SITE_soil_k_solids ) + CALL ncio_read_serial (fsrfdata, 'soil_lambda' , SITE_soil_lambda ) + CALL ncio_read_serial (fsrfdata, 'soil_psi_s' , SITE_soil_psi_s ) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_read_serial (fsrfdata, 'soil_theta_r' , SITE_soil_theta_r ) + CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm) + CALL ncio_read_serial (fsrfdata, 'soil_L_vgm' , SITE_soil_L_vgm ) + CALL ncio_read_serial (fsrfdata, 'soil_n_vgm' , SITE_soil_n_vgm ) +#endif + + CALL ncio_read_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha) + CALL ncio_read_serial (fsrfdata, 'soil_BA_beta' , SITE_soil_BA_beta ) + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture) + ENDIF + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + ENDIF + + CALL ncio_read_serial (fsrfdata, 'elevation' , SITE_elevation ) + CALL ncio_read_serial (fsrfdata, 'elvstd' , SITE_elvstd ) + CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio) + + ! used for downscaling + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf ) + CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur ) + CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut' , SITE_sf_lut ) + CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type ) + CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type ) + CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type) + ENDIF + ENDIF + + IF (.not. mksrfdata) THEN + + landpatch%nset = numpatch + + allocate (landpatch%settyp (numpatch)); landpatch%settyp = SITE_landtype + + landpatch%nblkgrp = 1 + allocate (landpatch%xblkgrp(1)); landpatch%xblkgrp(1) = 1 + allocate (landpatch%yblkgrp(1)); landpatch%yblkgrp(1) = 1 + + allocate (landpatch%vecgs%vlen(1,1)); landpatch%vecgs%vlen(1,1) = numpatch + allocate (landpatch%vecgs%vstt(1,1)); landpatch%vecgs%vstt(1,1) = 1 + allocate (landpatch%vecgs%vend(1,1)); landpatch%vecgs%vend(1,1) = numpatch + + landurban%nset = numurban + + allocate (landurban%settyp (numurban)); landurban%settyp = SITE_urbtyp + + landurban%nblkgrp = 1 + allocate (landurban%xblkgrp(1)); landurban%xblkgrp(1) = 1 + allocate (landurban%yblkgrp(1)); landurban%yblkgrp(1) = 1 + + allocate (landurban%vecgs%vlen(1,1)); landurban%vecgs%vlen(1,1) = numurban + allocate (landurban%vecgs%vstt(1,1)); landurban%vecgs%vstt(1,1) = 1 + allocate (landurban%vecgs%vend(1,1)); landurban%vecgs%vend(1,1) = numurban + + allocate (patch2urban (numurban)); patch2urban(1) = 1 + allocate (urban2patch (numurban)); urban2patch(1) = 1 + + numelm = 1 + allocate (landelm%settyp (1)); landelm%settyp (1) = 0 + allocate (elm_patch%substt (1)); elm_patch%substt(1) = 1 + allocate (elm_patch%subend (1)); elm_patch%subend(1) = numpatch + allocate (elm_patch%subfrc (numpatch)); elm_patch%subfrc = 1./numpatch + + ENDIF + + END SUBROUTINE read_urban_surface_data_single + + +!----------------------------------------------------------------------- + SUBROUTINE write_surface_data_single (numpatch, numpft) + + USE MOD_NetCDFSerial + USE MOD_Namelist + USE MOD_Const_LC + IMPLICIT NONE + + integer, intent(in) :: numpatch + integer, intent(in), optional :: numpft + + ! Local Variables + character(len=256) :: fsrfdata + integer :: ipft, iyear, itime + character(len=18) :: source + + fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc' + + CALL ncio_create_file (fsrfdata) + + CALL ncio_define_dimension (fsrfdata, 'patch', numpatch) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + CALL ncio_define_dimension (fsrfdata, 'pft', numpft) + ENDIF +#endif + + CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year)) + IF (DEF_LAI_MONTHLY) THEN + CALL ncio_define_dimension (fsrfdata, 'month', 12) + ELSE + CALL ncio_define_dimension (fsrfdata, 'J8day', 46) + ENDIF + + CALL ncio_define_dimension (fsrfdata, 'soil', 8) + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_define_dimension (fsrfdata, 'slope_type', num_slope_type) + CALL ncio_define_dimension (fsrfdata, 'azi', num_azimuth) + CALL ncio_define_dimension (fsrfdata, 'zen', num_zenith) + ENDIF + + + CALL ncio_write_serial (fsrfdata, 'latitude', SITE_lat_location) + CALL ncio_put_attr (fsrfdata, 'latitude', 'units', 'degrees_north') + + CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location) + CALL ncio_put_attr (fsrfdata, 'longitude','units', 'degrees_east') + +#ifdef LULC_USGS + CALL ncio_write_serial (fsrfdata, 'USGS_classification', SITE_landtype) + CALL ncio_put_attr (fsrfdata, 'USGS_classification', 'source', trim(datasource(u_site_landtype))) + CALL ncio_put_attr (fsrfdata, 'USGS_classification', 'long_name', 'GLCC USGS Land Use/Land Cover') +#else + CALL ncio_write_serial (fsrfdata, 'IGBP_classification', SITE_landtype) + CALL ncio_put_attr (fsrfdata, 'IGBP_classification', 'source', trim(datasource(u_site_landtype))) + CALL ncio_put_attr (fsrfdata, 'IGBP_classification', 'long_name', 'MODIS IGBP Land Use/Land Cover') +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + CALL ncio_write_serial (fsrfdata, 'pfttyp', SITE_pfttyp, 'pft') + CALL ncio_put_attr (fsrfdata, 'pfttyp', 'source', trim(datasource(u_site_pfts))) + CALL ncio_put_attr (fsrfdata, 'pfttyp', 'long_name', 'plant functional type') + + CALL ncio_write_serial (fsrfdata, 'pctpfts', SITE_pctpfts, 'pft') + CALL ncio_put_attr (fsrfdata, 'pctpfts', 'source', trim(datasource(u_site_pfts))) + CALL ncio_put_attr (fsrfdata, 'pctpfts', 'long_name', 'fraction of plant functional type') + ENDIF +#endif +#if (defined CROP) + IF (SITE_landtype == CROPLAND) THEN + CALL ncio_write_serial (fsrfdata, 'croptyp', SITE_croptyp, 'patch') + CALL ncio_put_attr (fsrfdata, 'croptyp', 'source', trim(datasource(u_site_crop))) + CALL ncio_put_attr (fsrfdata, 'croptyp', 'long_name', 'crop type') + + CALL ncio_write_serial (fsrfdata, 'pctcrop', SITE_pctcrop, 'patch') + CALL ncio_put_attr (fsrfdata, 'pctcrop', 'source', trim(datasource(u_site_crop))) + CALL ncio_put_attr (fsrfdata, 'pctcrop', 'long_name', 'fraction of crop type') + ENDIF +#endif + + CALL ncio_write_serial (fsrfdata, 'canopy_height', SITE_htop) + CALL ncio_put_attr (fsrfdata, 'canopy_height', 'source', trim(datasource(u_site_htop))) + CALL ncio_put_attr (fsrfdata, 'canopy_height', 'long_name', 'canopy height') + CALL ncio_put_attr (fsrfdata, 'canopy_height', 'units', 'm') +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + CALL ncio_write_serial (fsrfdata, 'canopy_height_pfts', SITE_htop_pfts, 'pft') + CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'source', trim(datasource(u_site_htop))) + CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'long_name', 'canopy height') + CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'units', 'm') + ENDIF +#endif + + source = trim(datasource(u_site_lai)) + CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year') +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft > 0) THEN + CALL ncio_write_serial (fsrfdata, 'LAI_pfts_monthly', SITE_LAI_pfts_monthly, 'pft', 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'LAI_pfts_monthly', 'source', source) + CALL ncio_put_attr (fsrfdata, 'LAI_pfts_monthly', 'long_name', 'monthly leaf area index associated with PFT') + + CALL ncio_write_serial (fsrfdata, 'SAI_pfts_monthly', SITE_SAI_pfts_monthly, 'pft', 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'SAI_pfts_monthly', 'source', source) + CALL ncio_put_attr (fsrfdata, 'SAI_pfts_monthly', 'long_name', 'monthly stem area index associated with PFT') + ELSE + CALL ncio_write_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly, 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'source', source) + CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'long_name', 'monthly leaf area index') + + CALL ncio_write_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly, 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'source', source) + CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'long_name', 'monthly stem area index') + ENDIF +#else + IF (DEF_LAI_MONTHLY) THEN + CALL ncio_write_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly, 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'source', source) + CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'long_name', 'monthly leaf area index') + + CALL ncio_write_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly, 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'source', source) + CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'long_name', 'monthly stem area index') + ELSE + CALL ncio_write_serial (fsrfdata, 'LAI_8day', SITE_LAI_8day, 'J8day', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'LAI_8day', 'source', source) + CALL ncio_put_attr (fsrfdata, 'LAI_8day', 'long_name', '8-day leaf area index') + ENDIF +#endif + + CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth) + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', trim(datasource(u_site_lakedepth))) + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'long_name', 'lake depth') + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'units', 'm') + + CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) + CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'long_name', 'albedo of visible of the saturated soil') + + CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) + CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'long_name', 'albedo of visible of the dry soil') + + CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) + CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'long_name', 'albedo of near infrared of the saturated soil') + + CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) + CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'long_name', 'albedo of near infrared of the dry soil') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', trim(datasource(u_site_vf_quartz_mineral))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'long_name', 'volumetric fraction of quartz within mineral soil') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'source', trim(datasource(u_site_vf_gravels))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'long_name', 'volumetric fraction of gravels') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'source', trim(datasource(u_site_vf_sand))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'long_name', 'volumetric fraction of sand') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'source', trim(datasource(u_site_vf_clay))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'long_name', 'volumetric fraction of clay') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'source', trim(datasource(u_site_vf_om))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'long_name', 'volumetric fraction of organic matter') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'source', trim(datasource(u_site_wf_gravels))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'long_name', 'gravimetric fraction of gravels') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'source', trim(datasource(u_site_wf_sand))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'long_name', 'gravimetric fraction of sand') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'source', trim(datasource(u_site_wf_clay))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'long_name', 'gravimetric fraction of clay') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'source', trim(datasource(u_site_wf_om))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'long_name', 'gravimetric fraction of om') + + CALL ncio_write_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'source', trim(datasource(u_site_OM_density))) + CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'long_name', 'OM density') + CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'units', 'kg/m3') + + CALL ncio_write_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'source', trim(datasource(u_site_BD_all))) + CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'long_name', 'bulk density of soil (GRAVELS + OM + mineral soils)') + CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'units', 'kg/m3') + + CALL ncio_write_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'source', trim(datasource(u_site_theta_s))) + CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'long_name', 'saturated water content') + CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'units', 'cm3/cm3') + + CALL ncio_write_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'source', trim(datasource(u_site_k_s))) + CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'long_name', 'saturated hydraulic conductivity') + CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'units', 'cm/day') + + CALL ncio_write_serial (fsrfdata, 'soil_csol', SITE_soil_csol(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_csol', 'source', trim(datasource(u_site_csol))) + CALL ncio_put_attr (fsrfdata, 'soil_csol', 'long_name', 'heat capacity of soil solids') + CALL ncio_put_attr (fsrfdata, 'soil_csol', 'units', 'J/(m3 K)') + + CALL ncio_write_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'source', trim(datasource(u_site_tksatu))) + CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'long_name', 'thermal conductivity of saturated unfrozen soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'units', 'W/m-K') + + CALL ncio_write_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'source', trim(datasource(u_site_tksatf))) + CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'long_name', 'thermal conductivity of saturated frozen soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'units', 'W/m-K') + + CALL ncio_write_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'source', trim(datasource(u_site_tkdry))) + CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'long_name', 'thermal conductivity for dry soil') + CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'units', 'W/(m-K)') + + CALL ncio_write_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'source', trim(datasource(u_site_k_solids))) + CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'long_name', 'thermal conductivity of minerals soil') + CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'units', 'W/m-K') + + CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', trim(datasource(u_site_lambda))) + CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'long_name', 'pore size distribution index (dimensionless)') + + CALL ncio_write_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', trim(datasource(u_site_psi_s))) + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'long_name', 'matric potential at saturation') + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'units', 'cm') + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_write_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'source', trim(datasource(u_site_theta_r))) + CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'long_name', 'residual water content') + CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'units', 'cm3/cm3') + + CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', trim(datasource(u_site_alpha_vgm))) + CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'long_name', 'a parameter corresponding approximately to the inverse of the air-entry value') + + CALL ncio_write_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'source', trim(datasource(u_site_L_vgm))) + CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'long_name', 'pore-connectivity parameter [dimensionless]') + + CALL ncio_write_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'source', trim(datasource(u_site_n_vgm))) + CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'long_name', 'a shape parameter [dimensionless]') + +#endif + + CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', trim(datasource(u_site_BA_alpha))) + CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'long_name', 'alpha in Balland and Arp(2005) thermal conductivity scheme') + + CALL ncio_write_serial (fsrfdata, 'soil_BA_beta', SITE_soil_BA_beta(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'source', trim(datasource(u_site_BA_beta))) + CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'long_name', 'beta in Balland and Arp(2005) thermal conductivity scheme') + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + CALL ncio_write_serial (fsrfdata, 'soil_texture ', SITE_soil_texture) + CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'source', trim(datasource(u_site_soil_texture))) + CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'long_name', 'USDA soil texture') + ENDIF + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', trim(datasource(u_site_dbedrock))) + ENDIF + + CALL ncio_write_serial (fsrfdata, 'elevation', SITE_elevation) + CALL ncio_put_attr (fsrfdata, 'elevation', 'source', trim(datasource(u_site_elevation))) + + CALL ncio_write_serial (fsrfdata, 'elvstd', SITE_elvstd) + CALL ncio_put_attr (fsrfdata, 'elvstd', 'source', trim(datasource(u_site_elvstd))) + CALL ncio_put_attr (fsrfdata, 'elvstd', 'long_name', 'standard deviation of elevation') + + CALL ncio_write_serial (fsrfdata, 'sloperatio', SITE_sloperatio) + CALL ncio_put_attr (fsrfdata, 'sloperatio', 'source', trim(datasource(u_site_sloperatio))) + CALL ncio_put_attr (fsrfdata, 'sloperatio', 'long_name', 'slope ratio') + + ! used for downscaling + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_write_serial (fsrfdata, 'SITE_svf', SITE_svf) + CALL ncio_put_attr (fsrfdata, 'SITE_svf','source', trim(datasource(u_site_svf))) + CALL ncio_put_attr (fsrfdata, 'SITE_svf','long_name', 'sky view factor') + + CALL ncio_write_serial (fsrfdata, 'SITE_cur', SITE_cur) + CALL ncio_put_attr (fsrfdata, 'SITE_cur','source', trim(datasource(u_site_cur))) + CALL ncio_put_attr (fsrfdata, 'SITE_cur','long_name', 'curvature') + + CALL ncio_write_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut, 'azi', 'zen') + CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','source', trim(datasource(u_site_sf_lut))) + CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','long_name', 'look up table of shadow factor') + + CALL ncio_write_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type , 'type') + CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','source', trim(datasource(u_site_slp_type))) + CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','long_name', 'topographic slope of each character') + + CALL ncio_write_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type , 'type') + CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','source', trim(datasource(u_site_asp_type))) + CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','long_name', 'topographic aspect of each character') + + CALL ncio_write_serial (fsrfdata, 'SITE_area_type', SITE_area_type, 'type') + CALL ncio_put_attr (fsrfdata, 'SITE_area_type','source', trim(datasource(u_site_area_type))) + CALL ncio_put_attr (fsrfdata, 'SITE_area_type','long_name', 'area percentage of each character') + ENDIF + + END SUBROUTINE write_surface_data_single + + +!----------------------------------------------------------------------- + SUBROUTINE write_urban_surface_data_single (numurban) + + USE MOD_NetCDFSerial + USE MOD_Namelist + USE MOD_Const_LC + IMPLICIT NONE + + integer, intent(in) :: numurban + + ! Local Variables + character(len=256) :: fsrfdata + integer :: iyear, itime + character(len=8) :: source + + fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc' + + SITE_fgper = 1 - (SITE_fgimp-SITE_froof)/(1-SITE_froof-SITE_flake_urb) + SITE_froof = SITE_froof/(1-SITE_flake_urb) + SITE_fveg_urb = SITE_fveg_urb * 100 + SITE_flake_urb = SITE_flake_urb * 100 + + CALL ncio_create_file (fsrfdata) + + CALL ncio_define_dimension (fsrfdata, 'soil', 8) + + CALL ncio_define_dimension (fsrfdata, 'azi', num_azimuth) + CALL ncio_define_dimension (fsrfdata, 'zen', num_zenith) + CALL ncio_define_dimension (fsrfdata, 'slope_type', num_slope_type) + + CALL ncio_define_dimension (fsrfdata, 'patch', numurban) + + CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year)) + CALL ncio_define_dimension (fsrfdata, 'month', 12) + + CALL ncio_define_dimension (fsrfdata, 'ulev' , 10) + CALL ncio_define_dimension (fsrfdata, 'numsolar', 2 ) + CALL ncio_define_dimension (fsrfdata, 'numrad' , 2 ) + + CALL ncio_write_serial (fsrfdata, 'latitude' , SITE_lat_location) + CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location) + + CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year') + CALL ncio_write_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly, 'month', 'LAI_year') + CALL ncio_write_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly, 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'TREE_LAI', 'source', trim(datasource(u_site_urblai))) + CALL ncio_put_attr (fsrfdata, 'TREE_SAI', 'source', trim(datasource(u_site_urbsai))) + + CALL ncio_write_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp ) + CALL ncio_write_serial (fsrfdata, 'LUCY_id' , SITE_lucyid ) + CALL ncio_write_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb ) + CALL ncio_write_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb ) + CALL ncio_write_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb ) + CALL ncio_write_serial (fsrfdata, 'WT_ROOF' , SITE_froof ) + CALL ncio_write_serial (fsrfdata, 'HT_ROOF' , SITE_hroof ) + CALL ncio_write_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper ) + CALL ncio_write_serial (fsrfdata, 'BUILDING_HLR' , SITE_hlr ) + CALL ncio_write_serial (fsrfdata, 'POP_DEN' , SITE_popden ) + + CALL ncio_put_attr (fsrfdata, 'PCT_Tree' , 'source', trim(datasource(u_site_fveg ))) + CALL ncio_put_attr (fsrfdata, 'URBAN_TREE_TOP', 'source', trim(datasource(u_site_htopu))) + CALL ncio_put_attr (fsrfdata, 'PCT_Water' , 'source', trim(datasource(u_site_flake))) + CALL ncio_put_attr (fsrfdata, 'WT_ROOF' , 'source', trim(datasource(u_site_froof))) + CALL ncio_put_attr (fsrfdata, 'HT_ROOF' , 'source', trim(datasource(u_site_hroof))) + CALL ncio_put_attr (fsrfdata, 'WTROAD_PERV' , 'source', trim(datasource(u_site_fgper))) + CALL ncio_put_attr (fsrfdata, 'BUILDING_HLR' , 'source', trim(datasource(u_site_hlr ))) + CALL ncio_put_attr (fsrfdata, 'POP_DEN' , 'source', trim(datasource(u_site_pop ))) + + CALL ncio_write_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof ) + CALL ncio_write_serial (fsrfdata, 'EM_WALL' , SITE_em_wall ) + CALL ncio_write_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp ) + CALL ncio_write_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper ) + CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) + CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) + CALL ncio_write_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof ) + CALL ncio_write_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall ) + + CALL ncio_put_attr (fsrfdata, 'EM_ROOF' , 'source', trim(datasource(u_site_emr ))) + CALL ncio_put_attr (fsrfdata, 'EM_WALL' , 'source', trim(datasource(u_site_emw ))) + CALL ncio_put_attr (fsrfdata, 'EM_IMPROAD' , 'source', trim(datasource(u_site_emgimp))) + CALL ncio_put_attr (fsrfdata, 'EM_PERROAD' , 'source', trim(datasource(u_site_emgper))) + CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MAX', 'source', trim(datasource(u_site_tbmax ))) + CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MIN', 'source', trim(datasource(u_site_tbmin ))) + CALL ncio_put_attr (fsrfdata, 'THICK_ROOF' , 'source', trim(datasource(u_site_thickr))) + CALL ncio_put_attr (fsrfdata, 'THICK_WALL' , 'source', trim(datasource(u_site_thickw))) + + CALL ncio_write_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof , 'numrad', 'numsolar') + CALL ncio_write_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall , 'numrad', 'numsolar') + CALL ncio_write_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp , 'numrad', 'numsolar') + CALL ncio_write_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper , 'numrad', 'numsolar') + + CALL ncio_put_attr (fsrfdata, 'ALB_ROOF' , 'source', trim(datasource(u_site_albr ))) + CALL ncio_put_attr (fsrfdata, 'ALB_WALL' , 'source', trim(datasource(u_site_albw ))) + CALL ncio_put_attr (fsrfdata, 'ALB_IMPROAD' , 'source', trim(datasource(u_site_albgimp))) + CALL ncio_put_attr (fsrfdata, 'ALB_PERROAD' , 'source', trim(datasource(u_site_albgper))) + + CALL ncio_write_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof , 'ulev') + CALL ncio_write_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall , 'ulev') + CALL ncio_write_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp , 'ulev') + CALL ncio_write_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof , 'ulev') + CALL ncio_write_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall , 'ulev') + CALL ncio_write_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp , 'ulev') + + CALL ncio_put_attr (fsrfdata, 'CV_ROOF' , 'source', trim(datasource(u_site_cvr ))) + CALL ncio_put_attr (fsrfdata, 'CV_WALL' , 'source', trim(datasource(u_site_cvw ))) + CALL ncio_put_attr (fsrfdata, 'CV_IMPROAD' , 'source', trim(datasource(u_site_cvgimp))) + CALL ncio_put_attr (fsrfdata, 'TK_ROOF' , 'source', trim(datasource(u_site_tkr ))) + CALL ncio_put_attr (fsrfdata, 'TK_WALL' , 'source', trim(datasource(u_site_tkw ))) + CALL ncio_put_attr (fsrfdata, 'TK_IMPROAD' , 'source', trim(datasource(u_site_tkgimp))) + + CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth) + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', trim(datasource(u_site_lakedepth))) + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'long_name', 'lake depth') + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'units', 'm') + + CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) + CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'long_name', 'albedo of visible of the saturated soil') + + CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) + CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'long_name', 'albedo of visible of the dry soil') + + CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) + CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'long_name', 'albedo of near infrared of the saturated soil') + + CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) + CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', trim(datasource(u_site_soil_bright))) + CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'long_name', 'albedo of near infrared of the dry soil') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', trim(datasource(u_site_vf_quartz_mineral))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'long_name', 'volumetric fraction of quartz within mineral soil') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'source', trim(datasource(u_site_vf_gravels))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'long_name', 'volumetric fraction of gravels') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'source', trim(datasource(u_site_vf_sand))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'long_name', 'volumetric fraction of sand') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'source', trim(datasource(u_site_vf_clay))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'long_name', 'volumetric fraction of clay') + + CALL ncio_write_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'source', trim(datasource(u_site_vf_om))) + CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'long_name', 'volumetric fraction of organic matter') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'source', trim(datasource(u_site_wf_gravels))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'long_name', 'gravimetric fraction of gravels') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'source', trim(datasource(u_site_wf_sand))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'long_name', 'gravimetric fraction of sand') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'source', trim(datasource(u_site_wf_clay))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'long_name', 'gravimetric fraction of clay') + + CALL ncio_write_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'source', trim(datasource(u_site_wf_om))) + CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'long_name', 'gravimetric fraction of om') + + CALL ncio_write_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'source', trim(datasource(u_site_OM_density))) + CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'long_name', 'OM density') + CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'units', 'kg/m3') + + CALL ncio_write_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'source', trim(datasource(u_site_BD_all))) + CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'long_name', 'bulk density of soil (GRAVELS + OM + mineral soils)') + CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'units', 'kg/m3') + + CALL ncio_write_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'source', trim(datasource(u_site_theta_s))) + CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'long_name', 'saturated water content') + CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'units', 'cm3/cm3') + + CALL ncio_write_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'source', trim(datasource(u_site_k_s))) + CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'long_name', 'saturated hydraulic conductivity') + CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'units', 'cm/day') + + CALL ncio_write_serial (fsrfdata, 'soil_csol', SITE_soil_csol(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_csol', 'source', trim(datasource(u_site_csol))) + CALL ncio_put_attr (fsrfdata, 'soil_csol', 'long_name', 'heat capacity of soil solids') + CALL ncio_put_attr (fsrfdata, 'soil_csol', 'units', 'J/(m3 K)') + + CALL ncio_write_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'source', trim(datasource(u_site_tksatu))) + CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'long_name', 'thermal conductivity of saturated unfrozen soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'units', 'W/m-K') + + CALL ncio_write_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'source', trim(datasource(u_site_tksatf))) + CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'long_name', 'thermal conductivity of saturated frozen soil') + CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'units', 'W/m-K') + + CALL ncio_write_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'source', trim(datasource(u_site_tkdry))) + CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'long_name', 'thermal conductivity for dry soil') + CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'units', 'W/(m-K)') + + CALL ncio_write_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'source', trim(datasource(u_site_k_solids))) + CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'long_name', 'thermal conductivity of minerals soil') + CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'units', 'W/m-K') + + CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', trim(datasource(u_site_lambda))) + CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'long_name', 'pore size distribution index (dimensionless)') + + CALL ncio_write_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', trim(datasource(u_site_psi_s))) + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'long_name', 'matric potential at saturation') + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'units', 'cm') + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_write_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'source', trim(datasource(u_site_theta_r))) + CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'long_name', 'residual water content') + CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'units', 'cm3/cm3') + + CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', trim(datasource(u_site_alpha_vgm))) + CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'long_name', 'a parameter corresponding approximately to the inverse of the air-entry value') + + CALL ncio_write_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'source', trim(datasource(u_site_L_vgm))) + CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'long_name', 'pore-connectivity parameter [dimensionless]') + + CALL ncio_write_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'source', trim(datasource(u_site_n_vgm))) + CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'long_name', 'a shape parameter [dimensionless]') + +#endif + + CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', trim(datasource(u_site_BA_alpha))) + CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'long_name', 'alpha in Balland and Arp(2005) thermal conductivity scheme') + + CALL ncio_write_serial (fsrfdata, 'soil_BA_beta', SITE_soil_BA_beta(1:8), 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'source', trim(datasource(u_site_BA_beta))) + CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'long_name', 'beta in Balland and Arp(2005) thermal conductivity scheme') + + IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC + CALL ncio_write_serial (fsrfdata, 'soil_texture ', SITE_soil_texture) + CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'source', trim(datasource(u_site_soil_texture))) + CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'long_name', 'USDA soil texture') + ENDIF + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', trim(datasource(u_site_dbedrock))) + ENDIF + + CALL ncio_write_serial (fsrfdata, 'elevation', SITE_elevation) + CALL ncio_put_attr (fsrfdata, 'elevation', 'source', trim(datasource(u_site_elevation))) + + CALL ncio_write_serial (fsrfdata, 'elvstd', SITE_elvstd) + CALL ncio_put_attr (fsrfdata, 'elvstd', 'source', trim(datasource(u_site_elvstd))) + CALL ncio_put_attr (fsrfdata, 'elvstd', 'long_name', 'standard deviation of elevation') + + CALL ncio_write_serial (fsrfdata, 'sloperatio', SITE_sloperatio) + CALL ncio_put_attr (fsrfdata, 'sloperatio', 'source', trim(datasource(u_site_sloperatio))) + CALL ncio_put_attr (fsrfdata, 'sloperatio', 'long_name', 'slope ratio') + + ! used for downscaling + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_write_serial (fsrfdata, 'SITE_svf', SITE_svf) + CALL ncio_put_attr (fsrfdata, 'SITE_svf','source', trim(datasource(u_site_svf))) + CALL ncio_put_attr (fsrfdata, 'SITE_svf','long_name', 'sky view factor') + + CALL ncio_write_serial (fsrfdata, 'SITE_cur', SITE_cur) + CALL ncio_put_attr (fsrfdata, 'SITE_cur','source', trim(datasource(u_site_cur))) + CALL ncio_put_attr (fsrfdata, 'SITE_cur','long_name', 'curvature') + + CALL ncio_write_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut, 'azi', 'zen') + CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','source', trim(datasource(u_site_sf_lut))) + CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','long_name', 'look up table of shadow factor') + + CALL ncio_write_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type , 'type') + CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','source', trim(datasource(u_site_slp_type))) + CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','long_name', 'topographic slope of each character') + + CALL ncio_write_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type , 'type') + CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','source', trim(datasource(u_site_asp_type))) + CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','long_name', 'topographic aspect of each character') + + CALL ncio_write_serial (fsrfdata, 'SITE_area_type', SITE_area_type, 'type') + CALL ncio_put_attr (fsrfdata, 'SITE_area_type','source', trim(datasource(u_site_area_type))) + CALL ncio_put_attr (fsrfdata, 'SITE_area_type','long_name', 'area percentage of each character') + ENDIF + + END SUBROUTINE write_urban_surface_data_single + + +!----------------------------------------------------------------------- + character(len=18) FUNCTION datasource (is_site) + + IMPLICIT NONE + logical, intent(in) :: is_site + + IF (is_site) THEN + datasource = 'SITE' + ELSE + datasource = 'CoLM 2024 raw data' + ENDIF + + END FUNCTION datasource + + +!----------------------------------------------------------------------- + SUBROUTINE single_srfdata_final () + + IMPLICIT NONE + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (allocated(SITE_pfttyp )) deallocate(SITE_pfttyp ) + IF (allocated(SITE_pctpfts)) deallocate(SITE_pctpfts) +#endif + +#ifdef CROP + IF (allocated(SITE_croptyp)) deallocate(SITE_croptyp) + IF (allocated(SITE_pctcrop)) deallocate(SITE_pctcrop) +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (allocated(SITE_htop_pfts)) deallocate(SITE_htop_pfts) +#endif + + IF (allocated(SITE_LAI_monthly)) deallocate(SITE_LAI_monthly) + IF (allocated(SITE_SAI_monthly)) deallocate(SITE_SAI_monthly) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (allocated(SITE_LAI_pfts_monthly)) deallocate(SITE_LAI_pfts_monthly) + IF (allocated(SITE_SAI_pfts_monthly)) deallocate(SITE_SAI_pfts_monthly) +#endif + + IF (allocated(SITE_LAI_year)) deallocate(SITE_LAI_year) + IF (allocated(SITE_LAI_8day)) deallocate(SITE_LAI_8day) + + IF (allocated(SITE_soil_vf_quartz_mineral)) deallocate(SITE_soil_vf_quartz_mineral) + IF (allocated(SITE_soil_vf_gravels )) deallocate(SITE_soil_vf_gravels ) + IF (allocated(SITE_soil_vf_sand )) deallocate(SITE_soil_vf_sand ) + IF (allocated(SITE_soil_vf_clay )) deallocate(SITE_soil_vf_clay ) + IF (allocated(SITE_soil_vf_om )) deallocate(SITE_soil_vf_om ) + IF (allocated(SITE_soil_wf_gravels )) deallocate(SITE_soil_wf_gravels ) + IF (allocated(SITE_soil_wf_sand )) deallocate(SITE_soil_wf_sand ) + IF (allocated(SITE_soil_wf_clay )) deallocate(SITE_soil_wf_clay ) + IF (allocated(SITE_soil_wf_om )) deallocate(SITE_soil_wf_om ) + IF (allocated(SITE_soil_OM_density )) deallocate(SITE_soil_OM_density ) + IF (allocated(SITE_soil_BD_all )) deallocate(SITE_soil_BD_all ) + IF (allocated(SITE_soil_theta_s )) deallocate(SITE_soil_theta_s ) + IF (allocated(SITE_soil_k_s )) deallocate(SITE_soil_k_s ) + IF (allocated(SITE_soil_csol )) deallocate(SITE_soil_csol ) + IF (allocated(SITE_soil_tksatu )) deallocate(SITE_soil_tksatu ) + IF (allocated(SITE_soil_tksatf )) deallocate(SITE_soil_tksatf ) + IF (allocated(SITE_soil_tkdry )) deallocate(SITE_soil_tkdry ) + IF (allocated(SITE_soil_k_solids )) deallocate(SITE_soil_k_solids ) + IF (allocated(SITE_soil_psi_s )) deallocate(SITE_soil_psi_s ) + IF (allocated(SITE_soil_lambda )) deallocate(SITE_soil_lambda ) + IF (allocated(SITE_soil_theta_r )) deallocate(SITE_soil_theta_r ) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + IF (allocated(SITE_soil_alpha_vgm )) deallocate(SITE_soil_alpha_vgm ) + IF (allocated(SITE_soil_L_vgm )) deallocate(SITE_soil_L_vgm ) + IF (allocated(SITE_soil_n_vgm )) deallocate(SITE_soil_n_vgm ) +#endif + IF (allocated(SITE_soil_BA_alpha )) deallocate(SITE_soil_BA_alpha ) + IF (allocated(SITE_soil_BA_beta )) deallocate(SITE_soil_BA_beta ) + + IF (allocated(SITE_sf_lut )) deallocate(SITE_sf_lut ) + IF (allocated(SITE_slp_type )) deallocate(SITE_slp_type ) + IF (allocated(SITE_asp_type )) deallocate(SITE_asp_type ) + IF (allocated(SITE_area_type )) deallocate(SITE_area_type ) + + END SUBROUTINE single_srfdata_final + +END MODULE MOD_SingleSrfdata +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 new file mode 100644 index 0000000000..3c83ff459f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 @@ -0,0 +1,553 @@ +#include + +#ifdef SrfdataDiag +MODULE MOD_SrfdataDiag +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! This module includes subroutines for checking the results of making +! surface data. +! +! The surface data in vector form is mapped to gridded data with last three +! dimensions of [type,longitude,latitude], which can be viewed by other +! softwares. +! +! In GRIDBASED, the grid of gridded data is just the grid of the mesh. In +! UNSTRUCTURED or CATCHMENT, the grid is user defined and the mapping uses +! area weighted scheme. +! +! Created by Shupeng Zhang, May 2023 +! +! !REVISIONS: +! TODO +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + + IMPLICIT NONE + + ! PUBLIC variables and subroutines + type(grid_type) :: gdiag + + type(spatial_mapping_type) :: m_elm2diag + + type(spatial_mapping_type) :: m_patch2diag +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + type(spatial_mapping_type) :: m_pft2diag +#endif +#ifdef URBAN_MODEL + type(spatial_mapping_type) :: m_urb2diag +#endif + + PUBLIC :: srfdata_diag_init + PUBLIC :: srfdata_map_and_write + + ! PRIVATE + type(grid_concat_type), PRIVATE :: srf_concat + integer, PRIVATE :: srf_data_id + +CONTAINS + + ! ------ SUBROUTINE ------ + SUBROUTINE srfdata_diag_init (dir_landdata, lc_year) + + USE MOD_SPMD_Task + USE MOD_LandElm + USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif +#ifdef URBAN_MODEL + USE MOD_LandUrban +#endif + + IMPLICIT NONE + + character(len=256), intent(in) :: dir_landdata + integer , intent(in) :: lc_year + + ! Local Variables + character(len=256) :: landdir, landname + integer :: ityp + integer :: typindex(N_land_classification+1) + real(r8), allocatable :: elmid_r8(:) + character(len=4) :: cyear + + landdir = trim(dir_landdata) // '/diag/' + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(adjustl(landdir))) + ENDIF + + CALL srf_concat%set (gdiag) + + CALL m_elm2diag%build_arealweighted (gdiag, landelm) + + CALL m_patch2diag%build_arealweighted (gdiag, landpatch) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL m_pft2diag%build_arealweighted (gdiag, landpft) +#endif + +#ifdef URBAN_MODEL + CALL m_urb2diag%build_arealweighted (gdiag, landurban) +#endif + + srf_data_id = 666 + + IF (p_is_worker) THEN + allocate (elmid_r8 (landelm%nset)); elmid_r8 = real(landelm%eindex, r8) + ENDIF + + write(cyear,'(i4.4)') lc_year + landname = trim(dir_landdata)//'/diag/element_'//trim(cyear)//'.nc' + CALL srfdata_map_and_write (elmid_r8, landelm%settyp, (/0,1/), m_elm2diag, & + -1.0e36_r8, landname, 'element', compress = 1, write_mode = 'one', & + defval=0._r8, create_mode=.true.) + + IF (p_is_worker) deallocate (elmid_r8) + + typindex = (/(ityp, ityp = 0, N_land_classification)/) + landname = trim(dir_landdata)//'/diag/patchfrac_elm_'//trim(cyear)//'.nc' + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + IF (.not. allocated(landpatch%pctshared)) THEN + allocate (landpatch%pctshared (numpatch)) + landpatch%pctshared = 1. + ENDIF + ENDIF + ENDIF + + CALL srfdata_map_and_write (landpatch%pctshared, landpatch%settyp, typindex, m_patch2diag, & + -1.0e36_r8, landname, 'patchfrac_elm', compress = 1, write_mode = 'one', defval=0._r8, & + stat_mode = 'fraction', pctshared = landpatch%pctshared, create_mode=.true.) + + END SUBROUTINE srfdata_diag_init + + ! ------ SUBROUTINE ------ + SUBROUTINE srfdata_map_and_write ( & + vsrfdata, settyp, typindex, m_srf, spv, filename, & + dataname, compress, write_mode, lastdimname, lastdimvalue, defval, & + stat_mode, pctshared, create_mode) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_NetCDFSerial + IMPLICIT NONE + + real(r8), intent(in) :: vsrfdata (:) + integer , intent(in) :: settyp (:) + integer , intent(in) :: typindex (:) + + type(spatial_mapping_type), intent(in) :: m_srf + + real(r8), intent(in) :: spv + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: compress + + character (len=*), intent(in), optional :: write_mode + + character (len=*), intent(in), optional :: lastdimname + integer, intent(in), optional :: lastdimvalue + + real(r8), intent(in), optional :: defval + + character (len=*), intent(in), optional :: stat_mode + real(r8), intent(in), optional :: pctshared (:) + logical , intent(in), optional :: create_mode + + ! Local variables + type(block_data_real8_3d) :: wdata, wtone + type(block_data_real8_2d) :: wdsum, wtsum + real(r8), allocatable :: vecone (:) + real(r8), allocatable :: areafrac (:) + real(r8), allocatable :: vdata (:,:,:), vdsum (:,:) + real(r8), allocatable :: rbuf (:,:,:), sbuf (:,:,:) + + character(len=10) :: wmode, smode + integer :: iblkme, ib, jb, iblk, jblk, idata, ixseg, iyseg + integer :: ntyps, ityp, xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp + integer :: rmesg(3), smesg(3), isrc + character(len=256) :: fileblock + logical :: fexists, cmode + integer :: ilastdim + + IF (present(write_mode)) THEN + wmode = trim(write_mode) + ELSE + wmode = 'one' + ENDIF + + IF (present(stat_mode)) THEN + smode = trim(stat_mode) + ELSE + smode = 'mean' + ENDIF + + IF (present(create_mode)) THEN + cmode = create_mode + ELSE + cmode = .false. + ENDIF + + ntyps = size(typindex) + + IF (p_is_io) THEN + CALL allocate_block_data (gdiag, wtone, ntyps) + CALL allocate_block_data (gdiag, wdata, ntyps) + CALL allocate_block_data (gdiag, wdsum) + CALL allocate_block_data (gdiag, wtsum) + ENDIF + + IF (p_is_worker) THEN + IF (m_srf%npset > 0) THEN + allocate (vecone (m_srf%npset)) + vecone(:) = 1.0 + ENDIF + ENDIF + + CALL m_srf%pset2grid_split (vecone, settyp, typindex, wtone, spv) + + IF (trim(smode) == 'mean') THEN + CALL m_srf%pset2grid_split (vsrfdata, settyp, typindex, wdata, spv) + ELSEIF (trim(smode) == 'fraction') THEN + IF (p_is_worker) THEN + IF (m_srf%npset > 0) THEN + allocate (areafrac (m_srf%npset)) + areafrac = vsrfdata + IF (present(pctshared)) THEN + WHERE (pctshared > 0.) areafrac = areafrac / pctshared + ENDIF + ENDIF + ENDIF + CALL m_srf%pset2grid_split (areafrac, settyp, typindex, wdata, spv) + ENDIF + + IF (p_is_io) THEN + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + wtsum%blk(ib,jb)%val = sum(wtone%blk(ib,jb)%val, & + mask = (wtone%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv), dim = 1) + wdsum%blk(ib,jb)%val = sum(wdata%blk(ib,jb)%val, & + mask = (wtone%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv), dim = 1) + + IF (trim(smode) == 'mean') THEN + + WHERE ((wtone%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv)) + wdata%blk(ib,jb)%val = wdata%blk(ib,jb)%val / wtone%blk(ib,jb)%val + ELSEWHERE + wdata%blk(ib,jb)%val = spv + END WHERE + + ELSEIF (trim(smode) == 'fraction') THEN + + DO ityp = 1, ntyps + WHERE ((wtsum%blk(ib,jb)%val(:,:) > 0.) .and. (wtone%blk(ib,jb)%val(ityp,:,:) /= spv)) + wdata%blk(ib,jb)%val(ityp,:,:) = wtone%blk(ib,jb)%val(ityp,:,:) / wtsum%blk(ib,jb)%val + ELSEWHERE + wdata%blk(ib,jb)%val(ityp,:,:) = spv + END WHERE + ENDDO + + ENDIF + + WHERE (wtsum%blk(ib,jb)%val > 0.) + wdsum%blk(ib,jb)%val = wdsum%blk(ib,jb)%val / wtsum%blk(ib,jb)%val + ELSEWHERE + wdsum%blk(ib,jb)%val = spv + END WHERE + + ENDDO + ENDIF + + IF (trim(wmode) == 'one') THEN + + IF (p_is_master) THEN + + allocate (vdata (srf_concat%ginfo%nlon, srf_concat%ginfo%nlat, ntyps)) + vdata(:,:,:) = spv + + allocate (vdsum (srf_concat%ginfo%nlon, srf_concat%ginfo%nlat)) + vdsum(:,:) = spv + +#ifdef USEMPI + DO idata = 1, srf_concat%ndatablk + + CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & + srf_data_id, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + + xgdsp = srf_concat%xsegs(ixseg)%gdsp + ygdsp = srf_concat%ysegs(iyseg)%gdsp + xcnt = srf_concat%xsegs(ixseg)%cnt + ycnt = srf_concat%ysegs(iyseg)%cnt + + allocate (rbuf (ntyps,xcnt,ycnt)) + + CALL mpi_recv (rbuf, ntyps * xcnt * ycnt, MPI_REAL8, & + isrc, srf_data_id, p_comm_glb, p_stat, p_err) + + DO ityp = 1, ntyps + vdata (xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt,ityp) = rbuf(ityp,:,:) + ENDDO + + CALL mpi_recv (rbuf(1,:,:), xcnt * ycnt, MPI_REAL8, & + isrc, srf_data_id, p_comm_glb, p_stat, p_err) + + vdsum (xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf(1,:,:) + + deallocate (rbuf) + ENDDO +#else + DO iyseg = 1, srf_concat%nyseg + DO ixseg = 1, srf_concat%nxseg + iblk = srf_concat%xsegs(ixseg)%blk + jblk = srf_concat%ysegs(iyseg)%blk + xbdsp = srf_concat%xsegs(ixseg)%bdsp + ybdsp = srf_concat%ysegs(iyseg)%bdsp + xgdsp = srf_concat%xsegs(ixseg)%gdsp + ygdsp = srf_concat%ysegs(iyseg)%gdsp + xcnt = srf_concat%xsegs(ixseg)%cnt + ycnt = srf_concat%ysegs(iyseg)%cnt + + DO ityp = 1, ntyps + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt,ityp) = & + wdata%blk(iblk,jblk)%val(ityp,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + ENDDO + + vdsum (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & + wdsum%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + ENDDO + ENDDO +#endif + + IF (present(defval)) THEN + WHERE (vdata == spv) vdata = defval + WHERE (vdsum == spv) vdsum = defval + ENDIF + + write(*,*) 'Please check gridded data < ', trim(dataname), ' > in ', trim(filename) + + inquire (file=trim(filename), exist=fexists) + IF (.not. fexists .or. cmode) THEN + + CALL ncio_create_file (filename) + + IF (ntyps > 1) THEN + CALL ncio_define_dimension (filename, 'TypeIndex', ntyps) + CALL ncio_write_serial (filename, 'TypeIndex', typindex, 'TypeIndex') + ENDIF + + CALL ncio_define_dimension (filename, 'lon' , srf_concat%ginfo%nlon) + CALL ncio_define_dimension (filename, 'lat' , srf_concat%ginfo%nlat) + + CALL ncio_write_serial (filename, 'lat', srf_concat%ginfo%lat_c, 'lat') + CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') + CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') + + CALL ncio_write_serial (filename, 'lon', srf_concat%ginfo%lon_c, 'lon') + CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') + CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') + + CALL ncio_write_serial (filename, 'lat_s', srf_concat%ginfo%lat_s, 'lat') + CALL ncio_put_attr (filename, 'lat_s', 'long_name', 'southern latitude boundary') + CALL ncio_put_attr (filename, 'lat_s', 'units', 'degrees_north') + + CALL ncio_write_serial (filename, 'lat_n', srf_concat%ginfo%lat_n, 'lat') + CALL ncio_put_attr (filename, 'lat_n', 'long_name', 'northern latitude boundary') + CALL ncio_put_attr (filename, 'lat_n', 'units', 'degrees_north') + + CALL ncio_write_serial (filename, 'lon_w', srf_concat%ginfo%lon_w, 'lon') + CALL ncio_put_attr (filename, 'lon_w', 'long_name', 'western longitude boundary') + CALL ncio_put_attr (filename, 'lon_w', 'units', 'degrees_east') + + CALL ncio_write_serial (filename, 'lon_e', srf_concat%ginfo%lon_e, 'lon') + CALL ncio_put_attr (filename, 'lon_e', 'long_name', 'eastern longitude boundary') + CALL ncio_put_attr (filename, 'lon_e', 'units', 'degrees_east') + + ENDIF + + IF (present(lastdimname) .and. present(lastdimvalue)) THEN + + CALL ncio_write_lastdim (filename, lastdimname, lastdimvalue, ilastdim) + + IF (ntyps > 1) THEN + CALL ncio_write_serial_time (filename, dataname, ilastdim, vdata, & + 'lon', 'lat', 'TypeIndex', trim(lastdimname), compress) + CALL ncio_write_serial_time (filename, trim(dataname)//'_grid', ilastdim, vdsum, & + 'lon', 'lat', trim(lastdimname), compress) + ELSE + CALL ncio_write_serial_time (filename, dataname, ilastdim, vdata(:,:,1), & + 'lon', 'lat', trim(lastdimname), compress) + ENDIF + + ELSE + + IF (ntyps > 1) THEN + CALL ncio_write_serial (filename, dataname, vdata, 'lon', 'lat', 'TypeIndex', compress) + CALL ncio_write_serial (filename, trim(dataname)//'_grid', vdsum, 'lon', 'lat', compress) + ELSE + CALL ncio_write_serial (filename, dataname, vdata(:,:,1), 'lon', 'lat', compress) + ENDIF + + ENDIF + + CALL ncio_put_attr (filename, dataname, 'missing_value', spv) + + IF (ntyps > 1) THEN + CALL ncio_put_attr (filename, trim(dataname)//'_grid', 'missing_value', spv) + ENDIF + + deallocate (vdata) + deallocate (vdsum) + + ENDIF + +#ifdef USEMPI + IF (p_is_io) THEN + + DO iyseg = 1, srf_concat%nyseg + DO ixseg = 1, srf_concat%nxseg + + iblk = srf_concat%xsegs(ixseg)%blk + jblk = srf_concat%ysegs(iyseg)%blk + + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + xbdsp = srf_concat%xsegs(ixseg)%bdsp + ybdsp = srf_concat%ysegs(iyseg)%bdsp + xcnt = srf_concat%xsegs(ixseg)%cnt + ycnt = srf_concat%ysegs(iyseg)%cnt + + smesg = (/p_iam_glb, ixseg, iyseg/) + CALL mpi_send (smesg, 3, MPI_INTEGER, & + p_address_master, srf_data_id, p_comm_glb, p_err) + + allocate (sbuf (ntyps,xcnt,ycnt)) + + sbuf = wdata%blk(iblk,jblk)%val(:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + CALL mpi_send (sbuf, ntyps*xcnt*ycnt, MPI_REAL8, & + p_address_master, srf_data_id, p_comm_glb, p_err) + + sbuf(1,:,:) = wdsum%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) + CALL mpi_send (sbuf(1,:,:), xcnt*ycnt, MPI_REAL8, & + p_address_master, srf_data_id, p_comm_glb, p_err) + + deallocate (sbuf) + ENDIF + ENDDO + ENDDO + ENDIF +#endif + + srf_data_id = srf_data_id + 1 + + ELSEIF (trim(wmode) == 'block') THEN + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF ((gdiag%xcnt(iblk) == 0) .or. (gdiag%ycnt(jblk) == 0)) CYCLE + + CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file=trim(filename), exist=fexists) + IF (.not. fexists) THEN + CALL ncio_create_file (fileblock) + CALL ncio_define_dimension (fileblock, 'TypeIndex', ntyps) + CALL srf_write_grid_info (fileblock, gdiag, iblk, jblk) + ENDIF + + IF (present(lastdimname) .and. present(lastdimvalue)) THEN + CALL ncio_write_lastdim (fileblock, lastdimname, lastdimvalue, ilastdim) + CALL ncio_write_serial_time (fileblock, dataname, ilastdim, wdata%blk(iblk,jblk)%val, & + 'TypeIndex', 'lon', 'lat', trim(lastdimname), compress) + ELSE + CALL ncio_write_serial (fileblock, dataname, & + wdata%blk(iblk,jblk)%val, 'TypeIndex', 'lon', 'lat', compress) + ENDIF + + CALL ncio_put_attr (fileblock, dataname, 'missing_value', spv) + + ENDDO + + ENDIF + ENDIF + + IF (allocated(vecone)) deallocate(vecone) + + END SUBROUTINE srfdata_map_and_write + + !------------------ + SUBROUTINE srf_write_grid_info (fileblock, grid, iblk, jblk) + + USE MOD_Block + USE MOD_Grid + USE MOD_NetCDFSerial + IMPLICIT NONE + + character(len=*), intent(in) :: fileblock + type (grid_type), intent(in) :: grid + integer, intent(in) :: iblk, jblk + + ! Local variable + integer :: yl, yu, xl, xu, nx + real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:) + + allocate (lon_w (grid%xcnt(iblk))) + allocate (lon_e (grid%xcnt(iblk))) + allocate (lat_s (grid%ycnt(jblk))) + allocate (lat_n (grid%ycnt(jblk))) + + yl = grid%ydsp(jblk) + 1 + yu = grid%ydsp(jblk) + grid%ycnt(jblk) + + lat_s = grid%lat_s(yl:yu) + lat_n = grid%lat_n(yl:yu) + + IF (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) THEN + xl = grid%xdsp(iblk) + 1 + xu = grid%nlon + nx = grid%nlon - grid%xdsp(iblk) + lon_w(1:nx) = grid%lon_w(xl:xu) + lon_e(1:nx) = grid%lon_e(xl:xu) + + xl = 1 + xu = grid%xcnt(iblk) - nx + lon_w(nx+1:grid%xcnt(iblk)) = grid%lon_w(xl:xu) + lon_e(nx+1:grid%xcnt(iblk)) = grid%lon_e(xl:xu) + ELSE + xl = grid%xdsp(iblk) + 1 + xu = grid%xdsp(iblk) + grid%xcnt(iblk) + lon_w = grid%lon_w(xl:xu) + lon_e = grid%lon_e(xl:xu) + ENDIF + + CALL ncio_define_dimension (fileblock, 'lat', grid%ycnt(jblk)) + CALL ncio_define_dimension (fileblock, 'lon', grid%xcnt(iblk)) + CALL ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat') + CALL ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat') + CALL ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon') + CALL ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon') + + END SUBROUTINE srf_write_grid_info + +END MODULE MOD_SrfdataDiag +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 new file mode 100644 index 0000000000..e9b2fa9aa3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 @@ -0,0 +1,816 @@ +#include + +MODULE MOD_SrfdataRestart +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! This module includes subroutines to read/write data of mesh and pixelsets. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + IMPLICIT NONE + + ! ----- subroutines ----- + PUBLIC :: mesh_save_to_file + PUBLIC :: mesh_load_from_file + + PUBLIC :: pixelset_save_to_file + PUBLIC :: pixelset_load_from_file + +CONTAINS + + ! ----------------------- + SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Mesh + USE MOD_Block + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: dir_landdata + integer , intent(in) :: lc_year + + ! Local variables + character(len=256) :: filename, fileblock, cyear + integer :: ie, je, nelm, totlen, tothis, iblk, jblk, iworker, i + integer, allocatable :: nelm_worker(:), ndsp_worker(:) + integer*8, allocatable :: elmindx(:) + integer, allocatable :: npxlall(:) + integer, allocatable :: elmpixels(:,:) + real(r8), allocatable :: lon(:), lat(:) + + integer :: nsend, nrecv, ndone, ndsp + + ! add parameter input for time year + write(cyear,'(i4.4)') lc_year +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,*) 'Saving land elements ...' + CALL system('mkdir -p ' // trim(dir_landdata) // '/mesh/' // trim(cyear)) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + filename = trim(dir_landdata) // '/mesh/' //trim(cyear) // '/mesh.nc' + + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + +#ifdef USEMPI + IF (p_is_worker) THEN + IF (gblock%pio(iblk,jblk) == p_address_io(p_my_group)) THEN +#endif + nelm = 0 + totlen = 0 + DO ie = 1, numelm + IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN + nelm = nelm + 1 + totlen = totlen + mesh(ie)%npxl + ENDIF + ENDDO + + IF (nelm > 0) THEN + + allocate (elmindx (nelm)) + allocate (npxlall (nelm)) + allocate (elmpixels (2,totlen)) + + je = 0 + ndsp = 0 + DO ie = 1, numelm + IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN + je = je + 1 + elmindx(je) = mesh(ie)%indx + npxlall(je) = mesh(ie)%npxl + + elmpixels(1,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilon + elmpixels(2,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilat + + ndsp = ndsp + npxlall(je) + ENDIF + ENDDO + ENDIF + +#ifdef USEMPI + CALL mpi_gather (nelm, 1, MPI_INTEGER, & + MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err) + + CALL mpi_gatherv (elmindx, nelm, MPI_INTEGER8, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + CALL mpi_gatherv (npxlall, nelm, MPI_INTEGER, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + p_root, p_comm_group, p_err) + + ndone = 0 + DO WHILE (ndone < totlen) + nsend = max(min(totlen-ndone, MesgMaxSize/8), 1) + CALL mpi_send (nsend, 1, & + MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_err) + CALL mpi_send (elmpixels(:,ndone+1:ndone+nsend), 2*nsend, & + MPI_INTEGER, p_root, mpi_tag_data, p_comm_group, p_err) + ndone = ndone + nsend + ENDDO + ENDIF + ENDIF +#endif + +#ifdef USEMPI + IF (p_is_io) THEN + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + allocate (nelm_worker (0:p_np_group-1)) + nelm_worker(0) = 0 + CALL mpi_gather (MPI_IN_PLACE, 0, MPI_INTEGER, & + nelm_worker, 1, MPI_INTEGER, p_root, p_comm_group, p_err) + + nelm = sum(nelm_worker) + + allocate (ndsp_worker(0:p_np_group-1)) + ndsp_worker(0) = 0 + DO iworker = 1, p_np_group-1 + ndsp_worker(iworker) = ndsp_worker(iworker-1) + nelm_worker(iworker-1) + ENDDO + + allocate (elmindx (nelm)) + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & + elmindx, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER8, & + p_root, p_comm_group, p_err) + + allocate (npxlall (nelm)) + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & + npxlall, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER, & + p_root, p_comm_group, p_err) + + totlen = sum(npxlall) + allocate (elmpixels (2, totlen)) + + ndone = 0 + DO iworker = 1, p_np_group-1 + + ndsp = ndsp_worker(iworker) + tothis = ndone + sum(npxlall(ndsp+1:ndsp+nelm_worker(iworker))) + + DO WHILE (ndone < tothis) + + CALL mpi_recv (nrecv, 1, & + MPI_INTEGER, iworker, mpi_tag_size, p_comm_group, p_stat, p_err) + CALL mpi_recv (elmpixels(:,ndone+1:ndone+nrecv), 2*nrecv, & + MPI_INTEGER, iworker, mpi_tag_data, p_comm_group, p_stat, p_err) + + ndone = ndone + nrecv + ENDDO + ENDDO + ENDIF + ENDIF +#endif + + IF (p_is_io) THEN + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + IF (nelm > 0) THEN + CALL get_filename_block (filename, iblk, jblk, fileblock) + CALL ncio_create_file (fileblock) + + CALL ncio_define_dimension (fileblock, 'element',nelm) + CALL ncio_define_dimension (fileblock, 'ncoor', 2 ) + CALL ncio_define_dimension (fileblock, 'pixel', totlen) + + CALL ncio_write_serial (fileblock, 'elmindex', elmindx, 'element') + CALL ncio_write_serial (fileblock, 'elmnpxl', npxlall, 'element') + CALL ncio_write_serial (fileblock, 'elmpixels', elmpixels, & + 'ncoor', 'pixel', compress = 1) + ENDIF + ENDIF + ENDIF + + IF (allocated (elmindx)) deallocate(elmindx) + IF (allocated (npxlall)) deallocate(npxlall) + IF (allocated (elmpixels)) deallocate(elmpixels) + + IF (allocated (nelm_worker)) deallocate(nelm_worker) + IF (allocated (ndsp_worker)) deallocate(ndsp_worker) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_group, p_err) +#endif + ENDDO + ENDDO + + IF (p_is_master) THEN + + CALL ncio_create_file (filename) + + CALL ncio_define_dimension (filename, 'xblk', gblock%nxblk) + CALL ncio_define_dimension (filename, 'yblk', gblock%nyblk) + CALL ncio_write_serial (filename, 'nelm_blk', nelm_blk, 'xblk', 'yblk') + + CALL ncio_define_dimension (filename, 'longitude', gridmesh%nlon) + CALL ncio_define_dimension (filename, 'latitude' , gridmesh%nlat) + + allocate (lon (gridmesh%nlon)) + allocate (lat (gridmesh%nlat)) + + DO i = 1, gridmesh%nlon + lon(i) = (gridmesh%lon_w(i) + gridmesh%lon_e(i)) * 0.5 + IF (gridmesh%lon_w(i) > gridmesh%lon_e(i)) THEN + lon(i) = lon(i) + 180.0 + CALL normalize_longitude (lon(i)) + ENDIF + ENDDO + CALL ncio_write_serial (filename, 'longitude', lon, 'longitude') + + DO i = 1, gridmesh%nlat + lat(i) = (gridmesh%lat_s(i) + gridmesh%lat_n(i)) * 0.5 + ENDDO + CALL ncio_write_serial (filename, 'latitude', lat, 'latitude') + +#ifdef GRIDBASED + CALL ncio_write_serial (filename, 'lat_s', gridmesh%lat_s, 'latitude' ) + CALL ncio_write_serial (filename, 'lat_n', gridmesh%lat_n, 'latitude' ) + CALL ncio_write_serial (filename, 'lon_w', gridmesh%lon_w, 'longitude') + CALL ncio_write_serial (filename, 'lon_e', gridmesh%lon_e, 'longitude') +#endif + + deallocate (lon) + deallocate (lat) + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) write(*,*) 'SAVE land elements done.' + + END SUBROUTINE mesh_save_to_file + + !------------------------------------ + SUBROUTINE prepare_subset_eindex(subset_eindex, sorted_subset) + + USE MOD_Utils, only: quicksort + IMPLICIT NONE + + integer*8, intent(in) :: subset_eindex(:) + integer*8, allocatable, intent(out) :: sorted_subset(:) + + integer, allocatable :: order(:) + integer :: i + + allocate(sorted_subset(size(subset_eindex))) + sorted_subset = subset_eindex + + IF (size(sorted_subset) > 1) THEN + allocate(order(size(sorted_subset))) + order = (/ (i, i = 1, size(sorted_subset)) /) + CALL quicksort(size(sorted_subset), sorted_subset, order) + deallocate(order) + ENDIF + + END SUBROUTINE prepare_subset_eindex + + !------------------------------------ + logical FUNCTION eindex_in_subset(eindex, sorted_subset) result(keep) + + USE MOD_Utils, only: find_in_sorted_list1 + IMPLICIT NONE + + integer*8, intent(in) :: eindex + integer*8, allocatable, intent(in) :: sorted_subset(:) + + IF (.not. allocated(sorted_subset)) THEN + keep = .true. + ELSEIF (size(sorted_subset) < 1) THEN + keep = .false. + ELSE + keep = find_in_sorted_list1(eindex, size(sorted_subset), sorted_subset) > 0 + ENDIF + + END FUNCTION eindex_in_subset + + !------------------------------------ + integer FUNCTION count_subset_eindex(eindex, sorted_subset) result(nkeep) + + IMPLICIT NONE + + integer*8, intent(in) :: eindex(:) + integer*8, allocatable, intent(in) :: sorted_subset(:) + + integer :: i + + nkeep = 0 + DO i = 1, size(eindex) + IF (eindex_in_subset(eindex(i), sorted_subset)) nkeep = nkeep + 1 + ENDDO + + END FUNCTION count_subset_eindex + + !------------------------------------ + SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Block + USE MOD_NetCDFSerial + USE MOD_Mesh + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: dir_landdata + integer*8, optional, intent(in) :: subset_eindex(:) + + ! Local variables + character(len=256) :: filename, fileblock, cyear + integer :: iblkme, iblk, jblk, ie, nelm, ndsp, pdsp + integer*8, allocatable :: elmindx(:) + integer*8, allocatable :: subset_sorted(:) + integer, allocatable :: datasize(:) + integer, allocatable :: npxl(:), pixels(:,:), pixels2d(:,:,:) + logical, allocatable :: keep_elm(:) + logical :: use_subset + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,*) 'Loading land elements ...' + ENDIF + + ! add parameter input for time year + write(cyear,'(i4.4)') lc_year + filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' + CALL ncio_read_bcast_serial (filename, 'nelm_blk', nelm_blk) + use_subset = present(subset_eindex) + IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) + + IF (p_is_io) THEN + + numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) + + IF (numelm > 0) THEN + + IF (allocated(mesh)) deallocate(mesh) + allocate (mesh (numelm)) + + ndsp = 0 + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + nelm = nelm_blk(iblk,jblk) + + IF (nelm > 0) THEN + + CALL get_filename_block (filename, iblk, jblk, fileblock) + CALL ncio_read_serial (fileblock, 'elmindex', elmindx) + CALL ncio_read_serial (fileblock, 'elmnpxl', npxl ) + + IF (use_subset) THEN + allocate (keep_elm(nelm)) + DO ie = 1, nelm + keep_elm(ie) = eindex_in_subset(elmindx(ie), subset_sorted) + ENDDO + IF (count(keep_elm) < 1) THEN + deallocate(keep_elm) + CYCLE + ENDIF + ENDIF + + CALL ncio_inquire_varsize (fileblock, 'elmpixels', datasize) + IF (size(datasize) == 3) THEN + CALL ncio_read_serial (fileblock, 'elmpixels', pixels2d) + ELSE + CALL ncio_read_serial (fileblock, 'elmpixels', pixels) + ENDIF + + pdsp = 0 + DO ie = 1, nelm + IF (use_subset) THEN + IF (.not. keep_elm(ie)) THEN + IF (size(datasize) /= 3) pdsp = pdsp + npxl(ie) + CYCLE + ENDIF + ENDIF + + ndsp = ndsp + 1 + mesh(ndsp)%indx = elmindx(ie) + mesh(ndsp)%npxl = npxl(ie) + mesh(ndsp)%xblk = iblk + mesh(ndsp)%yblk = jblk + + allocate (mesh(ndsp)%ilon (npxl(ie))) + allocate (mesh(ndsp)%ilat (npxl(ie))) + + IF (size(datasize) == 3) THEN + mesh(ndsp)%ilon = pixels2d(1,1:npxl(ie),ie) + mesh(ndsp)%ilat = pixels2d(2,1:npxl(ie),ie) + ELSE + mesh(ndsp)%ilon = pixels(1,pdsp+1:pdsp+npxl(ie)) + mesh(ndsp)%ilat = pixels(2,pdsp+1:pdsp+npxl(ie)) + pdsp = pdsp + npxl(ie) + ENDIF + ENDDO + + IF (allocated(keep_elm)) deallocate(keep_elm) + ENDIF + ENDDO + + numelm = ndsp + ENDIF + + IF (use_subset .and. allocated(nelm_blk)) THEN + nelm_blk(:,:) = 0 + DO ie = 1, numelm + nelm_blk(mesh(ie)%xblk, mesh(ie)%yblk) = & + nelm_blk(mesh(ie)%xblk, mesh(ie)%yblk) + 1 + ENDDO + ENDIF + + IF (allocated(elmindx )) deallocate(elmindx ) + IF (allocated(npxl )) deallocate(npxl ) + IF (allocated(datasize)) deallocate(datasize) + IF (allocated(pixels )) deallocate(pixels ) + IF (allocated(pixels2d)) deallocate(pixels2d) + IF (allocated(subset_sorted)) deallocate(subset_sorted) + + ENDIF + +#ifdef CoLMDEBUG + IF (p_is_io) write(*,'(I10,A,I4)') numelm, ' elements on group ', p_iam_io +#endif + +#ifdef USEMPI + CALL scatter_mesh_from_io_to_worker + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,*) 'Loading land elements done.' + ENDIF + + END SUBROUTINE mesh_load_from_file + + !------------------------------------------------ + SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year) + + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_NetCDFVector + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: dir_landdata + character(len=*), intent(in) :: psetname + type(pixelset_type), intent(in) :: pixelset + integer , intent(in) :: lc_year + + ! Local variables + character(len=256) :: filename, cyear + + write(cyear,'(i4.4)') lc_year +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + IF (p_is_master) THEN + write(*,*) 'Saving Pixel Sets ' // trim(psetname) // ' ...' + CALL system('mkdir -p ' // trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear)) + ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc' + + CALL ncio_create_file_vector (filename, pixelset) + CALL ncio_define_dimension_vector (filename, pixelset, trim(psetname)) + + CALL ncio_write_vector (filename, 'eindex', trim(psetname), pixelset, pixelset%eindex, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (filename, 'ipxstt', trim(psetname), pixelset, pixelset%ipxstt, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (filename, 'ipxend', trim(psetname), pixelset, pixelset%ipxend, DEF_Srfdata_CompressLevel) + CALL ncio_write_vector (filename, 'settyp', trim(psetname), pixelset, pixelset%settyp, DEF_Srfdata_CompressLevel) + + IF (pixelset%has_shared) THEN + CALL ncio_write_vector (filename, 'pctshared', trim(psetname), pixelset, pixelset%pctshared, DEF_Srfdata_CompressLevel) + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) write(*,*) 'SAVE Pixel Sets ' // trim(psetname) // ' done.' + + END SUBROUTINE pixelset_save_to_file + + + !--------------------------- + SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc_year, subset_eindex) + + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_Mesh + USE MOD_Pixelset + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: dir_landdata + character(len=*), intent(in) :: psetname + type(pixelset_type), intent(inout) :: pixelset + integer, intent(out) :: numset + integer*8, optional, intent(in) :: subset_eindex(:) + + ! Local variables + character(len=256) :: filename, fileblock, blockname, cyear + integer :: iset, nset, nset_file, ndsp, iblkme, iblk, jblk, ie, je, nave, nres, left, iproc, ipos + integer :: nsend, nrecv + integer*8, allocatable :: rbuff(:), sbuff(:) + integer*8, allocatable :: subset_sorted(:) + integer, allocatable :: iworker(:) + logical, allocatable :: msk(:) + logical, allocatable :: keep_set(:) + logical :: fexists, fexists_any + logical :: use_subset + + write(cyear,'(i4.4)') lc_year +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + use_subset = present(subset_eindex) + IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) + + IF (p_is_master) THEN + write(*,*) 'Loading Pixel Sets ' // trim(psetname) // ' ...' + ENDIF + + filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc' + + IF (p_is_io) THEN + + pixelset%nset = 0 + + fexists_any = .false. + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + +#if (defined VectorInOneFileS || defined VectorInOneFileP) + CALL get_blockname (iblk, jblk, blockname) + CALL ncio_inquire_length_grp (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), nset) + IF (use_subset .and. nset > 0) THEN + CALL ncio_read_serial_grp_int64_1d (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), rbuff) + nset = count_subset_eindex(rbuff, subset_sorted) + deallocate(rbuff) + ENDIF + pixelset%nset = pixelset%nset + nset +#else + CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file=trim(fileblock), exist=fexists) + IF (fexists) THEN + IF (use_subset) THEN + CALL ncio_read_serial (fileblock, 'eindex', rbuff) + nset = count_subset_eindex(rbuff, subset_sorted) + deallocate(rbuff) + ELSE + CALL ncio_inquire_length (fileblock, 'eindex', nset) + ENDIF + pixelset%nset = pixelset%nset + nset + ENDIF + + fexists_any = fexists_any .or. fexists +#endif + ENDDO + +#if (defined VectorInOneFileS || defined VectorInOneFileP) + fexists_any = pixelset%nset > 0 +#endif + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. fexists_any) THEN + write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' + CALL CoLM_stop () + ENDIF + + IF (pixelset%nset > 0) THEN + + allocate (pixelset%eindex (pixelset%nset)) + allocate (pixelset%srcpos (pixelset%nset)) + + ndsp = 0 + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + +#if (defined VectorInOneFileS || defined VectorInOneFileP) + CALL get_blockname (iblk, jblk, blockname) + CALL ncio_inquire_length_grp (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), nset) + + IF (nset > 0) THEN + + CALL ncio_read_serial_grp_int64_1d (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), rbuff) + + nset_file = size(rbuff) + IF (use_subset) THEN + allocate(keep_set(nset_file)) + DO iset = 1, nset_file + keep_set(iset) = eindex_in_subset(rbuff(iset), subset_sorted) + ENDDO + nset = count(keep_set) + ELSE + nset = nset_file + ENDIF + + IF (nset > 0) THEN + IF (use_subset) THEN + pixelset%eindex(ndsp+1:ndsp+nset) = pack(rbuff, keep_set) + pixelset%srcpos(ndsp+1:ndsp+nset) = & + pack((/ (ipos, ipos = 1, nset_file) /), keep_set) + ELSE + pixelset%eindex(ndsp+1:ndsp+nset) = rbuff + pixelset%srcpos(ndsp+1:ndsp+nset) = (/ (ipos, ipos = 1, nset) /) + ENDIF + + ndsp = ndsp + nset + ENDIF + + IF (allocated(keep_set)) deallocate(keep_set) + deallocate(rbuff) + ENDIF +#else + CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file=trim(fileblock), exist=fexists) + IF (fexists) THEN + + CALL ncio_read_serial (fileblock, 'eindex', rbuff) + + nset_file = size(rbuff) + IF (use_subset) THEN + allocate(keep_set(nset_file)) + DO iset = 1, nset_file + keep_set(iset) = eindex_in_subset(rbuff(iset), subset_sorted) + ENDDO + nset = count(keep_set) + ELSE + nset = nset_file + ENDIF + + IF (nset > 0) THEN + IF (use_subset) THEN + pixelset%eindex(ndsp+1:ndsp+nset) = pack(rbuff, keep_set) + pixelset%srcpos(ndsp+1:ndsp+nset) = & + pack((/ (ipos, ipos = 1, nset_file) /), keep_set) + ELSE + pixelset%eindex(ndsp+1:ndsp+nset) = rbuff + pixelset%srcpos(ndsp+1:ndsp+nset) = (/ (ipos, ipos = 1, nset) /) + ENDIF + + ndsp = ndsp + nset + ENDIF + + IF (allocated(keep_set)) deallocate(keep_set) + deallocate(rbuff) + ENDIF +#endif + + ENDDO + ENDIF + ENDIF + + +#ifdef USEMPI + IF (p_is_io) THEN + IF (pixelset%nset > 0) THEN + allocate (iworker (pixelset%nset)) + allocate (msk (pixelset%nset)) + + ie = 1 + je = 1 + iblk = mesh(ie)%xblk + jblk = mesh(ie)%yblk + DO iset = 1, pixelset%nset + DO WHILE (pixelset%eindex(iset) /= mesh(ie)%indx) + ie = ie + 1 + je = je + 1 + IF ((mesh(ie)%xblk /= iblk) .or. (mesh(ie)%yblk /= jblk)) THEN + je = 1 + iblk = mesh(ie)%xblk + jblk = mesh(ie)%yblk + ENDIF + ENDDO + + nave = nelm_blk(iblk,jblk) / (p_np_group-1) + nres = mod(nelm_blk(iblk,jblk), p_np_group-1) + left = (nave+1) * nres + IF (je <= left) THEN + iworker(iset) = (je-1) / (nave+1) + 1 + ELSE + iworker(iset) = (je-left-1) / nave + 1 + nres + ENDIF + ENDDO + + DO iproc = 1, p_np_group-1 + msk = (iworker == iproc) + nsend = count(msk) + CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err) + + IF (nsend > 0) THEN + allocate (sbuff(nsend)) + sbuff = pack(pixelset%eindex, msk) + CALL mpi_send (sbuff, nsend, MPI_INTEGER8, iproc, mpi_tag_data, p_comm_group, p_err) + deallocate (sbuff) + ENDIF + ENDDO + ELSE + DO iproc = 1, p_np_group-1 + nsend = 0 + CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err) + ENDDO + ENDIF + + ENDIF + + IF (p_is_worker) THEN + + CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_stat, p_err) + + pixelset%nset = nrecv + IF (nrecv > 0) THEN + allocate (pixelset%eindex (nrecv)) + CALL mpi_recv (pixelset%eindex, nrecv, MPI_INTEGER8, & + p_root, mpi_tag_data, p_comm_group, p_stat, p_err) + ENDIF + ENDIF +#endif + + + CALL pixelset%set_vecgs + + CALL ncio_read_vector (filename, 'ipxstt', pixelset, pixelset%ipxstt) + CALL ncio_read_vector (filename, 'ipxend', pixelset, pixelset%ipxend) + CALL ncio_read_vector (filename, 'settyp', pixelset, pixelset%settyp) + + IF (p_is_worker) THEN + IF (pixelset%nset > 0) THEN + + allocate (pixelset%ielm (pixelset%nset)) + ie = 1 + DO iset = 1, pixelset%nset + DO WHILE (pixelset%eindex(iset) /= mesh(ie)%indx) + ie = ie + 1 + ENDDO + pixelset%ielm(iset) = ie + ENDDO + + ELSE + write(*,*) 'Warning: 0 ',trim(psetname), ' on worker :', p_iam_glb + ENDIF + ENDIF + + numset = pixelset%nset + + pixelset%has_shared = .false. + IF (p_is_worker) THEN + DO iset = 1, pixelset%nset-1 + IF ((pixelset%ielm(iset) == pixelset%ielm(iset+1)) & + .and. (pixelset%ipxstt(iset) == pixelset%ipxstt(iset+1))) THEN + pixelset%has_shared = .true. + exit + ENDIF + ENDDO + ENDIF + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, pixelset%has_shared, 1, MPI_LOGICAL, & + MPI_LOR, p_comm_glb, p_err) +#endif + + IF (pixelset%has_shared) THEN + CALL ncio_read_vector (filename, 'pctshared', pixelset, pixelset%pctshared) + ENDIF + +#ifdef CoLMDEBUG + IF (p_is_io) write(*,*) numset, trim(psetname), ' on group', p_iam_io +#endif + + IF (allocated(subset_sorted)) deallocate(subset_sorted) + + END SUBROUTINE pixelset_load_from_file + +END MODULE MOD_SrfdataRestart diff --git a/src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme b/src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme new file mode 100644 index 0000000000..856f508a89 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme @@ -0,0 +1,127 @@ +########################################################################################### + Rules to Name your nml file + + Your nml file should be named in following format: + + REGION{_STRUCTURE}{_RES}_LANDTYPE_SOILMODEL[_BGC][_URBAN][_LULCC].nml + + eg. Global_Grid_2x2_PFT_VG_BGC.nml + SiteCNDin_IGBP_CB.nml + + Please leave your name at begining of the namelist file, + eg. Author: Xingjie Lu +########################################################################################### + + Detailed description of each tag in the namelist format: + + Region (mandatory): + The abbrevation of the model simulation region. + Existing definitions of the model simulation regions includes: + + -------------------------------------------------------------------------------------- + Abbreviation Description Edges + -------------------------------------------------------------------------------------- + Global Global region: edges = -90.0; edgen = 90.0; + edgew = -180.0; edgee = 180.0 + RegChina China region: edges = 18.0; edgen = 54.0; + edgew = 73.0; edgee = 135.0 + RegPearl Pearl catchment region: edges = 21.0; edgen = 27.0; + edgew = 100.0; edgee = 115.0 + RegTibet Tibet Plateau region: edges = 25.0; edgen = 40.0; + edgew = 75.0; edgee = 105.0 + ... + SiteCNDin Dinghushan site: latitude = 23.17329979; + longitude = 112.5361023 + ... + -------------------------------------------------------------------------------------- + + STRUCTURE (conditional, only applicable for global and regional simulation, not for site) + The abbreviation of the model spatial structure. + Existing definitions of the model spatail structure includes: + + -------------------------------------------------------------------------------------- + Abbreviation Description + -------------------------------------------------------------------------------------- + Grid Latitude-longitude grid: grid cells are partitioned by latitudes + and longitudes with a constant interval. + Unstr Unstructure grid: grid cells are formed by polygons according to the + heteorogeneity of soil properties, vegetation types and ... + Catch Catchment grid: grid cells represent catchment units, + which is generated from the DEM data. + -------------------------------------------------------------------------------------- + + RES (conditional: only applicable when "STRUCTURE=Grid"): + The abbreviation of the grid resolution. + Existing definitions of grid resolution includes: + + --------------------------------------------------------------------------------------- + Abbreviation Description (longitude resolution x latitude resolution (in degree)) + --------------------------------------------------------------------------------------- + 2x2 2.5x1.875 + 1x1 1x1 + 50km 0.5x0.5 + 25km 0.25x0.25 + 10km 0.1x0.1 + --------------------------------------------------------------------------------------- + + LANDTYPE (mandatory): + The abbreviation of the land cover type classification, including the subgrid structure. + Existing definition of the land cover type classification includes: + + --------------------------------------------------------------------------------------- + Abbreviation Description Patch subgrid + --------------------------------------------------------------------------------------- + USGS USGS land cover patch No patch subgrid + IGBP IGBP land cover patch No patch subgrid + PFT IGBP land cover patch All soil patches within a grid cell has been + with plant functional aggregated and divided into multiple PFT + type subgrid subgrids + PC IGBP land cover patch Each IGBP patch has been divided into + with plant community multiple PFT subgrids + subgrid. + --------------------------------------------------------------------------------------- + + SOILMODEL (mandatory): + The abbreviation of soil hydraulics models. + Existing definition of the soil hydraulics models include: + + --------------------------------------------------------------------------------------- + Abbreviation Long name + --------------------------------------------------------------------------------------- + CB Campbell model + VG vanGenuchten Mualem model + --------------------------------------------------------------------------------------- + + BGC (optional, if not present, the namelist must indicate a bgc off simulation): + The abbreviation of biogeochemical model switches. + Existing definition of the biogeochemical model switches include: + + --------------------------------------------------------------------------------------- + Abbreviation Description + --------------------------------------------------------------------------------------- + (not present) BGC is turned off + BGC BGC is defined, but CROP is undef in define.h + BGCCROP Both BGC and CROP are defined in define.h + --------------------------------------------------------------------------------------- + + URBAN (optional, if not present, the namelist must correspond to a no urban simulation): + The abbreviation of urban model switches. + Existing definition of the urban model switches include: + + --------------------------------------------------------------------------------------- + Abbreviation Description + --------------------------------------------------------------------------------------- + (not present) The urban model is turned off + URBAN URBAN is defined, and the urban model is on + --------------------------------------------------------------------------------------- + + LULCC (optional, if not present, the namelist must correspond to a no land use change simulation): + The abbreviation of land use change model switches. + Existing definition of the land use change model switches include: + + --------------------------------------------------------------------------------------- + Abbreviation Description + --------------------------------------------------------------------------------------- + (not present) The land use change model is turned off + LULCC LULCC is defined, and the land use change model is on + --------------------------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml new file mode 100644 index 0000000000..cdb1482240 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml @@ -0,0 +1,71 @@ +&nl_colm + +! Author: Zhongwang Wei +! Description : include soil state init from data. + + DEF_CASE_NAME = 'CRA40' + + + DEF_domain%edges = 20.0 + DEF_domain%edgen = 25.0 + DEF_domain%edgew = 109.0 + DEF_domain%edgee = 118.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 1980 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 21600 + DEF_simulation_time%end_year = 2015 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/share/home/dq013/zhwei/colm/data/CoLMrawdata/' + DEF_dir_runtime = '/share/home/dq013/zhwei/colm/data/CoLMruntime/' + DEF_dir_output = '/share/home/dq013/zhwei/colm/cases/' + + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/share/home/dq013/zhwei/colm/data/soilstate/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + DEF_USE_PLANTHYDRAULICS = .false. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '/share/home/dq013/zhwei/colm/CoLM202X-CRA40/CoLM202X/run/forcing/CRA40.nml' + + ! ----- history ----- + DEF_hist_grid_as_forcing = .true. + DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_CompressLevel = 1 + DEF_HIST_CompressLevel = 1 + + DEF_HIST_WriteBack = .true. + + DEF_hist_vars_out_default = .true. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml new file mode 100644 index 0000000000..f96a47da06 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml @@ -0,0 +1,68 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : include soil state init from data. + + DEF_CASE_NAME = 'China_Grid_10km_IGBP_VG' + + DEF_domain%edges = 0.0 + DEF_domain%edgen = 55.0 + DEF_domain%edgew = 70.0 + DEF_domain%edgee = 140.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2010 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2015 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/tera07/CoLMrawdata/' + DEF_dir_runtime = '/tera07/CoLMruntime/' + DEF_dir_output = '/tera05/zhangsp/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/tera05/zhangsp/data/soilstate/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + DEF_USE_PLANTHYDRAULICS = .false. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '/tera04/zhangsp/git/CoLM202X/run/forcing/ERA5LAND.nml' + + ! ----- history ----- + DEF_hist_grid_as_forcing = .true. + DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_CompressLevel = 1 + DEF_HIST_CompressLevel = 1 + + DEF_HIST_WriteBack = .true. + + DEF_hist_vars_out_default = .true. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml new file mode 100644 index 0000000000..2a1595c3b7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml @@ -0,0 +1,69 @@ +&nl_colm + +!Author: Xingjie Lu + + DEF_CASE_NAME = 'GlobalBGCPFTnoCROPHist1851-2014-newPHS' + + DEF_domain%edges = -90.0 + DEF_domain%edgen = 90.0 + DEF_domain%edgew = -180.0 + DEF_domain%edgee = 180.0 + + DEF_nx_blocks = 18 + DEF_ny_blocks = 9 + DEF_PIO_groupsize = 12 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 1849 + DEF_simulation_time%start_month = 12 + DEF_simulation_time%start_day = 31 + DEF_simulation_time%start_sec = 86400 + DEF_simulation_time%end_year = 2014 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CLMrawdata_updating//' + DEF_dir_runtime = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime//' + DEF_dir_output = '/share/home/dq010/CoLM/CoLM202X-CROP/cases/' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 2.5 + DEF_GRIDBASED_lat_res = 1.875 + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + ! Canopy DEF Interception scheme selection + DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC +! DEF_USE_IRRIGATION = .true. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP//run/forcing/GSWP3-boat.nml' + + ! ----- history ----- + DEF_hist_lon_res = 2.5 + DEF_hist_lat_res = 1.875 + DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_CompressLevel = 1 + DEF_HIST_CompressLevel = 1 + + DEF_hist_vars_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP/cases/GlobalBGCPFTnoCROPHist1851-2014-newPHS/history.nml' + DEF_hist_vars_out_default = .true. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml new file mode 100644 index 0000000000..cfd4823a80 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml @@ -0,0 +1,126 @@ +&nl_colm + +!Author: Wenzong Dong + + DEF_CASE_NAME = 'GlobalURBANIGBPHist2000-2016' + + DEF_domain%edges = -90.0 + DEF_domain%edgen = 90.0 + DEF_domain%edgew = -180.0 + DEF_domain%edgee = 180.0 + + DEF_nx_blocks = 30 + DEF_ny_blocks = 30 + DEF_PIO_groupsize = 6 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 1995 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2016 + DEF_simulation_time%end_month = 1 + DEF_simulation_time%end_day = 1 + DEF_simulation_time%end_sec = 0 + DEF_simulation_time%spinup_year = 2000 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 1 + DEF_simulation_time%spinup_sec = 0 + DEF_simulation_time%spinup_repeat= 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/stu01/dongwz/data/CoLMrawdata/' + DEF_dir_runtime = '/stu01/dongwz/data/CoLMruntime/' + DEF_dir_output = '/stu01/dongwz/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + ! LandCover setting + DEF_LC_YEAR = 2005 + + ! ----Soil Surface Resistance options---- + ! 0: NONE soil surface resistance + ! 1: SL14, Swenson and Lawrence (2014) + ! 2: SZ09, Sakaguchi and Zeng (2009) + ! 3: TR13, Tang and Riley (2013) + ! 4: LP92, Lee and Pielke (1992) + ! 5: S92, Sellers et al (1992) + DEF_RSS_SCHEME = 1 + + !---- Urban options ---- + ! urban type options + ! Options : + ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density + ! 2: LCZ Classification, 10 urban type with LCZ 1-10 + DEF_URBAN_type_scheme = 1 + + ! urban module options + DEF_URBAN_ONLY = .false. + DEF_URBAN_TREE = .true. + DEF_URBAN_WATER= .true. + DEF_URBAN_BEM = .true. + DEF_URBAN_LUCY = .true. + ! ----------------------- + + ! Canopy DEF Interception scheme selection + DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC + + ! ---- Hydrology module ---- + DEF_USE_SUPERCOOL_WATER = .false. + DEF_USE_VariablySaturatedFlow = .false. + DEF_USE_PLANTHYDRAULICS = .false. + ! -------------------------- + + ! ---- SNICAR ---- + DEF_USE_SNICAR = .false. + DEF_Aerosol_Readin = .true. + DEF_Aerosol_Clim = .false. + ! ---------------- + + ! ---- Ozone MODULE ---- + DEF_USE_OZONESTRESS = .false. + DEF_USE_OZONEDATA = .false. + ! ---------------------- + + ! ---- Bedrock ---- + DEF_USE_BEDROCK = .false. + ! ----------------- + + ! ---- Split Soil Snow ---- + DEF_SPLIT_SOILSNOW = .false. + ! ------------------------- + + ! ---- Forcing Downscalling ---- + DEF_USE_Forcing_Downscaling = .false. + DEF_DS_precipitation_adjust_scheme = 'II' + DEF_DS_longwave_adjust_scheme = 'II' + ! ------------------------------ + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '../forcing/CRUNCEPV7.nml' + + ! ----- history ----- + DEF_hist_lon_res = 0.5 + DEF_hist_lat_res = 0.5 + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_CompressLevel = 1 + DEF_HIST_CompressLevel = 1 + + DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' + DEF_hist_vars_out_default = .true. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml new file mode 100644 index 0000000000..bd6d2ff194 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml @@ -0,0 +1,73 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : include soil state init from data. + + DEF_CASE_NAME = 'GreaterBay_Grid_10km_IGBP_VG' + + DEF_domain%edges = 20.0 + DEF_domain%edgen = 25.0 + DEF_domain%edgew = 109.0 + DEF_domain%edgee = 118.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2010 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2010 + DEF_simulation_time%end_month = 1 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/tera07/CoLMrawdata/' + DEF_dir_runtime = '/tera07/CoLMruntime/' + DEF_dir_output = '/tera13/zhangsp/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.05 + DEF_GRIDBASED_lat_res = 0.05 + DEF_file_mesh_filter = '/tera13/zhangsp/landdata/filter/greaterbay_1km_filter.nc' + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/tera13/zhangsp/landdata/soilstate/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + DEF_USE_BEDROCK = .true. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '/tera13/zhangsp/work/CoLM2024/run/forcing/ERA5LAND.nml' + + DEF_Forcing_Interp_Method = 'arealweight' ! 'arealweight' (default) or 'bilinear' + + ! ----- history ----- + DEF_HIST_lon_res = 0.05 + DEF_HIST_lat_res = 0.05 + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_CompressLevel = 1 + DEF_HIST_CompressLevel = 1 + + DEF_HIST_WriteBack = .false. + + DEF_hist_vars_out_default = .false. + DEF_hist_vars_namelist = '/tera13/zhangsp/work/CoLM2024/run/history.nml' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml new file mode 100644 index 0000000000..4c418a4f3d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml @@ -0,0 +1,53 @@ +&nl_colm + + DEF_CASE_NAME = 'PearlRiver_100km' + + DEF_domain%edges = 20.0 + DEF_domain%edgen = 30.0 + DEF_domain%edgew = 100.0 + DEF_domain%edgee = 115.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2000 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2003 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 2000 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 1 + DEF_simulation_time%spinup_sec = 0 + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/tera07/CLMrawdata/' + DEF_dir_runtime = '/tera07/CoLMruntime/' + DEF_dir_output = '/tera05/zhangsp/cases/' + + DEF_CatchmentMesh_data = '/tera04/zhangsp/hillslope/output/pearl_100km2.nc' + DEF_ElementNeighbour_file = '/tera04/zhangsp/hillslope/output/pearl_100km2.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + ! ----- forcing ----- + DEF_forcing_namelist = '/tera04/zhangsp/git/CoLM202X/run/forcing/CRUJRA.nml' + + ! ----- history ----- + DEF_HISTORY_IN_VECTOR = .false. + DEF_hist_grid_as_forcing = .true. + + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_CompressLevel = 1 + DEF_HIST_CompressLevel = 1 + + DEF_hist_vars_out_default = .false. + DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM2024/run/history.nml' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml new file mode 100644 index 0000000000..234118c956 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml @@ -0,0 +1,65 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : an example to use dynamic lake. + + DEF_CASE_NAME = 'PoyangLake_Grid_5km_IGBP_VG' + + DEF_domain%edges = 28.0 + DEF_domain%edgen = 30.0 + DEF_domain%edgew = 115.0 + DEF_domain%edgee = 117.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2010 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2020 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/shr03/CoLMrawdata/' + DEF_dir_runtime = '/shr03/CoLMruntime/' + DEF_dir_output = '/tera13/zhangsp/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.05 + DEF_GRIDBASED_lat_res = 0.05 + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/shr03/CoLMruntime/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + DEF_USE_Dynamic_Lake = .true. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '/tera13/zhangsp/work/CoLM2024/run/forcing/CRUJRA.nml' + + ! ----- history ----- + DEF_HIST_lon_res = 0.05 + DEF_HIST_lat_res = 0.05 + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + + DEF_hist_vars_out_default = .false. + DEF_HIST_vars_namelist = 'run/hist_dynamic_lake.nml' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml new file mode 100644 index 0000000000..c9fa04d00c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml @@ -0,0 +1,110 @@ +&nl_colm + +!Author: Wanyi Lin + + DEF_CASE_NAME = 'RegChina_Grid_50km_IGBP_CB_LULCC.nml' + + DEF_domain%edges = 18.0 + DEF_domain%edgen = 54.0 + DEF_domain%edgew = 73.0 + DEF_domain%edgee = 135.0 + + DEF_nx_blocks = 30 + DEF_ny_blocks = 30 + DEF_PIO_groupsize = 6 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2002 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2003 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 2000 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 1 + DEF_simulation_time%spinup_sec = 0 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/tera07/CoLMrawdata/' + DEF_dir_runtime = '/tera07/CoLMruntime/' + DEF_dir_output = '/home/linwy20/stu01/colm202x-master/case' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_file_mesh = 'NONE' + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .true. + + ! LandCover setting + DEF_LC_YEAR = 2002 + + ! Land use change scheme selection + DEF_LULCC_SCHEME = 2 + + ! Canopy DEF Interception scheme selection + DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC + + ! ---------- Hydrology module --------- + DEF_USE_SUPERCOOL_WATER = .false. + DEF_USE_VariablySaturatedFlow = .false. + DEF_USE_PLANTHYDRAULICS = .false. + ! ------------------------------------- + + ! --------- SNICAR --------- + DEF_USE_SNICAR = .false. + DEF_Aerosol_Readin = .true. + DEF_Aerosol_Clim = .false. + ! -------------------------- + + ! ------ Ozone MODULE ------ + DEF_USE_OZONESTRESS = .false. + DEF_USE_OZONEDATA = .false. + ! -------------------------- + + ! ------- Bedrock ------- + DEF_USE_BEDROCK = .false. + ! ----------------------- + + ! ---- Split Soil Snow ---- + DEF_SPLIT_SOILSNOW = .false. + ! ------------------------- + + ! ---------- Forcing Downscalling ---------- + DEF_USE_Forcing_Downscaling = .false. + DEF_DS_precipitation_adjust_scheme = 'II' + DEF_DS_longwave_adjust_scheme = 'II' + ! ------------------------------------------ + + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + ! CLDAS + DEF_forcing_namelist = './forcing/GSWP3.nml' + + ! ----- history ----- + DEF_hist_grid_as_forcing = .false. + DEF_hist_lon_res = 0.5 + DEF_hist_lat_res = 0.5 + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + + DEF_REST_COMPRESS_LEVEL = 1 + DEF_HIST_COMPRESS_LEVEL = 1 + + DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' + DEF_hist_vars_out_default = .true. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml new file mode 100644 index 0000000000..feaa1e83ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml @@ -0,0 +1,64 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : an example for SinglePoint with all surface data from database instead of observations. + + DEF_CASE_NAME = 'SiteSYSUAtmos_IGBP_VG' + + SITE_lon_location = 113.5897 + SITE_lat_location = 22.3507 + + USE_SITE_landtype = .false. + USE_SITE_htop = .false. + USE_SITE_LAI = .false. + USE_SITE_lakedepth = .false. + USE_SITE_soilreflectance = .false. + USE_SITE_soilparameters = .false. + USE_SITE_dbedrock = .false. + USE_SITE_topography = .false. + USE_SITE_topostd = .false. + USE_SITE_BVIC = .false. + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 1951 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 1951 + DEF_simulation_time%end_month = 1 + DEF_simulation_time%end_day = 11 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/shr03/CoLMrawdata/' + DEF_dir_runtime = '/shr03/CoLMruntime/' + DEF_dir_output = '/tera09/training/CoLM202X-Tutorial/cases/' + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/tera13/zhangsp/landdata/soilstate/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q + DEF_forcing_namelist = '/tera13/zhangsp/work/CoLM2024/run/forcing/ERA5LAND.nml' + + ! ----- history ----- + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + + DEF_hist_vars_out_default = .true. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml new file mode 100644 index 0000000000..9ed55af006 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml @@ -0,0 +1,353 @@ +&nl_colm_history + + ! ----------- history ------------ + ! A full list of output variables. + + DEF_hist_vars%xy_us = .true. + DEF_hist_vars%xy_vs = .true. + DEF_hist_vars%xy_t = .true. + DEF_hist_vars%xy_q = .true. + DEF_hist_vars%xy_prc = .true. + DEF_hist_vars%xy_prl = .true. + DEF_hist_vars%xy_pbot = .true. + DEF_hist_vars%xy_frl = .true. + DEF_hist_vars%xy_solarin = .true. + DEF_hist_vars%xy_rain = .true. + DEF_hist_vars%xy_snow = .true. + DEF_hist_vars%xy_ozone = .true. + DEF_hist_vars%xy_hpbl = .true. + + DEF_hist_vars%taux = .true. + DEF_hist_vars%tauy = .true. + DEF_hist_vars%fsena = .true. + DEF_hist_vars%lfevpa = .true. + DEF_hist_vars%fevpa = .true. + DEF_hist_vars%fsenl = .true. + DEF_hist_vars%fevpl = .true. + DEF_hist_vars%etr = .true. + DEF_hist_vars%fseng = .true. + DEF_hist_vars%fevpg = .true. + DEF_hist_vars%fgrnd = .true. + DEF_hist_vars%sabvsun = .true. + DEF_hist_vars%sabvsha = .true. + DEF_hist_vars%sabg = .true. + DEF_hist_vars%olrg = .true. + DEF_hist_vars%rnet = .true. + DEF_hist_vars%xerr = .true. + DEF_hist_vars%zerr = .true. + DEF_hist_vars%rsur = .true. + DEF_hist_vars%rsur_se = .true. + DEF_hist_vars%rsur_ie = .true. + DEF_hist_vars%rsub = .true. + DEF_hist_vars%rnof = .true. + DEF_hist_vars%xwsur = .true. + DEF_hist_vars%xwsub = .true. + DEF_hist_vars%qintr = .true. + DEF_hist_vars%qinfl = .true. + DEF_hist_vars%qdrip = .true. + DEF_hist_vars%wat = .true. + DEF_hist_vars%wat_inst = .true. + DEF_hist_vars%wetwat = .true. + DEF_hist_vars%wetwat_inst = .true. + DEF_hist_vars%assim = .true. + DEF_hist_vars%respc = .true. + DEF_hist_vars%qcharge = .true. + DEF_hist_vars%t_grnd = .true. + DEF_hist_vars%tleaf = .true. + DEF_hist_vars%ldew = .true. + DEF_hist_vars%scv = .true. + DEF_hist_vars%snowdp = .true. + DEF_hist_vars%fsno = .true. + DEF_hist_vars%sigf = .true. + DEF_hist_vars%green = .true. + DEF_hist_vars%lai = .true. + DEF_hist_vars%laisun = .true. + DEF_hist_vars%laisha = .true. + DEF_hist_vars%sai = .true. + DEF_hist_vars%alb = .true. + DEF_hist_vars%emis = .true. + DEF_hist_vars%z0m = .true. + DEF_hist_vars%trad = .true. + DEF_hist_vars%rss = .true. + DEF_hist_vars%tref = .true. + DEF_hist_vars%qref = .true. + + DEF_hist_vars%fsen_roof = .true. + DEF_hist_vars%fsen_wsun = .true. + DEF_hist_vars%fsen_wsha = .true. + DEF_hist_vars%fsen_gimp = .true. + DEF_hist_vars%fsen_gper = .true. + DEF_hist_vars%fsen_urbl = .true. + DEF_hist_vars%lfevp_roof = .true. + DEF_hist_vars%lfevp_gimp = .true. + DEF_hist_vars%lfevp_gper = .true. + DEF_hist_vars%lfevp_urbl = .true. + DEF_hist_vars%fhac = .true. + DEF_hist_vars%fwst = .true. + DEF_hist_vars%fach = .true. + DEF_hist_vars%fhah = .true. + DEF_hist_vars%meta = .true. + DEF_hist_vars%vehc = .true. + DEF_hist_vars%t_room = .true. + DEF_hist_vars%tafu = .true. + DEF_hist_vars%t_roof = .true. + DEF_hist_vars%t_wall = .true. + + DEF_hist_vars%assimsun = .true. + DEF_hist_vars%assimsha = .true. + DEF_hist_vars%etrsun = .true. + DEF_hist_vars%etrsha = .true. + + DEF_hist_vars%leafc = .true. + DEF_hist_vars%leafc_storage = .true. + DEF_hist_vars%leafc_xfer = .true. + DEF_hist_vars%frootc = .true. + DEF_hist_vars%frootc_storage = .true. + DEF_hist_vars%frootc_xfer = .true. + DEF_hist_vars%livestemc = .true. + DEF_hist_vars%livestemc_storage = .true. + DEF_hist_vars%livestemc_xfer = .true. + DEF_hist_vars%deadstemc = .true. + DEF_hist_vars%deadstemc_storage = .true. + DEF_hist_vars%deadstemc_xfer = .true. + DEF_hist_vars%livecrootc = .true. + DEF_hist_vars%livecrootc_storage = .true. + DEF_hist_vars%livecrootc_xfer = .true. + DEF_hist_vars%deadcrootc = .true. + DEF_hist_vars%deadcrootc_storage = .true. + DEF_hist_vars%deadcrootc_xfer = .true. + DEF_hist_vars%grainc = .true. + DEF_hist_vars%grainc_storage = .true. + DEF_hist_vars%grainc_xfer = .true. + DEF_hist_vars%leafn = .true. + DEF_hist_vars%leafn_storage = .true. + DEF_hist_vars%leafn_xfer = .true. + DEF_hist_vars%frootn = .true. + DEF_hist_vars%frootn_storage = .true. + DEF_hist_vars%frootn_xfer = .true. + DEF_hist_vars%livestemn = .true. + DEF_hist_vars%livestemn_storage = .true. + DEF_hist_vars%livestemn_xfer = .true. + DEF_hist_vars%deadstemn = .true. + DEF_hist_vars%deadstemn_storage = .true. + DEF_hist_vars%deadstemn_xfer = .true. + DEF_hist_vars%livecrootn = .true. + DEF_hist_vars%livecrootn_storage = .true. + DEF_hist_vars%livecrootn_xfer = .true. + DEF_hist_vars%deadcrootn = .true. + DEF_hist_vars%deadcrootn_storage = .true. + DEF_hist_vars%deadcrootn_xfer = .true. + DEF_hist_vars%grainn = .true. + DEF_hist_vars%grainn_storage = .true. + DEF_hist_vars%grainn_xfer = .true. + DEF_hist_vars%retrasn = .true. + DEF_hist_vars%gpp = .true. + DEF_hist_vars%downreg = .true. + DEF_hist_vars%ar = .true. + DEF_hist_vars%cwdprod = .true. + DEF_hist_vars%cwddecomp = .true. + DEF_hist_vars%hr = .true. + DEF_hist_vars%fpg = .true. + DEF_hist_vars%fpi = .true. + DEF_hist_vars%gpp_enftemp = .false. !1 + DEF_hist_vars%gpp_enfboreal = .false. !2 + DEF_hist_vars%gpp_dnfboreal = .false. !3 + DEF_hist_vars%gpp_ebftrop = .false. !4 + DEF_hist_vars%gpp_ebftemp = .false. !5 + DEF_hist_vars%gpp_dbftrop = .false. !6 + DEF_hist_vars%gpp_dbftemp = .false. !7 + DEF_hist_vars%gpp_dbfboreal = .false. !8 + DEF_hist_vars%gpp_ebstemp = .false. !9 + DEF_hist_vars%gpp_dbstemp = .false. !10 + DEF_hist_vars%gpp_dbsboreal = .false. !11 + DEF_hist_vars%gpp_c3arcgrass = .false. !12 + DEF_hist_vars%gpp_c3grass = .false. !13 + DEF_hist_vars%gpp_c4grass = .false. !14 + DEF_hist_vars%leafc_enftemp = .false. !1 + DEF_hist_vars%leafc_enfboreal = .false. !2 + DEF_hist_vars%leafc_dnfboreal = .false. !3 + DEF_hist_vars%leafc_ebftrop = .false. !4 + DEF_hist_vars%leafc_ebftemp = .false. !5 + DEF_hist_vars%leafc_dbftrop = .false. !6 + DEF_hist_vars%leafc_dbftemp = .false. !7 + DEF_hist_vars%leafc_dbfboreal = .false. !8 + DEF_hist_vars%leafc_ebstemp = .false. !9 + DEF_hist_vars%leafc_dbstemp = .false. !10 + DEF_hist_vars%leafc_dbsboreal = .false. !11 + DEF_hist_vars%leafc_c3arcgrass = .false. !12 + DEF_hist_vars%leafc_c3grass = .false. !13 + DEF_hist_vars%leafc_c4grass = .false. !14 + + DEF_hist_vars%cphase = .true. + DEF_hist_vars%gddmaturity = .true. + DEF_hist_vars%gddplant = .true. + DEF_hist_vars%vf = .true. + DEF_hist_vars%hui = .true. + DEF_hist_vars%cropprod1c = .true. + DEF_hist_vars%cropprod1c_loss = .true. + DEF_hist_vars%cropseedc_deficit = .true. + DEF_hist_vars%grainc_to_cropprodc = .true. + DEF_hist_vars%plantdate_rainfed_temp_corn = .true. + DEF_hist_vars%plantdate_irrigated_temp_corn = .true. + DEF_hist_vars%plantdate_rainfed_spwheat = .true. + DEF_hist_vars%plantdate_irrigated_spwheat = .true. + DEF_hist_vars%plantdate_rainfed_wtwheat = .true. + DEF_hist_vars%plantdate_irrigated_wtwheat = .true. + DEF_hist_vars%plantdate_rainfed_temp_soybean = .true. + DEF_hist_vars%plantdate_irrigated_temp_soybean = .true. + DEF_hist_vars%plantdate_rainfed_cotton = .true. + DEF_hist_vars%plantdate_irrigated_cotton = .true. + DEF_hist_vars%plantdate_rainfed_rice = .true. + DEF_hist_vars%plantdate_irrigated_rice = .true. + DEF_hist_vars%plantdate_rainfed_sugarcane = .true. + DEF_hist_vars%plantdate_irrigated_sugarcane = .true. + DEF_hist_vars%plantdate_rainfed_trop_corn = .true. + DEF_hist_vars%plantdate_irrigated_trop_corn = .true. + DEF_hist_vars%plantdate_rainfed_trop_soybean = .true. + DEF_hist_vars%plantdate_irrigated_trop_soybean = .true. + DEF_hist_vars%plantdate_unmanagedcrop = .true. + DEF_hist_vars%cropprodc_rainfed_temp_corn = .true. + DEF_hist_vars%cropprodc_irrigated_temp_corn = .true. + DEF_hist_vars%cropprodc_rainfed_spwheat = .true. + DEF_hist_vars%cropprodc_irrigated_spwheat = .true. + DEF_hist_vars%cropprodc_rainfed_wtwheat = .true. + DEF_hist_vars%cropprodc_irrigated_wtwheat = .true. + DEF_hist_vars%cropprodc_rainfed_temp_soybean = .true. + DEF_hist_vars%cropprodc_irrigated_temp_soybean = .true. + DEF_hist_vars%cropprodc_rainfed_cotton = .true. + DEF_hist_vars%cropprodc_irrigated_cotton = .true. + DEF_hist_vars%cropprodc_rainfed_rice = .true. + DEF_hist_vars%cropprodc_irrigated_rice = .true. + DEF_hist_vars%cropprodc_rainfed_sugarcane = .true. + DEF_hist_vars%cropprodc_irrigated_sugarcane = .true. + DEF_hist_vars%cropprodc_rainfed_trop_corn = .true. + DEF_hist_vars%cropprodc_irrigated_trop_corn = .true. + DEF_hist_vars%cropprodc_rainfed_trop_soybean = .true. + DEF_hist_vars%cropprodc_irrigated_trop_soybean = .true. + DEF_hist_vars%cropprodc_unmanagedcrop = .true. + + DEF_hist_vars%grainc_to_seed = .true. + DEF_hist_vars%fert_to_sminn = .true. + + DEF_hist_vars%huiswheat = .true. + DEF_hist_vars%pdcorn = .true. + DEF_hist_vars%pdswheat = .true. + DEF_hist_vars%pdwwheat = .true. + DEF_hist_vars%pdsoybean = .true. + DEF_hist_vars%pdcotton = .true. + DEF_hist_vars%pdrice1 = .true. + DEF_hist_vars%pdrice2 = .true. + DEF_hist_vars%pdsugarcane = .true. + DEF_hist_vars%manunitro = .true. + DEF_hist_vars%fertnitro_corn = .true. + DEF_hist_vars%fertnitro_swheat = .true. + DEF_hist_vars%fertnitro_wwheat = .true. + DEF_hist_vars%fertnitro_soybean = .true. + DEF_hist_vars%fertnitro_cotton = .true. + DEF_hist_vars%fertnitro_rice1 = .true. + DEF_hist_vars%fertnitro_rice2 = .true. + DEF_hist_vars%fertnitro_sugarcane = .true. + DEF_hist_vars%irrig_method_corn = .true. + DEF_hist_vars%irrig_method_swheat = .true. + DEF_hist_vars%irrig_method_wwheat = .true. + DEF_hist_vars%irrig_method_soybean = .true. + DEF_hist_vars%irrig_method_cotton = .true. + DEF_hist_vars%irrig_method_rice1 = .true. + DEF_hist_vars%irrig_method_rice2 = .true. + DEF_hist_vars%irrig_method_sugarcane = .true. + + DEF_hist_vars%irrig_rate = .true. + DEF_hist_vars%deficit_irrig = .true. + DEF_hist_vars%sum_irrig = .true. + DEF_hist_vars%sum_irrig_count = .true. + + DEF_hist_vars%ndep_to_sminn = .true. + DEF_hist_vars%CONC_O2_UNSAT = .true. + DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT = .true. + DEF_hist_vars%abm = .true. + DEF_hist_vars%gdp = .true. + DEF_hist_vars%peatf = .true. + DEF_hist_vars%hdm = .true. + DEF_hist_vars%lnfm = .true. + + DEF_hist_vars%t_soisno = .true. + DEF_hist_vars%wliq_soisno = .true. + DEF_hist_vars%wice_soisno = .true. + + DEF_hist_vars%h2osoi = .true. + DEF_hist_vars%rstfacsun = .true. + DEF_hist_vars%rstfacsha = .true. + DEF_hist_vars%gssun = .true. + DEF_hist_vars%gssha = .true. + DEF_hist_vars%rootr = .true. + DEF_hist_vars%vegwp = .true. + DEF_hist_vars%BD_all = .true. + DEF_hist_vars%wfc = .true. + DEF_hist_vars%OM_density = .true. + DEF_hist_vars%wdsrf = .true. + DEF_hist_vars%wdsrf_inst = .true. + DEF_hist_vars%zwt = .true. + DEF_hist_vars%wa = .true. + DEF_hist_vars%wa_inst = .true. + + DEF_hist_vars%dz_lake = .true. + DEF_hist_vars%t_lake = .true. + DEF_hist_vars%lake_icefrac = .true. + + DEF_hist_vars%litr1c_vr = .true. + DEF_hist_vars%litr2c_vr = .true. + DEF_hist_vars%litr3c_vr = .true. + DEF_hist_vars%soil1c_vr = .true. + DEF_hist_vars%soil2c_vr = .true. + DEF_hist_vars%soil3c_vr = .true. + DEF_hist_vars%cwdc_vr = .true. + DEF_hist_vars%litr1n_vr = .true. + DEF_hist_vars%litr2n_vr = .true. + DEF_hist_vars%litr3n_vr = .true. + DEF_hist_vars%soil1n_vr = .true. + DEF_hist_vars%soil2n_vr = .true. + DEF_hist_vars%soil3n_vr = .true. + DEF_hist_vars%cwdn_vr = .true. + DEF_hist_vars%sminn_vr = .true. + + DEF_hist_vars%ustar = .true. + DEF_hist_vars%ustar2 = .true. + DEF_hist_vars%tstar = .true. + DEF_hist_vars%qstar = .true. + DEF_hist_vars%zol = .true. + DEF_hist_vars%rib = .true. + DEF_hist_vars%fm = .true. + DEF_hist_vars%fh = .true. + DEF_hist_vars%fq = .true. + DEF_hist_vars%us10m = .true. + DEF_hist_vars%vs10m = .true. + DEF_hist_vars%fm10m = .true. + DEF_hist_vars%sr = .true. + DEF_hist_vars%solvd = .true. + DEF_hist_vars%solvi = .true. + DEF_hist_vars%solnd = .true. + DEF_hist_vars%solni = .true. + DEF_hist_vars%srvd = .true. + DEF_hist_vars%srvi = .true. + DEF_hist_vars%srnd = .true. + DEF_hist_vars%srni = .true. + + DEF_hist_vars%solvdln = .true. + DEF_hist_vars%solviln = .true. + DEF_hist_vars%solndln = .true. + DEF_hist_vars%solniln = .true. + DEF_hist_vars%srvdln = .true. + DEF_hist_vars%srviln = .true. + DEF_hist_vars%srndln = .true. + DEF_hist_vars%srniln = .true. + + DEF_hist_vars%xsubs_bsn = .true. + DEF_hist_vars%xsubs_hru = .true. + DEF_hist_vars%riv_height = .true. + DEF_hist_vars%riv_veloct = .true. + DEF_hist_vars%discharge = .true. + DEF_hist_vars%wdsrf_hru = .true. + DEF_hist_vars%veloc_hru = .true. + + DEF_hist_vars%sensors = .true. +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml new file mode 100644 index 0000000000..2646cee645 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml @@ -0,0 +1,50 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/CLDAS/' + + DEF_forcing%dataset = 'CLDAS' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%regional = .true. + DEF_forcing%regbnd = 0.0 65.0 60.0 160.0 + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 2008 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2020 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 0 0 0 0 0 0 0 0 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'LAT' ! dimension name of latitude + DEF_forcing%lonname = 'LON' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'TMP/CLDAS_NRT_ASI_0P0625_HOR-TMP-' + DEF_forcing%fprefix(2) = 'SHU/CLDAS_NRT_ASI_0P0625_HOR-SHU-' + DEF_forcing%fprefix(3) = 'PRS/CLDAS_NRT_ASI_0P0625_HOR-PRS-' + DEF_forcing%fprefix(4) = 'PRE/CLDAS_NRT_ASI_0P0625_HOR-PRE-' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'WIN/CLDAS_NRT_ASI_0P0625_HOR-WIN-' + DEF_forcing%fprefix(7) = 'SSRA/CLDAS_NRT_ASI_0P0625_HOR-SSRA-' + DEF_forcing%fprefix(8) = 'tstr/CLDAS_NRT_ASI_0P0625_HOR-tstr-' + + + DEF_forcing%vname = 'TAIR' 'QAIR' 'PAIR' 'PRCP' 'NULL' 'WIND' 'SWDN' 'tstr' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml new file mode 100644 index 0000000000..8963774c67 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml @@ -0,0 +1,51 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/CMFD/' + + DEF_forcing%dataset = 'CMFD' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40.0 + DEF_forcing%HEIGHT_Q = 40.0 + + DEF_forcing%regional = .true. + DEF_forcing%regbnd = 15.0 55.0 70.0 140.0 + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' + + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2018 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 + DEF_forcing%offset = 5400 5400 5400 5400 0 5400 0 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'temp/temp_CMFD_V0106_B-01_03hr_010deg_' + DEF_forcing%fprefix(2) = 'shum/shum_CMFD_V0106_B-01_03hr_010deg_' + DEF_forcing%fprefix(3) = 'pres/pres_CMFD_V0106_B-01_03hr_010deg_' + DEF_forcing%fprefix(4) = 'prec/prec_CMFD_V0106_B-01_03hr_010deg_' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'wind/wind_CMFD_V0106_B-01_03hr_010deg_' + DEF_forcing%fprefix(7) = 'srad/srad_CMFD_V0106_B-01_03hr_010deg_' + DEF_forcing%fprefix(8) = 'lrad/lrad_CMFD_V0106_B-01_03hr_010deg_' + + + DEF_forcing%vname = 'temp' 'shum' 'pres' 'prec' 'NULL' 'wind' 'srad' 'lrad' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml new file mode 100644 index 0000000000..7d2a9c8bf0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml @@ -0,0 +1,51 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/share/home/dq013/zhwei/colm/data/CoLM_Forcing/CMFDv2/Data_forcing_03hr_010deg' + + DEF_forcing%dataset = 'CMFDv2' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40.0 + DEF_forcing%HEIGHT_Q = 40.0 + + DEF_forcing%regional = .true. + DEF_forcing%regbnd = 15.0 55.0 70.0 140.0 + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' + + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1951 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2020 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 + DEF_forcing%offset = 0 0 0 0 0 0 5400 0 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'Temp/temp_CMFD_V0200_B-01_03hr_010deg_' + DEF_forcing%fprefix(2) = 'SHum/shum_CMFD_V0200_B-01_03hr_010deg_' + DEF_forcing%fprefix(3) = 'Pres/pres_CMFD_V0200_B-01_03hr_010deg_' + DEF_forcing%fprefix(4) = 'Prec/prec_CMFD_V0200_B-01_03hr_010deg_' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'Wind/wind_CMFD_V0200_B-01_03hr_010deg_' + DEF_forcing%fprefix(7) = 'SRad/srad_CMFD_V0200_B-01_03hr_010deg_' + DEF_forcing%fprefix(8) = 'LRad/lrad_CMFD_V0200_B-01_03hr_010deg_' + + + DEF_forcing%vname = 'temp' 'shum' 'pres' 'prec' 'NULL' 'wind' 'srad' 'lrad' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'backward' 'instant' 'instant' 'backward' 'instant' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'uniform' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml new file mode 100644 index 0000000000..7d058b33ad --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml @@ -0,0 +1,50 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/CRA40/' + + DEF_forcing%dataset = 'CRA40' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + !DEF_forcing%has_missing_value = .true. + !DEF_forcing%missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1950 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2021 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 21600 21600 21600 21600 21600 21600 21600 21600 + DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'g0_lat_0' ! dimension name of latitude + DEF_forcing%lonname = 'g0_lon_1' ! dimension name of longitude + + DEF_forcing%groupby = 'year' ! file grouped by year/month + + + + DEF_forcing%fprefix(1) = 'CRA40_sp_t_u_v' + DEF_forcing%fprefix(2) = 'CRA40_sp_t_u_v' + DEF_forcing%fprefix(3) = 'CRA40_pres_remap' + DEF_forcing%fprefix(4) = 'CRA40_Radiation_precip_remap' + DEF_forcing%fprefix(5) = 'CRA40_sp_t_u_v' + DEF_forcing%fprefix(6) = 'CRA40_sp_t_u_v' + DEF_forcing%fprefix(7) = 'CRA40_Radiation_precip_remap' + DEF_forcing%fprefix(8) = 'CRA40_Radiation_precip_remap' + + + DEF_forcing%vname = 'TMP_GDS0_HTGL' 'SPF_H_GDS0_HTGL' 'PRES_P0_L1_GLL0' 'PRATE_P8_L1_GLL0_avg' 'U_GRD_GDS0_HTGL' 'V_GRD_GDS0_HTGL' 'DSWRF_P8_L1_GLL0_avg' 'DLWRF_P8_L1_GLL0_avg' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml new file mode 100644 index 0000000000..90ed744a6c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml @@ -0,0 +1,48 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/crujra_v2.5/' + + DEF_forcing%dataset = 'CRUJRA' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1901 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2022 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 21600 21600 21600 21600 21600 21600 21600 21600 + DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .false. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'year' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'tmp/crujra.v2.5.5d.tmp.' + DEF_forcing%fprefix(2) = 'spfh/crujra.v2.5.5d.spfh.' + DEF_forcing%fprefix(3) = 'pres/crujra.v2.5.5d.pres.' + DEF_forcing%fprefix(4) = 'pre/crujra.v2.5.5d.pre.' + DEF_forcing%fprefix(5) = 'ugrd/crujra.v2.5.5d.ugrd.' + DEF_forcing%fprefix(6) = 'vgrd/crujra.v2.5.5d.vgrd.' + DEF_forcing%fprefix(7) = 'dswrf/crujra.v2.5.5d.dswrf.' + DEF_forcing%fprefix(8) = 'dlwrf/crujra.v2.5.5d.dlwrf.' + + + DEF_forcing%vname = 'tmp' 'spfh' 'pres' 'pre' 'ugrd' 'vgrd' 'dswrf' 'dlwrf' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml new file mode 100644 index 0000000000..7cddcd5a4b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml @@ -0,0 +1,45 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/cruncep_v4/cruncep/' + + DEF_forcing%dataset = 'CRUNCEPV4' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1950 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2016 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 21600 21600 21600 21600 0 21600 21600 21600 + DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .false. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'LATIXY' ! dimension name of latitude + DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + DEF_forcing%fprefix(2) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + DEF_forcing%fprefix(3) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + DEF_forcing%fprefix(4) = 'Precip6Hrly/clmforc.cruncep.V4.c2011.0.5d.Prec.' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + DEF_forcing%fprefix(7) = 'Solar6Hrly/clmforc.cruncep.V4.c2011.0.5d.Solr.' + DEF_forcing%fprefix(8) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + + + DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml new file mode 100644 index 0000000000..c669c1f489 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml @@ -0,0 +1,45 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing ='/shr03/CoLM_Forcing/cruncep_v7/' + + DEF_forcing%dataset = 'CRUNCEPV7' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1950 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2016 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 21600 21600 21600 21600 0 21600 21600 21600 + DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .false. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'LATIXY' ! dimension name of latitude + DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' + DEF_forcing%fprefix(2) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' + DEF_forcing%fprefix(3) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' + DEF_forcing%fprefix(4) = 'Precip6Hrly/clmforc.cruncep.V7.c2016.0.5d.Prec.' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' + DEF_forcing%fprefix(7) = 'Solar6Hrly/clmforc.cruncep.V7.c2016.0.5d.Solr.' + DEF_forcing%fprefix(8) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' + + + DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml new file mode 100644 index 0000000000..15ae5fac2d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml @@ -0,0 +1,53 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5/' + + DEF_forcing%dataset = 'ERA5' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_mode = 'absolute' ! 'absolute' height to ground surface or + ! 'relative' height to tree/building top + ! if not speficied, default is absolute + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40.0 + DEF_forcing%HEIGHT_Q = 40.0 + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2024 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 1800 1800 1800 1800 1800 1800 0 1800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'latitude' ! dimension name of latitude + DEF_forcing%lonname = 'longitude' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = '2m_temperature/ERA5' + DEF_forcing%fprefix(2) = 'Specific_Humdity/ERA5' + DEF_forcing%fprefix(3) = 'surface_pressure/ERA5' + DEF_forcing%fprefix(4) = 'mean_total_precipitation_rate/ERA5' + DEF_forcing%fprefix(5) = '10m_u_component_of_wind/ERA5' + DEF_forcing%fprefix(6) = '10m_v_component_of_wind/ERA5' + DEF_forcing%fprefix(7) = 'mean_surface_downward_short_wave_radiation_flux/ERA5' + DEF_forcing%fprefix(8) = 'mean_surface_downward_long_wave_radiation_flux/ERA5' + + + DEF_forcing%vname = 't2m' 'q' 'sp' 'mtpr' 'u10' 'v10' 'msdwswrf' 'msdwlwrf' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'backward' 'instant' 'instant' 'backward' 'backward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + + DEF_forcing%CBL_fprefix = 'boundary_layer_height/ERA5' + DEF_forcing%CBL_vname = 'blh' + DEF_forcing%CBL_tintalgo = 'linear' + DEF_forcing%CBL_dtime = 3600 + DEF_forcing%CBL_offset = 3600 +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml new file mode 100644 index 0000000000..d4d8221da2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml @@ -0,0 +1,50 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5LAND/' + + DEF_forcing%dataset = 'ERA5LAND' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_mode = 'relative' ! 'absolute' height to ground surface or + ! 'relative' height to tree/building top + ! if not speficied, default is absolute + DEF_forcing%HEIGHT_V = 10.0 + DEF_forcing%HEIGHT_T = 10.0 + DEF_forcing%HEIGHT_Q = 10.0 + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1950 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2024 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 1800 1800 1800 1800 1800 1800 0 1800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'latitude' ! dimension name of latitude + DEF_forcing%lonname = 'longitude' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = '2m_temperature/ERA5LAND' + DEF_forcing%fprefix(2) = 'specific_humidity/ERA5LAND' + DEF_forcing%fprefix(3) = 'surface_pressure/ERA5LAND' + DEF_forcing%fprefix(4) = 'Precipitation_m_hr/ERA5LAND' + DEF_forcing%fprefix(5) = '10m_u_component_of_wind/ERA5LAND' + DEF_forcing%fprefix(6) = '10m_v_component_of_wind/ERA5LAND' + DEF_forcing%fprefix(7) = 'surface_solar_radiation_downwards_w_m2/ERA5LAND' + DEF_forcing%fprefix(8) = 'surface_thermal_radiation_downwards_w_m2/ERA5LAND' + + DEF_forcing%vname = 't2m' 'Q' 'sp' 'tp' 'u10' 'v10' 'ssrd' 'strd' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml new file mode 100644 index 0000000000..78007a1020 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml @@ -0,0 +1,50 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5/' + + DEF_forcing%dataset = 'ERA5' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40.0 + DEF_forcing%HEIGHT_Q = 40.0 + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2021 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 1800 1800 1800 1800 1800 1800 0 1800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'latitude' ! dimension name of latitude + DEF_forcing%lonname = 'longitude' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = '2m_temperature/ERA5' + DEF_forcing%fprefix(2) = 'Specific_Humdity/ERA5' + DEF_forcing%fprefix(3) = 'surface_pressure/ERA5' + DEF_forcing%fprefix(4) = 'mean_total_precipitation_rate/ERA5' + DEF_forcing%fprefix(5) = '10m_u_component_of_wind/ERA5' + DEF_forcing%fprefix(6) = '10m_v_component_of_wind/ERA5' + DEF_forcing%fprefix(7) = 'mean_surface_downward_short_wave_radiation_flux/ERA5' + DEF_forcing%fprefix(8) = 'mean_surface_downward_long_wave_radiation_flux/ERA5' + + + DEF_forcing%vname = 't2m' 'q' 'sp' 'mtpr' 'u10' 'v10' 'msdwswrf' 'msdwlwrf' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + + DEF_forcing%CBL_fprefix = 'boundary_layer_height/ERA5' + DEF_forcing%CBL_vname = 'blh' + DEF_forcing%CBL_tintalgo = 'linear' + DEF_forcing%CBL_dtime = 3600 + DEF_forcing%CBL_offset = 3600 +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml new file mode 100644 index 0000000000..6c40df842f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml @@ -0,0 +1,51 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/GDAS_GPCP/' + + DEF_forcing%dataset = 'GDAS' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%regional = .true. + DEF_forcing%regbnd = -60.0 90.0 -180.0 180.0 + + DEF_forcing%has_missing_value = .true. + missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 2002 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2021 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 + DEF_forcing%offset = 5400 5400 5400 5400 0 5400 0 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'GLDAS_GDAS_3H_Tair.' + DEF_forcing%fprefix(2) = 'GLDAS_GDAS_3H_Qair.' + DEF_forcing%fprefix(3) = 'GLDAS_GDAS_3H_Psurf.' + DEF_forcing%fprefix(4) = 'GLDAS_GDAS_3H_tot_prcip.' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'GLDAS_GDAS_3H_Wind.' + DEF_forcing%fprefix(7) = 'GLDAS_GDAS_3H_SWdown.' + DEF_forcing%fprefix(8) = 'GLDAS_GDAS_3H_LWdown.' + + + DEF_forcing%vname = 'Tair_f_inst' 'Qair_f_inst' 'Psurf_f_inst' 'Rainf_f_tavg' 'NULL' 'Wind_f_inst' 'SWdown_f_tavg' 'LWdown_f_tavg' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml new file mode 100644 index 0000000000..b53345f62f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml @@ -0,0 +1,44 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/GSWP3/' + + DEF_forcing%dataset = 'GSWP3' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1950 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2014 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 + DEF_forcing%offset = 5400 5400 5400 5400 0 5400 0 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .false. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'LATIXY' ! dimension name of latitude + DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(2) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(3) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(4) = 'Precip/clmforc.GSWP3.c2011.0.5x0.5.Prec.' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(7) = 'Solar/clmforc.GSWP3.c2011.0.5x0.5.Solr.' + DEF_forcing%fprefix(8) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' + + DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml new file mode 100644 index 0000000000..b9e914030c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml @@ -0,0 +1,68 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/IsoGSM/' + + DEF_forcing%dataset = 'IsoGSM' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1980 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2024 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 21600 21600 21600 21600 21600 21600 21600 21600 + DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'year' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'IsoGSM_temperature' + DEF_forcing%fprefix(2) = 'IsoGSM_Q' + DEF_forcing%fprefix(3) = 'IsoGSM_Pressure' + DEF_forcing%fprefix(4) = 'IsoGSM_prate' + DEF_forcing%fprefix(5) = 'IsoGSM_Wind' + DEF_forcing%fprefix(6) = 'IsoGSM_Wind' + DEF_forcing%fprefix(7) = 'IsoGSM_Radiation' + DEF_forcing%fprefix(8) = 'IsoGSM_Radiation' + + + DEF_forcing%vname = 'tmp2m' 'spfh2m' 'pressfc' 'pratesfc' 'ugrd10m' 'vgrd10m' 'dswrfsfc' 'dlwrfsfc' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + + DEF_forcing%precipitation_O18_fprefix = 'IsoGSM_prate' + DEF_forcing%precipitation_O18_vname = 'prate1sfc' + DEF_forcing%precipitation_O18_tintalgo = 'linear' + DEF_forcing%precipitation_O18_dtime = 21600 + DEF_forcing%precipitation_O18_offset = 10800 + + DEF_forcing%precipitation_H2_fprefix = 'IsoGSM_prate' + DEF_forcing%precipitation_H2_vname = 'prate2sfc' + DEF_forcing%precipitation_H2_tintalgo = 'linear' + DEF_forcing%precipitation_H2_dtime = 21600 + DEF_forcing%precipitation_H2_offset = 10800 + + DEF_forcing%water_vapor_O18_fprefix = 'IsoGSM_Q' + DEF_forcing%water_vapor_O18_vname = 'spfh12m' + DEF_forcing%water_vapor_O18_tintalgo = 'linear' + DEF_forcing%water_vapor_O18_dtime = 21600 + DEF_forcing%water_vapor_O18_offset = 10800 + + DEF_forcing%water_vapor_H2_fprefix = 'IsoGSM_Q' + DEF_forcing%water_vapor_H2_vname = 'spfh22m' + DEF_forcing%water_vapor_H2_tintalgo = 'linear' + DEF_forcing%water_vapor_H2_dtime = 21600 + DEF_forcing%water_vapor_H2_offset = 10800 +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml new file mode 100644 index 0000000000..e698a04a05 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml @@ -0,0 +1,47 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/JRA3Q/' + + DEF_forcing%dataset = 'JRA3Q' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 2003 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2024 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 0 0 0 1800 0 0 0 1800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'tmp2m/tmp2m' + DEF_forcing%fprefix(2) = 'spfh2m/spfh2m' + DEF_forcing%fprefix(3) = 'pres/pres' + DEF_forcing%fprefix(4) = 'tprate/tprate' + DEF_forcing%fprefix(5) = 'u/u' + DEF_forcing%fprefix(6) = 'v/v' + DEF_forcing%fprefix(7) = 'dswrf/dswrf' + DEF_forcing%fprefix(8) = 'dlwrf/dlwrf' + + + + DEF_forcing%vname = 'tmp2m-hgt-fc-gauss' 'spfh2m-hgt-fc-gauss' 'pres-sfc-fc-gauss' 'tprate1have-sfc-fc-gauss' 'ugrd10m-hgt-fc-gauss' 'vgrd10m-hgt-fc-gauss' 'dswrf1have-sfc-fc-gauss' 'dlwrf1have-sfc-fc-gauss' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'linear' 'linear' 'linear' 'coszen' 'linear' + + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml new file mode 100644 index 0000000000..884142b554 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml @@ -0,0 +1,46 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/JRA55-Final' + + DEF_forcing%dataset = 'JRA55' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1958 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2023 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 + DEF_forcing%offset = 0 0 0 5400 0 0 5400 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'tmp/tmp_' + DEF_forcing%fprefix(2) = 'spfh/spfh_' + DEF_forcing%fprefix(3) = 'pres/pres_' + DEF_forcing%fprefix(4) = 'tprat/tprat_' + DEF_forcing%fprefix(5) = 'ugrd/ugrd_' + DEF_forcing%fprefix(6) = 'vgrd/vgrd_' + DEF_forcing%fprefix(7) = 'dswrf/dswrf_' + DEF_forcing%fprefix(8) = 'dlwrf/dlwrf_' + + + DEF_forcing%vname = 'var11' 'var51' 'var1' 'var61' 'var33' 'var34' 'var204' 'var205' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml new file mode 100644 index 0000000000..c99da16be1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml @@ -0,0 +1,45 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/share/home/dq013/zhwei/colm/data/CoLM_Forcing/MPI-ESM1-2-HR/ssp585/' + + DEF_forcing%dataset = 'CMIP6' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40.0 + DEF_forcing%HEIGHT_Q = 40.0 + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 2016 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2100 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 + DEF_forcing%offset = 0 0 0 5400 0 0 0 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'year' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'tas/tas_1d' + DEF_forcing%fprefix(2) = 'huss/huss_1d' + DEF_forcing%fprefix(3) = 'ps/ps_1d' + DEF_forcing%fprefix(4) = 'pr/pr_1d' + DEF_forcing%fprefix(5) = 'uas/uas_1d' + DEF_forcing%fprefix(6) = 'vas/vas_1d' + DEF_forcing%fprefix(7) = 'rsds/rsds_1d' + DEF_forcing%fprefix(8) = 'rlds/rlds_1d' + + + DEF_forcing%vname = 'tas' 'huss' 'ps' 'pr' 'uas' 'vas' 'rsds' 'rlds' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml new file mode 100644 index 0000000000..e6635dcf91 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml @@ -0,0 +1,45 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/MSWX_V100/' + + DEF_forcing%dataset = 'MSWX' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2021 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 + DEF_forcing%offset = 5400 5400 5400 5400 5400 5400 0 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'Temp' + DEF_forcing%fprefix(2) = 'SpecHum' + DEF_forcing%fprefix(3) = 'Pres' + DEF_forcing%fprefix(4) = 'P' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'Wind' + DEF_forcing%fprefix(7) = 'SWd' + DEF_forcing%fprefix(8) = 'LWd' + + + DEF_forcing%vname = 'air_temperature' 'specific_humidity' 'surface_pressure' 'precipitation' 'NULL' 'wind_speed' 'downward_shortwave_radiation' 'downward_longwave_radiation' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml new file mode 100644 index 0000000000..4e4a773502 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml @@ -0,0 +1,31 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/PLUMBER2/Forcing/' + + DEF_forcing%dataset = 'POINT' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 100.0 + DEF_forcing%HEIGHT_T = 50. + DEF_forcing%HEIGHT_Q = 50. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 2013 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2020 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + + DEF_forcing%fprefix(1) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(2) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(3) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(4) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(5) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(6) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(7) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + DEF_forcing%fprefix(8) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' + + DEF_forcing%vname = 'Tair' 'Qair' 'Psurf' 'Precip' 'NULL' 'Wind' 'SWdown' 'LWdown' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml new file mode 100644 index 0000000000..8c965f6a64 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml @@ -0,0 +1,45 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/princeton-r/' + + DEF_forcing%dataset = 'PRINCETON' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1948 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2006 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 + DEF_forcing%offset = 0 0 0 0 0 0 0 0 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'latitude' ! dimension name of latitude + DEF_forcing%lonname = 'longitude' ! dimension name of longitude + + DEF_forcing%groupby = 'year' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'tas/tas_3hourly_' + DEF_forcing%fprefix(2) = 'shum/shum_3hourly_' + DEF_forcing%fprefix(3) = 'pres/pres_3hourly_' + DEF_forcing%fprefix(4) = 'prcp/prcp_3hourly_' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'wind/wind_3hourly_' + DEF_forcing%fprefix(7) = 'dswrf/dswrf_3hourly_' + DEF_forcing%fprefix(8) = 'dlwrf/dlwrf_3hourly_' + + + DEF_forcing%vname = 'tas' 'shum' 'pres' 'prcp' 'NULL' 'wind' 'dswrf' 'dlwrf' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml new file mode 100644 index 0000000000..ab97240b7d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml @@ -0,0 +1,45 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/qian/' + + DEF_forcing%dataset = 'QIAN' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1972 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2004 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 21600 0 10800 21600 0 + DEF_forcing%offset = 5400 5400 5400 10800 0 5400 0 0 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .false. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'LATIXY' ! dimension name of latitude + DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' + DEF_forcing%fprefix(2) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' + DEF_forcing%fprefix(3) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' + DEF_forcing%fprefix(4) = 'Precip6Hrly/clmforc.Qian.c2006.T62.Prec.' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' + DEF_forcing%fprefix(7) = 'Solar6Hrly/clmforc.Qian.c2006.T62.Solr.' + DEF_forcing%fprefix(8) = 'NULL' + + + DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'NULL' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'NULL' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml new file mode 100644 index 0000000000..0ff75008bc --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml @@ -0,0 +1,50 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/TPMFD/' + + DEF_forcing%dataset = 'TPMFD' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40.0 + DEF_forcing%HEIGHT_Q = 40.0 + + DEF_forcing%regional = .true. + DEF_forcing%regbnd = 25.4166 41.3818 61.0 105.678 + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2021 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 0 0 0 0 0 0 0 0 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'latitude' ! dimension name of latitude + DEF_forcing%lonname = 'longitude' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'temp/temp_' + DEF_forcing%fprefix(2) = 'shum/shum_' + DEF_forcing%fprefix(3) = 'pres/pres_' + DEF_forcing%fprefix(4) = 'prcp/prcp_' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'wind/wind_' + DEF_forcing%fprefix(7) = 'srad/srad_' + DEF_forcing%fprefix(8) = 'lrad/lrad_' + + + DEF_forcing%vname = 'temp' 'shum' 'pres' 'prcp' 'NULL' 'wind' 'srad' 'lrad' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml new file mode 100644 index 0000000000..c94765eed4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml @@ -0,0 +1,48 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/WFDE5/' + + DEF_forcing%dataset = 'WFDE5' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = '_FillValue' + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2019 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 + DEF_forcing%offset = 0 0 0 1800 0 0 0 1800 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .true. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'lat' ! dimension name of latitude + DEF_forcing%lonname = 'lon' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'near_surface_air_temperature/Tair_WFDE5_CRU_' + DEF_forcing%fprefix(2) = 'near_surface_specific_humidity/Qair_WFDE5_CRU_' + DEF_forcing%fprefix(3) = 'surface_air_pressure/PSurf_WFDE5_CRU_' + DEF_forcing%fprefix(4) = 'rainfall_plus_snowfall_flux_CRU_GPCP/precipitation_CRU_GPCP_' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'near_surface_wind_speed/Wind_WFDE5_CRU_' + DEF_forcing%fprefix(7) = 'surface_downwelling_shortwave_radiation/SWdown_WFDE5_CRU_' + DEF_forcing%fprefix(8) = 'surface_downwelling_longwave_radiation/LWdown_WFDE5_CRU_' + + + DEF_forcing%vname = 'Tair' 'Qair' 'PSurf' 'precipitation' 'NULL' 'Wind' 'SWdown' 'LWdown' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml new file mode 100644 index 0000000000..7c44a9cb49 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml @@ -0,0 +1,49 @@ +&nl_colm_forcing + + ! ----- forcing ----- + DEF_dir_forcing = '/shr03/CoLM_Forcing/WFDEI/' + + DEF_forcing%dataset = 'WFDEI' + DEF_forcing%solarin_all_band = .true. + DEF_forcing%HEIGHT_V = 50.0 + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = '_FillValue' + + + DEF_forcing%NVAR = 8 ! variable number of forcing data + DEF_forcing%startyr = 1979 ! start year of forcing data + DEF_forcing%startmo = 1 ! start month of forcing data + DEF_forcing%endyr = 2016 ! end year of forcing data + DEF_forcing%endmo = 12 ! end month of forcing data + DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 + DEF_forcing%offset = 0 0 0 5400 0 0 0 5400 + DEF_forcing%nlands = 1 ! land grid number in 1d + + DEF_forcing%leapyear = .false. ! leapyear calendar + DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) + DEF_forcing%hightdim = .false. ! have "z" dimension + DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + DEF_forcing%latname = 'LATIXY' ! dimension name of latitude + DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude + + DEF_forcing%groupby = 'month' ! file grouped by year/month + + DEF_forcing%fprefix(1) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(2) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(3) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(4) = 'clmforc.WFDEI.c2017.0.5x0.5.Prec.' + DEF_forcing%fprefix(5) = 'NULL' + DEF_forcing%fprefix(6) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' + DEF_forcing%fprefix(7) = 'clmforc.WFDEI.c2017.0.5x0.5.Solr.' + DEF_forcing%fprefix(8) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' + + + DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' + DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' + DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt b/src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt new file mode 100644 index 0000000000..0b04883dcc --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt @@ -0,0 +1,5 @@ + NX 360 + NY 200 + NLFP 10 + REGIONALL 1 + NSEQMAX 41455 diff --git a/src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml b/src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml new file mode 100644 index 0000000000..c082d9ffea --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml @@ -0,0 +1,111 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : include soil state init from data. + + DEF_CASE_NAME = 'test_vic_para_global' + !DEF_file_mesh='/stu01/guoqj23/data/landtype/mask_zhujiang_0.5deg/mask_landtype9.nc' + !DEF_file_mesh='/stu01/guoqj23/data/landtype_mask/china_mask.nc' + + DEF_domain%edges = -90 + DEF_domain%edgen = 90 + DEF_domain%edgew = -180 + DEF_domain%edgee = 180 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2000 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2010 + DEF_simulation_time%end_month = 1 + DEF_simulation_time%end_day = 1 + DEF_simulation_time%end_sec = 0 + DEF_simulation_time%spinup_year = 2000 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 1 + DEF_simulation_time%spinup_sec = 0 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/shr03/CoLMrawdata/' + DEF_dir_runtime = '/shr03/CoLMruntime/' + DEF_dir_output = '/stu01/guoqj23/CoLM202X/cases/' + + !---- Run off setting ---- + DEF_file_VIC_para = './vic_para.txt' + DEF_VIC_OPT = .true. + DEF_file_VIC_OPT = '/stu01/guoqj23/CoLM202X/CoLM202X-20250829/vic_para.nc' + DEF_Runoff_SCHEME = 1 + + !---- LAI setting ---- + DEF_LC_YEAR = 2005 + + !---- Urban options ---- + ! urban type options + ! Options : + ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density + ! 2: LCZ Classification, 10 urban type with LCZ 1-10 + DEF_URBAN_type_scheme = 1 + + DEF_LAI_CHANGE_YEARLY=.false. + DEF_RSS_SCHEME = 1 + ! urban module options + DEF_URBAN_ONLY = .false. + DEF_URBAN_TREE = .true. + DEF_URBAN_WATER= .true. + DEF_URBAN_BEM = .true. + DEF_URBAN_LUCY = .true. + ! ----------------------- + + ! Canopy DEF Interception scheme selection + DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC + + ! ---- Hydrology module ---- + DEF_USE_SUPERCOOL_WATER = .false. + DEF_USE_VariablySaturatedFlow = .false. + DEF_USE_PLANTHYDRAULICS = .false. + ! -------------------------- + + ! ---- SNICAR ---- + DEF_USE_SNICAR = .false. + DEF_Aerosol_Readin = .true. + DEF_Aerosol_Clim = .false. + ! ---------------- + + ! ---- Ozone MODULE ---- + DEF_USE_OZONESTRESS = .false. + DEF_USE_OZONEDATA = .false. + ! ---------------------- + + ! ---- Bedrock ---- + DEF_USE_BEDROCK = .false. + ! ----------------- + + ! ---- Forcing Downscalling ---- + DEF_USE_Forcing_Downscaling = .false. + DEF_DS_precipitation_adjust_scheme = 'II' + DEF_DS_longwave_adjust_scheme = 'II' + + ! ----- forcing ----- + DEF_forcing_namelist = '/stu01/guoqj23/CoLM202X/CoLM202X-20250830/run/forcing/GSWP3.nml' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + ! ----- history ----- + DEF_hist_lon_res = 0.5 + DEF_hist_lat_res = 0.5 + DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'YEAR' ! history in one file: DAY/MONTH/YEAR + DEF_REST_CompressLevel = 0 + DEF_HIST_CompressLevel = 0 + + !DEF_hist_vars_namelist = '/stu01/guoqj23/CoLM202X/CoLM202X-0314vicsingle/run/history.nml' + !DEF_hist_vars_out_default = .false. + +/ diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 new file mode 100644 index 0000000000..4cc54435c0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 @@ -0,0 +1,554 @@ +#include + +MODULE MOD_5x5DataReadin + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Reading data in netCDF files by 5 degree blocks. +! +! The file name gives the boundaries of the block. +! For example, file "RG_65_75_60_80.URB2010.nc" stores data in region +! from 65N to 60N and 75E to 80E. +! +! Notice that: +! 1. Subroutines loop over all 5 degree blocks in simulation region. +! 2. Latitude in files is from north to south. +! 3. "read_5x5_data_pft" reads data with dimension "pft" and permute +! dimension (lon,lat,pft) in files to (pft,lon,lat) in variables. +! 4. "read_5x5_data_time" reads data with dimension "time" +! at given time. +! 5. "read_5x5_data_pft_time" reads data with dimension "pft" and "time" +! at given time and permute dimension (lon,lat,pft) in files +! to (pft,lon,lat) in variables. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_NetCDFSerial, only: nccheck + IMPLICIT NONE + + integer, parameter :: N_PFT_modis = 16 + + INTERFACE read_5x5_data + MODULE procedure read_5x5_data_int32 + MODULE procedure read_5x5_data_real8 + END INTERFACE read_5x5_data + + PUBLIC :: read_5x5_data_pft + PUBLIC :: read_5x5_data_time + PUBLIC :: read_5x5_data_pft_time + +CONTAINS + + ! ----- + SUBROUTINE this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + USE MOD_Grid + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + + integer, intent(in) :: nxbox, nybox, nxglb + integer, intent(in) :: isouth, inorth, iwest, ieast + integer, intent(inout) :: ibox, jbox, ibox0 + integer, intent(out) :: i0, i1, j0, j1 + integer, intent(out) :: il0, il1, jl0, jl1 + + character (len=*), intent(out) :: file_5x5 + + ! Local variables + integer :: xdsp, ydsp + character(len=4) :: str + + xdsp = (ibox-1) * nxbox + ydsp = (jbox-1) * nybox + + j0 = max(inorth-ydsp, 1) + j1 = min(isouth-ydsp, nybox) + jl0 = j0 + ydsp - inorth + 1 + jl1 = j1 + ydsp - inorth + 1 + + IF (ieast >= iwest) THEN + i0 = max(iwest-xdsp, 1) + i1 = min(ieast-xdsp, nxbox) + il0 = i0 + xdsp - iwest + 1 + il1 = i1 + xdsp - iwest + 1 + ELSE + IF (iwest <= xdsp+nxbox) THEN + i0 = max(iwest-xdsp, 1) + i1 = nxbox + il0 = i0 + xdsp - iwest + 1 + il1 = i1 + xdsp - iwest + 1 + ELSE + i0 = 1 + i1 = min(ieast-xdsp, nxbox) + il0 = i0 + xdsp + nxglb - iwest + 1 + il1 = i1 + xdsp + nxglb - iwest + 1 + ENDIF + ENDIF + + file_5x5 = trim(dir_5x5) // '/RG' + write(str, '(I4)') (19-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-37)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (18-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-36)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + file_5x5 = trim(file_5x5) // '.' // trim(sfx) // '.nc' + + IF ((ieast >= xdsp + 1) .and. (ieast <= xdsp + nxbox)) THEN + IF (isouth <= ydsp + nybox) THEN + jbox = -1 + ELSE + ibox = ibox0 + jbox = jbox + 1 + ENDIF + ELSE + ibox = mod(ibox, nxglb/nxbox) + 1 + ENDIF + + END SUBROUTINE this_block_and_move_to_next + + ! ----- + SUBROUTINE read_5x5_data_int32 (dir_5x5, sfx, grid, dataname, rdata) + + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + type (block_data_int32_2d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + integer, allocatable :: dcache(:,:) + logical :: fexists + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, (/i0,j0/), (/i1-i0+1,j1-j0+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + rdata%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_int32 + + ! ----- + SUBROUTINE read_5x5_data_real8 (dir_5x5, sfx, grid, dataname, rdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:) + logical :: fexists + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, (/i0,j0/), (/i1-i0+1,j1-j0+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + rdata%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache + + deallocate(dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_real8 + + ! ----- + SUBROUTINE read_5x5_data_pft (dir_5x5, sfx, grid, dataname, rdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + type (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:,:) + logical :: fexists + integer :: ipft + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1,0:N_PFT_modis-1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, & + (/i0,j0,1/), (/i1-i0+1,j1-j0+1,N_PFT_modis/)) ) + CALL nccheck( nf90_close(ncid) ) + + DO ipft = 0, N_PFT_modis-1 + rdata%blk(iblk,jblk)%val(ipft,il0:il1,jl0:jl1) = dcache(:,:,ipft) + ENDDO + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_pft + + ! ----- + SUBROUTINE read_5x5_data_time (dir_5x5, sfx, grid, dataname, time, rdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + integer, intent(in) :: time + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:) + logical :: fexists + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, & + (/i0,j0,time/), (/i1-i0+1,j1-j0+1,1/)) ) + CALL nccheck( nf90_close(ncid) ) + + rdata%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_time + + ! ----- + SUBROUTINE read_5x5_data_pft_time (dir_5x5, sfx, grid, dataname, time, rdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + integer, intent(in) :: time + type (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:,:) + logical :: fexists + integer :: ipft + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1,0:N_PFT_modis-1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, & + (/i0,j0,1,time/), (/i1-i0+1,j1-j0+1,N_PFT_modis,1/)) ) + CALL nccheck( nf90_close(ncid) ) + + DO ipft = 0, N_PFT_modis-1 + rdata%blk(iblk,jblk)%val(ipft,il0:il1,jl0:jl1) = dcache(:,:,ipft) + ENDDO + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_pft_time + +END MODULE MOD_5x5DataReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 new file mode 100644 index 0000000000..a3724e2e13 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 @@ -0,0 +1,635 @@ +#include + +MODULE MOD_Block + +!------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! To deal with high-resolution data, the globe is divided into blocks. +! +! (180W,90N) (180E,90N) +! .-----------------------------------. +! | | | | | +! | | | | | +! | | | | | +! .-----------------------------------. +! | | | | | +! | | | | | +! | | | | | +! .-----------------------------------. +! | | | | | +! | | | | | +! | | | | | +! .-----------------------------------. +! (180W,90S) (180E,90S) +! +! 1. +! Boundaries for block (i,j) is saved in +! "gblock%lat_s(j), gblock%lat_n(j), gblock%lon_w(i), gblock%lon_e(i)" +! for south, north, west and east boundaries respectively. +! +! 2. +! The (i,j) element of 2D array gblock%pio saves the global communication +! number of process which is in charge of Input/Output of block (i,j). +! +! 3. +! For Input/Output processes, "gblock%nblkme, gblock%xblkme(:), gblock%yblkme(:)" +! SAVE the locations of blocks which are handled by themselves. +! +! 4. +! Division of blocks can be generated by number of blocks globally (by set_by_size), +! or set by predefined boundaries in files (by set_by_file). +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + ! ---- data types ---- + type :: block_type + + ! Coordinates. + integer :: nxblk, nyblk + real(r8), allocatable :: lat_s (:) + real(r8), allocatable :: lat_n (:) + real(r8), allocatable :: lon_w (:) + real(r8), allocatable :: lon_e (:) + + ! IO. + integer, allocatable :: pio(:,:) + + integer :: nblkme + integer, allocatable :: xblkme(:), yblkme(:) + + CONTAINS + + procedure, PUBLIC :: set => block_set + + procedure, PUBLIC :: save_to_file => block_save_to_file + procedure, PUBLIC :: load_from_file => block_load_from_file + + procedure, PRIVATE :: clip => block_clip + procedure, PRIVATE :: init_pio => block_init_pio + procedure, PRIVATE :: read_pio => block_read_pio + + final :: block_free_mem + + END type block_type + + ! ---- Instance ---- + type (block_type) :: gblock + + + ! ---- PUBLIC SUBROUTINE ---- + PUBLIC :: get_filename_block + +CONTAINS + + ! -------------------------------- + SUBROUTINE block_set (this) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Utils + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + IMPLICIT NONE + + class (block_type) :: this + + ! Local Variables + logical :: fexists + integer :: iblk, jblk + + inquire(file=trim(DEF_BlockInfoFile), exist=fexists) + + IF (fexists) THEN + + CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lon_e', this%lon_e) + + this%nyblk = size(this%lat_s) + this%nxblk = size(this%lon_w) + + ! blocks should be from south to north + IF (this%lat_s(1) > this%lat_s(this%nyblk)) THEN + this%lat_s = this%lat_s(this%nyblk:1:-1) + this%lat_n = this%lat_n(this%nyblk:1:-1) + ENDIF + + ELSE + + IF (DEF_AverageElementSize > 0) THEN + + this%nxblk = floor(360./(DEF_AverageElementSize/120.*50)) + this%nxblk = min(this%nxblk,360) + DO WHILE ((this%nxblk < 360) .and. (mod(360,this%nxblk) /= 0)) + this%nxblk = this%nxblk + 1 + ENDDO + + this%nyblk = floor(180./(DEF_AverageElementSize/120.*50)) + this%nyblk = min(this%nyblk,180) + DO WHILE ((this%nyblk < 180) .and. (mod(180,this%nyblk) /= 0)) + this%nyblk = this%nyblk + 1 + ENDDO + + ELSE + + this%nxblk = DEF_nx_blocks + this%nyblk = DEf_ny_blocks + + ENDIF + + IF ((mod(360,this%nxblk) /= 0) .or. (mod(180,this%nyblk) /= 0)) THEN + IF (p_is_master) THEN + write(*,*) 'Number of blocks in longitude should be a factor of 360 ' + write(*,*) ' and Number of blocks in latitude should be a factor of 180.' + CALL CoLM_stop () + ENDIF + ENDIF + + allocate (this%lon_w (this%nxblk)) + allocate (this%lon_e (this%nxblk)) + + DO iblk = 1, this%nxblk + this%lon_w(iblk) = -180.0 + 360.0/this%nxblk * (iblk-1) + this%lon_e(iblk) = -180.0 + 360.0/this%nxblk * iblk + + CALL normalize_longitude (this%lon_w(iblk)) + CALL normalize_longitude (this%lon_e(iblk)) + ENDDO + + allocate (this%lat_s (this%nyblk)) + allocate (this%lat_n (this%nyblk)) + + DO jblk = 1, this%nyblk + this%lat_s(jblk) = -90.0 + 180.0/this%nyblk * (jblk-1) + this%lat_n(jblk) = -90.0 + 180.0/this%nyblk * jblk + ENDDO + + ENDIF + +#ifndef SinglePoint + IF (p_is_master) THEN + write (*,*) + write (*,'(A)') '----- Block information -----' + write (*,'(I4,A,I4,A)') this%nxblk, ' blocks in longitude,', & + this%nyblk, ' blocks in latitude.' + write (*,*) + ENDIF +#else + write(*,'(A)') 'Blocks : Set (360 longitude x 180 latitude) blocks for Single Point.' +#endif + +#ifndef SinglePoint + CALL this%init_pio () +#endif + + END SUBROUTINE block_set + + ! -------------------------------- + SUBROUTINE block_save_to_file (this, dir_landdata) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + IMPLICIT NONE + + class (block_type) :: this + + character(len=*), intent(in) :: dir_landdata + + ! Local variables + character(len=256) :: filename + + IF (p_is_master) THEN + + filename = trim(dir_landdata) // '/block.nc' + + CALL ncio_create_file (filename) + + CALL ncio_define_dimension (filename, 'longitude', this%nxblk) + CALL ncio_define_dimension (filename, 'latitude', this%nyblk) + + CALL ncio_write_serial (filename, 'lat_s', this%lat_s, 'latitude' ) + CALL ncio_write_serial (filename, 'lat_n', this%lat_n, 'latitude' ) + CALL ncio_write_serial (filename, 'lon_w', this%lon_w, 'longitude') + CALL ncio_write_serial (filename, 'lon_e', this%lon_e, 'longitude') + + ENDIF + + END SUBROUTINE block_save_to_file + + ! -------------------------------- + SUBROUTINE block_load_from_file (this, dir_landdata) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + IMPLICIT NONE + + class (block_type) :: this + character(len=*), intent(in) :: dir_landdata + + ! Local variables + character(len=256) :: filename + + filename = trim(dir_landdata) // '/block.nc' + + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nyblk = size(this%lat_s) + this%nxblk = size(this%lon_w) + + IF (p_is_master) THEN + write (*,*) 'Block information:' + write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', & + this%nyblk, ' blocks in latitude.' + write (*,*) + ENDIF + + CALL this%read_pio (dir_landdata) + + END SUBROUTINE block_load_from_file + + ! -------------------------------- + SUBROUTINE block_clip (this, & + iblk_south, iblk_north, iblk_west, iblk_east, numblocks) + + USE MOD_Namelist + USE MOD_Utils + IMPLICIT NONE + + class (block_type) :: this + integer, intent(out) :: iblk_south, iblk_north, iblk_west, iblk_east + integer, intent(out), optional :: numblocks + + ! Local Variables + real(r8) :: edges, edgen, edgew, edgee + integer :: numblocks_x, numblocks_y + + edges = DEF_domain%edges + edgen = DEF_domain%edgen + edgew = DEF_domain%edgew + edgee = DEF_domain%edgee + + iblk_south = find_nearest_south (edges, this%nyblk, this%lat_s) + iblk_north = find_nearest_north (edgen, this%nyblk, this%lat_n) + + CALL normalize_longitude (edgew) + CALL normalize_longitude (edgee) + + IF (edgew == edgee) THEN + iblk_west = 1 + iblk_east = this%nxblk + ELSE + iblk_west = find_nearest_west (edgew, this%nxblk, this%lon_w) + iblk_east = find_nearest_east (edgee, this%nxblk, this%lon_e) + + IF (iblk_west == iblk_east) THEN + IF ((lon_between_floor(edgee,this%lon_w(iblk_west),edgew)) & + .and. (this%lon_w(iblk_west) /= edgew)) THEN + iblk_west = 1 + iblk_east = this%nxblk + ENDIF + ENDIF + ENDIF + + IF (present(numblocks)) THEN + + numblocks_y = iblk_north - iblk_south + 1 + + IF (iblk_east >= iblk_west) THEN + numblocks_x = iblk_east - iblk_west + 1 + ELSE + numblocks_x = this%nxblk - iblk_west + 1 + iblk_east + ENDIF + + numblocks = numblocks_x * numblocks_y + + ENDIF + + END SUBROUTINE block_clip + + ! -------------------------------- + SUBROUTINE block_init_pio (this) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Utils + IMPLICIT NONE + + class (block_type) :: this + + integer :: iblk, jblk, iproc + integer :: iblk_south, iblk_north, iblk_west, iblk_east + integer :: numblocks, ngrp + integer :: iblkme + + IF (p_is_master) THEN + CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east, numblocks) + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + + IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN + ngrp = p_np_glb / DEF_PIO_groupsize + ELSE + ngrp = (p_np_glb-1) / DEF_PIO_groupsize + ENDIF + ngrp = min(max(ngrp, 1), numblocks) + + CALL divide_processes_into_groups (ngrp) +#endif + + allocate (this%pio (this%nxblk,this%nyblk)) + this%pio(:,:) = -1 + + IF (p_is_master) THEN + + iproc = -1 + DO jblk = iblk_south, iblk_north + + iblk = iblk_west + DO WHILE (.true.) +#ifdef USEMPI + iproc = mod(iproc+1, p_np_io) + this%pio(iblk,jblk) = p_address_io(iproc) +#else + this%pio(iblk,jblk) = p_root +#endif + + IF (iblk /= iblk_east) THEN + iblk = mod(iblk,this%nxblk) + 1 + ELSE + EXIT + ENDIF + ENDDO + ENDDO + + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, & + p_address_master, p_comm_glb, p_err) +#endif + + this%nblkme = 0 + IF (p_is_io) THEN + this%nblkme = count(this%pio == p_iam_glb) + IF (this%nblkme > 0) THEN + iblkme = 0 + allocate (this%xblkme(this%nblkme)) + allocate (this%yblkme(this%nblkme)) + DO iblk = 1, this%nxblk + DO jblk = 1, this%nyblk + IF (p_iam_glb == this%pio(iblk,jblk)) THEN + iblkme = iblkme + 1 + this%xblkme(iblkme) = iblk + this%yblkme(iblkme) = jblk + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE block_init_pio + + ! -------------------------------- + SUBROUTINE block_read_pio (this, dir_landdata) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Namelist + IMPLICIT NONE + + class (block_type) :: this + character(len=*), intent(in) :: dir_landdata + + ! Local Variables + character(len=256) :: filename, cyear + integer, allocatable :: nelm_io(:), nelmblk(:,:) + integer :: iblk_south, iblk_north, iblk_west, iblk_east + integer :: numblocks, ngrp, iblk, jblk, iproc, jproc + integer :: iblkme + + IF (p_is_master) THEN + ! Whether it varies by year??? + write(cyear,'(i4.4)') DEF_LC_YEAR + filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' + CALL ncio_read_serial (filename, 'nelm_blk', nelmblk) + numblocks = count(nelmblk > 0) + + CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east) + + ENDIF + +#ifdef USEMPI + IF (p_is_master) THEN + + IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN + ngrp = p_np_glb / DEF_PIO_groupsize + ELSE + ngrp = (p_np_glb-1) / DEF_PIO_groupsize + ENDIF + ngrp = min(max(ngrp, 1), numblocks) + + DO WHILE (.true.) + + allocate (nelm_io (ngrp)) + nelm_io(:) = 0 + + DO jblk = iblk_south, iblk_north + iblk = iblk_west + DO WHILE (.true.) + + IF (nelmblk(iblk,jblk) > 0) THEN + iproc = minloc(nelm_io, dim=1) + nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk) + ENDIF + + IF (iblk /= iblk_east) THEN + iblk = mod(iblk,this%nxblk) + 1 + ELSE + EXIT + ENDIF + ENDDO + ENDDO + + IF (maxval(nelm_io) < 2 * minval(nelm_io)) THEN + deallocate (nelm_io) + EXIT + ELSE + ngrp = ngrp - 1 + deallocate (nelm_io) + ENDIF + ENDDO + + IF (DEF_nIO_eq_nBlock) THEN + ngrp = numblocks + ENDIF + + IF ((p_np_glb-1)/ngrp < 2) THEN + CALL CoLM_stop ('CoLM called STOP: Too many groups or Too few processors for this case.') + ENDIF + ENDIF + + + CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (ngrp, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL divide_processes_into_groups (ngrp) +#endif + + allocate (this%pio (this%nxblk,this%nyblk)) + this%pio(:,:) = -1 + + IF (p_is_master) THEN + +#ifdef USEMPI + allocate (nelm_io (0:p_np_io-1)) + nelm_io(:) = 0 + jproc = -1 +#endif + + DO jblk = iblk_south, iblk_north + iblk = iblk_west + DO WHILE (.true.) +#ifdef USEMPI + IF (nelmblk(iblk,jblk) > 0) THEN + iproc = minloc(nelm_io, dim=1) - 1 + this%pio(iblk,jblk) = p_address_io(iproc) + nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk) + ELSEIF (nelmblk(iblk,jblk) == 0) THEN + jproc = mod(jproc+1, p_np_io) + this%pio(iblk,jblk) = p_address_io(jproc) + ENDIF +#else + this%pio(iblk,jblk) = p_root +#endif + + IF (iblk /= iblk_east) THEN + iblk = mod(iblk,this%nxblk) + 1 + ELSE + EXIT + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + deallocate (nelm_io) +#endif + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, & + p_address_master, p_comm_glb, p_err) +#endif + + this%nblkme = 0 + IF (p_is_io) THEN + this%nblkme = count(this%pio == p_iam_glb) + IF (this%nblkme > 0) THEN + iblkme = 0 + allocate (this%xblkme(this%nblkme)) + allocate (this%yblkme(this%nblkme)) + DO iblk = 1, this%nxblk + DO jblk = 1, this%nyblk + IF (p_iam_glb == this%pio(iblk,jblk)) THEN + iblkme = iblkme + 1 + this%xblkme(iblkme) = iblk + this%yblkme(iblkme) = jblk + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + + IF (allocated(nelmblk)) deallocate (nelmblk) + + END SUBROUTINE block_read_pio + + ! -------------------------------- + SUBROUTINE block_free_mem (this) + + IMPLICIT NONE + type (block_type) :: this + + IF (allocated (this%lat_s)) deallocate (this%lat_s) + IF (allocated (this%lat_n)) deallocate (this%lat_n) + IF (allocated (this%lon_w)) deallocate (this%lon_w) + IF (allocated (this%lon_e)) deallocate (this%lon_e) + + IF (allocated (this%pio) ) deallocate (this%pio ) + + IF (allocated (this%xblkme)) deallocate (this%xblkme) + IF (allocated (this%yblkme)) deallocate (this%yblkme) + + END SUBROUTINE block_free_mem + + ! ----- + SUBROUTINE get_blockname (iblk, jblk, blockname) + + IMPLICIT NONE + + integer, intent(in) :: iblk, jblk + + character(len=*), intent(out) :: blockname + + ! Local variables + character(len=4) :: cx + character(len=3) :: cy + integer :: i + + IF (gblock%lat_s(jblk) < 0) THEN + write (cy, '(A1,I2.2)') 's', - floor(gblock%lat_s(jblk)) + ELSE + write (cy, '(A1,I2.2)') 'n', floor(gblock%lat_s(jblk)) + ENDIF + + IF (gblock%lon_w(iblk) < 0) THEN + write (cx, '(A1,I3.3)') 'w', - floor(gblock%lon_w(iblk)) + ELSE + write (cx, '(A1,I3.3)') 'e', floor(gblock%lon_w(iblk)) + ENDIF + + blockname = trim(cx) // '_' // trim(cy) + + END SUBROUTINE get_blockname + + ! -------------------------------- + SUBROUTINE get_filename_block (filename, iblk, jblk, fileblock) + + IMPLICIT NONE + + character(len=*), intent(in) :: filename + integer, intent(in) :: iblk, jblk + + character(len=*), intent(out) :: fileblock + + ! Local variables + character(len=8) :: blockname + integer :: i + + CALL get_blockname (iblk, jblk, blockname) + + i = len_trim (filename) + DO WHILE (i > 0) + IF (filename(i:i) == '.') EXIT + i = i - 1 + ENDDO + + IF (i > 0) THEN + fileblock = filename(1:i-1) // '_' // blockname // '.nc' + ELSE + fileblock = filename // '_' // blockname // '.nc' + ENDIF + + END SUBROUTINE get_filename_block + +END MODULE MOD_Block diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 new file mode 100644 index 0000000000..22474e9f12 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 @@ -0,0 +1,375 @@ +#include + +MODULE MOD_CatchmentDataReadin + +!-------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Reading preprocessed MERIT Hydro data and generated catchment data in netcdf files. +! +! 1. If "in_one_file" is false, then the data is orgnized by 5 degree blocks. +! The file name gives the southwest corner of the block. +! For example, file "n60e075.nc" stores data in region from 65N to 60N and 75E to 80E, +! Subroutines loop over all 5 degree blocks in simulation region. +! +! 2. Data is saved in variables with types of "block_data_xxxxx_xd". +! +! 3. Latitude in files is from north to south. +! +! Created by Shupeng Zhang, May 2023 +!-------------------------------------------------------------------------------------- + + IMPLICIT NONE + + integer, parameter :: nxhbox = 6000 + integer, parameter :: nyhbox = 6000 + integer, parameter :: nxhglb = 432000 + integer, parameter :: nyhglb = 216000 + + INTERFACE catchment_data_read + MODULE procedure catchment_data_read_int32 + MODULE procedure catchment_data_read_real8 + END INTERFACE catchment_data_read + +CONTAINS + + ! ----- + SUBROUTINE catchment_data_read_int32 (file_meshdata_in, dataname, grid, rdata_int32, spv) + + USE MOD_Grid + USE MOD_DataType + IMPLICIT NONE + + character (len=*), intent(in) :: file_meshdata_in + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_int32_2d), intent(inout) :: rdata_int32 + integer, intent(in), optional :: spv + + IF (present(spv)) THEN + CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & + rdata_int32 = rdata_int32, spv_i4 = spv) + ELSE + CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & + rdata_int32 = rdata_int32) + ENDIF + + END SUBROUTINE catchment_data_read_int32 + + ! ----- + SUBROUTINE catchment_data_read_real8 (file_meshdata_in, dataname, grid, rdata_real8, spv) + + USE MOD_Grid + USE MOD_DataType + IMPLICIT NONE + + character (len=*), intent(in) :: file_meshdata_in + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_real8_2d), intent(inout) :: rdata_real8 + real(r8), intent(in), optional :: spv + + IF (present(spv)) THEN + CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & + rdata_real8 = rdata_real8, spv_r8 = spv) + ELSE + CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & + rdata_real8 = rdata_real8) + ENDIF + + END SUBROUTINE catchment_data_read_real8 + + ! ----- + SUBROUTINE catchment_data_read_general (file_meshdata_in, dataname, grid, & + rdata_int32, spv_i4, rdata_real8, spv_r8) + + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_Utils + USE MOD_NetCDFSerial + IMPLICIT NONE + + character (len=*), intent(in) :: file_meshdata_in + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_int32_2d), intent(inout), optional :: rdata_int32 + integer, intent(in), optional :: spv_i4 + + type (block_data_real8_2d), intent(inout), optional :: rdata_real8 + real(r8), intent(in), optional :: spv_r8 + + + ! Local Variables + logical :: in_one_file + integer :: nlat, nlon, ilon + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox + integer :: xdsp, ydsp, i0, i1, j0, j1, il0, il1, jl0, jl1 + integer :: i0min, i1max, if0, if1, jf0, jf1, i0next, i1next + character(len=256) :: file_mesh, path_mesh + character(len=3) :: pre1 + character(len=4) :: pre2 + integer, allocatable :: dcache_i4(:,:) + real(r8), allocatable :: dcache_r8(:,:) + real(r8), allocatable :: latitude(:), longitude(:) + logical :: fexists + + IF (p_is_io) THEN + + IF (p_iam_io == p_root) THEN + IF (grid%yinc == 1) THEN + write(*,*) 'Warning: latitude in catchment data should be from north to south.' + ENDIF + ENDIF + + IF (p_iam_io == p_root) THEN + in_one_file = ncio_var_exist (file_meshdata_in, dataname) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (in_one_file, 1, mpi_logical, p_root, p_comm_io, p_err) +#endif + + IF (in_one_file) THEN + + file_mesh = file_meshdata_in + + CALL ncio_read_serial (file_mesh, 'lat', latitude) + CALL ncio_read_serial (file_mesh, 'lon', longitude) + + nlat = size(latitude ) + nlon = size(longitude) + + isouth = find_nearest_south (latitude(nlat), grid%nlat, grid%lat_s) + inorth = find_nearest_north (latitude(1), grid%nlat, grid%lat_n) + + DO ilon = 1, nlon + CALL normalize_longitude (longitude(ilon)) + ENDDO + + iwest = find_nearest_west (longitude(1), grid%nlon, grid%lon_w) + ieast = find_nearest_east (longitude(nlon), grid%nlon, grid%lon_e) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF (present(rdata_int32)) THEN + IF (present(spv_i4)) THEN + rdata_int32%blk(iblk,jblk)%val(:,:) = spv_i4 + ELSE + rdata_int32%blk(iblk,jblk)%val(:,:) = 0 + ENDIF + ENDIF + + IF (present(rdata_real8)) THEN + IF (present(spv_r8)) THEN + rdata_real8%blk(iblk,jblk)%val(:,:) = spv_r8 + ELSE + rdata_real8%blk(iblk,jblk)%val(:,:) = -1.e36_r8 + ENDIF + ENDIF + + IF ((inorth > grid%ydsp(jblk)+nyhbox) .or. (isouth < grid%ydsp(jblk)+1)) THEN + CYCLE + ENDIF + + j0 = max(inorth, grid%ydsp(jblk)+1) + j1 = min(isouth, grid%ydsp(jblk)+grid%ycnt(jblk)) + + jl0 = j0 - grid%ydsp(jblk) + jl1 = j1 - grid%ydsp(jblk) + jf0 = j0 - inorth + 1 + jf1 = j1 - inorth + 1 + + i0min = grid%xdsp(iblk) + 1 + i1max = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (i1max > grid%nlon) i1max = i1max - grid%nlon + + DO WHILE ((i0min /= i1max) .and. (.not. (lon_between_floor(grid%lon_w(i0min), & + grid%lon_w(iwest), grid%lon_e(ieast))))) + i0min = i0min + 1; IF (i0min > grid%nlon) i0min = 1 + ENDDO + + IF (lon_between_floor(grid%lon_w(i0min), grid%lon_w(iwest), grid%lon_e(ieast))) THEN + i0 = i0min + i1 = i0 + i1next = i1 + 1; IF (i1next > grid%nlon) i1next = 1 + DO WHILE ((i1 /= i1max) .and. & + lon_between_floor(grid%lon_w(i1next), grid%lon_w(iwest), grid%lon_e(ieast))) + i1 = i1next + i1next = i1 + 1; IF (i1next > grid%nlon) i1next = 1 + ENDDO + + if0 = i0 - iwest + 1; IF (if0 <= 0) if0 = if0 + grid%nlon + if1 = i1 - iwest + 1; IF (if1 <= 0) if1 = if1 + grid%nlon + il0 = i0 - grid%xdsp(iblk); IF (il0 <= 0) il0 = il0 + grid%nlon + il1 = i1 - grid%xdsp(iblk); IF (il1 <= 0) il1 = il1 + grid%nlon + + IF (present(rdata_int32)) THEN + CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_i4) + dcache_i4 = transpose(dcache_i4) + + rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4 + ENDIF + + IF (present(rdata_real8)) THEN + CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_r8) + dcache_r8 = transpose(dcache_r8) + + rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8 + ENDIF + + ENDIF + + IF (lon_between_ceil(grid%lon_e(i1max), grid%lon_w(iwest), grid%lon_e(ieast))) THEN + i1 = i1max + i0 = i1 + i0next = i0 - 1; IF (i0next == 0) i0next = grid%nlon + DO WHILE ((i0 /= i0min) .and. & + lon_between_ceil(grid%lon_e(i0next), grid%lon_w(iwest), grid%lon_e(ieast))) + i0 = i0next + i0next = i0 - 1; IF (i0next == 0) i0next = grid%nlon + ENDDO + + IF (i0 /= i0min) THEN + if0 = i0 - iwest + 1; IF (if0 <= 0) if0 = if0 + grid%nlon + if1 = i1 - iwest + 1; IF (if1 <= 0) if1 = if1 + grid%nlon + il0 = i0 - grid%xdsp(iblk); IF (il0 <= 0) il0 = il0 + grid%nlon + il1 = i1 - grid%xdsp(iblk); IF (il1 <= 0) il1 = il1 + grid%nlon + + IF (present(rdata_int32)) THEN + CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_i4) + dcache_i4 = transpose(dcache_i4) + + rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4 + ENDIF + + IF (present(rdata_real8)) THEN + CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_r8) + dcache_r8 = transpose(dcache_r8) + + rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8 + ENDIF + ENDIF + ENDIF + + ENDDO + + ELSE + + ! remove suffix ".nc" + path_mesh = file_meshdata_in(1:len_trim(file_meshdata_in)-3) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF (present(rdata_int32)) THEN + IF (present(spv_i4)) THEN + rdata_int32%blk(iblk,jblk)%val(:,:) = spv_i4 + ELSE + rdata_int32%blk(iblk,jblk)%val(:,:) = 0 + ENDIF + ENDIF + + IF (present(rdata_real8)) THEN + IF (present(spv_r8)) THEN + rdata_real8%blk(iblk,jblk)%val(:,:) = spv_r8 + ELSE + rdata_real8%blk(iblk,jblk)%val(:,:) = -1.e36_r8 + ENDIF + ENDIF + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxhglb) ieast = ieast - nxhglb + + ibox = grid%xdsp(iblk)/nxhbox + 1 + jbox = grid%ydsp(jblk)/nyhbox + 1 + + DO WHILE (.true.) + + xdsp = (ibox-1) * nxhbox + ydsp = (jbox-1) * nyhbox + + j0 = max(inorth-ydsp, 1) + j1 = min(isouth-ydsp, nyhbox) + jl0 = j0 + ydsp - inorth + 1 + jl1 = j1 + ydsp - inorth + 1 + + IF (ieast >= iwest) THEN + i0 = max(iwest-xdsp, 1) + i1 = min(ieast-xdsp, nxhbox) + il0 = i0 + xdsp - iwest + 1 + il1 = i1 + xdsp - iwest + 1 + ELSE + IF (iwest <= xdsp+nxhbox) THEN + i0 = max(iwest-xdsp, 1) + i1 = nxhbox + il0 = i0 + xdsp - iwest + 1 + il1 = i1 + xdsp - iwest + 1 + ELSE + i0 = 1 + i1 = min(ieast-xdsp, nxhbox) + il0 = i0 + xdsp + nxhglb - iwest + 1 + il1 = i1 + xdsp + nxhglb - iwest + 1 + ENDIF + ENDIF + + IF (jbox <= 18) THEN + write (pre1,'(A1,I2.2)') 'n', (18-jbox)*5 + ELSE + write (pre1,'(A1,I2.2)') 's', (jbox-18)*5 + ENDIF + + IF (ibox <= 36) THEN + write (pre2,'(A1,I3.3)') 'w', (37-ibox)*5 + ELSE + write (pre2,'(A1,I3.3)') 'e', (ibox-37)*5 + ENDIF + + file_mesh = trim(path_mesh) // '/' // trim(pre1) // trim(pre2) // '.nc' + + inquire(file=file_mesh, exist=fexists) + IF (fexists) THEN + IF (present(rdata_int32)) THEN + CALL ncio_read_part_serial (file_mesh, dataname, (/j0,i0/), (/j1,i1/), dcache_i4) + dcache_i4 = transpose(dcache_i4) + + rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4 + ENDIF + + IF (present(rdata_real8)) THEN + CALL ncio_read_part_serial (file_mesh, dataname, (/j0,i0/), (/j1,i1/), dcache_r8) + dcache_r8 = transpose(dcache_r8) + + rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8 + ENDIF + ENDIF + + IF ((ieast >= xdsp + 1) .and. (ieast <= xdsp + nxhbox)) THEN + IF (isouth <= ydsp + nyhbox) THEN + EXIT + ELSE + ibox = grid%xdsp(iblk)/nxhbox + 1 + jbox = jbox + 1 + ENDIF + ELSE + ibox = mod(ibox, nxhglb/nxhbox) + 1 + ENDIF + + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE catchment_data_read_general + +END MODULE MOD_CatchmentDataReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 new file mode 100644 index 0000000000..4a907ac1a1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 @@ -0,0 +1,709 @@ +#include + +MODULE MOD_DataType + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Definitions of data types used in CoLM. +! +! Most frequently used data types in CoLM are "blocked" data types +! including, +! 1. Blocked 2D data of 4-byte integer type; +! 2. Blocked 2D data of 8-byte float type; +! 3. Blocked 3D data of 8-byte float type; +! 4. Blocked 4D data of 8-byte float type; +! +! Subroutines are used to +! 1. allocate memory; +! 2. flush data values; +! 3. copy data; +! 4. do linear transformation and interpolations. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + + ! ---- data types ---- + !------- + type :: pointer_real8_1d + real(r8), allocatable :: val(:) + CONTAINS + final :: pointer_real8_1d_free_mem + END type pointer_real8_1d + + !------- + type :: pointer_int8_1d + integer(1), allocatable :: val(:) + CONTAINS + final :: pointer_int8_1d_free_mem + END type pointer_int8_1d + + !------- + type :: pointer_int32_1d + integer, allocatable :: val(:) + CONTAINS + final :: pointer_int32_1d_free_mem + END type pointer_int32_1d + + !------- + type :: pointer_int64_1d + integer*8, allocatable :: val(:) + CONTAINS + final :: pointer_int64_1d_free_mem + END type pointer_int64_1d + + !------- + type :: pointer_logic_1d + logical, allocatable :: val(:) + CONTAINS + final :: pointer_logic_1d_free_mem + END type pointer_logic_1d + + !------- + type :: pointer_int32_2d + integer, allocatable :: val (:,:) + CONTAINS + final :: pointer_int32_2d_free_mem + END type pointer_int32_2d + + type :: block_data_int32_2d + type(pointer_int32_2d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_int32_2d_free_mem + END type block_data_int32_2d + + !------- + type :: pointer_real8_2d + real(r8), allocatable :: val (:,:) + CONTAINS + final :: pointer_real8_2d_free_mem + END type pointer_real8_2d + + type :: block_data_real8_2d + type(pointer_real8_2d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_real8_2d_free_mem + END type block_data_real8_2d + + !------- + type :: pointer_real8_3d + real(r8), allocatable :: val (:,:,:) + CONTAINS + final :: pointer_real8_3d_free_mem + END type pointer_real8_3d + + type :: block_data_real8_3d + integer :: lb1, ub1 + type(pointer_real8_3d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_real8_3d_free_mem + END type block_data_real8_3d + + !------- + type :: pointer_real8_4d + real(r8), allocatable :: val (:,:,:,:) + CONTAINS + final :: pointer_real8_4d_free_mem + END type pointer_real8_4d + + type :: block_data_real8_4d + integer :: lb1, ub1, lb2, ub2 + type(pointer_real8_4d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_real8_4d_free_mem + END type block_data_real8_4d + + ! ---- PUBLIC subroutines ---- + !------ + INTERFACE allocate_block_data + MODULE procedure allocate_block_data_int32_2d + MODULE procedure allocate_block_data_real8_2d + MODULE procedure allocate_block_data_real8_3d + MODULE procedure allocate_block_data_real8_4d + END INTERFACE allocate_block_data + + !------ + INTERFACE flush_block_data + MODULE procedure flush_block_data_int32_2d + MODULE procedure flush_block_data_real8_2d + MODULE procedure flush_block_data_real8_3d + MODULE procedure flush_block_data_real8_4d + END INTERFACE flush_block_data + + !----- + PUBLIC :: block_data_linear_transform + PUBLIC :: block_data_copy + PUBLIC :: block_data_linear_interp + PUBLIC :: block_data_division + +CONTAINS + + !------------------ + SUBROUTINE pointer_real8_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_1d_free_mem + + !------------------ + SUBROUTINE pointer_int8_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int8_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int8_1d_free_mem + + !------------------ + SUBROUTINE pointer_int32_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int32_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int32_1d_free_mem + + !------------------ + SUBROUTINE pointer_int64_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int64_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int64_1d_free_mem + + !------------------ + SUBROUTINE pointer_logic_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_logic_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_logic_1d_free_mem + + !------------------ + SUBROUTINE pointer_int32_2d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int32_2d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int32_2d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_int32_2d (grid, gdata) + + USE MOD_Grid + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_int32_2d), intent(out) :: gdata + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val (grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_int32_2d + + !------------------ + SUBROUTINE block_data_int32_2d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_int32_2d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_int32_2d_free_mem + + !------------------ + SUBROUTINE pointer_real8_2d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_2d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_2d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_real8_2d (grid, gdata) + + USE MOD_Grid + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_real8_2d), intent(out) :: gdata + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val (grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_real8_2d + + !------------------ + SUBROUTINE block_data_real8_2d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_real8_2d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_real8_2d_free_mem + + !------------------ + SUBROUTINE pointer_real8_3d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_3d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_3d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_real8_3d (grid, gdata, ndim1, lb1) + + USE MOD_Grid + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_real8_3d), intent(out) :: gdata + integer, intent(in) :: ndim1 + integer, intent(in), optional :: lb1 + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + IF (present(lb1)) THEN + gdata%lb1 = lb1 + ELSE + gdata%lb1 = 1 + ENDIF + + gdata%ub1 = gdata%lb1-1+ndim1 + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val (gdata%lb1:gdata%ub1, grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_real8_3d + + !------------------ + SUBROUTINE block_data_real8_3d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_real8_3d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_real8_3d_free_mem + + !------------------ + SUBROUTINE pointer_real8_4d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_4d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_4d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_real8_4d (grid, gdata, ndim1, ndim2, lb1, lb2) + + USE MOD_Grid + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_real8_4d), intent(out) :: gdata + integer, intent(in) :: ndim1, ndim2 + integer, intent(in), optional :: lb1, lb2 + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + IF (present(lb1)) THEN + gdata%lb1 = lb1 + ELSE + gdata%lb1 = 1 + ENDIF + + gdata%ub1 = gdata%lb1-1+ndim1 + + IF (present(lb2)) THEN + gdata%lb2 = lb2 + ELSE + gdata%lb2 = 1 + ENDIF + + gdata%ub2 = gdata%lb2-1+ndim2 + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val ( & + gdata%lb1:gdata%ub1, gdata%lb2:gdata%ub2, grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_real8_4d + + !------------------ + SUBROUTINE block_data_real8_4d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_real8_4d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_real8_4d_free_mem + + !------------------ + SUBROUTINE flush_block_data_real8_2d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + real(r8), intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_real8_2d + + !------------------ + SUBROUTINE flush_block_data_int32_2d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_int32_2d), intent(inout) :: gdata + integer, intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_int32_2d + + !------------------ + SUBROUTINE flush_block_data_real8_3d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_real8_3d), intent(inout) :: gdata + real(r8), intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_real8_3d + + !------------------ + SUBROUTINE flush_block_data_real8_4d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_real8_4d), intent(inout) :: gdata + real(r8), intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_real8_4d + + !------------------ + SUBROUTINE block_data_linear_transform (gdata, scl, dsp) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + real(r8), intent(in), optional :: scl + real(r8), intent(in), optional :: dsp + + ! Local variables + integer :: iblkme, iblk, jblk + + IF (present(scl)) THEN + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = gdata%blk(iblk,jblk)%val * scl + ENDDO + ENDIF + + IF (present(dsp)) THEN + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = gdata%blk(iblk,jblk)%val + dsp + ENDDO + ENDIF + + END SUBROUTINE block_data_linear_transform + + !------------------ + SUBROUTINE block_data_copy (gdata_from, gdata_to, sca) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_real8_2d), intent(in) :: gdata_from + type(block_data_real8_2d), intent(inout) :: gdata_to + real(r8), intent(in), optional :: sca + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (present(sca)) THEN + gdata_to%blk(iblk,jblk)%val = gdata_from%blk(iblk,jblk)%val * sca + ELSE + gdata_to%blk(iblk,jblk)%val = gdata_from%blk(iblk,jblk)%val + ENDIF + ENDDO + + END SUBROUTINE block_data_copy + + !------------------ + SUBROUTINE block_data_linear_interp ( & + gdata_from1, alp1, gdata_from2, alp2, gdata_to) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + IMPLICIT NONE + + type(block_data_real8_2d), intent(in) :: gdata_from1, gdata_from2 + real(r8), intent(in) :: alp1, alp2 + type(block_data_real8_2d), intent(inout) :: gdata_to + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata_to%blk(iblk,jblk)%val = & + gdata_from1%blk(iblk,jblk)%val * alp1 & + + gdata_from2%blk(iblk,jblk)%val * alp2 + ENDDO + + END SUBROUTINE block_data_linear_interp + + !----------------- + SUBROUTINE block_data_division (gdata, sumdata, spv) + + USE MOD_Precision + USE MOD_Block + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + type(block_data_real8_2d), intent(inout) :: sumdata + real(r8), intent(in), optional :: spv + + ! Local variables + integer :: iblkme, iblk, jblk + + IF (p_is_io) THEN + + IF (.not. present(spv)) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE (sumdata%blk(iblk,jblk)%val > 0.) + gdata%blk(iblk,jblk)%val = & + gdata%blk(iblk,jblk)%val / sumdata%blk(iblk,jblk)%val + ELSEWHERE + gdata%blk(iblk,jblk)%val = spval + ENDWHERE + ENDDO + + ELSE + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE ((sumdata%blk(iblk,jblk)%val > 0.) .and. (gdata%blk(iblk,jblk)%val /= spv)) + gdata%blk(iblk,jblk)%val = & + gdata%blk(iblk,jblk)%val / sumdata%blk(iblk,jblk)%val + ELSEWHERE + gdata%blk(iblk,jblk)%val = spv + ENDWHERE + ENDDO + + ENDIF + + ENDIF + + END SUBROUTINE block_data_division + +END MODULE MOD_DataType diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 new file mode 100644 index 0000000000..6b8ad66908 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 @@ -0,0 +1,1004 @@ +#include + +MODULE MOD_Grid + +!------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Definition of latitude-longitude grids and data types related to grids. +! +! Latitude-longitude grid can be defined by +! 1. "name" : frequently used grids is predefined in this MODULE; +! 2. "ndims" : how many longitude and latitude grids are used globally; +! 3. "res" : longitude and latitude resolutions in radian +! 4. "center" : longitude and latitude grid centers, and the border lines +! are defined by center lines of grid centers; the region +! boundaries is optional. +! 5. "file" : read grid informations from a file, the variables are +! 'lat_s', 'lat_n', 'lon_w', 'lon_e' +! 6. "copy" : copy grid informations from an existing grid +! +! Grid centers in radian can be calculated by using "set_rlon" and "set_rlat" +! +! Two additional data types are defined: +! 1. "grid_list_type" : list of grid boxes; +! 2. "grid_concat_type" : used to concatenate grids distributed in blocks. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_UserDefFun + IMPLICIT NONE + + ! ---- data types ---- + type :: grid_type + + integer :: nlat + integer :: nlon + + ! Latitude direction. (yinc = 1) means south to north. + integer :: yinc + + ! Coordinates. + real(r8), allocatable :: lat_s (:) + real(r8), allocatable :: lat_n (:) + real(r8), allocatable :: lon_w (:) + real(r8), allocatable :: lon_e (:) + + ! Blocks. + integer, allocatable :: xdsp(:), ydsp(:) + integer, allocatable :: xcnt(:), ycnt(:) + integer, allocatable :: xblk(:), yblk(:) + integer, allocatable :: xloc(:), yloc(:) + + ! Mapping to pixels. + integer, allocatable :: xgrd(:), ygrd(:) + + ! Grid info. + real(r8), allocatable :: rlon(:) + real(r8), allocatable :: rlat(:) + + CONTAINS + procedure, PUBLIC :: define_by_name => grid_define_by_name + procedure, PUBLIC :: define_by_ndims => grid_define_by_ndims + procedure, PUBLIC :: define_by_res => grid_define_by_res + procedure, PUBLIC :: define_by_center => grid_define_by_center + procedure, PUBLIC :: define_from_file => grid_define_from_file + procedure, PUBLIC :: define_by_copy => grid_define_by_copy + + procedure, PUBLIC :: set_rlon => grid_set_rlon + procedure, PUBLIC :: set_rlat => grid_set_rlat + + procedure, PRIVATE :: init => grid_init + procedure, PRIVATE :: normalize => grid_normalize + procedure, PRIVATE :: set_blocks => grid_set_blocks + + final :: grid_free_mem + + END type grid_type + + ! ---- data types ---- + type :: grid_list_type + integer :: ng + integer, allocatable :: ilat(:) + integer, allocatable :: ilon(:) + END type grid_list_type + + type :: segment_type + integer :: blk + integer :: cnt + integer :: bdsp + integer :: gdsp + END type segment_type + + type :: grid_info_type + integer :: nlat, nlon + real(r8), allocatable :: lat_s(:) + real(r8), allocatable :: lat_n(:) + real(r8), allocatable :: lon_w(:) + real(r8), allocatable :: lon_e(:) + real(r8), allocatable :: lon_c(:) !grid center + real(r8), allocatable :: lat_c(:) !grid center + END type grid_info_type + + type :: grid_concat_type + integer :: ndatablk + integer :: nxseg, nyseg + type(segment_type), allocatable :: xsegs(:), ysegs(:) + type(grid_info_type) :: ginfo + CONTAINS + procedure, PUBLIC :: set => set_grid_concat + final :: grid_concat_free_mem + END type grid_concat_type + + + ! -- PUBLIC SUBROUTINEs -- + PUBLIC :: get_region_by_this_IO + +CONTAINS + + ! -------------------------------- + SUBROUTINE grid_init (this, nlon, nlat) + + IMPLICIT NONE + class (grid_type) :: this + + integer, intent(in) :: nlon + integer, intent(in) :: nlat + + this%nlat = nlat + this%nlon = nlon + + IF (allocated(this%lat_s)) deallocate(this%lat_s) + IF (allocated(this%lat_n)) deallocate(this%lat_n) + IF (allocated(this%lon_w)) deallocate(this%lon_w) + IF (allocated(this%lon_e)) deallocate(this%lon_e) + allocate (this%lat_s (nlat)) + allocate (this%lat_n (nlat)) + allocate (this%lon_w (nlon)) + allocate (this%lon_e (nlon)) + + END SUBROUTINE grid_init + + ! -------------------------------- + SUBROUTINE grid_define_by_name (this, gridname) + + IMPLICIT NONE + class (grid_type) :: this + + character(len=*), intent(in) :: gridname + + ! Local variables + integer :: nlat, nlon, ilat, ilon + real(r8) :: del_lat, del_lon + + IF (trim(gridname) == 'merit_90m') THEN + + nlat = 180*60*20 + nlon = 360*60*20 + + this%nlat = nlat + this%nlon = nlon + + CALL this%init (this%nlon, this%nlat) + + del_lat = 180.0 / nlat + DO ilat = 1, this%nlat + this%lat_s(ilat) = 90.0 - del_lat * ilat - del_lat/2.0 + this%lat_n(ilat) = 90.0 - del_lat * (ilat-1) - del_lat/2.0 + ENDDO + + del_lon = 360.0 / nlon + DO ilon = 1, this%nlon + this%lon_w(ilon) = -180.0 + del_lon * (ilon-1) - del_lon/2.0 + this%lon_e(ilon) = -180.0 + del_lon * ilon - del_lon/2.0 + ENDDO + + CALL this%normalize () + CALL this%set_blocks () + + ENDIF + + IF (trim(gridname) == 'colm_5km') THEN + + CALL this%define_by_ndims (8640,4320) + + ENDIF + + IF (trim(gridname) == 'colm_1km') THEN + + CALL this%define_by_ndims (43200,21600) + + ENDIF + + + IF (trim(gridname) == 'colm_500m') THEN + + CALL this%define_by_ndims (86400,43200) + + ENDIF + + IF (trim(gridname) == 'colm_100m') THEN + + CALL this%define_by_ndims (432000,216000) + + ENDIF + + IF (trim(gridname) == 'nitrif_2deg') THEN + + CALL this%define_by_ndims (144,96) + + ENDIF + + END SUBROUTINE grid_define_by_name + + !----------------------------------------------------- + SUBROUTINE grid_define_by_ndims (this, lon_points, lat_points) + + IMPLICIT NONE + class (grid_type) :: this + + integer, intent(in) :: lon_points + integer, intent(in) :: lat_points + + ! Local variables + integer :: ilat, ilon + real(r8) :: del_lat, del_lon + + this%nlat = lat_points + this%nlon = lon_points + + CALL this%init (this%nlon, this%nlat) + + del_lat = 180.0 / lat_points + DO ilat = 1, this%nlat + this%lat_s(ilat) = 90.0 - del_lat * ilat + this%lat_n(ilat) = 90.0 - del_lat * (ilat-1) + ENDDO + + del_lon = 360.0 / lon_points + DO ilon = 1, this%nlon + this%lon_w(ilon) = -180.0 + del_lon * (ilon-1) + this%lon_e(ilon) = -180.0 + del_lon * ilon + ENDDO + + this%lon_e(this%nlon) = -180.0 + + CALL this%normalize () + CALL this%set_blocks () + + END SUBROUTINE grid_define_by_ndims + + !----------------------------------------------------- + SUBROUTINE grid_define_by_res (this, lon_res, lat_res) + + IMPLICIT NONE + class (grid_type) :: this + + real(r8), intent(in) :: lon_res, lat_res + + ! Local variables + integer :: lon_points, lat_points + + lon_points = nint(360.0/lon_res) + lat_points = nint(180.0/lat_res) + + CALL this%define_by_ndims (lon_points, lat_points) + + END SUBROUTINE grid_define_by_res + + !--------------------------------------------- + SUBROUTINE grid_define_by_center (this, lat_in, lon_in, & + south, north, west, east) + + USE MOD_Precision + USE MOD_Utils + IMPLICIT NONE + class (grid_type) :: this + + real(r8), intent(in) :: lat_in(:), lon_in(:) + real(r8), intent(in), optional :: south, north, west, east + + ! Local variables + integer :: ilat, ilon, ilone, ilonw + real(r8), allocatable :: lon_in_n(:) + + this%nlat = size(lat_in) + this%nlon = size(lon_in) + + CALL this%init (this%nlon, this%nlat) + + IF (lat_in(1) > lat_in(this%nlat)) THEN + this%yinc = -1 + ELSE + this%yinc = 1 + ENDIF + + DO ilat = 1, this%nlat + IF (this%yinc == 1) THEN + IF (ilat < this%nlat) THEN + this%lat_n(ilat) = (lat_in(ilat) + lat_in(ilat+1)) * 0.5 + ELSE + IF (present(north)) THEN + this%lat_n(ilat) = north + ELSE + this%lat_n(ilat) = 90.0 + ENDIF + ENDIF + + IF (ilat > 1) THEN + this%lat_s(ilat) = (lat_in(ilat-1) + lat_in(ilat)) * 0.5 + ELSE + IF (present(south)) THEN + this%lat_s(ilat) = south + ELSE + this%lat_s(ilat) = -90.0 + ENDIF + ENDIF + ELSEIF (this%yinc == -1) THEN + IF (ilat > 1) THEN + this%lat_n(ilat) = (lat_in(ilat-1) + lat_in(ilat)) * 0.5 + ELSE + IF (present(north)) THEN + this%lat_n(ilat) = north + ELSE + this%lat_n(ilat) = 90.0 + ENDIF + ENDIF + + IF (ilat < this%nlat) THEN + this%lat_s(ilat) = (lat_in(ilat) + lat_in(ilat+1)) * 0.5 + ELSE + IF (present(south)) THEN + this%lat_s(ilat) = south + ELSE + this%lat_s(ilat) = -90.0 + ENDIF + ENDIF + ENDIF + ENDDO + + allocate (lon_in_n (size(lon_in))) + + lon_in_n = lon_in + DO ilon = 1, size(lon_in_n) + CALL normalize_longitude (lon_in_n(ilon)) + ENDDO + + DO ilon = 1, this%nlon + ilone = mod(ilon,this%nlon) + 1 + IF (lon_in_n(ilon) > lon_in_n(ilone)) THEN + this%lon_e(ilon) = (lon_in_n(ilon) + lon_in_n(ilone) + 360.0) * 0.5 + ELSE + this%lon_e(ilon) = (lon_in_n(ilon) + lon_in_n(ilone)) * 0.5 + ENDIF + + IF ((ilon == this%nlon) .and. (present(east))) THEN + this%lon_e(this%nlon) = east + ENDIF + + ilonw = ilon - 1 + IF (ilonw == 0) ilonw = this%nlon + IF (lon_in_n(ilonw) > lon_in_n(ilon)) THEN + this%lon_w(ilon) = (lon_in_n(ilonw) + lon_in_n(ilon) + 360.0) * 0.5 + ELSE + this%lon_w(ilon) = (lon_in_n(ilonw) + lon_in_n(ilon)) * 0.5 + ENDIF + + IF ((ilon == 1) .and. (present(west))) THEN + this%lon_w(1) = west + ENDIF + ENDDO + + deallocate (lon_in_n) + + CALL this%normalize () + CALL this%set_blocks () + + END SUBROUTINE grid_define_by_center + + !----------------------------------------------------- + SUBROUTINE grid_define_from_file (this, filename, latname, lonname) + + USE MOD_NetCDFSerial + IMPLICIT NONE + class (grid_type) :: this + + character(len=*), intent(in) :: filename + character(len=*), intent(in), optional :: latname, lonname + + ! Local Variables + real(r8), allocatable :: lon_in(:) + real(r8), allocatable :: lat_in(:) + + IF (.not. (present(latname) .and. present(lonname))) THEN + + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nlat = size(this%lat_s) + this%nlon = size(this%lon_w) + + CALL this%normalize () + CALL this%set_blocks () + + ELSE + + CALL ncio_read_bcast_serial (filename, latname, lat_in) + CALL ncio_read_bcast_serial (filename, lonname, lon_in) + CALL this%define_by_center (lat_in, lon_in) + + deallocate (lat_in, lon_in) + ENDIF + + END SUBROUTINE grid_define_from_file + + !----------------------------------------------------- + SUBROUTINE grid_define_by_copy (this, grid_in) + + USE MOD_NetCDFSerial + IMPLICIT NONE + class (grid_type) :: this + + type(grid_type) :: grid_in + + CALL this%init (grid_in%nlon, grid_in%nlat) + + this%lat_s = grid_in%lat_s + this%lat_n = grid_in%lat_n + this%lon_w = grid_in%lon_w + this%lon_e = grid_in%lon_e + + CALL this%normalize () + CALL this%set_blocks () + + END SUBROUTINE grid_define_by_copy + + !----------------------------------------------------- + SUBROUTINE grid_normalize (this) + + USE MOD_Utils + IMPLICIT NONE + class(grid_type) :: this + + ! Local variable + integer :: ilon, ilat + + DO ilon = 1, this%nlon + CALL normalize_longitude (this%lon_w(ilon)) + CALL normalize_longitude (this%lon_e(ilon)) + ENDDO + + DO ilat = 1, this%nlat + this%lat_s(ilat) = max(-90.0, min(90.0, this%lat_s(ilat))) + this%lat_n(ilat) = max(-90.0, min(90.0, this%lat_n(ilat))) + ENDDO + + IF (this%lat_s(1) <= this%lat_s(this%nlat)) THEN + this%yinc = 1 + ELSE + this%yinc = -1 + ENDIF + + ! align grid + DO ilon = 1, this%nlon-1 + IF (lon_between_ceil(this%lon_e(ilon), this%lon_w(ilon+1), this%lon_e(ilon+1))) THEN + this%lon_e(ilon) = this%lon_w(ilon+1) + ELSE + this%lon_w(ilon+1) = this%lon_e(ilon) + ENDIF + ENDDO + + IF (this%nlon > 1) THEN + ilon = this%nlon + IF (lon_between_ceil(this%lon_e(ilon), this%lon_w(1), this%lon_e(1))) THEN + this%lon_e(ilon) = this%lon_w(1) + ENDIF + ENDIF + + DO ilat = 1, this%nlat-1 + IF (this%yinc == 1) THEN + this%lat_n(ilat) = max(this%lat_n(ilat),this%lat_s(ilat+1)) + this%lat_s(ilat+1) = this%lat_n(ilat) + ELSEIF (this%yinc == -1) THEN + this%lat_s(ilat) = min(this%lat_s(ilat),this%lat_n(ilat+1)) + this%lat_n(ilat+1) = this%lat_s(ilat) + ENDIF + ENDDO + + END SUBROUTINE grid_normalize + + !----------------------------------------------------- + SUBROUTINE grid_set_blocks (this) + + USE MOD_Namelist + USE MOD_Block + USE MOD_Utils + IMPLICIT NONE + + class (grid_type) :: this + + ! Local variables + integer :: ilat, ilon, iblk, jblk, ilon_e + real(r8) :: edges, edgen, edgew, edgee + + IF (allocated(this%xcnt)) deallocate(this%xcnt) + IF (allocated(this%xdsp)) deallocate(this%xdsp) + IF (allocated(this%ycnt)) deallocate(this%ycnt) + IF (allocated(this%ydsp)) deallocate(this%ydsp) + allocate (this%xcnt (gblock%nxblk)) + allocate (this%xdsp (gblock%nxblk)) + allocate (this%ycnt (gblock%nyblk)) + allocate (this%ydsp (gblock%nyblk)) + + IF (allocated(this%xblk)) deallocate(this%xblk) + IF (allocated(this%yblk)) deallocate(this%yblk) + allocate (this%xblk (this%nlon)) + allocate (this%yblk (this%nlat)) + + IF (allocated(this%xloc)) deallocate(this%xloc) + IF (allocated(this%yloc)) deallocate(this%yloc) + allocate (this%xloc (this%nlon)) + allocate (this%yloc (this%nlat)) + + edges = DEF_domain%edges + edgen = DEF_domain%edgen + edgew = DEF_domain%edgew + edgee = DEF_domain%edgee + + CALL normalize_longitude (edgew) + CALL normalize_longitude (edgee) + + IF (this%yinc == 1) THEN + + this%ycnt(:) = 0 + this%yblk(:) = 0 + + IF (edges < this%lat_s(1)) THEN + jblk = find_nearest_south (this%lat_s(1), gblock%nyblk, gblock%lat_s) + ilat = 1 + ELSE + jblk = find_nearest_south (edges, gblock%nyblk, gblock%lat_s) + ilat = find_nearest_south (edges, this%nlat, this%lat_s) + ENDIF + + this%ydsp(jblk) = ilat - 1 + + DO WHILE (ilat <= this%nlat) + IF (this%lat_s(ilat) < edgen) THEN + IF (this%lat_s(ilat) < gblock%lat_n(jblk)) THEN + + this%ycnt(jblk) = this%ycnt(jblk) + 1 + + this%yblk(ilat) = jblk + this%yloc(ilat) = this%ycnt(jblk) + + ilat = ilat + 1 + ELSE + jblk = jblk + 1 + IF (jblk <= gblock%nyblk) THEN + this%ydsp(jblk) = ilat - 1 + ELSE + EXIT + ENDIF + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + ELSE + + this%ycnt(:) = 0 + this%yblk(:) = 0 + + IF (edgen > this%lat_n(1)) THEN + jblk = find_nearest_north (this%lat_n(1), gblock%nyblk, gblock%lat_n) + ilat = 1 + ELSE + jblk = find_nearest_north (edgen, gblock%nyblk, gblock%lat_n) + ilat = find_nearest_north (edgen, this%nlat, this%lat_n) + ENDIF + + this%ydsp(jblk) = ilat - 1 + + DO WHILE (ilat <= this%nlat) + IF (this%lat_n(ilat) > edges) THEN + IF (this%lat_n(ilat) > gblock%lat_s(jblk)) THEN + + this%ycnt(jblk) = this%ycnt(jblk) + 1 + + this%yblk(ilat) = jblk + this%yloc(ilat) = this%ycnt(jblk) + + ilat = ilat + 1 + ELSE + jblk = jblk - 1 + IF (jblk >= 1) THEN + this%ydsp(jblk) = ilat - 1 + ELSE + EXIT + ENDIF + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + ENDIF + + + this%xcnt(:) = 0 + this%xblk(:) = 0 + + IF ((this%lon_w(1) /= this%lon_e(this%nlon)) & + .and. (lon_between_floor(edgew, this%lon_e(this%nlon), this%lon_w(1)))) THEN + iblk = find_nearest_west (this%lon_w(1), gblock%nxblk, gblock%lon_w) + ilon = 1 + ELSE + iblk = find_nearest_west (edgew, gblock%nxblk, gblock%lon_w) + ilon = find_nearest_west (edgew, this%nlon, this%lon_w) + ENDIF + + this%xdsp(iblk) = ilon - 1 + this%xcnt(iblk) = 1 + this%xblk(ilon) = iblk + this%xloc(ilon) = 1 + + ilon_e = ilon - 1 + IF (ilon_e == 0) ilon_e = this%nlon + ilon = mod(ilon,this%nlon) + 1 + DO WHILE (.true.) + IF (lon_between_floor(this%lon_w(ilon), edgew, edgee)) THEN + IF (lon_between_floor(this%lon_w(ilon), gblock%lon_w(iblk), gblock%lon_e(iblk))) THEN + + this%xcnt(iblk) = this%xcnt(iblk) + 1 + + this%xblk(ilon) = iblk + this%xloc(ilon) = this%xcnt(iblk) + + IF (ilon /= ilon_e) THEN + ilon = mod(ilon,this%nlon) + 1 + ELSE + EXIT + ENDIF + ELSE + iblk = mod(iblk,gblock%nxblk) + 1 + IF (this%xcnt(iblk) == 0) THEN + this%xdsp(iblk) = ilon - 1 + ELSE + ilon_e = this%xdsp(iblk) + this%xcnt(iblk) + IF (ilon_e > this%nlon) ilon_e = ilon_e - this%nlon + + this%xdsp(iblk) = ilon - 1 + this%xcnt(iblk) = 0 + DO WHILE (.true.) + this%xcnt(iblk) = this%xcnt(iblk) + 1 + this%xblk(ilon) = iblk + this%xloc(ilon) = this%xcnt(iblk) + + IF (ilon /= ilon_e) THEN + ilon = mod(ilon,this%nlon) + 1 + ELSE + EXIT + ENDIF + ENDDO + + EXIT + ENDIF + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + END SUBROUTINE grid_set_blocks + + !----------- + SUBROUTINE grid_set_rlon (this) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (grid_type) :: this + + ! Local variables + integer :: ix + real(r8) :: lon + + IF (.not. allocated(this%rlon)) THEN + allocate (this%rlon(this%nlon)) + ENDIF + + DO ix = 1, this%nlon + IF (this%lon_w(ix) <= this%lon_e(ix)) THEN + lon = (this%lon_w(ix) + this%lon_e(ix)) * 0.5 + ELSE + lon = (this%lon_w(ix) + this%lon_e(ix)) * 0.5 + 180.0 + ENDIF + + CALL normalize_longitude (lon) + + this%rlon(ix) = lon / 180.0_r8 * pi + ENDDO + + END SUBROUTINE grid_set_rlon + + !----------- + SUBROUTINE grid_set_rlat (this) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (grid_type) :: this + + ! Local variables + integer :: iy + + IF (.not. allocated(this%rlat)) THEN + allocate (this%rlat(this%nlat)) + ENDIF + + DO iy = 1, this%nlat + this%rlat(iy) = & + (this%lat_s(iy) + this%lat_n(iy)) * 0.5 / 180.0_r8 * pi + ENDDO + + END SUBROUTINE grid_set_rlat + + !--------- + SUBROUTINE grid_free_mem (this) + + IMPLICIT NONE + type (grid_type) :: this + + IF (allocated (this%lat_s)) deallocate (this%lat_s) + IF (allocated (this%lat_n)) deallocate (this%lat_n) + IF (allocated (this%lon_w)) deallocate (this%lon_w) + IF (allocated (this%lon_e)) deallocate (this%lon_e) + + IF (allocated (this%xdsp)) deallocate (this%xdsp) + IF (allocated (this%ydsp)) deallocate (this%ydsp) + + IF (allocated (this%xcnt)) deallocate (this%xcnt) + IF (allocated (this%ycnt)) deallocate (this%ycnt) + + IF (allocated (this%xblk)) deallocate (this%xblk) + IF (allocated (this%yblk)) deallocate (this%yblk) + + IF (allocated (this%xloc)) deallocate (this%xloc) + IF (allocated (this%yloc)) deallocate (this%yloc) + + IF (allocated (this%xgrd)) deallocate (this%xgrd) + IF (allocated (this%ygrd)) deallocate (this%ygrd) + + IF (allocated (this%rlon)) deallocate (this%rlon) + IF (allocated (this%rlat)) deallocate (this%rlat) + + END SUBROUTINE grid_free_mem + + !---------- + SUBROUTINE set_grid_concat (this, grid) + + USE MOD_Block + USE MOD_Utils + IMPLICIT NONE + + class(grid_concat_type) :: this + type(grid_type), intent(in) :: grid + + ! Local variables + integer :: ilat_l, ilat_u, ilat, ilatloc, jblk, iyseg + integer :: ilon_w, ilon_e, ilon, ilonloc, iblk, ixseg + + ilat_l = findloc_ud(grid%yblk /= 0) + ilat_u = findloc_ud(grid%yblk /= 0, back=.true.) + + this%ginfo%nlat = ilat_u - ilat_l + 1 + IF (allocated(this%ginfo%lat_s)) deallocate(this%ginfo%lat_s) + IF (allocated(this%ginfo%lat_n)) deallocate(this%ginfo%lat_n) + IF (allocated(this%ginfo%lat_c)) deallocate(this%ginfo%lat_c) + allocate (this%ginfo%lat_s (this%ginfo%nlat)) + allocate (this%ginfo%lat_n (this%ginfo%nlat)) + allocate (this%ginfo%lat_c (this%ginfo%nlat)) + + this%nyseg = 0 + jblk = 0 + ilatloc = 0 + DO ilat = ilat_l, ilat_u + IF (grid%yblk(ilat) /= jblk) THEN + this%nyseg = this%nyseg + 1 + jblk = grid%yblk(ilat) + ENDIF + + ilatloc = ilatloc + 1 + this%ginfo%lat_s(ilatloc) = grid%lat_s(ilat) + this%ginfo%lat_n(ilatloc) = grid%lat_n(ilat) + this%ginfo%lat_c(ilatloc) = (grid%lat_s(ilat)+grid%lat_n(ilat)) * 0.5 + ENDDO + + IF (allocated(this%ysegs)) deallocate(this%ysegs) + allocate (this%ysegs (this%nyseg)) + + iyseg = 0 + jblk = 0 + DO ilat = ilat_l, ilat_u + IF (grid%yblk(ilat) /= jblk) THEN + iyseg = iyseg + 1 + jblk = grid%yblk(ilat) + this%ysegs(iyseg)%blk = jblk + this%ysegs(iyseg)%bdsp = grid%yloc(ilat) - 1 + this%ysegs(iyseg)%gdsp = ilat - ilat_l + this%ysegs(iyseg)%cnt = 1 + ELSE + this%ysegs(iyseg)%cnt = this%ysegs(iyseg)%cnt + 1 + ENDIF + ENDDO + + IF (all(grid%xblk > 0)) THEN + ilon_w = 1 + ilon_e = grid%nlon + ELSE + ilon_w = findloc_ud(grid%xblk /= 0) + DO WHILE (.true.) + ilon = ilon_w - 1 + IF (ilon == 0) ilon = grid%nlon + + IF (grid%xblk(ilon) /= 0) THEN + ilon_w = ilon + ELSE + EXIT + ENDIF + ENDDO + + ilon_e = ilon_w + DO WHILE (.true.) + ilon = mod(ilon_e,grid%nlon) + 1 + + IF (grid%xblk(ilon) /= 0) THEN + ilon_e = ilon + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + this%ginfo%nlon = ilon_e - ilon_w + 1 + IF (this%ginfo%nlon <= 0) THEN + this%ginfo%nlon = this%ginfo%nlon + grid%nlon + ENDIF + + IF (allocated(this%ginfo%lon_w)) deallocate(this%ginfo%lon_w) + IF (allocated(this%ginfo%lon_e)) deallocate(this%ginfo%lon_e) + IF (allocated(this%ginfo%lon_c)) deallocate(this%ginfo%lon_c) + allocate (this%ginfo%lon_w (this%ginfo%nlon)) + allocate (this%ginfo%lon_e (this%ginfo%nlon)) + allocate (this%ginfo%lon_c (this%ginfo%nlon)) + + this%nxseg = 0 + ilon = ilon_w - 1 + iblk = 0 + ilonloc = 0 + DO WHILE (.true.) + ilon = mod(ilon,grid%nlon) + 1 + IF ((grid%xblk(ilon) /= iblk) .or. (grid%xloc(ilon) == 1)) THEN + this%nxseg = this%nxseg + 1 + iblk = grid%xblk(ilon) + ENDIF + + ilonloc = ilonloc + 1 + this%ginfo%lon_w(ilonloc) = grid%lon_w(ilon) + this%ginfo%lon_e(ilonloc) = grid%lon_e(ilon) + + this%ginfo%lon_c(ilonloc) = (grid%lon_w(ilon) + grid%lon_e(ilon)) * 0.5 + IF (grid%lon_w(ilon) > grid%lon_e(ilon)) THEN + this%ginfo%lon_c(ilonloc) = this%ginfo%lon_c(ilonloc) + 180.0 + CALL normalize_longitude (this%ginfo%lon_c(ilonloc)) + ENDIF + + IF (ilon == ilon_e) EXIT + ENDDO + + DO ilon = 2, this%ginfo%nlon + IF ((this%ginfo%lon_c(ilon) < this%ginfo%lon_c(ilon-1)) & + .and. (this%ginfo%lon_c(ilon) < 0)) THEN + this%ginfo%lon_c(ilon) = this%ginfo%lon_c(ilon) + 360.0 + ENDIF + ENDDO + + IF (allocated(this%xsegs)) deallocate(this%xsegs) + allocate (this%xsegs (this%nxseg)) + + ixseg = 0 + iblk = 0 + ilon = ilon_w - 1 + ilonloc = 0 + DO WHILE (.true.) + ilon = mod(ilon,grid%nlon) + 1 + ilonloc = ilonloc + 1 + IF ((grid%xblk(ilon) /= iblk) .or. (grid%xloc(ilon) == 1)) THEN + ixseg = ixseg + 1 + iblk = grid%xblk(ilon) + this%xsegs(ixseg)%blk = iblk + this%xsegs(ixseg)%bdsp = grid%xloc(ilon) - 1 + this%xsegs(ixseg)%gdsp = ilonloc - 1 + this%xsegs(ixseg)%cnt = 1 + ELSE + this%xsegs(ixseg)%cnt = this%xsegs(ixseg)%cnt + 1 + ENDIF + + IF (ilon == ilon_e) EXIT + ENDDO + + this%ndatablk = 0 + + DO iyseg = 1, this%nyseg + DO ixseg = 1, this%nxseg + iblk = this%xsegs(ixseg)%blk + jblk = this%ysegs(iyseg)%blk + IF (gblock%pio(iblk,jblk) >= 0) THEN + this%ndatablk = this%ndatablk + 1 + ENDIF + ENDDO + ENDDO + + END SUBROUTINE set_grid_concat + + !------- + SUBROUTINE grid_concat_free_mem (this) + + IMPLICIT NONE + + type(grid_concat_type) :: this + + IF (allocated(this%xsegs)) deallocate(this%xsegs) + IF (allocated(this%ysegs)) deallocate(this%ysegs) + + IF (allocated(this%ginfo%lat_s)) deallocate(this%ginfo%lat_s) + IF (allocated(this%ginfo%lat_n)) deallocate(this%ginfo%lat_n) + IF (allocated(this%ginfo%lat_c)) deallocate(this%ginfo%lat_c) + IF (allocated(this%ginfo%lon_w)) deallocate(this%ginfo%lon_w) + IF (allocated(this%ginfo%lon_e)) deallocate(this%ginfo%lon_e) + IF (allocated(this%ginfo%lon_c)) deallocate(this%ginfo%lon_c) + + END SUBROUTINE grid_concat_free_mem + + ! ------- + SUBROUTINE get_region_by_this_IO ( grid, & + west, east, north, south, iwest, ieast, isouth, inorth) + + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + + real(r8), intent(out) :: west, east, north, south + integer, intent(out) :: iwest, ieast, inorth, isouth + + ! Local Variables + integer :: iblk, jblk + + IF (p_is_io) THEN + + IF (gblock%nblkme /= 1) THEN + write(*,*) 'Warning: more than one block is on IO processor: ', p_iam_glb + west = spval; iwest = -1 + east = spval; ieast = -1 + north = spval; inorth = -1 + south = spval; isouth = -1 + RETURN + ENDIF + + iblk = gblock%xblkme(1) + jblk = gblock%yblkme(1) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + + IF (grid%yinc == 1) THEN + inorth = grid%ydsp(jblk) + grid%ycnt(jblk) + isouth = grid%ydsp(jblk) + 1 + ELSE + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + ENDIF + + west = grid%lon_w(iwest ) + east = grid%lon_e(ieast ) + north = grid%lat_n(inorth) + south = grid%lat_s(isouth) + + ENDIF + + END SUBROUTINE get_region_by_this_IO + +END MODULE MOD_Grid diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 new file mode 100644 index 0000000000..2d8a195d55 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 @@ -0,0 +1,946 @@ +MODULE MOD_IncompleteGamma + + USE MOD_Precision, ONLY: r8 + IMPLICIT REAL(KIND=r8) (A-H,O-Z) + +! ALGORITHM 654, COLLECTED ALGORITHMS FROM ACM. +! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, +! VOL. 13, NO. 3, P. 318. + +CONTAINS + + SUBROUTINE GRATIO (A, X, ANS, QANS, IND) +! ---------------------------------------------------------------------- +! EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +! P(A,X) AND Q(A,X) +! +! ---------- +! +! IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X +! ARE NOT BOTH 0. +! +! ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE +! P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. +! IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS +! POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF +! IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE +! 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY +! IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. +! +! ERROR RETURN ... +! ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, +! WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. +! P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN +! X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. +! ---------------------------------------------------------------------- +! WRITTEN BY ALFRED H. MORRIS, JR. +! NAVAL SURFACE WEAPONS CENTER +! DAHLGREN, VIRGINIA +! -------------------- + REAL(r8) J, L, ACC0(3), BIG(3), E00(3), X00(3), WK(20) + REAL(r8) D0(13), D1(12), D2(10), D3(8), D4(6), D5(4), D6(2) +! -------------------- + DATA ACC0(1)/5.E-15/, ACC0(2)/5.E-7/, ACC0(3)/5.E-4/ + DATA BIG(1)/20.0/, BIG(2)/14.0/, BIG(3)/10.0/ + DATA E00(1)/.25E-3/, E00(2)/.25E-1/, E00(3)/.14/ + DATA X00(1)/31.0/, X00(2)/17.0/, X00(3)/9.7/ +! -------------------- +! ALOG10 = LN(10) +! RT2PIN = 1/SQRT(2*PI) +! RTPI = SQRT(PI) +! -------------------- + DATA ALOG10/2.30258509299405/ + DATA RT2PIN/.398942280401433/ + DATA RTPI /1.77245385090552/ + DATA THIRD /.333333333333333/ +! -------------------- + DATA D0(1) / .833333333333333E-01/, D0(2) /-.148148148148148E-01/, & + D0(3) / .115740740740741E-02/, D0(4) / .352733686067019E-03/, & + D0(5) /-.178755144032922E-03/, D0(6) / .391926317852244E-04/, & + D0(7) /-.218544851067999E-05/, D0(8) /-.185406221071516E-05/, & + D0(9) / .829671134095309E-06/, D0(10)/-.176659527368261E-06/, & + D0(11)/ .670785354340150E-08/, D0(12)/ .102618097842403E-07/, & + D0(13)/-.438203601845335E-08/ +! -------------------- + DATA D10 /-.185185185185185E-02/, D1(1) /-.347222222222222E-02/, & + D1(2) / .264550264550265E-02/, D1(3) /-.990226337448560E-03/, & + D1(4) / .205761316872428E-03/, D1(5) /-.401877572016461E-06/, & + D1(6) /-.180985503344900E-04/, D1(7) / .764916091608111E-05/, & + D1(8) /-.161209008945634E-05/, D1(9) / .464712780280743E-08/, & + D1(10)/ .137863344691572E-06/, D1(11)/-.575254560351770E-07/, & + D1(12)/ .119516285997781E-07/ +! -------------------- + DATA D20 / .413359788359788E-02/, D2(1) /-.268132716049383E-02/, & + D2(2) / .771604938271605E-03/, D2(3) / .200938786008230E-05/, & + D2(4) /-.107366532263652E-03/, D2(5) / .529234488291201E-04/, & + D2(6) /-.127606351886187E-04/, D2(7) / .342357873409614E-07/, & + D2(8) / .137219573090629E-05/, D2(9) /-.629899213838006E-06/, & + D2(10)/ .142806142060642E-06/ +! -------------------- + DATA D30 / .649434156378601E-03/, D3(1) / .229472093621399E-03/, & + D3(2) /-.469189494395256E-03/, D3(3) / .267720632062839E-03/, & + D3(4) /-.756180167188398E-04/, D3(5) /-.239650511386730E-06/, & + D3(6) / .110826541153473E-04/, D3(7) /-.567495282699160E-05/, & + D3(8) / .142309007324359E-05/ +! -------------------- + DATA D40 /-.861888290916712E-03/, D4(1) / .784039221720067E-03/, & + D4(2) /-.299072480303190E-03/, D4(3) /-.146384525788434E-05/, & + D4(4) / .664149821546512E-04/, D4(5) /-.396836504717943E-04/, & + D4(6) / .113757269706784E-04/ +! -------------------- + DATA D50 /-.336798553366358E-03/, D5(1) /-.697281375836586E-04/, & + D5(2) / .277275324495939E-03/, D5(3) /-.199325705161888E-03/, & + D5(4) / .679778047793721E-04/ +! -------------------- + DATA D60 / .531307936463992E-03/, D6(1) /-.592166437353694E-03/, & + D6(2) / .270878209671804E-03/ +! -------------------- + DATA D70 / .344367606892378E-03/ +! -------------------- +! ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST +! FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +! +! E = SPMPAR(1) + E = epsilon(1._r8) +! +! -------------------- + IF (A .LT. 0.0 .OR. X .LT. 0.0) GO TO 400 + IF (A .EQ. 0.0 .AND. X .EQ. 0.0) GO TO 400 + IF (A*X .EQ. 0.0) GO TO 331 +! + IOP = IND + 1 + IF (IOP .NE. 1 .AND. IOP .NE. 2) IOP = 3 + ACC = DMAX1(ACC0(IOP),E) + E0 = E00(IOP) + X0 = X00(IOP) +! +! SELECT THE APPROPRIATE ALGORITHM +! + IF (A .GE. 1.0) GO TO 10 + IF (A .EQ. 0.5) GO TO 320 + IF (X .LT. 1.1) GO TO 110 + T1 = A*LOG(X) - X + U = A*EXP(T1) + IF (U .EQ. 0.0) GO TO 310 + R = U*(1.0 + GAM1(A)) + GO TO 170 +! + 10 IF (A .GE. BIG(IOP)) GO TO 20 + IF (A .GT. X .OR. X .GE. X0) GO TO 11 + TWOA = A + A + M = INT(TWOA) + IF (TWOA .NE. REAL(M, r8)) GO TO 11 + I = M/2 + IF (A .EQ. REAL(I, r8)) GO TO 140 + GO TO 150 + 11 T1 = A*LOG(X) - X + R = EXP(T1)/GAMMA(A) + GO TO 30 +! + 20 L = X/A + IF (L .EQ. 0.0) GO TO 300 + S = 0.5 + (0.5 - L) + Z = RLOG(L) + IF (Z .GE. 700.0/A) GO TO 330 + Y = A*Z + RTA = SQRT(A) + IF (ABS(S) .LE. E0/RTA) GO TO 250 + IF (ABS(S) .LE. 0.4) GO TO 200 +! + T = (1.0/A)**2 + T1 = (((0.75*T - 1.0)*T + 3.5)*T - 105.0)/(A*1260.0) + T1 = T1 - Y + R = RT2PIN*RTA*EXP(T1) +! + 30 IF (R .EQ. 0.0) GO TO 331 + IF (X .LE. DMAX1(A,ALOG10)) GO TO 50 + IF (X .LT. X0) GO TO 170 + GO TO 80 +! +! TAYLOR SERIES FOR P/R +! + 50 APN = A + 1.0 + T = X/APN + WK(1) = T + DO N = 2,20 + APN = APN + 1.0 + T = T*(X/APN) + IF (T .LE. 1.E-3) GO TO 60 + WK(N) = T + ENDDO + N = 20 +! + 60 SUM = T + TOL = 0.5*ACC + 61 APN = APN + 1.0 + T = T*(X/APN) + SUM = SUM + T + IF (T .GT. TOL) GO TO 61 +! + MAX = N - 1 + DO M = 1,MAX + N = N - 1 + SUM = SUM + WK(N) + ENDDO + ANS = (R/A)*(1.0 + SUM) + QANS = 0.5 + (0.5 - ANS) + RETURN +! +! ASYMPTOTIC EXPANSION +! + 80 AMN = A - 1.0 + T = AMN/X + WK(1) = T + DO N = 2,20 + AMN = AMN - 1.0 + T = T*(AMN/X) + IF (ABS(T) .LE. 1.E-3) GO TO 90 + WK(N) = T + ENDDO + N = 20 +! + 90 SUM = T + 91 IF (ABS(T) .LE. ACC) GO TO 100 + AMN = AMN - 1.0 + T = T*(AMN/X) + SUM = SUM + T + GO TO 91 +! + 100 MAX = N - 1 + DO M = 1,MAX + N = N - 1 + SUM = SUM + WK(N) + ENDDO + QANS = (R/X)*(1.0 + SUM) + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! TAYLOR SERIES FOR P(A,X)/X**A +! + 110 AN = 3.0 + C = X + SUM = X/(A + 3.0) + TOL = 3.0*ACC/(A + 1.0) + 111 AN = AN + 1.0 + C = -C*(X/AN) + T = C/(A + AN) + SUM = SUM + T + IF (ABS(T) .GT. TOL) GO TO 111 + J = A*X*((SUM/6.0 - 0.5/(A + 2.0))*X + 1.0/(A + 1.0)) +! + Z = A*LOG(X) + H = GAM1(A) + G = 1.0 + H + IF (X .LT. 0.25) GO TO 120 + IF (A .LT. X/2.59) GO TO 135 + GO TO 130 + 120 IF (Z .GT. -.13394) GO TO 135 +! + 130 W = EXP(Z) + ANS = W*G*(0.5 + (0.5 - J)) + QANS = 0.5 + (0.5 - ANS) + RETURN +! + 135 L = REXP(Z) + W = 0.5 + (0.5 + L) + QANS = (W*J - L)*G - H + IF (QANS .LT. 0.0) GO TO 310 + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! FINITE SUMS FOR Q WHEN A .GE. 1 +! AND 2*A IS AN INTEGER +! + 140 SUM = EXP(-X) + T = SUM + N = 1 + C = 0.0 + GO TO 160 +! + 150 RTX = SQRT(X) + SUM = ERFC1(0,RTX) + T = EXP(-X)/(RTPI*RTX) + N = 0 + C = -0.5 +! + 160 IF (N .EQ. I) GO TO 161 + N = N + 1 + C = C + 1.0 + T = (X*T)/C + SUM = SUM + T + GO TO 160 + 161 QANS = SUM + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! CONTINUED FRACTION EXPANSION +! + 170 TOL = DMAX1(5.0_r8*E,ACC) + A2NM1 = 1.0 + A2N = 1.0 + B2NM1 = X + B2N = X + (1.0 - A) + C = 1.0 + 171 A2NM1 = X*A2N + C*A2NM1 + B2NM1 = X*B2N + C*B2NM1 + AM0 = A2NM1/B2NM1 + C = C + 1.0 + CMA = C - A + A2N = A2NM1 + CMA*A2N + B2N = B2NM1 + CMA*B2N + AN0 = A2N/B2N + IF (ABS(AN0 - AM0) .GE. TOL*AN0) GO TO 171 +! + QANS = R*AN0 + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! GENERAL TEMME EXPANSION +! + 200 IF (ABS(S) .LE. 2.0*E .AND. A*E*E .GT. 3.28E-3) GO TO 400 + C = EXP(-Y) + W = 0.5*ERFC1(1,SQRT(Y)) + U = 1.0/A + Z = SQRT(Z + Z) + IF (L .LT. 1.0) Z = -Z + IF (IOP < 2) THEN + GO TO 210 + ELSEIF (IOP == 2) THEN + GO TO 220 + ELSE + GO TO 230 + ENDIF +! + 210 IF (ABS(S) .LE. 1.E-3) GO TO 260 + C0 = ((((((((((((D0(13) * Z + D0(12)) * Z + D0(11)) * Z & + + D0(10)) * Z + D0(9)) * Z + D0(8)) * Z + D0(7)) * Z & + + D0(6)) * Z + D0(5)) * Z + D0(4)) * Z + D0(3)) * Z & + + D0(2)) * Z + D0(1)) * Z - THIRD + C1 = (((((((((((D1(12) * Z + D1(11)) * Z + D1(10)) * Z & + + D1(9)) * Z + D1(8)) * Z + D1(7)) * Z + D1(6)) * Z & + + D1(5)) * Z + D1(4)) * Z + D1(3)) * Z + D1(2)) * Z & + + D1(1)) * Z + D10 + C2 = (((((((((D2(10) * Z + D2(9)) * Z + D2(8)) * Z & + + D2(7)) * Z + D2(6)) * Z + D2(5)) * Z + D2(4)) * Z & + + D2(3)) * Z + D2(2)) * Z + D2(1)) * Z + D20 + C3 = (((((((D3(8) * Z + D3(7)) * Z + D3(6)) * Z & + + D3(5)) * Z + D3(4)) * Z + D3(3)) * Z + D3(2)) * Z & + + D3(1)) * Z + D30 + C4 = (((((D4(6) * Z + D4(5)) * Z + D4(4)) * Z + D4(3)) * Z & + + D4(2)) * Z + D4(1)) * Z + D40 + C5 = (((D5(4) * Z + D5(3)) * Z + D5(2)) * Z + D5(1)) * Z & + + D50 + C6 = (D6(2) * Z + D6(1)) * Z + D60 + T = ((((((D70*U + C6)*U + C5)*U + C4)*U + C3)*U + C2)*U & + + C1)*U + C0 + GO TO 240 +! + 220 C0 = (((((D0(6) * Z + D0(5)) * Z + D0(4)) * Z + D0(3)) * Z & + + D0(2)) * Z + D0(1)) * Z - THIRD + C1 = (((D1(4) * Z + D1(3)) * Z + D1(2)) * Z + D1(1)) * Z & + + D10 + C2 = D2(1) * Z + D20 + T = (C2*U + C1)*U + C0 + GO TO 240 +! + 230 T = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z - THIRD +! + 240 IF (L .LT. 1.0) GO TO 241 + QANS = C*(W + RT2PIN*T/RTA) + ANS = 0.5 + (0.5 - QANS) + RETURN + 241 ANS = C*(W - RT2PIN*T/RTA) + QANS = 0.5 + (0.5 - ANS) + RETURN +! +! TEMME EXPANSION FOR L = 1 +! + 250 IF (A*E*E .GT. 3.28E-3) GO TO 400 + C = 0.5 + (0.5 - Y) + W = (0.5 - SQRT(Y)*(0.5 + (0.5 - Y/3.0))/RTPI)/C + U = 1.0/A + Z = SQRT(Z + Z) + IF (L .LT. 1.0) Z = -Z + IF (IOP < 2) THEN + GO TO 260 + ELSEIF (IOP == 2) THEN + GO TO 270 + ELSE + GO TO 280 + ENDIF +! + 260 C0 = ((((((D0(7) * Z + D0(6)) * Z + D0(5)) * Z + D0(4)) * Z & + + D0(3)) * Z + D0(2)) * Z + D0(1)) * Z - THIRD + C1 = (((((D1(6) * Z + D1(5)) * Z + D1(4)) * Z + D1(3)) * Z & + + D1(2)) * Z + D1(1)) * Z + D10 + C2 = ((((D2(5) * Z + D2(4)) * Z + D2(3)) * Z + D2(2)) * Z & + + D2(1)) * Z + D20 + C3 = (((D3(4) * Z + D3(3)) * Z + D3(2)) * Z + D3(1)) * Z & + + D30 + C4 = (D4(2) * Z + D4(1)) * Z + D40 + C5 = (D5(2) * Z + D5(1)) * Z + D50 + C6 = D6(1) * Z + D60 + T = ((((((D70*U + C6)*U + C5)*U + C4)*U + C3)*U + C2)*U & + + C1)*U + C0 + GO TO 240 +! + 270 C0 = (D0(2) * Z + D0(1)) * Z - THIRD + C1 = D1(1) * Z + D10 + T = (D20*U + C1)*U + C0 + GO TO 240 +! + 280 T = D0(1) * Z - THIRD + GO TO 240 +! +! SPECIAL CASES +! + 300 ANS = 0.0 + QANS = 1.0 + RETURN +! + 310 ANS = 1.0 + QANS = 0.0 + RETURN +! + 320 IF (X .GE. 0.25) GO TO 321 + ANS = ERF(SQRT(X)) + QANS = 0.5 + (0.5 - ANS) + RETURN + 321 QANS = ERFC1(0,SQRT(X)) + ANS = 0.5 + (0.5 - QANS) + RETURN +! + 330 IF (ABS(S) .LE. 2.0*E) GO TO 400 + 331 IF (X .LE. A) GO TO 300 + GO TO 310 +! +! ERROR RETURN +! + 400 ANS = 2.0 + RETURN + + END SUBROUTINE + + + + FUNCTION ERF(X) +! ****************************************************************** +! EVALUATION OF THE REAL ERROR FUNCTION +! ****************************************************************** + DIMENSION A(4),B(4),P(8),Q(8),R(5),S(5) + DATA A(1)/-1.65581836870402E-4/, A(2)/3.25324098357738E-2/, & + A(3)/1.02201136918406E-1/, A(4)/1.12837916709552E00/ + DATA B(1)/4.64988945913179E-3/, B(2)/7.01333417158511E-2/, & + B(3)/4.23906732683201E-1/, B(4)/1.00000000000000E00/ + DATA P(1)/-1.36864857382717E-7/, P(2)/5.64195517478974E-1/, & + P(3)/7.21175825088309E00/, P(4)/4.31622272220567E01/, & + P(5)/1.52989285046940E02/, P(6)/3.39320816734344E02/, & + P(7)/4.51918953711873E02/, P(8)/3.00459261020162E02/ + DATA Q(1)/1.00000000000000E00/, Q(2)/1.27827273196294E01/, & + Q(3)/7.70001529352295E01/, Q(4)/2.77585444743988E02/, & + Q(5)/6.38980264465631E02/, Q(6)/9.31354094850610E02/, & + Q(7)/7.90950925327898E02/, Q(8)/3.00459260956983E02/ + DATA R(1)/2.10144126479064E00/, R(2)/2.62370141675169E01/, & + R(3)/2.13688200555087E01/, R(4)/4.65807828718470E00/, & + R(5)/2.82094791773523E-1/ + DATA S(1)/9.41537750555460E01/, S(2)/1.87114811799590E02/, & + S(3)/9.90191814623914E01/, S(4)/1.80124575948747E01/, & + S(5)/1.00000000000000E00/ + DATA C/5.64189583547756E-1/ +! ------------------- + AX=ABS(X) + X2=AX*AX + IF (AX.GE.0.5) GO TO 10 + TOP=((A(1)*X2+A(2))*X2+A(3))*X2+A(4) + BOT=((B(1)*X2+B(2))*X2+B(3))*X2+B(4) + ERF=X*TOP/BOT + RETURN +! + 10 IF (AX.GT.4.0) GO TO 20 + TOP=((((((P(1)*AX+P(2))*AX+P(3))*AX+P(4))*AX+P(5))*AX & + +P(6))*AX+P(7))*AX+P(8) + BOT=((((((Q(1)*AX+Q(2))*AX+Q(3))*AX+Q(4))*AX+Q(5))*AX & + +Q(6))*AX+Q(7))*AX+Q(8) + ERF=1.0-EXP(-X2)*TOP/BOT + IF (X.LT.0.0) ERF=-ERF + RETURN +! + 20 ERF=1.0 + IF (AX.GE.5.54) GO TO 21 + T=1.0/X2 + TOP=(((R(1)*T+R(2))*T+R(3))*T+R(4))*T+R(5) + BOT=(((S(1)*T+S(2))*T+S(3))*T+S(4))*T+S(5) + ERF=C-TOP/(X2*BOT) + ERF=1.0-EXP(-X2)*ERF/AX + 21 IF (X.LT.0.0) ERF=-ERF + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION ERFC1(IND,X) +! ---------------------------------------------------------------------- +! EVALUATION OF THE REAL COMPLEMENTARY ERROR FUNCTION +! +! ERFC1(IND,X) = ERFC(X) IF IND = 0 +! ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE +! ---------------------------------------------------------------------- + DIMENSION A(4),B(4),P(8),Q(8),R(5),S(5) + DATA A(1)/-1.65581836870402E-4/, A(2)/3.25324098357738E-2/, & + A(3)/1.02201136918406E-1/, A(4)/1.12837916709552E00/ + DATA B(1)/4.64988945913179E-3/, B(2)/7.01333417158511E-2/, & + B(3)/4.23906732683201E-1/, B(4)/1.00000000000000E00/ + DATA P(1)/-1.36864857382717E-7/, P(2)/5.64195517478974E-1/, & + P(3)/7.21175825088309E00/, P(4)/4.31622272220567E01/, & + P(5)/1.52989285046940E02/, P(6)/3.39320816734344E02/, & + P(7)/4.51918953711873E02/, P(8)/3.00459261020162E02/ + DATA Q(1)/1.00000000000000E00/, Q(2)/1.27827273196294E01/, & + Q(3)/7.70001529352295E01/, Q(4)/2.77585444743988E02/, & + Q(5)/6.38980264465631E02/, Q(6)/9.31354094850610E02/, & + Q(7)/7.90950925327898E02/, Q(8)/3.00459260956983E02/ + DATA R(1)/2.10144126479064E00/, R(2)/2.62370141675169E01/, & + R(3)/2.13688200555087E01/, R(4)/4.65807828718470E00/, & + R(5)/2.82094791773523E-1/ + DATA S(1)/9.41537750555460E01/, S(2)/1.87114811799590E02/, & + S(3)/9.90191814623914E01/, S(4)/1.80124575948747E01/, & + S(5)/1.00000000000000E00/ + DATA C/5.64189583547756E-1/ +! ------------------- + AX=ABS(X) + X2=AX*AX + IF (AX.GE.0.47) GO TO 10 + TOP=((A(1)*X2+A(2))*X2+A(3))*X2+A(4) + BOT=((B(1)*X2+B(2))*X2+B(3))*X2+B(4) + ERFC1=1.0-X*TOP/BOT + IF (IND.NE.0) ERFC1=EXP(X2)*ERFC1 + RETURN +! + 10 IF (AX.GT.4.0) GO TO 20 + TOP=((((((P(1)*AX+P(2))*AX+P(3))*AX+P(4))*AX+P(5))*AX & + +P(6))*AX+P(7))*AX+P(8) + BOT=((((((Q(1)*AX+Q(2))*AX+Q(3))*AX+Q(4))*AX+Q(5))*AX & + +Q(6))*AX+Q(7))*AX+Q(8) + ERFC1=TOP/BOT + IF (IND.EQ.0) GO TO 11 + IF (X.LT.0.0) ERFC1=2.0*EXP(X2)-ERFC1 + RETURN + 11 ERFC1=EXP(-X2)*ERFC1 + IF (X.LT.0.0) ERFC1=2.0-ERFC1 + RETURN +! + 20 IF (X.LE.-5.33) GO TO 30 + T=1.0/X2 + TOP=(((R(1)*T+R(2))*T+R(3))*T+R(4))*T+R(5) + BOT=(((S(1)*T+S(2))*T+S(3))*T+S(4))*T+S(5) + ERFC1=(C-TOP/(X2*BOT))/AX + IF (IND.EQ.0) GO TO 11 + IF (X.LT.0.0) ERFC1=2.0*EXP(X2)-ERFC1 + RETURN +! + 30 ERFC1=2.0 + IF (IND.NE.0) ERFC1=EXP(X2)*ERFC1 + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION REXP(X) +! ------------------------------------------------------------------ +! COMPUTATION OF EXP(X) - 1 +! ------------------------------------------------------------------ + DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/, & + Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/, & + Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/ +! ------------------ + IF (ABS(X) .GT. 0.15) GO TO 10 + REXP = X*(((P2*X + P1)*X + 1.0)/((((Q4*X + Q3)*X + Q2)*X & + + Q1)*X + 1.0)) + RETURN +! + 10 W = EXP(X) + IF (X .GT. 0.0) GO TO 20 + REXP = (W - 0.5) - 0.5 + RETURN + 20 REXP = W*(0.5 + (0.5 - 1.0/W)) + RETURN + END FUNCTION + + + + REAL(r8) FUNCTION RLOG(X) +! ------------------- +! COMPUTATION OF X - 1 - LN(X) +! ------------------- + DATA A/.566749439387324E-01/ + DATA B/.456512608815524E-01/ +! ------------------- + DATA P0/ .333333333333333E+00/, P1/-.224696413112536E+00/, & + P2/ .620886815375787E-02/ + DATA Q1/-.127408923933623E+01/, Q2/ .354508718369557E+00/ +! ------------------- + IF (X .LT. 0.61 .OR. X .GT. 1.57) GO TO 100 + IF (X .LT. 0.82) GO TO 10 + IF (X .GT. 1.18) GO TO 20 +! +! ARGUMENT REDUCTION +! + U = (X - 0.5) - 0.5 + W1 = 0.0 + GO TO 30 +! + 10 U = DBLE(X) - 0.7D0 + U = U/0.7 + W1 = A - U*0.3 + GO TO 30 +! + 20 U = 0.75D0*DBLE(X) - 1.D0 + W1 = B + U/3.0 +! +! SERIES EXPANSION +! + 30 R = U/(U + 2.0) + T = R*R + W = ((P2*T + P1)*T + P0)/((Q2*T + Q1)*T + 1.0) + RLOG = 2.0*T*(1.0/(1.0 - R) - R*W) + W1 + RETURN +! +! + 100 R = (X - 0.5) - 0.5 + RLOG = R - LOG(X) + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION GAMMA(A) +!----------------------------------------------------------------------- +! +! EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS +! +! ----------- +! +! GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT +! BE COMPUTED. +! +!----------------------------------------------------------------------- +! WRITTEN BY ALFRED H. MORRIS, JR. +! NAVAL SURFACE WEAPONS CENTER +! DAHLGREN, VIRGINIA +!----------------------------------------------------------------------- + REAL(r8) P(7), Q(7) + DOUBLE PRECISION D, G, Z, LNX +!-------------------------- +! D = 0.5*(LN(2*PI) - 1) +!-------------------------- + DATA PI /3.1415926535898/ + DATA D /.41893853320467274178D0/ +!-------------------------- + DATA P(1)/ .539637273585445E-03/, P(2)/ .261939260042690E-02/, & + P(3)/ .204493667594920E-01/, P(4)/ .730981088720487E-01/, & + P(5)/ .279648642639792E+00/, P(6)/ .553413866010467E+00/, & + P(7)/ 1.0/ + DATA Q(1)/-.832979206704073E-03/, Q(2)/ .470059485860584E-02/, & + Q(3)/ .225211131035340E-01/, Q(4)/-.170458969313360E+00/, & + Q(5)/-.567902761974940E-01/, Q(6)/ .113062953091122E+01/, & + Q(7)/ 1.0/ +!-------------------------- + DATA R1/.820756370353826E-03/, R2/-.595156336428591E-03/, & + R3/.793650663183693E-03/, R4/-.277777777770481E-02/, & + R5/.833333333333333E-01/ +!-------------------------- + GAMMA = 0.0 + X = A + IF (ABS(A) .GE. 15.0) GO TO 60 +!----------------------------------------------------------------------- +! EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 +!----------------------------------------------------------------------- + T = 1.0 + M = INT(A) - 1 +! +! LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 +! + IF (M < 0) THEN + GO TO 20 + ELSEIF (M == 0) THEN + GO TO 12 + ELSE + GO TO 10 + ENDIF + + 10 DO J = 1,M + X = X - 1.0 + T = X*T + ENDDO + 12 X = X - 1.0 + GO TO 40 +! +! LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 +! + 20 T = A + IF (A .GT. 0.0) GO TO 30 + M = - M - 1 + IF (M .EQ. 0) GO TO 22 + DO J = 1,M + X = X + 1.0 + T = X*T + ENDDO + 22 X = (X + 0.5) + 0.5 + T = X*T + IF (T .EQ. 0.0) RETURN +! + 30 CONTINUE +! +! THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS +! CODE MAY BE OMITTED IF DESIRED. +! + IF (ABS(T) .GE. 1.E-30) GO TO 40 +! IF (ABS(T)*SPMPAR(3) .LE. 1.0001) RETURN + IF (ABS(T)*HUGE(1._r8) .LE. 1.0001) RETURN + GAMMA = 1.0/T + RETURN +! +! COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 +! + 40 TOP = P(1) + BOT = Q(1) + DO I = 2,7 + TOP = P(I) + X*TOP + BOT = Q(I) + X*BOT + ENDDO + GAMMA = TOP/BOT +! +! TERMINATION +! + IF (A .LT. 1.0) GO TO 50 + GAMMA = GAMMA*T + RETURN + 50 GAMMA = GAMMA/T + RETURN +!----------------------------------------------------------------------- +! EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 +!----------------------------------------------------------------------- + 60 IF (ABS(A) .GE. 1.E3) RETURN + IF (A .GT. 0.0) GO TO 70 + X = -A + N = X + T = X - N + IF (T .GT. 0.9) T = 1.0 - T + S = SIN(PI*T)/PI + IF (MOD(N,2) .EQ. 0) S = -S + IF (S .EQ. 0.0) RETURN +! +! COMPUTE THE MODIFIED ASYMPTOTIC SUM +! + 70 T = 1.0/(X*X) + G = ((((R1*T + R2)*T + R3)*T + R4)*T + R5)/X +! +! ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) +! BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. +! + LNX = GLOG(X) +! +! FINAL ASSEMBLY +! + Z = X + G = (D + G) + (Z - 0.5D0)*(LNX - 1.D0) + W = G + T = G - DBLE(W) + IF (W .GT. 0.99999*EXPARG(0)) RETURN + GAMMA = EXP(W)*(1.0 + T) + IF (A .LT. 0.0) GAMMA = (1.0/(GAMMA*S))/X + RETURN + + END FUNCTION + + + + DOUBLE PRECISION FUNCTION GLOG(X) +! ------------------- +! EVALUATION OF LN(X) FOR X .GE. 15 +! ------------------- + REAL(r8) X + DOUBLE PRECISION Z, W(163) +! ------------------- + DATA C1/.286228750476730/, C2/.399999628131494/, & + C3/.666666666752663/ +! ------------------- +! W(J) = LN(J + 14) FOR EACH J +! ------------------- + DATA W(1) /.270805020110221007D+01/, & + W(2) /.277258872223978124D+01/, W(3) /.283321334405621608D+01/, & + W(4) /.289037175789616469D+01/, W(5) /.294443897916644046D+01/, & + W(6) /.299573227355399099D+01/, W(7) /.304452243772342300D+01/, & + W(8) /.309104245335831585D+01/, W(9) /.313549421592914969D+01/, & + W(10)/.317805383034794562D+01/, W(11)/.321887582486820075D+01/, & + W(12)/.325809653802148205D+01/, W(13)/.329583686600432907D+01/, & + W(14)/.333220451017520392D+01/, W(15)/.336729582998647403D+01/, & + W(16)/.340119738166215538D+01/, W(17)/.343398720448514625D+01/, & + W(18)/.346573590279972655D+01/, W(19)/.349650756146648024D+01/, & + W(20)/.352636052461616139D+01/, W(21)/.355534806148941368D+01/, & + W(22)/.358351893845611000D+01/, W(23)/.361091791264422444D+01/, & + W(24)/.363758615972638577D+01/, W(25)/.366356164612964643D+01/, & + W(26)/.368887945411393630D+01/, W(27)/.371357206670430780D+01/, & + W(28)/.373766961828336831D+01/, W(29)/.376120011569356242D+01/, & + W(30)/.378418963391826116D+01/ + DATA W(31)/.380666248977031976D+01/, & + W(32)/.382864139648909500D+01/, W(33)/.385014760171005859D+01/, & + W(34)/.387120101090789093D+01/, W(35)/.389182029811062661D+01/, & + W(36)/.391202300542814606D+01/, W(37)/.393182563272432577D+01/, & + W(38)/.395124371858142735D+01/, W(39)/.397029191355212183D+01/, & + W(40)/.398898404656427438D+01/, W(41)/.400733318523247092D+01/, & + W(42)/.402535169073514923D+01/, W(43)/.404305126783455015D+01/, & + W(44)/.406044301054641934D+01/, W(45)/.407753744390571945D+01/, & + W(46)/.409434456222210068D+01/, W(47)/.411087386417331125D+01/, & + W(48)/.412713438504509156D+01/, W(49)/.414313472639153269D+01/, & + W(50)/.415888308335967186D+01/, W(51)/.417438726989563711D+01/, & + W(52)/.418965474202642554D+01/, W(53)/.420469261939096606D+01/, & + W(54)/.421950770517610670D+01/, W(55)/.423410650459725938D+01/, & + W(56)/.424849524204935899D+01/, W(57)/.426267987704131542D+01/, & + W(58)/.427666611901605531D+01/, W(59)/.429045944114839113D+01/, & + W(60)/.430406509320416975D+01/ + DATA W(61)/.431748811353631044D+01/, & + W(62)/.433073334028633108D+01/, W(63)/.434380542185368385D+01/, & + W(64)/.435670882668959174D+01/, W(65)/.436944785246702149D+01/, & + W(66)/.438202663467388161D+01/, W(67)/.439444915467243877D+01/, & + W(68)/.440671924726425311D+01/, W(69)/.441884060779659792D+01/, & + W(70)/.443081679884331362D+01/, W(71)/.444265125649031645D+01/, & + W(72)/.445434729625350773D+01/, W(73)/.446590811865458372D+01/, & + W(74)/.447733681447820647D+01/, W(75)/.448863636973213984D+01/, & + W(76)/.449980967033026507D+01/, W(77)/.451085950651685004D+01/, & + W(78)/.452178857704904031D+01/, W(79)/.453259949315325594D+01/, & + W(80)/.454329478227000390D+01/, W(81)/.455387689160054083D+01/, & + W(82)/.456434819146783624D+01/, W(83)/.457471097850338282D+01/, & + W(84)/.458496747867057192D+01/, W(85)/.459511985013458993D+01/, & + W(86)/.460517018598809137D+01/, W(87)/.461512051684125945D+01/, & + W(88)/.462497281328427108D+01/, W(89)/.463472898822963577D+01/, & + W(90)/.464439089914137266D+01/ + DATA W(91) /.465396035015752337D+01/, & + W(92) /.466343909411206714D+01/, W(93) /.467282883446190617D+01/, & + W(94) /.468213122712421969D+01/, W(95) /.469134788222914370D+01/, & + W(96) /.470048036579241623D+01/, W(97) /.470953020131233414D+01/, & + W(98) /.471849887129509454D+01/, W(99) /.472738781871234057D+01/, & + W(100)/.473619844839449546D+01/, W(101)/.474493212836325007D+01/, & + W(102)/.475359019110636465D+01/, W(103)/.476217393479775612D+01/, & + W(104)/.477068462446566476D+01/, W(105)/.477912349311152939D+01/, & + W(106)/.478749174278204599D+01/, W(107)/.479579054559674109D+01/, & + W(108)/.480402104473325656D+01/, W(109)/.481218435537241750D+01/, & + W(110)/.482028156560503686D+01/, W(111)/.482831373730230112D+01/, & + W(112)/.483628190695147800D+01/, W(113)/.484418708645859127D+01/, & + W(114)/.485203026391961717D+01/, W(115)/.485981240436167211D+01/, & + W(116)/.486753445045558242D+01/, W(117)/.487519732320115154D+01/, & + W(118)/.488280192258637085D+01/, W(119)/.489034912822175377D+01/, & + W(120)/.489783979995091137D+01/ + DATA W(121)/.490527477843842945D+01/, & + W(122)/.491265488573605201D+01/, W(123)/.491998092582812492D+01/, & + W(124)/.492725368515720469D+01/, W(125)/.493447393313069176D+01/, & + W(126)/.494164242260930430D+01/, W(127)/.494875989037816828D+01/, & + W(128)/.495582705760126073D+01/, W(129)/.496284463025990728D+01/, & + W(130)/.496981329957600062D+01/, W(131)/.497673374242057440D+01/, & + W(132)/.498360662170833644D+01/, W(133)/.499043258677873630D+01/, & + W(134)/.499721227376411506D+01/, W(135)/.500394630594545914D+01/, & + W(136)/.501063529409625575D+01/, W(137)/.501727983681492433D+01/, & + W(138)/.502388052084627639D+01/, W(139)/.503043792139243546D+01/, & + W(140)/.503695260241362916D+01/, W(141)/.504342511691924662D+01/, & + W(142)/.504985600724953705D+01/, W(143)/.505624580534830806D+01/, & + W(144)/.506259503302696680D+01/, W(145)/.506890420222023153D+01/, & + W(146)/.507517381523382692D+01/, W(147)/.508140436498446300D+01/, & + W(148)/.508759633523238407D+01/, W(149)/.509375020080676233D+01/, & + W(150)/.509986642782419842D+01/ + DATA W(151)/.510594547390058061D+01/, & + W(152)/.511198778835654323D+01/, W(153)/.511799381241675511D+01/, & + W(154)/.512396397940325892D+01/, W(155)/.512989871492307347D+01/, & + W(156)/.513579843705026176D+01/, W(157)/.514166355650265984D+01/, & + W(158)/.514749447681345304D+01/, W(159)/.515329159449777895D+01/, & + W(160)/.515905529921452903D+01/, W(161)/.516478597392351405D+01/, & + W(162)/.517048399503815178D+01/, W(163)/.517614973257382914D+01/ +! + IF (X .GE. 178.0) GO TO 10 + N = X + T = (X - N)/(X + N) + T2 = T*T + Z = (((C1*T2 + C2)*T2 + C3)*T2 + 2.0)*T + GLOG = W(N - 14) + Z + RETURN +! + 10 GLOG = LOG(X) + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION EXPARG (IDUMMY) +!-------------------------------------------------------------------- +! COMPUTATION OF THE LARGEST ARGUMENT W FOR WHICH EXP(W) +! MAY BE COMPUTED. (ONLY AN APPROXIMATE VALUE IS NEEDED.) +!-------------------------------------------------------------------- +! EXPARG = 0.99999*ALOG(SPMPAR(3)) + EXPARG = 0.99999*LOG(HUGE(1._r8)) + RETURN + END + + + + REAL(r8) FUNCTION GAM1(A) +! ------------------------------------------------------------------ +! COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 +! ------------------------------------------------------------------ + REAL(r8) P(7), Q(5), R(9) +! ------------------- + DATA P(1)/ .577215664901533E+00/, P(2)/-.409078193005776E+00/, & + P(3)/-.230975380857675E+00/, P(4)/ .597275330452234E-01/, & + P(5)/ .766968181649490E-02/, P(6)/-.514889771323592E-02/, & + P(7)/ .589597428611429E-03/ +! ------------------- + DATA Q(1)/ .100000000000000E+01/, Q(2)/ .427569613095214E+00/, & + Q(3)/ .158451672430138E+00/, Q(4)/ .261132021441447E-01/, & + Q(5)/ .423244297896961E-02/ +! ------------------- + DATA R(1)/-.422784335098468E+00/, R(2)/-.771330383816272E+00/, & + R(3)/-.244757765222226E+00/, R(4)/ .118378989872749E+00/, & + R(5)/ .930357293360349E-03/, R(6)/-.118290993445146E-01/, & + R(7)/ .223047661158249E-02/, R(8)/ .266505979058923E-03/, & + R(9)/-.132674909766242E-03/ +! ------------------- + DATA S1 / .273076135303957E+00/, S2 / .559398236957378E-01/ +! ------------------- + T = A + D = A - 0.5 + IF (D .GT. 0.0) T = D - 0.5 + IF (T < 0) THEN + GO TO 30 + ELSEIF (T == 0) THEN + GO TO 10 + ELSE + GO TO 20 + ENDIF +! + 10 GAM1 = 0.0 + RETURN +! + 20 TOP = (((((P(7)*T + P(6))*T + P(5))*T + P(4))*T + P(3))*T & + + P(2))*T + P(1) + BOT = (((Q(5)*T + Q(4))*T + Q(3))*T + Q(2))*T + 1.0 + W = TOP/BOT + IF (D .GT. 0.0) GO TO 21 + GAM1 = A*W + RETURN + 21 GAM1 = (T/A)*((W - 0.5) - 0.5) + RETURN +! + 30 TOP = (((((((R(9)*T + R(8))*T + R(7))*T + R(6))*T + R(5))*T & + + R(4))*T + R(3))*T + R(2))*T + R(1) + BOT = (S2*T + S1)*T + 1.0 + W = TOP/BOT + IF (D .GT. 0.0) GO TO 31 + GAM1 = A*((W + 0.5) + 0.5) + RETURN + 31 GAM1 = T*W/A + RETURN + + END FUNCTION + +END MODULE MOD_IncompleteGamma diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 new file mode 100644 index 0000000000..02bd497abf --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -0,0 +1,1045 @@ +#include + +MODULE MOD_Mesh + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! +! MESH refers to the set of largest elements in CoLM. +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! To represent ELEMENT in CoLM, the land surface is first divided into pixels, +! which are rasterized points defined by fine-resolution data. +! +! ELEMENT in MESH is set of pixels: +! 1. If GRIDBASED, ELEMENT is set of pixels in a longitude-latitude rectangle. +! 2. If UNSTRUCTURED, ELEMENT is set of pixels in an irregular area (usually polygon). +! 3. If CATCHMENT, ELEMENT is set of pixels in a catchment whose area is less than +! a predefined value. +! +! If GRIDBASED is defined, MESH is built by using input files containing mask of +! land area or by defining the resolution of longitude-latitude grid. +! If CATCHMENT or UNSTRUCTURED is defined, MESH is built by using input files +! containing index of elements. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_Grid + IMPLICIT NONE + + ! ---- data types ---- + type :: irregular_elm_type + + integer*8 :: indx + integer :: xblk, yblk + + integer :: npxl + integer, allocatable :: ilon(:) + integer, allocatable :: ilat(:) + + END type irregular_elm_type + + ! ---- Instance ---- + type (grid_type) :: gridmesh + + integer :: numelm + type (irregular_elm_type), allocatable :: mesh (:) + + integer, allocatable :: nelm_blk(:,:) + +#ifdef GRIDBASED + logical :: read_mesh_from_file = .true. +#endif + +CONTAINS + + ! ------ +#ifdef GRIDBASED + SUBROUTINE init_gridbased_mesh_grid () + + USE MOD_SPMD_Task + USE MOD_Namelist + IMPLICIT NONE + + IF (p_is_master) THEN + inquire (file=trim(DEF_file_mesh), exist=read_mesh_from_file) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#endif + IF (read_mesh_from_file) THEN + CALL gridmesh%define_from_file (DEF_file_mesh) + ELSE + CALL gridmesh%define_by_res (DEF_GRIDBASED_lon_res, DEF_GRIDBASED_lat_res) + ENDIF + + END SUBROUTINE init_gridbased_mesh_grid +#endif + + ! ------- + SUBROUTINE copy_elm (elm_from, elm_to) + + IMPLICIT NONE + type (irregular_elm_type), intent(in) :: elm_from + type (irregular_elm_type), intent(out) :: elm_to + + elm_to%indx = elm_from%indx + elm_to%npxl = elm_from%npxl + elm_to%xblk = elm_from%xblk + elm_to%yblk = elm_from%yblk + + IF (allocated(elm_to%ilat)) deallocate(elm_to%ilat) + IF (allocated(elm_to%ilon)) deallocate(elm_to%ilon) + + allocate (elm_to%ilat (elm_to%npxl)) + allocate (elm_to%ilon (elm_to%npxl)) + elm_to%ilon = elm_from%ilon + elm_to%ilat = elm_from%ilat + + END SUBROUTINE copy_elm + + ! -------------------------------- + SUBROUTINE mesh_build () + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFBlock + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_Utils + USE MOD_DataType + USE MOD_CatchmentDataReadin + + IMPLICIT NONE + + ! Local Variables + type(block_data_int32_2d) :: datamesh + + integer :: nelm, ie, je, dsp + integer :: iblkme, iblk, jblk, xloc, yloc, xg, yg, ixloc, iyloc + integer :: xp, yp, xblk, yblk, npxl, ipxl, ix, iy + integer :: iworker, iproc, idest, isrc, iloc, iloc_max(2) + integer :: ylg, yug, ysp, ynp, nyp + integer :: xlg, xug, xwp, xep, nxp + real(r8) :: dlatp, dlonp + logical :: is_new + integer :: smesg(6), rmesg(6), blktag, nsend, nrecv, irecv + integer :: iblk_p, jblk_p, nelm_max_blk, nelm_glb + + integer, allocatable :: nelm_worker(:) + type(pointer_int64_1d), allocatable :: elist_worker(:) + + integer*8 :: elmid + integer*8, allocatable :: elist(:), elist2(:,:), sbuf64(:), elist_recv(:) + + integer, allocatable :: iaddr(:), elmindx (:), order(:) + integer, allocatable :: xlist(:), ylist (:), npxl_(:), xlist_recv(:), ylist_recv(:), sbuf(:) + logical, allocatable :: msk (:), work_done(:) + + integer, allocatable :: xlist2(:,:), ylist2(:,:), ipt2(:,:), npxl_blk(:,:), blkdsp(:,:), blkcnt(:,:) + logical, allocatable :: msk2 (:,:) + + type(irregular_elm_type), allocatable :: meshtmp (:) + + + IF (p_is_io) THEN + CALL allocate_block_data (gridmesh, datamesh) + ENDIF + +#ifdef GRIDBASED + IF (read_mesh_from_file) THEN + CALL ncio_read_block (DEF_file_mesh, 'landmask', gridmesh, datamesh) + ELSE + CALL flush_block_data (datamesh, 1) + ENDIF +#endif + +#ifdef CATCHMENT + CALL catchment_data_read (DEF_CatchmentMesh_data, 'icatchment2d', gridmesh, datamesh, spv = -1) +#endif + +#ifdef UNSTRUCTURED + CALL ncio_read_block (DEF_file_mesh, 'elmindex', gridmesh, datamesh) +#endif + + ! Step 1: How many elms in each block? + IF (p_is_io) THEN + + nelm = 0 + + allocate (nelm_worker (0:p_np_worker-1)) + nelm_worker(:) = 0 + + allocate (elist_worker (0:p_np_worker-1)) + DO iworker = 0, p_np_worker-1 + allocate (elist_worker(iworker)%val (1000)) + ENDDO + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + DO yloc = 1, gridmesh%ycnt(jblk) + DO xloc = 1, gridmesh%xcnt(iblk) + +#ifdef GRIDBASED + IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN + xg = gridmesh%xdsp(iblk) + xloc + IF (xg > gridmesh%nlon) xg = xg - gridmesh%nlon + + yg = gridmesh%ydsp(jblk) + yloc + + elmid = int(gridmesh%nlon,8) * (yg-1) + xg + ELSE + elmid = 0 + ENDIF +#endif +#ifdef CATCHMENT + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) +#endif +#ifdef UNSTRUCTURED + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) +#endif + + IF (elmid > 0) THEN + + iworker = mod(elmid, p_np_worker) + CALL insert_into_sorted_list1 ( & + elmid, nelm_worker(iworker), elist_worker(iworker)%val, iloc) + + IF (nelm_worker(iworker) == size(elist_worker(iworker)%val)) THEN + CALL expand_list (elist_worker(iworker)%val, 0.2_r8) + ENDIF + + ENDIF + + ENDDO + ENDDO + +#ifdef USEMPI + DO iworker = 0, p_np_worker-1 + IF (nelm_worker(iworker) > 0) THEN + idest = p_address_worker(iworker) + smesg(1:2) = (/p_iam_glb, nelm_worker(iworker)/) + ! send(01) + CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & + idest, mpi_tag_size, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + nelm = nelm + sum(nelm_worker) + nelm_worker(:) = 0 + ENDDO + +#ifdef USEMPI + DO iworker = 0, p_np_worker-1 + idest = p_address_worker(iworker) + ! send(02) + smesg(1:2) = (/p_iam_glb, 0/) + CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & + idest, mpi_tag_size, p_comm_glb, p_err) + ENDDO +#endif + + deallocate (nelm_worker) + DO iworker = 0, p_np_worker-1 + deallocate (elist_worker(iworker)%val) + ENDDO + deallocate (elist_worker) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + nelm = 0 + allocate(work_done(0:p_np_io-1)) + work_done(:) = .false. + DO WHILE (.not. all(work_done)) + ! recv(01,02) + CALL mpi_recv (rmesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_size, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nrecv = rmesg(2) + + IF (nrecv > 0) THEN + nelm = nelm + nrecv + ELSE + work_done(p_itis_io(isrc)) = .true. + ENDIF + ENDDO + + deallocate(work_done) + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + ! Step 2: Build pixel list for each elm. + IF (p_is_worker) THEN + IF (nelm > 0) THEN + allocate (meshtmp (nelm)) + allocate (elist (nelm)) + allocate (iaddr (nelm)) + ENDIF + nelm = 0 + ENDIF + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (gridmesh%xcnt(iblk) <= 0) CYCLE + IF (gridmesh%ycnt(jblk) <= 0) CYCLE + + ylg = gridmesh%ydsp(jblk) + 1 + yug = gridmesh%ydsp(jblk) + gridmesh%ycnt(jblk) + IF (gridmesh%yinc == 1) THEN + ysp = find_nearest_south (gridmesh%lat_s(ylg), pixel%nlat, pixel%lat_s) + ynp = find_nearest_north (gridmesh%lat_n(yug), pixel%nlat, pixel%lat_n) + ELSE + ysp = find_nearest_south (gridmesh%lat_s(yug), pixel%nlat, pixel%lat_s) + ynp = find_nearest_north (gridmesh%lat_n(ylg), pixel%nlat, pixel%lat_n) + ENDIF + + nyp = ynp - ysp + 1 + + xlg = gridmesh%xdsp(iblk) + 1 + xug = gridmesh%xdsp(iblk) + gridmesh%xcnt(iblk) + IF (xug > gridmesh%nlon) xug = xug - gridmesh%nlon + + xwp = find_nearest_west (gridmesh%lon_w(xlg), pixel%nlon, pixel%lon_w) + IF (.not. lon_between_floor(pixel%lon_w(xwp), gridmesh%lon_w(xlg), gridmesh%lon_e(xlg))) THEN + xwp = mod(xwp,pixel%nlon) + 1 + ENDIF + + xep = find_nearest_east (gridmesh%lon_e(xug), pixel%nlon, pixel%lon_e) + IF (.not. lon_between_ceil(pixel%lon_e(xep), gridmesh%lon_w(xug), gridmesh%lon_e(xug))) THEN + xep = xep - 1 + IF (xep == 0) xep = pixel%nlon + ENDIF + + nxp = xep - xwp + 1 + IF (nxp <= 0) nxp = nxp + pixel%nlon + + allocate (elist2 (nxp,nyp)) + allocate (xlist2 (nxp,nyp)) + allocate (ylist2 (nxp,nyp)) + allocate (msk2 (nxp,nyp)) + + DO iy = ysp, ynp + yg = gridmesh%ygrd(iy) + yloc = gridmesh%yloc(yg) + + iyloc = iy - ysp + 1 + dlatp = pixel%lat_n(iy) - pixel%lat_s(iy) + IF (dlatp < 1.0e-6_r8) THEN + elist2(:,iyloc) = 0 + CYCLE + ENDIF + + ix = xwp + ixloc = 0 + DO WHILE (.true.) + ixloc = ixloc + 1 + dlonp = pixel%lon_e(ix) - pixel%lon_w(ix) + IF (dlonp < 0) dlonp = dlonp + 360.0_r8 + + xg = gridmesh%xgrd(ix) + xloc = gridmesh%xloc(xg) + +#ifdef GRIDBASED + IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN + elmid = int(gridmesh%nlon,8) * (yg-1) + xg + ELSE + elmid = 0 + ENDIF +#endif +#ifdef CATCHMENT + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) +#endif +#ifdef UNSTRUCTURED + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) +#endif + + xlist2(ixloc,iyloc) = ix + ylist2(ixloc,iyloc) = iy + elist2(ixloc,iyloc) = elmid + + IF (dlonp < 1.0e-6_r8) THEN + elist2(ixloc,iyloc) = 0 + ENDIF + + IF (ix == xep) EXIT + ix = mod(ix,pixel%nlon) + 1 + ENDDO + ENDDO + +#ifdef USEMPI + allocate (sbuf (nxp*nyp)) + allocate (ipt2 (nxp,nyp)) + + allocate (sbuf64 (nxp*nyp)) + + blktag = iblkme + ipt2 = mod(elist2, p_np_worker) + DO iproc = 0, p_np_worker-1 + msk2 = (ipt2 == iproc) .and. (elist2 > 0) + nsend = count(msk2) + IF (nsend > 0) THEN + + idest = p_address_worker(iproc) + + smesg(1:3) = (/p_iam_glb, nsend, blktag/) + ! send(03) + CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + + sbuf64(1:nsend) = pack(elist2, msk2) + ! send(04) + CALL mpi_send (sbuf64(1:nsend), nsend, MPI_INTEGER8, & + idest, blktag, p_comm_glb, p_err) + + sbuf(1:nsend) = pack(xlist2, msk2) + ! send(05) + CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, & + idest, blktag, p_comm_glb, p_err) + + sbuf(1:nsend) = pack(ylist2, msk2) + ! send(06) + CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, & + idest, blktag, p_comm_glb, p_err) + + ENDIF + ENDDO + + deallocate (sbuf ) + deallocate (ipt2 ) + deallocate (sbuf64) +#else + + DO iy = 1, nyp + DO ix = 1, nxp + + elmid = elist2(ix,iy) + IF (elmid > 0) THEN + + CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new) + + msk2 = (elist2 == elmid) + npxl = count(msk2) + + IF (is_new) THEN + IF (iloc < nelm) THEN + iaddr(iloc+1:nelm) = iaddr(iloc:nelm-1) + ENDIF + iaddr(iloc) = nelm + + meshtmp(iaddr(iloc))%indx = elmid + meshtmp(iaddr(iloc))%npxl = npxl + ELSE + meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl + ENDIF + + allocate (xlist(npxl)) + allocate (ylist(npxl)) + xlist = pack(xlist2, msk2) + ylist = pack(ylist2, msk2) + + CALL append_to_list (meshtmp(iaddr(iloc))%ilon, xlist) + CALL append_to_list (meshtmp(iaddr(iloc))%ilat, ylist) + + WHERE(msk2) elist2 = -1 + + deallocate (xlist) + deallocate (ylist) + ENDIF + + ENDDO + ENDDO +#endif + + deallocate (elist2) + deallocate (xlist2) + deallocate (ylist2) + deallocate (msk2 ) + + ENDDO + +#ifdef USEMPI + DO iworker = 0, p_np_worker-1 + idest = p_address_worker(iworker) + ! send(07) + smesg(1:3) = (/p_iam_glb, 0, 0/) + CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + ENDDO +#endif + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + allocate(work_done(0:p_np_io-1)) + work_done(:) = .false. + DO WHILE (.not. all(work_done)) + ! recv(03,07) + CALL mpi_recv (rmesg(1:3), 3, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nrecv = rmesg(2) + blktag = rmesg(3) + IF (nrecv > 0) THEN + + allocate (elist_recv (nrecv)) + ! recv(04) + CALL mpi_recv (elist_recv, nrecv, MPI_INTEGER8, & + isrc, blktag, p_comm_glb, p_stat, p_err) + + allocate (xlist_recv (nrecv)) + ! recv(05) + CALL mpi_recv (xlist_recv, nrecv, MPI_INTEGER, & + isrc, blktag, p_comm_glb, p_stat, p_err) + + allocate (ylist_recv (nrecv)) + ! recv(06) + CALL mpi_recv (ylist_recv, nrecv, MPI_INTEGER, & + isrc, blktag, p_comm_glb, p_stat, p_err) + + allocate (msk(nrecv)) + + DO irecv = 1, nrecv + + elmid = elist_recv(irecv) + + IF (elmid > 0) THEN + + CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new) + + msk = (elist_recv == elmid) + npxl = count(msk) + + IF (is_new) THEN + IF (iloc < nelm) THEN + iaddr(iloc+1:nelm) = iaddr(iloc:nelm-1) + ENDIF + iaddr(iloc) = nelm + + meshtmp(iaddr(iloc))%indx = elmid + meshtmp(iaddr(iloc))%npxl = npxl + ELSE + meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl + ENDIF + + allocate (xlist(npxl)) + allocate (ylist(npxl)) + xlist = pack(xlist_recv, msk) + ylist = pack(ylist_recv, msk) + + CALL append_to_list (meshtmp(iaddr(iloc))%ilon, xlist) + CALL append_to_list (meshtmp(iaddr(iloc))%ilat, ylist) + + WHERE(msk) elist_recv = -1 + deallocate (xlist) + deallocate (ylist) + ENDIF + + ENDDO + + deallocate (msk) + deallocate (elist_recv) + deallocate (xlist_recv) + deallocate (ylist_recv) + ELSE + work_done(p_itis_io(isrc)) = .true. + ENDIF + ENDDO + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (allocated(elist)) deallocate (elist) + IF (allocated(iaddr)) deallocate (iaddr) + + ! Step 3: Which block each elm locates at. + IF (p_is_worker) THEN + + allocate (npxl_blk (gblock%nxblk,gblock%nyblk)) + allocate (nelm_blk (gblock%nxblk,gblock%nyblk)) + + nelm_blk(:,:) = 0 + + DO ie = 1, nelm + + npxl_blk (:,:) = 0 + + DO ipxl = 1, meshtmp(ie)%npxl + xp = meshtmp(ie)%ilon(ipxl) + yp = meshtmp(ie)%ilat(ipxl) + + xg = gridmesh%xgrd(xp) + yg = gridmesh%ygrd(yp) + + xblk = gridmesh%xblk(xg) + yblk = gridmesh%yblk(yg) + + npxl_blk(xblk,yblk) = npxl_blk(xblk,yblk) + 1 + ENDDO + + iloc_max = maxloc(npxl_blk) + meshtmp(ie)%xblk = iloc_max(1) + meshtmp(ie)%yblk = iloc_max(2) + + nelm_blk(iloc_max(1), iloc_max(2)) = & + nelm_blk(iloc_max(1), iloc_max(2)) + 1 + + ENDDO + + deallocate (npxl_blk) + ENDIF + +#ifdef USEMPI + IF (.not. p_is_worker) THEN + allocate (nelm_blk (gblock%nxblk,gblock%nyblk)) + nelm_blk(:,:) = 0 + ENDIF + + CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, & + MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) +#endif + + ! Step 4: IF MPI is used, sending elms from worker to their IO processes. + + IF (p_is_io) THEN + + allocate (blkdsp (gblock%nxblk, gblock%nyblk)) + blkdsp(1,1) = 0 + DO iblk = 1, gblock%nxblk + DO jblk = 1, gblock%nyblk + IF ((iblk /= 1) .or. (jblk /= 1)) THEN + IF (jblk == 1) THEN + iblk_p = iblk - 1 + jblk_p = gblock%nyblk + ELSE + iblk_p = iblk + jblk_p = jblk - 1 + ENDIF + + IF (gblock%pio(iblk_p,jblk_p) == p_iam_glb) THEN + blkdsp(iblk,jblk) = blkdsp(iblk_p,jblk_p) + nelm_blk(iblk_p,jblk_p) + ELSE + blkdsp(iblk,jblk) = blkdsp(iblk_p,jblk_p) + ENDIF + ENDIF + ENDDO + ENDDO + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + DO iblk = 1, gblock%nxblk + DO jblk = 1, gblock%nyblk + + idest = gblock%pio(iblk,jblk) + + nsend = 0 + npxl = 0 + DO ie = 1, nelm + IF ((meshtmp(ie)%xblk == iblk) .and. (meshtmp(ie)%yblk == jblk)) THEN + nsend = nsend + 1 + npxl = npxl + meshtmp(ie)%npxl + ENDIF + ENDDO + + IF (nsend > 0) THEN + + allocate (elist (nsend)) + allocate (npxl_ (nsend)) + allocate (xlist (npxl )) + allocate (ylist (npxl )) + + nsend = 0 + npxl = 0 + DO ie = 1, nelm + IF ((meshtmp(ie)%xblk == iblk) .and. (meshtmp(ie)%yblk == jblk)) THEN + + nsend = nsend + 1 + + elist(nsend) = meshtmp(ie)%indx + npxl_(nsend) = meshtmp(ie)%npxl + + xlist(npxl+1:npxl+meshtmp(ie)%npxl) = meshtmp(ie)%ilon + ylist(npxl+1:npxl+meshtmp(ie)%npxl) = meshtmp(ie)%ilat + + npxl = npxl + meshtmp(ie)%npxl + ENDIF + ENDDO + + blktag = p_iam_glb + 1000 + + ! send(09) + smesg(1:6) = (/p_iam_glb, blktag, iblk, jblk, nsend, npxl/) + CALL mpi_send (smesg(1:6), 6, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) + + ! send(10) + CALL mpi_send (elist, nsend, MPI_INTEGER8, idest, blktag, p_comm_glb, p_err) + CALL mpi_send (npxl_, nsend, MPI_INTEGER, idest, blktag, p_comm_glb, p_err) + + ! send(11) + CALL mpi_send (xlist, npxl, MPI_INTEGER, idest, blktag, p_comm_glb, p_err) + CALL mpi_send (ylist, npxl, MPI_INTEGER, idest, blktag, p_comm_glb, p_err) + + deallocate (elist) + deallocate (npxl_) + deallocate (xlist) + deallocate (ylist) + + ENDIF + ENDDO + ENDDO + ENDIF + + IF (p_is_io) THEN + + numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) + + IF (numelm > 0) THEN + + allocate (mesh (numelm)) + + allocate (blkcnt (gblock%nxblk, gblock%nyblk)) + blkcnt(:,:) = 0 + + DO WHILE (sum(blkcnt) < numelm) + + ! recv(09) + CALL mpi_recv (rmesg(1:6), 6, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = rmesg(1) + blktag = rmesg(2) + xblk = rmesg(3) + yblk = rmesg(4) + nrecv = rmesg(5) + npxl = rmesg(6) + + allocate (elist (nrecv)) + allocate (npxl_ (nrecv)) + allocate (xlist (npxl )) + allocate (ylist (npxl )) + + ! recv(10) + CALL mpi_recv (elist, nrecv, MPI_INTEGER8, isrc, blktag, p_comm_glb, p_stat, p_err) + CALL mpi_recv (npxl_, nrecv, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err) + + ! recv(11) + CALL mpi_recv (xlist, npxl, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err) + CALL mpi_recv (ylist, npxl, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err) + + dsp = 0 + DO ie = 1, nrecv + + je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk) + ie + + mesh(je)%indx = elist(ie) + mesh(je)%xblk = xblk + mesh(je)%yblk = yblk + mesh(je)%npxl = npxl_(ie) + + allocate (mesh(je)%ilon (npxl_(ie))) + allocate (mesh(je)%ilat (npxl_(ie))) + + mesh(je)%ilon = xlist(dsp+1:dsp+npxl_(ie)) + mesh(je)%ilat = ylist(dsp+1:dsp+npxl_(ie)) + + dsp = dsp + npxl_(ie) + + ENDDO + + blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + nrecv + + deallocate (elist) + deallocate (npxl_) + deallocate (xlist) + deallocate (ylist) + + ENDDO + + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) + +#else + numelm = nelm + IF (numelm > 0) THEN + + allocate (mesh (numelm)) + + allocate (blkcnt (gblock%nxblk, gblock%nyblk)) + blkcnt(:,:) = 0 + DO ie = 1, numelm + + xblk = meshtmp(ie)%xblk + yblk = meshtmp(ie)%yblk + + blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + 1 + je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk) + + CALL copy_elm (meshtmp(ie), mesh(je)) + + ENDDO + + ENDIF +#endif + + ! Step 4-2: sort elms. + IF (p_is_io) THEN + IF (allocated (meshtmp)) THEN + DO ie = 1, size(meshtmp) + IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon) + IF (allocated(meshtmp(ie)%ilat)) deallocate (meshtmp(ie)%ilat) + ENDDO + deallocate (meshtmp) + ENDIF + + IF (numelm > 0) THEN + allocate (meshtmp (numelm)) + DO ie = 1, numelm + CALL copy_elm(mesh(ie), meshtmp(ie)) + ENDDO + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + IF (blkcnt(iblk,jblk) > 0) THEN + allocate (elmindx (blkcnt(iblk,jblk))) + allocate (order (blkcnt(iblk,jblk))) + + DO ie = blkdsp(iblk,jblk)+1, blkdsp(iblk,jblk)+blkcnt(iblk,jblk) + elmindx(ie-blkdsp(iblk,jblk)) = mesh(ie)%indx + ENDDO + + order = (/ (ie, ie = 1, blkcnt(iblk,jblk)) /) + CALL quicksort (blkcnt(iblk,jblk), elmindx, order) + + DO ie = 1, blkcnt(iblk,jblk) + CALL copy_elm (meshtmp(blkdsp(iblk,jblk)+order(ie)), & + mesh(blkdsp(iblk,jblk)+ie)) + ENDDO + + deallocate (elmindx) + deallocate (order ) + ENDIF + + ENDDO + ENDIF + ENDIF + + IF (allocated(blkdsp)) deallocate(blkdsp) + IF (allocated(blkcnt)) deallocate(blkcnt) + + IF (allocated (meshtmp)) THEN + DO ie = 1, size(meshtmp) + IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon) + IF (allocated(meshtmp(ie)%ilat)) deallocate (meshtmp(ie)%ilat) + ENDDO + + deallocate (meshtmp ) + ENDIF + + ! Step 5: IF MPI is used, scatter elms from IO to workers. +#ifdef USEMPI + CALL scatter_mesh_from_io_to_worker () +#endif + + IF (p_is_master) THEN + write(*,'(A)') 'Making mesh elements:' + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_io) THEN + + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_io, p_err) + IF (p_iam_io == p_root) THEN + write(*,'(A,I12,A)') 'Total : ', nelm_glb, ' elements.' + ENDIF + + nelm_max_blk = maxval(nelm_blk, mask = gblock%pio == p_iam_glb) + CALL mpi_allreduce (MPI_IN_PLACE, nelm_max_blk, 1, MPI_INTEGER, MPI_MAX, p_comm_io, p_err) + IF (p_iam_io == p_root) THEN + write(*,'(A,I12,A)') 'Maximum : ', nelm_max_blk, & + ' elements in one block (More than 3600 is recommended).' + write(*,'(/,A)') ' -----------------------------------------------------------------' + write(*,'(A)') ' | Examples for setting of blocks and processor groupsize: |' + write(*,'(A)') ' | Resolution DEF_nx_blocks DEF_ny_blocks DEF_PIO_groupsize |' + write(*,'(A)') ' | 2x2 18 9 15 |' + write(*,'(A)') ' | 1x1 18 9 24 |' + write(*,'(A)') ' | 0.5x0.5 18 9 36 |' + write(*,'(A)') ' | 0.25x0.25 30 15 45 |' + write(*,'(A)') ' | 0.1x0.1 72 36 64 |' + write(*,'(A,/)') ' -----------------------------------------------------------------' + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numelm, ' elements.' +#endif + + END SUBROUTINE mesh_build + + +#ifdef USEMPI + ! -------------------------------- + SUBROUTINE scatter_mesh_from_io_to_worker + + USE MOD_SPMD_Task + USE MOD_Block + IMPLICIT NONE + + ! Local variables + integer :: iblk, jblk, nave, nres, iproc, ndsp, nsend, idest, ie + integer :: smesg(4), rmesg(4) + integer, allocatable :: nelm_worker(:) + integer :: iblkme + character(len=20) :: wfmt + + CALL mpi_barrier (p_comm_glb, p_err) + + IF (p_is_io) THEN + + allocate (nelm_worker (1:p_np_group-1)) + nelm_worker(:) = 0 + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + nave = nelm_blk(iblk,jblk) / (p_np_group-1) + nres = mod(nelm_blk(iblk,jblk), p_np_group-1) + DO iproc = 1, p_np_group-1 + nelm_worker(iproc) = nelm_worker(iproc) + nave + IF (iproc <= nres) nelm_worker(iproc) = nelm_worker(iproc) + 1 + ENDDO + ENDDO + + IF (any(nelm_worker == 0)) THEN + write(*,'(A,/,A)') 'Warning: there are idle workers, please use less processors ' // & + 'OR larger working group ', ' (set by DEF_PIO_groupsize in CoLM namelist).' + write(wfmt,'(A,I0,A)') '(A,I6,A,', p_np_group-1, '(X,I0))' + write(*,wfmt) 'Numbers of elements by workers in group ', p_iam_glb, ' are ', nelm_worker + ENDIF + + DO iproc = 1, p_np_group-1 + CALL mpi_send (nelm_worker(iproc), 1, MPI_INTEGER, & + iproc, mpi_tag_size, p_comm_group, p_err) + ENDDO + deallocate (nelm_worker) + + ndsp = 0 + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + nave = nelm_blk(iblk,jblk) / (p_np_group-1) + nres = mod(nelm_blk(iblk,jblk), p_np_group-1) + DO iproc = 1, p_np_group-1 + nsend = nave + IF (iproc <= nres) nsend = nsend + 1 + + DO ie = ndsp+1, ndsp+nsend + idest = iproc + CALL mpi_send (mesh(ie)%indx, 1, MPI_INTEGER8, & + idest, mpi_tag_mesg, p_comm_group, p_err) + smesg(1:3) = (/mesh(ie)%xblk, mesh(ie)%yblk, mesh(ie)%npxl/) + CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_group, p_err) + CALL mpi_send (mesh(ie)%ilon, mesh(ie)%npxl, & + MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err) + CALL mpi_send (mesh(ie)%ilat, mesh(ie)%npxl, & + MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err) + ENDDO + ndsp = ndsp + nsend + ENDDO + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + CALL mpi_recv (numelm, 1, MPI_INTEGER, & + p_root, mpi_tag_size, p_comm_group, p_stat, p_err) + + IF (numelm > 0) THEN + allocate (mesh (numelm)) + + DO ie = 1, numelm + CALL mpi_recv (mesh(ie)%indx, 1, MPI_INTEGER8, & + p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err) + CALL mpi_recv (rmesg, 3, MPI_INTEGER, & + p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err) + + mesh(ie)%xblk = rmesg(1) + mesh(ie)%yblk = rmesg(2) + mesh(ie)%npxl = rmesg(3) + + allocate (mesh(ie)%ilon (mesh(ie)%npxl)) + allocate (mesh(ie)%ilat (mesh(ie)%npxl)) + + CALL mpi_recv (mesh(ie)%ilon, mesh(ie)%npxl, MPI_INTEGER, & + p_root, mpi_tag_data, p_comm_group, p_stat, p_err) + CALL mpi_recv (mesh(ie)%ilat, mesh(ie)%npxl, MPI_INTEGER, & + p_root, mpi_tag_data, p_comm_group, p_stat, p_err) + ENDDO + + ENDIF + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) + + END SUBROUTINE scatter_mesh_from_io_to_worker + +#endif + + ! -------------------------------- + SUBROUTINE mesh_free_mem () + + IMPLICIT NONE + + ! Local variables + integer :: ie + + IF (allocated(mesh)) THEN + DO ie = 1, numelm + deallocate (mesh(ie)%ilon) + deallocate (mesh(ie)%ilat) + ENDDO + + deallocate (mesh) + ENDIF + + END SUBROUTINE mesh_free_mem + +END MODULE MOD_Mesh diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 new file mode 100644 index 0000000000..caf415f838 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 @@ -0,0 +1,2508 @@ +#include + +MODULE MOD_Namelist + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Variables in namelist files and subroutines to read namelist files. +! +! Initial Authors: Shupeng Zhang, Zhongwang Wei, Xingjie Lu, Nan Wei, +! Hua Yuan, Wenzong Dong et al., May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision, only: r8 + IMPLICIT NONE + SAVE + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 0: CASE name ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_CASE_NAME = 'CASENAME' + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 1: domain ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~ + + type nl_domain_type + real(r8) :: edges = -90.0 + real(r8) :: edgen = 90.0 + real(r8) :: edgew = -180.0 + real(r8) :: edgee = 180.0 + END type nl_domain_type + + type (nl_domain_type) :: DEF_domain + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 2: blocks and MPI ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! "blocks" is used to deal with high resolution data. + ! It is defined by one of the following (in order of priority): + ! 1) "DEF_BlockInfoFile" : "lat_s","lat_n","lon_w","lon_e" in file ; + ! 2) "DEF_AverageElementSize" : diameter of element (in kilometer); + ! 3) "DEF_nx_blocks" and "DEF_ny_blocks" : number of blocks; + character(len=256) :: DEF_BlockInfoFile = 'null' + real(r8) :: DEF_AverageElementSize = -1. + integer :: DEF_nx_blocks = 72 + integer :: DEF_ny_blocks = 36 + + ! A group includes one "IO" process and several "worker" processes. + ! Its size determines number of IOs in a job. + integer :: DEF_PIO_groupsize = 12 + logical :: DEF_nIO_eq_nBlock = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 3: For Single Point ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: SITE_fsitedata = 'null' + + real(r8) :: SITE_lon_location = -1.e36_r8 + real(r8) :: SITE_lat_location = -1.e36_r8 + + integer :: SITE_landtype = -1 + + logical :: USE_SITE_landtype = .false. + logical :: USE_SITE_pctpfts = .true. + logical :: USE_SITE_pctcrop = .true. + logical :: USE_SITE_htop = .true. + logical :: USE_SITE_LAI = .true. + logical :: USE_SITE_lakedepth = .true. + logical :: USE_SITE_soilreflectance = .true. + logical :: USE_SITE_soilparameters = .true. + logical :: USE_SITE_dbedrock = .true. + logical :: USE_SITE_topography = .true. + logical :: USE_SITE_urban_geometry = .true. + logical :: USE_SITE_urban_ecology = .true. + logical :: USE_SITE_urban_radiation = .true. + logical :: USE_SITE_urban_thermal = .false. + logical :: USE_SITE_urban_human = .true. + logical :: USE_SITE_HistWriteBack = .true. + logical :: USE_SITE_ForcingReadAhead = .true. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 4: simulation time type ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + type nl_simulation_time_type + logical :: greenwich = .TRUE. + integer :: start_year = 2000 + integer :: start_month = 1 + integer :: start_day = 1 + integer :: start_sec = 0 + integer :: end_year = 2003 + integer :: end_month = 1 + integer :: end_day = 1 + integer :: end_sec = 0 + integer :: spinup_year = 0 + integer :: spinup_month = 1 + integer :: spinup_day = 1 + integer :: spinup_sec = 0 + integer :: spinup_repeat = 1 + real(r8) :: timestep = 1800. + END type nl_simulation_time_type + + type (nl_simulation_time_type) :: DEF_simulation_time + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 5: directories and files ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_dir_rawdata = 'path/to/rawdata/' + character(len=256) :: DEF_dir_runtime = 'path/to/runtime/' + character(len=256) :: DEF_dir_output = 'path/to/output/data' + + character(len=256) :: DEF_dir_landdata = 'path/to/landdata' + character(len=256) :: DEF_dir_restart = 'path/to/restart' + character(len=256) :: DEF_dir_history = 'path/to/history' + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 6: make surface data ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_file_mesh = 'path/to/mesh/file' + real(r8) :: DEF_GRIDBASED_lon_res = 0.5 + real(r8) :: DEF_GRIDBASED_lat_res = 0.5 + + character(len=256) :: DEF_CatchmentMesh_data = 'path/to/catchment/data' + + character(len=256) :: DEF_file_mesh_filter = 'path/to/mesh/filter' + + ! ----- Use surface data from existing dataset ----- + ! case 1: from a larger region + logical :: USE_srfdata_from_larger_region = .false. + character(len=256) :: DEF_dir_existing_srfdata = 'path/to/landdata' + ! case 2: from gridded data with dimensions [patch,lon,lat] or [pft,lon,lat] + ! only available for USGS/IGBP/PFT CLASSIFICATION + logical :: USE_srfdata_from_3D_gridded_data = .false. + + ! ----- land cover data year (for static land cover, i.e. non-LULCC) ----- + ! NOTE: Please check the LC data year range available + integer :: DEF_LC_YEAR = 2005 + + ! ----- Subgrid scheme ----- + logical :: DEF_USE_USGS = .false. + logical :: DEF_USE_IGBP = .false. + logical :: DEF_USE_LCT = .false. + logical :: DEF_USE_PFT = .false. + logical :: DEF_USE_PC = .false. + logical :: DEF_SOLO_PFT = .false. + logical :: DEF_FAST_PC = .true. + logical :: DEF_PC_CROP_SPLIT = .true. + character(len=256) :: DEF_SUBGRID_SCHEME = 'LCT' + + logical :: DEF_LANDONLY = .true. + logical :: DEF_USE_DOMINANT_PATCHTYPE = .false. + + ! soil hydraulic parameters are upscaled from rawdata (1km resolution) + ! to model patches through FIT algorithm (Montzka et al., 2017). + logical :: DEF_USE_SOILPAR_UPS_FIT = .true. + + ! Options for soil reflectance setting schemes + ! 1: Guessed soil color type according to land cover classes + ! 2: Read a global soil color map from CLM + integer :: DEF_SOIL_REFL_SCHEME = 2 + + ! ----- merge data in aggregation when send data from IO to worker ----- + logical :: USE_zip_for_aggregation = .true. + + ! ----- compress level in writing aggregated surface data ----- + integer :: DEF_Srfdata_CompressLevel = 1 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 7: Leaf Area Index ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! NOTE: Please check the LAI data year range available + integer :: DEF_LAI_START_YEAR = 2000 + integer :: DEF_LAI_END_YEAR = 2020 + + ! add by zhongwang wei @ sysu 2021/12/23 + ! To allow read satellite observed LAI + ! 06/2023, note by hua yuan: change DEF_LAI_CLIM to DEF_LAI_MONTHLY + logical :: DEF_LAI_MONTHLY = .true. + + ! ------LAI change and Land cover year setting ---------- + ! 06/2023, add by wenzong dong and hua yuan: use for updating LAI with simulation year + logical :: DEF_LAI_CHANGE_YEARLY = .true. + + ! 05/2023, add by Xingjie Lu: use for updating LAI with leaf carbon + logical :: DEF_USE_LAIFEEDBACK = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 8: Initialization ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + logical :: DEF_USE_SoilInit = .false. + character(len=256) :: DEF_file_SoilInit = 'null' + + logical :: DEF_USE_SnowInit = .false. + character(len=256) :: DEF_file_SnowInit = 'null' + + logical :: DEF_USE_CN_INIT = .false. + character(len=256) :: DEF_file_cn_init = 'null' + + logical :: DEF_USE_WaterTableInit = .false. + character(len=256) :: DEF_file_WaterTable = 'null' + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 9: LULCC related ------ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Options for LULCC year-to-year transfer schemes + ! 1: Same Type Assignment scheme (STA), state variables assignment for the same type (LC, PFT or PC) + ! 2: Mass and Energy Conservation scheme (MEC), DO mass and energy conservation calculation + integer :: DEF_LULCC_SCHEME = 1 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 10: Urban model related ------ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Options for urban type scheme + ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density + ! 2: LCZ Classification, 10 urban type with LCZ 1-10 + integer :: DEF_URBAN_type_scheme = 1 + integer :: DEF_URBAN_geom_data = 1 + logical :: DEF_URBAN_ONLY = .false. + logical :: DEF_URBAN_RUN = .false. + logical :: DEF_URBAN_BEM = .true. + logical :: DEF_URBAN_TREE = .true. + logical :: DEF_URBAN_WATER = .true. + logical :: DEF_URBAN_LUCY = .true. + logical :: DEF_USE_CANYON_HWR = .true. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 11: parameterization schemes ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + integer :: DEF_Interception_scheme = 1 !1:CoLM；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC; 7:JULES + + ! ----- SOIL parameters and supercool water setting ------ + integer :: DEF_THERMAL_CONDUCTIVITY_SCHEME = 4 ! Options for soil thermal conductivity schemes + ! 1: Farouki (1981) + ! 2: Johansen(1975) + ! 3: Cote and Konrad (2005) + ! 4: Balland and Arp (2005) + ! 5: Lu et al. (2007) + ! 6: Tarnawski and Leong (2012) + ! 7: De Vries (1963) + ! 8: Yan Hengnian, He Hailong et al.(2019) + + logical :: DEF_USE_SUPERCOOL_WATER = .true. ! supercooled soil water scheme, Niu & Yang (2006) + + ! ----- Options for soil surface resistance schemes ----- + ! 0: NONE soil surface resistance + ! 1: SL14, Swenson and Lawrence (2014) + ! 2: SZ09, Sakaguchi and Zeng (2009) + ! 3: TR13, Tang and Riley (2013) + ! 4: LP92, Lee and Pielke (1992) + ! 5: S92, Sellers et al (1992) + integer :: DEF_RSS_SCHEME = 1 + + ! ----- Options for runoff parameterization schemes ----- + ! 0: scheme from TOPMODEL, also used in CoLM2014 + ! 1: scheme from VIC model + ! 2: scheme from XinAnJiang model, also used in ECMWF model + ! 3: scheme from Simple VIC, also used in NoahMP 5.0 + + integer :: DEF_Runoff_SCHEME = 3 + character(len=256) :: DEF_file_VIC_para = 'null' + character(len=256) :: DEF_file_VIC_OPT = 'null' + logical :: DEF_VIC_OPT = .false. + + integer :: DEF_TOPMOD_method = 0 + + ! ----- Treat exposed soil and snow surface separately ----- + ! including solar absorption, sensible/latent heat, ground temperature, + ! ground heat flux and ground evp/dew/subl/fros. Corresponding vars are + ! named as ***_soil, ***_snow. + logical :: DEF_SPLIT_SOILSNOW = .false. + + ! ----- Account for vegetation snow process ----- + ! NOTE: This option will be activated in the new release, accompanied by + ! a new set of canopy structure data, include the snow-free LAI. + logical :: DEF_VEG_SNOW = .false. + + ! ----- Variably Saturated Flow Soil Water ----- + logical :: DEF_USE_VariablySaturatedFlow = .true. + logical :: DEF_USE_BEDROCK = .false. + + ! ----- Ozone stress ----- + logical :: DEF_USE_OZONESTRESS = .true. + logical :: DEF_USE_OZONEDATA = .true. + + ! ----- SNICAR model related ----- + logical :: DEF_USE_SNICAR = .false. + character(len=256) :: DEF_file_snowoptics = 'null' + character(len=256) :: DEF_file_snowaging = 'null' + + ! ----- Hyperspectral related ----- + logical :: DEF_HighResSoil = .true. + logical :: DEF_HighResVeg = .true. + logical :: DEF_PROSPECT = .false. + + CHARACTER(LEN=256) :: DEF_HighResUrban_albedo = 'null' + ! logical :: DEF_Satellite_Params = .false. + ! character(len=256) :: DEF_file_soiloptics = 'null' + ! character(len=256) :: DEF_file_satellite_params = 'null' + ! character(len=256) :: DEF_sla_varname = 'null' + + ! .true. read aerosol deposition data from file or .false. set in the code + logical :: DEF_Aerosol_Readin = .true. + + ! .true. Read aerosol deposition climatology data or .false. yearly changed + logical :: DEF_Aerosol_Clim = .false. + + ! ----- Atmospheric Nitrogen Deposition ----- + !add by Fang Shang @ pku 2023/08 + !1: To allow annuaul ndep data to be read in + !2: To allow monthly ndep data to be read in + integer :: DEF_NDEP_FREQUENCY = 1 + + ! ----- lateral flow related ----- + character(len=256) :: DEF_ElementNeighbour_file = 'null' + character(len=256) :: DEF_UnitCatchment_file = 'null' + character(len=256) :: DEF_ReservoirPara_file = 'null' + + logical :: DEF_USE_EstimatedRiverDepth = .true. + integer :: DEF_Reservoir_Method = 0 + real(r8) :: DEF_GRIDBASED_ROUTING_MAX_DT = 3600. + + ! ----- sediment module ----- + logical :: DEF_USE_SEDIMENT = .false. + real(r8) :: DEF_SED_LAMBDA = 0.4 + real(r8) :: DEF_SED_LYRDPH = 0.00005 + real(r8) :: DEF_SED_DENSITY = 2.65 + real(r8) :: DEF_SED_WATER_DENSITY = 1.0 + real(r8) :: DEF_SED_VISKIN = 1.0e-6 + real(r8) :: DEF_SED_VONKAR = 0.4 + real(r8) :: DEF_SED_PSET = 1.0 + integer :: DEF_SED_TOTLYRNUM = 5 + real(r8) :: DEF_SED_CFL_ADV = 0.5 + real(r8) :: DEF_SED_IGNORE_DPH = 0.05 + real(r8) :: DEF_SED_DT_MAX = 3600. + character(len=256) :: DEF_SED_DIAMETER = "0.0002,0.002,0.02" + real(r8) :: DEF_SED_PYLD = 0.01 + real(r8) :: DEF_SED_PYLDC = 2.0 + real(r8) :: DEF_SED_PYLDPC = 2.0 + real(r8) :: DEF_SED_DSYLUNIT = 1.0e-6 + + ! ----- others ----- + character(len=5) :: DEF_precip_phase_discrimination_scheme = 'II' + + character(len=256) :: DEF_SSP = '585' ! Co2 path for CMIP6 future scenario. + + logical :: DEF_USE_IRRIGATION = .false. ! use irrigation + integer :: DEF_IRRIGATION_ALLOCATION = 1 ! irrigation allocated method + + logical :: DEF_USE_NOSTRESSNITROGEN = .false. ! photosynthesis stress option + integer :: DEF_RSTFAC = 1 ! root resistance factors option + logical :: DEF_USE_PLANTHYDRAULICS = .true. ! Plant Hydraulics + logical :: DEF_USE_MEDLYNST = .false. ! Medlyn stomata model + logical :: DEF_USE_WUEST = .true. ! WUE stomata model + + logical :: DEF_USE_SASU = .false. ! Semi-Analytic-Spin-Up + logical :: DEF_USE_DiagMatrix = .false. + logical :: DEF_USE_PN = .false. ! Punctuated nitrogen addition Spin up + + logical :: DEF_USE_FERT = .true. ! Fertilisation on crop + integer :: DEF_FERT_SOURCE = 1 ! Fertilisation data source + logical :: DEF_USE_NITRIF = .true. ! Nitrification and denitrification switch + logical :: DEF_USE_CNSOYFIXN = .true. ! Soy nitrogen fixation + + logical :: DEF_USE_FIRE = .false. ! Fire MODULE + + logical :: DEF_USE_Dynamic_Lake = .false. ! Dynamic Lake model + + logical :: DEF_USE_Dynamic_Wetland = .false. ! Dynamic wetland model + + logical :: DEF_CheckEquilibrium = .false. + + logical :: DEF_Output_2mWMO = .false. ! 2m WMO temperature + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 12: forcing ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_forcing_namelist = 'null' + + character(len=256) :: DEF_dir_forcing = 'path/to/forcing/data' + + type nl_forcing_type + + character(len=256) :: dataset = 'CRUNCEP' + logical :: solarin_all_band = .true. + character(len=256) :: HEIGHT_mode = 'absolute' + real(r8) :: HEIGHT_V = 100.0 + real(r8) :: HEIGHT_T = 50. + real(r8) :: HEIGHT_Q = 50. + + logical :: regional = .false. + real(r8) :: regbnd(4) = (/-90.0, 90.0, -180.0, 180.0/) + logical :: has_missing_value = .false. + character(len=256) :: missing_value_name = 'missing_value' + + integer :: NVAR = 8 ! variable number of forcing data + integer :: startyr = 2000 ! start year of forcing data + integer :: startmo = 1 ! start month of forcing data + integer :: endyr = 2003 ! end year of forcing data + integer :: endmo = 12 ! end month of forcing data + integer :: dtime(8) = (/21600,21600,21600,21600,0,21600,21600,21600/) + integer :: offset(8) = (/10800,10800,10800,10800,0,10800,0,10800/) + integer :: nlands = 1 ! land grid number in 1d + + logical :: leapyear = .false. ! leapyear calendar + logical :: data2d = .true. ! data in 2 dimension (lon, lat) + logical :: hightdim = .false. ! have "z" dimension + logical :: dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + character(len=256) :: latname = 'LATIXY' ! dimension name of latitude + character(len=256) :: lonname = 'LONGXY' ! dimension name of longitude + + character(len=256) :: groupby = 'month' ! file grouped by year/month + + character(len=256) :: fprefix(8) = (/ & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'Precip6Hrly/clmforc.cruncep.V4.c2011.0.5d.Prec.', & + 'NULL ', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'Solar6Hrly/clmforc.cruncep.V4.c2011.0.5d.Solr. ', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' /) + character(len=256) :: vname(8) = (/ & + 'TBOT ','QBOT ','PSRF ','PRECTmms', & + 'NULL ','WIND ','FSDS ','FLDS ' /) + character(len=256) :: timelog(8) = (/ & + 'instant ','instant ','instant ','forward ', & + 'NULL ','instant ','forward ','forward ' /) + character(len=256) :: tintalgo(8) = (/ & + 'linear ','linear ','linear ','nearest', & + 'NULL ','linear ','coszen ','linear ' /) + + character(len=256) :: CBL_fprefix = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + character(len=256) :: CBL_vname = 'blh' + character(len=256) :: CBL_tintalgo = 'linear' + integer :: CBL_dtime = 21600 + integer :: CBL_offset = 10800 + END type nl_forcing_type + + type (nl_forcing_type) :: DEF_forcing + + !CBL height + logical :: DEF_USE_CBL_HEIGHT = .false. + + character(len=20) :: DEF_Forcing_Interp_Method = 'arealweight' ! 'arealweight' (default) or 'bilinear' + + logical :: DEF_USE_Forcing_Downscaling = .false. + logical :: DEF_USE_Forcing_Downscaling_Simple = .false. + character(len=256):: DEF_DS_HiresTopographyDataDir = 'null' + character(len=5) :: DEF_DS_precipitation_adjust_scheme = 'I' + character(len=5) :: DEF_DS_longwave_adjust_scheme = 'II' + + logical :: DEF_USE_ClimForcing_for_Spinup = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 13: data assimilation ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=256) :: DEF_DA_obsdir = 'null' + logical :: DEF_DA_TWS = .false. + logical :: DEF_DA_TWS_GRACE = .false. + logical :: DEF_DA_SM = .false. + integer :: DEF_DA_ENS_NUM = 20 + logical :: DEF_DA_ENS_SM = .false. + logical :: DEF_DA_SM_SMAP = .false. + logical :: DEF_DA_SM_FY = .false. + logical :: DEF_DA_SM_SYNOP = .false. + integer :: DEF_DA_RTM_diel = 0 + integer :: DEF_DA_RTM_rough = 0 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 14: parameter optimization ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + logical :: DEF_Optimize_Baseflow = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 15: history and restart ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + logical :: DEF_HISTORY_IN_VECTOR = .false. + + logical :: DEF_HIST_grid_as_forcing = .false. + real(r8) :: DEF_HIST_lon_res = 0.5 + real(r8) :: DEF_HIST_lat_res = 0.5 + + character(len=256) :: DEF_WRST_FREQ = 'none' ! write restart file frequency: TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY + character(len=256) :: DEF_HIST_FREQ = 'none' ! write history file frequency: TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY + character(len=256) :: DEF_HIST_groupby = 'MONTH' ! history file in one file: DAY/MONTH/YEAR + character(len=256) :: DEF_HIST_mode = 'one' + logical :: DEF_HIST_WriteBack = .false. + integer :: DEF_REST_CompressLevel = 1 + integer :: DEF_HIST_CompressLevel = 1 + + character(len=256) :: DEF_HIST_vars_namelist = 'null' + logical :: DEF_HIST_vars_out_default = .true. + + + ! ----- history variables ----- + type history_var_type + + logical :: xy_us = .true. + logical :: xy_vs = .true. + logical :: xy_t = .true. + logical :: xy_q = .true. + logical :: xy_prc = .true. + logical :: xy_prl = .true. + logical :: xy_pbot = .true. + logical :: xy_frl = .true. + logical :: xy_solarin = .true. + logical :: xy_rain = .true. + logical :: xy_snow = .true. + logical :: xy_ozone = .true. + logical :: xy_hpbl = .true. + + logical :: taux = .true. + logical :: tauy = .true. + logical :: fsena = .true. + logical :: lfevpa = .true. + logical :: fevpa = .true. + logical :: fsenl = .true. + logical :: fevpl = .true. + logical :: etr = .true. + logical :: fseng = .true. + logical :: fevpg = .true. + logical :: fgrnd = .true. + logical :: sabvsun = .true. + logical :: sabvsha = .true. + logical :: sabg = .true. + logical :: olrg = .true. + logical :: rnet = .true. + logical :: xerr = .true. + logical :: zerr = .true. + logical :: rsur = .true. + logical :: rsur_se = .true. + logical :: rsur_ie = .true. + logical :: rsub = .true. + logical :: rnof = .true. + logical :: xwsur = .true. + logical :: xwsub = .true. + logical :: fldarea = .true. + logical :: qintr = .true. + logical :: qinfl = .true. + logical :: qdrip = .true. + logical :: wat = .true. + logical :: wat_inst = .true. + logical :: wetwat = .true. + logical :: wetwat_inst = .true. + logical :: wetzwt = .true. + logical :: assim = .true. + logical :: respc = .true. + logical :: qcharge = .true. + logical :: t_grnd = .true. + logical :: tleaf = .true. + logical :: ldew = .true. + logical :: scv = .true. + logical :: snowdp = .true. + logical :: fsno = .true. + logical :: frcsat = .true. + logical :: sigf = .true. + logical :: green = .true. + logical :: lai = .true. + logical :: laisun = .true. + logical :: laisha = .true. + logical :: sai = .true. + logical :: alb = .true. + logical :: alb_hires = .true. + logical :: reflectance_out = .true. + logical :: transmittance_out = .true. + logical :: emis = .true. + logical :: z0m = .true. + logical :: trad = .true. + logical :: rss = .true. + logical :: tref = .true. + logical :: t2m_wmo = .true. + logical :: qref = .true. + + logical :: fsen_roof = .true. + logical :: fsen_wsun = .true. + logical :: fsen_wsha = .true. + logical :: fsen_gimp = .true. + logical :: fsen_gper = .true. + logical :: fsen_urbl = .true. + logical :: lfevp_roof = .true. + logical :: lfevp_gimp = .true. + logical :: lfevp_gper = .true. + logical :: lfevp_urbl = .true. + logical :: fhac = .true. + logical :: fwst = .true. + logical :: fach = .true. + logical :: fhah = .true. + logical :: meta = .true. + logical :: vehc = .true. + logical :: t_room = .true. + logical :: tafu = .true. + logical :: t_roof = .true. + logical :: t_wall = .true. + + logical :: assimsun = .true. + logical :: assimsha = .true. + logical :: etrsun = .true. + logical :: etrsha = .true. + + logical :: o3uptakesun = .true. + logical :: o3uptakesha = .true. + + logical :: leafc = .true. + logical :: leafc_storage = .true. + logical :: leafc_xfer = .true. + logical :: frootc = .true. + logical :: frootc_storage = .true. + logical :: frootc_xfer = .true. + logical :: livestemc = .true. + logical :: livestemc_storage = .true. + logical :: livestemc_xfer = .true. + logical :: deadstemc = .true. + logical :: deadstemc_storage = .true. + logical :: deadstemc_xfer = .true. + logical :: livecrootc = .true. + logical :: livecrootc_storage = .true. + logical :: livecrootc_xfer = .true. + logical :: deadcrootc = .true. + logical :: deadcrootc_storage = .true. + logical :: deadcrootc_xfer = .true. + logical :: grainc = .true. + logical :: grainc_storage = .true. + logical :: grainc_xfer = .true. + logical :: leafn = .true. + logical :: leafn_storage = .true. + logical :: leafn_xfer = .true. + logical :: frootn = .true. + logical :: frootn_storage = .true. + logical :: frootn_xfer = .true. + logical :: livestemn = .true. + logical :: livestemn_storage = .true. + logical :: livestemn_xfer = .true. + logical :: deadstemn = .true. + logical :: deadstemn_storage = .true. + logical :: deadstemn_xfer = .true. + logical :: livecrootn = .true. + logical :: livecrootn_storage = .true. + logical :: livecrootn_xfer = .true. + logical :: deadcrootn = .true. + logical :: deadcrootn_storage = .true. + logical :: deadcrootn_xfer = .true. + logical :: grainn = .true. + logical :: grainn_storage = .true. + logical :: grainn_xfer = .true. + logical :: retrasn = .true. + logical :: gpp = .true. + logical :: downreg = .true. + logical :: ar = .true. + logical :: cwdprod = .true. + logical :: cwddecomp = .true. + logical :: hr = .true. + logical :: fpg = .true. + logical :: fpi = .true. + logical :: totvegc = .true. + logical :: totlitc = .true. + logical :: totcwdc = .true. + logical :: totsomc = .true. + logical :: totcolc = .true. + logical :: totvegn = .true. + logical :: totlitn = .true. + logical :: totcwdn = .true. + logical :: totsomn = .true. + logical :: totcoln = .true. + logical :: totsoiln_vr = .true. + logical :: gpp_enftemp = .false. !1 + logical :: gpp_enfboreal = .false. !2 + logical :: gpp_dnfboreal = .false. !3 + logical :: gpp_ebftrop = .false. !4 + logical :: gpp_ebftemp = .false. !5 + logical :: gpp_dbftrop = .false. !6 + logical :: gpp_dbftemp = .false. !7 + logical :: gpp_dbfboreal = .false. !8 + logical :: gpp_ebstemp = .false. !9 + logical :: gpp_dbstemp = .false. !10 + logical :: gpp_dbsboreal = .false. !11 + logical :: gpp_c3arcgrass = .false. !12 + logical :: gpp_c3grass = .false. !13 + logical :: gpp_c4grass = .false. !14 + logical :: leafc_enftemp = .false. !1 + logical :: leafc_enfboreal = .false. !2 + logical :: leafc_dnfboreal = .false. !3 + logical :: leafc_ebftrop = .false. !4 + logical :: leafc_ebftemp = .false. !5 + logical :: leafc_dbftrop = .false. !6 + logical :: leafc_dbftemp = .false. !7 + logical :: leafc_dbfboreal = .false. !8 + logical :: leafc_ebstemp = .false. !9 + logical :: leafc_dbstemp = .false. !10 + logical :: leafc_dbsboreal = .false. !11 + logical :: leafc_c3arcgrass = .false. !12 + logical :: leafc_c3grass = .false. !13 + logical :: leafc_c4grass = .false. !14 + logical :: lai_enftemp = .false. !1 + logical :: lai_enfboreal = .false. !2 + logical :: lai_dnfboreal = .false. !3 + logical :: lai_ebftrop = .false. !4 + logical :: lai_ebftemp = .false. !5 + logical :: lai_dbftrop = .false. !6 + logical :: lai_dbftemp = .false. !7 + logical :: lai_dbfboreal = .false. !8 + logical :: lai_ebstemp = .false. !9 + logical :: lai_dbstemp = .false. !10 + logical :: lai_dbsboreal = .false. !11 + logical :: lai_c3arcgrass = .false. !12 + logical :: lai_c3grass = .false. !13 + logical :: lai_c4grass = .false. !14 + logical :: npp_enftemp = .false. !1 + logical :: npp_enfboreal = .false. !2 + logical :: npp_dnfboreal = .false. !3 + logical :: npp_ebftrop = .false. !4 + logical :: npp_ebftemp = .false. !5 + logical :: npp_dbftrop = .false. !6 + logical :: npp_dbftemp = .false. !7 + logical :: npp_dbfboreal = .false. !8 + logical :: npp_ebstemp = .false. !9 + logical :: npp_dbstemp = .false. !10 + logical :: npp_dbsboreal = .false. !11 + logical :: npp_c3arcgrass = .false. !12 + logical :: npp_c3grass = .false. !13 + logical :: npp_c4grass = .false. !14 + logical :: npptoleafc_enftemp = .false. !1 + logical :: npptoleafc_enfboreal = .false. !2 + logical :: npptoleafc_dnfboreal = .false. !3 + logical :: npptoleafc_ebftrop = .false. !4 + logical :: npptoleafc_ebftemp = .false. !5 + logical :: npptoleafc_dbftrop = .false. !6 + logical :: npptoleafc_dbftemp = .false. !7 + logical :: npptoleafc_dbfboreal = .false. !8 + logical :: npptoleafc_ebstemp = .false. !9 + logical :: npptoleafc_dbstemp = .false. !10 + logical :: npptoleafc_dbsboreal = .false. !11 + logical :: npptoleafc_c3arcgrass = .false. !12 + logical :: npptoleafc_c3grass = .false. !13 + logical :: npptoleafc_c4grass = .false. !14 + + logical :: cphase = .true. + logical :: gddmaturity = .true. + logical :: gddplant = .true. + logical :: vf = .true. + logical :: hui = .true. + logical :: cropprod1c = .true. + logical :: cropprod1c_loss = .true. + logical :: cropseedc_deficit = .true. + logical :: grainc_to_cropprodc = .true. + logical :: plantdate_rainfed_temp_corn = .true. + logical :: plantdate_irrigated_temp_corn = .true. + logical :: plantdate_rainfed_spwheat = .true. + logical :: plantdate_irrigated_spwheat = .true. + logical :: plantdate_rainfed_wtwheat = .true. + logical :: plantdate_irrigated_wtwheat = .true. + logical :: plantdate_rainfed_temp_soybean = .true. + logical :: plantdate_irrigated_temp_soybean = .true. + logical :: plantdate_rainfed_cotton = .true. + logical :: plantdate_irrigated_cotton = .true. + logical :: plantdate_rainfed_rice = .true. + logical :: plantdate_irrigated_rice = .true. + logical :: plantdate_rainfed_sugarcane = .true. + logical :: plantdate_irrigated_sugarcane = .true. + logical :: plantdate_rainfed_trop_corn = .true. + logical :: plantdate_irrigated_trop_corn = .true. + logical :: plantdate_rainfed_trop_soybean = .true. + logical :: plantdate_irrigated_trop_soybean = .true. + logical :: plantdate_unmanagedcrop = .true. + logical :: cropprodc_rainfed_temp_corn = .true. + logical :: cropprodc_irrigated_temp_corn = .true. + logical :: cropprodc_rainfed_spwheat = .true. + logical :: cropprodc_irrigated_spwheat = .true. + logical :: cropprodc_rainfed_wtwheat = .true. + logical :: cropprodc_irrigated_wtwheat = .true. + logical :: cropprodc_rainfed_temp_soybean = .true. + logical :: cropprodc_irrigated_temp_soybean = .true. + logical :: cropprodc_rainfed_cotton = .true. + logical :: cropprodc_irrigated_cotton = .true. + logical :: cropprodc_rainfed_rice = .true. + logical :: cropprodc_irrigated_rice = .true. + logical :: cropprodc_rainfed_sugarcane = .true. + logical :: cropprodc_irrigated_sugarcane = .true. + logical :: cropprodc_rainfed_trop_corn = .true. + logical :: cropprodc_irrigated_trop_corn = .true. + logical :: cropprodc_rainfed_trop_soybean = .true. + logical :: cropprodc_irrigated_trop_soybean = .true. + logical :: cropprodc_unmanagedcrop = .true. + + logical :: grainc_to_seed = .true. + logical :: fert_to_sminn = .true. + + logical :: huiswheat = .true. + logical :: pdcorn = .false. + logical :: pdswheat = .false. + logical :: pdwwheat = .false. + logical :: pdsoybean = .false. + logical :: pdcotton = .false. + logical :: pdrice1 = .false. + logical :: pdrice2 = .false. + logical :: pdsugarcane = .false. + logical :: manunitro = .false. + logical :: fertnitro_corn = .true. + logical :: fertnitro_swheat = .true. + logical :: fertnitro_wwheat = .true. + logical :: fertnitro_soybean = .true. + logical :: fertnitro_cotton = .true. + logical :: fertnitro_rice1 = .true. + logical :: fertnitro_rice2 = .true. + logical :: fertnitro_sugarcane = .true. + logical :: irrig_method_corn = .true. + logical :: irrig_method_swheat = .true. + logical :: irrig_method_wwheat = .true. + logical :: irrig_method_soybean = .true. + logical :: irrig_method_cotton = .true. + logical :: irrig_method_rice1 = .true. + logical :: irrig_method_rice2 = .true. + logical :: irrig_method_sugarcane = .true. + + logical :: sum_irrig = .true. + logical :: sum_deficit_irrig = .true. + logical :: sum_irrig_count = .true. + logical :: waterstorage = .true. + logical :: groundwater_demand = .true. + logical :: groundwater_supply = .true. + logical :: reservoirriver_demand = .true. + logical :: reservoirriver_supply = .true. + + logical :: ndep_to_sminn = .true. + logical :: CONC_O2_UNSAT = .false. + logical :: O2_DECOMP_DEPTH_UNSAT = .false. + logical :: abm = .false. + logical :: gdp = .false. + logical :: peatf = .false. + logical :: hdm = .false. + logical :: lnfm = .false. + + logical :: leafcCap = .false. + logical :: leafc_storageCap = .false. + logical :: leafc_xferCap = .false. + logical :: frootcCap = .false. + logical :: frootc_storageCap = .false. + logical :: frootc_xferCap = .false. + logical :: livestemcCap = .false. + logical :: livestemc_storageCap = .false. + logical :: livestemc_xferCap = .false. + logical :: deadstemcCap = .false. + logical :: deadstemc_storageCap = .false. + logical :: deadstemc_xferCap = .false. + logical :: livecrootcCap = .false. + logical :: livecrootc_storageCap = .false. + logical :: livecrootc_xferCap = .false. + logical :: deadcrootcCap = .false. + logical :: deadcrootc_storageCap = .false. + logical :: deadcrootc_xferCap = .false. + logical :: leafnCap = .false. + logical :: leafn_storageCap = .false. + logical :: leafn_xferCap = .false. + logical :: frootnCap = .false. + logical :: frootn_storageCap = .false. + logical :: frootn_xferCap = .false. + logical :: livestemnCap = .false. + logical :: livestemn_storageCap = .false. + logical :: livestemn_xferCap = .false. + logical :: deadstemnCap = .false. + logical :: deadstemn_storageCap = .false. + logical :: deadstemn_xferCap = .false. + logical :: livecrootnCap = .false. + logical :: livecrootn_storageCap = .false. + logical :: livecrootn_xferCap = .false. + logical :: deadcrootnCap = .false. + logical :: deadcrootn_storageCap = .false. + logical :: deadcrootn_xferCap = .false. + logical :: t_scalar = .false. + logical :: w_scalar = .false. + + logical :: t_soisno = .true. + logical :: wliq_soisno = .true. + logical :: wice_soisno = .true. + + logical :: h2osoi = .true. + logical :: qlayer = .true. + logical :: lake_deficit = .true. + logical :: rstfacsun = .true. + logical :: rstfacsha = .true. + logical :: gssun = .true. + logical :: gssha = .true. + logical :: rootr = .true. + logical :: vegwp = .true. + logical :: BD_all = .true. + logical :: wfc = .true. + logical :: OM_density = .true. + logical :: wdsrf = .true. + logical :: wdsrf_inst = .true. + logical :: zwt = .true. + logical :: wa = .true. + logical :: wa_inst = .true. + + logical :: dz_lake = .true. + logical :: t_lake = .true. + logical :: lake_icefrac = .true. + + logical :: DA_wliq_h2osoi_5cm = .true. + logical :: DA_wliq_h2osoi_5cm_a = .true. + logical :: DA_t_soisno_5cm = .true. + logical :: DA_t_soisno_5cm_a = .true. + logical :: DA_wliq_soisno_ens = .true. + logical :: DA_t_soisno_ens = .true. + logical :: DA_wliq_soisno_5cm_ens_std = .true. + logical :: DA_t_soisno_5cm_ens_std = .true. + logical :: DA_t_brt_smap = .true. + logical :: DA_t_brt_smap_a = .true. + logical :: DA_t_brt_smap_ens = .true. + logical :: DA_t_brt_smap_ens_std = .true. + logical :: DA_t_brt_fy3d = .true. + logical :: DA_t_brt_fy3d_a = .true. + logical :: DA_t_brt_fy3d_ens = .true. + logical :: DA_t_brt_fy3d_ens_std = .true. + + logical :: litr1c_vr = .true. + logical :: litr2c_vr = .true. + logical :: litr3c_vr = .true. + logical :: soil1c_vr = .true. + logical :: soil2c_vr = .true. + logical :: soil3c_vr = .true. + logical :: cwdc_vr = .true. + logical :: litr1n_vr = .true. + logical :: litr2n_vr = .true. + logical :: litr3n_vr = .true. + logical :: soil1n_vr = .true. + logical :: soil2n_vr = .true. + logical :: soil3n_vr = .true. + logical :: cwdn_vr = .true. + + logical :: litr1cCap_vr = .false. + logical :: litr2cCap_vr = .false. + logical :: litr3cCap_vr = .false. + logical :: soil1cCap_vr = .false. + logical :: soil2cCap_vr = .false. + logical :: soil3cCap_vr = .false. + logical :: cwdcCap_vr = .false. + logical :: litr1nCap_vr = .false. + logical :: litr2nCap_vr = .false. + logical :: litr3nCap_vr = .false. + logical :: soil1nCap_vr = .false. + logical :: soil2nCap_vr = .false. + logical :: soil3nCap_vr = .false. + logical :: cwdnCap_vr = .false. + + logical :: sminn_vr = .true. + + logical :: ustar = .true. + logical :: ustar2 = .true. + logical :: tstar = .true. + logical :: qstar = .true. + logical :: zol = .true. + logical :: rib = .true. + logical :: fm = .true. + logical :: fh = .true. + logical :: fq = .true. + logical :: us10m = .true. + logical :: vs10m = .true. + logical :: fm10m = .true. + logical :: sr = .true. + logical :: solvd = .true. + logical :: solvi = .true. + logical :: solnd = .true. + logical :: solni = .true. + logical :: srvd = .true. + logical :: srvi = .true. + logical :: srnd = .true. + logical :: srni = .true. + + logical :: solvdln = .true. + logical :: solviln = .true. + logical :: solndln = .true. + logical :: solniln = .true. + logical :: srvdln = .true. + logical :: srviln = .true. + logical :: srndln = .true. + logical :: srniln = .true. + + logical :: sol_dir_ln_hires = .true. + logical :: sol_dif_ln_hires = .true. + logical :: sr_dir_ln_hires = .true. + logical :: sr_dif_ln_hires = .true. + + logical :: xsubs_bsn = .true. + logical :: xsubs_hru = .true. + logical :: riv_height = .true. + logical :: riv_veloct = .true. + logical :: discharge = .true. + logical :: floodarea = .true. + logical :: floodfrc = .true. + logical :: wdsrf_hru = .true. + logical :: veloc_hru = .true. + logical :: volresv = .true. + logical :: qresv_in = .true. + logical :: qresv_out = .true. + + logical :: sedcon = .true. + logical :: sedout = .true. + logical :: bedout = .true. + logical :: sedinp = .true. + logical :: netflw = .true. + logical :: sedlayer = .true. + logical :: shearvel = .false. + + logical :: sensors = .true. + + END type history_var_type + + type (history_var_type) :: DEF_hist_vars + +CONTAINS + + SUBROUTINE read_namelist (nlfile) + + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: nlfile + + ! Local variables + logical :: fexists + integer :: ivar + integer :: ierr + character(len=256) :: iomesg + + namelist /nl_colm/ & + DEF_CASE_NAME, & + DEF_domain, & + + SITE_fsitedata, & + SITE_lon_location, & + SITE_lat_location, & + SITE_landtype, & + USE_SITE_landtype, & + USE_SITE_pctpfts, & + USE_SITE_pctcrop, & + USE_SITE_htop, & + USE_SITE_LAI, & + USE_SITE_lakedepth, & + USE_SITE_soilreflectance, & + USE_SITE_soilparameters, & + USE_SITE_dbedrock, & + USE_SITE_topography, & + USE_SITE_HistWriteBack, & + USE_SITE_ForcingReadAhead, & + USE_SITE_urban_geometry, & + USE_SITE_urban_ecology, & + USE_SITE_urban_radiation, & + USE_SITE_urban_thermal, & + USE_SITE_urban_human, & + + DEF_BlockInfoFile, & + DEF_AverageElementSize, & + DEF_nx_blocks, & + DEF_ny_blocks, & + DEF_PIO_groupsize, & + DEF_nIO_eq_nBlock, & + DEF_simulation_time, & + DEF_dir_rawdata, & + DEF_dir_runtime, & + DEF_dir_output, & + DEF_file_mesh, & + DEF_GRIDBASED_lon_res, & + DEF_GRIDBASED_lat_res, & + DEF_CatchmentMesh_data, & + DEF_file_mesh_filter, & + + DEF_USE_LCT, & + DEF_USE_PFT, & + DEF_USE_PC, & + DEF_FAST_PC, & + DEF_PC_CROP_SPLIT, & + DEF_SOLO_PFT, & + DEF_SUBGRID_SCHEME, & + + DEF_LAI_MONTHLY, & !add by zhongwang wei @ sysu 2021/12/23 + DEF_NDEP_FREQUENCY, & !add by Fang Shang @ pku 2023/08 + DEF_Interception_scheme, & !add by zhongwang wei @ sysu 2022/05/23 + DEF_SSP, & !add by zhongwang wei @ sysu 2023/02/07 + + DEF_LAI_START_YEAR, & + DEF_LAI_END_YEAR, & + DEF_LAI_CHANGE_YEARLY, & + DEF_USE_LAIFEEDBACK, & !add by Xingjie Lu, use for updating LAI with leaf carbon + DEF_USE_IRRIGATION, & !add by Hongbin Liang @ sysu + DEF_IRRIGATION_ALLOCATION, & !add by Hongbin Liang @ sysu + DEF_USE_NOSTRESSNITROGEN, & !add by Hongbin Liang @ sysu + DEF_RSTFAC, & !add by Hongbin Liang @ sysu + DEF_LC_YEAR, & + DEF_LULCC_SCHEME, & + + DEF_URBAN_type_scheme, & + DEF_URBAN_geom_data, & + DEF_URBAN_ONLY, & + DEF_URBAN_RUN, & !add by hua yuan, open urban model or not + DEF_URBAN_BEM, & !add by hua yuan, open urban BEM model or not + DEF_URBAN_TREE, & !add by hua yuan, modeling urban tree or not + DEF_URBAN_WATER, & !add by hua yuan, modeling urban water or not + DEF_URBAN_LUCY, & + DEF_USE_CANYON_HWR, & + + DEF_USE_SOILPAR_UPS_FIT, & + DEF_THERMAL_CONDUCTIVITY_SCHEME, & + DEF_USE_SUPERCOOL_WATER, & + DEF_SOIL_REFL_SCHEME, & + DEF_RSS_SCHEME, & + DEF_Runoff_SCHEME, & + DEF_TOPMOD_method, & + DEF_SPLIT_SOILSNOW, & + DEF_VEG_SNOW, & + DEF_file_VIC_para, & + DEF_file_VIC_OPT, & + DEF_VIC_OPT, & !add by Qijia Guo @ sysu + + DEF_dir_existing_srfdata, & + USE_srfdata_from_larger_region, & + USE_srfdata_from_3D_gridded_data, & + USE_zip_for_aggregation, & + DEF_Srfdata_CompressLevel, & + + DEF_USE_CBL_HEIGHT, & !add by zhongwang wei @ sysu 2022/12/31 + DEF_USE_PLANTHYDRAULICS, & !add by xingjie lu @ sysu 2023/05/28 + DEF_USE_MEDLYNST, & !add by xingjie lu @ sysu 2023/05/28 + DEF_USE_WUEST, & !add by xingjie lu @ sysu 2024/05/28 + DEF_USE_SASU, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_DiagMatrix, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_PN, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_FERT, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_FERT_SOURCE, & !add by Hongbin Liang @ sysu + DEF_USE_NITRIF, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_CNSOYFIXN, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_FIRE, & !add by Xingjie Lu @ sysu 2023/06/27 + + DEF_USE_Dynamic_Lake, & !add by Shupeng Zhang @ sysu 2024/09/12 + DEF_USE_Dynamic_Wetland, & !add by Shupeng Zhang @ sysu 2026/01/09 + + DEF_CheckEquilibrium, & !add by Shupeng Zhang @ sysu 2024/11/26 + DEF_Output_2mWMO, & + + DEF_LANDONLY, & + DEF_USE_DOMINANT_PATCHTYPE, & + DEF_USE_VariablySaturatedFlow, & + DEF_USE_BEDROCK, & + DEF_USE_OZONESTRESS, & + DEF_USE_OZONEDATA, & + DEF_USE_SNICAR, & + DEF_Aerosol_Readin, & + DEF_Aerosol_Clim, & + DEF_USE_EstimatedRiverDepth, & + DEF_Reservoir_Method, & + DEF_GRIDBASED_ROUTING_MAX_DT, & + + DEF_USE_SEDIMENT, & + DEF_SED_LAMBDA, & + DEF_SED_LYRDPH, & + DEF_SED_DENSITY, & + DEF_SED_WATER_DENSITY, & + DEF_SED_VISKIN, & + DEF_SED_VONKAR, & + DEF_SED_PSET, & + DEF_SED_TOTLYRNUM, & + DEF_SED_CFL_ADV, & + DEF_SED_IGNORE_DPH, & + DEF_SED_DT_MAX, & + DEF_SED_DIAMETER, & + DEF_SED_PYLD, & + DEF_SED_PYLDC, & + DEF_SED_PYLDPC, & + DEF_SED_DSYLUNIT, & + + DEF_precip_phase_discrimination_scheme, & + + DEF_USE_SoilInit, & + DEF_file_SoilInit, & + + DEF_HighResSoil, & + DEF_HighResVeg, & + DEF_PROSPECT, & + DEF_HighResUrban_albedo, & + ! DEF_Satellite_Params, & + ! DEF_file_soiloptics, & + ! DEF_file_satellite_params, & + ! DEF_sla_varname, & + + DEF_USE_SnowInit, & + DEF_file_SnowInit, & + + DEF_USE_CN_INIT, & + DEF_file_cn_init, & + + DEF_USE_WaterTableInit, & + DEF_file_WaterTable, & + + DEF_file_snowoptics, & + DEF_file_snowaging , & + + DEF_ElementNeighbour_file, & + DEF_UnitCatchment_file, & + DEF_ReservoirPara_file, & + + DEF_DA_obsdir, & + DEF_DA_TWS, & + DEF_DA_TWS_GRACE, & + DEF_DA_SM, & + DEF_DA_ENS_NUM, & + DEF_DA_ENS_SM, & + DEF_DA_SM_SMAP, & + DEF_DA_SM_FY, & + DEF_DA_SM_SYNOP, & + DEF_DA_RTM_diel, & + DEF_DA_RTM_rough, & + + DEF_Optimize_Baseflow, & + + DEF_forcing_namelist, & + + DEF_Forcing_Interp_Method, & + + DEF_USE_Forcing_Downscaling, & + DEF_USE_Forcing_Downscaling_Simple, & + DEF_DS_HiresTopographyDataDir, & + DEF_DS_precipitation_adjust_scheme, & + DEF_DS_longwave_adjust_scheme, & + DEF_USE_ClimForcing_for_Spinup, & + + DEF_HISTORY_IN_VECTOR, & + DEF_HIST_lon_res, & + DEF_HIST_lat_res, & + DEF_HIST_grid_as_forcing, & + DEF_WRST_FREQ, & + DEF_HIST_FREQ, & + DEF_HIST_groupby, & + DEF_HIST_mode, & + DEF_HIST_WriteBack, & + DEF_REST_CompressLevel, & + DEF_HIST_CompressLevel, & + DEF_HIST_vars_namelist, & + DEF_HIST_vars_out_default + + namelist /nl_colm_forcing/ DEF_dir_forcing, DEF_forcing + namelist /nl_colm_history/ DEF_hist_vars + + ! ----- open the namelist file ----- + IF (p_is_master) THEN + + open(10, status='OLD', file=nlfile, form="FORMATTED") + read(10, nml=nl_colm, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(nlfile), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(nlfile)) + ENDIF + close(10) + + open(10, status='OLD', file=trim(DEF_forcing_namelist), form="FORMATTED") + read(10, nml=nl_colm_forcing, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(DEF_forcing_namelist), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(DEF_forcing_namelist)) + ENDIF + close(10) + + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + DEF_forcing%has_missing_value = .false. + ENDIF + + DEF_dir_landdata = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/landdata' + DEF_dir_restart = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/restart' + DEF_dir_history = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/history' + + CALL system('mkdir -p ' // trim(adjustl(DEF_dir_output ))) + CALL system('mkdir -p ' // trim(adjustl(DEF_dir_landdata))) + CALL system('mkdir -p ' // trim(adjustl(DEF_dir_restart ))) + CALL system('mkdir -p ' // trim(adjustl(DEF_dir_history ))) + +#ifdef SinglePoint + DEF_nx_blocks = 360 + DEF_ny_blocks = 180 + DEF_HIST_mode = 'one' +#endif + + IF (DEF_simulation_time%timestep > 3600.) THEN + write(*,*) ' ***** ' + write(*,*) 'Warning: timestep should be less than or equal to 3600 seconds.' + CALL CoLM_Stop () + ENDIF + +! =============================================================== +! ----- Macros&Namelist conflicts and dependency management ----- +! =============================================================== + + +! ----- SOIL model related ------ Macros&Namelist conflicts and dependency management +#if (defined vanGenuchten_Mualem_SOIL_MODEL) + write(*,*) ' ***** ' + write(*,*) 'Note: DEF_USE_VariablySaturatedFlow is automaticlly set to .true. ' + write(*,*) 'when using vanGenuchten_Mualem_SOIL_MODEL. ' + DEF_USE_VariablySaturatedFlow = .true. +#endif +#if (defined CatchLateralFlow) + write(*,*) ' ***** ' + write(*,*) 'Note: DEF_USE_VariablySaturatedFlow is automaticlly set to .true. ' + write(*,*) 'when defined CatchLateralFlow. ' + DEF_USE_VariablySaturatedFlow = .true. +#endif +#ifdef SinglePoint + IF (DEF_Runoff_SCHEME == 0) THEN + write(*,*) 'Note: DEF_TOPMOD_method is set to 0 in SinglePoint.' + DEF_TOPMOD_method = 0 + ENDIF +#endif + + IF (DEF_Runoff_SCHEME == 1) THEN + DEF_file_VIC_para = trim(DEF_dir_runtime)//'/vic/vic_para.txt' + IF (DEF_VIC_OPT) THEN + DEF_file_VIC_OPT = trim(DEF_dir_runtime)//'vic/vic_para.nc' + ENDIF + ENDIF + +! ----- subgrid type related ------ Macros&Namelist conflicts and dependency management + +#if (defined LULC_USGS || defined LULC_IGBP) + DEF_USE_LCT = .true. + DEF_USE_PFT = .false. + DEF_USE_PC = .false. + DEF_FAST_PC = .false. + DEF_SOLO_PFT = .false. +#ifdef vanGenuchten_Mualem_SOIL_MODEL + write(*,*) ' ***** ' + write(*,*) 'Note: Soil resistance is automaticlly turned off for VG soil + USGS|IGBP scheme.' + DEF_RSS_SCHEME = 0 +#endif +#endif + +#ifdef LULC_IGBP_PFT + DEF_USE_LCT = .false. + DEF_USE_PFT = .true. + DEF_USE_PC = .false. + DEF_FAST_PC = .false. +#endif + +#ifdef LULC_IGBP_PC + DEF_USE_LCT = .false. + DEF_USE_PFT = .false. + DEF_USE_PC = .true. + DEF_SOLO_PFT = .false. +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (.not.DEF_LAI_MONTHLY) THEN + write(*,*) ' ***** ' + write(*,*) 'Warning: 8-day LAI data is not supported for ' + write(*,*) 'LULC_IGBP_PFT and LULC_IGBP_PC.' + write(*,*) 'Changed to monthly data, set DEF_LAI_MONTHLY = .true.' + DEF_LAI_MONTHLY = .true. + ENDIF +#endif + + +! ----- BGC and CROP model related ------ Macros&Namelist conflicts and dependency management + +#ifndef BGC + IF(DEF_USE_LAIFEEDBACK)THEN + DEF_USE_LAIFEEDBACK = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: LAI feedback is not supported for BGC off.' + write(*,*) 'DEF_USE_LAIFEEDBACK is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_SASU)THEN + DEF_USE_SASU = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Semi-Analytic Spin-up is on when BGC is off.' + write(*,*) 'DEF_USE_SASU is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_DiagMatrix)THEN + DEF_USE_DiagMatrix = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: CN Matrix Diagnostic is on when BGC is off.' + write(*,*) 'DEF_USE_DiagMatrix is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_PN)THEN + DEF_USE_PN = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Punctuated nitrogen addition spin up is on when BGC is off.' + write(*,*) 'DEF_USE_PN is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_NITRIF)THEN + DEF_USE_NITRIF = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Nitrification-Denitrification is on when BGC is off.' + write(*,*) 'DEF_USE_NITRIF is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_FIRE)THEN + DEF_USE_FIRE = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Fire model is on when BGC is off.' + write(*,*) 'DEF_USE_FIRE is set to false automatically when BGC is turned off.' + ENDIF +#endif + +#ifndef CROP + IF(DEF_USE_FERT)THEN + DEF_USE_FERT = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Fertilization is on when CROP is off.' + write(*,*) 'DEF_USE_FERT is set to false automatically when CROP is turned off.' + ENDIF + + IF(DEF_USE_CNSOYFIXN)THEN + DEF_USE_CNSOYFIXN = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Soy nitrogen fixation is on when CROP is off.' + write(*,*) 'DEF_USE_CNSOYFIXN is set to false automatically when CROP is turned off.' + ENDIF + + IF(DEF_USE_IRRIGATION)THEN + DEF_USE_IRRIGATION = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: irrigation is on when CROP is off.' + write(*,*) 'DEF_USE_IRRIGATION is set to false automatically when CROP is turned off.' + ENDIF +#endif + + IF(.not.(DEF_FERT_SOURCE == 1 .or. DEF_FERT_SOURCE == 2))THEN + write(*,*) ' ***** ' + write(*,'(A,I0,A)') 'ERROR: DEF_FERT_SOURCE is ',DEF_FERT_SOURCE,' , should only = 1 or 2' + CALL CoLM_stop () + ENDIF + + IF(.not. DEF_USE_OZONESTRESS)THEN + IF(DEF_USE_OZONEDATA)THEN + DEF_USE_OZONEDATA = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: DEF_USE_OZONEDATA is not supported for OZONESTRESS off.' + write(*,*) 'DEF_USE_OZONEDATA is set to false automatically.' + ENDIF + ENDIF + + IF(DEF_USE_MEDLYNST)THEN + IF(DEF_USE_WUEST)THEN + DEF_USE_MEDLYNST = .false. + DEF_USE_WUEST = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: configure conflict, both DEF_USE_MEDLYNST and DEF_USE_WUEST were set true.' + write(*,*) 'set both DEF_USE_MEDLYNST and DEF_USE_WUEST to false.' + ENDIF + ENDIF + +! ----- SNICAR model ------ Macros&Namelist conflicts and dependency management + + DEF_file_snowoptics = trim(DEF_dir_runtime)//'/snicar/snicar_optics_5bnd_mam_c211006.nc' + DEF_file_snowaging = trim(DEF_dir_runtime)//'/snicar/snicar_drdt_bst_fit_60_c070416.nc' + + IF (.not. DEF_USE_SNICAR) THEN + IF (DEF_Aerosol_Readin) THEN + DEF_Aerosol_Readin = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: DEF_Aerosol_Readin is not needed for DEF_USE_SNICAR off. ' + write(*,*) 'DEF_Aerosol_Readin is set to false automatically.' + ENDIF + ENDIF + + +! ----- Urban model ----- Macros&Namelist conflicts and dependency management + +#ifdef URBAN_MODEL + DEF_URBAN_RUN = .true. + + write(*,*) ' ***** ' + write(*,*) 'When URBAN model is opened, WUEST/SUPERCOOL_WATER/PLANTHYDRAULICS/OZONESTRESS/SOILSNOW' + write(*,*) 'will be set to false automatically for simplicity.' + DEF_USE_WUEST = .false. + DEF_USE_SUPERCOOL_WATER = .false. + DEF_USE_PLANTHYDRAULICS = .false. + DEF_USE_OZONESTRESS = .false. + DEF_USE_OZONEDATA = .false. + DEF_SPLIT_SOILSNOW = .false. +#else + IF (DEF_URBAN_RUN) THEN + write(*,*) ' ***** ' + write(*,*) 'Note: The Urban model is not opened. IF you want to run Urban model ' + write(*,*) 'please #define URBAN_MODEL in define.h. otherwise DEF_URBAN_RUN will ' + write(*,*) 'be set to false automatically.' + DEF_URBAN_RUN = .false. + ENDIF +#endif + + +! ----- LULCC ----- Macros&Namelist conflicts and dependency management + +#ifdef LULCC + + write(*,*) ' ***** ' + write(*,*) 'Warning: The LULCC data is provided for years 2000 to 2020 right now! ' + write(*,*) 'Please make sure the year range you set is suitable. ' + +#if (defined LULC_USGS || defined BGC) + write(*,*) ' ***** ' + write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_USGS/BGC at present. STOP! ' + CALL CoLM_stop () +#endif + IF (.not.DEF_LAI_MONTHLY) THEN + write(*,*) ' ***** ' + write(*,*) 'Note: When LULCC is opened, DEF_LAI_MONTHLY ' + write(*,*) 'will be set to true automatically.' + DEF_LAI_MONTHLY = .true. + ENDIF + + IF (.not.DEF_LAI_CHANGE_YEARLY) THEN + write(*,*) ' ***** ' + write(*,*) 'Note: When LULCC is opened, DEF_LAI_CHANGE_YEARLY ' + write(*,*) 'will be set to true automatically.' + DEF_LAI_CHANGE_YEARLY = .true. + ENDIF + +#if (defined LULC_IGBP_PC || defined URBAN) + !write(*,*) ' ***** ' + !write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_IGBP_PC/URBAN at present. STOP! ' + !write(*,*) 'It is coming soon. ' + !CALL CoLM_stop () + ![update] 24/10/2023: right now IGBP/PFT/PC and Urban are all supported. +#endif + +#if (defined SinglePoint) + write(*,*) ' ***** ' + write(*,*) 'Fatal ERROR: LULCC is not supported for Single Point run at present. STOP! ' + write(*,*) 'It will come later. ' + CALL CoLM_stop () +#endif + +#endif + +#if (defined DEF_LAI_CHANGE_YEARLY) + write(*,*) ' ***** ' + write(*,*) 'Warning: The LAI data is provided for years 2000 to 2020 right now! ' + write(*,*) 'Any year before 2000 or after 2020 will be treated as 2000 or 2020. ' +#endif + + +! ----- single point run ----- Macros&Namelist conflicts and dependency management + +#if (defined SinglePoint) +#ifdef SrfdataDiag + write(*,*) ' ***** ' + write(*,*) 'Surface data diagnose is closed in SinglePoint case.' +#undef SrfdataDiag +#endif + IF (trim(DEF_Forcing_Interp_Method) == 'bilinear') THEN + DEF_Forcing_Interp_Method = 'arealweight' + write(*,*) ' ***** ' + write(*,*) 'Bilinear interpolation is not supported in SinglePoint case.' + ENDIF +#endif + +! ----- Soil water and temperature Initialization ----- Namelist conflicts + + IF (DEF_USE_SoilInit .and. DEF_USE_WaterTableInit) THEN + write(*,*) ' ***** ' + write(*,*) 'If both DEF_USE_SoilInit and DEF_USE_WaterTableInit are .TRUE., ' + write(*,*) 'initial value of water table depth is read from DEF_file_SoilInit,' + write(*,*) 'instead of DEF_file_WaterTable (which is useless in this CASE). ' + ENDIF + +! ----- dynamic lake run ----- Macros&Namelist conflicts and dependency management + +#ifndef CATCHMENT + IF ((.not. DEF_USE_VariablySaturatedFlow) .and. DEF_USE_Dynamic_Lake) THEN + DEF_USE_Dynamic_Lake = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Dynamic Lake is closed if variably saturated flow algorithm is not used.' + ENDIF + IF (DEF_USE_Dynamic_Lake) THEN + write(*,*) ' ***** ' + write(*,*) 'Warning: Dynamic Lake is not well supported without lateral flow.' + ENDIF +#else + DEF_USE_Dynamic_Lake = .true. + write(*,*) ' ***** ' + write(*,*) 'Warning: Dynamic Lake is used if CATCHMENT-based lateral flow used.' +#endif + +! ----- 2m WMO temperature ---- Macros&Namelist conflicts and dependency management + +#if !defined(GRIDBASED) || (defined LULC_IGBP || defined LULC_USGS) + IF (DEF_Output_2mWMO) THEN + DEF_Output_2mWMO = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: 2m WMO temperature is not well supported for IGBP and USGS' + write(*,*) 'DEF_Output_2mWMO will be set to false automatically.' + ENDIF +#endif + +! ----- [Complement IF needed] ----- Macros&Namelist conflicts and dependency management + + +! -----END Macros&Namelist conflicts and dependency management ----- +! =============================================================== + + + ENDIF + + +#ifdef USEMPI + CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_PIO_groupsize ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_nIO_eq_nBlock ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + +#if (defined GRIDBASED || defined UNSTRUCTURED) + CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) +#endif + +#ifdef CATCHMENT + CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) +#endif + + CALL mpi_bcast (DEF_file_mesh_filter ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (USE_zip_for_aggregation ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Srfdata_CompressLevel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + ! 07/2023, added by yuan: subgrid setting related + CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + ! 05/2023, added by Xingjie lu + CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + ! LULC related + CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + ! 05/2023, added by yuan + CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + ! 06/2023, added by weinan + CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + ! 06/2023, added by hua yuan + CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + ! 07/2023, added by zhuo liu + CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + ! 02/2024, added by Shupeng Zhang + CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + ! 08/2023, added by hua yuan + CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + + DO ivar = 1, 8 + CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + ENDDO + CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) +#endif + + CALL sync_hist_vars (set_defaults = .true.) + + IF (p_is_master) THEN + + inquire (file=trim(DEF_HIST_vars_namelist), exist=fexists) + IF (.not. fexists) THEN + write(*,*) 'History namelist file: ', trim(DEF_HIST_vars_namelist), ' does not exist.' + ELSE + open(10, status='OLD', file=trim(DEF_HIST_vars_namelist), form="FORMATTED") + read(10, nml=nl_colm_history, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(DEF_HIST_vars_namelist), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: ' & + // trim(DEF_HIST_vars_namelist)) + ENDIF + close(10) + ENDIF + + IF(DEF_USE_DiagMatrix)THEN + DEF_hist_vars%leafcCap = .true. + DEF_hist_vars%leafc_storageCap = .true. + DEF_hist_vars%leafc_xferCap = .true. + DEF_hist_vars%frootcCap = .true. + DEF_hist_vars%frootc_storageCap = .true. + DEF_hist_vars%frootc_xferCap = .true. + DEF_hist_vars%livestemcCap = .true. + DEF_hist_vars%livestemc_storageCap = .true. + DEF_hist_vars%livestemc_xferCap = .true. + DEF_hist_vars%deadstemcCap = .true. + DEF_hist_vars%deadstemc_storageCap = .true. + DEF_hist_vars%deadstemc_xferCap = .true. + DEF_hist_vars%livecrootcCap = .true. + DEF_hist_vars%livecrootc_storageCap = .true. + DEF_hist_vars%livecrootc_xferCap = .true. + DEF_hist_vars%deadcrootcCap = .true. + DEF_hist_vars%deadcrootc_storageCap = .true. + DEF_hist_vars%deadcrootc_xferCap = .true. + DEF_hist_vars%leafnCap = .true. + DEF_hist_vars%leafn_storageCap = .true. + DEF_hist_vars%leafn_xferCap = .true. + DEF_hist_vars%frootnCap = .true. + DEF_hist_vars%frootn_storageCap = .true. + DEF_hist_vars%frootn_xferCap = .true. + DEF_hist_vars%livestemnCap = .true. + DEF_hist_vars%livestemn_storageCap = .true. + DEF_hist_vars%livestemn_xferCap = .true. + DEF_hist_vars%deadstemnCap = .true. + DEF_hist_vars%deadstemn_storageCap = .true. + DEF_hist_vars%deadstemn_xferCap = .true. + DEF_hist_vars%livecrootnCap = .true. + DEF_hist_vars%livecrootn_storageCap = .true. + DEF_hist_vars%livecrootn_xferCap = .true. + DEF_hist_vars%deadcrootnCap = .true. + DEF_hist_vars%deadcrootn_storageCap = .true. + DEF_hist_vars%deadcrootn_xferCap = .true. + DEF_hist_vars%t_scalar = .true. + DEF_hist_vars%w_scalar = .true. + + DEF_hist_vars%litr1cCap_vr = .true. + DEF_hist_vars%litr2cCap_vr = .true. + DEF_hist_vars%litr3cCap_vr = .true. + DEF_hist_vars%soil1cCap_vr = .true. + DEF_hist_vars%soil2cCap_vr = .true. + DEF_hist_vars%soil3cCap_vr = .true. + DEF_hist_vars%cwdcCap_vr = .true. + DEF_hist_vars%litr1nCap_vr = .true. + DEF_hist_vars%litr2nCap_vr = .true. + DEF_hist_vars%litr3nCap_vr = .true. + DEF_hist_vars%soil1nCap_vr = .true. + DEF_hist_vars%soil2nCap_vr = .true. + DEF_hist_vars%soil3nCap_vr = .true. + DEF_hist_vars%cwdnCap_vr = .true. + ENDIF + ENDIF + + CALL sync_hist_vars (set_defaults = .false.) + + END SUBROUTINE read_namelist + + ! --------------- + SUBROUTINE sync_hist_vars (set_defaults) + + IMPLICIT NONE + + logical, intent(in) :: set_defaults + + CALL sync_hist_vars_one (DEF_hist_vars%xy_us , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_vs , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_t , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_q , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_prc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_prl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_pbot , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_frl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_solarin , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_rain , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_snow , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%xy_hpbl , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%taux , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tauy , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsena , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevpa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fevpa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsenl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fevpl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fseng , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fevpg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fgrnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sabvsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sabvsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sabg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%olrg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rnet , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xerr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%zerr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsur , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsur_se , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsur_ie , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsub , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rnof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xwsur , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xwsub , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fldarea , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qintr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qinfl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qdrip , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wat_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetwat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetwat_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetzwt , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%assim , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%respc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qcharge , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_grnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tleaf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%ldew , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%scv , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%snowdp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsno , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frcsat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sigf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%green , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%laisun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%laisha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sai , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%alb , set_defaults) +#ifdef HYPERSPECTRAL + CALL sync_hist_vars_one (DEF_hist_vars%alb_hires , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%reflectance_out , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%transmittance_out , set_defaults) +#endif + CALL sync_hist_vars_one (DEF_hist_vars%emis , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%z0m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%trad , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rss , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tref , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t2m_wmo , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qref , set_defaults) +#ifdef URBAN_MODEL + CALL sync_hist_vars_one (DEF_hist_vars%fsen_roof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_wsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_wsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_gimp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_gper , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_urbl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_roof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_gimp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_gper , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_urbl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fhac , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fwst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fach , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fhah , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%meta , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vehc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_room , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tafu , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_roof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_wall , set_defaults) +#endif + CALL sync_hist_vars_one (DEF_hist_vars%assimsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%assimsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etrsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etrsha , set_defaults) +#ifdef BGC + CALL sync_hist_vars_one (DEF_hist_vars%leafc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%retrasn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%downreg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%ar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdprod , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwddecomp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%hr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fpg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fpi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totvegc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totlitc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcwdc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totsomc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcolc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totvegn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totlitn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcwdn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totsomn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcoln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totsoiln_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_c4grass , set_defaults) +#ifdef CROP + CALL sync_hist_vars_one (DEF_hist_vars%cphase , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gddmaturity , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gddplant , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%hui , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprod1c , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprod1c_loss , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropseedc_deficit , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc_to_cropprodc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_temp_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_temp_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_trop_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_trop_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_unmanagedcrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_temp_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_temp_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_trop_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_trop_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_unmanagedcrop , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%grainc_to_seed , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fert_to_sminn , set_defaults) + + IF(DEF_USE_FERT)THEN + CALL sync_hist_vars_one (DEF_hist_vars%manunitro , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_swheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_wwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_rice1 , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_rice2 , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_sugarcane , set_defaults) + ENDIF + + IF(DEF_USE_IRRIGATION)THEN + CALL sync_hist_vars_one (DEF_hist_vars%sum_irrig , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sum_deficit_irrig , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sum_irrig_count , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%waterstorage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%groundwater_demand , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%groundwater_supply , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%reservoirriver_demand , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%reservoirriver_supply , set_defaults) + ENDIF +#endif + CALL sync_hist_vars_one (DEF_hist_vars%ndep_to_sminn , set_defaults) + IF(DEF_USE_NITRIF)THEN + CALL sync_hist_vars_one (DEF_hist_vars%CONC_O2_UNSAT , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT , set_defaults) + ENDIF + IF(DEF_USE_FIRE)THEN + CALL sync_hist_vars_one (DEF_hist_vars%abm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gdp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%peatf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%hdm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lnfm , set_defaults) + ENDIF + CALL sync_hist_vars_one (DEF_hist_vars%leafcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_scalar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%w_scalar , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%litr1cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdcCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr1nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdnCap_vr , set_defaults) +#endif + IF(DEF_USE_OZONESTRESS)THEN + CALL sync_hist_vars_one (DEF_hist_vars%o3uptakesun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%o3uptakesha , set_defaults) + ENDIF + +#ifdef DataAssimilation + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_h2osoi_5cm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_h2osoi_5cm_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_5cm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_5cm_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_soisno_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_soisno_5cm_ens_std, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_5cm_ens_std , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap_ens_std , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d_ens_std , set_defaults) +#endif + + CALL sync_hist_vars_one (DEF_hist_vars%t_soisno , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wliq_soisno , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wice_soisno , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%h2osoi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qlayer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lake_deficit, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rstfacsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rstfacsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gssun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gssha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rootr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vegwp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%BD_all , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wfc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%OM_density , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%zwt , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wa_inst , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%dz_lake , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_lake , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lake_icefrac, set_defaults) + +#ifdef BGC + CALL sync_hist_vars_one (DEF_hist_vars%litr1c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdc_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr1n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdn_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sminn_vr , set_defaults) +#endif + + CALL sync_hist_vars_one (DEF_hist_vars%ustar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%ustar2 , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tstar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qstar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%zol , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rib , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fh , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fq , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%us10m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vs10m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fm10m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solvd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solvi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solni , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srvd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srvi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srni , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%solvdln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solviln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solndln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solniln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srvdln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srviln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srndln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srniln , set_defaults) +#ifdef HYPERSPECTRAL + CALL sync_hist_vars_one (DEF_hist_vars%sol_dir_ln_hires, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sol_dif_ln_hires, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sr_dir_ln_hires , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sr_dif_ln_hires , set_defaults) +#endif + + CALL sync_hist_vars_one (DEF_hist_vars%xsubs_bsn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xsubs_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%riv_height , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%riv_veloct , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%discharge , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%floodarea , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%floodfrc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%veloc_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%volresv , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qresv_in , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qresv_out , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%sedcon , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sedout , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%bedout , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sedinp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%netflw , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sedlayer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%shearvel , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%sensors , set_defaults) + + END SUBROUTINE sync_hist_vars + + SUBROUTINE sync_hist_vars_one (onoff, set_defaults) + + USE MOD_SPMD_Task + IMPLICIT NONE + + logical, intent(inout) :: onoff + logical, intent(in) :: set_defaults + + IF (p_is_master) THEN + IF (set_defaults) THEN + onoff = DEF_HIST_vars_out_default + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_bcast (onoff, 1, mpi_logical, p_address_master, p_comm_glb, p_err) +#endif + + END SUBROUTINE sync_hist_vars_one + +END MODULE MOD_Namelist diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 new file mode 100644 index 0000000000..faff0b500a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 @@ -0,0 +1,462 @@ +#include + +MODULE MOD_NetCDFBlock + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! +! CoLM read and write netCDF files mainly in three ways: +! 1. Serial: read and write data by a single process; +! 2. Vector: 1) read vector data by IO and scatter from IO to workers +! 2) gather from workers to IO and write vectors by IO +! Notice: each file contains vector data in one block. +! 3. Block : read blocked data by IO +! Notice: input file is a single file. +! +! This MODULE contains subroutines of "3. Block". +! +! Created by Shupeng Zhang, May 2023 +!---------------------------------------------------------------------------------- + + USE netcdf + USE MOD_NetCDFSerial + IMPLICIT NONE + + ! PUBLIC subroutines + INTERFACE ncio_read_block + MODULE procedure ncio_read_block_int32_2d + MODULE procedure ncio_read_block_real8_2d + MODULE procedure ncio_read_block_real8_3d + END INTERFACE ncio_read_block + + INTERFACE ncio_read_block_time + MODULE procedure ncio_read_block_int32_2d_time + MODULE procedure ncio_read_block_real8_2d_time + MODULE procedure ncio_read_block_real8_3d_time + END INTERFACE ncio_read_block_time + + PUBLIC :: ncio_read_site_time + +CONTAINS + + ! ---- + SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_int32_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start2(2), count2(2), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start2 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1/) + count2(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count2(2) = grid%ycnt(jblk) + + IF (count2(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start2, count2) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count2(1),:), start2, count2) ) + + start2(1) = 1 + start_mem = count2(1) + 1 + count2(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start2, count2) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_int32_2d + + ! ---- + SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start2(2), count2(2), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start2 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1/) + count2(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count2(2) = grid%ycnt(jblk) + + IF (count2(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start2, count2) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count2(1),:), start2, count2) ) + + start2(1) = 1 + start_mem = count2(1) + 1 + count2(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start2, count2) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_2d + + ! ---- + SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: ndim1 + + type (block_data_real8_3d), intent(inout) :: rdata + integer :: ncid, varid + + ! Local variables + integer :: iblk, jblk, ndims(3), start3(3), count3(3), start_mem + integer :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/ndim1, grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start3 = (/1, grid%xdsp(iblk)+1, grid%ydsp(jblk)+1/) + count3(1) = ndim1 + count3(2) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count3(3) = grid%ycnt(jblk) + + IF (count3(2) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start3, count3) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,1:count3(2),:), start3, count3) ) + + start3(2) = 1 + start_mem = count3(2) + 1 + count3(2) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,start_mem:ndims(2),:), start3, count3) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_3d + + ! ---- + SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_int32_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start3(3), count3(3), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start3 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count3(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count3(2) = grid%ycnt(jblk) + count3(3) = 1 + + IF (count3(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start3, count3) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count3(1),:), start3, count3) ) + + start3(1) = 1 + start_mem = count3(1) + 1 + count3(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start3, count3) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_int32_2d_time + + ! ---- + SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start3(3), count3(3), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start3 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count3(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count3(2) = grid%ycnt(jblk) + count3(3) = 1 + IF (count3(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start3, count3) ,trace=trim(filename)) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count3(1),:), start3, count3) ) + + start3(1) = 1 + start_mem = count3(1) + 1 + count3(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start3, count3) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_2d_time + + ! ---- + SUBROUTINE ncio_read_block_real8_3d_time (filename, dataname, grid, ndim1, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: ndim1, itime + + type (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(3), start4(4), count4(4), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/ndim1, grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start4 = (/1, grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count4(1) = ndim1 + count4(2) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count4(3) = grid%ycnt(jblk) + count4(4) = 1 + IF (count4(2) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start4, count4) ,trace=trim(filename)) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,1:count4(2),:), start4, count4) ) + + start4(2) = 1 + start_mem = count4(2) + 1 + count4(2) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,start_mem:ndims(2),:), start4, count4) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_3d_time + + ! ---- + SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Namelist + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: start3(3), count3(3) + integer :: varid, dimid + character(len=256), SAVE :: fileopen = 'null' + integer, SAVE :: ncid, time_dim + logical, SAVE :: fid = .false. + + IF (p_is_io) THEN + CALL check_ncfile_exist (filename) + + IF ((.not. fid) .or. (trim(fileopen) /= trim(filename))) THEN + fid = .true. + fileopen = trim(filename) + + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + + CALL nccheck (nf90_inq_dimid(ncid, 'time', dimid), trace=trim(filename)) + CALL nccheck (nf90_inquire_dimension(ncid, dimid, len=time_dim), trace=trim(filename)) + ENDIF + + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + start3 = (/1, 1, itime/) + count3 = (/1, 1, 1/) + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(gblock%xblkme(1),gblock%yblkme(1))%val, start3, count3) ) + + IF ((itime==time_dim) .and. trim(dataname)==DEF_forcing%vname(DEF_forcing%NVAR)) THEN + CALL nccheck( nf90_close(ncid) ) + ENDIF + + ENDIF + + END SUBROUTINE ncio_read_site_time + +END MODULE MOD_NetCDFBlock diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 new file mode 100644 index 0000000000..95e7615a95 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 @@ -0,0 +1,425 @@ +#include + +MODULE MOD_NetCDFPoint + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! Read data for single point run. +! +! Created by Shupeng Zhang, March 2025 +!---------------------------------------------------------------------------------- + + USE netcdf + USE MOD_Precision + USE MOD_Grid + USE MOD_Utils + USE MOD_NetCDFSerial, only : nccheck + IMPLICIT NONE + + ! PUBLIC subroutines + PUBLIC :: read_point_var_2d_int32 + PUBLIC :: read_point_var_2d_real8 + PUBLIC :: read_point_var_3d_real8 + PUBLIC :: read_point_var_3d_first_real8 + PUBLIC :: read_point_var_2d_time_real8 + PUBLIC :: read_point_var_3d_time_real8 + PUBLIC :: read_point_5x5_var_2d_int32 + PUBLIC :: read_point_5x5_var_2d_real8 + PUBLIC :: read_point_5x5_var_3d_real8 + PUBLIC :: read_point_5x5_var_2d_time_real8 + PUBLIC :: read_point_5x5_var_3d_time_real8 + +CONTAINS + + ! ------ + SUBROUTINE read_point_var_2d_int32 (grid, filename, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + integer, intent(out) :: rdata + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + integer :: rcache(1) + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, (/ilon,ilat/), (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_var_2d_int32 + + ! ------ + SUBROUTINE read_point_var_2d_real8 (grid, filename, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + real(r8), intent(out) :: rdata + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + real(r8) :: rcache(1) + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, (/ilon,ilat/), (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_var_2d_real8 + + ! ------ + SUBROUTINE read_point_var_3d_real8 (grid, filename, varname, site_lon, site_lat, nlastdim, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + + real(r8), allocatable, intent(out) :: rdata(:) + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + allocate (rdata (nlastdim)) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, (/ilon,ilat,1/), (/1,1,nlastdim/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_var_3d_real8 + + ! ------ + SUBROUTINE read_point_var_3d_first_real8 (grid, filename, varname, site_lon, site_lat, nfirstdim, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nfirstdim + + real(r8), allocatable, intent(out) :: rdata(:) + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + allocate (rdata (nfirstdim)) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, (/1,ilon,ilat/), (/nfirstdim,1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_var_3d_first_real8 + + ! ------ + SUBROUTINE read_point_var_2d_time_real8 (grid, filename, varname, site_lon, site_lat, itime, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: itime + + real(r8), intent(out) :: rdata + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + real(r8) :: rcache(1) + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, (/ilon,ilat,itime/), (/1,1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_var_2d_time_real8 + + ! ------ + SUBROUTINE read_point_var_3d_time_real8 (grid, filename, varname, site_lon, site_lat, nlastdim, itime, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + integer, intent(in) :: itime + + real(r8), allocatable, intent(out) :: rdata(:) + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + allocate (rdata (nlastdim)) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, (/ilon,ilat,1,itime/), (/1,1,nlastdim,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_var_3d_time_real8 + + ! ----- + SUBROUTINE get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, file_5x5, start2) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + character (len=*), intent(out) :: file_5x5 + integer, intent(out) :: start2(2) + + ! local variables + integer :: ilon, ilat, nxbox, nybox, ibox, jbox + character (len=4) :: str + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + nxbox = grid%nlon / 360 * 5 + nybox = grid%nlat / 180 * 5 + + ibox = (ilon-1)/nxbox + 1 + jbox = (ilat-1)/nybox + 1 + start2(1) = ilon - (ibox-1)*nxbox + start2(2) = ilat - (jbox-1)*nybox + + file_5x5 = trim(dir_5x5) // '/RG' + write(str, '(I4)') (19-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-37)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (18-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-36)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + file_5x5 = trim(file_5x5) // '.' // trim(sfx) // '.nc' + + END SUBROUTINE get_5x5_filename + + ! ----- + SUBROUTINE read_point_5x5_var_2d_int32 (grid, dir_5x5, sfx, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + integer, intent(out) :: rdata + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start2(2) + integer :: rcache(1) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start2) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, start2, (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_5x5_var_2d_int32 + + ! ----- + SUBROUTINE read_point_5x5_var_2d_real8 (grid, dir_5x5, sfx, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + real(r8), intent(out) :: rdata + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start2(2) + real(r8) :: rcache(1) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start2) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, start2, (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_5x5_var_2d_real8 + + ! ----- + SUBROUTINE read_point_5x5_var_3d_real8 (grid, dir_5x5, sfx, varname, site_lon, site_lat, nlastdim, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + + real(r8), allocatable, intent(out) :: rdata(:) + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start3(3) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start3(1:2)) + + allocate (rdata (nlastdim)) + + start3(3) = 1 + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, start3, (/1,1,nlastdim/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_5x5_var_3d_real8 + + ! ----- + SUBROUTINE read_point_5x5_var_2d_time_real8 (grid, dir_5x5, sfx, varname, site_lon, site_lat, itime, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: itime + + real(r8), intent(out) :: rdata + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start3(3) + real(r8) :: rcache(1) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start3(1:2)) + + start3(3) = itime + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, start3, (/1,1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_5x5_var_2d_time_real8 + + ! ----- + SUBROUTINE read_point_5x5_var_3d_time_real8 (grid, dir_5x5, sfx, varname, & + site_lon, site_lat, nlastdim, itime, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + integer, intent(in) :: itime + + real(r8), allocatable, intent(out) :: rdata(:) + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start4(4) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start4(1:2)) + + allocate (rdata (nlastdim)) + + start4(3) = 1 + start4(4) = itime + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, start4, (/1,1,nlastdim,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_5x5_var_3d_time_real8 + +END MODULE MOD_NetCDFPoint diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 new file mode 100644 index 0000000000..367f650562 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 @@ -0,0 +1,2635 @@ +#include + +MODULE MOD_NetCDFSerial + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! +! CoLM read and write netCDF files mainly in three ways: +! 1. Serial: read and write data by a single process; +! 2. Vector: 1) read vector data by IO and scatter from IO to workers +! 2) gather from workers to IO and write vectors by IO +! Notice: each file CONTAINS vector data in one block. +! 3. Block : read blocked data by IO +! Notice: input file is a single file. +! +! This MODULE CONTAINS subroutines of "1. Serial". +! +! Created by Shupeng Zhang, May 2023 +!---------------------------------------------------------------------------------- + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + ! PUBLIC subroutines + + PUBLIC :: ncio_create_file + PUBLIC :: check_ncfile_exist + + INTERFACE ncio_put_attr + MODULE procedure ncio_put_attr_str + MODULE procedure ncio_put_attr_real8 + END INTERFACE ncio_put_attr + + INTERFACE ncio_get_attr + MODULE procedure ncio_get_attr_str + MODULE procedure ncio_get_attr_real8 + END INTERFACE ncio_get_attr + + PUBLIC :: ncio_var_exist + PUBLIC :: ncio_inquire_varsize + PUBLIC :: ncio_inquire_length + + INTERFACE ncio_read_serial + MODULE procedure ncio_read_serial_int32_0d + MODULE procedure ncio_read_serial_real8_0d + MODULE procedure ncio_read_serial_int8_1d + MODULE procedure ncio_read_serial_int32_1d + MODULE procedure ncio_read_serial_int64_1d + MODULE procedure ncio_read_serial_real8_1d + MODULE procedure ncio_read_serial_int8_2d + MODULE procedure ncio_read_serial_int16_2d + MODULE procedure ncio_read_serial_int32_2d + MODULE procedure ncio_read_serial_real4_2d + MODULE procedure ncio_read_serial_real8_2d + MODULE procedure ncio_read_serial_int32_3d + MODULE procedure ncio_read_serial_real8_3d + MODULE procedure ncio_read_serial_real8_4d + MODULE procedure ncio_read_serial_real8_5d + END INTERFACE ncio_read_serial + + INTERFACE ncio_read_bcast_serial + MODULE procedure ncio_read_bcast_serial_int32_0d + MODULE procedure ncio_read_bcast_serial_real8_0d + MODULE procedure ncio_read_bcast_serial_int32_1d + MODULE procedure ncio_read_bcast_serial_int32_2d + MODULE procedure ncio_read_bcast_serial_real8_1d + MODULE procedure ncio_read_bcast_serial_real8_2d + MODULE procedure ncio_read_bcast_serial_real8_3d + MODULE procedure ncio_read_bcast_serial_real8_4d + MODULE procedure ncio_read_bcast_serial_real8_5d + MODULE procedure ncio_read_bcast_serial_logical_1d + END INTERFACE ncio_read_bcast_serial + + INTERFACE ncio_read_part_serial + MODULE procedure ncio_read_part_serial_int32_1d + MODULE procedure ncio_read_part_serial_int32_2d + MODULE procedure ncio_read_part_serial_real8_2d + END INTERFACE ncio_read_part_serial + + INTERFACE ncio_read_indexed_serial + MODULE procedure ncio_read_indexed_serial_int32_1d + MODULE procedure ncio_read_indexed_serial_real8_1d + MODULE procedure ncio_read_indexed_serial_int32_2d + MODULE procedure ncio_read_indexed_serial_real8_2d + END INTERFACE ncio_read_indexed_serial + + PUBLIC :: ncio_read_indexed_serial + + INTERFACE ncio_read_period_serial + MODULE procedure ncio_read_period_serial_real8_2d + END INTERFACE ncio_read_period_serial + + + INTERFACE ncio_define_dimension + MODULE procedure ncio_define_dimension_int32 + MODULE procedure ncio_define_dimension_int64 + END INTERFACE ncio_define_dimension + + INTERFACE ncio_write_serial + MODULE procedure ncio_write_serial_int32_0d + MODULE procedure ncio_write_serial_real8_0d + MODULE procedure ncio_write_serial_int8_1d + MODULE procedure ncio_write_serial_int32_1d + MODULE procedure ncio_write_serial_int64_1d + MODULE procedure ncio_write_serial_real8_1d + MODULE procedure ncio_write_serial_logical_1d + MODULE procedure ncio_write_serial_int8_2d + MODULE procedure ncio_write_serial_int16_2d + MODULE procedure ncio_write_serial_int32_2d + MODULE procedure ncio_write_serial_int64_2d + MODULE procedure ncio_write_serial_real4_2d + MODULE procedure ncio_write_serial_real8_2d + MODULE procedure ncio_write_serial_int32_3d + MODULE procedure ncio_write_serial_real8_3d + MODULE procedure ncio_write_serial_real8_4d + MODULE procedure ncio_write_serial_real8_5d + END INTERFACE ncio_write_serial + + PUBLIC :: ncio_write_serial + PUBLIC :: ncio_write_time + PUBLIC :: ncio_write_lastdim + + INTERFACE ncio_write_serial_time + MODULE procedure ncio_write_serial_real8_0d_time + MODULE procedure ncio_write_serial_real8_1d_time + MODULE procedure ncio_write_serial_real8_2d_time + MODULE procedure ncio_write_serial_real8_3d_time + MODULE procedure ncio_write_serial_real8_4d_time + END INTERFACE ncio_write_serial_time + + PUBLIC :: get_time_now + + PUBLIC :: ncio_write_colm_dimension + +CONTAINS + + ! ---- + SUBROUTINE nccheck (status, trace) + + USE MOD_SPMD_Task + IMPLICIT NONE + + integer, intent(in) :: status + character(len=*), intent(in), optional :: trace + + IF (status /= NF90_NOERR) THEN + IF (present(trace)) THEN + write(*,'(A)') 'Netcdf error: ' //trim(nf90_strerror(status))// ' ' //trim(trace) + ELSE + write(*,'(A)') 'Netcdf error: ' //trim(nf90_strerror(status)) + ENDIF + + CALL CoLM_stop () + ENDIF + + END SUBROUTINE nccheck + + ! ---- + SUBROUTINE check_ncfile_exist (filename) + + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: filename + ! Local Variables + logical :: fexists + + inquire (file=trim(filename), exist=fexists) + IF (.not. fexists) THEN + write(*,*) trim(filename), ' does not exist.' + CALL CoLM_stop () + ENDIF + + END SUBROUTINE check_ncfile_exist + + ! ---- + character(len=27) FUNCTION get_time_now () + + IMPLICIT NONE + character(len=8) :: date + character(len=10) :: time + character(len=5) :: zone + + CALL date_and_time(date, time, zone) + get_time_now = date(1:8)//'-'//time(1:2)//':'//time(3:4)//':'//time(5:6) & + //' UTC'//zone(1:3)//':'//zone(4:5) + + END FUNCTION get_time_now + + ! ---- + SUBROUTINE ncio_create_file (filename) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + + ! Local Variables + integer :: ncid + + CALL nccheck( nf90_create(trim(filename), ior(NF90_CLOBBER,NF90_NETCDF4), ncid) ) + + CALL nccheck( nf90_put_att(ncid, NF90_GLOBAL, 'create_time', get_time_now())) + CALL nccheck (nf90_enddef (ncid)) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_create_file + + ! ---- + SUBROUTINE ncio_put_attr_str (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname, attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_WRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_redef (ncid)) + CALL nccheck (nf90_put_att (ncid, varid, trim(attrname), trim(attrval))) + CALL nccheck (nf90_enddef (ncid)) + CALL nccheck( nf90_close (ncid)) + + END SUBROUTINE ncio_put_attr_str + + ! ---- + SUBROUTINE ncio_get_attr_str (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname + character(len=*), intent(out) :: attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_get_att (ncid, varid, trim(attrname), attrval)) + CALL nccheck( nf90_close (ncid)) + + END SUBROUTINE ncio_get_attr_str + + ! ---- + SUBROUTINE ncio_get_attr_real8 (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname + real(r8), intent(out) :: attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_get_att (ncid, varid, trim(attrname), attrval)) + CALL nccheck (nf90_close (ncid)) + + END SUBROUTINE ncio_get_attr_real8 + + ! ---- + SUBROUTINE ncio_put_attr_real8 (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname + real(r8), intent(in) :: attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_WRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_redef (ncid)) + CALL nccheck (nf90_put_att (ncid, varid, trim(attrname), attrval)) + CALL nccheck (nf90_enddef (ncid)) + CALL nccheck( nf90_close (ncid)) + + END SUBROUTINE ncio_put_attr_real8 + + + !--------------------------------------------------------- + SUBROUTINE ncio_inquire_varsize (filename, dataname, varsize) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: varsize(:) + + ! Local variables + integer :: ncid, varid, ndims, idm + integer, allocatable :: dimids(:) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + CALL nccheck( nf90_inquire_variable(ncid, varid, ndims = ndims) ) + allocate (dimids(ndims)) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids = dimids) ) + + allocate (varsize(ndims)) + DO idm = 1, ndims + CALL nccheck( nf90_inquire_dimension(ncid, dimids(idm), len = varsize(idm)) ) + ENDDO + + CALL nccheck( nf90_close(ncid) ) + deallocate (dimids) + + END SUBROUTINE ncio_inquire_varsize + + !--------------------------------------------------------- + logical FUNCTION ncio_var_exist (filename, dataname, readflag) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + logical, optional,intent(in) :: readflag + + ! Local variables + integer :: ncid, varid, status + logical :: readflag_ + + status = nf90_open(trim(filename), NF90_NOWRITE, ncid) + IF (status == nf90_noerr) THEN + status = nf90_inq_varid(ncid, trim(dataname), varid) + ncio_var_exist = (status == nf90_noerr) + CALL nccheck( nf90_close(ncid) ) + ELSE + ncio_var_exist = .false. + ENDIF + + IF (present(readflag)) THEN + readflag_ = readflag + ELSE + readflag_ = .true. + ENDIF + + IF ((.not. ncio_var_exist) .and. trim(filename) /= 'null' .and. readflag_) THEN + write(*,*) 'Warning: ', trim(dataname), ' not found in ', trim(filename) + ENDIF + + END FUNCTION ncio_var_exist + + !--------------------------------------------------------- + SUBROUTINE ncio_inquire_length (filename, dataname, length) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(out) :: length + + ! Local variables + integer :: ncid, varid, ndims + integer, allocatable :: dimids(:) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + CALL nccheck( nf90_inquire_variable(ncid, varid, ndims = ndims) ) + allocate (dimids(ndims)) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids = dimids) ) + CALL nccheck( nf90_inquire_dimension(ncid, dimids(ndims), len = length) ) + + CALL nccheck( nf90_close(ncid) ) + deallocate (dimids) + + END SUBROUTINE ncio_inquire_length + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_0d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(out) :: rdata + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_serial_int32_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_0d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(out) :: rdata + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_serial_real8_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int8_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int64_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer*8, allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int64_1d + + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_1d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int8_2d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int16_2d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(2), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int16_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_2d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + integer :: dsp, nread + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + IF ((varsize(1) > 1000) .and. (varsize(2) > 100000)) THEN + dsp = 0 + DO WHILE (dsp < varsize(2)) + nread = min(100000,varsize(2)-dsp) + CALL nccheck (nf90_get_var(ncid, varid, & + rdata(1:varsize(1),dsp+1:dsp+nread), (/1,dsp+1/), (/varsize(1),nread/))) + dsp = dsp + nread + ENDDO + ELSE + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real4_2d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(4), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real4_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_2d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + integer :: dsp, nread + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + IF ((varsize(1) > 1000) .and. (varsize(2) > 100000)) THEN + dsp = 0 + DO WHILE (dsp < varsize(2)) + nread = min(100000,varsize(2)-dsp) + CALL nccheck (nf90_get_var(ncid, varid, & + rdata(1:varsize(1),dsp+1:dsp+nread), (/1,dsp+1/), (/varsize(1),nread/))) + dsp = dsp + nread + ENDDO + ELSE + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_3d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int32_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_3d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_4d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3), varsize(4)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_5d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3), varsize(4), varsize(5)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_5d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_int32_0d (filename, dataname, rdata) + + USE netcdf + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(out) :: rdata + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_int32_0d (filename, dataname, rdata) + ENDIF + CALL mpi_bcast (rdata, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_int32_0d (filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_int32_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_0d (filename, dataname, rdata) + + USE MOD_SPMD_Task + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(out) :: rdata + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_real8_0d (filename, dataname, rdata) + ENDIF + CALL mpi_bcast (rdata, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_real8_0d (filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_int32_1d (filename, dataname, rdata) + + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:) + integer :: vlen + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_int32_1d(filename, dataname, rdata) + vlen = size(rdata) + ENDIF + CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_int32_1d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_int32_2d (filename, dataname, rdata) + + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:,:) + integer :: vsize(2) + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_int32_2d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vsize(1), vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_int32_2d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_1d (filename, dataname, rdata) + + USE netcdf + USE MOD_SPMD_Task + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:) + integer :: vlen + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_real8_1d(filename, dataname, rdata) + vlen = size(rdata) + ENDIF + CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_REAL8, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_real8_1d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_2d (filename, dataname, rdata) + + USE netcdf + USE MOD_SPMD_Task + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:) + integer :: vsize(2) + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_real8_2d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_real8_2d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_3d (filename, dataname, rdata) + + USE netcdf + USE MOD_SPMD_Task + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:) + integer :: vsize(3) + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_real8_3d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 3, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2),vsize(3))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_real8_3d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_4d (filename, dataname, rdata) + + USE netcdf + USE MOD_SPMD_Task + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:) + integer :: vsize(4) + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_real8_4d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 4, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4), MPI_REAL8, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_real8_4d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_5d (filename, dataname, rdata) + + USE netcdf + USE MOD_SPMD_Task + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:,:) + integer :: vsize(5) + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_real8_5d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 5, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4),vsize(5))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4)*vsize(5), MPI_REAL8, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_real8_5d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_5d + + ! ------------------------------- + SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) + + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + logical, allocatable, intent(out) :: rdata (:) + integer :: vlen + integer(1), allocatable :: rdata_byte(:) + +#ifdef USEMPI + IF (p_is_master) THEN + CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) + vlen = size(rdata_byte) + + allocate(rdata(vlen)) + rdata = (rdata_byte == 1) + + deallocate (rdata_byte) + ENDIF + CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_master) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) +#else + CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) + vlen = size(rdata_byte) + + allocate(rdata(vlen)) + rdata = (rdata_byte == 1) + + deallocate (rdata_byte) +#endif + + END SUBROUTINE ncio_read_bcast_serial_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_part_serial_int32_1d (filename, dataname, datastt, dataend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: datastt, dataend + integer, allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + allocate (rdata (datastt:dataend) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/datastt/), (/dataend-datastt+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_part_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_part_serial_int32_2d (filename, dataname, datastt, dataend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: datastt(2), dataend(2) + integer, allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + allocate (rdata (datastt(1):dataend(1), datastt(2):dataend(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/datastt(1),datastt(2)/), (/dataend(1)-datastt(1)+1, dataend(2)-datastt(2)+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_part_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_part_serial_real8_2d (filename, dataname, datastt, dataend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: datastt(2), dataend(2) + real(r8), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + allocate (rdata (datastt(1):dataend(1), datastt(2):dataend(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/datastt(1),datastt(2)/), (/dataend(1)-datastt(1)+1, dataend(2)-datastt(2)+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_part_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_int32_1d (filename, dataname, index, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + integer, allocatable, intent(out) :: rdata(:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + + nidx = size(index) + allocate (rdata(nidx)) + IF (nidx == 0) RETURN + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(istart:iend), & + start=(/index(istart)/), count=(/nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_indexed_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_real8_1d (filename, dataname, index, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + real(r8), allocatable, intent(out) :: rdata(:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + + nidx = size(index) + allocate (rdata(nidx)) + IF (nidx == 0) RETURN + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(istart:iend), & + start=(/index(istart)/), count=(/nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_indexed_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_int32_2d (filename, dataname, index, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + integer, allocatable, intent(out) :: rdata(:,:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + integer, allocatable :: varsize(:) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + nidx = size(index) + IF (size(varsize) /= 2) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + allocate (rdata(varsize(1), nidx)) + IF (nidx == 0) THEN + deallocate (varsize) + RETURN + ENDIF + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(:,istart:iend), & + start=(/1,index(istart)/), count=(/varsize(1),nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + deallocate (varsize) + + END SUBROUTINE ncio_read_indexed_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_real8_2d (filename, dataname, index, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + real(r8), allocatable, intent(out) :: rdata(:,:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + integer, allocatable :: varsize(:) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + nidx = size(index) + IF (size(varsize) /= 2) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + allocate (rdata(varsize(1), nidx)) + IF (nidx == 0) THEN + deallocate (varsize) + RETURN + ENDIF + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(:,istart:iend), & + start=(/1,index(istart)/), count=(/varsize(1),nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + deallocate (varsize) + + END SUBROUTINE ncio_read_indexed_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_period_serial_real8_2d (filename, dataname, timestt, timeend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: timestt, timeend + + real(r8), allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize (filename, dataname, varsize) + + allocate (rdata (varsize(1), varsize(2), timestt:timeend) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/1,1,timestt/), (/varsize(1),varsize(2), timeend-timestt+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate(varsize) + + END SUBROUTINE ncio_read_period_serial_real8_2d + + ! ------------------------------- + SUBROUTINE ncio_define_dimension_int32 (filename, dimname, dimlen) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimlen + + ! Local variables + integer :: ncid, dimid, status + integer :: varid + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + + status = nf90_inq_dimid(ncid, trim(dimname), dimid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + IF (dimlen == 0) THEN + CALL nccheck( nf90_def_dim(ncid, trim(dimname), NF90_UNLIMITED, dimid) ) + ELSE + CALL nccheck( nf90_def_dim(ncid, trim(dimname), dimlen, dimid) ) + ENDIF + IF (trim(dimname) .eq. 'lon') THEN + !print *, 'lon-def' + CALL nccheck( nf90_def_var(ncid, 'lon', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) + ELSEIF (trim(dimname) .eq.'lat') THEN + !print *, 'lat-def' + CALL nccheck( nf90_def_var(ncid, 'lat', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) + ELSEIF (trim(dimname) .eq.'lat_cama') THEN + !print *, 'lat-def' + CALL nccheck( nf90_def_var(ncid, 'lat_cama', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) + ELSEIF (trim(dimname) .eq.'lon_cama') THEN + CALL nccheck( nf90_def_var(ncid, 'lon_cama', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) + ENDIF + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_define_dimension_int32 + + ! ------------------------------- + SUBROUTINE ncio_define_dimension_int64 (filename, dimname, dimlen) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dimname + integer*8, intent(in) :: dimlen + + ! Local variables + integer :: ncid, dimid, status + integer :: varid + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + + status = nf90_inq_dimid(ncid, trim(dimname), dimid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + IF (dimlen == 0) THEN + CALL nccheck( nf90_def_dim(ncid, trim(dimname), NF90_UNLIMITED, dimid) ) + ELSE + CALL nccheck( nf90_def_dim(ncid, trim(dimname), int(dimlen), dimid) ) + ENDIF + IF (trim(dimname) .eq. 'lon') THEN + !print *, 'lon-def' + CALL nccheck( nf90_def_var(ncid, 'lon', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) + ELSEIF (trim(dimname) .eq.'lat') THEN + !print *, 'lat-def' + CALL nccheck( nf90_def_var(ncid, 'lat', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) + ELSEIF (trim(dimname) .eq.'lat_cama') THEN + !print *, 'lat-def' + CALL nccheck( nf90_def_var(ncid, 'lat_cama', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) + ELSEIF (trim(dimname) .eq.'lon_cama') THEN + CALL nccheck( nf90_def_var(ncid, 'lon_cama', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) + + ENDIF + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_define_dimension_int64 + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_0d (filename, dataname, wdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata + + ! Local variables + integer :: ncid, varid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, varid = varid)) + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_0d (filename, dataname, wdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata + + ! Local variables + integer :: ncid, varid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, varid = varid)) + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int8_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int64_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer*8, intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_logical_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + logical, intent(in) :: wdata (:) + + character(len=*), intent(in) :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer(1), allocatable :: wdata_byte(:) + + allocate(wdata_byte(size(wdata))) + WHERE(wdata) + wdata_byte = 1 + ELSEWHERE + wdata_byte = 0 + ENDWHERE + + IF (present(compress)) THEN + CALL ncio_write_serial_int8_1d (filename, dataname, wdata_byte, dimname, compress) + ELSE + CALL ncio_write_serial_int8_1d (filename, dataname, wdata_byte, dimname) + ENDIF + + deallocate(wdata_byte) + + END SUBROUTINE ncio_write_serial_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int8_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int16_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(2), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_SHORT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_SHORT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int16_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int64_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer*8, intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int64_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real4_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(4), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_FLOAT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_FLOAT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real4_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_3d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata (:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(3), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_3d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(3), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_4d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, dim4name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name, dim4name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(4), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) & + .and. present(dim3name) .and. present(dim4name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_5d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:,:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + character(len=*), intent(in), optional :: dim4name, dim5name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(5), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name) & + .and. present(dim4name) .and. present(dim5name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim5name), dimid(5))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_5d + + !------------------------------ + SUBROUTINE ncio_write_time (filename, dataname, time_component, itime, adjust) + + USE MOD_TimeManager + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: time_component(3) + integer, intent(out) :: itime + + character(len=*), intent(in), optional :: adjust + + ! Local variables + integer, allocatable :: time_file(:) + integer :: ncid, varid, time_id, status + integer :: timelen, minutes + + minutes = minutes_since_1900 (time_component(1), time_component(2), time_component(3)) + + IF (present(adjust)) THEN + SELECTCASE (trim(adjustl(adjust))) + CASE ('HOURLY') + minutes = minutes - 30 + CASE ('DAILY') + minutes = minutes - 720 + CASE ('MONTHLY') + minutes = minutes - 21600 + CASE ('YEARLY') + minutes = minutes - 262800 + ENDSELECT + ENDIF + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status == NF90_NOERR) THEN + CALL nccheck( nf90_inq_dimid(ncid, 'time', time_id) ) + CALL nccheck( nf90_inquire_dimension(ncid, time_id, len = timelen) ) + + itime = 1 + IF (timelen > 0) THEN + allocate (time_file (timelen)) + CALL nccheck( nf90_get_var(ncid, varid, time_file) ) + + DO WHILE (itime <= timelen) + IF (minutes == time_file(itime)) EXIT + itime = itime + 1 + ENDDO + + deallocate(time_file) + ENDIF + + ELSE + status = nf90_inq_dimid(ncid, 'time', time_id) + IF (status /= NF90_NOERR) THEN + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_dim(ncid, 'time', NF90_UNLIMITED, time_id) ) + CALL nccheck( nf90_enddef(ncid) ) + ENDIF + + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_var(ncid, trim(dataname), NF90_INT, (/time_id/), varid) ) + + CALL nccheck( nf90_put_att(ncid, varid, 'long_name', 'time') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units', 'minutes since 1900-1-1 0:0:0') ) + CALL nccheck( nf90_enddef(ncid) ) + + itime = 1 + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, minutes, (/itime/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_time + + !------------------------------ + SUBROUTINE ncio_write_lastdim (filename, lastname, lastvalue, ilast) + + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: lastname + integer, intent(in) :: lastvalue + integer, intent(out) :: ilast + + ! Local variables + integer :: ncid, varid, dimid, dimlen, status + integer, allocatable :: lastvalue_f(:) + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + + status = nf90_inq_varid(ncid, trim(lastname), varid) + + IF (status == NF90_NOERR) THEN + CALL nccheck( nf90_inq_dimid(ncid, trim(lastname), dimid) ) + CALL nccheck( nf90_inquire_dimension(ncid, dimid, len = dimlen) ) + + ilast = 1 + IF (dimlen > 0) THEN + allocate (lastvalue_f (dimlen)) + CALL nccheck( nf90_get_var(ncid, varid, lastvalue_f) ) + + DO WHILE (ilast <= dimlen) + IF (lastvalue == lastvalue_f(ilast)) EXIT + ilast = ilast + 1 + ENDDO + + deallocate(lastvalue_f) + ENDIF + ELSE + status = nf90_inq_dimid(ncid, trim(lastname), dimid) + IF (status /= NF90_NOERR) THEN + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_dim(ncid, trim(lastname), NF90_UNLIMITED, dimid) ) + CALL nccheck( nf90_enddef(ncid) ) + ENDIF + + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_var(ncid, trim(lastname), NF90_INT, (/dimid/), varid) ) + CALL nccheck( nf90_enddef(ncid) ) + + ilast = 1 + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, lastvalue, (/ilast/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_lastdim + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_0d_time ( & + filename, dataname, itime, wdata, dim1name) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata + + character(len=*), intent(in), optional :: dim1name + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dim1name)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid)) + + CALL nccheck (nf90_redef(ncid)) + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, start = (/itime/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_0d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_1d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,itime/), (/size(wdata,1),1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_1d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_2d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, dim3name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(3), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,1,itime/), (/size(wdata,1),size(wdata,2),1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_2d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_3d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, dim3name, dim4name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name, dim4name + integer, intent(in), optional :: compress + ! Local variables + integer :: ncid, varid, dimid(4), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) & + .and. present(dim3name) .and. present(dim4name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,1,1,itime/), (/size(wdata,1),size(wdata,2),size(wdata,3),1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_3d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_4d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:,:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + character(len=*), intent(in), optional :: dim4name, dim5name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(5), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) & + .and. present(dim3name) .and. present(dim4name) .and. present(dim5name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim5name), dimid(5))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,1,1,1,itime/), (/size(wdata,1),size(wdata,2),size(wdata,3),size(wdata,4), 1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_4d_time + + !---------------------- + SUBROUTINE ncio_write_colm_dimension (filename) + + USE MOD_Vars_Global, only: nl_soil, maxsnl, nl_lake, nvegwcs + IMPLICIT NONE + + character(len=*), intent(in) :: filename + + ! Local Variables + integer :: soillayers(1:nl_soil) + integer :: soilinterfaces(0:nl_soil) + integer :: soilsnowlayers(-maxsnl+nl_soil) + integer :: lakelayers(1:nl_lake) + integer :: vegnodes(1:nvegwcs) + integer :: i + + + soillayers = (/(i, i = 1,nl_soil)/) + CALL ncio_define_dimension (filename, 'soil', nl_soil) + CALL ncio_write_serial (filename, 'soil', soillayers, 'soil') + CALL ncio_put_attr_str (filename, 'soil', 'long_name', 'soil layers') + + soilinterfaces = (/(i, i = 0,nl_soil)/) + CALL ncio_define_dimension (filename, 'soilinterface', nl_soil+1) + CALL ncio_write_serial (filename, 'soilinterface', soilinterfaces, 'soilinterface') + CALL ncio_put_attr_str (filename, 'soilinterface', 'long_name', 'soil layer interfaces') + + soilsnowlayers = (/(i, i = maxsnl+1,nl_soil)/) + CALL ncio_define_dimension (filename, 'soilsnow', -maxsnl+nl_soil) + CALL ncio_write_serial (filename, 'soilsnow', soilsnowlayers, 'soilsnow') + CALL ncio_put_attr_str (filename, 'soilsnow', 'long_name', 'snow(<= 0) and soil(>0) layers') + + lakelayers = (/(i, i = 1,nl_lake)/) + CALL ncio_define_dimension (filename, 'lake', nl_lake) + CALL ncio_write_serial (filename, 'lake', lakelayers, 'lake') + CALL ncio_put_attr_str (filename, 'lake', 'long_name', 'vertical lake layers') + + vegnodes = (/(i, i = 1,nvegwcs)/) + CALL ncio_define_dimension (filename, 'vegnodes', nvegwcs) + CALL ncio_write_serial (filename, 'vegnodes', vegnodes, 'vegnodes') + CALL ncio_put_attr_str (filename, 'vegnodes', 'long_name', 'vegetation water potential nodes') + + CALL ncio_define_dimension (filename, 'band', 2) + CALL ncio_write_serial (filename, 'band', (/1,2/), 'band') + CALL ncio_put_attr_str (filename, 'band', 'long_name', '1 = visible; 2 = near-infrared') + + CALL ncio_define_dimension (filename, 'rtyp', 2) + CALL ncio_write_serial (filename, 'rtyp', (/1,2/), 'rtyp') + CALL ncio_put_attr_str (filename, 'rtyp', 'long_name', '1 = direct; 2 = diffuse') + + END SUBROUTINE ncio_write_colm_dimension + +END MODULE MOD_NetCDFSerial diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 new file mode 100644 index 0000000000..32653d4d2f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -0,0 +1,1996 @@ +#include + +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) +#define COLM_VECTOR_MPI_IO +#endif + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! +! CoLM read and write netCDF files mainly in three ways: +! 1. Serial: read and write data by a single process; +! 2. Vector: 1) read vector data by IO and scatter from IO to workers +! 2) gather from workers to IO and write vectors by IO +! 3. Block : read blocked data by IO +! Notice: input file is a single file. +! +! This MODULE CONTAINS subroutines of "2. Vector". +! +! Two implementations can be used, +! 1) "MOD_NetCDFVectorBlk.F90": +! A vector is saved in separated files, each associated with a block. +! READ/WRITE are fast in this way and compression can be used. +! However, there may be too many files, especially when blocks are small. +! CHOOSE this implementation by "#undef VectorInOneFile" in include/define.h +! 2) "MOD_NetCDFVectorOne.F90": +! A vector is saved in one file. +! READ/WRITE may be slow in this way. +! CHOOSE this implementation by "#define VectorInOneFile" in include/define.h +! +! Created by Shupeng Zhang, May 2023 +!---------------------------------------------------------------------------------- + +MODULE MOD_NetCDFVector + + + USE MOD_DataType + IMPLICIT NONE + + ! PUBLIC subroutines + + INTERFACE ncio_read_vector + MODULE procedure ncio_read_vector_logical_1d + MODULE procedure ncio_read_vector_int32_1d + MODULE procedure ncio_read_vector_int64_1d + MODULE procedure ncio_read_vector_real8_1d + MODULE procedure ncio_read_vector_real8_2d + MODULE procedure ncio_read_vector_real8_3d + MODULE procedure ncio_read_vector_real8_4d + MODULE procedure ncio_read_vector_real8_5d + END INTERFACE ncio_read_vector + + PUBLIC :: ncio_create_file_vector + PUBLIC :: ncio_define_dimension_vector + + INTERFACE ncio_write_vector + MODULE procedure ncio_write_vector_logical_1d + MODULE procedure ncio_write_vector_int32_1d + MODULE procedure ncio_write_vector_int32_3d + MODULE procedure ncio_write_vector_int64_1d + MODULE procedure ncio_write_vector_real8_1d + MODULE procedure ncio_write_vector_real8_2d + MODULE procedure ncio_write_vector_real8_3d + MODULE procedure ncio_write_vector_real8_4d + MODULE procedure ncio_write_vector_real8_5d + END INTERFACE ncio_write_vector + +CONTAINS + + !--------------------------------------------------------- + SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write, use_srcpos) + + USE MOD_Block, only: get_filename_block +#ifdef MPAS_EMBEDDED_COLM + USE MOD_SPMD_Task, only: p_iam_glb +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + integer, intent(in) :: iblk, jblk + character(len=*), intent(out) :: fileblock + logical, intent(in), optional :: for_write + logical, intent(inout), optional :: use_srcpos + +#ifdef MPAS_EMBEDDED_COLM + character(len=256) :: fileblock_rank + character(len=32) :: rank_suffix + integer :: idot +#endif + + CALL get_filename_block (filename, iblk, jblk, fileblock) + +#ifdef MPAS_EMBEDDED_COLM + write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb + idot = len_trim(fileblock) + DO WHILE (idot > 0) + IF (fileblock(idot:idot) == '.') EXIT + idot = idot - 1 + ENDDO + + IF (idot > 0) THEN + fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) + ELSE + fileblock_rank = trim(fileblock) // trim(rank_suffix) + ENDIF + + fileblock = fileblock_rank + IF (present(use_srcpos)) use_srcpos = .false. +#endif + + END SUBROUTINE get_filename_vector_block + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int32_1d ( & + filename, dataname, pixelset, rdata, defval) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + integer, allocatable, intent(inout) :: rdata (:) + integer, intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + integer, allocatable :: sbuff(:), rbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & + MPI_IN_PLACE, 0, MPI_INTEGER, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(iset) = sbuff(pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int64_1d ( & + filename, dataname, pixelset, rdata, defval) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + integer*8, allocatable, intent(inout) :: rdata (:) + integer, intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + integer*8, allocatable :: sbuff(:), rbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & + MPI_IN_PLACE, 0, MPI_INTEGER8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(iset) = sbuff(pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & + defval) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + logical, allocatable, intent(inout) :: rdata (:) + logical, intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + integer(1), allocatable :: sbuff(:), rbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + IF (defval) THEN + sbuff(:) = 1 + ELSE + sbuff(:) = 0 + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, & + MPI_IN_PLACE, 0, MPI_INTEGER1, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(iset) = (sbuff(pixelset%srcpos(iset)) == 1) + ENDDO + ELSE + rdata(istt:iend) = (sbuff == 1) + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = (rbuff == 1) + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & + defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:), rbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(iset) = sbuff(pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_2d ( & + filename, dataname, ndim1, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:), rbuff(:,:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(:,iset) = sbuff(:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_3d ( & + filename, dataname, ndim1, ndim2, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1, ndim2 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(:,:,iset) = sbuff(:,:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,:,istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_4d ( & + filename, dataname, ndim1, ndim2, ndim3, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1, ndim2, ndim3 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:,:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2,ndim3, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(:,:,:,iset) = sbuff(:,:,:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,:,:,istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1,1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_4d + + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_5d ( & + filename, dataname, ndim1, ndim2, ndim3, ndim4, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1, ndim2, ndim3, ndim4 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:,:,:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2,ndim3,ndim4, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk))) + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) + + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:,:) = defval + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_scatterv ( & + sbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (use_srcpos .and. block_has_data) THEN + DO iset = istt, iend + rdata(:,:,:,:,iset) = sbuff(:,:,:,:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,:,:,:,istt:iend) = sbuff + ENDIF +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1,1,1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,:,:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_5d + + + !--------------------------------------------------------- + SUBROUTINE ncio_create_file_vector (filename, pixelset) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + integer :: iblkgrp, iblk, jblk + character(len=256) :: fileblock + + IF (p_is_io) THEN + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + CALL ncio_create_file (fileblock) + + ENDDO + ENDIF + + END SUBROUTINE ncio_create_file_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + type(pixelset_type), intent(in) :: pixelset + character(len=*), intent(in) :: dimname + integer, intent(in), optional :: dimlen + + ! Local variables + integer :: iblkgrp, iblk, jblk + character(len=256) :: fileblock + logical :: fexists + + IF (p_is_io) THEN + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + inquire (file=trim(fileblock), exist=fexists) + IF (.not. fexists) THEN + CALL ncio_create_file (fileblock) + ENDIF + + IF (present(dimlen)) THEN + CALL ncio_define_dimension (fileblock, trim(dimname), dimlen) + ELSE + CALL ncio_define_dimension (fileblock, trim(dimname), & + pixelset%vecgs%vlen(iblk,jblk)) + ENDIF + + ENDDO + ENDIF + + END SUBROUTINE ncio_define_dimension_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int32_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + integer, allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_logical_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + logical, intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, i + character(len=256) :: fileblock + integer(1), allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER1, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + DO i = istt, iend + IF(wdata(i))THEN + rbuff(i-istt+1) = 1 + ELSE + rbuff(i-istt+1) = 0 + ENDIF + ENDDO +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + DO i = istt, iend + IF(wdata(i))THEN + sbuff(i-istt+1) = 1 + ELSE + sbuff(i-istt+1) = 0 + ENDIF + ENDDO + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int32_3d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + dim3name, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: ndim1, ndim2 + integer, intent(in) :: wdata (:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + integer, allocatable :: sbuff(:,:,:), rbuff(:,:,:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & + rbuff, ndim1*ndim2*pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1*ndim2*pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,:,istt:iend) + ELSE + allocate (sbuff (1,1,1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, ndim1*ndim2*pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_int32_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int64_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + integer*8, intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + integer*8, allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + real(r8), intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv ( MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dimname, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_2d ( & + filename, dataname, dim1name, ndim1, & + dim2name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name + integer, intent(in) :: ndim1 + type(pixelset_type), intent(in) :: pixelset + real(r8), intent(in) :: wdata (:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:), rbuff(:,:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,istt:iend) + ELSE + allocate (sbuff (1,1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_3d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + dim3name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: ndim1, ndim2 + real(r8), intent(in) :: wdata (:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,:,istt:iend) + ELSE + allocate (sbuff (1,1,1)) + ENDIF + + CALL mpi_gatherv ( sbuff, & + ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_4d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, dim3name, ndim3, & + dim4name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name + integer, intent(in) :: ndim1, ndim2, ndim3 + type(pixelset_type), intent(in) :: pixelset + real(r8), intent(in) :: wdata (:,:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, ndim3, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,:,istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,ndim2,ndim3,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,:,:,istt:iend) + ELSE + allocate (sbuff (1,1,1,1)) + ENDIF + + CALL mpi_gatherv ( sbuff, & + ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_4d + + + !------------------------------------------------ + SUBROUTINE ncio_write_vector_real8_5d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + dim3name, ndim3, dim4name, ndim4, dim5name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name, dim5name + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: ndim1, ndim2, ndim3, ndim4 + real(r8), intent(in) :: wdata (:,:,:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, ndim3, ndim4, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,:,:,istt:iend) +#endif + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name, dim5name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,ndim2,ndim3,ndim4,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,:,:,:,istt:iend) + ELSE + allocate (sbuff (1,1,1,1,1)) + ENDIF + + CALL mpi_gatherv ( sbuff, & + ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_5d + !------------------------------------------------ + + LOGICAL FUNCTION ncio_vector_report_missing(mandatory) + + USE MOD_SPMD_Task, only: p_iam_io, p_root + IMPLICIT NONE + + logical, intent(in) :: mandatory + +#ifdef MPAS_EMBEDDED_COLM + ncio_vector_report_missing = mandatory .or. (p_iam_io == p_root) +#else + ncio_vector_report_missing = (p_iam_io == p_root) +#endif + + END FUNCTION ncio_vector_report_missing + + +END MODULE MOD_NetCDFVector diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 new file mode 100644 index 0000000000..cf18c44ce0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 @@ -0,0 +1,418 @@ +#include + +MODULE MOD_Pixel + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! +! Pixels are rasterized points defined by fine-resolution data. +! +! CoLM USE multiple grids to construct pixels. Grids are assimilated into pixel +! coordinate one by one. One grid is assimilated by adding grid lines not present +! in pixel coordinate. In other words, pixel coordinate is the union of all grids. +! +! Pixels are used to carry out land surface tessellation. The grids used to +! construct pixels are associated with surface data such as land cover types, soil +! parameters, plant function types, leaf area index and forest height. +! By using pixels, these variables are downscaled to fine resolution. +! +! In pixel data type, region boundaries and each pixel boundaries are defined. +! Subroutines to assimilate grid and map pixel to grid are defined as methods. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------ + + USE MOD_Precision + IMPLICIT NONE + + ! ---- data types ---- + type :: pixel_type + + real(r8) :: edges ! southern edge (degrees) + real(r8) :: edgen ! northern edge (degrees) + real(r8) :: edgew ! western edge (degrees) + real(r8) :: edgee ! eastern edge (degrees) + + integer :: nlon, nlat + real(r8), allocatable :: lat_s (:) + real(r8), allocatable :: lat_n (:) + real(r8), allocatable :: lon_w (:) + real(r8), allocatable :: lon_e (:) + + CONTAINS + procedure, PUBLIC :: set_edges => pixel_set_edges + + procedure, PRIVATE :: assimilate_latlon => pixel_assimilate_latlon + procedure, PUBLIC :: assimilate_gblock => pixel_assimilate_gblock + procedure, PUBLIC :: assimilate_grid => pixel_assimilate_grid + + procedure, PUBLIC :: map_to_grid => pixel_map_to_grid + + procedure, PUBLIC :: save_to_file => pixel_save_to_file + procedure, PUBLIC :: load_from_file => pixel_load_from_file + + final :: pixel_free_mem + + END type pixel_type + + ! ---- Instance ---- + type(pixel_type) :: pixel + +CONTAINS + + ! -------------------------------- + SUBROUTINE pixel_set_edges (this, & + edges_in, edgen_in, edgew_in, edgee_in) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Utils + IMPLICIT NONE + + class(pixel_type) :: this + + real(r8), intent(in) :: edges_in, edgen_in + real(r8), intent(in) :: edgew_in, edgee_in + + this%nlon = 1 + this%nlat = 1 + + this%edges = edges_in + this%edgen = edgen_in + this%edgew = edgew_in + this%edgee = edgee_in + + CALL normalize_longitude (this%edgew) + CALL normalize_longitude (this%edgee) + + allocate (this%lat_s (1)) + allocate (this%lat_n (1)) + allocate (this%lon_w (1)) + allocate (this%lon_e (1)) + + this%lat_s(1) = this%edges + this%lat_n(1) = this%edgen + this%lon_w(1) = this%edgew + this%lon_e(1) = this%edgee + + IF (p_is_master) THEN + write(*,'(A)') '----- Region information -----' + write(*,'(A,F10.4,A,F10.4,A,F10.4,A,F10.4,A)') ' (south,north,west,east) = (', & + this%edges, ',', this%edgen, ',', this%edgew, ',', this%edgee, ')' + ENDIF + + END SUBROUTINE pixel_set_edges + + ! -------------------------------- + SUBROUTINE pixel_assimilate_latlon (this, & + nlat, lat_s, lat_n, nlon, lon_w, lon_e) + + USE MOD_Precision + USE MOD_Utils + IMPLICIT NONE + class(pixel_type) :: this + + integer, intent(in) :: nlat + real(r8), intent(in) :: lat_s(nlat), lat_n(nlat) + integer, intent(in) :: nlon + real(r8), intent(in) :: lon_w(nlon), lon_e(nlon) + + ! Local variables + real(r8) :: south, north, west, east + + integer :: ny, yinc + integer :: iy1, iy2, ys2, yn2 + real(r8), allocatable :: ytmp(:) + + integer :: nx, nlonc + integer :: ix1, ix2, xw2 + real(r8), allocatable :: xtmp(:), loncirc(:) + + IF (lat_s(1) <= lat_s(nlat)) THEN + yinc = 1 + south = lat_s(1) + north = lat_n(nlat) + ELSE + yinc = -1 + south = lat_s(nlat) + north = lat_n(1) + ENDIF + + allocate (ytmp (this%nlat+nlat+2)) + + ny = 0 + DO iy1 = 1, this%nlat + + ny = ny + 1 + ytmp(ny) = this%lat_s(iy1) + + IF ((this%lat_s(iy1) < north) .and. (this%lat_n(iy1) > south)) THEN + ys2 = find_nearest_south (this%lat_s(iy1), nlat, lat_s) + yn2 = find_nearest_north (this%lat_n(iy1), nlat, lat_n) + DO iy2 = ys2, yn2, yinc + IF (lat_s(iy2) > this%lat_s(iy1)) THEN + ny = ny + 1 + ytmp(ny) = lat_s(iy2) + ENDIF + ENDDO + IF (lat_n(yn2) < this%lat_n(iy1)) THEN + ny = ny + 1 + ytmp(ny) = lat_n(yn2) + ENDIF + ENDIF + ENDDO + + ny = ny + 1 + ytmp(ny) = this%lat_n(this%nlat) + + deallocate (this%lat_s) + deallocate (this%lat_n) + + this%nlat = ny - 1 + allocate (this%lat_s (this%nlat)) + allocate (this%lat_n (this%nlat)) + + this%lat_s = ytmp(1:ny-1) + this%lat_n = ytmp(2:ny) + + deallocate (ytmp) + + west = lon_w(1) + east = lon_e(nlon) + + IF (west == east) THEN + nlonc = nlon + allocate (loncirc (nlonc)) + loncirc = lon_w + ELSE + nlonc = nlon + 1 + allocate (loncirc (nlonc)) + loncirc(1:nlon) = lon_w + loncirc(nlon+1) = east + ENDIF + + allocate (xtmp (this%nlon+nlon+2)) + nx = 0 + DO ix1 = 1, this%nlon + + nx = nx + 1 + xtmp(nx) = this%lon_w(ix1) + + xw2 = find_nearest_west (this%lon_w(ix1), nlonc, loncirc) + ix2 = mod(xw2,nlonc) + 1 + DO WHILE (.true.) + IF (lon_between_floor(loncirc(ix2), this%lon_w(ix1), this%lon_e(ix1))) THEN + IF (loncirc(ix2) /= this%lon_w(ix1)) THEN + nx = nx + 1 + xtmp(nx) = loncirc(ix2) + ENDIF + + IF (ix2 /= xw2) THEN + ix2 = mod(ix2,nlonc) + 1 + ELSE + EXIT + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + ENDDO + + nx = nx + 1 + xtmp(nx) = this%lon_e(this%nlon) + + deallocate (this%lon_w) + deallocate (this%lon_e) + + this%nlon = nx - 1 + allocate (this%lon_w (this%nlon)) + allocate (this%lon_e (this%nlon)) + + this%lon_w = xtmp(1:nx-1) + this%lon_e = xtmp(2:nx) + + deallocate (xtmp) + + END SUBROUTINE pixel_assimilate_latlon + + ! -------------------------------- + SUBROUTINE pixel_assimilate_gblock (this) + + USE MOD_Block, only: gblock + IMPLICIT NONE + class(pixel_type) :: this + + CALL this%assimilate_latlon ( & + gblock%nyblk, gblock%lat_s, gblock%lat_n, & + gblock%nxblk, gblock%lon_w, gblock%lon_e) + + END SUBROUTINE pixel_assimilate_gblock + + ! -------------------------------- + SUBROUTINE pixel_assimilate_grid (this, grid) + + USE MOD_Grid + IMPLICIT NONE + class(pixel_type) :: this + + type(grid_type), intent(in) :: grid + + CALL this%assimilate_latlon ( & + grid%nlat, grid%lat_s, grid%lat_n, & + grid%nlon, grid%lon_w, grid%lon_e) + + END SUBROUTINE pixel_assimilate_grid + + ! -------------------------------- + SUBROUTINE pixel_map_to_grid (this, grd) + + USE MOD_Grid + USE MOD_Utils + IMPLICIT NONE + class(pixel_type) :: this + + type(grid_type), intent(inout) :: grd + + ! Local variables + integer :: iy1, iy2, ix1, ix2 + real(r8) :: south, north, west, east + + IF (allocated (grd%xgrd)) deallocate (grd%xgrd) + IF (allocated (grd%ygrd)) deallocate (grd%ygrd) + + allocate (grd%ygrd (this%nlat)) + + IF (grd%yinc == 1) THEN + south = grd%lat_s(1) + north = grd%lat_n(grd%nlat) + ELSE + south = grd%lat_s(grd%nlat) + north = grd%lat_n(1) + ENDIF + + iy1 = 1 + DO WHILE (.true.) + IF ((this%lat_s(iy1) < north) .and. (this%lat_n(iy1) > south)) THEN + iy2 = find_nearest_south (this%lat_s(iy1), grd%nlat, grd%lat_s) + DO WHILE (this%lat_n(iy1) <= grd%lat_n(iy2)) + grd%ygrd(iy1) = iy2 + iy1 = iy1 + 1 + IF (iy1 > this%nlat) EXIT + ENDDO + ELSE + write(*,*) 'Warning: grid in latitude does not cover simulation region completely.', & + south, north, this%lat_s(iy1), this%lat_n(iy1) + grd%ygrd(iy1) = -1 + iy1 = iy1 + 1 + ENDIF + IF (iy1 > this%nlat) EXIT + ENDDO + + allocate (grd%xgrd (this%nlon)) + + west = grd%lon_w(1) + east = grd%lon_e(grd%nlon) + + ix1 = 1 + DO WHILE (.true.) + IF ( lon_between_floor(this%lon_w(ix1), west, east) & + .or. lon_between_ceil (this%lon_e(ix1), west, east) ) THEN + + ix2 = find_nearest_west (this%lon_w(ix1), grd%nlon, grd%lon_w) + DO WHILE (lon_between_ceil(this%lon_e(ix1), grd%lon_w(ix2), grd%lon_e(ix2))) + grd%xgrd(ix1) = ix2 + ix1 = ix1 + 1 + IF (ix1 > this%nlon) EXIT + ENDDO + + ELSE + write(*,*) 'Warning: grid in longitude does not cover simulation region completely.', & + west, east, this%lon_w(ix1), this%lon_e(ix1) + grd%xgrd(ix1) = -1 + ix1 = ix1 + 1 + ENDIF + IF (ix1 > this%nlon) EXIT + ENDDO + + END SUBROUTINE pixel_map_to_grid + + ! -------------------------------- + SUBROUTINE pixel_save_to_file (this, dir_landdata) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + IMPLICIT NONE + class(pixel_type) :: this + + character(len=*), intent(in) :: dir_landdata + + ! Local variables + character(len=256) :: filename + + IF (p_is_master) THEN + + filename = trim(dir_landdata) // '/pixel.nc' + + CALL ncio_create_file (filename) + + CALL ncio_write_serial (filename, 'edges', this%edges) + CALL ncio_write_serial (filename, 'edgen', this%edgen) + CALL ncio_write_serial (filename, 'edgew', this%edgew) + CALL ncio_write_serial (filename, 'edgee', this%edgee) + + CALL ncio_define_dimension (filename, 'latitude', this%nlat) + CALL ncio_define_dimension (filename, 'longitude', this%nlon) + + CALL ncio_write_serial (filename, 'lat_s', this%lat_s, 'latitude' ) + CALL ncio_write_serial (filename, 'lat_n', this%lat_n, 'latitude' ) + CALL ncio_write_serial (filename, 'lon_w', this%lon_w, 'longitude') + CALL ncio_write_serial (filename, 'lon_e', this%lon_e, 'longitude') + + ENDIF + + END SUBROUTINE pixel_save_to_file + + ! -------------------------------- + SUBROUTINE pixel_load_from_file (this, dir_landdata) + + USE MOD_NetCDFSerial + IMPLICIT NONE + + class(pixel_type) :: this + + character(len=*), intent(in) :: dir_landdata + ! Local variables + character(len=256) :: filename + + filename = trim(dir_landdata) // '/pixel.nc' + + CALL ncio_read_bcast_serial (filename, 'edges', this%edges) + CALL ncio_read_bcast_serial (filename, 'edgen', this%edgen) + CALL ncio_read_bcast_serial (filename, 'edgew', this%edgew) + CALL ncio_read_bcast_serial (filename, 'edgee', this%edgee) + + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nlon = size(this%lon_w) + this%nlat = size(this%lat_s) + + END SUBROUTINE pixel_load_from_file + + ! -------------------------------- + SUBROUTINE pixel_free_mem (this) + + IMPLICIT NONE + type (pixel_type) :: this + + IF (allocated(this%lat_s)) deallocate(this%lat_s) + IF (allocated(this%lat_n)) deallocate(this%lat_n) + IF (allocated(this%lon_w)) deallocate(this%lon_w) + IF (allocated(this%lon_e)) deallocate(this%lon_e) + + END SUBROUTINE pixel_free_mem + +END MODULE MOD_Pixel diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 new file mode 100644 index 0000000000..29b7ccfa32 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -0,0 +1,737 @@ +#include + +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) +#define COLM_VECTOR_MPI_IO +#endif + +MODULE MOD_Pixelset + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! +! Pixelset refers to a set of pixels in CoLM. +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant FUNCTION Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! In CoLM, the land surface is first divided into pixels, which are rasterized +! points defined by fine-resolution data. Then ELEMENT, PATCH, HRU, PFT, PC +! are all consists of pixels, and hence they are all pixelsets. +! +! The highest level pixelset in CoLM is ELEMENT, all other pixelsets are subsets +! of ELEMENTs. +! In a pixelset, pixels are sorted to make pixels in its subsets consecutive. +! Thus a subset can be represented by starting pixel index and ending pixel index +! in an ELEMENT. +! +! Example of hierarchical pixelsets +! ************************************************ <-- pixels in an ELEMENT +! |<------------------- ELEMENT ---------------->| <-- level 1 +! | subset 1 | subset 2 | subset 3 | <-- level 2 +! |s11| s12 | s21 | s22 | s23 | s31 | <-- level 3 +! +! "Vector" is a collection of data when each pixelset in a given level is associated +! with a value, representing its averaged physical, chemical or biological state. +! +! "Vector" is usually defined on worker process, while its IO is through IO process. +! To read, vector is first loaded from files by IO and then scattered from IO to worker. +! To write, vector is first gathered from worker to IO and then saved to files by IO. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_DataType + IMPLICIT NONE + + ! ---- data types ---- + type :: vec_gather_scatter_type + + ! for worker and io + integer, allocatable :: vlen(:,:) + + ! for worker + integer, allocatable :: vstt(:,:) + integer, allocatable :: vend(:,:) + + ! for io + integer, allocatable :: vcnt(:,:,:) + integer, allocatable :: vdsp(:,:,:) + + CONTAINS + final :: vec_gather_scatter_free_mem + + END type vec_gather_scatter_type + + ! ---- data types ---- + type :: pixelset_type + + integer :: nset + + integer*8, allocatable :: eindex(:) ! global index of element to which pixelset belongs + + integer, allocatable :: ipxstt(:) ! start local index of pixel in the element + integer, allocatable :: ipxend(:) ! end local index of pixel in the element + integer, allocatable :: settyp(:) ! type of pixelset + + integer, allocatable :: ielm(:) ! local index of element to which pixelset belongs + integer, allocatable :: srcpos(:) ! original block-vector position for packed subsets + + integer :: nblkgrp ! number of blocks for this process's working group + integer, allocatable :: xblkgrp (:) ! block index in longitude for this process's group + integer, allocatable :: yblkgrp (:) ! block index in latitude for this process's group + + type(vec_gather_scatter_type) :: vecgs ! for vector gathering and scattering + + logical :: has_shared = .false. + real(r8), allocatable :: pctshared (:) + + CONTAINS + procedure, PUBLIC :: set_vecgs => vec_gather_scatter_set + procedure, PUBLIC :: get_lonlat_radian => pixelset_get_lonlat_radian + procedure, PUBLIC :: pset_pack => pixelset_pack + procedure, PUBLIC :: forc_free_mem => pixelset_forc_free_mem + final :: pixelset_free_mem + + END type pixelset_type + + ! ---- data types ---- + type :: subset_type + + integer, allocatable :: substt(:) + integer, allocatable :: subend(:) + real(r8), allocatable :: subfrc(:) + + CONTAINS + procedure, PUBLIC :: build => subset_build + final :: subset_free_mem + + END type subset_type + + ! ---- data types ---- + type :: superset_type + + integer, allocatable :: sup(:) + + CONTAINS + procedure, PUBLIC :: build => superset_build + final :: superset_free_mem + + END type superset_type + +CONTAINS + + ! -------------------------------- + SUBROUTINE pixelset_get_lonlat_radian (this, rlon, rlat) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Pixel + USE MOD_Mesh + + IMPLICIT NONE + CLASS(pixelset_type) :: this + + real(r8), intent(inout) :: rlon(:), rlat(:) + + ! Local Variables + integer :: iset, ie, ipxstt, ipxend, npxl, ipxl + real(r8), allocatable :: area(:) + + DO iset = 1, this%nset + + ie = this%ielm(iset) + + ipxstt = this%ipxstt (iset) + ipxend = this%ipxend (iset) + + ! for 2m WMO patch, use all pixels + IF (ipxstt == -1) THEN + ipxstt = 1 + ipxend = mesh(ie)%npxl + ENDIF + + allocate (area (ipxstt:ipxend)) + DO ipxl = ipxstt, ipxend + area(ipxl) = areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), & + pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), & + pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + + npxl = ipxend - ipxstt + 1 + rlat(iset) = get_pixelset_rlat ( & + npxl, mesh(ie)%ilat(ipxstt:ipxend), area) + rlon(iset) = get_pixelset_rlon ( & + npxl, mesh(ie)%ilon(ipxstt:ipxend), area) + + deallocate (area) + + ENDDO + + END SUBROUTINE pixelset_get_lonlat_radian + + ! -------------------------------- + FUNCTION get_pixelset_rlat (npxl, ilat, area) result(rlat) + + USE MOD_Precision + USE MOD_Vars_Global, only: pi + USE MOD_Pixel + IMPLICIT NONE + + real(r8) :: rlat + + integer, intent(in) :: npxl + integer, intent(in) :: ilat(npxl) + real(r8), intent(in) :: area(npxl) + + ! Local variables + integer :: ipxl + + rlat = 0.0 + DO ipxl = 1, npxl + rlat = rlat + (pixel%lat_s(ilat(ipxl)) + pixel%lat_n(ilat(ipxl))) * 0.5 * area(ipxl) + ENDDO + rlat = rlat / sum(area) * pi/180.0 + + END FUNCTION get_pixelset_rlat + + ! -------------------------------- + FUNCTION get_pixelset_rlon (npxl, ilon, area) result(rlon) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Vars_Global, only: pi + USE MOD_Pixel + IMPLICIT NONE + + real(r8) :: rlon + + integer, intent(in) :: npxl + integer, intent(in) :: ilon(npxl) + real(r8), intent(in) :: area(npxl) + + ! Local variables + integer :: ipxl + real(r8) :: lon, lon0, area_done + + lon = 0.0 + area_done = 0.0 + DO ipxl = 1, npxl + + IF (pixel%lon_w(ilon(ipxl)) > pixel%lon_e(ilon(ipxl))) THEN + lon0 = (pixel%lon_w(ilon(ipxl)) + pixel%lon_e(ilon(ipxl)) + 360.0) * 0.5 + ELSE + lon0 = (pixel%lon_w(ilon(ipxl)) + pixel%lon_e(ilon(ipxl))) * 0.5 + ENDIF + + CALL normalize_longitude (lon0) + + IF (lon - lon0 > 180._r8) THEN + lon = lon * area_done + (lon0 + 360._r8) * area(ipxl) + ELSEIF (lon - lon0 < -180._r8) THEN + lon = lon * area_done + (lon0 - 360._r8) * area(ipxl) + ELSE + lon = lon * area_done + lon0 * area(ipxl) + ENDIF + + area_done = area_done + area(ipxl) + lon = lon / area_done + + CALL normalize_longitude(lon) + + ENDDO + + rlon = lon * pi/180.0 + + END FUNCTION get_pixelset_rlon + + ! -------------------------------- + SUBROUTINE pixelset_free_mem (this) + + IMPLICIT NONE + type (pixelset_type) :: this + + IF (allocated(this%eindex)) deallocate(this%eindex) + IF (allocated(this%ipxstt)) deallocate(this%ipxstt) + IF (allocated(this%ipxend)) deallocate(this%ipxend) + IF (allocated(this%settyp)) deallocate(this%settyp) + + IF (allocated(this%ielm )) deallocate(this%ielm ) + IF (allocated(this%srcpos)) deallocate(this%srcpos) + + IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) + IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + + IF (allocated(this%pctshared)) deallocate(this%pctshared) + + END SUBROUTINE pixelset_free_mem + + ! -------------------------------- + SUBROUTINE pixelset_forc_free_mem (this) + + IMPLICIT NONE + + class(pixelset_type) :: this + + IF (allocated(this%eindex )) deallocate(this%eindex ) + IF (allocated(this%ipxstt )) deallocate(this%ipxstt ) + IF (allocated(this%ipxend )) deallocate(this%ipxend ) + IF (allocated(this%settyp )) deallocate(this%settyp ) + + IF (allocated(this%ielm )) deallocate(this%ielm ) + IF (allocated(this%srcpos )) deallocate(this%srcpos ) + + IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) + IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + + IF (allocated(this%pctshared)) deallocate(this%pctshared) + + END SUBROUTINE pixelset_forc_free_mem + + ! -------------------------------- + SUBROUTINE copy_pixelset(pixel_from, pixel_to) + + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixel_from + type(pixelset_type), intent(out) :: pixel_to + + pixel_to%nset = pixel_from%nset + pixel_to%eindex = pixel_from%eindex + pixel_to%ipxstt = pixel_from%ipxstt + pixel_to%ipxend = pixel_from%ipxend + pixel_to%settyp = pixel_from%settyp + pixel_to%ielm = pixel_from%ielm + IF (allocated(pixel_from%srcpos)) THEN + pixel_to%srcpos = pixel_from%srcpos + ENDIF + + pixel_to%nblkgrp = pixel_from%nblkgrp + pixel_to%xblkgrp = pixel_from%xblkgrp + pixel_to%yblkgrp = pixel_from%yblkgrp + + IF (pixel_from%has_shared) THEN + pixel_to%pctshared = pixel_from%pctshared + ENDIF + + END SUBROUTINE + + ! -------------------------------- + SUBROUTINE vec_gather_scatter_set (this) + + USE MOD_Block + USE MOD_SPMD_Task + USE MOD_Mesh + IMPLICIT NONE + + class(pixelset_type) :: this + + ! Local variables + integer :: iproc + integer :: iset, ie, xblk, yblk, iblk, jblk, scnt, iblkgrp, iblkall + logical, allocatable :: nonzero(:,:) + +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (.not. allocated (this%vecgs%vlen)) THEN + allocate (this%vecgs%vlen (gblock%nxblk, gblock%nyblk)) + this%vecgs%vlen(:,:) = 0 + ENDIF + + IF (p_is_worker) THEN + + IF (.not. allocated (this%vecgs%vstt)) THEN + allocate (this%vecgs%vstt (gblock%nxblk, gblock%nyblk)) + allocate (this%vecgs%vend (gblock%nxblk, gblock%nyblk)) + ENDIF + + this%vecgs%vstt(:,:) = 0 + this%vecgs%vend(:,:) = -1 + + ie = 1 + xblk = 0 + yblk = 0 + DO iset = 1, this%nset + DO WHILE (this%eindex(iset) /= mesh(ie)%indx) + ie = ie + 1 + ENDDO + + IF ((mesh(ie)%xblk /= xblk) .or. (mesh(ie)%yblk /= yblk)) THEN + xblk = mesh(ie)%xblk + yblk = mesh(ie)%yblk + this%vecgs%vstt(xblk,yblk) = iset + ENDIF + + this%vecgs%vend(xblk,yblk) = iset + ENDDO + + this%vecgs%vlen = this%vecgs%vend - this%vecgs%vstt + 1 + +#ifdef COLM_VECTOR_MPI_IO + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (gblock%pio(iblk,jblk) == p_address_io(p_my_group)) THEN + + scnt = this%vecgs%vlen(iblk,jblk) + CALL mpi_gather (scnt, 1, MPI_INTEGER, & + MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err) + + ENDIF + ENDDO + ENDDO +#endif + ENDIF + +#ifdef COLM_VECTOR_MPI_IO + IF (p_is_io) THEN + + IF (.not. allocated(this%vecgs%vcnt)) THEN + allocate (this%vecgs%vcnt (0:p_np_group-1,gblock%nxblk,gblock%nyblk)) + allocate (this%vecgs%vdsp (0:p_np_group-1,gblock%nxblk,gblock%nyblk)) + ENDIF + + this%vecgs%vcnt(:,:,:) = 0 + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN + + scnt = 0 + CALL mpi_gather (scnt, 1, MPI_INTEGER, & + this%vecgs%vcnt(:,iblk,jblk), 1, MPI_INTEGER, & + p_root, p_comm_group, p_err) + + this%vecgs%vdsp(0,iblk,jblk) = 0 + DO iproc = 1, p_np_group-1 + this%vecgs%vdsp(iproc,iblk,jblk) = & + this%vecgs%vdsp(iproc-1,iblk,jblk) + this%vecgs%vcnt(iproc-1,iblk,jblk) + ENDDO + + this%vecgs%vlen(iblk,jblk) = sum(this%vecgs%vcnt(:,iblk,jblk)) + + ENDIF + ENDDO + ENDDO + ENDIF +#endif + + IF (p_is_io .or. p_is_worker) THEN + allocate (nonzero (gblock%nxblk,gblock%nyblk)) + + nonzero = this%vecgs%vlen > 0 +#ifdef COLM_VECTOR_MPI_IO + CALL mpi_allreduce (MPI_IN_PLACE, nonzero, gblock%nxblk * gblock%nyblk, & + MPI_LOGICAL, MPI_LOR, p_comm_group, p_err) +#endif + + this%nblkgrp = count(nonzero) + IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) + IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + allocate (this%xblkgrp (this%nblkgrp)) + allocate (this%yblkgrp (this%nblkgrp)) + + iblkgrp = 0 + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (nonzero(iblk,jblk)) THEN + iblkgrp = iblkgrp + 1 + this%xblkgrp(iblkgrp) = iblk + this%yblkgrp(iblkgrp) = jblk + ENDIF + ENDDO + ENDDO + + deallocate(nonzero) + ENDIF + + END SUBROUTINE vec_gather_scatter_set + + ! -------------------------------- + SUBROUTINE pixelset_pack (this, mask, nset_packed) + + USE MOD_SPMD_Task + IMPLICIT NONE + class(pixelset_type) :: this + logical, intent(in) :: mask(:) + integer, intent(out) :: nset_packed + + integer*8, allocatable :: eindex_(:) + integer, allocatable :: ipxstt_(:) + integer, allocatable :: ipxend_(:) + integer, allocatable :: settyp_(:) + integer, allocatable :: ielm_ (:) + integer, allocatable :: srcpos_(:) + + real(r8), allocatable :: pctshared_(:) + integer :: s, e + + IF (p_is_worker) THEN + + IF (this%nset > 0) THEN + IF (count(mask) < this%nset) THEN + + allocate (eindex_(this%nset)) + allocate (ipxstt_(this%nset)) + allocate (ipxend_(this%nset)) + allocate (settyp_(this%nset)) + allocate (ielm_ (this%nset)) + IF (allocated(this%srcpos)) allocate (srcpos_(this%nset)) + + eindex_ = this%eindex + ipxstt_ = this%ipxstt + ipxend_ = this%ipxend + settyp_ = this%settyp + ielm_ = this%ielm + IF (allocated(this%srcpos)) srcpos_ = this%srcpos + + deallocate (this%eindex) + deallocate (this%ipxstt) + deallocate (this%ipxend) + deallocate (this%settyp) + deallocate (this%ielm ) + IF (allocated(this%srcpos)) deallocate (this%srcpos) + + IF (this%has_shared) THEN + allocate (pctshared_(this%nset)) + pctshared_ = this%pctshared + deallocate (this%pctshared) + ENDIF + + this%nset = count(mask) + + IF (this%nset > 0) THEN + + allocate (this%eindex(this%nset)) + allocate (this%ipxstt(this%nset)) + allocate (this%ipxend(this%nset)) + allocate (this%settyp(this%nset)) + allocate (this%ielm (this%nset)) + IF (allocated(srcpos_)) allocate (this%srcpos(this%nset)) + + this%eindex = pack(eindex_, mask) + this%ipxstt = pack(ipxstt_, mask) + this%ipxend = pack(ipxend_, mask) + this%settyp = pack(settyp_, mask) + this%ielm = pack(ielm_ , mask) + IF (allocated(srcpos_)) this%srcpos = pack(srcpos_, mask) + + IF (this%has_shared) THEN + + this%pctshared = pack(pctshared_, mask) + + s = 1 + DO WHILE (s < this%nset) + e = s + DO WHILE (e < this%nset) + IF ((this%ielm(e+1) == this%ielm(s)) & + .and. (this%ipxstt(e+1) == this%ipxstt(s))) THEN + e = e + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (e > s) THEN + this%pctshared(s:e) = this%pctshared(s:e)/sum(this%pctshared(s:e)) + ENDIF + + s = e + 1 + ENDDO + + ENDIF + + ENDIF + + deallocate (eindex_) + deallocate (ipxstt_) + deallocate (ipxend_) + deallocate (settyp_) + deallocate (ielm_ ) + IF (allocated(srcpos_)) deallocate (srcpos_) + + IF (this%has_shared) THEN + deallocate (pctshared_) + ENDIF + + ENDIF + ENDIF + + ENDIF + + CALL this%set_vecgs + + nset_packed = this%nset + + END SUBROUTINE pixelset_pack + + ! -------------------------------- + SUBROUTINE vec_gather_scatter_free_mem (this) + + IMPLICIT NONE + type (vec_gather_scatter_type) :: this + + IF (allocated(this%vlen)) deallocate (this%vlen) + IF (allocated(this%vstt)) deallocate (this%vstt) + IF (allocated(this%vend)) deallocate (this%vend) + IF (allocated(this%vcnt)) deallocate (this%vcnt) + IF (allocated(this%vdsp)) deallocate (this%vdsp) + + END SUBROUTINE vec_gather_scatter_free_mem + + ! -------------------------------- + SUBROUTINE subset_build (this, superset, subset, use_frac) + + USE MOD_Mesh + USE MOD_Pixel + USE MOD_Utils + IMPLICIT NONE + + CLASS(subset_type) :: this + + type (pixelset_type), intent(in) :: superset + type (pixelset_type), intent(in) :: subset + logical, intent(in) :: use_frac + + ! Local Variables + integer :: isuperset, isubset, ielm, ipxl, istt, iend + + IF (superset%nset <= 0) RETURN + + IF (superset%has_shared) THEN + write(*,*) 'Warning: superset has shared area.' + ENDIF + + IF (allocated(this%substt)) deallocate(this%substt) + IF (allocated(this%subend)) deallocate(this%subend) + + allocate (this%substt (superset%nset)) + allocate (this%subend (superset%nset)) + + this%substt = 0 + this%subend = -1 + + isuperset = 1 + isubset = 1 + DO WHILE (isubset <= subset%nset) + IF ( (subset%eindex(isubset) == superset%eindex(isuperset)) & + .and. (subset%ipxstt(isubset) >= superset%ipxstt(isuperset) .or. & + subset%ipxstt(isubset) == -1 ) & + .and. (subset%ipxend(isubset) <= superset%ipxend(isuperset) .or. & + subset%ipxend(isubset) == -1 ) ) THEN + + IF (this%substt(isuperset) == 0) THEN + this%substt(isuperset) = isubset + ENDIF + + this%subend(isuperset) = isubset + + isubset = isubset + 1 + ELSE + isuperset = isuperset + 1 + ENDIF + ENDDO + + IF (use_frac) THEN + + IF (allocated(this%subfrc)) deallocate(this%subfrc) + + IF (subset%nset <= 0) RETURN + + allocate (this%subfrc (subset%nset)) + + DO isubset = 1, subset%nset + ielm = subset%ielm(isubset) + this%subfrc(isubset) = 0 + DO ipxl = subset%ipxstt(isubset), subset%ipxend(isubset) + IF (ipxl == -1) CYCLE + this%subfrc(isubset) = this%subfrc(isubset) & + + areaquad (& + pixel%lat_s(mesh(ielm)%ilat(ipxl)), & + pixel%lat_n(mesh(ielm)%ilat(ipxl)), & + pixel%lon_w(mesh(ielm)%ilon(ipxl)), & + pixel%lon_e(mesh(ielm)%ilon(ipxl)) ) + ENDDO + IF (subset%has_shared) THEN + this%subfrc(isubset) = this%subfrc(isubset) * subset%pctshared(isubset) + ENDIF + ENDDO + + DO isuperset = 1, superset%nset + IF (this%substt(isuperset) /= 0) THEN + istt = this%substt(isuperset) + iend = this%subend(isuperset) + this%subfrc(istt:iend) = this%subfrc(istt:iend) / sum(this%subfrc(istt:iend)) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE subset_build + + ! -------------------------------- + SUBROUTINE subset_free_mem (this) + + IMPLICIT NONE + type (subset_type) :: this + + IF (allocated(this%substt)) deallocate (this%substt) + IF (allocated(this%subend)) deallocate (this%subend) + IF (allocated(this%subfrc)) deallocate (this%subfrc) + + END SUBROUTINE subset_free_mem + + ! -------------------------------- + SUBROUTINE superset_build (this, superset, subset) + + IMPLICIT NONE + + CLASS(superset_type) :: this + + type (pixelset_type), intent(in) :: superset + type (pixelset_type), intent(in) :: subset + + ! Local Variables + integer :: isuperset, isubset + + IF (subset%nset <= 0) RETURN + + IF (allocated(this%sup)) deallocate(this%sup) + + allocate (this%sup (subset%nset)) + + isuperset = 1 + isubset = 1 + DO WHILE (isubset <= subset%nset) + IF ( (subset%eindex(isubset) == superset%eindex(isuperset)) & + .and. (subset%ipxstt(isubset) >= superset%ipxstt(isuperset)) & + .and. (subset%ipxend(isubset) <= superset%ipxend(isuperset))) THEN + + this%sup(isubset) = isuperset + + isubset = isubset + 1 + ELSE + isuperset = isuperset + 1 + ENDIF + ENDDO + + END SUBROUTINE superset_build + + ! -------------------------------- + SUBROUTINE superset_free_mem (this) + + IMPLICIT NONE + type (superset_type) :: this + + IF (allocated(this%sup)) deallocate (this%sup) + + END SUBROUTINE superset_free_mem + +END MODULE MOD_Pixelset diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 new file mode 100644 index 0000000000..d3c259200b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 @@ -0,0 +1,12 @@ +MODULE MOD_Precision +!------------------------------------------------------------------------------- +! !Purpose: +! Define the precision to use for floating point and integer operations +! throughout the model. +!------------------------------------------------------------------------------- + integer, parameter :: r4 = selected_real_kind(5) + integer, parameter :: r8 = selected_real_kind(12) + integer, parameter :: r16 = selected_real_kind(24) !16 byte REAL + integer, parameter :: i8 = selected_int_kind(13) + +END MODULE MOD_Precision diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 new file mode 100644 index 0000000000..f98194e8e4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 @@ -0,0 +1,886 @@ +#include + +MODULE MOD_RangeCheck + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Subroutines show the range of values in block data or vector data. +! +! Notice that: +! 1. "check_block_data" can only be called by IO processes. +! 2. "check_vector_data" can only be called by worker processes. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + +#ifdef RangeCheck + USE MOD_UserDefFun, only: isnan_ud + IMPLICIT NONE + + INTERFACE check_block_data + MODULE procedure check_block_data_real8_2d + END INTERFACE check_block_data + + INTERFACE check_vector_data + MODULE procedure check_vector_data_real8_1d + MODULE procedure check_vector_data_real8_2d + MODULE procedure check_vector_data_real8_3d + MODULE procedure check_vector_data_real8_4d + MODULE procedure check_vector_data_real8_5d + MODULE procedure check_vector_data_int32_1d + END INTERFACE check_vector_data + +CONTAINS + + ! ---------- + SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_DataType + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: varname + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(in), optional :: spv_in + real(r8), intent(in), optional :: limits(2) + + ! Local variables + real(r8) :: gmin, gmax, spv + real(r8), allocatable :: gmin_all(:), gmax_all(:) + logical, allocatable :: msk2(:,:) + integer :: iblkme, ib, jb, ix, iy + logical :: has_nan + character(len=256) :: wfmt, exception, str_print + + IF (p_is_io) THEN + + IF (present(spv_in)) THEN + spv = spv_in + ELSE + spv = spval + ENDIF + + gmin = spv + gmax = spv + + has_nan = .false. + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + + IF (.not. allocated(gdata%blk(ib,jb)%val)) CYCLE + + allocate(msk2 (size(gdata%blk(ib,jb)%val,1), size(gdata%blk(ib,jb)%val,2))) + msk2 = gdata%blk(ib,jb)%val /= spv + + IF (any(msk2)) THEN + IF (gmin == spv) THEN + gmin = minval(gdata%blk(ib,jb)%val, mask = msk2) + ELSE + gmin = min(gmin, minval(gdata%blk(ib,jb)%val, mask = msk2)) + ENDIF + + IF (gmax == spv) THEN + gmax = maxval(gdata%blk(ib,jb)%val, mask = msk2) + ELSE + gmax = max(gmax, maxval(gdata%blk(ib,jb)%val, mask = msk2)) + ENDIF + ENDIF + + DO iy = 1, size(gdata%blk(ib,jb)%val,2) + DO ix = 1, size(gdata%blk(ib,jb)%val,1) + has_nan = has_nan .or. isnan_ud(gdata%blk(ib,jb)%val(ix,iy)) + ENDDO + ENDDO + + deallocate(msk2) + + ENDDO + +#ifdef USEMPI + IF (p_iam_io == p_root) THEN + allocate (gmin_all (0:p_np_io-1)) + allocate (gmax_all (0:p_np_io-1)) + CALL mpi_gather (gmin, 1, MPI_REAL8, gmin_all, 1, MPI_REAL8, p_root, p_comm_io, p_err) + CALL mpi_gather (gmax, 1, MPI_REAL8, gmax_all, 1, MPI_REAL8, p_root, p_comm_io, p_err) + ELSE + CALL mpi_gather (gmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_io, p_err) + CALL mpi_gather (gmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_io, p_err) + ENDIF + + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + + IF (p_iam_io == p_root) THEN + IF (any(gmin_all /= spv)) THEN + gmin = minval(gmin_all, mask = (gmin_all /= spv)) + ELSE + gmin = spv + ENDIF + + IF (any(gmax_all /= spv)) THEN + gmax = maxval(gmax_all, mask = (gmax_all /= spv)) + ELSE + gmax = spv + ENDIF + + deallocate (gmin_all) + deallocate (gmax_all) + ENDIF +#endif + IF (p_iam_io == p_root) THEN + + exception = '' + + IF (has_nan) THEN + exception = trim(exception) // ' with NAN' + ENDIF + + IF (present(limits)) THEN + IF ((gmin < limits(1)) .or. (gmax > limits(2))) THEN + exception = trim(exception) // ' Out of Range!' + ENDIF + ENDIF + + wfmt = "('Check block data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" + write(str_print,wfmt) varname, gmin, gmax, trim(exception) + +#ifdef USEMPI + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_io(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_io(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + + write(*,'(A)') trim(str_print) + +#if (defined CoLMDEBUG) + IF (len_trim(exception) > 0) THEN + CALL CoLM_stop () + ENDIF +#endif + ENDIF + + END SUBROUTINE check_block_data_real8_2d + + + ! ---------- + SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: varname + real(r8), allocatable, intent(in) :: vdata(:) + + real(r8), intent(in), optional :: spv_in + real(r8), intent(in), optional :: limits(2) + + ! Local variables + real(r8) :: vmin, vmax, spv + real(r8), allocatable :: vmin_all(:), vmax_all(:) + integer :: i + logical :: has_nan + character(len=256) :: wfmt, exception, str_print + + IF (p_is_worker) THEN + + IF (present(spv_in)) THEN + spv = spv_in + ELSE + spv = spval + ENDIF + + IF (allocated(vdata)) THEN + IF (any(vdata /= spv)) THEN + vmin = minval(vdata, mask = vdata /= spv) + vmax = maxval(vdata, mask = vdata /= spv) + ELSE + vmin = spv + vmax = spv + ENDIF + + has_nan = .false. + DO i = lbound(vdata,1), ubound(vdata,1) + has_nan = has_nan .or. isnan_ud(vdata(i)) + ENDDO + ELSE + vmin = spv; vmax = spv + has_nan = .false. + ENDIF + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (vmin_all (0:p_np_worker-1)) + allocate (vmax_all (0:p_np_worker-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ELSE + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ENDIF + + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + IF (any(vmin_all /= spv)) THEN + vmin = minval(vmin_all, mask = (vmin_all /= spv)) + ELSE + vmin = spv + ENDIF + + IF (any(vmax_all /= spv)) THEN + vmax = maxval(vmax_all, mask = (vmax_all /= spv)) + ELSE + vmax = spv + ENDIF + + deallocate (vmin_all) + deallocate (vmax_all) + ENDIF +#endif + + IF (p_iam_worker == p_root) THEN + + exception = '' + + IF (has_nan) THEN + exception = trim(exception) // ' with NAN' + ENDIF + + IF (present(limits)) THEN + IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN + exception = trim(exception) // ' Out of Range!' + ENDIF + ENDIF + + wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" + write(str_print,wfmt) varname, vmin, vmax, trim(exception) + +#ifdef USEMPI + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + + write(*,'(A)') trim(str_print) + +#if (defined CoLMDEBUG) + IF (len_trim(exception) > 0) THEN + CALL CoLM_stop () + ENDIF +#endif + ENDIF + + END SUBROUTINE check_vector_data_real8_1d + + ! ---------- + SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: varname + real(r8), allocatable, intent(in) :: vdata(:,:) + + real(r8), intent(in), optional :: spv_in + real(r8), intent(in), optional :: limits(2) + + ! Local variables + real(r8) :: vmin, vmax, spv + real(r8), allocatable :: vmin_all(:), vmax_all(:) + integer :: i, j + logical :: has_nan + character(len=256) :: wfmt, exception, str_print + + IF (p_is_worker) THEN + + IF (present(spv_in)) THEN + spv = spv_in + ELSE + spv = spval + ENDIF + + IF (allocated(vdata)) THEN + IF (any(vdata /= spv)) THEN + vmin = minval(vdata, mask = vdata /= spv) + vmax = maxval(vdata, mask = vdata /= spv) + ELSE + vmin = spv + vmax = spv + ENDIF + + has_nan = .false. + DO j = lbound(vdata,2), ubound(vdata,2) + DO i = lbound(vdata,1), ubound(vdata,1) + has_nan = has_nan .or. isnan_ud(vdata(i,j)) + ENDDO + ENDDO + ELSE + vmin = spv; vmax = spv + has_nan = .false. + ENDIF + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (vmin_all (0:p_np_worker-1)) + allocate (vmax_all (0:p_np_worker-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ELSE + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ENDIF + + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + IF (any(vmin_all /= spv)) THEN + vmin = minval(vmin_all, mask = (vmin_all /= spv)) + ELSE + vmin = spv + ENDIF + + IF (any(vmax_all /= spv)) THEN + vmax = maxval(vmax_all, mask = (vmax_all /= spv)) + ELSE + vmax = spv + ENDIF + + deallocate (vmin_all) + deallocate (vmax_all) + ENDIF +#endif + + IF (p_iam_worker == p_root) THEN + + exception = '' + + IF (has_nan) THEN + exception = trim(exception) // ' with NAN' + ENDIF + + IF (present(limits)) THEN + IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN + exception = trim(exception) // ' Out of Range!' + ENDIF + ENDIF + + wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" + write(str_print,wfmt) varname, vmin, vmax, trim(exception) + +#ifdef USEMPI + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + + write(*,'(A)') trim(str_print) + +#if (defined CoLMDEBUG) + IF (len_trim(exception) > 0) THEN + CALL CoLM_stop () + ENDIF +#endif + ENDIF + + END SUBROUTINE check_vector_data_real8_2d + + ! ---------- + SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: varname + real(r8), allocatable, intent(in) :: vdata(:,:,:) + + real(r8), intent(in), optional :: spv_in + real(r8), intent(in), optional :: limits(2) + + ! Local variables + real(r8) :: vmin, vmax, spv + real(r8), allocatable :: vmin_all(:), vmax_all(:) + integer :: i, j, k + logical :: has_nan + character(len=256) :: wfmt, exception, str_print + + IF (p_is_worker) THEN + + IF (present(spv_in)) THEN + spv = spv_in + ELSE + spv = spval + ENDIF + + IF (allocated(vdata)) THEN + IF (any(vdata /= spv)) THEN + vmin = minval(vdata, mask = vdata /= spv) + vmax = maxval(vdata, mask = vdata /= spv) + ELSE + vmin = spv + vmax = spv + ENDIF + + has_nan = .false. + DO k = lbound(vdata,3), ubound(vdata,3) + DO j = lbound(vdata,2), ubound(vdata,2) + DO i = lbound(vdata,1), ubound(vdata,1) + has_nan = has_nan .or. isnan_ud(vdata(i,j,k)) + ENDDO + ENDDO + ENDDO + ELSE + vmin = spv; vmax = spv + has_nan = .false. + ENDIF + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (vmin_all (0:p_np_worker-1)) + allocate (vmax_all (0:p_np_worker-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ELSE + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ENDIF + + + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + IF (any(vmin_all /= spv)) THEN + vmin = minval(vmin_all, mask = (vmin_all /= spv)) + ELSE + vmin = spv + ENDIF + + IF (any(vmax_all /= spv)) THEN + vmax = maxval(vmax_all, mask = (vmax_all /= spv)) + ELSE + vmax = spv + ENDIF + + deallocate (vmin_all) + deallocate (vmax_all) + ENDIF +#endif + + IF (p_iam_worker == p_root) THEN + + exception = '' + + IF (has_nan) THEN + exception = trim(exception) // ' with NAN' + ENDIF + + IF (present(limits)) THEN + IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN + exception = trim(exception) // ' Out of Range!' + ENDIF + ENDIF + + wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" + write(str_print,wfmt) varname, vmin, vmax, trim(exception) + +#ifdef USEMPI + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + + write(*,'(A)') trim(str_print) + +#if (defined CoLMDEBUG) + IF (len_trim(exception) > 0) THEN + CALL CoLM_stop () + ENDIF +#endif + ENDIF + + END SUBROUTINE check_vector_data_real8_3d + + ! ---------- + SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=*), intent(in) :: varname + real(r8), allocatable, intent(in) :: vdata(:,:,:,:) + + real(r8), intent(in), optional :: spv_in + real(r8), intent(in), optional :: limits(2) + + ! Local variables + real(r8) :: vmin, vmax, spv + real(r8), allocatable :: vmin_all(:), vmax_all(:) + integer :: i, j, k, l + logical :: has_nan + character(len=256) :: wfmt, exception, str_print + + IF (p_is_worker) THEN + + IF (present(spv_in)) THEN + spv = spv_in + ELSE + spv = spval + ENDIF + + IF (allocated(vdata)) THEN + IF (any(vdata /= spv)) THEN + vmin = minval(vdata, mask = vdata /= spv) + vmax = maxval(vdata, mask = vdata /= spv) + ELSE + vmin = spv + vmax = spv + ENDIF + + has_nan = .false. + DO l = lbound(vdata,4), ubound(vdata,4) + DO k = lbound(vdata,3), ubound(vdata,3) + DO j = lbound(vdata,2), ubound(vdata,2) + DO i = lbound(vdata,1), ubound(vdata,1) + has_nan = has_nan .or. isnan_ud(vdata(i,j,k,l)) + ENDDO + ENDDO + ENDDO + ENDDO + ELSE + vmin = spv; vmax = spv + has_nan = .false. + ENDIF + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (vmin_all (0:p_np_worker-1)) + allocate (vmax_all (0:p_np_worker-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ELSE + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ENDIF + + + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + IF (any(vmin_all /= spv)) THEN + vmin = minval(vmin_all, mask = (vmin_all /= spv)) + ELSE + vmin = spv + ENDIF + + IF (any(vmax_all /= spv)) THEN + vmax = maxval(vmax_all, mask = (vmax_all /= spv)) + ELSE + vmax = spv + ENDIF + + deallocate (vmin_all) + deallocate (vmax_all) + ENDIF +#endif + + IF (p_iam_worker == p_root) THEN + + exception = '' + + IF (has_nan) THEN + exception = trim(exception) // ' with NAN' + ENDIF + + IF (present(limits)) THEN + IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN + exception = trim(exception) // ' Out of Range!' + ENDIF + ENDIF + + wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" + write(str_print,wfmt) varname, vmin, vmax, trim(exception) + +#ifdef USEMPI + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + + write(*,'(A)') trim(str_print) + +#if (defined CoLMDEBUG) + IF (len_trim(exception) > 0) THEN + CALL CoLM_stop () + ENDIF +#endif + ENDIF + + END SUBROUTINE check_vector_data_real8_4d + + + ! ---------- + SUBROUTINE check_vector_data_real8_5d (varname, vdata, spv_in, limits) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + character(len=*), intent(in) :: varname + real(r8), intent(in) :: vdata(:,:,:,:,:) + real(r8), intent(in), optional :: spv_in + real(r8), intent(in), optional :: limits(2) + + ! Local variables + real(r8) :: vmin, vmax, spv + real(r8), allocatable :: vmin_all(:), vmax_all(:) + integer :: i, j, k, l, m + logical :: has_nan + character(len=256) :: wfmt, ss, info + + IF (p_is_worker) THEN + + IF (present(spv_in)) THEN + spv = spv_in + ELSE + spv = spval + ENDIF + + IF (any(vdata /= spv)) THEN + vmin = minval(vdata, mask = vdata /= spv) + vmax = maxval(vdata, mask = vdata /= spv) + ELSE + vmin = spv + vmax = spv + ENDIF + + has_nan = .false. + DO m = 1, size(vdata,5) + DO l = 1, size(vdata,4) + DO k = 1, size(vdata,3) + DO j = 1, size(vdata,2) + DO i = 1, size(vdata,1) + has_nan = has_nan .or. isnan_ud(vdata(i,j,k,l,m)) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (vmin_all (0:p_np_worker-1)) + allocate (vmax_all (0:p_np_worker-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ELSE + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + ENDIF + + + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + + IF (p_iam_worker == p_root) THEN + IF (any(vmin_all /= spv)) THEN + vmin = minval(vmin_all, mask = (vmin_all /= spv)) + ELSE + vmin = spv + ENDIF + + IF (any(vmax_all /= spv)) THEN + vmax = maxval(vmax_all, mask = (vmax_all /= spv)) + ELSE + vmax = spv + ENDIF + + deallocate (vmin_all) + deallocate (vmax_all) + ENDIF +#endif + + IF (p_iam_worker == p_root) THEN + + info = '' + + IF (has_nan) THEN + info = trim(info) // ' with NAN' + ENDIF + + IF (present(limits)) THEN + IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN + info = trim(info) // ' Out of Range!' + ENDIF + ENDIF + + wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" + write(*,wfmt) varname, vmin, vmax, info + +#if(defined CoLMDEBUG) + IF (len_trim(info) > 0) THEN + CALL CoLM_stop () + ENDIF +#endif + + ENDIF + + ENDIF + + END SUBROUTINE check_vector_data_real8_5d + + + ! ---------- + SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) + + USE MOD_Precision + USE MOD_SPMD_Task + IMPLICIT NONE + + character(len=*), intent(in) :: varname + integer, allocatable, intent(in) :: vdata(:) + + integer, intent(in), optional :: spv_in + + ! Local variables + integer :: vmin, vmax + logical :: isnull + logical, allocatable :: null_all(:) + integer, allocatable :: vmin_all(:), vmax_all(:) + character(len=256) :: wfmt, str_print + + IF (p_is_worker) THEN + + isnull = .not. allocated(vdata) + + IF (.not. isnull) THEN + IF (present(spv_in)) THEN + IF (any(vdata /= spv_in)) THEN + vmin = minval(vdata, mask = vdata /= spv_in) + vmax = maxval(vdata, mask = vdata /= spv_in) + ELSE + vmin = spv_in + vmax = spv_in + ENDIF + ELSE + vmin = minval(vdata) + vmax = maxval(vdata) + ENDIF + ENDIF + +#ifdef USEMPI + IF (p_iam_worker == p_root) THEN + allocate (null_all (0:p_np_worker-1)) + allocate (vmin_all (0:p_np_worker-1)) + allocate (vmax_all (0:p_np_worker-1)) + CALL mpi_gather (isnull, 1, MPI_LOGICAL, null_all, 1, MPI_LOGICAL, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_INTEGER, vmin_all, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_INTEGER, vmax_all, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + ELSE + CALL mpi_gather (isnull, 1, MPI_LOGICAL, MPI_LNULL_P, 1, MPI_LOGICAL, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmax, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + ENDIF + + IF (p_iam_worker == p_root) THEN + IF (present(spv_in)) THEN + null_all = null_all .and. (vmin_all == spv_in) + ENDIF + + vmin = minval(vmin_all, mask = .not. null_all) + vmax = maxval(vmax_all, mask = .not. null_all) + + deallocate (null_all) + deallocate (vmin_all) + deallocate (vmax_all) + ENDIF +#endif + + IF (p_iam_worker == p_root) THEN + wfmt = "('Check vector data:', A25, ' is in (', I20, ',', I20, ')')" + write(str_print,wfmt) varname, vmin, vmax +#ifdef USEMPI + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + mpi_tag_mesg, p_comm_glb, p_err) +#endif + ENDIF + ENDIF + + IF (p_is_master) THEN +#ifdef USEMPI + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) +#endif + write(*,'(A)') trim(str_print) + ENDIF + + END SUBROUTINE check_vector_data_int32_1d + +#endif + +END MODULE MOD_RangeCheck diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 new file mode 100644 index 0000000000..bf85591aec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 @@ -0,0 +1,215 @@ +#include + +MODULE MOD_SPMD_Task + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! SPMD refers to "Single PROGRAM/Multiple Data" parallelization. +! +! In MPAS-embedded CoLM the standalone CoLM MPI master/IO/worker split is not +! used. MPAS owns MPI initialization and decomposition; every MPAS rank stays +! active as a CoLM compute rank, with rank 0 used only for legacy logging/error +! compatibility. The io/worker communicator names below are compatibility +! aliases for older CoLM helper APIs, not separate process pools. +! +! CoLM element ownership is supplied by MPAS cell ownership. Patch/PFT state +! remains internal to CoLM and is mapped back to the owning element/cell by CoLM. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + include 'mpif.h' + + integer, parameter :: p_root = 0 + + logical :: p_is_master = .false. + logical :: p_is_io = .false. + logical :: p_is_worker = .false. + logical :: p_is_writeback = .false. + + integer :: p_comm_glb_plus = MPI_COMM_NULL + integer :: p_iam_glb_plus = -1 + + ! MPAS-owned communicator aliases used by legacy CoLM helper APIs. + integer :: p_comm_glb = MPI_COMM_NULL + integer :: p_iam_glb = -1 + integer :: p_np_glb = 0 + + integer :: p_comm_group = MPI_COMM_NULL + integer :: p_iam_group = -1 + integer :: p_np_group = 0 + + integer :: p_my_group = 0 + integer :: p_address_master = p_root + + integer :: p_comm_io = MPI_COMM_NULL + integer :: p_iam_io = -1 + integer :: p_np_io = 0 + + integer, allocatable :: p_itis_io (:) + integer, allocatable :: p_address_io (:) + + integer :: p_comm_worker = MPI_COMM_NULL + integer :: p_iam_worker = -1 + integer :: p_np_worker = 0 + + integer, allocatable :: p_itis_worker (:) + integer, allocatable :: p_address_worker (:) + + integer :: p_address_writeback = -1 + + integer :: p_stat (MPI_STATUS_SIZE) + integer :: p_err = 0 + + integer, PUBLIC, parameter :: mpi_tag_size = 1 + integer, PUBLIC, parameter :: mpi_tag_mesg = 2 + integer, PUBLIC, parameter :: mpi_tag_data = 3 + + integer :: MPI_INULL_P(1) + logical :: MPI_LNULL_P(1) + real(r8) :: MPI_RNULL_P(1) + + integer, parameter :: MesgMaxSize = 4194304 ! 4MB + + PUBLIC :: spmd_init + PUBLIC :: spmd_exit + PUBLIC :: divide_processes_into_groups + PUBLIC :: spmd_assign_writeback + +CONTAINS + + !----------------------------------------- + SUBROUTINE spmd_init (MyComm_r) + + IMPLICIT NONE + integer, intent(in), optional :: MyComm_r + logical mpi_inited + integer :: iproc + + CALL MPI_INITIALIZED (mpi_inited, p_err) + + IF ( .not. mpi_inited ) THEN + CALL mpi_init (p_err) + ENDIF + + IF (present(MyComm_r)) THEN + CALL MPI_Comm_dup (MyComm_r, p_comm_glb, p_err) + ELSE + CALL MPI_Comm_dup (MPI_COMM_WORLD, p_comm_glb, p_err) + ENDIF + + CALL mpi_comm_rank (p_comm_glb, p_iam_glb, p_err) + CALL mpi_comm_size (p_comm_glb, p_np_glb, p_err) + + p_address_master = p_root + p_is_master = (p_iam_glb == p_address_master) + p_is_io = .true. + p_is_worker = .true. + p_is_writeback = .false. + + p_comm_group = p_comm_glb + p_iam_group = p_iam_glb + p_np_group = p_np_glb + p_my_group = 0 + + p_comm_io = p_comm_glb + p_iam_io = p_iam_glb + p_np_io = p_np_glb + + p_comm_worker = p_comm_glb + p_iam_worker = p_iam_glb + p_np_worker = p_np_glb + + p_comm_glb_plus = MPI_COMM_NULL + p_iam_glb_plus = -1 + p_address_writeback = -1 + + IF (allocated(p_itis_io )) deallocate (p_itis_io ) + IF (allocated(p_address_io )) deallocate (p_address_io ) + IF (allocated(p_itis_worker )) deallocate (p_itis_worker ) + IF (allocated(p_address_worker)) deallocate (p_address_worker) + + allocate (p_itis_io (0:p_np_glb-1)) + allocate (p_address_io (0:p_np_glb-1)) + allocate (p_itis_worker (0:p_np_glb-1)) + allocate (p_address_worker (0:p_np_glb-1)) + + DO iproc = 0, p_np_glb-1 + p_itis_io(iproc) = iproc + p_address_io(iproc) = iproc + p_itis_worker(iproc) = iproc + p_address_worker(iproc) = iproc + ENDDO + + END SUBROUTINE spmd_init + + !----------------------------------------- + SUBROUTINE divide_processes_into_groups (ngrp) + + IMPLICIT NONE + integer, intent(in) :: ngrp + + IF (ngrp <= 0) THEN + CALL mpi_abort (p_comm_glb, 1, p_err) + ENDIF + + ! MPAS owns the process decomposition. Keep every MPAS rank active. + p_comm_group = p_comm_glb + p_iam_group = p_iam_glb + p_np_group = p_np_glb + p_my_group = 0 + + END SUBROUTINE divide_processes_into_groups + + !----------------------------------------- + SUBROUTINE spmd_exit + + IF (allocated(p_itis_io )) deallocate (p_itis_io ) + IF (allocated(p_address_io )) deallocate (p_address_io ) + IF (allocated(p_itis_worker )) deallocate (p_itis_worker ) + IF (allocated(p_address_worker)) deallocate (p_address_worker) + + IF (p_comm_glb /= MPI_COMM_NULL) THEN + CALL mpi_barrier (p_comm_glb, p_err) + CALL MPI_Comm_free (p_comm_glb, p_err) + ENDIF + + p_comm_glb = MPI_COMM_NULL + p_comm_group = MPI_COMM_NULL + p_comm_io = MPI_COMM_NULL + p_comm_worker = MPI_COMM_NULL + + END SUBROUTINE spmd_exit + + ! ----- ----- + SUBROUTINE spmd_assign_writeback () + + IMPLICIT NONE + + CALL CoLM_stop('MPAS embedded CoLM does not support a standalone writeback MPI task.') + + END SUBROUTINE spmd_assign_writeback + + ! -- STOP all processes -- + SUBROUTINE CoLM_stop (mesg) + + IMPLICIT NONE + character(len=*), optional :: mesg + logical :: mpi_inited + + IF (present(mesg)) write(*,*) trim(mesg) + + CALL MPI_INITIALIZED (mpi_inited, p_err) + IF (mpi_inited .and. p_comm_glb /= MPI_COMM_NULL) THEN + CALL mpi_abort (p_comm_glb, 1, p_err) + ENDIF + + STOP + + END SUBROUTINE CoLM_stop + +END MODULE MOD_SPMD_Task diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 new file mode 100644 index 0000000000..f10bbd8181 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 @@ -0,0 +1,2856 @@ +#include + +MODULE MOD_SpatialMapping + +!-------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Spatial Mapping module. +! +! Created by Shupeng Zhang, May 2024 +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + ! ------ + type :: spatial_mapping_type + + type(grid_type) :: grid + + type(grid_list_type), allocatable :: glist (:) + + integer :: npset + integer, allocatable :: npart(:) + type(pointer_int32_2d), allocatable :: address (:) + + logical :: has_missing_value = .false. + real(r8) :: missing_value = spval + + type(pointer_real8_1d), allocatable :: areapart(:) ! intersection area + real(r8), allocatable :: areapset(:) + type(block_data_real8_2d) :: areagrid + + CONTAINS + + procedure, PUBLIC :: build_arealweighted => spatial_mapping_build_arealweighted + procedure, PUBLIC :: build_bilinear => spatial_mapping_build_bilinear + + procedure, PUBLIC :: set_missing_value => spatial_mapping_set_missing_value + + ! 1) from pixelset to grid + procedure, PRIVATE :: pset2grid_2d => spatial_mapping_pset2grid_2d + procedure, PRIVATE :: pset2grid_3d => spatial_mapping_pset2grid_3d + procedure, PRIVATE :: pset2grid_4d => spatial_mapping_pset2grid_4d + generic, PUBLIC :: pset2grid => pset2grid_2d, pset2grid_3d, pset2grid_4d + + procedure, PUBLIC :: pset2grid_max => spatial_mapping_pset2grid_max + procedure, PUBLIC :: pset2grid_split => spatial_mapping_pset2grid_split + + procedure, PUBLIC :: get_sumarea => spatial_mapping_get_sumarea + + ! 2) from grid to pixelset + procedure, PRIVATE :: grid2pset_2d => spatial_mapping_grid2pset_2d + procedure, PRIVATE :: grid2pset_3d => spatial_mapping_grid2pset_3d + generic, PUBLIC :: grid2pset => grid2pset_2d, grid2pset_3d + + procedure, PUBLIC :: grid2pset_dominant => spatial_mapping_dominant_2d + procedure, PUBLIC :: grid2pset_varvalue => spatial_mapping_varvalue_2d + + ! 3) between grid and intersections + procedure, PUBLIC :: grid2part => spatial_mapping_grid2part + procedure, PUBLIC :: part2grid => spatial_mapping_part2grid + procedure, PUBLIC :: normalize => spatial_mapping_normalize + + ! 4) intersections to pixelset + procedure, PUBLIC :: part2pset => spatial_mapping_part2pset + + procedure, PUBLIC :: allocate_part => spatial_mapping_allocate_part + procedure, PUBLIC :: deallocate_part => spatial_mapping_deallocate_part + procedure, PUBLIC :: forc_free_mem => forc_free_mem_spatial_mapping + + final :: spatial_mapping_free_mem + + END type spatial_mapping_type + +!----------------------- +CONTAINS + + !------------------------------------------ + SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_Mesh + USE MOD_Utils + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(grid_type), intent(in) :: fgrid + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + type(pointer_real8_1d), allocatable :: afrac(:) + type(grid_list_type), allocatable :: gfrom(:) + type(pointer_int32_1d), allocatable :: list_lat(:) + integer, allocatable :: ng_lat(:) + integer, allocatable :: ys(:), yn(:), xw(:), xe(:) + integer, allocatable :: xlist(:), ylist(:) + integer, allocatable :: ipt(:) + logical, allocatable :: msk(:) + + integer :: ie, iset, iblkme + integer :: ng, ig, ng_all, iloc + integer :: npxl, ipxl, ilat, ilon + integer :: iworker, iproc, idest, isrc, nrecv + integer :: rmesg(2), smesg(2) + integer :: iy, ix, xblk, yblk, xloc, yloc + integer :: ipxstt, ipxend + real(r8) :: lat_s, lat_n, lon_w, lon_e, area + logical :: skip, is_new + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + + write(*,"(A, I0, A, I0, A)") & + 'Making areal weighted mapping between pixel set and grid: ', & + fgrid%nlat, ' grids in latitude ', fgrid%nlon, ' grids in longitude.' + +#ifndef SinglePoint + IF (.not. (lon_between_floor(pixel%edgew, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)) & + .and. lon_between_ceil(pixel%edgee, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)))) THEN + write(*,'(A)') 'Warning: Grid does not cover longitude range of modeling region.' + ENDIF + + IF (fgrid%yinc == 1) THEN + IF (.not. ((pixel%edges >= fgrid%lat_s(1)) & + .and. (pixel%edgen <= fgrid%lat_n(fgrid%nlat)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ELSE + IF (.not. ((pixel%edges >= fgrid%lat_s(fgrid%nlat)) & + .and. (pixel%edgen <= fgrid%lat_n(1)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ENDIF +#endif + + ENDIF + + allocate (this%grid%xblk (size(fgrid%xblk))); this%grid%xblk = fgrid%xblk + allocate (this%grid%yblk (size(fgrid%yblk))); this%grid%yblk = fgrid%yblk + allocate (this%grid%xloc (size(fgrid%xloc))); this%grid%xloc = fgrid%xloc + allocate (this%grid%yloc (size(fgrid%yloc))); this%grid%yloc = fgrid%yloc + allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt + allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt + +#ifdef SinglePoint + allocate (this%glist (0:0)) + allocate (this%glist(0)%ilat (1)) + allocate (this%glist(0)%ilon (1)) + + allocate (this%npart (pixelset%nset)) + allocate (this%address (pixelset%nset)) + allocate (this%areapset(pixelset%nset)) + allocate (this%areapart(pixelset%nset)) + DO iset = 1, pixelset%nset + allocate (this%address(iset)%val (2,1)) + allocate (this%areapart(iset)%val (1)) + ENDDO + + this%glist(0)%ng = 1 + this%glist(0)%ilat(1) = find_nearest_south (SITE_lat_location, fgrid%nlat, fgrid%lat_s) + this%glist(0)%ilon(1) = find_nearest_west (SITE_lon_location, fgrid%nlon, fgrid%lon_w) + + this%npset = pixelset%nset + this%npart (:) = 1 + this%areapset(:) = 1. + + DO iset = 1, pixelset%nset + this%address(iset)%val = reshape((/0,1/), (/2,1/)) + this%areapart(iset)%val = 1. + ENDDO + + CALL allocate_block_data (fgrid, this%areagrid) + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + this%areagrid%blk(xblk,yblk)%val = 1. + ENDDO + + RETURN +#endif + + + IF (p_is_worker) THEN + + this%npset = pixelset%nset + + allocate (afrac (pixelset%nset)) + allocate (gfrom (pixelset%nset)) + + allocate (ys (pixel%nlat)) + allocate (yn (pixel%nlat)) + allocate (xw (pixel%nlon)) + allocate (xe (pixel%nlon)) + + DO ilat = 1, pixel%nlat + ys(ilat) = find_nearest_south (pixel%lat_s(ilat), fgrid%nlat, fgrid%lat_s) + yn(ilat) = find_nearest_north (pixel%lat_n(ilat), fgrid%nlat, fgrid%lat_n) + ENDDO + + DO ilon = 1, pixel%nlon + xw(ilon) = find_nearest_west (pixel%lon_w(ilon), fgrid%nlon, fgrid%lon_w) + xe(ilon) = find_nearest_east (pixel%lon_e(ilon), fgrid%nlon, fgrid%lon_e) + ENDDO + + allocate (list_lat (fgrid%nlat)) + DO iy = 1, fgrid%nlat + allocate (list_lat(iy)%val (100)) + ENDDO + + allocate (ng_lat (fgrid%nlat)); ng_lat(:) = 0 + + DO iset = 1, pixelset%nset + + ie = pixelset%ielm(iset) + npxl = pixelset%ipxend(iset) - pixelset%ipxstt(iset) + 1 + + ipxstt = pixelset%ipxstt(iset) + ipxend = pixelset%ipxend(iset) + + ! deal with 2m WMO patch + IF (ipxstt==-1 .and. ipxend==-1) THEN + ipxstt = 1 + ipxend = mesh(ie)%npxl + npxl = mesh(ie)%npxl + ENDIF + + allocate (afrac(iset)%val (npxl)) + allocate (gfrom(iset)%ilat(npxl)) + allocate (gfrom(iset)%ilon(npxl)) + + gfrom(iset)%ng = 0 + + DO ipxl = ipxstt, ipxend + + ilat = mesh(ie)%ilat(ipxl) + ilon = mesh(ie)%ilon(ipxl) + + DO iy = ys(ilat), yn(ilat), fgrid%yinc + + lat_s = max(fgrid%lat_s(iy), pixel%lat_s(ilat)) + lat_n = min(fgrid%lat_n(iy), pixel%lat_n(ilat)) + + IF ((lat_n-lat_s) < 1.0e-6_r8) THEN + CYCLE + ENDIF + + ix = xw(ilon) + DO WHILE (.true.) + + IF (ix == xw(ilon)) THEN + lon_w = pixel%lon_w(ilon) + ELSE + lon_w = fgrid%lon_w(ix) + ENDIF + + IF (ix == xe(ilon)) THEN + lon_e = pixel%lon_e(ilon) + ELSE + lon_e = fgrid%lon_e(ix) + ENDIF + + skip = .false. + IF (.not. (lon_between_floor (lon_w, pixel%lon_w(ilon), lon_e) & + .and. lon_between_ceil (lon_e, lon_w, pixel%lon_e(ilon)))) THEN + skip = .true. + ELSE + IF (lon_e > lon_w) THEN + IF ((lon_e-lon_w) < 1.0e-6_r8) THEN + skip = .true. + ENDIF + ELSE + IF ((lon_e+360.0_r8-lon_w) < 1.0e-6_r8) THEN + skip = .true. + ENDIF + ENDIF + ENDIF + + IF (.not. skip) THEN + + area = areaquad (lat_s, lat_n, lon_w, lon_e) + + CALL insert_into_sorted_list2 ( ix, iy, & + gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & + iloc, is_new) + + IF (is_new) THEN + IF (iloc < gfrom(iset)%ng) THEN + afrac(iset)%val(iloc+1:gfrom(iset)%ng) & + = afrac(iset)%val(iloc:gfrom(iset)%ng-1) + ENDIF + + afrac(iset)%val(iloc) = area + ELSE + afrac(iset)%val(iloc) = afrac(iset)%val(iloc) + area + ENDIF + + IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN + CALL expand_list (gfrom(iset)%ilat, 0.2_r8) + CALL expand_list (gfrom(iset)%ilon, 0.2_r8) + CALL expand_list (afrac(iset)%val, 0.2_r8) + ENDIF + + CALL insert_into_sorted_list1 ( & + ix, ng_lat(iy), list_lat(iy)%val, iloc) + + IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN + CALL expand_list (list_lat(iy)%val, 0.2_r8) + ENDIF + + ENDIF + + IF (ix == xe(ilon)) EXIT + ix = mod(ix,fgrid%nlon) + 1 + ENDDO + ENDDO + + ENDDO + ENDDO + + deallocate (ys) + deallocate (yn) + deallocate (xw) + deallocate (xe) + + ng_all = sum(ng_lat) + allocate (xlist(ng_all)) + allocate (ylist(ng_all)) + + ig = 0 + DO iy = 1, fgrid%nlat + DO ix = 1, ng_lat(iy) + ig = ig + 1 + xlist(ig) = list_lat(iy)%val(ix) + ylist(ig) = iy + ENDDO + ENDDO + + deallocate (ng_lat) + DO iy = 1, fgrid%nlat + deallocate (list_lat(iy)%val) + ENDDO + deallocate (list_lat) + +#ifdef USEMPI + allocate (ipt (ng_all)) + allocate (msk (ng_all)) + DO ig = 1, ng_all + xblk = fgrid%xblk(xlist(ig)) + yblk = fgrid%yblk(ylist(ig)) + ipt(ig) = gblock%pio(xblk,yblk) + ENDDO +#endif + + allocate (this%glist (0:p_np_io-1)) + DO iproc = 0, p_np_io-1 +#ifdef USEMPI + msk = (ipt == p_address_io(iproc)) + ng = count(msk) +#else + ng = ng_all +#endif + + this%glist(iproc)%ng = ng + + IF (ng > 0) THEN + allocate (this%glist(iproc)%ilat (ng)) + allocate (this%glist(iproc)%ilon (ng)) + +#ifdef USEMPI + this%glist(iproc)%ilon = pack(xlist, msk) + this%glist(iproc)%ilat = pack(ylist, msk) +#else + this%glist(iproc)%ilon = xlist + this%glist(iproc)%ilat = ylist +#endif + ENDIF + ENDDO + +#ifdef USEMPI + deallocate (ipt) + deallocate (msk) +#endif + + allocate (this%address (pixelset%nset)) + allocate (this%areapart (pixelset%nset)) + + allocate (this%npart (pixelset%nset)) + + DO iset = 1, pixelset%nset + + ng = gfrom(iset)%ng + + this%npart(iset) = ng + + allocate (this%address(iset)%val (2,ng)) + allocate (this%areapart(iset)%val (ng)) + + this%areapart(iset)%val = afrac(iset)%val(1:ng) + + IF (pixelset%has_shared) THEN + this%areapart(iset)%val = this%areapart(iset)%val * pixelset%pctshared(iset) + ENDIF + + DO ig = 1, gfrom(iset)%ng + ilon = gfrom(iset)%ilon(ig) + ilat = gfrom(iset)%ilat(ig) + xblk = fgrid%xblk(ilon) + yblk = fgrid%yblk(ilat) + +#ifdef USEMPI + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + + this%address(iset)%val(1,ig) = iproc + this%address(iset)%val(2,ig) = find_in_sorted_list2 ( & + ilon, ilat, this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + ENDDO + ENDDO + + deallocate (xlist) + deallocate (ylist) + + DO iset = 1, pixelset%nset + deallocate (afrac(iset)%val ) + deallocate (gfrom(iset)%ilon) + deallocate (gfrom(iset)%ilat) + ENDDO + + deallocate (afrac) + deallocate (gfrom) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iproc = 0, p_np_io-1 + idest = p_address_io(iproc) + smesg = (/p_iam_glb, this%glist(iproc)%ng/) + + CALL mpi_send (smesg, 2, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + + IF (this%glist(iproc)%ng > 0) THEN + CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO + + ENDIF + + IF (p_is_io) THEN + + allocate (this%glist (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (rmesg, 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nrecv = rmesg(2) + iproc = p_itis_worker(isrc) + + this%glist(iproc)%ng = nrecv + + IF (nrecv > 0) THEN + allocate (this%glist(iproc)%ilon (nrecv)) + allocate (this%glist(iproc)%ilat (nrecv)) + + CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + ENDDO + + ENDIF +#endif + + IF (p_is_worker) THEN + IF (this%npset > 0) THEN + allocate (this%areapset (this%npset)) + this%areapset(:) = 0. + ENDIF + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + this%areapset(iset) = sum(this%areapart(iset)%val) + ENDIF + ENDDO + ENDIF + + IF (p_is_io) CALL allocate_block_data (fgrid, this%areagrid) + IF (p_is_worker) THEN + IF (this%npset > 0) THEN + allocate (msk (this%npset)) + msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 + ENDIF + ENDIF + CALL this%get_sumarea (this%areagrid, msk) + + IF (allocated(msk)) deallocate(msk) + + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE spatial_mapping_build_arealweighted + + !------------------------------------------ + SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_Pixelset + USE MOD_Utils + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(grid_type), intent(in) :: fgrid + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + integer, allocatable :: ys(:), yn(:), xw(:), xe(:) + integer, allocatable :: xlist(:), ylist(:), ipt(:) + + real(r8), allocatable :: rlon_pset(:), rlat_pset(:) + real(r8), allocatable :: nwgt(:), swgt(:), wwgt(:), ewgt(:) + + logical, allocatable :: msk(:) + + integer :: iset, ilat, ilon, iwest, ieast, ie, ipxl + integer :: nglist, iloc, ng, ig + integer :: iworker, iproc, iio, idest, isrc, nrecv + integer :: rmesg(2), smesg(2) + integer :: iy, ix, xblk, yblk, xloc, yloc + integer :: ipxstt, ipxend + + real(r8) :: lon, lonw, lone, latn, lats + real(r8) :: distn, dists, distw, diste, diffw, diffe, areathis + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + + write(*,*) + write(*,"(A, I0, A, I0, A)") & + 'Building bilinear interpolation from grid to pixel set: ', & + fgrid%nlat, ' grids in latitude ', fgrid%nlon, ' grids in longitude.' + write(*,*) + + IF (.not. (lon_between_floor(pixel%edgew, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)) & + .and. lon_between_ceil(pixel%edgee, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)))) THEN + write(*,'(A)') 'Warning: Grid does not cover longitude range of modeling region.' + ENDIF + + IF (fgrid%yinc == 1) THEN + IF (.not. ((pixel%edges >= fgrid%lat_s(1)) & + .and. (pixel%edgen <= fgrid%lat_n(fgrid%nlat)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ELSE + IF (.not. ((pixel%edges >= fgrid%lat_s(fgrid%nlat)) & + .and. (pixel%edgen <= fgrid%lat_n(1)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ENDIF + + ENDIF + + this%grid%nlat = fgrid%nlat + this%grid%nlon = fgrid%nlon + + allocate (this%grid%xblk (size(fgrid%xblk))); this%grid%xblk = fgrid%xblk + allocate (this%grid%yblk (size(fgrid%yblk))); this%grid%yblk = fgrid%yblk + allocate (this%grid%xloc (size(fgrid%xloc))); this%grid%xloc = fgrid%xloc + allocate (this%grid%yloc (size(fgrid%yloc))); this%grid%yloc = fgrid%yloc + allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt + allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt + + IF (p_is_worker) THEN + + allocate (this%grid%lat_s(this%grid%nlat)); this%grid%lat_s = fgrid%lat_s + allocate (this%grid%lat_n(this%grid%nlat)); this%grid%lat_n = fgrid%lat_n + allocate (this%grid%lon_w(this%grid%nlon)); this%grid%lon_w = fgrid%lon_w + allocate (this%grid%lon_e(this%grid%nlon)); this%grid%lon_e = fgrid%lon_e + allocate (this%grid%rlon (this%grid%nlon)); CALL this%grid%set_rlon () + allocate (this%grid%rlat (this%grid%nlat)); CALL this%grid%set_rlat () + + this%npset = pixelset%nset + + allocate (yn (this%npset)) + allocate (ys (this%npset)) + allocate (xw (this%npset)) + allocate (xe (this%npset)) + allocate (rlon_pset (this%npset)) + allocate (rlat_pset (this%npset)) + + CALL pixelset%get_lonlat_radian (rlon_pset, rlat_pset) + + allocate (xlist(4*this%npset)) + allocate (ylist(4*this%npset)) + + allocate (nwgt (this%npset)) + allocate (swgt (this%npset)) + allocate (wwgt (this%npset)) + allocate (ewgt (this%npset)) + + nglist = 0 + + DO iset = 1, this%npset + + IF (this%grid%rlat(1) > this%grid%rlat(this%grid%nlat)) THEN + ! from north to south + ilat = 1 + DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat < this%grid%nlat)) + ilat = ilat + 1 + ENDDO + + IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN + yn(iset) = max(ilat-1,1) + ys(iset) = ilat + ELSE + yn(iset) = this%grid%nlat + ys(iset) = this%grid%nlat + ENDIF + ELSE + ! from south to north + ilat = this%grid%nlat + DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat > 1)) + ilat = ilat - 1 + ENDDO + + IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN + yn(iset) = min(ilat+1,this%grid%nlat) + ys(iset) = ilat + ELSE + yn(iset) = 1 + ys(iset) = 1 + ENDIF + ENDIF + + IF (yn(iset) /= ys(iset)) THEN + latn = this%grid%rlat(yn(iset)) + lats = this%grid%rlat(ys(iset)) + distn = arclen(rlat_pset(iset), rlon_pset(iset), latn, rlon_pset(iset)) + dists = arclen(rlat_pset(iset), rlon_pset(iset), lats, rlon_pset(iset)) + nwgt(iset) = dists/(dists+distn) + swgt(iset) = distn/(dists+distn) + ELSE + nwgt(iset) = 1.0 + swgt(iset) = 0.0 + ENDIF + + + lon = rlon_pset(iset)*180.0/pi + CALL normalize_longitude (lon) + + DO iwest = 1, this%grid%nlon + lonw = this%grid%rlon(iwest) *180.0/pi + CALL normalize_longitude (lonw) + + ieast = mod(iwest,this%grid%nlon) + 1 + lone = this%grid%rlon(ieast)*180.0/pi + CALL normalize_longitude (lone) + + IF (lon_between_floor(lon, lonw, lone)) EXIT + ENDDO + + xw(iset) = iwest + xe(iset) = ieast + + ! for the case grid does not cover [-180,180) + IF ((iwest == this%grid%nlon) .and. (this%grid%nlon > 1)) THEN + IF (lon_between_floor( & + this%grid%lon_e(this%grid%nlon), lonw, this%grid%lon_w(1))) THEN + + diffw = lon - lonw; IF (diffw < 0) diffw = diffw + 360.0 + diffe = lone - lon; IF (diffe < 0) diffe = diffe + 360.0 + + IF (diffw > diffe) THEN + xw(iset) = ieast + xe(iset) = ieast + ELSE + xw(iset) = iwest + xe(iset) = iwest + ENDIF + + ENDIF + ENDIF + + IF (xw(iset) /= xe(iset)) THEN + lonw = this%grid%rlon(xw(iset)) + lone = this%grid%rlon(xe(iset)) + distw = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lonw) + diste = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lone) + wwgt(iset) = diste/(distw+diste) + ewgt(iset) = distw/(distw+diste) + ELSE + wwgt(iset) = 1.0 + ewgt(iset) = 0.0 + ENDIF + + CALL insert_into_sorted_list2 ( xw(iset), yn(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xe(iset), yn(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xw(iset), ys(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xe(iset), ys(iset), nglist, xlist, ylist, iloc) + + ENDDO + +#ifdef USEMPI + allocate (ipt (nglist)) + allocate (msk (nglist)) + DO ig = 1, nglist + xblk = this%grid%xblk(xlist(ig)) + yblk = this%grid%yblk(ylist(ig)) + ipt(ig) = gblock%pio(xblk,yblk) + ENDDO +#endif + + allocate (this%glist (0:p_np_io-1)) + DO iproc = 0, p_np_io-1 +#ifdef USEMPI + msk = (ipt == p_address_io(iproc)) + ng = count(msk) +#else + ng = nglist +#endif + + this%glist(iproc)%ng = ng + + IF (ng > 0) THEN + allocate (this%glist(iproc)%ilat (ng)) + allocate (this%glist(iproc)%ilon (ng)) + +#ifdef USEMPI + this%glist(iproc)%ilon = pack(xlist(1:nglist), msk) + this%glist(iproc)%ilat = pack(ylist(1:nglist), msk) +#else + this%glist(iproc)%ilon = xlist(1:nglist) + this%glist(iproc)%ilat = ylist(1:nglist) +#endif + ENDIF + + ENDDO + + deallocate (xlist) + deallocate (ylist) + +#ifdef USEMPI + deallocate (ipt) + deallocate (msk) +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + idest = p_address_io(iproc) + smesg = (/p_iam_glb, this%glist(iproc)%ng/) + + CALL mpi_send (smesg, 2, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + + IF (this%glist(iproc)%ng > 0) THEN + CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO + ENDIF + + IF (p_is_io) THEN + + allocate (this%glist (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + + CALL mpi_recv (rmesg, 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = rmesg(1) + nrecv = rmesg(2) + iproc = p_itis_worker(isrc) + + this%glist(iproc)%ng = nrecv + + IF (nrecv > 0) THEN + allocate (this%glist(iproc)%ilon (nrecv)) + allocate (this%glist(iproc)%ilat (nrecv)) + + CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF + + ENDDO + + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_worker) THEN + + allocate (this%address (this%npset)) + allocate (this%npart (this%npset)) + allocate (this%areapart(this%npset)) + + DO iset = 1, pixelset%nset + + this%npart(iset) = 4 + + allocate (this%address (iset)%val(2,4)) + allocate (this%areapart(iset)%val(4)) + + areathis = 0. + + ie = pixelset%ielm(iset) + + ipxstt = pixelset%ipxstt(iset) + ipxend = pixelset%ipxend(iset) + + ! deal with 2m WMO patch + IF (ipxstt==-1 .and. ipxend==-1) THEN + ipxstt = 1 + ipxend = mesh(ie)%npxl + ENDIF + + DO ipxl = ipxstt, ipxend + areathis = areathis + areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + + IF (pixelset%has_shared) THEN + areathis = areathis * pixelset%pctshared(iset) + ENDIF + + ! northwest grid + ix = xw(iset); iy = yn(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,1) = iproc + this%address(iset)%val(2,1) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(1) = areathis * nwgt(iset) * wwgt(iset) + + ! northeast grid + ix = xe(iset); iy = yn(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,2) = iproc + this%address(iset)%val(2,2) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(2) = areathis * nwgt(iset) * ewgt(iset) + + ! southwest + ix = xw(iset); iy = ys(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,3) = iproc + this%address(iset)%val(2,3) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(3) = areathis * swgt(iset) * wwgt(iset) + + ! southeast + ix = xe(iset); iy = ys(iset); +#ifdef USEMPI + xblk = this%grid%xblk(ix) + yblk = this%grid%yblk(iy) + iproc = p_itis_io(gblock%pio(xblk,yblk)) +#else + iproc = 0 +#endif + this%address(iset)%val(1,4) = iproc + this%address(iset)%val(2,4) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(4) = areathis * swgt(iset) * ewgt(iset) + + ENDDO + + ENDIF + + IF (p_is_worker) THEN + IF (this%npset > 0) THEN + allocate (this%areapset (this%npset)) + ENDIF + DO iset = 1, this%npset + this%areapset(iset) = sum(this%areapart(iset)%val) + ENDDO + ENDIF + + IF (p_is_io) CALL allocate_block_data (fgrid, this%areagrid) + IF (p_is_worker) THEN + IF (this%npset > 0) THEN + allocate (msk (this%npset)) + msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 + ENDIF + ENDIF + CALL this%get_sumarea (this%areagrid, msk) + + + IF (allocated(this%grid%lat_s)) deallocate(this%grid%lat_s) + IF (allocated(this%grid%lat_n)) deallocate(this%grid%lat_n) + IF (allocated(this%grid%lon_w)) deallocate(this%grid%lon_w) + IF (allocated(this%grid%lon_e)) deallocate(this%grid%lon_e) + IF (allocated(this%grid%rlon )) deallocate(this%grid%rlon ) + IF (allocated(this%grid%rlat )) deallocate(this%grid%rlat ) + + IF (allocated(yn)) deallocate(yn) + IF (allocated(ys)) deallocate(ys) + IF (allocated(xw)) deallocate(xw) + IF (allocated(xe)) deallocate(xe) + + IF (allocated(rlon_pset)) deallocate(rlon_pset) + IF (allocated(rlat_pset)) deallocate(rlat_pset) + + IF (allocated(nwgt)) deallocate(nwgt) + IF (allocated(swgt)) deallocate(swgt) + IF (allocated(wwgt)) deallocate(wwgt) + IF (allocated(ewgt)) deallocate(ewgt) + + IF (allocated(msk)) deallocate(msk) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + END SUBROUTINE spatial_mapping_build_bilinear + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(in) :: missing_value + + logical, intent(inout), optional :: pmask(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart, iblkme + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + this%has_missing_value = .true. + this%missing_value = missing_value + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (gdata%blk(xblk,yblk)%val == missing_value) + this%areagrid%blk(xblk,yblk)%val = 0. + ENDWHERE + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + + DO iset = 1, this%npset + + this%areapset(iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) == missing_value) THEN + this%areapart(iset)%val(ipart) = 0. + ELSE + this%areapset(iset) = this%areapset(iset) + this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + IF (present(pmask)) THEN + pmask(iset) = (this%areapset(iset) > 0.) + ENDIF + + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_set_missing_value + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mode) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + character(len=*), intent(in), optional :: input_mode + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + character(len=256) :: inmode + real(r8) :: sumwt + + IF (p_is_worker) THEN + + inmode = 'average' + IF (present(input_mode)) inmode = trim(input_mode) + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:) = spv + ELSE + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(spv)) THEN + IF (pdata(iset) == spv) CYCLE + ENDIF + + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + IF ((this%npart(iset) > 0) .and. (trim(inmode) == 'total')) THEN + sumwt = sum(this%areapart(iset)%val) + ELSE + sumwt = 1. + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (present(spv)) THEN + IF (pbuff(iproc)%val(iloc) /= spv) THEN + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset)/sumwt * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(iloc) = & + pdata(iset)/sumwt * this%areapart(iset)%val(ipart) + ENDIF + ELSE + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset)/sumwt * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + IF (present(spv)) THEN + IF (gbuff(ig) /= spv) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ELSE + gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ELSE + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + + END SUBROUTINE spatial_mapping_pset2grid_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:,:) + type(block_data_real8_3d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart + integer :: xblk, yblk, xloc, yloc + integer :: lb1, ub1, i1 + + real(r8), allocatable :: gbuff(:,:) + type(pointer_real8_2d), allocatable :: pbuff(:) + + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + lb1 = lbound(pdata,1) + ub1 = ubound(pdata,1) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (lb1:ub1, this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:,:) = spv + ELSE + pbuff(iproc)%val(:,:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + DO i1 = lb1, ub1 + IF (present(spv)) THEN + IF (pdata(i1,iset) /= spv) THEN + IF (pbuff(iproc)%val(i1,iloc) /= spv) THEN + pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & + + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(i1,iloc) = & + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDIF + ELSE + pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & + + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, & + (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + lb1 = gdata%lb1 + ub1 = gdata%ub1 + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (lb1:ub1, this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, & + (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + DO i1 = lb1, ub1 + IF (present(spv)) THEN + IF (gbuff(i1,ig) /= spv) THEN + IF (gdata%blk(xblk,yblk)%val(i1,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) + ELSE + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = gbuff(i1,ig) + ENDIF + ENDIF + ELSE + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) + ENDIF + ENDDO + ENDDO + + deallocate (gbuff) + ENDIF + + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_3d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:,:,:) + type(block_data_real8_4d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart + integer :: xblk, yblk, xloc, yloc + integer :: lb1, ub1, i1, ndim1, lb2, ub2, i2, ndim2 + + real(r8), allocatable :: gbuff(:,:,:) + type(pointer_real8_3d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + lb1 = lbound(pdata,1) + ub1 = ubound(pdata,1) + ndim1 = ub1 - lb1 + 1 + + lb2 = lbound(pdata,2) + ub2 = ubound(pdata,2) + ndim2 = ub2 - lb2 + 1 + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:,:,:) = spv + ELSE + pbuff(iproc)%val(:,:,:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + IF (present(spv)) THEN + IF (pdata(i1,i2,iset) /= spv) THEN + IF (pbuff(iproc)%val(i1,i2,iloc) /= spv) THEN + pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & + + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(i1,i2,iloc) = & + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDIF + ELSE + pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & + + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + lb1 = gdata%lb1 + ub1 = gdata%ub1 + ndim1 = ub1 - lb1 + 1 + + lb2 = gdata%lb2 + ub2 = gdata%ub2 + ndim2 = ub2 - lb2 + 1 + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + IF (present(spv)) THEN + IF (gbuff(i1,i2,ig) /= spv) THEN + IF (gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) + ELSE + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = gbuff(i1,i2,ig) + ENDIF + ENDIF + ELSE + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) + ENDIF + ENDDO + ENDDO + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_4d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = spval + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(spv)) THEN + IF (pdata(iset) == spv) CYCLE + ENDIF + + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) /= spval) THEN + pbuff(iproc)%val(iloc) = max(pdata(iset), pbuff(iproc)%val(iloc)) + ELSE + pbuff(iproc)%val(iloc) = pdata(iset) + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + CALL flush_block_data (gdata, spval) + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + IF (gbuff(ig) /= spval) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + max(gdata%blk(xblk,yblk)%val(xloc,yloc), gbuff(ig)) + ELSE + gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_max + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, spv) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata (:) + integer , intent(in) :: settyp(:) + integer , intent(in) :: typidx(:) + type(block_data_real8_3d), intent(inout) :: gdata + + real(r8), intent(in) :: spv + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart, ityp, ntyps + integer :: xblk, yblk, xloc, yloc + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff (:) + + IF (p_is_worker) THEN + allocate (pbuff (0:p_np_io-1)) + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + ENDIF + ENDDO + ENDIF + + IF (p_is_io) THEN + CALL flush_block_data (gdata, spv) + ENDIF + + ntyps = size(typidx) + + DO ityp = 1, ntyps + + IF (p_is_worker) THEN + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + pbuff(iproc)%val(:) = spv + ENDIF + ENDDO + + DO iset = 1, this%npset + IF ((settyp(iset) == typidx(ityp)) .and. (pdata(iset) /= spv)) THEN + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) /= spv) THEN + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(iloc) = & + pdata(iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDIF + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + IF (gbuff(ig) /= spv) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) + gbuff(ig) + ELSE + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + + ENDDO + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + ENDDO + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_split + + ! ------------------------------ + SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(inout) :: sumarea + logical, intent(in), optional :: filter(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(filter)) THEN + IF (.not. filter(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) + this%areapart(iset)%val(ipart) + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + CALL flush_block_data (sumarea, 0.0_r8) + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + sumarea%blk(xblk,yblk)%val(xloc,yloc) = & + sumarea%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_get_sumarea + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(out) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata(iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (this%areapart(iset)%val(ipart) > 0) THEN + pdata(iset) = pdata(iset) & + + pbuff(iproc)%val(iloc) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + pdata(iset) = pdata(iset) / this%areapset(iset) + + ELSE + pdata(iset) = spval + ENDIF + + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2pset_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_3d), intent(in) :: gdata + integer, intent(in) :: ndim1 + real(r8), intent(out) :: pdata(:,:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart, i + + real(r8), allocatable :: gbuff(:,:) + type(pointer_real8_2d), allocatable :: pbuff(:) + + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (ndim1, this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(:,ig) = gdata%blk(xblk,yblk)%val(:,xloc,yloc) + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, ndim1 * this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, ndim1 * this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata(:,iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (this%areapart(iset)%val(ipart) > 0) THEN + pdata(:,iset) = pdata(:,iset) & + + pbuff(iproc)%val(:,iloc) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + pdata(:,iset) = pdata(:,iset) / this%areapset(iset) + + ELSE + pdata(:,iset) = spval + ENDIF + + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2pset_3d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_int32_2d), intent(in) :: gdata + integer, intent(out) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + integer, allocatable :: gbuff(:) + type(pointer_int32_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (this%areapset(iset) > 0.) THEN + ipart = maxloc(this%areapart(iset)%val, dim=1) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + pdata(iset) = pbuff(iproc)%val(iloc) + ELSE + pdata(iset) = -9999 + ENDIF + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_dominant_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(inout) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + real(r8), allocatable :: pdata_tem(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + allocate (pdata_tem (size(pdata))) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata_tem(iset) = 0._r8 + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pdata_tem(iset) = pdata_tem(iset) & + + pdata(iset) * pbuff(iproc)%val(iloc) * this%areapart(iset)%val(ipart) + ENDDO + + pdata_tem(iset) = pdata_tem(iset) / this%areapset(iset) + + ELSE + pdata_tem(iset) = 0._r8 + ENDIF + + ENDDO + + pdata = pdata_tem + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + deallocate (pdata_tem) + + ENDIF + + END SUBROUTINE spatial_mapping_varvalue_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + type(pointer_real8_1d), intent(inout) :: sdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + sdata(iset)%val(ipart) = pbuff(iproc)%val(iloc) + ENDDO + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), intent(in) :: sdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + integer :: iblkme + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDDO + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + sdata(iset)%val(ipart) * this%areapart(iset)%val(ipart) + ENDDO + ENDDO + +#ifdef USEMPI + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + idest = p_address_io(iproc) + CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDDO +#endif + + ENDIF + + IF (p_is_io) THEN + + CALL flush_block_data (gdata, 0.0_r8) + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_worker(iproc) + CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + gbuff = pbuff(0)%val +#endif + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (this%areagrid%blk(xblk,yblk)%val > 0) + gdata%blk(xblk,yblk)%val = & + gdata%blk(xblk,yblk)%val / this%areagrid%blk(xblk,yblk)%val + ELSEWHERE + gdata%blk(xblk,yblk)%val = this%missing_value + ENDWHERE + ENDDO + + ENDIF + + IF (p_is_worker) THEN + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_part2grid + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + type(pointer_real8_1d), intent(inout) :: sdata(:) + + ! Local variables + integer :: iblkme, xblk, yblk, iset, ipart + + type(block_data_real8_2d) :: sumdata + type(pointer_real8_1d), allocatable :: scaldata(:) + + + IF (p_is_io) CALL allocate_block_data (this%grid, sumdata) + IF (p_is_worker) CALL this%allocate_part (scaldata) + + CALL this%part2grid (sdata, sumdata) + + IF (p_is_io) THEN + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (sumdata%blk(xblk,yblk)%val /= this%missing_value) + sumdata%blk(xblk,yblk)%val = gdata%blk(xblk,yblk)%val / sumdata%blk(xblk,yblk)%val + ENDWHERE + ENDDO + + ENDIF + + CALL this%grid2part (sumdata, scaldata) + + IF (p_is_worker) THEN + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + IF (this%areapart(iset)%val(ipart) > 0.) THEN + sdata(iset)%val(ipart) = sdata(iset)%val(ipart) * scaldata(iset)%val(ipart) + ELSE + sdata(iset)%val(ipart) = this%missing_value + ENDIF + ENDDO + ENDDO + + ENDIF + + IF (p_is_worker) deallocate(scaldata) + + END SUBROUTINE spatial_mapping_normalize + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_part2pset (this, sdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), intent(in) :: sdata(:) + real(r8), intent(out) :: pdata(:) + + ! Local variables + integer :: iset + + IF (p_is_worker) THEN + + pdata(:) = spval + + DO iset = 1, this%npset + IF (this%areapset(iset) > 0) THEN + pdata(iset) = sum(sdata(iset)%val * this%areapart(iset)%val) / this%areapset(iset) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE spatial_mapping_part2pset + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_allocate_part (this, datapart) + + USE MOD_SPMD_Task + USE MOD_DataType + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), allocatable :: datapart (:) + + ! Local variables + integer :: iset + + IF (p_is_worker) THEN + + IF (this%npset > 0) THEN + allocate (datapart (this%npset)) + ENDIF + + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + allocate (datapart(iset)%val (this%npart(iset))) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE spatial_mapping_allocate_part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_deallocate_part (this, datapart) + + USE MOD_SPMD_Task + USE MOD_DataType + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), allocatable :: datapart (:) + + ! Local variables + integer :: iset + + IF (p_is_worker) THEN + + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + deallocate (datapart(iset)%val) + ENDIF + ENDDO + + IF (this%npset > 0) THEN + deallocate (datapart) + ENDIF + + ENDIF + + END SUBROUTINE spatial_mapping_deallocate_part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_free_mem (this) + + USE MOD_SPMD_Task + IMPLICIT NONE + + type (spatial_mapping_type) :: this + + ! Local variables + integer :: iproc, iset + + IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) + IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) + + IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) + IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) + + IF (allocated (this%grid%xcnt)) deallocate (this%grid%xcnt) + IF (allocated (this%grid%ycnt)) deallocate (this%grid%ycnt) + + IF (allocated(this%glist)) THEN + DO iproc = lbound(this%glist,1), ubound(this%glist,1) + IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) + IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) + ENDDO + + deallocate (this%glist) + ENDIF + + IF (p_is_worker) THEN + + IF (allocated(this%npart)) deallocate(this%npart) + + IF (allocated(this%address)) THEN + DO iset = lbound(this%address,1), ubound(this%address,1) + IF (allocated(this%address(iset)%val)) THEN + deallocate (this%address(iset)%val) + ENDIF + ENDDO + + deallocate (this%address) + ENDIF + + IF (allocated(this%areapart)) THEN + DO iset = lbound(this%areapart,1), ubound(this%areapart,1) + IF (allocated(this%areapart(iset)%val)) THEN + deallocate (this%areapart(iset)%val) + ENDIF + ENDDO + + deallocate (this%areapart) + ENDIF + + IF (allocated(this%areapset)) deallocate(this%areapset) + + ENDIF + + END SUBROUTINE spatial_mapping_free_mem + + SUBROUTINE forc_free_mem_spatial_mapping(this) + + USE MOD_SPMD_Task + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + ! Local variables + integer :: iproc, iset + + IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) + IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) + + IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) + IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) + + IF (allocated (this%grid%xcnt)) deallocate (this%grid%xcnt) + IF (allocated (this%grid%ycnt)) deallocate (this%grid%ycnt) + + IF (allocated(this%glist)) THEN + DO iproc = lbound(this%glist,1), ubound(this%glist,1) + IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) + IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) + ENDDO + + deallocate (this%glist) + ENDIF + + IF (p_is_worker) THEN + + IF (allocated(this%npart)) deallocate(this%npart) + + IF (allocated(this%address)) THEN + DO iset = lbound(this%address,1), ubound(this%address,1) + IF (allocated(this%address(iset)%val)) THEN + deallocate (this%address(iset)%val) + ENDIF + ENDDO + + deallocate (this%address) + ENDIF + + IF (allocated(this%areapart)) THEN + DO iset = lbound(this%areapart,1), ubound(this%areapart,1) + IF (allocated(this%areapart(iset)%val)) THEN + deallocate (this%areapart(iset)%val) + ENDIF + ENDDO + + deallocate (this%areapart) + ENDIF + + IF (allocated(this%areapset)) deallocate(this%areapset) + + ENDIF + + END SUBROUTINE forc_free_mem_spatial_mapping + +END MODULE MOD_SpatialMapping diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 new file mode 100644 index 0000000000..0b1b63cf2d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 @@ -0,0 +1,711 @@ +#include + +MODULE MOD_TimeManager + +! -------------------------------------------------------- +! +! !DESCRIPTION: +! Time manager module: to provide some basic operations for time stamp +! +! Created by Hua Yuan, 04/2014 +! +! !REVISIONS: +! 06/28/2017, Hua Yuan: added issame() and monthday2julian() +! TODO... +! -------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + integer, dimension(0:12), parameter :: & + daysofmonth_leap = (/0,31,29,31,30,31,30,31,31,30,31,30,31/) ,& + daysofmonth_noleap = (/0,31,28,31,30,31,30,31,31,30,31,30,31/) ,& + accdaysofmonth_leap = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) ,& + accdaysofmonth_noleap = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + + type :: timestamp + integer :: year, day, sec + END type timestamp + + INTERFACE ASSIGNMENT (=) + MODULE procedure assignidate + MODULE procedure assigntstamp + END INTERFACE + + INTERFACE OPERATOR (+) + MODULE procedure addsec + END INTERFACE + + INTERFACE OPERATOR (-) + MODULE procedure subtstamp + END INTERFACE + + INTERFACE OPERATOR (<=) + MODULE procedure lessequal + END INTERFACE + + INTERFACE OPERATOR (<) + MODULE procedure lessthan + END INTERFACE + + INTERFACE OPERATOR (==) + MODULE procedure isnull + MODULE procedure besame + END INTERFACE + + INTERFACE calendarday + MODULE procedure calendarday_date + MODULE procedure calendarday_stamp + END INTERFACE + + logical, SAVE :: isgreenwich + real(r8),SAVE :: LocalLongitude = 0. + PUBLIC get_calday + +CONTAINS + + SUBROUTINE initimetype(greenwich) + + IMPLICIT NONE + logical, intent(in) :: greenwich + + isgreenwich = greenwich + +#ifndef SinglePoint + IF (.not. isgreenwich) THEN + write(*,*) 'Warning: Please USE Greenwich time for non-SinglePoint case.' + isgreenwich = .true. + ENDIF +#endif + + END SUBROUTINE initimetype + + SUBROUTINE assignidate(tstamp, idate) + + IMPLICIT NONE + type(timestamp), intent(inout) :: tstamp + integer, intent(in) :: idate(3) + + tstamp%year = idate(1) + tstamp%day = idate(2) + tstamp%sec = idate(3) + + END SUBROUTINE assignidate + + SUBROUTINE assigntstamp(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(out) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + + tstamp1%year = tstamp2%year + tstamp1%day = tstamp2%day + tstamp1%sec = tstamp2%sec + + END SUBROUTINE assigntstamp + + FUNCTION addsec(tstamp, sec) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp + integer, intent(in) :: sec + type(timestamp) :: addsec + integer :: maxday + + addsec = tstamp + addsec%sec = addsec%sec + sec + DO WHILE (addsec%sec > 86400) + addsec%sec = addsec%sec - 86400 + IF( isleapyear(addsec%year) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + addsec%day = addsec%day + 1 + IF(addsec%day > maxday) THEN + addsec%year = addsec%year + 1 + addsec%day = 1 + ENDIF + ENDDO + DO WHILE (addsec%sec <= 0) + addsec%sec = addsec%sec + 86400 + IF( isleapyear(addsec%year-1) )THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + addsec%day = addsec%day - 1 + IF(addsec%day <= 0) THEN + addsec%year = addsec%year - 1 + addsec%day = maxday + ENDIF + ENDDO + RETURN + + END FUNCTION addsec + + FUNCTION subtstamp(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + integer :: subtstamp + + subtstamp = tstamp1%sec - tstamp2%sec + IF (subtstamp < 0) THEN + subtstamp = subtstamp + 86400 + ENDIF + RETURN + + END FUNCTION subtstamp + + logical FUNCTION lessequal(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + + integer(kind=4) :: idate1(3), idate2(3) + integer(kind=4) :: ts1, ts2 + + idate1 = (/tstamp1%year, tstamp1%day, tstamp1%sec/) + idate2 = (/tstamp2%year, tstamp2%day, tstamp2%sec/) + + CALL adj2end(idate1) + CALL adj2end(idate2) + + ts1 = idate1(1)*1000 + idate1(2) + ts2 = idate2(1)*1000 + idate2(2) + + lessequal = .false. + + IF (ts1 < ts2) lessequal = .true. + + IF (ts1==ts2 .and. idate1(3)<=idate2(3)) THEN + lessequal = .true. + ENDIF + + RETURN + + END FUNCTION lessequal + + logical FUNCTION lessthan(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + + integer(kind=4) :: idate1(3), idate2(3) + integer(kind=4) :: ts1, ts2 + + idate1 = (/tstamp1%year, tstamp1%day, tstamp1%sec/) + idate2 = (/tstamp2%year, tstamp2%day, tstamp2%sec/) + + CALL adj2end(idate1) + CALL adj2end(idate2) + + ts1 = idate1(1)*1000 + idate1(2) + ts2 = idate2(1)*1000 + idate2(2) + + lessthan = .false. + + IF (ts1 < ts2) lessthan = .true. + + IF (ts1==ts2 .and. idate1(3) 86400) THEN + + idate(3) = idate(3) - 86400 + idate(2) = idate(2) + 1 + + IF ( isleapyear(idate(1)) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + + IF(idate(2) > maxday) THEN + idate(1) = idate(1) + 1 + idate(2) = 1 + ENDIF + ENDIF + + END SUBROUTINE localtime2gmt + + SUBROUTINE ticktime(deltim, idate) + + IMPLICIT NONE + + real(r8),intent(in) :: deltim + integer, intent(inout) :: idate(3) + integer maxday + + idate(3) = idate(3) + nint(deltim) + IF (idate(3) > 86400) THEN + + idate(3) = idate(3) - 86400 + idate(2) = idate(2) + 1 + + IF ( isleapyear(idate(1)) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + + IF(idate(2) > maxday) THEN + idate(1) = idate(1) + 1 + idate(2) = 1 + ENDIF + ENDIF + + END SUBROUTINE ticktime + + real(r8) FUNCTION calendarday_date(date) + + IMPLICIT NONE + integer, intent(in) :: date(3) + + integer idate(3) + + idate(:) = date(:) + + IF ( .not. isgreenwich ) THEN + CALL localtime2gmt(idate) + ENDIF + + calendarday_date = float(idate(2)) + float(idate(3))/86400. + RETURN + + END FUNCTION calendarday_date + + real(r8) FUNCTION calendarday_stamp(stamp) + + IMPLICIT NONE + type(timestamp), intent(in) :: stamp + + integer idate(3) + + idate(1) = stamp%year + idate(2) = stamp%day + idate(3) = stamp%sec + + IF ( .not. isgreenwich ) THEN + CALL localtime2gmt(idate) + ENDIF + + calendarday_stamp = float(idate(2)) + float(idate(3))/86400. + RETURN + + END FUNCTION calendarday_stamp + + integer FUNCTION get_calday(mmdd,isleap) + + IMPLICIT NONE + integer, intent(in) :: mmdd + logical, intent(in) :: isleap + + integer imonth, iday + + imonth = mmdd / 100 + iday = mod(mmdd,100) + IF(isleap)THEN + get_calday = sum(daysofmonth_leap(0:imonth-1)) + iday + ELSE + get_calday = sum(daysofmonth_noleap(0:imonth-1)) + iday + ENDIF + RETURN + END FUNCTION get_calday + + integer FUNCTION minutes_since_1900 (year, julianday, second) + + USE MOD_UserDefFun + IMPLICIT NONE + integer, intent(in) :: year, julianday, second + + integer :: refyear(10) = (/1, 1900, 1950, 1980, 1990, 2000, 2005, 2010, 2015, 2020/) + integer :: refval (10) = (/-998776800,0,26297280,42075360,47335680,52594560,55225440,& + 57854880,60484320,63113760/) + integer :: iref, iyear + + iref = findloc_ud(refyear <= year, back=.true.) + minutes_since_1900 = refval(iref) + DO iyear = refyear(iref), year-1 + IF (isleapyear(iyear)) THEN + minutes_since_1900 = minutes_since_1900 + 527040 + ELSE + minutes_since_1900 = minutes_since_1900 + 525600 + ENDIF + ENDDO + + minutes_since_1900 = minutes_since_1900 + (julianday-1) * 1440 + minutes_since_1900 = minutes_since_1900 + second/60 + + END FUNCTION minutes_since_1900 + + ! ----------------------------------------------------------------------- + SUBROUTINE gmt2local(idate, long, ldate) + + ! !DESCRIPTION: + ! A SUBROUTINE to calculate local time + ! !PURPOSE + ! Convert GMT time to local time in global run + ! ----------------------------------------------------------------------- + + IMPLICIT NONE + + integer , intent(in ) :: idate(3) + real(r8), intent(in ) :: long + real(r8), intent(out) :: ldate(3) + + integer :: maxday + real(r8) :: tdiff + + tdiff = long/15.*3600 + + ldate(3) = idate(3) + tdiff + ldate(1) = idate(1) + + IF (ldate(3) < 0) THEN + + ldate(3) = 86400 + ldate(3) + ldate(2) = idate(2) - 1 + + IF (ldate(2) < 1) THEN + ldate(1) = idate(1) - 1 + IF ( isleapyear(int(ldate(1))) ) THEN + ldate(2) = 366 + ELSE + ldate(2) = 365 + ENDIF + ENDIF + + ELSEIF (ldate(3) > 86400) THEN + + ldate(3) = ldate(3) - 86400 + ldate(2) = idate(2) + 1 + + IF ( isleapyear(int(ldate(1))) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + + IF(ldate(2) > maxday) THEN + ldate(1) = idate(1) + 1 + ldate(2) = 1 + ENDIF + ELSE + ldate(2) = idate(2) + ldate(1) = idate(1) + ENDIF + + END SUBROUTINE gmt2local + + ! ----------------------------------------------------------------------- + SUBROUTINE timeweek(year, month, day, iweek) + + ! !DESCRIPTION: + ! A subroutine to calculate day of week + ! !PURPOSE + ! Calculate day of week to determine IF the day is week holiday + ! ----------------------------------------------------------------------- + + IMPLICIT NONE + + integer, intent(in ) :: year, month + integer, intent(out) :: iweek, day + + integer :: myear, mmonth + integer :: yy, mm, dd, y12, y34 + integer :: A, B, C, D, i + + integer :: monthday(0:12) + + IF ( isleapyear(year) ) THEN + monthday(:) = daysofmonth_leap(:) + ELSE + monthday(:) = daysofmonth_noleap(:) + ENDIF + + IF (month==1 .or. month==2) THEN + mmonth = month + 12 + myear = year - 1 + ELSE + mmonth = month + myear = year + ENDIF + + y12 = myear/100 + y34 = myear - y12*100 + + A = int(y34/4.) + B = int(y12/4.) + C = y12*2 + D = int(26*(mmonth+1)/10.) + + iweek = abs(mod((y34+A+B-C+D+day-1), 7)) + + DO i=1, month-1 + day = day + monthday(i) + ENDDO + + IF (iweek == 0) THEN + iweek = 7 + ENDIF + + END SUBROUTINE timeweek + +END MODULE MOD_TimeManager diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 new file mode 100644 index 0000000000..cb44a3e2b2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 @@ -0,0 +1,70 @@ +MODULE MOD_UserDefFun + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! This MODULE contains user defined functions to replace non-standard functions. +! +! Created by Shupeng Zhang, April 2024 +!----------------------------------------------------------------------------------------- + + ! ---- PUBLIC subroutines ---- + + INTERFACE isnan_ud + MODULE procedure isnan_ud_r8 + END INTERFACE isnan_ud + +CONTAINS + + ! ---------- + elemental logical FUNCTION isnan_ud_r8 (a) + + USE MOD_Precision, only: r8 + + IMPLICIT NONE + real(r8), intent(in) :: a + + isnan_ud_r8 = (a /= a) + + END FUNCTION isnan_ud_r8 + + ! ---------- + integer FUNCTION findloc_ud (array, back) + + IMPLICIT NONE + logical, intent(in) :: array(:) + logical, intent(in), optional :: back + + ! Local Variables + logical :: bb + integer :: n, i, i0, i1, ii + + n = size(array) + IF (n <= 0) THEN + findloc_ud = 0 + ELSE + + bb = .false. + IF (present(back)) THEN + bb = back + ENDIF + + IF (.not. bb) THEN + i0 = 1; i1 = n; ii = 1 + ELSE + i0 = n; i1 = 1; ii = -1 + ENDIF + + findloc_ud = 0 + DO i = i0, i1, ii + IF (array(i)) THEN + findloc_ud = i + EXIT + ENDIF + ENDDO + + ENDIF + + END FUNCTION findloc_ud + +END MODULE MOD_UserDefFun diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 new file mode 100644 index 0000000000..4f22b5b0b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 @@ -0,0 +1,2615 @@ +MODULE MOD_Utils + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! This MODULE CONTAINS utilities. +! +! !REVISIONS: +! Subroutines lmder, enorm, tridia and polint are moved from other files. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------------------------- + + ! ---- PUBLIC subroutines ---- + + PUBLIC :: normalize_longitude + + INTERFACE expand_list + MODULE procedure expand_list_int32 + MODULE procedure expand_list_int64 + MODULE procedure expand_list_real8 + END INTERFACE expand_list + + PUBLIC :: append_to_list + + INTERFACE insert_into_sorted_list1 + MODULE procedure insert_into_sorted_list1_int32 + MODULE procedure insert_into_sorted_list1_int64 + END INTERFACE insert_into_sorted_list1 + + PUBLIC :: insert_into_sorted_list2 + + INTERFACE find_in_sorted_list1 + MODULE procedure find_in_sorted_list1_int32 + MODULE procedure find_in_sorted_list1_int64 + END INTERFACE find_in_sorted_list1 + + PUBLIC :: find_in_sorted_list2 + + PUBLIC :: find_nearest_south + PUBLIC :: find_nearest_north + PUBLIC :: find_nearest_west + PUBLIC :: find_nearest_east + + PUBLIC :: lon_between_floor + PUBLIC :: lon_between_ceil + + INTERFACE quicksort + MODULE procedure quicksort_int32 + MODULE procedure quicksort_int64 + MODULE procedure quicksort_real8 + END INTERFACE quicksort + + PUBLIC :: quickselect + PUBLIC :: median + + PUBLIC :: areaquad + PUBLIC :: arclen + + INTERFACE unpack_inplace + MODULE procedure unpack_inplace_int32 + MODULE procedure unpack_inplace_real8 + MODULE procedure unpack_inplace_lastdim_real8 + END INTERFACE unpack_inplace + + PUBLIC :: num_max_frequency + + PUBLIC :: lmder + PUBLIC :: lmpar + PUBLIC :: qrfac + PUBLIC :: qrsolv + + PUBLIC :: enorm + PUBLIC :: tridia + PUBLIC :: polint + +CONTAINS + + !--------------------------------- + SUBROUTINE normalize_longitude (lon) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(inout) :: lon + + DO WHILE (lon >= 180.0) + lon = lon - 360.0 + ENDDO + + DO WHILE (lon < -180.0) + lon = lon + 360.0 + ENDDO + + END SUBROUTINE normalize_longitude + + !-------------------------------------------------- + SUBROUTINE expand_list_int32 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + integer, allocatable, intent(inout) :: list (:) + real(r8), intent(in) :: percent + + ! Local variables + integer :: n0, n1 + integer, allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_int32 + + !-------------------------------------------------- + SUBROUTINE expand_list_int64 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + integer*8, allocatable, intent(inout) :: list (:) + real(r8), intent(in) :: percent + + ! Local variables + integer :: n0, n1 + integer*8, allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_int64 + + !-------------------------------------------------- + SUBROUTINE expand_list_real8 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), allocatable, intent(inout) :: list (:) + real(r8), intent(in) :: percent + + ! Local variables + integer :: n0, n1 + real(r8), allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_real8 + + !-------------------------------------------------- + SUBROUTINE append_to_list (list1, list2) + + IMPLICIT NONE + + integer, allocatable, intent(inout) :: list1 (:) + integer, intent(in) :: list2 (:) + + ! Local variables + integer :: n1, n2 + integer, allocatable :: temp (:) + + IF (.not. allocated(list1)) THEN + n1 = 0 + ELSE + n1 = size(list1) + ENDIF + + n2 = size(list2) + + IF (n1 > 0) THEN + allocate (temp(n1)) + temp = list1 + + deallocate(list1) + allocate (list1(n1+n2)) + list1(1:n1) = temp + + deallocate (temp) + ELSE + IF (n2 > 0) allocate (list1(n2)) + ENDIF + + IF (n1 + n2 > 0) THEN + list1(n1+1:n1+n2) = list2 + ENDIF + + END SUBROUTINE append_to_list + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list1_int32 (x, n, list, iloc, is_new_out) + + IMPLICIT NONE + + integer, intent(in) :: x + integer, intent(inout) :: n + integer, intent(inout) :: list(:) + integer, intent(out) :: iloc + logical, intent(out), optional :: is_new_out + + ! Local variables + logical :: is_new + integer :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF (x <= list(1)) THEN + iloc = 1 + is_new = (x /= list(1)) + ELSEIF (x > list(n)) THEN + iloc = n + 1 + is_new = .true. + ELSEIF (x == list(n)) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF (x > list(iloc)) THEN + ileft = iloc + ELSEIF (x < list(iloc)) THEN + iright = iloc + ELSE + is_new = .false. + EXIT + ENDIF + ELSE + iloc = iright + is_new = .true. + EXIT + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + list(iloc+1:n+1) = list(iloc:n) + ENDIF + + list(iloc) = x + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list1_int32 + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list1_int64 (x, n, list, iloc, is_new_out) + + IMPLICIT NONE + + integer*8, intent(in) :: x + integer, intent(inout) :: n + integer*8, intent(inout) :: list(:) + integer, intent(out) :: iloc + logical, intent(out), optional :: is_new_out + + ! Local variables + logical :: is_new + integer :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF (x <= list(1)) THEN + iloc = 1 + is_new = (x /= list(1)) + ELSEIF (x > list(n)) THEN + iloc = n + 1 + is_new = .true. + ELSEIF (x == list(n)) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF (x > list(iloc)) THEN + ileft = iloc + ELSEIF (x < list(iloc)) THEN + iright = iloc + ELSE + is_new = .false. + EXIT + ENDIF + ELSE + iloc = iright + is_new = .true. + EXIT + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + list(iloc+1:n+1) = list(iloc:n) + ENDIF + + list(iloc) = x + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list1_int64 + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list2 (x, y, n, xlist, ylist, iloc, is_new_out) + + IMPLICIT NONE + + integer, intent(in) :: x, y + integer, intent(inout) :: n + integer, intent(inout) :: xlist(:), ylist(:) + integer, intent(out) :: iloc + logical, intent(out), optional :: is_new_out + + ! Local variables + logical :: is_new + integer :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF ((y < ylist(1)) .or. ((y == ylist(1)) .and. (x <= xlist(1)))) THEN + iloc = 1 + is_new = (x /= xlist(1)) .or. (y /= ylist(1)) + ELSEIF ((y > ylist(n)) .or. ((y == ylist(n)) .and. (x > xlist(n)))) THEN + iloc = n + 1 + is_new = .true. + ELSEIF ((x == xlist(n)) .and. (y == ylist(n))) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF ((y > ylist(iloc)) .or. ((y == ylist(iloc)) .and. (x > xlist(iloc)))) THEN + ileft = iloc + ELSEIF ((y < ylist(iloc)) .or. ((y == ylist(iloc)) .and. (x < xlist(iloc)))) THEN + iright = iloc + ELSE + is_new = .false. + EXIT + ENDIF + ELSE + iloc = iright + is_new = .true. + EXIT + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + xlist(iloc+1:n+1) = xlist(iloc:n) + ylist(iloc+1:n+1) = ylist(iloc:n) + ENDIF + + xlist(iloc) = x + ylist(iloc) = y + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list2 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list1_int32 (x, n, list) result(iloc) + + IMPLICIT NONE + + integer :: iloc + + integer, intent(in) :: x + integer, intent(in) :: n + integer, intent(in) :: list (n) + + ! Local variables + integer :: i, ileft, iright + + iloc = 0 + IF (n > 0) THEN + IF ((x >= list(1)) .and. (x <= list(n))) THEN + IF (x == list(1)) THEN + iloc = 1 + ELSEIF (x == list(n)) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (iright - ileft > 1) + i = (ileft + iright) / 2 + IF (x == list(i)) THEN + iloc = i + EXIT + ELSEIF (x > list(i)) THEN + ileft = i + ELSEIF (x < list(i)) THEN + iright = i + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + END FUNCTION find_in_sorted_list1_int32 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list1_int64 (x, n, list) result(iloc) + + IMPLICIT NONE + + integer :: iloc + + integer*8, intent(in) :: x + integer, intent(in) :: n + integer*8, intent(in) :: list (n) + + ! Local variables + integer :: i, ileft, iright + + iloc = 0 + IF (n > 0) THEN + IF ((x >= list(1)) .and. (x <= list(n))) THEN + IF (x == list(1)) THEN + iloc = 1 + ELSEIF (x == list(n)) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (iright - ileft > 1) + i = (ileft + iright) / 2 + IF (x == list(i)) THEN + iloc = i + EXIT + ELSEIF (x > list(i)) THEN + ileft = i + ELSEIF (x < list(i)) THEN + iright = i + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + END FUNCTION find_in_sorted_list1_int64 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list2 (x, y, n, xlist, ylist) result(iloc) + + IMPLICIT NONE + + integer :: iloc + + integer, intent(in) :: x, y + integer, intent(in) :: n + integer, intent(in) :: xlist(:), ylist(:) + + ! Local variables + integer :: i, ileft, iright + + iloc = 0 + IF (n < 1) RETURN + + IF ((y < ylist(1)) .or. ((y == ylist(1)) .and. (x < xlist(1)))) THEN + iloc = 0 + ELSEIF ((y > ylist(n)) .or. ((y == ylist(n)) .and. (x > xlist(n)))) THEN + iloc = 0 + ELSEIF ((x == xlist(1)) .and. (y == ylist(1))) THEN + iloc = 1 + ELSEIF ((x == xlist(n)) .and. (y == ylist(n))) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + i = (ileft + iright) / 2 + IF ((y == ylist(i)) .and. (x == xlist(i))) THEN + iloc = i + EXIT + ELSEIF ((y > ylist(i)) .or. ((y == ylist(i)) .and. (x > xlist(i)))) THEN + ileft = i + ELSEIF ((y < ylist(i)) .or. ((y == ylist(i)) .and. (x < xlist(i)))) THEN + iright = i + ENDIF + ELSE + iloc = 0 + EXIT + ENDIF + ENDDO + ENDIF + + END FUNCTION find_in_sorted_list2 + + !----------------------------------------------------- + FUNCTION find_nearest_south (y, n, lat) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + integer :: iloc + + real(r8), intent(in) :: y + integer, intent(in) :: n + real(r8), intent(in) :: lat (n) + + ! Local variables + integer :: i, iright, ileft + + IF (lat(1) < lat(n)) THEN + IF (y <= lat(1)) THEN + iloc = 1 + ELSEIF (y >= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y >= lat(i)) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = ileft + ENDIF + ELSE + IF (y >= lat(1)) THEN + iloc = 1 + ELSEIF (y <= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y >= lat(i)) THEN + iright = i + ELSE + ileft = i + ENDIF + ENDDO + + iloc = iright + ENDIF + ENDIF + + END FUNCTION find_nearest_south + + !----------------------------------------------------- + FUNCTION find_nearest_north (y, n, lat) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: y + integer, intent(in) :: n + real(r8), intent(in) :: lat (n) + + integer :: iloc + + ! Local variables + integer :: i, iright, ileft + + IF (lat(1) < lat(n)) THEN + IF (y <= lat(1)) THEN + iloc = 1 + ELSEIF (y >= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y > lat(i)) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = iright + ENDIF + ELSE + IF (y >= lat(1)) THEN + iloc = 1 + ELSEIF (y <= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y > lat(i)) THEN + iright = i + ELSE + ileft = i + ENDIF + ENDDO + + iloc = ileft + ENDIF + ENDIF + + END FUNCTION find_nearest_north + + !----------------------------------------- + logical FUNCTION lon_between_floor (lon, west, east) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: lon, west, east ! [-180, 180) + + IF (west >= east) THEN + lon_between_floor = (lon >= west) .or. (lon < east) + ELSE + lon_between_floor = (lon >= west) .and. (lon < east) + ENDIF + + END FUNCTION lon_between_floor + + !----------------------------------------- + logical FUNCTION lon_between_ceil (lon, west, east) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: lon, west, east ! [-180, 180) + + IF (west >= east) THEN + lon_between_ceil = (lon > west) .or. (lon <= east) + ELSE + lon_between_ceil = (lon > west) .and. (lon <= east) + ENDIF + + END FUNCTION lon_between_ceil + + !----------------------------------------------------- + FUNCTION find_nearest_west (x, n, lon) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8), intent(in) :: lon (n) + + integer :: iloc + + ! Local variables + integer :: i, iright, ileft + + IF (n == 1) THEN + iloc = 1 + RETURN + ENDIF + + IF (lon_between_floor (x, lon(n), lon(1))) THEN + iloc = n + RETURN + ENDIF + + ileft = 1; iright = n + DO WHILE (iright - ileft > 1) + i = (iright + ileft)/2 + IF (lon_between_floor(x,lon(i),lon(iright))) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = ileft + + END FUNCTION find_nearest_west + + !----------------------------------------------------- + FUNCTION find_nearest_east (x, n, lon) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8), intent(in) :: lon (n) + + integer :: iloc + + ! Local variables + integer :: i, iright, ileft + + IF (n == 1) THEN + iloc = 1 + RETURN + ENDIF + + IF (lon_between_ceil (x, lon(n), lon(1))) THEN + iloc = 1 + RETURN + ENDIF + + ileft = 1; iright = n + DO WHILE (iright - ileft > 1) + i = (iright + ileft)/2 + IF (lon_between_ceil(x,lon(i),lon(iright))) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = iright + + END FUNCTION find_nearest_east + + + !----------------------------------------------------- + recursive SUBROUTINE quicksort_int32 (nA, A, order) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: nA + integer, intent(inout) :: A (nA) + integer, intent(inout) :: order (nA) + + ! Local variables + integer :: left, right + integer :: pivot + integer :: marker + integer :: itemp + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + itemp = A(left) + A(left) = A(right) + A(right) = itemp + + itemp = order(left) + order(left) = order(right) + order(right) = itemp + ENDIF + ENDDO + + marker = right + + CALL quicksort_int32 (marker, A(1:marker), order(1:marker)) + CALL quicksort_int32 (nA-marker, A(marker+1:nA), order(marker+1:nA)) + + ENDIF + + END SUBROUTINE quicksort_int32 + + !----------------------------------------------------- + recursive SUBROUTINE quicksort_int64 (nA, A, order) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: nA + integer*8, intent(inout) :: A (nA) + integer, intent(inout) :: order (nA) + + ! Local variables + integer*8 :: left, right, pivot, itemp + integer :: marker + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + itemp = A(left) + A(left) = A(right) + A(right) = itemp + + itemp = order(left) + order(left) = order(right) + order(right) = itemp + ENDIF + ENDDO + + marker = right + + CALL quicksort_int64 (marker, A(1:marker), order(1:marker)) + CALL quicksort_int64 (nA-marker, A(marker+1:nA), order(marker+1:nA)) + + ENDIF + + END SUBROUTINE quicksort_int64 + + !----------------------------------------------------- + recursive SUBROUTINE quicksort_real8 (nA, A, order) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: nA + real(r8), intent(inout) :: A (nA) + integer, intent(inout) :: order (nA) + + ! Local variables + real(r8) :: pivot, temp + integer :: left, right, marker, itemp + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + temp = A(left) + A(left) = A(right) + A(right) = temp + + itemp = order(left) + order(left) = order(right) + order(right) = itemp + ENDIF + ENDDO + + marker = right + + CALL quicksort_real8 (marker, A(1:marker), order(1:marker)) + CALL quicksort_real8 (nA-marker, A(marker+1:nA), order(marker+1:nA)) + + ENDIF + + END SUBROUTINE quicksort_real8 + + !----------------------------------------------------- + recursive FUNCTION quickselect (nA, A, k) result(selected) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: selected + + integer , intent(in) :: nA + real(r8), intent(inout) :: A (nA) + integer, intent(in) :: k + + ! Local variables + integer :: left, right + real(r8) :: pivot + integer :: marker + real(r8) :: rtemp + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + rtemp = A(left) + A(left) = A(right) + A(right) = rtemp + ENDIF + ENDDO + + marker = right + + IF (k <= marker) THEN + selected = quickselect (marker, A(1:marker), k) + ELSE + selected = quickselect (nA-marker, A(marker+1:nA), k-marker) + ENDIF + + ELSE + selected = A(1) + ENDIF + + END FUNCTION quickselect + + + ! ------------------------ + FUNCTION median(x, n, spval) result(mval) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: mval + + integer, intent(in) :: n + real(r8), intent(in) :: x(n) + real(r8), intent(in), optional :: spval + + ! Local variables + integer :: nc + real(r8), allocatable :: xtemp(:) + logical, allocatable :: msk (:) + real(r8) :: right, left + + IF (present(spval)) THEN + allocate (msk (n)) + msk = (x /= spval) + nc = count(msk) + IF (nc /= 0) THEN + + allocate (xtemp(nc)) + xtemp = pack(x, msk) + + deallocate (msk) + ELSE + + mval = spval + + deallocate(msk) + RETURN + ENDIF + ELSE + nc = n + allocate (xtemp(nc)) + xtemp = x + ENDIF + + IF (mod(nc,2) == 0) THEN + left = quickselect(nc,xtemp,nc/2) + right = quickselect(nc,xtemp,nc/2+1) + mval = (left + right) / 2.0_r8 + ELSE + mval = quickselect(nc,xtemp,nc/2+1) + ENDIF + + deallocate (xtemp) + + END FUNCTION median + + + !----------------------------------------------------- + FUNCTION areaquad (lats, latn, lonw, lone) result(area) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: area ! in km^2 + real(r8), parameter :: re = 6.37122e3 ! kilometer + real(r8), parameter :: deg2rad = 1.745329251994330e-2_r8 + real(r8), intent(in) :: lats, latn, lonw, lone + + ! Local variables + real(r8) :: dx, dy + + IF (lone < lonw) THEN + dx = (lone + 360 - lonw) * deg2rad + ELSE + dx = (lone - lonw) * deg2rad + ENDIF + + dy = sin(latn * deg2rad) - sin(lats * deg2rad) + + area = dx * dy * re * re + + END FUNCTION areaquad + + ! --- spherical distance --- + FUNCTION arclen (lat1, lon1, lat2, lon2) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: arclen ! in km + real(r8), intent(in) :: lat1, lon1, lat2, lon2 + + real(r8), parameter :: re = 6.37122e3 ! kilometer + real(r8) :: tmp + + tmp = sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2) * cos(lon1-lon2) + tmp = min(max(tmp, -1.), 1.) + arclen = re * acos(tmp) + + END FUNCTION arclen + + !----------------------------------------------------- + SUBROUTINE unpack_inplace_int32 (din, msk, dout) + + IMPLICIT NONE + + integer, intent(in) :: din (:) + logical, intent(in) :: msk (:) + integer, intent(inout) :: dout (:) + + ! Local variables + integer :: n, i + + n = 0 + DO i = 1, size(msk) + IF (msk(i)) THEN + n = n + 1 + dout(i) = din(n) + ENDIF + ENDDO + + END SUBROUTINE unpack_inplace_int32 + + !----------------------------------------------------- + SUBROUTINE unpack_inplace_real8 (din, msk, dout) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: din (:) + logical, intent(in) :: msk (:) + real(r8), intent(inout) :: dout (:) + + ! Local variables + integer :: n, i + + n = 0 + DO i = 1, size(msk) + IF (msk(i)) THEN + n = n + 1 + dout(i) = din(n) + ENDIF + ENDDO + + END SUBROUTINE unpack_inplace_real8 + + !----------------------------------------------------- + SUBROUTINE unpack_inplace_lastdim_real8 (din, msk, dout) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: din (:,:) + logical, intent(in) :: msk (:) + real(r8), intent(inout) :: dout (:,:) + + ! Local variables + integer :: n, i + + n = 0 + DO i = 1, size(msk) + IF (msk(i)) THEN + n = n + 1 + dout(:,i) = din(:,n) + ENDIF + ENDDO + + END SUBROUTINE unpack_inplace_lastdim_real8 + + !--------------------------------------------------- + integer FUNCTION num_max_frequency (data_in) + + IMPLICIT NONE + + integer, intent(in) :: data_in(:) + + ! Local Variables + integer, allocatable :: data_(:), cnts(:) + integer :: ndata, i, n, iloc + logical :: is_new + + ndata = size(data_in) + allocate (data_(ndata)) + allocate (cnts (ndata)) + + n = 0 + cnts(:) = 0 + DO i = 1, ndata + CALL insert_into_sorted_list1 (data_in(i), n, data_, iloc, is_new) + IF (is_new) THEN + IF (iloc < n) cnts(iloc+1:ndata) = cnts(iloc:ndata-1) + cnts(iloc) = 1 + ELSE + cnts(iloc) = cnts(iloc) + 1 + ENDIF + ENDDO + + num_max_frequency = data_(maxloc(cnts,dim=1)) + + deallocate(data_) + deallocate(cnts ) + + END FUNCTION num_max_frequency + + !---------------------------------------------------- + SUBROUTINE lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, & + diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf, xdat, npoint, ydat, & + ydatks, nptf, phi, k_s, isiter, L_vgm) + + !******************************************************************************* + ! + !! LMDER minimizes M functions in N variables by the Levenberg-Marquardt method + ! implemented for fitting the SW retention & hydraulic conductivity parameters + ! in the Campbell/van Genuchten models. + ! + ! Discussion: + ! + ! LMDER minimizes the sum of the squares of M nonlinear functions in + ! N variables by a modification of the Levenberg-Marquardt algorithm. + ! The user must provide a subroutine which calculates the functions + ! and the jacobian. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! Modified by Nan Wei, 2019/01 + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, external FCN, the name of the user-supplied subroutine which + ! calculates the functions and the jacobian. FCN should have the form: + ! subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ! integer ( kind = 4 ) ldfjac + ! integer ( kind = 4 ) n + ! real ( kind = 8 ) fjac(ldfjac,n) + ! real ( kind = 8 ) fvec(m) + ! integer ( kind = 4 ) iflag + ! real ( kind = 8 ) x(n) + ! xdat, npoint, ydat, ydatks, nptf, phi, k_s and isiter are transfered as the inputs of the fitting functions. + ! L_vgm are only used for vanGenuchten_Mualem soil model input. + ! + ! If IFLAG = 0 on input, then FCN is only being called to allow the user + ! to print out the current iterate. + ! If IFLAG = 1 on input, FCN should calculate the functions at X and + ! return this vector in FVEC. + ! If IFLAG = 2 on input, FCN should calculate the jacobian at X and + ! return this matrix in FJAC. + ! To terminate the algorithm, FCN may set IFLAG negative on return. + ! + ! Input, integer ( kind = 4 ) M, is the number of functions. + ! + ! Input, integer ( kind = 4 ) N, is the number of variables. + ! N must not exceed M. + ! + ! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial + ! estimate of the solution vector. On output X contains the final + ! estimate of the solution vector. + ! + ! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X. + ! + ! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array. The upper + ! N by N submatrix of FJAC contains an upper triangular matrix R with + ! diagonal elements of nonincreasing magnitude such that + ! P' * ( JAC' * JAC ) * P = R' * R, + ! where P is a permutation matrix and JAC is the final calculated jacobian. + ! Column J of P is column IPVT(J) of the identity matrix. The lower + ! trapezoidal part of FJAC contains information generated during + ! the computation of R. + ! + ! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC. + ! LDFJAC must be at least M. + ! + ! Input, real ( kind = 8 ) FTOL. Termination occurs when both the actual + ! and predicted relative reductions in the sum of squares are at most FTOL. + ! Therefore, FTOL measures the relative error desired in the sum of + ! squares. FTOL should be nonnegative. + ! + ! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error + ! between two consecutive iterates is at most XTOL. XTOL should be + ! nonnegative. + ! + ! Input, real ( kind = 8 ) GTOL. Termination occurs when the cosine of the + ! angle between FVEC and any column of the jacobian is at most GTOL in + ! absolute value. Therefore, GTOL measures the orthogonality desired + ! between the function vector and the columns of the jacobian. GTOL should + ! be nonnegative. + ! + ! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number of + ! calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration. + ! + ! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set + ! internally. If MODE = 2, then DIAG must contain positive entries that + ! serve as multiplicative scale factors for the variables. + ! + ! Input, integer ( kind = 4 ) MODE, scaling option. + ! 1, variables will be scaled internally. + ! 2, scaling is specified by the input DIAG vector. + ! + ! Input, real ( kind = 8 ) FACTOR, determines the initial step bound. This + ! bound is set to the product of FACTOR and the euclidean norm of DIAG*X if + ! nonzero, or else to FACTOR itself. In most cases, FACTOR should lie + ! in the interval (0.1, 100) with 100 the recommended value. + ! + ! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates + ! if it is positive. In this case, FCN is called with IFLAG = 0 at the + ! beginning of the first iteration and every NPRINT iterations thereafter + ! and immediately prior to return, with X and FVEC available + ! for printing. If NPRINT is not positive, no special calls + ! of FCN with IFLAG = 0 are made. + ! + ! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated + ! execution, INFO is set to the (negative) value of IFLAG. See description + ! of FCN. Otherwise, INFO is set as follows: + ! 0, improper input parameters. + ! 1, both actual and predicted relative reductions in the sum of + ! squares are at most FTOL. + ! 2, relative error between two consecutive iterates is at most XTOL. + ! 3, conditions for INFO = 1 and INFO = 2 both hold. + ! 4, the cosine of the angle between FVEC and any column of the jacobian + ! is at most GTOL in absolute value. + ! 5, number of calls to FCN with IFLAG = 1 has reached MAXFEV. + ! 6, FTOL is too small. No further reduction in the sum of squares + ! is possible. + ! 7, XTOL is too small. No further improvement in the approximate + ! solution X is possible. + ! 8, GTOL is too small. FVEC is orthogonal to the columns of the + ! jacobian to machine precision. + ! + ! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with + ! IFLAG = 1. + ! + ! Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with + ! IFLAG = 2. + ! + ! Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P + ! such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is + ! orthogonal (not stored), and R is upper triangular with diagonal + ! elements of nonincreasing magnitude. Column J of P is column + ! IPVT(J) of the identity matrix. + ! + ! Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC. + ! + IMPLICIT NONE + + integer ( kind = 4 ) ldfjac + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + real ( kind = 8 ) actred + real ( kind = 8 ) delta + real ( kind = 8 ) diag(n) + real ( kind = 8 ) dirder + real ( kind = 8 ) epsmch + real ( kind = 8 ) factor + external fcn + real ( kind = 8 ) fjac(ldfjac,n) + real ( kind = 8 ) fnorm + real ( kind = 8 ) fnorm1 + real ( kind = 8 ) ftol + real ( kind = 8 ) fvec(m) + real ( kind = 8 ) gnorm + real ( kind = 8 ) gtol + integer ( kind = 4 ) i + integer ( kind = 4 ) iflag + integer ( kind = 4 ) info + integer ( kind = 4 ) ipvt(n) + integer ( kind = 4 ) iter + integer ( kind = 4 ) j + integer ( kind = 4 ) l + integer ( kind = 4 ) maxfev + integer ( kind = 4 ) mode + integer ( kind = 4 ) nfev + integer ( kind = 4 ) njev + integer ( kind = 4 ) nprint + real ( kind = 8 ) par + logical pivot + real ( kind = 8 ) pnorm + real ( kind = 8 ) prered + real ( kind = 8 ) qtf(n) + real ( kind = 8 ) ratio + real ( kind = 8 ) sum2 + real ( kind = 8 ) temp + real ( kind = 8 ) temp1 + real ( kind = 8 ) temp2 + real ( kind = 8 ) wa1(n) + real ( kind = 8 ) wa2(n) + real ( kind = 8 ) wa3(n) + real ( kind = 8 ) wa4(m) + real ( kind = 8 ) xnorm + real ( kind = 8 ) x(n) + real ( kind = 8 ) xtol + real ( kind = 8 ) phi,k_s + integer ( kind = 4 ) isiter + integer ( kind = 4 ) npoint + integer ( kind = 4 ) nptf + real ( kind = 8 ) xdat(npoint) + real ( kind = 8 ) ydat (nptf,npoint) + real ( kind = 8 ) ydatks(nptf,npoint) + real ( kind = 8 ), optional :: L_vgm + + epsmch = epsilon ( epsmch ) + + info = 0 + iflag = 0 + nfev = 0 + njev = 0 + ! + ! Check the input parameters for errors. + ! + IF ( n <= 0 ) THEN + go to 300 + ENDIF + + IF ( m < n ) THEN + go to 300 + ENDIF + + IF ( ldfjac < m & + .or. ftol < 0.0D+00 .or. xtol < 0.0D+00 .or. gtol < 0.0D+00 & + .or. maxfev <= 0 .or. factor <= 0.0D+00 ) THEN + go to 300 + ENDIF + + IF ( mode == 2 ) THEN + DO j = 1, n + IF ( diag(j) <= 0.0D+00 ) THEN + go to 300 + ENDIF + ENDDO + ENDIF + ! + ! Evaluate the function at the starting point and calculate its norm. + ! + iflag = 1 + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + nfev = 1 + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + + fnorm = enorm ( m, fvec ) + ! + ! Initialize Levenberg-Marquardt parameter and iteration counter. + ! + par = 0.0D+00 + iter = 1 + ! + ! Beginning of the outer loop. + ! + DO + ! + ! Calculate the jacobian matrix. + ! + iflag = 2 + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + + njev = njev + 1 + + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + ! + ! IF requested, call FCN to enable printing of iterates. + ! + IF ( 0 < nprint ) THEN + iflag = 0 + IF ( mod ( iter - 1, nprint ) == 0 ) THEN + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + ENDIF + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + ENDIF + ! + ! Compute the QR factorization of the jacobian. + ! + pivot = .true. + CALL qrfac ( m, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 ) + + ! On the first iteration and if mode is 1, scale according + ! to the norms of the columns of the initial jacobian. + ! + IF ( iter == 1 ) THEN + + IF ( mode /= 2 ) THEN + diag(1:n) = wa2(1:n) + DO j = 1, n + IF ( wa2(j) == 0.0D+00 ) THEN + diag(j) = 1.0D+00 + ENDIF + ENDDO + ENDIF + ! + ! On the first iteration, calculate the norm of the scaled X + ! and initialize the step bound DELTA. + ! + wa3(1:n) = diag(1:n) * x(1:n) + + xnorm = enorm ( n, wa3 ) + + IF ( xnorm == 0.0D+00 ) THEN + delta = factor + ELSE + delta = factor * xnorm + ENDIF + + ENDIF + ! + ! Form Q'*FVEC and store the first N components in QTF. + ! + wa4(1:m) = fvec(1:m) + + DO j = 1, n + + IF ( fjac(j,j) /= 0.0D+00 ) THEN + sum2 = dot_product ( wa4(j:m), fjac(j:m,j) ) + temp = - sum2 / fjac(j,j) + wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp + ENDIF + + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + + ENDDO + ! + ! Compute the norm of the scaled gradient. + ! + gnorm = 0.0D+00 + + IF ( fnorm /= 0.0D+00 ) THEN + + DO j = 1, n + l = ipvt(j) + IF ( wa2(l) /= 0.0D+00 ) THEN + sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm + gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) ) + ENDIF + ENDDO + + ENDIF + ! + ! Test for convergence of the gradient norm. + ! + IF ( gnorm <= gtol ) THEN + info = 4 + go to 300 + ENDIF + ! + ! Rescale if necessary. + ! + IF ( mode /= 2 ) THEN + DO j = 1, n + diag(j) = max ( diag(j), wa2(j) ) + ENDDO + ENDIF + ! + ! Beginning of the inner loop. + ! + DO + ! + ! Determine the Levenberg-Marquardt parameter. + + CALL lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 ) + + ! Store the direction p and x + p. calculate the norm of p. + ! + wa1(1:n) = - wa1(1:n) + wa2(1:n) = x(1:n) + wa1(1:n) + wa3(1:n) = diag(1:n) * wa1(1:n) + + pnorm = enorm ( n, wa3 ) + ! + ! On the first iteration, adjust the initial step bound. + ! + IF ( iter == 1 ) THEN + delta = min ( delta, pnorm ) + ENDIF + ! + ! Evaluate the function at x + p and calculate its norm. + ! + iflag = 1 + IF (present(L_vgm)) THEN + CALL fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + + nfev = nfev + 1 + + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + + fnorm1 = enorm ( m, wa4 ) + ! + ! Compute the scaled actual reduction. + ! + IF ( 0.1D+00 * fnorm1 < fnorm ) THEN + actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2 + ELSE + actred = - 1.0D+00 + ENDIF + ! + ! Compute the scaled predicted reduction and + ! the scaled directional derivative. + ! + DO j = 1, n + wa3(j) = 0.0D+00 + l = ipvt(j) + temp = wa1(l) + wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp + ENDDO + + temp1 = enorm ( n, wa3 ) / fnorm + temp2 = ( sqrt ( par ) * pnorm ) / fnorm + prered = temp1 ** 2 + temp2 ** 2 / 0.5D+00 + dirder = - ( temp1 ** 2 + temp2 ** 2 ) + ! + ! Compute the ratio of the actual to the predicted reduction. + ! + IF ( prered /= 0.0D+00 ) THEN + ratio = actred / prered + ELSE + ratio = 0.0D+00 + ENDIF + ! + ! Update the step bound. + ! + IF ( ratio <= 0.25D+00 ) THEN + + IF ( 0.0D+00 <= actred ) THEN + temp = 0.5D+00 + ENDIF + + IF ( actred < 0.0D+00 ) THEN + temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred ) + ENDIF + + IF ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) THEN + temp = 0.1D+00 + ENDIF + + delta = temp * min ( delta, pnorm / 0.1D+00 ) + par = par / temp + + ELSE + + IF ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) THEN + delta = 2.0D+00 * pnorm + par = 0.5D+00 * par + ENDIF + + ENDIF + ! + ! Successful iteration. + ! + ! Update X, FVEC, and their norms. + ! + IF ( 0.0001D+00 <= ratio ) THEN + x(1:n) = wa2(1:n) + wa2(1:n) = diag(1:n) * x(1:n) + fvec(1:m) = wa4(1:m) + xnorm = enorm ( n, wa2 ) + fnorm = fnorm1 + iter = iter + 1 + ENDIF + ! + ! Tests for convergence. + ! + IF ( abs ( actred) <= ftol .and. & + prered <= ftol .and. & + 0.5D+00 * ratio <= 1.0D+00 ) THEN + info = 1 + ENDIF + + IF ( delta <= xtol * xnorm ) THEN + info = 2 + ENDIF + + IF ( abs ( actred) <= ftol .and. prered <= ftol & + .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) THEN + info = 3 + ENDIF + + IF ( info /= 0 ) THEN + go to 300 + ENDIF + ! + ! Tests for termination and stringent tolerances. + ! + IF ( nfev >= maxfev ) THEN + info = 5 + ENDIF + + IF ( abs ( actred ) <= epsmch .and. prered <= epsmch & + .and. 0.5D+00 * ratio <= 1.0D+00 ) THEN + info = 6 + ENDIF + + IF ( delta <= epsmch * xnorm ) THEN + info = 7 + ENDIF + + IF ( gnorm <= epsmch ) THEN + info = 8 + ENDIF + + IF ( info /= 0 ) THEN + go to 300 + ENDIF + ! + ! End of the inner loop. repeat IF iteration unsuccessful. + ! + IF ( 0.0001D+00 <= ratio ) THEN + EXIT + ENDIF + + ENDDO + ! + ! End of the outer loop. + ! + ENDDO + + 300 continue + ! + ! Termination, either normal or user imposed. + ! + IF ( iflag < 0 ) THEN + info = iflag + ENDIF + + iflag = 0 + + IF ( 0 < nprint ) THEN + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + ENDIF + + RETURN + END SUBROUTINE lmder + + SUBROUTINE lmpar ( n, r, ldr, ipvt, diag, qtb, delta, par, x, sdiag ) + + !*****************************************************************************80 + ! + !! LMPAR computes a parameter for the Levenberg-Marquardt method. + ! + ! Discussion: + ! + ! Given an M by N matrix A, an N by N nonsingular diagonal + ! matrix D, an M-vector B, and a positive number DELTA, + ! the problem is to determine a value for the parameter + ! PAR such that IF X solves the system + ! + ! A*X = B, + ! sqrt ( PAR ) * D * X = 0, + ! + ! in the least squares sense, and DXNORM is the euclidean + ! norm of D*X, THEN either PAR is zero and + ! + ! ( DXNORM - DELTA ) <= 0.1 * DELTA, + ! + ! or PAR is positive and + ! + ! abs ( DXNORM - DELTA) <= 0.1 * DELTA. + ! + ! This FUNCTION completes the solution of the problem + ! IF it is provided with the necessary information from the + ! QR factorization, with column pivoting, of A. That is, IF + ! A*P = Q*R, WHERE P is a permutation matrix, Q has orthogonal + ! columns, and R is an upper triangular matrix with diagonal + ! elements of nonincreasing magnitude, THEN LMPAR expects + ! the full upper triangle of R, the permutation matrix P, + ! and the first N components of Q'*B. On output + ! LMPAR also provides an upper triangular matrix S such that + ! + ! P' * ( A' * A + PAR * D * D ) * P = S'* S. + ! + ! S is employed within LMPAR and may be of separate interest. + ! + ! Only a few iterations are generally needed for convergence + ! of the algorithm. + ! + ! IF, however, the limit of 10 iterations is reached, THEN the output + ! PAR will contain the best value obtained so far. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 24 January 2014 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the order of R. + ! + ! Input/output, real ( kind = 8 ) R(LDR,N),the N by N matrix. The full + ! upper triangle must contain the full upper triangle of the matrix R. + ! On output the full upper triangle is unaltered, and the strict lower + ! triangle CONTAINS the strict upper triangle (transposed) of the upper + ! triangular matrix S. + ! + ! Input, integer ( kind = 4 ) LDR, the leading dimension of R. LDR must be + ! no less than N. + ! + ! Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P + ! such that A*P = Q*R. Column J of P is column IPVT(J) of the + ! identity matrix. + ! + ! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D. + ! + ! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B. + ! + ! Input, real ( kind = 8 ) DELTA, an upper bound on the euclidean norm + ! of D*X. DELTA should be positive. + ! + ! Input/output, real ( kind = 8 ) PAR. On input an initial estimate of the + ! Levenberg-Marquardt parameter. On output the final estimate. + ! PAR should be nonnegative. + ! + ! Output, real ( kind = 8 ) X(N), the least squares solution of the system + ! A*X = B, sqrt(PAR)*D*X = 0, for the output value of PAR. + ! + ! Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper + ! triangular matrix S. + ! + IMPLICIT NONE + + integer ( kind = 4 ) ldr + integer ( kind = 4 ) n + + real ( kind = 8 ) delta + real ( kind = 8 ) diag(n) + real ( kind = 8 ) dwarf + real ( kind = 8 ) dxnorm + real ( kind = 8 ) gnorm + real ( kind = 8 ) fp + integer ( kind = 4 ) i + integer ( kind = 4 ) ipvt(n) + integer ( kind = 4 ) iter + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) l + integer ( kind = 4 ) nsing + real ( kind = 8 ) par + real ( kind = 8 ) parc + real ( kind = 8 ) parl + real ( kind = 8 ) paru + real ( kind = 8 ) qnorm + real ( kind = 8 ) qtb(n) + real ( kind = 8 ) r(ldr,n) + real ( kind = 8 ) sdiag(n) + real ( kind = 8 ) sum2 + real ( kind = 8 ) temp + real ( kind = 8 ) wa1(n) + real ( kind = 8 ) wa2(n) + real ( kind = 8 ) x(n) + + ! + ! DWARF is the smallest positive magnitude. + ! + dwarf = tiny ( dwarf ) + ! + ! Compute and store in X the Gauss-Newton direction. + ! + ! IF the jacobian is rank-deficient, obtain a least squares solution. + ! + nsing = n + + DO j = 1, n + wa1(j) = qtb(j) + IF ( r(j,j) == 0.0D+00 .and. nsing == n ) THEN + nsing = j - 1 + ENDIF + IF ( nsing < n ) THEN + wa1(j) = 0.0D+00 + ENDIF + ENDDO + + DO k = 1, nsing + j = nsing - k + 1 + wa1(j) = wa1(j) / r(j,j) + temp = wa1(j) + wa1(1:j-1) = wa1(1:j-1) - r(1:j-1,j) * temp + ENDDO + + DO j = 1, n + l = ipvt(j) + x(l) = wa1(j) + ENDDO + ! + ! Initialize the iteration counter. + ! Evaluate the FUNCTION at the origin, and test + ! for acceptance of the Gauss-Newton direction. + ! + iter = 0 + wa2(1:n) = diag(1:n) * x(1:n) + dxnorm = enorm ( n, wa2 ) + fp = dxnorm - delta + + IF ( fp <= 0.1D+00 * delta ) THEN + IF ( iter == 0 ) THEN + par = 0.0D+00 + ENDIF + RETURN + ENDIF + ! + ! IF the jacobian is not rank deficient, the Newton + ! step provides a lower bound, PARL, for the zero of + ! the FUNCTION. + ! + ! Otherwise set this bound to zero. + ! + parl = 0.0D+00 + + IF ( n <= nsing ) THEN + + DO j = 1, n + l = ipvt(j) + wa1(j) = diag(l) * ( wa2(l) / dxnorm ) + ENDDO + + DO j = 1, n + sum2 = dot_product ( wa1(1:j-1), r(1:j-1,j) ) + wa1(j) = ( wa1(j) - sum2 ) / r(j,j) + ENDDO + + temp = enorm ( n, wa1 ) + parl = ( ( fp / delta ) / temp ) / temp + + ENDIF + ! + ! Calculate an upper bound, PARU, for the zero of the FUNCTION. + ! + DO j = 1, n + sum2 = dot_product ( qtb(1:j), r(1:j,j) ) + l = ipvt(j) + wa1(j) = sum2 / diag(l) + ENDDO + + gnorm = enorm ( n, wa1 ) + paru = gnorm / delta + + IF ( paru == 0.0D+00 ) THEN + paru = dwarf / min ( delta, 0.1D+00 ) + ENDIF + ! + ! IF the input PAR lies outside of the interval (PARL, PARU), + ! set PAR to the closer endpoint. + ! + par = max ( par, parl ) + par = min ( par, paru ) + IF ( par == 0.0D+00 ) THEN + par = gnorm / dxnorm + ENDIF + ! + ! Beginning of an iteration. + ! + DO + + iter = iter + 1 + ! + ! Evaluate the FUNCTION at the current value of PAR. + ! + IF ( par == 0.0D+00 ) THEN + par = max ( dwarf, 0.001D+00 * paru ) + ENDIF + + wa1(1:n) = sqrt ( par ) * diag(1:n) + + CALL qrsolv ( n, r, ldr, ipvt, wa1, qtb, x, sdiag ) + + wa2(1:n) = diag(1:n) * x(1:n) + dxnorm = enorm ( n, wa2 ) + temp = fp + fp = dxnorm - delta + ! + ! IF the FUNCTION is small enough, accept the current value of PAR. + ! + IF ( abs ( fp ) <= 0.1D+00 * delta ) THEN + EXIT + ENDIF + ! + ! Test for the exceptional cases WHERE PARL + ! is zero or the number of iterations has reached 10. + ! + IF ( parl == 0.0D+00 .and. fp <= temp .and. temp < 0.0D+00 ) THEN + EXIT + ELSEIF ( iter == 10 ) THEN + EXIT + ENDIF + ! + ! Compute the Newton correction. + ! + DO j = 1, n + l = ipvt(j) + wa1(j) = diag(l) * ( wa2(l) / dxnorm ) + ENDDO + + DO j = 1, n + wa1(j) = wa1(j) / sdiag(j) + temp = wa1(j) + wa1(j+1:n) = wa1(j+1:n) - r(j+1:n,j) * temp + ENDDO + + temp = enorm ( n, wa1 ) + parc = ( ( fp / delta ) / temp ) / temp + ! + ! Depending on the sign of the FUNCTION, update PARL or PARU. + ! + IF ( 0.0D+00 < fp ) THEN + parl = max ( parl, par ) + ELSEIF ( fp < 0.0D+00 ) THEN + paru = min ( paru, par ) + ENDIF + ! + ! Compute an improved estimate for PAR. + ! + par = max ( parl, par + parc ) + ! + ! END of an iteration. + ! + ENDDO + ! + ! Termination. + ! + IF ( iter == 0 ) THEN + par = 0.0D+00 + ENDIF + + RETURN + + END SUBROUTINE lmpar + + SUBROUTINE qrfac ( m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm ) + + !*****************************************************************************80 + ! + !! QRFAC computes a QR factorization using Householder transformations. + ! + ! Discussion: + ! + ! This FUNCTION uses Householder transformations with optional column + ! pivoting to compute a QR factorization of the + ! M by N matrix A. That is, QRFAC determines an orthogonal + ! matrix Q, a permutation matrix P, and an upper trapezoidal + ! matrix R with diagonal elements of nonincreasing magnitude, + ! such that A*P = Q*R. + ! + ! The Householder transformation for column K, K = 1,2,...,min(M,N), + ! is of the form + ! + ! I - ( 1 / U(K) ) * U * U' + ! + ! WHERE U has zeros in the first K-1 positions. + ! + ! The form of this transformation and the method of pivoting first + ! appeared in the corresponding LINPACK routine. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) M, the number of rows of A. + ! + ! Input, integer ( kind = 4 ) N, the number of columns of A. + ! + ! Input/output, real ( kind = 8 ) A(LDA,N), the M by N array. + ! On input, A CONTAINS the matrix for which the QR factorization is to + ! be computed. On output, the strict upper trapezoidal part of A CONTAINS + ! the strict upper trapezoidal part of R, and the lower trapezoidal + ! part of A CONTAINS a factored form of Q, the non-trivial elements of + ! the U vectors described above. + ! + ! Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must + ! be no less than M. + ! + ! Input, logical PIVOT, is TRUE IF column pivoting is to be carried out. + ! + ! Output, integer ( kind = 4 ) IPVT(LIPVT), defines the permutation matrix P + ! such that A*P = Q*R. Column J of P is column IPVT(J) of the identity + ! matrix. IF PIVOT is false, IPVT is not referenced. + ! + ! Input, integer ( kind = 4 ) LIPVT, the dimension of IPVT, which should + ! be N IF pivoting is used. + ! + ! Output, real ( kind = 8 ) RDIAG(N), CONTAINS the diagonal elements of R. + ! + ! Output, real ( kind = 8 ) ACNORM(N), the norms of the corresponding + ! columns of the input matrix A. IF this information is not needed, + ! THEN ACNORM can coincide with RDIAG. + ! + IMPLICIT NONE + + integer ( kind = 4 ) lda + integer ( kind = 4 ) lipvt + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + real ( kind = 8 ) a(lda,n) + real ( kind = 8 ) acnorm(n) + real ( kind = 8 ) ajnorm + real ( kind = 8 ) epsmch + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_temp + integer ( kind = 4 ) ipvt(lipvt) + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) kmax + integer ( kind = 4 ) minmn + logical pivot + real ( kind = 8 ) r8_temp(m) + real ( kind = 8 ) rdiag(n) + real ( kind = 8 ) temp + real ( kind = 8 ) wa(n) + + epsmch = epsilon ( epsmch ) + ! + ! Compute the initial column norms and initialize several arrays. + ! + DO j = 1, n + acnorm(j) = enorm ( m, a(1:m,j) ) + ENDDO + + rdiag(1:n) = acnorm(1:n) + wa(1:n) = acnorm(1:n) + + IF ( pivot ) THEN + DO j = 1, n + ipvt(j) = j + ENDDO + ENDIF + ! + ! Reduce A to R with Householder transformations. + ! + minmn = min ( m, n ) + + DO j = 1, minmn + ! + ! Bring the column of largest norm into the pivot position. + ! + IF ( pivot ) THEN + + kmax = j + + DO k = j, n + IF ( rdiag(kmax) < rdiag(k) ) THEN + kmax = k + ENDIF + ENDDO + + IF ( kmax /= j ) THEN + + r8_temp(1:m) = a(1:m,j) + a(1:m,j) = a(1:m,kmax) + a(1:m,kmax) = r8_temp(1:m) + + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + + i4_temp = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = i4_temp + + ENDIF + + ENDIF + ! + ! Compute the Householder transformation to reduce the + ! J-th column of A to a multiple of the J-th unit vector. + ! + ajnorm = enorm ( m-j+1, a(j,j) ) + + IF ( ajnorm /= 0.0D+00 ) THEN + + IF ( a(j,j) < 0.0D+00 ) THEN + ajnorm = -ajnorm + ENDIF + + a(j:m,j) = a(j:m,j) / ajnorm + a(j,j) = a(j,j) + 1.0D+00 + ! + ! Apply the transformation to the remaining columns and update the norms. + ! + DO k = j + 1, n + + temp = dot_product ( a(j:m,j), a(j:m,k) ) / a(j,j) + + a(j:m,k) = a(j:m,k) - temp * a(j:m,j) + + IF ( pivot .and. rdiag(k) /= 0.0D+00 ) THEN + + temp = a(j,k) / rdiag(k) + rdiag(k) = rdiag(k) * sqrt ( max ( 0.0D+00, 1.0D+00-temp ** 2 ) ) + + IF ( 0.05D+00 * ( rdiag(k) / wa(k) ) ** 2 <= epsmch ) THEN + rdiag(k) = enorm ( m-j, a(j+1,k) ) + wa(k) = rdiag(k) + ENDIF + + ENDIF + + ENDDO + + ENDIF + + rdiag(j) = - ajnorm + + ENDDO + + RETURN + + END SUBROUTINE qrfac + + SUBROUTINE qrsolv ( n, r, ldr, ipvt, diag, qtb, x, sdiag ) + + !*****************************************************************************80 + ! + !! QRSOLV solves a rectangular linear system A*x=b in the least squares sense. + ! + ! Discussion: + ! + ! Given an M by N matrix A, an N by N diagonal matrix D, + ! and an M-vector B, the problem is to determine an X which + ! solves the system + ! + ! A*X = B + ! D*X = 0 + ! + ! in the least squares sense. + ! + ! This FUNCTION completes the solution of the problem + ! IF it is provided with the necessary information from the + ! QR factorization, with column pivoting, of A. That is, IF + ! A*P = Q*R, WHERE P is a permutation matrix, Q has orthogonal + ! columns, and R is an upper triangular matrix with diagonal + ! elements of nonincreasing magnitude, THEN QRSOLV expects + ! the full upper triangle of R, the permutation matrix p, + ! and the first N components of Q'*B. + ! + ! The system is THEN equivalent to + ! + ! R*Z = Q'*B + ! P'*D*P*Z = 0 + ! + ! WHERE X = P*Z. IF this system does not have full rank, + ! THEN a least squares solution is obtained. On output QRSOLV + ! also provides an upper triangular matrix S such that + ! + ! P'*(A'*A + D*D)*P = S'*S. + ! + ! S is computed within QRSOLV and may be of separate interest. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the order of R. + ! + ! Input/output, real ( kind = 8 ) R(LDR,N), the N by N matrix. + ! On input the full upper triangle must contain the full upper triangle + ! of the matrix R. On output the full upper triangle is unaltered, and + ! the strict lower triangle CONTAINS the strict upper triangle + ! (transposed) of the upper triangular matrix S. + ! + ! Input, integer ( kind = 4 ) LDR, the leading dimension of R, which must be + ! at least N. + ! + ! Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P such + ! that A*P = Q*R. Column J of P is column IPVT(J) of the identity matrix. + ! + ! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D. + ! + ! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B. + ! + ! Output, real ( kind = 8 ) X(N), the least squares solution. + ! + ! Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper + ! triangular matrix S. + ! + IMPLICIT NONE + + integer ( kind = 4 ) ldr + integer ( kind = 4 ) n + + real ( kind = 8 ) c + real ( kind = 8 ) cotan + real ( kind = 8 ) diag(n) + integer ( kind = 4 ) i + integer ( kind = 4 ) ipvt(n) + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) l + integer ( kind = 4 ) nsing + real ( kind = 8 ) qtb(n) + real ( kind = 8 ) qtbpj + real ( kind = 8 ) r(ldr,n) + real ( kind = 8 ) s + real ( kind = 8 ) sdiag(n) + real ( kind = 8 ) sum2 + real ( kind = 8 ) t + real ( kind = 8 ) temp + real ( kind = 8 ) wa(n) + real ( kind = 8 ) x(n) + + ! + ! Copy R and Q'*B to preserve input and initialize S. + ! + ! In particular, SAVE the diagonal elements of R in X. + ! + DO j = 1, n + r(j:n,j) = r(j,j:n) + x(j) = r(j,j) + ENDDO + + wa(1:n) = qtb(1:n) + ! + ! Eliminate the diagonal matrix D using a Givens rotation. + ! + DO j = 1, n + ! + ! Prepare the row of D to be eliminated, locating the + ! diagonal element using P from the QR factorization. + ! + l = ipvt(j) + + IF ( diag(l) /= 0.0D+00 ) THEN + + sdiag(j:n) = 0.0D+00 + sdiag(j) = diag(l) + ! + ! The transformations to eliminate the row of D + ! modify only a single element of Q'*B + ! beyond the first N, which is initially zero. + ! + qtbpj = 0.0D+00 + + DO k = j, n + ! + ! Determine a Givens rotation which eliminates the + ! appropriate element in the current row of D. + ! + IF ( sdiag(k) /= 0.0D+00 ) THEN + + IF ( abs ( r(k,k) ) < abs ( sdiag(k) ) ) THEN + cotan = r(k,k) / sdiag(k) + s = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan ** 2 ) + c = s * cotan + ELSE + t = sdiag(k) / r(k,k) + c = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * t ** 2 ) + s = c * t + ENDIF + ! + ! Compute the modified diagonal element of R and + ! the modified element of (Q'*B,0). + ! + r(k,k) = c * r(k,k) + s * sdiag(k) + temp = c * wa(k) + s * qtbpj + qtbpj = - s * wa(k) + c * qtbpj + wa(k) = temp + ! + ! Accumulate the tranformation in the row of S. + ! + DO i = k + 1, n + temp = c * r(i,k) + s * sdiag(i) + sdiag(i) = - s * r(i,k) + c * sdiag(i) + r(i,k) = temp + ENDDO + + ENDIF + + ENDDO + + ENDIF + ! + ! Store the diagonal element of S and restore + ! the corresponding diagonal element of R. + ! + sdiag(j) = r(j,j) + r(j,j) = x(j) + + ENDDO + ! + ! Solve the triangular system for Z. IF the system is + ! singular, THEN obtain a least squares solution. + ! + nsing = n + + DO j = 1, n + + IF ( sdiag(j) == 0.0D+00 .and. nsing == n ) THEN + nsing = j - 1 + ENDIF + + IF ( nsing < n ) THEN + wa(j) = 0.0D+00 + ENDIF + + ENDDO + + DO j = nsing, 1, -1 + sum2 = dot_product ( wa(j+1:nsing), r(j+1:nsing,j) ) + wa(j) = ( wa(j) - sum2 ) / sdiag(j) + ENDDO + ! + ! Permute the components of Z back to components of X. + ! + DO j = 1, n + l = ipvt(j) + x(l) = wa(j) + ENDDO + + RETURN + + END SUBROUTINE qrsolv + + FUNCTION enorm ( n, x ) + + !*****************************************************************************80 + ! + !! ENORM computes the Euclidean norm of a vector. + ! + ! Discussion: + ! + ! This is an extremely simplified version of the original ENORM + ! routine, which has been renamed to "ENORM2". + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, is the length of the vector. + ! + ! Input, real ( kind = 8 ) X(N), the vector whose norm is desired. + ! + ! Output, real ( kind = 8 ) ENORM, the Euclidean norm of the vector. + ! + IMPLICIT NONE + + integer ( kind = 4 ) n + real ( kind = 8 ) x(n) + real ( kind = 8 ) enorm + + enorm = sqrt ( sum ( x(1:n) ** 2 )) + + RETURN + + END FUNCTION enorm + + SUBROUTINE tridia (n, a, b, c, r, u) + + USE MOD_Precision + IMPLICIT NONE + integer, intent(in) :: n !length of diagonal element vector + real(r8), intent(in) :: a(1:n) !subdiagonal elements + real(r8), intent(in) :: b(1:n) !diagonal elements + real(r8), intent(in) :: c(1:n) !superdiagonal elements + real(r8), intent(in) :: r(1:n) !right hand side + real(r8), intent(out) :: u(1:n) !solution vector + + integer j + real(r8) gam(1:n),bet + + bet = b(1) + u(1) = r(1) / bet + DO j = 2, n + gam(j) = c(j-1) / bet + bet = b(j) - a(j) * gam(j) + u(j) = (r(j) - a(j)*u(j-1)) / bet + ENDDO + DO j = n-1, 1, -1 + u(j) = u(j) - gam(j+1) * u(j+1) + ENDDO + + END SUBROUTINE tridia + + ! ----------------------------------------------------------------- + SUBROUTINE polint(xa,ya,n,x,y) + + ! Given arrays xa and ya, each of length n, and gi + ! value y, and an error estimate dy. IF P (x) is the p + ! P (xa(i)) = ya(i), i = 1, . . . , n, THEN the returned value + ! (from: "Numerical Recipes") + + USE MOD_Precision + IMPLICIT NONE + integer n,NMAX + real(r8) dy,x,y,xa(n),ya(n) + parameter (NMAX=10) !Largest anticipated val + integer i,m,ns + real(r8) den,dif,dift,ho,hp,w,c(NMAX),d(NMAX) + + ns=1 + dif=abs(x-xa(1)) + + DO i=1,n !Here we find the index ns of the closest table entry, + dift=abs(x-xa(i)) + IF(dift.lt.dif) THEN + ns=i + dif=dift + ENDIF + c(i)=ya(i) !and initialize the tableau of c's and d's. + d(i)=ya(i) + ENDDO + + y=ya(ns) !This is the initial approximation to y. + ns=ns-1 + + DO m=1,n-1 !For each column of the tableau, + DO i=1,n-m !we loop over the current c's and d's and update them. + ho=xa(i)-x + hp=xa(i+m)-x + w=c(i+1)-d(i) + den=ho-hp + IF(den.eq.0.) print*, 'failure in polint' !two input xa's are identical. + den=w/den + d(i)=hp*den !here the c's and d's are updated. + c(i)=ho*den + ENDDO + IF(2*ns.lt.n-m)THEN !After each column in the tableau is completed, we decide + dy=c(ns+1) !which correction, c or d, we want to add to our accumulating + ELSE !value of y, i.e., which path to take through + dy=d(ns) !the tableau-forking up or down. We DO this in such a + ns=ns-1 !way as to take the most "straight line" route through the + ENDIF !tableau to its apex, updating ns accordingly to keep track + y=y+dy !of WHERE we are. This route keeps the partial approximations + ENDDO !centered (insofar as possible) on the target x. T he + !last dy added is thus the error indication. + + END SUBROUTINE polint + +END MODULE MOD_Utils diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 new file mode 100644 index 0000000000..5fa6725e4d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 @@ -0,0 +1,1136 @@ +#include + +MODULE MOD_WorkerPushData +!-------------------------------------------------------------------------------- +! DESCRIPTION: +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Utils + IMPLICIT NONE + + ! -- Data Type : push data between workers -- + type :: worker_pushdata_type + + integer :: num_req_uniq + + integer, allocatable :: addr_single (:) + + integer, allocatable :: addr_multi (:,:) + real(r8), allocatable :: area_multi (:,:) + real(r8), allocatable :: sum_area (:) + + ! data is on the same processor + integer :: nself + integer, allocatable :: self_from (:) + integer, allocatable :: self_to (:) +#ifdef COLM_PARALLEL + ! data is on other processors + integer, allocatable :: n_to_other (:) + integer, allocatable :: n_from_other (:) + type(pointer_int32_1d), allocatable :: to_other (:) + type(pointer_int32_1d), allocatable :: other_to (:) +#endif + CONTAINS + final :: worker_pushdata_free_mem + END type worker_pushdata_type + + + ! -- Data Type : remap data on workers -- + type :: worker_remapdata_type + + integer :: num_grid + integer, allocatable :: ilon_me (:) + integer, allocatable :: ilat_me (:) + integer, allocatable :: ids_me (:) + + integer :: npset + real(r8), allocatable :: sum_area (:) + integer, allocatable :: npart (:) + type(pointer_int32_1d), allocatable :: part_to (:) ! + type(pointer_real8_1d), allocatable :: areapart (:) ! intersection area + + CONTAINS + final :: worker_remapdata_free_mem + END type worker_remapdata_type + + ! -- public subroutines -- + INTERFACE build_worker_pushdata + MODULE procedure build_worker_pushdata_single + MODULE procedure build_worker_pushdata_multi + END INTERFACE build_worker_pushdata + + PUBLIC :: build_worker_pushdata_subset + + PUBLIC :: build_worker_remapdata + + INTERFACE worker_push_data + MODULE procedure worker_push_data_single_real8 + MODULE procedure worker_push_data_single_int32 + MODULE procedure worker_push_data_multi_real8 + END INTERFACE worker_push_data + + INTERFACE worker_remap_data_pset2grid + MODULE procedure worker_remap_data_pset2grid_real8 + END INTERFACE worker_remap_data_pset2grid + + INTERFACE worker_remap_data_grid2pset + MODULE procedure worker_remap_data_grid2pset_real8 + END INTERFACE worker_remap_data_grid2pset + +CONTAINS + + ! ---------- + SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, pushdata) + + IMPLICIT NONE + + integer, intent(in) :: num_me, ids_me (:) + integer, intent(in) :: n_req_uniq, ids_req_uniq (:) + type(worker_pushdata_type), intent(inout) :: pushdata + + ! Local Variables + integer, allocatable :: ids_me_sorted(:), order_ids(:), self_from(:) +#ifdef COLM_PARALLEL + integer, allocatable :: ids(:), loc_from_me(:), loc_from_other(:) + integer :: request(3) +#endif + integer :: i, iloc, iworker, jworker, n_req_other + + + IF (p_is_worker) THEN + + allocate (ids_me_sorted (num_me)) + allocate (order_ids (num_me)) + IF (num_me > 0) THEN + ids_me_sorted = ids_me + order_ids = (/(i, i = 1, num_me)/) + CALL quicksort (num_me, ids_me_sorted, order_ids) + ENDIF + + pushdata%nself = 0 + + IF (n_req_uniq > 0) THEN + allocate (self_from (n_req_uniq)) + self_from(:) = -1 + + DO i = 1, n_req_uniq + iloc = find_in_sorted_list1 (ids_req_uniq(i), num_me, ids_me_sorted) + IF (iloc > 0) THEN + self_from(i) = order_ids(iloc) + ENDIF + ENDDO + + pushdata%nself = count(self_from > 0) + IF (pushdata%nself > 0) THEN + allocate (pushdata%self_from (pushdata%nself)) + allocate (pushdata%self_to (pushdata%nself)) + pushdata%self_from = pack(self_from, self_from > 0) + pushdata%self_to = pack((/(i,i=1,n_req_uniq)/), self_from > 0) + ENDIF + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_barrier (p_comm_worker, p_err) + + allocate (pushdata%n_to_other (0:p_np_worker-1)) + allocate (pushdata%to_other (0:p_np_worker-1)) + + allocate (pushdata%n_from_other (0:p_np_worker-1)) + allocate (pushdata%other_to (0:p_np_worker-1)) + + pushdata%n_to_other (:) = 0 + pushdata%n_from_other(:) = 0 + + IF (n_req_uniq > 0) allocate (loc_from_other (n_req_uniq)) + + iworker = modulo(p_iam_worker+1, p_np_worker) + jworker = modulo(p_iam_worker-1, p_np_worker) + DO WHILE (iworker /= p_iam_worker) + + CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jworker, 10, & + p_comm_worker, request(1), p_err) + + IF (n_req_uniq > 0) THEN + CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jworker, 11, & + p_comm_worker, request(2), p_err) + ENDIF + + CALL mpi_recv (n_req_other, 1, MPI_INTEGER, iworker, 10, & + p_comm_worker, p_stat, p_err) + + IF (n_req_other > 0) THEN + + allocate (ids (n_req_other)) + CALL mpi_recv (ids, n_req_other, MPI_INTEGER, iworker, 11, & + p_comm_worker, p_stat, p_err) + + allocate (loc_from_me (n_req_other)) + loc_from_me(:) = -1 + + IF (num_me > 0) THEN + DO i = 1, n_req_other + iloc = find_in_sorted_list1 (ids(i), num_me, ids_me_sorted) + IF (iloc > 0) THEN + loc_from_me(i) = order_ids(iloc) + ENDIF + ENDDO + ENDIF + + pushdata%n_to_other(iworker) = count(loc_from_me > 0) + IF (pushdata%n_to_other(iworker) > 0) THEN + allocate (pushdata%to_other(iworker)%val (pushdata%n_to_other(iworker))) + pushdata%to_other(iworker)%val = pack(loc_from_me, loc_from_me > 0) + ENDIF + + CALL mpi_isend (loc_from_me, n_req_other, MPI_INTEGER, iworker, 12, & + p_comm_worker, request(3), p_err) + + ENDIF + + IF (n_req_uniq > 0) THEN + + CALL mpi_recv (loc_from_other, n_req_uniq, MPI_INTEGER, & + jworker, 12, p_comm_worker, p_stat, p_err) + + pushdata%n_from_other(jworker) = count(loc_from_other > 0) + IF (pushdata%n_from_other(jworker) > 0) THEN + allocate (pushdata%other_to(jworker)%val (pushdata%n_from_other(jworker))) + pushdata%other_to(jworker)%val = pack((/(i,i=1,n_req_uniq)/), loc_from_other > 0) + ENDIF + + ENDIF + + CALL mpi_wait(request(1), MPI_STATUS_IGNORE, p_err) + IF (n_req_uniq > 0) CALL mpi_wait(request(2), MPI_STATUSES_IGNORE, p_err) + IF (n_req_other > 0) CALL mpi_wait(request(3), MPI_STATUSES_IGNORE, p_err) + + IF (allocated(ids )) deallocate(ids ) + IF (allocated(loc_from_me)) deallocate(loc_from_me) + + iworker = modulo(iworker+1, p_np_worker) + jworker = modulo(jworker-1, p_np_worker) + ENDDO + + IF (allocated (loc_from_other)) deallocate (loc_from_other) + + CALL mpi_barrier (p_comm_worker, p_err) +#endif + + IF (allocated(ids_me_sorted)) deallocate(ids_me_sorted) + IF (allocated(order_ids )) deallocate(order_ids ) + IF (allocated(self_from )) deallocate(self_from ) + + ENDIF + + END SUBROUTINE build_worker_pushdata_uniq + + ! ---------- + SUBROUTINE build_worker_pushdata_single (num_me, ids_me, num_req, ids_req, pushdata) + + IMPLICIT NONE + + integer, intent(in) :: num_me, ids_me (:) + integer, intent(in) :: num_req, ids_req (:) + type(worker_pushdata_type), intent(inout) :: pushdata + + ! Local Variables + integer :: n_req_uniq, iloc, i + integer, allocatable :: ids_req_uniq (:) + + IF (p_is_worker) THEN + + n_req_uniq = 0 + + allocate (ids_req_uniq (num_req)) + IF (num_req > 0) THEN + DO i = 1, size(ids_req) + CALL insert_into_sorted_list1 (ids_req(i), n_req_uniq, ids_req_uniq, iloc) + ENDDO + + allocate (pushdata%addr_single (num_req)) + DO i = 1, size(ids_req) + pushdata%addr_single(i) = & + find_in_sorted_list1 (ids_req(i), n_req_uniq, ids_req_uniq(1:n_req_uniq)) + ENDDO + ENDIF + + pushdata%num_req_uniq = n_req_uniq + + CALL build_worker_pushdata_uniq ( & + num_me, ids_me, n_req_uniq, ids_req_uniq(1:n_req_uniq), pushdata) + + IF (allocated (ids_req_uniq)) deallocate(ids_req_uniq) + + ENDIF + + END SUBROUTINE build_worker_pushdata_single + + ! ---------- + SUBROUTINE build_worker_pushdata_multi ( & + num_me, ids_me, num_req, ids_req, area_req, pushdata) + + IMPLICIT NONE + + integer, intent(in) :: num_me, ids_me (:) + integer, intent(in) :: num_req, ids_req (:,:) + real(r8), intent(in) :: area_req(:,:) + type(worker_pushdata_type), intent(inout) :: pushdata + + ! Local Variables + integer :: ndim1, n_req_uniq, iloc, i, j, iworker + integer, allocatable :: ids_req_uniq (:) + logical, allocatable :: id_found (:) + + IF (p_is_worker) THEN + + n_req_uniq = 0 + + ndim1 = size(ids_req,1) + allocate (ids_req_uniq (ndim1*num_req)) + + IF (num_req > 0) THEN + + DO j = 1, num_req + DO i = 1, ndim1 + CALL insert_into_sorted_list1 (ids_req(i,j), n_req_uniq, ids_req_uniq, iloc) + ENDDO + ENDDO + + allocate (pushdata%addr_multi (ndim1,num_req)) + + DO j = 1, num_req + DO i = 1, ndim1 + pushdata%addr_multi(i,j) = & + find_in_sorted_list1 (ids_req(i,j), n_req_uniq, ids_req_uniq(1:n_req_uniq)) + ENDDO + ENDDO + ENDIF + + pushdata%num_req_uniq = n_req_uniq + + CALL build_worker_pushdata_uniq ( & + num_me, ids_me, n_req_uniq, ids_req_uniq(1:n_req_uniq), pushdata) + + IF (num_req > 0) THEN + allocate (pushdata%area_multi (ndim1,num_req)) + allocate (pushdata%sum_area (num_req)) + + pushdata%area_multi = area_req + + WHERE ((area_req <= 0.) .or. (ids_req <= 0)) + pushdata%area_multi = 0. + END WHERE + + allocate (id_found (n_req_uniq)) + id_found(:) = .false. + + IF (pushdata%nself > 0) id_found(pushdata%self_to) = .true. +#ifdef COLM_PARALLEL + DO iworker = 0, p_np_worker-1 + IF (pushdata%n_from_other(iworker) > 0) THEN + id_found(pushdata%other_to(iworker)%val) = .true. + ENDIF + ENDDO +#endif + + DO j = 1, num_req + DO i = 1, ndim1 + IF (.not. id_found(pushdata%addr_multi(i,j))) then + pushdata%area_multi(i,j) = 0. + ENDIF + ENDDO + ENDDO + + pushdata%sum_area = sum(pushdata%area_multi, dim = 1) + + deallocate (id_found) + ENDIF + + IF (allocated (ids_req_uniq)) deallocate(ids_req_uniq) + + ENDIF + + END SUBROUTINE build_worker_pushdata_multi + + ! ---------- + SUBROUTINE build_worker_pushdata_subset ( & + num_me, num_req, pushdata_in, subset_in, pushdata_out, subset_out, numsubset) + + USE MOD_Pixelset + IMPLICIT NONE + + integer, intent(in) :: num_me + integer, intent(in) :: num_req + + type(worker_pushdata_type), intent(in) :: pushdata_in + type(subset_type), intent(in) :: subset_in + + type(worker_pushdata_type), intent(inout) :: pushdata_out + type(subset_type), optional, intent(inout) :: subset_out + integer, optional, intent(inout) :: numsubset + + ! Local Variables + integer :: i, j, ii, jj, idsp, jdsp, kdsp, nsub, iworker + integer, allocatable :: nsub_me (:), nsub_req(:), nsub_req_uniq(:) + integer, allocatable :: subdsp_me(:), subdsp_req_uniq(:) + + IF (p_is_worker) THEN + + IF (num_me > 0) THEN + allocate (nsub_me (num_me)) + nsub_me = subset_in%subend - subset_in%substt + 1 + ENDIF + + IF (num_req > 0) THEN + allocate (nsub_req (num_req)) + ENDIF + + CALL worker_push_data (pushdata_in, nsub_me, nsub_req, 0) + + IF (present(subset_out) .and. present(numsubset)) THEN + IF (num_req > 0) THEN + allocate (subset_out%substt (num_req)) + allocate (subset_out%subend (num_req)) + + idsp = 0 + DO i = 1, num_req + IF (nsub_req(i) == 0) THEN + subset_out%substt(i) = 0 + subset_out%subend(i) = -1 + ELSE + subset_out%substt(i) = idsp + 1 + subset_out%subend(i) = idsp + nsub_req(i) + ENDIF + idsp = idsp + nsub_req(i) + ENDDO + + numsubset = idsp + ELSE + numsubset = 0 + ENDIF + ENDIF + + IF (num_me > 0) THEN + allocate (subdsp_me (num_me)) + idsp = 0 + DO i = 1, num_me + IF (nsub_me(i) > 0) THEN + subdsp_me(i) = idsp + idsp = idsp + nsub_me(i) + ENDIF + ENDDO + ENDIF + + pushdata_out%num_req_uniq = 0 + IF (pushdata_in%num_req_uniq > 0) THEN + + allocate (nsub_req_uniq (pushdata_in%num_req_uniq)) + allocate (subdsp_req_uniq (pushdata_in%num_req_uniq)) + + nsub_req_uniq(:) = 0 + DO i = 1, size(pushdata_in%addr_single) + nsub_req_uniq(pushdata_in%addr_single(i)) = nsub_req(i) + ENDDO + + idsp = 0 + DO i = 1, pushdata_in%num_req_uniq + IF (nsub_req_uniq(i) > 0) THEN + subdsp_req_uniq(i) = idsp + idsp = idsp + nsub_req_uniq(i) + ENDIF + ENDDO + + pushdata_out%num_req_uniq = sum(nsub_req_uniq) + ENDIF + + + IF (pushdata_out%num_req_uniq > 0) THEN + allocate (pushdata_out%addr_single (sum(nsub_req))) + + idsp = 0 + DO i = 1, num_req + IF (nsub_req(i) > 0) THEN + jdsp = subdsp_req_uniq(pushdata_in%addr_single(i)) + pushdata_out%addr_single(idsp+1:idsp+nsub_req(i)) = & + (/(jj, jj=jdsp+1,jdsp+nsub_req(i))/) + idsp = idsp + nsub_req(i) + ENDIF + ENDDO + ENDIF + + pushdata_out%nself = 0 + DO i = 1, pushdata_in%nself + pushdata_out%nself = pushdata_out%nself + nsub_me(pushdata_in%self_from(i)) + ENDDO + + IF (pushdata_out%nself > 0) THEN + allocate (pushdata_out%self_from (pushdata_out%nself)) + allocate (pushdata_out%self_to (pushdata_out%nself)) + + kdsp = 0 + DO i = 1, pushdata_in%nself + IF (nsub_me(pushdata_in%self_from(i)) > 0) THEN + nsub = nsub_me(pushdata_in%self_from(i)) + idsp = subdsp_me (pushdata_in%self_from(i)) + jdsp = subdsp_req_uniq(pushdata_in%self_to (i)) + pushdata_out%self_from(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) + pushdata_out%self_to (kdsp+1:kdsp+nsub) = (/(jj, jj=jdsp+1,jdsp+nsub)/) + kdsp = kdsp + nsub + ENDIF + ENDDO + ENDIF + +#ifdef COLM_PARALLEL + allocate (pushdata_out%n_to_other (0:p_np_worker-1)) + allocate (pushdata_out%to_other (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + + pushdata_out%n_to_other(iworker) = 0 + DO i = 1, pushdata_in%n_to_other(iworker) + pushdata_out%n_to_other(iworker) = pushdata_out%n_to_other(iworker) & + + nsub_me(pushdata_in%to_other(iworker)%val(i)) + ENDDO + + IF (pushdata_out%n_to_other(iworker) > 0) THEN + allocate (pushdata_out%to_other(iworker)%val (pushdata_out%n_to_other(iworker))) + kdsp = 0 + DO i = 1, pushdata_in%n_to_other(iworker) + IF (nsub_me(pushdata_in%to_other(iworker)%val(i)) > 0) THEN + nsub = nsub_me (pushdata_in%to_other(iworker)%val(i)) + idsp = subdsp_me(pushdata_in%to_other(iworker)%val(i)) + pushdata_out%to_other(iworker)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) + kdsp = kdsp + nsub + ENDIF + ENDDO + ENDIF + + ENDDO + + allocate (pushdata_out%n_from_other (0:p_np_worker-1)) + allocate (pushdata_out%other_to (0:p_np_worker-1)) + + DO iworker = 0, p_np_worker-1 + pushdata_out%n_from_other(iworker) = 0 + DO i = 1, pushdata_in%n_from_other(iworker) + pushdata_out%n_from_other(iworker) = pushdata_out%n_from_other(iworker) & + + nsub_req_uniq(pushdata_in%other_to(iworker)%val(i)) + ENDDO + + IF (pushdata_out%n_from_other(iworker) > 0) THEN + allocate (pushdata_out%other_to(iworker)%val (pushdata_out%n_from_other(iworker))) + kdsp = 0 + DO i = 1, pushdata_in%n_from_other(iworker) + IF (nsub_req_uniq(pushdata_in%other_to(iworker)%val(i)) > 0) THEN + nsub = nsub_req_uniq (pushdata_in%other_to(iworker)%val(i)) + idsp = subdsp_req_uniq(pushdata_in%other_to(iworker)%val(i)) + pushdata_out%other_to(iworker)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) + kdsp = kdsp + nsub + ENDIF + ENDDO + ENDIF + ENDDO +#endif + + IF (allocated (nsub_me )) deallocate (nsub_me ) + IF (allocated (nsub_req )) deallocate (nsub_req ) + IF (allocated (nsub_req_uniq )) deallocate (nsub_req_uniq ) + IF (allocated (subdsp_me )) deallocate (subdsp_me ) + IF (allocated (subdsp_req_uniq)) deallocate (subdsp_req_uniq) + + ENDIF + + END SUBROUTINE build_worker_pushdata_subset + + ! ---------- + SUBROUTINE build_worker_remapdata (pixelset, grid, remapdata) + + USE MOD_Grid + USE MOD_Pixelset + USE MOD_SpatialMapping + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixelset + type(grid_type), intent(in) :: grid + + type(worker_remapdata_type), intent(inout) :: remapdata + + ! Local Variables + type(spatial_mapping_type) :: mapping + integer, allocatable :: ilon_me(:), ilat_me(:) + integer :: ngrid, iproc, ig, iloc, iset, ipart + + + CALL mapping%build_arealweighted (grid, pixelset) + + IF (p_is_worker) THEN + + ngrid = 0 + DO iproc = 0, p_np_io-1 + ngrid = ngrid + mapping%glist(iproc)%ng + ENDDO + + IF (ngrid > 0) THEN + allocate (ilon_me (ngrid)) + allocate (ilat_me (ngrid)) + ENDIF + + ngrid = 0 + DO iproc = 0, p_np_io-1 + DO ig = 1, mapping%glist(iproc)%ng + CALL insert_into_sorted_list2 ( & + mapping%glist(iproc)%ilon(ig), mapping%glist(iproc)%ilat(ig), & + ngrid, ilon_me, ilat_me, iloc) + ENDDO + ENDDO + + remapdata%num_grid = ngrid + + IF (ngrid > 0) THEN + allocate (remapdata%ilon_me (ngrid)) + allocate (remapdata%ilat_me (ngrid)) + allocate (remapdata%ids_me (ngrid)) + remapdata%ilon_me = ilon_me(1:ngrid) + remapdata%ilat_me = ilat_me(1:ngrid) + remapdata%ids_me = (ilat_me(1:ngrid)-1) * grid%nlon + ilon_me(1:ngrid) + ENDIF + + remapdata%npset = mapping%npset + + IF (remapdata%npset > 0) THEN + + allocate (remapdata%sum_area (remapdata%npset)) + allocate (remapdata%npart (remapdata%npset)) + allocate (remapdata%part_to (remapdata%npset)) + allocate (remapdata%areapart (remapdata%npset)) + + remapdata%npart = mapping%npart + + DO iset = 1, remapdata%npset + IF (remapdata%npart(iset) > 0) THEN + allocate (remapdata%part_to(iset)%val (remapdata%npart(iset))) + allocate (remapdata%areapart(iset)%val (remapdata%npart(iset))) + ENDIF + + DO ipart = 1, remapdata%npart(iset) + iproc = mapping%address(iset)%val(1,ipart) + iloc = mapping%address(iset)%val(2,ipart) + remapdata%part_to(iset)%val(ipart) = find_in_sorted_list2 ( & + mapping%glist(iproc)%ilon(iloc), mapping%glist(iproc)%ilat(iloc), ngrid, ilon_me, ilat_me) + ! from km^2 to m^2 + remapdata%areapart(iset)%val(ipart) = mapping%areapart(iset)%val(ipart) * 1.e6 + ENDDO + + IF (remapdata%npart(iset) > 0) THEN + remapdata%sum_area(iset) = sum(remapdata%areapart(iset)%val) + ENDIF + ENDDO + ENDIF + + IF (allocated(ilon_me)) deallocate(ilon_me) + IF (allocated(ilat_me)) deallocate(ilat_me) + + ENDIF + + END SUBROUTINE build_worker_remapdata + + ! ---------- + SUBROUTINE worker_push_data_uniq_real8 ( & + pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(worker_pushdata_type), intent(in) :: pushdata + + real(r8), intent(in) , optional :: vec_send (:) + real(r8), intent(inout), optional :: vec_recv (:) + real(r8), intent(in) , optional :: fillvalue + + ! Local Variables + integer :: ndatasend + integer, allocatable :: req_send (:) + real(r8), allocatable :: sendcache (:) + + integer :: ndatarecv + integer, allocatable :: req_recv (:) + real(r8), allocatable :: recvcache (:) + + integer :: iworker, iproc, idsp, istt, iend, i, i_to + + + IF (p_is_worker) THEN + + IF (pushdata%num_req_uniq > 0) THEN + vec_recv = fillvalue + ENDIF + + IF (pushdata%nself > 0) THEN + vec_recv(pushdata%self_to) = vec_send(pushdata%self_from) + ENDIF + +#ifdef COLM_PARALLEL + ndatasend = sum(pushdata%n_to_other) + IF (ndatasend > 0) THEN + + allocate (sendcache(ndatasend)) + allocate (req_send (count(pushdata%n_to_other > 0))) + + iproc = 0 + idsp = 0 + DO iworker = 0, p_np_worker-1 + IF (pushdata%n_to_other(iworker) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_to_other(iworker) + + sendcache(istt:iend) = vec_send(pushdata%to_other(iworker)%val) + CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(iworker), MPI_REAL8, & + iworker, 101, p_comm_worker, req_send(iproc), p_err) + + idsp = iend + ENDIF + ENDDO + ENDIF + + ndatarecv = sum(pushdata%n_from_other) + IF (ndatarecv > 0) THEN + + allocate (recvcache(ndatarecv)) + allocate (req_recv (count(pushdata%n_from_other > 0))) + + iproc = 0 + idsp = 0 + DO iworker = 0, p_np_worker-1 + IF (pushdata%n_from_other(iworker) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_from_other(iworker) + + CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(iworker), MPI_REAL8, & + iworker, 101, p_comm_worker, req_recv(iproc), p_err) + + idsp = iend + ENDIF + ENDDO + ENDIF + + IF (ndatarecv > 0) THEN + + CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) + + idsp = 0 + DO iworker = 0, p_np_worker-1 + DO i = 1, pushdata%n_from_other(iworker) + + IF (recvcache(idsp+i) /= fillvalue) THEN + i_to = pushdata%other_to(iworker)%val(i) + IF (vec_recv(i_to) == fillvalue) THEN + vec_recv(i_to) = recvcache(idsp+i) + ELSE + vec_recv(i_to) = vec_recv(i_to) + recvcache(idsp+i) + ENDIF + ENDIF + + ENDDO + idsp = idsp + pushdata%n_from_other(iworker) + ENDDO + + ENDIF + + IF (ndatasend > 0) THEN + CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, p_err) + ENDIF + + IF (allocated(req_send )) deallocate(req_send ) + IF (allocated(sendcache)) deallocate(sendcache) + IF (allocated(req_recv )) deallocate(req_recv ) + IF (allocated(recvcache)) deallocate(recvcache) +#endif + + ENDIF + + END SUBROUTINE worker_push_data_uniq_real8 + + ! ---------- + SUBROUTINE worker_push_data_uniq_int32 ( & + pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(worker_pushdata_type), intent(in) :: pushdata + + integer, intent(in) , optional :: vec_send (:) + integer, intent(inout), optional :: vec_recv (:) + integer, intent(in) , optional :: fillvalue + + ! Local Variables + integer :: ndatasend + integer, allocatable :: req_send (:) + integer, allocatable :: sendcache (:) + + integer :: ndatarecv + integer, allocatable :: req_recv (:) + integer, allocatable :: recvcache (:) + + integer :: iworker, iproc, idsp, istt, iend, i, i_to + + + IF (p_is_worker) THEN + + IF (pushdata%num_req_uniq > 0) THEN + vec_recv = fillvalue + ENDIF + + IF (pushdata%nself > 0) THEN + vec_recv(pushdata%self_to) = vec_send(pushdata%self_from) + ENDIF + +#ifdef COLM_PARALLEL + ndatasend = sum(pushdata%n_to_other) + IF (ndatasend > 0) THEN + + allocate (sendcache(ndatasend)) + allocate (req_send (count(pushdata%n_to_other > 0))) + + iproc = 0 + idsp = 0 + DO iworker = 0, p_np_worker-1 + IF (pushdata%n_to_other(iworker) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_to_other(iworker) + + sendcache(istt:iend) = vec_send(pushdata%to_other(iworker)%val) + CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(iworker), MPI_INTEGER, & + iworker, 101, p_comm_worker, req_send(iproc), p_err) + + idsp = iend + ENDIF + ENDDO + ENDIF + + ndatarecv = sum(pushdata%n_from_other) + IF (ndatarecv > 0) THEN + + allocate (recvcache(ndatarecv)) + allocate (req_recv (count(pushdata%n_from_other > 0))) + + iproc = 0 + idsp = 0 + DO iworker = 0, p_np_worker-1 + IF (pushdata%n_from_other(iworker) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_from_other(iworker) + + CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(iworker), MPI_INTEGER, & + iworker, 101, p_comm_worker, req_recv(iproc), p_err) + + idsp = iend + ENDIF + ENDDO + ENDIF + + IF (ndatarecv > 0) THEN + + CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) + + idsp = 0 + DO iworker = 0, p_np_worker-1 + DO i = 1, pushdata%n_from_other(iworker) + + IF (recvcache(idsp+i) /= fillvalue) THEN + i_to = pushdata%other_to(iworker)%val(i) + IF (vec_recv(i_to) == fillvalue) THEN + vec_recv(i_to) = recvcache(idsp+i) + ELSE + vec_recv(i_to) = vec_recv(i_to) + recvcache(idsp+i) + ENDIF + ENDIF + + ENDDO + idsp = idsp + pushdata%n_from_other(iworker) + ENDDO + + ENDIF + + IF (ndatasend > 0) THEN + CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, p_err) + ENDIF + + IF (allocated(req_send )) deallocate(req_send ) + IF (allocated(sendcache)) deallocate(sendcache) + IF (allocated(req_recv )) deallocate(req_recv ) + IF (allocated(recvcache)) deallocate(recvcache) +#endif + + ENDIF + + END SUBROUTINE worker_push_data_uniq_int32 + + ! ---------- + SUBROUTINE worker_push_data_single_real8 (pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(worker_pushdata_type) :: pushdata + + real(r8), intent(in) :: vec_send (:) + real(r8), intent(inout) :: vec_recv (:) + real(r8), intent(in) :: fillvalue + + ! Local Variables + real(r8), allocatable :: vec_recv_uniq (:) + + IF (p_is_worker) THEN + + ! Always allocate (zero-length if no requests) to avoid passing + ! unallocated array to worker_push_data_uniq_real8. + allocate (vec_recv_uniq (pushdata%num_req_uniq)) + IF (pushdata%num_req_uniq > 0) THEN + vec_recv_uniq(:) = fillvalue + ENDIF + + CALL worker_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) + + IF (pushdata%num_req_uniq > 0) THEN + vec_recv = vec_recv_uniq(pushdata%addr_single) + ENDIF + deallocate (vec_recv_uniq) + + ENDIF + + END SUBROUTINE worker_push_data_single_real8 + + ! ---------- + SUBROUTINE worker_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalue, mode) + + IMPLICIT NONE + + type(worker_pushdata_type) :: pushdata + + real(r8), intent(in) :: vec_send (:) + real(r8), intent(inout) :: vec_recv (:) + real(r8), intent(in) :: fillvalue + + character(len=*), intent(in) :: mode + + ! Local Variables + real(r8), allocatable :: vec_recv_uniq (:) + integer :: i, j + real(r8) :: val, sumarea + + IF (p_is_worker) THEN + + ! Always allocate (zero-length if no requests) to avoid passing + ! unallocated array to worker_push_data_uniq_real8. + allocate (vec_recv_uniq (pushdata%num_req_uniq)) + IF (pushdata%num_req_uniq > 0) THEN + vec_recv_uniq(:) = fillvalue + ENDIF + + CALL worker_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) + + IF (pushdata%num_req_uniq > 0) THEN + + vec_recv(:) = fillvalue + + DO j = 1, size(pushdata%addr_multi,2) + + sumarea = 0. + + DO i = 1, size(pushdata%addr_multi,1) + val = vec_recv_uniq(pushdata%addr_multi(i,j)) + IF (val /= fillvalue) THEN + IF (vec_recv(j) == fillvalue) THEN + vec_recv(j) = val * pushdata%area_multi(i,j) + ELSE + vec_recv(j) = vec_recv(j) + val * pushdata%area_multi(i,j) + ENDIF + sumarea = sumarea + pushdata%area_multi(i,j) + ENDIF + ENDDO + + IF (trim(mode) == 'average') THEN + IF (vec_recv(j) /= fillvalue) THEN + vec_recv(j) = vec_recv(j) / sumarea + ENDIF + ENDIF + ENDDO + + ENDIF + deallocate (vec_recv_uniq) + + ENDIF + + END SUBROUTINE worker_push_data_multi_real8 + + ! ---------- + SUBROUTINE worker_push_data_single_int32 (pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(worker_pushdata_type) :: pushdata + + integer, intent(in) :: vec_send (:) + integer, intent(inout) :: vec_recv (:) + integer, intent(in) :: fillvalue + + ! Local Variables + integer, allocatable :: vec_recv_uniq (:) + + IF (p_is_worker) THEN + + allocate (vec_recv_uniq (pushdata%num_req_uniq)) + IF (pushdata%num_req_uniq > 0) THEN + vec_recv_uniq(:) = fillvalue + ENDIF + + CALL worker_push_data_uniq_int32 (pushdata, vec_send, vec_recv_uniq, fillvalue) + + IF (pushdata%num_req_uniq > 0) THEN + vec_recv = vec_recv_uniq(pushdata%addr_single) + ENDIF + deallocate (vec_recv_uniq) + + ENDIF + + END SUBROUTINE worker_push_data_single_int32 + + ! --------- + SUBROUTINE worker_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillvalue, filter) + + IMPLICIT NONE + + type(worker_remapdata_type), intent(in) :: remapdata + + real(r8), intent(in) :: vec_in (:) + real(r8), intent(inout) :: vec_out(:) + real(r8), intent(in) :: fillvalue + logical, intent(in) :: filter (:) + + ! Local Variables + integer :: iset, ipart, iloc + real(r8) :: area + + + IF (p_is_worker) THEN + IF (remapdata%num_grid > 0) THEN + + vec_out(:) = fillvalue + + DO iset = 1, remapdata%npset + IF (filter(iset) .and. (vec_in(iset) /= fillvalue)) THEN + DO ipart = 1, remapdata%npart(iset) + + iloc = remapdata%part_to(iset)%val(ipart) + area = remapdata%areapart(iset)%val(ipart) + + IF (vec_out(iloc) == fillvalue) THEN + vec_out(iloc) = vec_in(iset) * area + ELSE + vec_out(iloc) = vec_out(iloc) + vec_in(iset) * area + ENDIF + + ENDDO + ENDIF + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE worker_remap_data_pset2grid_real8 + + ! --------- + SUBROUTINE worker_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillvalue, mode) + + IMPLICIT NONE + + type(worker_remapdata_type), intent(in) :: remapdata + + real(r8), intent(in) :: vec_in (:) + real(r8), intent(inout) :: vec_out(:) + real(r8), intent(in) :: fillvalue + + character(len=*), intent(in) :: mode + + ! Local Variables + integer :: iset, ipart, iloc + real(r8) :: area, sumarea + + IF (p_is_worker) THEN + IF (remapdata%npset > 0) THEN + + vec_out(:) = fillvalue + + DO iset = 1, remapdata%npset + + sumarea = 0. + + DO ipart = 1, remapdata%npart(iset) + iloc = remapdata%part_to(iset)%val(ipart) + area = remapdata%areapart(iset)%val(ipart) + + IF (vec_in(iloc) /= fillvalue) THEN + IF (vec_out(iset) == fillvalue) THEN + vec_out(iset) = vec_in(iloc) * area + ELSE + vec_out(iset) = vec_out(iset) + vec_in(iloc) * area + ENDIF + sumarea = sumarea + area + ENDIF + ENDDO + + IF (trim(mode) == 'average') THEN + IF (vec_out(iset) /= fillvalue) THEN + vec_out(iset) = vec_out(iset) / sumarea + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE worker_remap_data_grid2pset_real8 + + ! --------- + SUBROUTINE worker_pushdata_free_mem (this) + + IMPLICIT NONE + type(worker_pushdata_type) :: this + + IF (allocated(this%addr_single )) deallocate(this%addr_single ) + IF (allocated(this%addr_multi )) deallocate(this%addr_multi ) + IF (allocated(this%area_multi )) deallocate(this%area_multi ) + IF (allocated(this%sum_area )) deallocate(this%sum_area ) + IF (allocated(this%self_from )) deallocate(this%self_from ) + IF (allocated(this%self_to )) deallocate(this%self_to ) +#ifdef COLM_PARALLEL + IF (allocated(this%n_to_other )) deallocate(this%n_to_other ) + IF (allocated(this%n_from_other)) deallocate(this%n_from_other) + IF (allocated(this%to_other )) deallocate(this%to_other ) + IF (allocated(this%other_to )) deallocate(this%other_to ) +#endif + + END SUBROUTINE worker_pushdata_free_mem + + ! --------- + SUBROUTINE worker_remapdata_free_mem (this) + + IMPLICIT NONE + type(worker_remapdata_type) :: this + + IF (allocated(this%ilon_me )) deallocate(this%ilon_me ) + IF (allocated(this%ilat_me )) deallocate(this%ilat_me ) + IF (allocated(this%ids_me )) deallocate(this%ids_me ) + IF (allocated(this%npart )) deallocate(this%npart ) + IF (allocated(this%sum_area)) deallocate(this%sum_area) + IF (allocated(this%part_to )) deallocate(this%part_to ) + IF (allocated(this%areapart)) deallocate(this%areapart) + + END SUBROUTINE worker_remapdata_free_mem + +END MODULE MOD_WorkerPushData diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index faa5761c9a..8b679a7adb 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -10037,6 +10037,7 @@ subroutine rrtmg_swrad( & swupb,swupbc,swdnb,swdnbc, & swupflx, swupflxc, swdnflx, swdnflxc, & swddir,swddni,swddif, & + swvisdir,swvisdif,swnirdir,swnirdif, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -10085,7 +10086,7 @@ subroutine rrtmg_swrad( & !--- output arguments: real,intent(out),dimension(ims:ime,jms:jme),optional:: & - swddir,swddni,swddif + swddir,swddni,swddif,swvisdir,swvisdif,swnirdir,swnirdif real,intent(out),dimension(ims:ime,kms:kme+2,jms:jme ),optional:: & swupflx,swupflxc,swdnflx,swdnflxc @@ -10625,6 +10626,14 @@ subroutine rrtmg_swrad( & swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10 endif + if(present(swvisdir) .and. present(swvisdif) .and. & + present(swnirdir) .and. present(swnirdif)) then + swvisdir(i,j) = sibvisdir(1,1) + swvisdif(i,j) = sibvisdif(1,1) + swnirdir(i,j) = sibnirdir(1,1) + swnirdif(i,j) = sibnirdif(1,1) + endif + if(present (swupflx)) then do k = kts, kte+2 swupflx(i,k,j) = swuflx(1,k) @@ -10655,6 +10664,20 @@ subroutine rrtmg_swrad( & swdnbc(i,j) = 0. endif + if(present(swddir) .and. present(swddni) .and. present(swddif)) then + swddir(i,j) = 0. + swddni(i,j) = 0. + swddif(i,j) = 0. + endif + + if(present(swvisdir) .and. present(swvisdif) .and. & + present(swnirdir) .and. present(swnirdif)) then + swvisdir(i,j) = 0. + swvisdif(i,j) = 0. + swnirdir(i,j) = 0. + swnirdif(i,j) = 0. + endif + endif end do i_loop !end longitude loop. From 423a4e50fd3dc60c124b44934fc333e32e089f94 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 18:43:33 +0800 Subject: [PATCH 02/17] Drop CoLM initial and surface generators MPAS-embedded CoLM consumes existing landdata/restart files and should not carry the standalone make-initial/make-surface generation chain. The runtime Land/PFT/Patch and SrfdataRestart loaders remain for MPAS cell-owned execution. Constraint: CoLM patch/PFT metadata still lives inside CoLM and is loaded from MPAS-owned landdata paths. Rejected: deleting all mksrfdata modules | MOD_SrfdataRestart and Land* modules are runtime loaders, not surface generators. Rejected: keeping LULCC driver sources | they depend on deleted make-surface transfer traces and MOD_Initialize. Confidence: high Scope-risk: moderate Directive: Keep CoLM source lists aligned between physics_colm2024/Makefile and core_atmosphere/CMakeLists.txt. Tested: rg found no remaining initial/surface/LULCC generator references; git diff --check; cmake -S . -B build-cmake-colm-debug; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; NETCDF=/opt/homebrew/Cellar/netcdf/4.10.0 NETCDFF=/opt/homebrew/Cellar/netcdf-fortran/4.6.2 PNETCDF=/opt/homebrew/Cellar/pnetcdf/1.14.1 make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true -j 8. Not-tested: full runtime case with real MPAS+CoLM landdata/restart inputs. --- src/core_atmosphere/CMakeLists.txt | 2 - .../physics/physics_colm2024/Makefile | 29 +- .../main/LULCC/MOD_Lulcc_Driver.F90 | 162 -- .../main/LULCC/MOD_Lulcc_Initialize.F90 | 138 -- .../LULCC/MOD_Lulcc_MassEnergyConserve.F90 | 1165 ---------- .../LULCC/MOD_Lulcc_TransferTraceReadin.F90 | 136 -- .../LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 | 201 -- .../LULCC/MOD_Lulcc_Vars_TimeVariables.F90 | 1206 ---------- .../mkinidata/MOD_DBedrockReadin.F90 | 72 - .../mkinidata/MOD_HtopReadin.F90 | 152 -- .../mkinidata/MOD_IniTimeVariable.F90 | 1376 ----------- .../mkinidata/MOD_Initialize.F90 | 1662 -------------- .../mkinidata/MOD_LakeDepthReadin.F90 | 110 - .../mkinidata/MOD_PercentagesPFTReadin.F90 | 94 - .../mkinidata/MOD_SoilColorRefl.F90 | 115 - .../mkinidata/MOD_SoilParametersReadin.F90 | 550 ----- .../mkinidata/MOD_SoilTextureReadin.F90 | 54 - .../mkinidata/MOD_UrbanIniTimeVariable.F90 | 132 -- .../mkinidata/MOD_UrbanReadin.F90 | 321 --- .../mksrfdata/Aggregation_DBedrock.F90 | 129 -- .../mksrfdata/Aggregation_ForestHeight.F90 | 332 --- .../mksrfdata/Aggregation_LAI.F90 | 759 ------ .../mksrfdata/Aggregation_LakeDepth.F90 | 145 -- .../mksrfdata/Aggregation_PercentagesPFT.F90 | 218 -- .../mksrfdata/Aggregation_SoilBrightness.F90 | 409 ---- .../mksrfdata/Aggregation_SoilHyperAlbedo.F90 | 166 -- .../mksrfdata/Aggregation_SoilParameters.F90 | 2042 ----------------- .../mksrfdata/Aggregation_SoilTexture.F90 | 139 -- .../mksrfdata/Aggregation_TopoWetness.F90 | 345 --- .../mksrfdata/Aggregation_Topography.F90 | 206 -- .../Aggregation_TopographyFactors.F90 | 522 ----- .../Aggregation_TopographyFactors_Simple.F90 | 242 -- .../mksrfdata/Aggregation_Urban.F90 | 1293 ----------- .../mksrfdata/MOD_LandPFT.F90 | 3 +- .../mksrfdata/MOD_Lulcc_TransferTrace.F90 | 293 --- .../mksrfdata/MOD_RegionClip.F90 | 809 ------- .../mksrfdata/MOD_SrfdataDiag.F90 | 553 ----- 37 files changed, 7 insertions(+), 16275 deletions(-) delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 9b94b64ca6..500de79be7 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -321,12 +321,10 @@ if(MPAS_COLM2024) include share mksrfdata - mkinidata main main/HYDRO main/BGC main/URBAN - main/LULCC main/DA main/ParaOpt drivers/mpas diff --git a/src/core_atmosphere/physics/physics_colm2024/Makefile b/src/core_atmosphere/physics/physics_colm2024/Makefile index e19c22d2bb..8a922e1cb3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/Makefile +++ b/src/core_atmosphere/physics/physics_colm2024/Makefile @@ -10,13 +10,15 @@ endif ifneq ($(strip $(PNETCDF_INC)),) INCLUDE_DIR += -I$(PNETCDF_INC) endif -VPATH = include : share : mksrfdata : mkinidata \ - : main : main/HYDRO : main/BGC : main/URBAN : main/LULCC : main/DA \ +VPATH = include : share : mksrfdata \ + : main : main/HYDRO : main/BGC : main/URBAN : main/DA \ : main/ParaOpt : drivers/mpas : .bld .PHONY: all all : mpas_objects +.NOTPARALLEL: + .PHONY: mkdir_build mkdir_build : mkdir -p .bld @@ -59,12 +61,10 @@ OBJS_SHARED = \ MOD_LandUrban.o \ MOD_Urban_Const_LCZ.o \ MOD_SingleSrfdata.o \ - MOD_SrfdataDiag.o \ MOD_SrfdataRestart.o \ MOD_ElmVector.o \ MOD_HRUVector.o \ - MOD_MeshFilter.o \ - MOD_RegionClip.o + MOD_MeshFilter.o ${OBJS_SHARED} : %.o : %.F90 ${HEADER} ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld @@ -121,23 +121,12 @@ OBJS_BASIC = \ MOD_Urban_Shortwave.o \ MOD_Urban_Albedo.o \ MOD_MonthlyinSituCO2MaunaLoa.o \ - MOD_PercentagesPFTReadin.o \ - MOD_LakeDepthReadin.o \ - MOD_DBedrockReadin.o \ - MOD_SoilColorRefl.o \ - MOD_SoilParametersReadin.o \ - MOD_SoilTextureReadin.o \ - MOD_HtopReadin.o \ - MOD_UrbanReadin.o \ MOD_BGC_CNSummary.o \ - MOD_IniTimeVariable.o \ - MOD_UrbanIniTimeVariable.o \ MOD_ElementNeighbour.o \ MOD_Catch_HillslopeNetwork.o \ MOD_Catch_RiverLakeNetwork.o \ MOD_Catch_Reservoir.o \ - MOD_VicParaReadin.o \ - MOD_Initialize.o + MOD_VicParaReadin.o $(OBJS_BASIC) : %.o : %.F90 ${HEADER} ${OBJS_SHARED} @@ -248,12 +237,6 @@ OBJS_MAIN = \ MOD_Urban_LUCY.o \ MOD_Urban_Thermal.o \ CoLMMAIN_Urban.o \ - MOD_Lulcc_Vars_TimeInvariants.o \ - MOD_Lulcc_Vars_TimeVariables.o \ - MOD_Lulcc_TransferTraceReadin.o \ - MOD_Lulcc_MassEnergyConserve.o \ - MOD_Lulcc_Initialize.o \ - MOD_Lulcc_Driver.o \ CoLMDRIVER.o \ MOD_CoLM_MPAS_Interface.o \ CoLMMAIN.o diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 deleted file mode 100644 index 729503c858..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Driver.F90 +++ /dev/null @@ -1,162 +0,0 @@ -#include - -#ifdef LULCC -MODULE MOD_Lulcc_Driver - - USE MOD_Precision - IMPLICIT NONE - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: LulccDriver - - CONTAINS - - - SUBROUTINE LulccDriver (casename, dir_landdata, dir_restart, & - jdate, greenwich) - -!----------------------------------------------------------------------- -! -! !DESCRIPTION: -! the main subroutine for Land use and land cover change simulation -! -! Created by Hua Yuan, 04/08/2022 -! -! !REVISIONS: -! 07/2023, Wenzong Dong: porting to MPI version. -! 08/2023, Wanyi Lin: add interface for Mass&Energy conserved scheme. -! -!----------------------------------------------------------------------- -! -! ***** For Development ***** -! -! Extra processes when adding a new variable and #define LULCC: -! -! 1. Save a copy of new variable (if called "var", save it to "var_") -! with 2 steps: -! -! 1.1 main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine -! "allocate_LulccTimeVariables": -! allocate (var_(dimension)) -! -! 1.2 main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine -! "SAVE_LulccTimeVariables": -! var_ = var -! -! 2. Reassignment for the next year -! -! 2.1 if used Same Type Assignment (SAT) scheme for variable recovery -! main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine -! "REST_LulccTimeVariables" -! var(np) = var_(np_) -! -! 2.2 if using Mass and Energy conservation (MEC) scheme for variable -! recovery -! -! 2.2.1 main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90's subroutine -! "REST_LulccTimeVariables": -! var(np) = var_(np_) -! -! 2.2.2 [No need for PFT/PC scheme] Mass and Energy conserve -! adjustment, add after line 519 of MOD_Lulcc_MassEnergyConserve.F90. -! -! o if variable should be mass conserved: -! var(:,np) = var(:,np) + & -! var(:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np -! -! o if variable should be energy conserved, take soil temperature -! "t_soisno" as an example: [May neeed extra calculation] -! t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) + & -! t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k)* & -! lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) -! where cvsoil_ is the heat capacity, wgt is the sum of -! cvsoil_(1:nl_soil,k)*lccpct_np(patchclass_(frnp_(k))), which need to -! be calculated in advance. -! -! 3. Deallocate the copy of new variable in -! MOD_Lulcc_Vars_TimeVariables.F90's subroutine -! "deallocate_LulccTimeVariables": -! deallocate (var_) -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Lulcc_Vars_TimeInvariants - USE MOD_Lulcc_Vars_TimeVariables - USE MOD_Lulcc_Initialize - USE MOD_Vars_TimeVariables - USE MOD_Lulcc_TransferTraceReadin - USE MOD_Lulcc_MassEnergyConserve - USE MOD_Namelist - - IMPLICIT NONE - - character(len=256), intent(in) :: casename !casename name - character(len=256), intent(in) :: dir_landdata !surface data directory - character(len=256), intent(in) :: dir_restart !case restart data directory - - logical, intent(in) :: greenwich !true: greenwich time, false: local time - integer, intent(inout) :: jdate(3) !year, julian day, seconds of the starting time -!----------------------------------------------------------------------- - - ! allocate Lulcc memory - CALL allocate_LulccTimeInvariants - CALL allocate_LulccTimeVariables - - ! SAVE variables - CALL SAVE_LulccTimeInvariants - CALL SAVE_LulccTimeVariables - - ! ============================================================= - ! cold start for Lulcc - ! ============================================================= - - IF (p_is_master) THEN - print *, ">>> LULCC: initializing..." - ENDIF - - CALL LulccInitialize (casename, dir_landdata, dir_restart, & - jdate, greenwich) - - - ! ============================================================= - ! 1. Same Type Assignment (SAT) scheme for variable recovery - ! ============================================================= - - IF (DEF_LULCC_SCHEME == 1) THEN - IF (p_is_master) THEN - print *, ">>> LULCC: Same Type Assignment (SAT) scheme for variable recovery..." - ENDIF - CALL REST_LulccTimeVariables - ENDIF - - - ! ============================================================= - ! 2. Mass and Energy conservation (MEC) scheme for variable recovery - ! ============================================================= - - IF (DEF_LULCC_SCHEME == 2) THEN - IF (p_is_master) THEN - print *, ">>> LULCC: Mass&Energy conserve (MEC) for variable recovery..." - ENDIF - CALL allocate_LulccTransferTrace() - CALL REST_LulccTimeVariables - CALL LulccTransferTraceReadin(jdate(1)) - CALL LulccMassEnergyConserve() - ENDIF - - - ! deallocate Lulcc memory - CALL deallocate_LulccTimeInvariants() - CALL deallocate_LulccTimeVariables() - IF (DEF_LULCC_SCHEME == 2) THEN - CALL deallocate_LulccTransferTrace() - ENDIF - - END SUBROUTINE LulccDriver - -END MODULE MOD_Lulcc_Driver -#endif -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 deleted file mode 100644 index 7b260a81ab..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Initialize.F90 +++ /dev/null @@ -1,138 +0,0 @@ -#include -#ifdef LULCC -MODULE MOD_Lulcc_Initialize - - USE MOD_Precision - IMPLICIT NONE - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: LulccInitialize - -CONTAINS - - SUBROUTINE LulccInitialize (casename, dir_landdata, dir_restart, & - jdate, greenwich) - -!----------------------------------------------------------------------- -! -! !DESCRIPTION: -! Initialization routine for Land-use-Land-cover-change (Lulcc) case -! -! Created by Hua Yuan, 04/08/2022 -! -! !REVISIONS: -! 08/2023, Wenzong Dong: Porting to MPI version and share the same code -! with MOD_Initialize:initialize() -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif - USE MOD_LandUrban - USE MOD_Const_LC - USE MOD_Const_PFT - USE MOD_TimeManager - USE MOD_Lulcc_Vars_TimeInvariants - USE MOD_Lulcc_Vars_TimeVariables - USE MOD_SrfdataRestart - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Initialize - - IMPLICIT NONE - -!-------------------------- Dummy Arguments ---------------------------- - character(len=*), intent(in) :: casename ! case name - character(len=*), intent(in) :: dir_landdata - character(len=*), intent(in) :: dir_restart - - integer, intent(inout) :: jdate(3) ! year, julian day, seconds of the starting time - logical, intent(in) :: greenwich ! true: greenwich time, false: local time - -!-------------------------- Local Variables ---------------------------- - integer :: year, jday - -!----------------------------------------------------------------------- - - ! initial time of model run and consts - year = jdate(1) - jday = jdate(2) - - CALL Init_GlobalVars - CALL Init_LC_Const - CALL Init_PFT_Const - - ! deallocate pixelset and mesh data of previous year - CALL mesh_free_mem - CALL landelm%forc_free_mem - CALL landpatch%forc_free_mem -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL landpft%forc_free_mem -#endif -#ifdef URBAN_MODEL - CALL landurban%forc_free_mem -#endif - - ! load pixelset and mesh data of next year - ! CALL pixel%load_from_file (dir_landdata) - ! CALL gblock%load_from_file (dir_landdata) - CALL mesh_load_from_file (dir_landdata, year) - CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , year) - - ! load CATCHMENT of next year -#ifdef CATCHMENT - CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , year) -#endif - - ! load landpatch data of next year - CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, year) - - ! load pft data of PFT/PC of next year -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , year) - CALL map_patch_to_pft -#endif - - ! load urban data of next year -#ifdef URBAN_MODEL - CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, year) - CALL map_patch_to_urban -#endif - - ! initialize for data associated with land element -#if (defined UNSTRUCTURED || defined CATCHMENT) - CALL elm_vector_init () -#ifdef CATCHMENT - CALL hru_vector_init () -#endif -#endif - - ! build element subfraction of next year which it's needed in the MOD_Lulcc_TransferTrace - IF (p_is_worker) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) - ENDIF - - - ! -------------------------------------------------------------------- - ! Deallocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------------------------- - CALL deallocate_TimeInvariants - CALL deallocate_TimeVariables - - ! initialize all state variables of next year - CALL initialize (casename, dir_landdata, dir_restart,& - jdate, year, greenwich, lulcc_call=.true.) - - END SUBROUTINE LulccInitialize - -END MODULE MOD_Lulcc_Initialize -#endif -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 deleted file mode 100644 index 6909cbcabf..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 +++ /dev/null @@ -1,1165 +0,0 @@ -#include - -#ifdef LULCC -MODULE MOD_Lulcc_MassEnergyConserve - - USE MOD_Precision - IMPLICIT NONE - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: LulccMassEnergyConserve - -CONTAINS - - - SUBROUTINE LulccMassEnergyConserve - -!----------------------------------------------------------------------- -! -! !DESCRIPTION -! This is the main subroutine to execute the calculation of the restart -! variables for the begin of next year. There are mainly three ways to -! adjust restart variables: -! -! 1) variable related to mass: area weighted mean of the source -! patches, e.g., ldew, wliq_soisno. variable related to energy: keep -! energy conserve after the change of temperature, e.g., t_soisno. -! -! 2) recalculate according to physical process, e.g., dz_sno, scv, -! fsno. -! -! Created by Wanyi Lin and Hua Yuan, 07/2023 -! -! !REVISIONS: -! -! 10/2023, Wanyi Lin: share the codes with REST_LulccTimeVariables(), -! and simplify the codes in this subroutine. -! -! 01/2024, Wanyi Lin: use "enthalpy conservation" for snow layer -! temperature calculation. -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_LandElm - USE MOD_Mesh - USE MOD_SPMD_Task - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Lulcc_Vars_TimeInvariants - USE MOD_Lulcc_Vars_TimeVariables - USE MOD_Lulcc_TransferTraceReadin -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables -#endif -#ifdef URBAN_MODEL - USE MOD_LandUrban - USE MOD_Urban_Vars_TimeVariables - USE MOD_Urban_Vars_TimeInvariants -#endif - USE MOD_Const_Physical, only: cpice, cpliq, hfus, tfrz, denh2o, denice - USE MOD_GroundTemperature - USE MOD_SnowFraction - USE MOD_Albedo - USE MOD_Namelist - USE MOD_Hydro_SoilWater - - IMPLICIT NONE - -!-------------------------- Local Variables ---------------------------- - integer, allocatable, dimension(:) :: grid_patch_s , grid_patch_e - integer, allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ - integer, allocatable, dimension(:) :: locpxl - integer :: numpxl,ipxl - - integer, allocatable :: frnp_(:) !index of source patches - integer, allocatable :: gu_(:) !index of urban patches in last year's grid - real(r8),allocatable :: cvsoil_(:,:) !heat capacity [J/(m2 K)] - real(r8),allocatable :: h_(:,:) !enthalpy of source patches [J/m2] - - integer :: k, ilc, num, inp_ - integer :: i, j, np, np_, selfnp_, l, ipft, ip, ip_, pc, pc_ - integer :: nsl !number of snow layer of the source patch with maximum area - integer :: nsl_max !maximum number of snow layer considering all source patches - integer :: u, u_, iu, selfu_, nurb, duclass - integer :: nlc = N_land_classification - integer :: ps, pe, ps_, pe_ !start and end index of patch pft - - real(r8), dimension(1:N_land_classification) :: lccpct_np - real(r8):: sum_lccpct_np, wgt(maxsnl+1:nl_soil), hc(maxsnl+1:0) - real(r8):: zi_sno(maxsnl+1:0) !local variable for snow node and depth calculation - real(r8):: vf_water !volumetric fraction liquid water within soil - real(r8):: vf_ice !volumetric fraction ice lens within soil - real(r8):: hcap !J/(m3 K) - real(r8):: c_water !Specific heat of water * density of liquid water - real(r8):: c_ice !Specific heat of ice * density of ice - real(r8):: denice_np(maxsnl+1:0), denh2o_np(maxsnl+1:0), rhosnow_np(maxsnl+1:0) - real(r8):: wbef,wpre !water before and water present for water calculation heck - ! real(r8):: fmelt !dimensionless melting factor - real(r8):: wt !fraction of vegetation covered with snow [-] - real(r8), parameter :: m = 1.0 !the value of m used in CLM4.5 is 1.0. - ! real(r8) :: deltim = 1800. !time step (seconds) TODO: be intent in - logical :: FROM_SOIL, FOUND - - ! update for zwt, wa, ldew - real(r8) :: tolerance, tol_z, tol_v, zi_soisno(0:nl_soil), sp_zi(0:nl_soil), sp_dz(1:nl_soil) -#ifdef Campbell_SOIL_MODEL - integer, parameter :: nprms = 1 -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - integer, parameter :: nprms = 5 -#endif - real(r8) :: prms(nprms, 1:nl_soil) - real(r8) :: ldew_tmp -!----------------------------------------------------------------------- - - IF (p_is_worker) THEN - - ! allocate with numelm - allocate(grid_patch_s (numelm )) - allocate(grid_patch_e (numelm )) - allocate(grid_patch_s_(numelm_)) - allocate(grid_patch_e_(numelm_)) - - grid_patch_e (:) = -1 - grid_patch_s (:) = -1 - grid_patch_e_(:) = -1 - grid_patch_s_(:) = -1 - - ! loop for numelm of next year, patches at the beginning and end of - ! the element were recorded landpatch%eindex is arranged in order, - ! and the not land element is skipped so, if element is missing, the - ! recorder is -1. - DO i=1, numelm - ! how many patches in ith element in this worker - numpxl = count(landpatch%eindex==landelm%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - ! get all patches' index that eindex is equal the i element - locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) - ! the min index is the start of patch's index - grid_patch_s(i) = minval(locpxl) - ! the max index is the end of patch's index - grid_patch_e(i) = maxval(locpxl) - ENDDO - - ! same as above, loop for numelm of previous year - ! patches at the beginning and end of the element were recorded - DO i=1, numelm_ - numpxl = count(landpatch_%eindex==landelm_%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - locpxl = pack([(ipxl, ipxl=1, numpatch_)], landpatch_%eindex==landelm_%eindex(i)) - - grid_patch_s_(i) = minval(locpxl) - grid_patch_e_(i) = maxval(locpxl) - ENDDO - - DO i=1, numelm - DO j=1,numelm_ - IF (landelm%eindex(i) == landelm_%eindex(j)) THEN - np = grid_patch_s (i) - np_= grid_patch_s_(j) - - IF (np.le.0) CYCLE - - DO WHILE (np.le.grid_patch_e(i)) - -IF (patchtype(np) .ne. 3) THEN !not a glacier patch - -IF (DEF_USE_PFT .or. DEF_FAST_PC) THEN - lccpct_np(:) = 0 - lccpct_np(1) = sum(lccpct_patches(np,1:), mask=patchtypes(:)==0) - lccpct_np(URBAN ) = lccpct_patches(np,URBAN ) - lccpct_np(WETLAND) = lccpct_patches(np,WETLAND) - lccpct_np(WATERBODY) = lccpct_patches(np,WATERBODY) - lccpct_np(GLACIERS) = lccpct_patches(np,GLACIERS) - - !TODO: treat cropland separately for FAST_PC - IF ( DEF_FAST_PC ) THEN - lccpct_np(CROPLAND) = lccpct_patches(np,CROPLAND) & - + lccpct_patches(np,14) - lccpct_np(1) = lccpct_np(1) - lccpct_np(CROPLAND) - ENDIF -ELSE - lccpct_np(:) = lccpct_patches(np,1:nlc) -ENDIF - - num = count(lccpct_np .gt. 0) - sum_lccpct_np = sum(lccpct_np) - allocate ( frnp_ ( num)) - allocate ( cvsoil_(maxsnl+1:nl_soil,num)) - allocate ( h_ (maxsnl+1:0, num)) - - ! Source patch type which differs from np's type exists - IF ( (sum_lccpct_np - lccpct_np(patchclass(np))) .gt. 0 ) THEN - - ! Get the index of source patches, and stored as frnp_ - k = 0 - DO ilc = 1, nlc - - IF (lccpct_np(ilc) .gt. 0) THEN - FOUND = .FALSE. - k = k + 1 - inp_ = np_ - - DO WHILE (inp_ .le. grid_patch_e_(j)) - - ! Get the index of source patch that has the - ! same LC, and stored as selfnp_ - IF (patchclass_(inp_) .eq. patchclass(np)) THEN - selfnp_ = inp_ - ENDIF - - IF (patchclass_(inp_) .eq. ilc) THEN - frnp_(k) = inp_ - FOUND = .TRUE. - EXIT - ENDIF - inp_ = inp_ + 1 - ENDDO - IF (.not.(FOUND)) THEN - PRINT*, 'source patch not found, np', np, 'patchclass_', & - patchclass_(grid_patch_s_(j):grid_patch_e_(j)) - ENDIF - ELSE - CYCLE - ENDIF - ENDDO - - ! Initialize - wliq_soisno (:,np) = 0 !liquid water in layers [kg/m2] - wice_soisno (:,np) = 0 !ice lens in layers [kg/m2] - t_soisno (:,np) = 0 !soil + snow layer temperature [K] - z_sno (:,np) = 0 !node depth [m] - dz_sno (:,np) = 0 !interface depth [m] - t_grnd (np) = 0 !ground surface temperature [K] - tleaf (np) = 0 !leaf temperature [K] - ldew (np) = 0 !depth of water on foliage [mm] - ldew_rain (np) = 0 !depth of rain on foliage [mm] - ldew_snow (np) = 0 !depth of snow on foliage [mm] - sag (np) = 0 !non dimensional snow age [-] - scv (np) = 0 !snow cover, water equivalent [mm] - snowdp (np) = 0 !snow depth [meter] - fsno (np) = 0 !frac of snow cover on ground - sigf (np) = 0 !frac of veg cover, exclud snow-covered veg [-] - zwt (np) = 0 !the depth to water table [m] - wa (np) = 0 !water storage in aquifer [mm] - wdsrf (np) = 0 !depth of surface water [mm] - smp (:,np) = 0 !soil matrix potential [mm] - hk (:,np) = 0 !hydraulic conductivity [mm h2o/s] - - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp (:,np) = 0 !vegetation water potential [mm] - gs0sun (np) = 0 !working copy of sunlit stomata conductance - gs0sha (np) = 0 !working copy of shaded stomata conductance - ENDIF - - IF(DEF_USE_OZONESTRESS)THEN - lai_old (np) = 0 !lai in last time step - ENDIF - - snw_rds (:,np) = 0 !effective grain radius (col,lyr) [microns, m-6] - mss_bcpho (:,np) = 0 !mass of hydrophobic BC in snow (col,lyr) [kg] - mss_bcphi (:,np) = 0 !mass of hydrophillic BC in snow (col,lyr) [kg] - mss_ocpho (:,np) = 0 !mass of hydrophobic OC in snow (col,lyr) [kg] - mss_ocphi (:,np) = 0 !mass of hydrophillic OC in snow (col,lyr) [kg] - mss_dst1 (:,np) = 0 !mass of dust species 1 in snow (col,lyr) [kg] - mss_dst2 (:,np) = 0 !mass of dust species 2 in snow (col,lyr) [kg] - mss_dst3 (:,np) = 0 !mass of dust species 3 in snow (col,lyr) [kg] - mss_dst4 (:,np) = 0 !mass of dust species 4 in snow (col,lyr) [kg] - ssno_lyr(:,:,:,np) = 0 !snow layer absorption [-] - - trad (np) = 0 !radiative temperature of surface [K] - tref (np) = 0 !2 m height air temperature [kelvin] - qref (np) = 0 !2 m height air specific humidity - rst (np) = 0 !canopy stomatal resistance (s/m) - emis (np) = 0 !averaged bulk surface emissivity - z0m (np) = 0 !effective roughness [m] - zol (np) = 0 !dimensionless height (z/L) used in M-O theory - rib (np) = 0 !bulk Richardson number in surface layer - ustar (np) = 0 !u* in similarity theory [m/s] - qstar (np) = 0 !q* in similarity theory [kg/kg] - tstar (np) = 0 !t* in similarity theory [K] - fm (np) = 0 !integral of profile function for momentum - fh (np) = 0 !integral of profile function for heat - fq (np) = 0 !integral of profile function for moisture - - - ! ============================================================= - ! 1) Mass and Energy conserve adjustment (except for dz_sno). - ! ============================================================= - - ! Calculate the weight of temperature adjustment - c_water = cpliq * denh2o ! J/(m3 K) = 4188 [J/(kg K)]*1000(kg/m3) - c_ice = cpice * denice ! J/(m3 K) = 2117.27[J/(kg K)]*917 (kg/m3) - cvsoil_(:,:) = 0 - h_ (:,:) = 0 - wgt(maxsnl+1:nl_soil) = 0 - hc (maxsnl+1:0 ) = 0 - - DO k = 1, num - - ! Soil ground and wetland heat capacity from: MOD_GroundTemperature.F90 - DO l = 1, nl_soil - vf_water = wliq_soisno_(l,frnp_(k))/(dz_soi(l)*denh2o) - vf_ice = wice_soisno_(l,frnp_(k))/(dz_soi(l)*denice) - hcap = csol_(l,frnp_(k)) + vf_water*c_water + vf_ice*c_ice - cvsoil_(l,k) = hcap*dz_soi(l) - ENDDO - - ! no snow layer exist - IF( dz_sno_(0,frnp_(k))<1.e-6 .and. scv_(frnp_(k))>0.) THEN - cvsoil_(1,k) = cvsoil_(1,k) + cpice*scv_(frnp_(k)) - ENDIF - - ! Snow heat capacity - IF( z_sno_(0,frnp_(k)) < 0 ) THEN - cvsoil_(:0,k) = cpliq*wliq_soisno_(:0,frnp_(k)) & - + cpice*wice_soisno_(:0,frnp_(k)) - h_(:0,k) = (cpliq*wliq_soisno_(:0,frnp_(k)) + & - cpice*wice_soisno_(:0,frnp_(k))) & - * (t_soisno_(:0,frnp_(k)) - tfrz) & - + hfus*wliq_soisno_(:0,frnp_(k)) - ENDIF - - wgt(maxsnl+1:nl_soil) = wgt(maxsnl+1:nl_soil) & - + cvsoil_(maxsnl+1:nl_soil,k) * lccpct_np(patchclass_(frnp_(k))) - hc(:0) = hc(:0) & - + h_(:0,k) * lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np - ENDDO - - ! Get the maximum lccpct for snow layers assignment - inp_ = frnp_(1) - k = 2 - DO WHILE (k .le. num) - IF ( lccpct_np(patchclass_(frnp_(k))) & - .gt. lccpct_np(patchclass_(inp_)) ) THEN - inp_ = frnp_(k) - ENDIF - k = k + 1 - ENDDO - - ! check if snow layer exist in patch inp_ - nsl = count(z_sno_(:,inp_) .lt. 0) - nsl_max = count(wgt(:0) .gt. 0) - ! denh2o_np(maxsnl+1:0) = 0 - ! denice_np(maxsnl+1:0) = 0 - rhosnow_np(maxsnl+1:0) = 0 ! partial density of water/snow (ice + liquid) - - IF (nsl > 0) THEN - ! move wgt above nsl to nsl - IF ( nsl_max > nsl) THEN - DO l = nsl+1, nsl_max - wgt(-nsl+1) = wgt(-nsl+1) + wgt(-l+1) - hc (-nsl+1) = hc (-nsl+1) + hc (-l+1) - ENDDO - ENDIF - - DO k = 1, num - - t_soisno (-nsl+1:0,np) = t_soisno (-nsl+1:0,np) & - + t_soisno_(-nsl+1:0,frnp_(k))*cvsoil_(-nsl+1:0,k) & - * lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1:0) - wliq_soisno (-nsl+1:0,np) = wliq_soisno (-nsl+1:0,np) & - + wliq_soisno_(-nsl+1:0,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno (-nsl+1:0,np) = wice_soisno (-nsl+1:0,np) & - + wice_soisno_(-nsl+1:0,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - l = 1 - DO WHILE ( (l .le. nsl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) - ! denh2o_np (-l+1) = denh2o_np(-l+1) & - ! + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ! denice_np (-l+1) = denice_np(-l+1) & - ! + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - ! Reference: MOD_GroundTemperature.F90 Line205 - rhosnow_np (-l+1) = rhosnow_np(-l+1) & - + (wliq_soisno_(-l+1,frnp_(k)) + wice_soisno_(-l+1,frnp_(k))) & - / dz_sno_(-l+1,frnp_(k)) & - * (lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np) - l = l + 1 - IF (l .gt. -maxsnl) EXIT - ENDDO - - ! if source patch has more snow layer than the main patch - IF (nsl .lt. -maxsnl) THEN - l = nsl+1 - DO WHILE ( (l .le. -maxsnl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) - - wliq_soisno(-nsl+1,np) = wliq_soisno (-nsl+1,np) & - + wliq_soisno_(-l+1,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno(-nsl+1,np) = wice_soisno (-nsl+1,np) & - + wice_soisno_(-l+1,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - t_soisno (-nsl+1,np) = t_soisno (-nsl+1,np) & - + t_soisno_(-l+1,frnp_(k))*cvsoil_(-l+1,k) & - * lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1) - - ! denh2o_np (-nsl+1) = denh2o_np(-nsl+1) & - ! + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ! denice_np (-nsl+1) = denice_np(-nsl+1) & - ! + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - rhosnow_np (-nsl+1) = rhosnow_np(-nsl+1) & - + (wliq_soisno_(-l+1,frnp_(k))+wice_soisno_(-l+1,frnp_(k))) & - / dz_sno_(-l+1,frnp_(k)) & - * (lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np) - l = l + 1 - IF (l .gt. -maxsnl) EXIT - ENDDO - ENDIF - ENDDO - - - - ! snow layer node and depth calculation according to new mass and density - zi_sno(0) = 0._r8 - DO l = 0, -nsl+1, -1 - - ! IF (denice_np(l)>0 .and. denh2o_np(l)>0) THEN - ! dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) & - ! + wliq_soisno(l,np)/denh2o_np(l) - - ! ELSEIF (denice_np(l)==0 .and. denh2o_np(l)>0) THEN - ! dz_sno (l,np) = wliq_soisno(l,np)/denh2o_np(l) - ! ! print*, 'denice=0! np=',np,'igbp=',patchclass(np),& - ! 'nsl=',nsl,'frnp_=',frnp_ - ! ! DO k = 1,num - ! ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) - ! ! ENDDO - - ! ELSEIF (denh2o_np(l)==0 .and. denice_np(l)>0) THEN - ! dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) - ! ! print*, 'denh2o=0! np=',np,'igbp=',patchclass(np),& - ! 'nsl=',nsl,'frnp_=',frnp_ - ! ! DO k = 1,num - ! ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - ! ! ENDDO - - ! ELSE - ! print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),& - ! 'nsl=',nsl,'frnp_=',frnp_ - ! DO k = 1,num - ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) - ! ENDDO - ! CALL CoLM_stop() - ! ENDIF - - - ! Reference: MOD_SnowLayersCombineDivide.F90's subroutine combo - IF (hc(l) < 0.) THEN - t_soisno (l,np) = tfrz + hc(l) / (cpice*wice_soisno(l,np) & - + cpliq*wliq_soisno(l,np)) - ELSEIF (hc(l) .le. hfus*wliq_soisno(l,np)) THEN - t_soisno (l,np) = tfrz - ELSE - t_soisno (l,np) = tfrz + (hc(l) - hfus*wliq_soisno(l,np)) & - / (cpice*wice_soisno(l,np)+cpliq*wliq_soisno(l,np)) - ENDIF - - - dz_sno (l,np) = (wice_soisno(l,np) + wliq_soisno(l,np))/rhosnow_np(l) - - z_sno (l,np) = zi_sno(l) - 0.5_r8*dz_sno(l,np) - IF (l-1 .lt. maxsnl+1) EXIT - zi_sno (l-1) = zi_sno(l) - dz_sno(l,np) - - ENDDO - - ELSE - ! no snow layer exist in the main patch, add a layer - ! move wgt above soil to layer 0 - IF ( nsl_max > nsl) THEN - DO l = nsl+1, nsl_max - wgt(0) = wgt(0) + wgt(-l+1) - ENDDO - ENDIF - - l = 0 - DO WHILE (wgt(l) .gt. 0) - DO k = 1, num - - wliq_soisno(0,np) = wliq_soisno(0,np) & - + wliq_soisno_(l,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno(0,np) = wice_soisno(0,np) & - + wice_soisno_(l,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - t_soisno (0,np) = t_soisno (0,np) & - + t_soisno_(l,frnp_(k))*cvsoil_(l,k) & - * lccpct_np(patchclass_(frnp_(k)))/wgt(0) - - IF (dz_sno_(l,frnp_(k)) .gt. 0) THEN - ! denh2o_np(0) = denh2o_np(0) & - ! + wliq_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ! denice_np(0) = denice_np(0) & - ! + wice_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - rhosnow_np(0) = rhosnow_np(0) & - + (wliq_soisno_(l,frnp_(k)) + wice_soisno_(l,frnp_(k))) & - / dz_sno_(l,frnp_(k)) & - * (lccpct_np(patchclass_(frnp_(k))) / sum_lccpct_np) - ENDIF - ENDDO - - l = l-1 - IF (l .lt. maxsnl+1) EXIT - ENDDO - - IF (wgt(0) .gt. 0) THEN - - ! snow layer node and depth calculation according to - ! new mass and density - ! IF (denh2o_np(0)>0 .and. denh2o_np(0)>0) THEN - ! dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) & - ! + wliq_soisno(0,np)/denh2o_np(0) - ! ELSEIF (denice_np(0)==0 .and. denh2o_np(0)>0) THEN - ! dz_sno (0,np) = wliq_soisno(0,np)/denh2o_np(0) - ! ! print*, 'denice=0! stop! np=',np,'igbp=',patchclass(np),& - ! 'nsl=',nsl,'frnp_=',frnp_ - ! ! DO k = 1,num - ! ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) - ! ! ENDDO - ! ELSEIF (denice_np(0)>0 .and. denh2o_np(0)==0) THEN - ! dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) - ! ! print*, 'denh2o=0! stop! np=',np,'igbp=',patchclass(np),& - ! 'nsl=',nsl,'frnp_=',frnp_ - ! ! DO k = 1,num - ! ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - ! ! ENDDO - ! ELSE - ! print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),& - ! 'nsl=',nsl,'frnp_=',frnp_ - ! DO k = 1,num - ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) - ! ENDDO - ! CALL CoLM_stop() - ! ENDIF - - - ! Reference: MOD_SnowLayersCombineDivide.F90's subroutine combo - IF (hc(0) < 0.) THEN - t_soisno (0,np) = tfrz & - + hc(0) / (cpice*wice_soisno(0,np) + cpliq*wliq_soisno(0,np)) - ELSEIF (hc(0) .le. hfus*wliq_soisno(0,np)) THEN - t_soisno (0,np) = tfrz - ELSE - t_soisno (0,np) = tfrz + (hc(0) - hfus*wliq_soisno(0,np)) & - / (cpice*wice_soisno(0,np)+cpliq*wliq_soisno(0,np)) - ENDIF - - dz_sno (0,np) = (wice_soisno(0,np) + wliq_soisno(0,np))/rhosnow_np(0) - - zi_sno (0) = 0._r8 - z_sno (0,np) = zi_sno(0) - 0.5_r8*dz_sno(0,np) - ENDIF - - ENDIF - - - ! Variable adjustment - DO k = 1, num - - wliq_soisno (1:nl_soil,np) = wliq_soisno (1:nl_soil,np) & - + wliq_soisno_(1:nl_soil,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno (1:nl_soil,np) = wice_soisno (1:nl_soil,np) & - + wice_soisno_(1:nl_soil,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) & - + t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k) & - * lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) - - tleaf (np) = tleaf (np) + tleaf_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ldew (np) = ldew (np) + ldew_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ldew_rain (np) = ldew_rain (np) + ldew_rain_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ldew_snow (np) = ldew_snow (np) + ldew_snow_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - sag (np) = sag (np) + sag_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - ! TODO: use MOD_SnowFraction.F90 to calculate sigf later - DONE - ! sigf (np) = sigf (np) + sigf_ (frnp_(k)) & - ! * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wa (np) = wa (np) + wa_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wdsrf (np) = wdsrf (np) + wdsrf_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - IF (.not. DEF_USE_VariablySaturatedFlow) THEN - zwt (np) = zwt (np) + zwt_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDIF - - snw_rds (:,np) = snw_rds (:,np) + snw_rds_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_bcpho (:,np) = mss_bcpho (:,np) + mss_bcpho_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_bcphi (:,np) = mss_bcphi (:,np) + mss_bcphi_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_ocpho (:,np) = mss_ocpho (:,np) + mss_ocpho_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_ocphi (:,np) = mss_ocphi (:,np) + mss_ocphi_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst1 (:,np) = mss_dst1 (:,np) + mss_dst1_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst2 (:,np) = mss_dst2 (:,np) + mss_dst2_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst3 (:,np) = mss_dst3 (:,np) + mss_dst3_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst4 (:,np) = mss_dst4 (:,np) + mss_dst4_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ssno_lyr (:,:,:,np) = ssno_lyr (:,:,:,np) + ssno_lyr_ (:,:,:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - ! TODO: or use same type assignment - smp (:,np) = smp (:,np) + smp_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - hk (:,np) = hk (:,np) + hk_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp (:,np) = vegwp (:,np) + vegwp_ (:,frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - gs0sun (np) = gs0sun (np) + gs0sun_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - gs0sha (np) = gs0sha (np) + gs0sha_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDIF - - IF(DEF_USE_OZONESTRESS)THEN - lai_old (np) = lai_old (np) + lai_old_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDIF - - trad (np) = trad (np) + trad_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - tref (np) = tref (np) + tref_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - qref (np) = qref (np) + qref_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - rst (np) = rst (np) + rst_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - emis (np) = emis (np) + emis_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - z0m (np) = z0m (np) + z0m_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - zol (np) = zol (np) + zol_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - rib (np) = rib (np) + rib_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ustar (np) = ustar (np) + ustar_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - qstar (np) = qstar (np) + qstar_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - tstar (np) = tstar (np) + tstar_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - fm (np) = fm (np) + fm_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - fh (np) = fh (np) + fh_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - fq (np) = fq (np) + fq_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDDO - - ! water balance check - wbef = 0 - wpre = 0 - DO k = 1, num - wbef = wbef + ldew_(frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + scv_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + wa_ (frnp_(k)) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k))) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k))) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDDO - - wpre = ldew(np) + scv(np) + wa(np) + sum(wliq_soisno(maxsnl+1:nl_soil,np)) & - + sum(wice_soisno(maxsnl+1:nl_soil,np)) - IF (wpre-wbef > 1.e-6) THEN - print*,'np=',np,'total err=',wpre-wbef - ENDIF - - wbef = 0 - wpre = 0 - DO k = 1, num - wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k))) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k))) & - * lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDDO - - wpre = sum(wliq_soisno(maxsnl+1:nl_soil,np)) & - + sum(wice_soisno(maxsnl+1:nl_soil,np)) - IF (wpre-wbef > 1.e-6) THEN - print*,'np=',np,'wice+wliq err=',wpre-wbef - ENDIF - - - ! ============================================================= - ! 2) adjusted based on code of physical process. - ! ============================================================= - - DO l = maxsnl+1, 0 - IF ( z_sno(l,np) .lt. 0 ) THEN - scv(np) = scv(np) + wice_soisno(l,np) + wliq_soisno(l,np) - snowdp(np) = snowdp(np) + dz_sno(l,np) - ENDIF - ENDDO - - ! Use restart value from the same type of - ! source patch or remain initialized - ! IF (lccpct_np(patchclass(np)) .gt. 0) THEN - ! tleaf (np) = tleaf_ (selfnp_) - ! lake_icefrac(:,np) = lake_icefrac_(:,selfnp_) - ! t_lake (:,np) = t_lake_ (:,selfnp_) - ! ENDIF - - ! Fraction of soil covered by snow - zlnd = 0.01 !Roughness length for soil [m] - ! fsno(np) = 0.0 - ! IF (snowdp(np) > 0.) THEN - ! fmelt = (scv(np)/snowdp(np)/100.) ** m - ! fsno(np) = tanh(snowdp(np)/(2.5 * zlnd * fmelt)) - ! ENDIF - - ! Sigf, fsno - CALL snowfraction (tlai(np),tsai(np),z0m(np),zlnd,& - scv(np),snowdp(np),wt,sigf(np),fsno(np)) - sai(np) = tsai(np) * sigf(np) - - ! account for vegetation snow - IF ( DEF_VEG_SNOW ) THEN - lai(np) = tlai(np) * sigf(np) - ENDIF - - ! ! In case lai+sai come into existence this year, set sigf to 1; - ! Update: won't happen if CALL snowfraction - ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN - ! sigf(np) = 1 - ! ENDIF - - ! Set Groud temperature - IF ( sum( z_sno(:,np) ) .eq. 0 ) THEN - t_grnd(np) = t_soisno(1,np) - ELSE - DO k = maxsnl+1, 0 - IF ( z_sno(k,np) .lt. 0 ) THEN - t_grnd(np) = t_soisno(k,np) - EXIT - ENDIF - ENDDO - ENDIF - - - ! Zwt calculation suggested by Shupeng Zhang - IF (DEF_USE_VariablySaturatedFlow) THEN - IF (wa(np) >= 0) THEN - DO l = nl_soil, 1, -1 - vf_water = (wliq_soisno(l,np)/denh2o) / dz_soi(l) - vf_ice = (wice_soisno(l,np)/denice) / dz_soi(l) - IF ((vf_water + vf_ice) < porsl(l,np)) THEN ! fraction of soil that is voids [-] - zwt(np) = zi_soi(l) ! interface depths (lower bound) of soil layers - EXIT - ELSEIF (l==1) THEN - zwt(np) = 0 - ENDIF - ENDDO - ELSE - PRINT*, 'Water table is below the soil column.' -#ifdef Campbell_SOIL_MODEL - prms(1,1:nl_soil) = bsw(1:nl_soil,np) -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,np) - prms(2,1:nl_soil) = n_vgm (1:nl_soil,np) - prms(3,1:nl_soil) = L_vgm (1:nl_soil,np) - prms(4,1:nl_soil) = sc_vgm (1:nl_soil,np) - prms(5,1:nl_soil) = fc_vgm (1:nl_soil,np) -#endif - - tolerance = 1.e-3 - tol_z = tolerance / real(nl_soil,r8) /2.0 - zi_soisno = (/0., zi_soi/) - sp_zi(0:nl_soil) = zi_soisno(0:nl_soil) * 1000.0 ! from meter to mm - sp_dz(1:nl_soil) = sp_zi(1:nl_soil) - sp_zi(0:nl_soil-1) - tol_v = tol_z / maxval(sp_dz) - CALL get_zwt_from_wa(porsl(nl_soil,np), theta_r(nl_soil,np), psi0(nl_soil,np), hksati(nl_soil,np), & - nprms, prms(:,nl_soil), tol_v, tol_z, wa(np), sp_zi(nl_soil), zwt(np) ) - ENDIF - ENDIF - - - ! ELSE - ! ! Patch area stay unchanged or decrease, - ! use restart value or remain initialized - ! ! TODO: CALL REST - DONE - ! inp_ = np_ - ! DO WHILE (inp_ .le. grid_patch_e_(j)) - ! IF (patchclass_(inp_) .eq. patchclass(np)) THEN - ! selfnp_ = inp_ - ! frnp_(1) = inp_ - ! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) - ! wice_soisno (:,np) = wice_soisno_ (:,inp_) - ! t_soisno (:,np) = t_soisno_ (:,inp_) - ! z_sno (:,np) = z_sno_ (:,inp_) - ! dz_sno (:,np) = dz_sno_ (:,inp_) - ! t_grnd (np) = t_grnd_ (inp_) - ! tleaf (np) = tleaf_ (inp_) - ! ldew (np) = ldew_ (inp_) - ! sag (np) = sag_ (inp_) - ! scv (np) = scv_ (inp_) - ! snowdp (np) = snowdp_ (inp_) - ! fsno (np) = fsno_ (inp_) - ! sigf (np) = sigf_ (inp_) - ! ! In case lai+sai come into existence this year, set sigf to 1 - ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN - ! sigf(np) = 1 - ! ENDIF - ! zwt (np) = zwt_ (inp_) - ! wa (np) = wa_ (inp_) - ! EXIT - ! ENDIF - ! - ! inp_ = inp_ + 1 - ! ENDDO - - ENDIF - -! ELSEIF (patchtype(np)==3) THEN !glacier patch -! ! Used restart value for GLACIERS patches if patchclass exists last year, -! ! or remain initialized -! ! TODO: CALL REST - DONE -! inp_ = np_ -! DO WHILE (inp_ .le. grid_patch_e_(j)) -! IF (patchclass_(inp_) .eq. patchclass(np)) THEN -! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) -! wice_soisno (:,np) = wice_soisno_ (:,inp_) -! t_soisno (:,np) = t_soisno_ (:,inp_) -! z_sno (:,np) = z_sno_ (:,inp_) -! dz_sno (:,np) = dz_sno_ (:,inp_) -! t_grnd (np) = t_grnd_ (inp_) -! tleaf (np) = tleaf_ (inp_) -! ldew (np) = ldew_ (inp_) -! sag (np) = sag_ (inp_) -! scv (np) = scv_ (inp_) -! snowdp (np) = snowdp_ (inp_) -! fsno (np) = fsno_ (inp_) -! sigf (np) = sigf_ (inp_) -! zwt (np) = zwt_ (inp_) -! wa (np) = wa_ (inp_) -! EXIT -! ENDIF -! inp_ = inp_ + 1 -! ENDDO -ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - - IF (patchtype(np)==0) THEN - ps = patch_pft_s(np) - pe = patch_pft_e(np) - ! ps_ = patch_pft_s_(selfnp_) - ! pe_ = patch_pft_e_(selfnp_) - - ! if totally come from other types,ldew set to zero since ldew_p(:)=0 - ! using MEC replace STA - ldew_tmp = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) - IF ((ldew_tmp) > 0) THEN - ldew_p(ps:pe) = ldew_p(ps:pe) * (ldew(np) / ldew_tmp) - ELSE - ldew(np) = 0 - ENDIF - - ! z0m_p was same-type assigned, then here we update sigf_p, sigf, fsno - CALL snowfraction_pftwrap (np,zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) - - sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - sai(np) = sum(sai_p(ps:pe)*pftfrac(ps:pe)) - - ! account for vegetation snow - IF ( DEF_VEG_SNOW ) THEN - lai_p(ps:pe) = tlai_p(ps:pe) * sigf_p(ps:pe) - lai(np) = sum(lai_p(ps:pe)*pftfrac(ps:pe)) - ENDIF - - ENDIF - - ! ! TODO: CALL REST - DONE - ! IF (patchtype(np)==0 .and. lccpct_np(patchclass(np)) .gt. 0) THEN - ! ! Used restart value of the same pftclass for pft-specific variables - ! ! Note: For ip-specific variables, remain initialized value - ! for new soil patch or pftclass - ! ip = ps - ! ip_= ps_ - ! - ! IF (ip.le.0 .or. ip_.le.0) THEN - ! print *, "Error in LuLccMassEnergyConserve LULC_IGBP_PFT|LULC_IGBP_PC!" - ! STOP - ! ENDIF - ! - ! DO WHILE (ip.le.pe .and. ip_.le.pe_) - ! ! if a PFT is missing, CYCLE - ! IF (pftclass(ip) > pftclass_(ip_)) THEN - ! ip_= ip_+ 1 - ! CYCLE - ! ENDIF - ! - ! ! if a PFT is added, CYCLE - ! IF (pftclass(ip) < pftclass_(ip_)) THEN - ! ip = ip + 1 - ! CYCLE - ! ENDIF - ! - ! ! for the same PFT, set PFT value - ! tleaf_p (ip) = tleaf_p_ (ip_) - ! ldew_p (ip) = ldew_p_ (ip_) - ! ! use MOD_SnowFraction.F90 later - ! sigf_p (ip) = sigf_p_ (ip_) - ! IF ( (lai_p(ip) + sai_p(ip)).gt.0 .and. sigf_p(ip).eq.0 ) THEN - ! sigf_p(ip) = 1 - ! ENDIF - ! - ! ip = ip + 1 - ! ip_= ip_+ 1 - ! ENDDO - ! ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) - ! ENDIF - -#endif - -#ifdef URBAN_MODEL - IF (patchclass(np)==URBAN) THEN - - ! If there isn't any urban patch in last year's grid,initialized value was - ! remained. Though the first source soil patch would be used for pervious - ! ground related variables. - u = patch2urban (np) - nurb = count( patchclass_(grid_patch_s_(j):grid_patch_e_(j)) == URBAN ) - - ! Get the index of urban patches in last year's grid, and index of urban - ! patch with the same urbclass - IF (nurb > 0) THEN - - allocate(gu_(nurb)) ! ind of urban patches in last year's grid - selfu_ = -1 ! ind of urban patch with same class in last year - inp_ = np_ ! for loop to record the index of urban patch - iu = 0 - - DO WHILE (inp_ .le. grid_patch_e_(j)) - IF (patchclass_(inp_) == URBAN) THEN - iu = iu + 1 - gu_(iu) = patch2urban_(inp_) - IF (landurban%settyp(u) == urbclass_(gu_(iu))) THEN - selfu_ = gu_(iu) - ENDIF - ENDIF - inp_ = inp_ + 1 - ENDDO - ENDIF - - ! Index of the same urbclass or the nearest class would be used for new - ! year's assignment - IF (selfu_ > 0) THEN - u_ = selfu_ - - ELSEIF (nurb > 0) THEN - duclass = abs ( landurban%settyp(u) - urbclass_(gu_(1)) ) - u_ = gu_(1) - iu = 2 - DO WHILE (iu .le. nurb) - IF (duclass .gt. abs( landurban%settyp(u) - urbclass_(gu_(iu)) )) THEN - u_ = gu_(iu) - duclass = abs( landurban%settyp(u) - urbclass_(u_) ) - ENDIF - iu = iu + 1 - ENDDO - ENDIF - - IF (u.le.0 .or. u_.le.0) THEN - print *, "Error in LuLccMassEnergyConserve URBAN_MODEL!" - STOP - ENDIF - - fwsun (u) = fwsun_ (u_) - dfwsun (u) = dfwsun_ (u_) - - sroof (:,:,u) = sroof_ (:,:,u_) - swsun (:,:,u) = swsun_ (:,:,u_) - swsha (:,:,u) = swsha_ (:,:,u_) - sgimp (:,:,u) = sgimp_ (:,:,u_) - sgper (:,:,u) = sgper_ (:,:,u_) - slake (:,:,u) = slake_ (:,:,u_) - - z_sno_roof (:,u) = z_sno_roof_ (:,u_) - z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) - z_sno_gper (:,u) = z_sno_gper_ (:,u_) - z_sno_lake (:,u) = z_sno_lake_ (:,u_) - - dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) - dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) - dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) - dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) - - lwsun (u) = lwsun_ (u_) - lwsha (u) = lwsha_ (u_) - lgimp (u) = lgimp_ (u_) - lgper (u) = lgper_ (u_) - lveg (u) = lveg_ (u_) - - t_roofsno (:,u) = t_roofsno_ (:,u_) - t_wallsun (:,u) = t_wallsun_ (:,u_) - t_wallsha (:,u) = t_wallsha_ (:,u_) - t_gimpsno (:,u) = t_gimpsno_ (:,u_) - t_gpersno (:,u) = t_gpersno_ (:,u_) - t_lakesno (:,u) = t_lakesno_ (:,u_) - - troof_inner (u) = troof_inner_ (u_) - twsun_inner (u) = twsun_inner_ (u_) - twsha_inner (u) = twsha_inner_ (u_) - - wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) - wice_roofsno (:,u) = wice_roofsno_ (:,u_) - wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) - wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) - wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) - wice_gpersno (:,u) = wice_gpersno_ (:,u_) - wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) - wice_lakesno (:,u) = wice_lakesno_ (:,u_) - - sag_roof (u) = sag_roof_ (u_) - sag_gimp (u) = sag_gimp_ (u_) - sag_gper (u) = sag_gper_ (u_) - sag_lake (u) = sag_lake_ (u_) - scv_roof (u) = scv_roof_ (u_) - scv_gimp (u) = scv_gimp_ (u_) - scv_gper (u) = scv_gper_ (u_) - scv_lake (u) = scv_lake_ (u_) - fsno_roof (u) = fsno_roof_ (u_) - fsno_gimp (u) = fsno_gimp_ (u_) - fsno_gper (u) = fsno_gper_ (u_) - fsno_lake (u) = fsno_lake_ (u_) - snowdp_roof (u) = snowdp_roof_ (u_) - snowdp_gimp (u) = snowdp_gimp_ (u_) - snowdp_gper (u) = snowdp_gper_ (u_) - snowdp_lake (u) = snowdp_lake_ (u_) - - Fhac (u) = Fhac_ (u_) - Fwst (u) = Fwst_ (u_) - Fach (u) = Fach_ (u_) - Fahe (u) = Fahe_ (u_) - Fhah (u) = Fhah_ (u_) - vehc (u) = vehc_ (u_) - meta (u) = meta_ (u_) - t_room (u) = t_room_ (u_) - t_roof (u) = t_roof_ (u_) - t_wall (u) = t_wall_ (u_) - tafu (u) = tafu_ (u_) - urb_green (u) = urb_green_ (u_) - - ! used soil patch value for variable on pervious ground - FROM_SOIL = .false. - IF (selfu_ < 0) THEN - DO k = 1, num - IF (patchtype_(frnp_(k)) == 0) THEN - FROM_SOIL = .true. - ENDIF - ENDDO - ENDIF - - ! Use the first source soil patch temporarily - IF (FROM_SOIL) THEN - z_sno_gper (:,u) = z_sno_ (:,frnp_(1)) - sag_gper (u) = sag_ (frnp_(1)) - scv_gper (u) = scv_ (frnp_(1)) - fsno_gper (u) = fsno_ (frnp_(1)) - snowdp_gper (u) = snowdp_ (frnp_(1)) - ENDIF - - !TODO: need to recalculate wliq_soisno, wice_soisno and scv value - DONE - wliq_soisno(: ,np) = 0. - wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) - wliq_soisno(: ,np) = wliq_soisno (: ,np) & - + wliq_gpersno(: ,u )*(1-froof(u))*fgper(u) - wliq_soisno(:1,np) = wliq_soisno (:1,np) & - + wliq_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) - - wice_soisno(: ,np) = 0. - wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) - wice_soisno(: ,np) = wice_soisno (: ,np) & - + wice_gpersno(: ,u )*(1-froof(u))*fgper(u) - wice_soisno(:1,np) = wice_soisno (:1,np) & - + wice_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) - - scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) & - + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) - - ENDIF -#endif - - ! CALL albland (np, patchtype(np),deltim,& - ! soil_s_v_alb(np),soil_d_v_alb(np),soil_s_n_alb(np),soil_d_n_alb(np),& - ! chil(patchclass(np)),rho(1:,1:,patchclass(np)),tau(1:,1:,patchclass(np)),& - ! fveg(np),green(np),lai(np),sai(np),coszen(np),& - ! wt,fsno(np),scv(np),scvold(np),sag(np),ssw,pg_snow(np),& - ! forc_t(np),t_grnd(np),t_soisno_(maxsnl+1:,np),& - ! dz_soisno_(maxsnl+1:,np),snl,wliq_soisno(maxsnl+1:,np),& - ! wice_soisno(maxsnl+1:,np),snw_rds(maxsnl+1:0,np),snofrz,& - ! mss_bcpho(maxsnl+1:0,np),mss_bcphi(maxsnl+1:0,np),& - ! mss_ocpho(maxsnl+1:0,np),mss_ocphi(maxsnl+1:0,np),& - ! mss_dst1(maxsnl+1:0,np),mss_dst2(maxsnl+1:0,np),& - ! mss_dst3(maxsnl+1:0,np),mss_dst4(maxsnl+1:0,np),& - ! alb(1:,1:,np),ssun(1:,1:,np),ssha(1:,1:,np),ssno(:,:,:,np),& - ! thermk(np),extkb(np),extkd(np)) - - - IF (allocated(frnp_ )) deallocate(frnp_ ) - IF (allocated(gu_ )) deallocate(gu_ ) - IF (allocated(cvsoil_)) deallocate(cvsoil_) - IF (allocated(h_ )) deallocate(h_ ) - np = np + 1 - ENDDO - ENDIF - ENDDO - ENDDO - ENDIF - - IF (p_is_worker) THEN - IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) - IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) - IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) - IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) - IF (allocated(locpxl )) deallocate(locpxl ) - ENDIF - - END SUBROUTINE LulccMassEnergyConserve - -END MODULE MOD_Lulcc_MassEnergyConserve -#endif -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 deleted file mode 100644 index c2953c6cc1..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_TransferTraceReadin.F90 +++ /dev/null @@ -1,136 +0,0 @@ -#include - -MODULE MOD_Lulcc_TransferTraceReadin - -!------------------------------------------------------------------------ -! -! !DESCRIPTION: -! The transfer matrix and patch tracing vector were created using the -! land cover type data of the adjacent two years. Based on next year's -! patch, the pixels within the patch and last years' land cover type of -! these pixels were obtained. Then the percent of source land cover -! type of each patch was derived. -! -! Created by Wanyi Lin, Shupeng Zhang and Hua Yuan, 07/2023 -! -! !HISTORY: -! 05/2025, Wanyi Lin and Hua Yuan: change to reading the lulcc transfer -! tracing vector from data files which are produced in the making -! surface data stage. See mksrfdata/MOD_Lulcc_TransferTrace.F90. -! -!------------------------------------------------------------------------ - - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE - - !frac of source patches in a patch - real(r8), allocatable, dimension(:,:) :: lccpct_patches(:,:) - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTransferTrace - PUBLIC :: deallocate_LulccTransferTrace - PUBLIC :: LulccTransferTraceReadin - - ! PRIVATE MEMBER FUNCTIONS: - - -CONTAINS - - - SUBROUTINE allocate_LulccTransferTrace - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time invariant variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_SPMD_Task - - IMPLICIT NONE - - integer :: nlc = N_land_classification - - IF (p_is_worker) THEN - allocate (lccpct_patches (numpatch, 0:nlc)) - lccpct_patches (:,:) = 0 - ENDIF - - END SUBROUTINE allocate_LulccTransferTrace - - - SUBROUTINE LulccTransferTraceReadin (lc_year) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_AggregationRequestData - USE MOD_Mesh - USE MOD_MeshFilter - USE MOD_LandElm - USE MOD_DataType - USE MOD_Block - USE MOD_Pixel - USE MOD_5x5DataReadin - USE MOD_RegionClip - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_Vars_TimeInvariants - - IMPLICIT NONE - - integer, intent(in) :: lc_year - - character(len=256) :: dir_landdata, lndname, thisyr - character(len=4) :: c2 - integer :: ilc - real(r8), allocatable :: tmpvec(:) - - - IF (p_is_worker) THEN - IF (allocated(tmpvec)) deallocate (tmpvec) - allocate (tmpvec(numpatch)) - ENDIF - - write(thisyr,'(i4.4)') lc_year - dir_landdata = DEF_dir_landdata - DO ilc = 0, N_land_classification - write(c2, '(i2.2)') ilc - lndname = trim(dir_landdata)//'/lulcc/'//trim(thisyr)//& - '/lccpct_patches_lc'//trim(c2)//'.nc' - CALL ncio_read_vector(lndname, 'lccpct_patches', landpatch, tmpvec) - - IF (p_is_worker) THEN - lccpct_patches(:,ilc) = tmpvec - ENDIF - ENDDO - - - END SUBROUTINE LulccTransferTraceReadin - - - SUBROUTINE deallocate_LulccTransferTrace - ! -------------------------------------------------- - ! Deallocates memory for Lulcc time invariant variables - ! -------------------------------------------------- - USE MOD_SPMD_Task - - IF (p_is_worker) THEN - IF (allocated(lccpct_patches)) deallocate (lccpct_patches) - ENDIF - - END SUBROUTINE deallocate_LulccTransferTrace - -END MODULE MOD_Lulcc_TransferTraceReadin -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 deleted file mode 100644 index ef50692cb6..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 +++ /dev/null @@ -1,201 +0,0 @@ -#include - -MODULE MOD_Lulcc_Vars_TimeInvariants - -!----------------------------------------------------------------------- -! Created by Hua Yuan, 04/2022 -! -! !REVISIONS: -! -! 07/2023, Wenzong Dong: porting to MPI version -! 08/2023, Hua Yuan: unified PFT and PC process -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_PixelSet - - IMPLICIT NONE - SAVE -!----------------------------------------------------------------------- - ! for patch time invariant information - type(pixelset_type) :: landpatch_ - type(pixelset_type) :: landelm_ - integer :: numpatch_ - integer :: numelm_ - integer :: numpft_ - integer :: numpc_ - integer :: numurban_ - integer, allocatable :: patchclass_ (:) !index of land cover type - integer, allocatable :: patchtype_ (:) !land patch type - real(r8), allocatable:: csol_ (:,:) !heat capacity of soil solids [J/(m3 K)] - - ! for LULC_IGBP_PFT and LULC_IGBP_PC - integer, allocatable :: pftclass_ (:) !PFT type - integer, allocatable :: patch_pft_s_ (:) !start PFT index of a patch - integer, allocatable :: patch_pft_e_ (:) !end PFT index of a patch - - ! for Urban model - integer, allocatable :: urbclass_ (:) !urban type - integer, allocatable :: patch2urban_ (:) !projection from patch to Urban - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTimeInvariants - PUBLIC :: deallocate_LulccTimeInvariants - PUBLIC :: SAVE_LulccTimeInvariants - -! PRIVATE MEMBER FUNCTIONS: - -!----------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_LulccTimeInvariants - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time invariant variables - ! -------------------------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_Mesh -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif -#ifdef URBAN_MODEL - USE MOD_LandUrban -#endif - - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (landpatch_%eindex (numpatch)) - allocate (landpatch_%ipxstt (numpatch)) - allocate (landpatch_%ipxend (numpatch)) - allocate (landpatch_%settyp (numpatch)) - allocate (landpatch_%ielm (numpatch)) - allocate (landpatch_%xblkgrp (numpatch)) - allocate (landpatch_%yblkgrp (numpatch)) - - allocate (landelm_%eindex (numelm)) - allocate (landelm_%ipxstt (numelm)) - allocate (landelm_%ipxend (numelm)) - allocate (landelm_%settyp (numelm)) - - allocate (patchclass_ (numpatch)) - allocate (patchtype_ (numpatch)) - allocate (csol_ (nl_soil,numpatch)) - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - allocate (pftclass_ (numpft)) - allocate (patch_pft_s_ (numpatch)) - allocate (patch_pft_e_ (numpatch)) - ENDIF -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - allocate (urbclass_ (numurban)) - allocate (patch2urban_ (numpatch)) - ENDIF -#endif - ENDIF - ENDIF - END SUBROUTINE allocate_LulccTimeInvariants - - - SUBROUTINE SAVE_LulccTimeInvariants - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_Pixelset - USE MOD_Vars_TimeInvariants - USE MOD_Landpatch - USE MOD_Landelm - USE MOD_Mesh -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeInvariants - USE MOD_LandPFT -#endif -#ifdef URBAN_MODEL - USE MOD_LandUrban -#endif - - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - CALL copy_pixelset (landpatch, landpatch_ ) - CALL copy_pixelset (landelm , landelm_ ) - numpatch_ = numpatch - numelm_ = numelm - patchclass_ (:) = patchclass (:) - patchtype_ (:) = patchtype (:) - csol_ (:,:) = csol (:,:) - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - numpft_ = numpft - pftclass_ (:) = pftclass (:) - patch_pft_s_ (:) = patch_pft_s (:) - patch_pft_e_ (:) = patch_pft_e (:) - ENDIF -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - numurban_ = numurban - urbclass_ (:) = landurban%settyp (:) - patch2urban_ (:) = patch2urban (:) - ENDIF -#endif - ENDIF - ENDIF - - CALL landpatch_%set_vecgs - - END SUBROUTINE SAVE_LulccTimeInvariants - - - SUBROUTINE deallocate_LulccTimeInvariants - USE MOD_SPMD_Task - USE MOD_PixelSet -! -------------------------------------------------- -! Deallocates memory for Lulcc time invariant variables -! -------------------------------------------------- - IF (p_is_worker) THEN - IF (numpatch_ > 0) THEN - CALL landpatch_%forc_free_mem - CALL landelm_%forc_free_mem - deallocate (patchclass_ ) - deallocate (patchtype_ ) - deallocate (csol_ ) - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft_ > 0) THEN - deallocate (pftclass_ ) - deallocate (patch_pft_s_ ) - deallocate (patch_pft_e_ ) - ENDIF -#endif - -#ifdef URBAN_MODEL - IF (numurban_ > 0) THEN - deallocate (urbclass_ ) - deallocate (patch2urban_ ) - ENDIF -#endif - ENDIF - ENDIF - - END SUBROUTINE deallocate_LulccTimeInvariants - -END MODULE MOD_Lulcc_Vars_TimeInvariants -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 deleted file mode 100644 index 1eb2a359ec..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 +++ /dev/null @@ -1,1206 +0,0 @@ -#include - -MODULE MOD_Lulcc_Vars_TimeVariables - -!----------------------------------------------------------------------- -! -! Created by Hua Yuan, 04/2022 -! -! !REVISIONS: -! 07/2023, Wenzong Dong: porting to MPI version -! 08/2023, Hua Yuan: unified PFT and PC process -! 10/2023, Wanyi Lin: check with MOD_Vars_TimeVariables.F90, add -! variables, and remove unnecessary variables -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE -! ---------------------------------------------------------------------- -! Time-varying state variables which required by restart run - !TODO: need to check with MOD_Vars_TimeVariables.F90 whether - ! there are any variables missing. - DONE - real(r8), allocatable :: z_sno_ (:,:) !node depth [m] - real(r8), allocatable :: dz_sno_ (:,:) !interface depth [m] - real(r8), allocatable :: t_soisno_ (:,:) !soil temperature [K] - real(r8), allocatable :: wliq_soisno_ (:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wice_soisno_ (:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: smp_ (:,:) !soil matrix potential [mm] - real(r8), allocatable :: hk_ (:,:) !hydraulic conductivity [mm h2o/s] - real(r8), allocatable :: t_grnd_ (:) !ground surface temperature [K] - - real(r8), allocatable :: tleaf_ (:) !leaf temperature [K] - real(r8), allocatable :: ldew_ (:) !depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain_ (:) !depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_ (:) !depth of rain on foliage [mm] - real(r8), allocatable :: fwet_snow_ (:) !vegetation snow fractional cover [-] - real(r8), allocatable :: sag_ (:) !non dimensional snow age [-] - real(r8), allocatable :: scv_ (:) !snow cover, water equivalent [mm] - real(r8), allocatable :: snowdp_ (:) !snow depth [meter] - real(r8), allocatable :: fsno_ (:) !frac of snow cover on ground - real(r8), allocatable :: sigf_ (:) !frac of veg cover, excluding snow-covered veg [-] - real(r8), allocatable :: zwt_ (:) !the depth to water table [m] - real(r8), allocatable :: wa_ (:) !water storage in aquifer [mm] - real(r8), allocatable :: wdsrf_ (:) !depth of surface water [mm] - real(r8), allocatable :: rss_ (:) !soil surface resistance [s/m] - - real(r8), allocatable :: t_lake_ (:,:) !lake layer temperature [K] - real(r8), allocatable :: lake_icefrac_ (:,:) !lake mass fraction of lake layer that is frozen - real(r8), allocatable :: savedtke1_ (:) !top level eddy conductivity (W/m K) - - !Plant Hydraulic variables - real(r8), allocatable :: vegwp_ (:,:) !vegetation water potential [mm] - real(r8), allocatable :: gs0sun_ (:) !working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha_ (:) !working copy of shaded stomata conductance - !END plant hydraulic variables - - !Ozone stress variables - real(r8), allocatable :: lai_old_ (:) !lai in last time step - real(r8), allocatable :: o3uptakesun_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) - real(r8), allocatable :: o3uptakesha_ (:) !Ozone does, shaded leaf (mmol O3/m^2) - !End ozone stress variables - - real(r8), allocatable :: snw_rds_ (:,:) !effective grain radius (col,lyr) [microns, m-6] - real(r8), allocatable :: mss_bcpho_ (:,:) !mass of hydrophobic BC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_bcphi_ (:,:) !mass of hydrophillic BC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_ocpho_ (:,:) !mass of hydrophobic OC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_ocphi_ (:,:) !mass of hydrophillic OC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst1_ (:,:) !mass of dust species 1 in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst2_ (:,:) !mass of dust species 2 in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst3_ (:,:) !mass of dust species 3 in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst4_ (:,:) !mass of dust species 4 in snow (col,lyr) [kg] - real(r8), allocatable :: ssno_lyr_ (:,:,:,:) !snow layer absorption [-] - - ! Additional variables required by regional model (such as WRF ) RSM) - real(r8), allocatable :: trad_ (:) !radiative temperature of surface [K] - real(r8), allocatable :: tref_ (:) !2 m height air temperature [kelvin] - real(r8), allocatable :: qref_ (:) !2 m height air specific humidity - real(r8), allocatable :: rst_ (:) !canopy stomatal resistance (s/m) - real(r8), allocatable :: emis_ (:) !averaged bulk surface emissivity - real(r8), allocatable :: z0m_ (:) !effective roughness [m] - real(r8), allocatable :: displa_ (:) !zero displacement height [m] - real(r8), allocatable :: zol_ (:) !dimensionless height (z/L) used in M-O theory - real(r8), allocatable :: rib_ (:) !bulk Richardson number in surface layer - real(r8), allocatable :: ustar_ (:) !u* in similarity theory [m/s] - real(r8), allocatable :: qstar_ (:) !q* in similarity theory [kg/kg] - real(r8), allocatable :: tstar_ (:) !t* in similarity theory [K] - real(r8), allocatable :: fm_ (:) !integral of profile function for momentum - real(r8), allocatable :: fh_ (:) !integral of profile function for heat - real(r8), allocatable :: fq_ (:) !integral of profile function for moisture - - real(r8), allocatable :: sum_irrig_ (:) !total irrigation amount [kg/m2] - real(r8), allocatable :: sum_irrig_count_ (:) !total irrigation counts [-] - - ! for LULC_IGBP_PFT and LULC_IGBP_PC - real(r8), allocatable :: tleaf_p_ (:) !shaded leaf temperature [K] - real(r8), allocatable :: ldew_p_ (:) !depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain_p_ (:) !depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_p_ (:) !depth of snow on foliage [mm] - real(r8), allocatable :: fwet_snow_p_ (:) !vegetation snow fractional cover [-] - real(r8), allocatable :: sigf_p_ (:) !frac of veg cover, excluding snow-covered veg [-] - - !TODO@yuan: to check the below for PC whether they are needed - real(r8), allocatable :: tref_p_ (:) !2 m height air temperature [kelvin] - real(r8), allocatable :: qref_p_ (:) !2 m height air specific humidity - real(r8), allocatable :: rst_p_ (:) !canopy stomatal resistance (s/m) - real(r8), allocatable :: z0m_p_ (:) !effective roughness [m] - - ! Plant Hydraulic variables - real(r8), allocatable :: vegwp_p_ (:,:) !vegetation water potential [mm] - real(r8), allocatable :: gs0sun_p_ (:) !working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha_p_ (:) !working copy of shaded stomata conductance - ! end plant hydraulic variables - - ! Ozone Stress Variables - real(r8), allocatable :: lai_old_p_ (:) !lai in last time step - real(r8), allocatable :: o3uptakesun_p_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) - real(r8), allocatable :: o3uptakesha_p_ (:) !Ozone does, shaded leaf (mmol O3/m^2) - ! End Ozone Stress Variables - - ! for URBAN_MODEL - real(r8), allocatable :: fwsun_ (:) !sunlit fraction of walls [-] - real(r8), allocatable :: dfwsun_ (:) !change of sunlit fraction of walls [-] - - ! shortwave absorption - real(r8), allocatable :: sroof_ (:,:,:) !roof absorption [-] - real(r8), allocatable :: swsun_ (:,:,:) !sunlit wall absorption [-] - real(r8), allocatable :: swsha_ (:,:,:) !shaded wall absorption [-] - real(r8), allocatable :: sgimp_ (:,:,:) !impervious absorption [-] - real(r8), allocatable :: sgper_ (:,:,:) !pervious absorption [-] - real(r8), allocatable :: slake_ (:,:,:) !urban lake absorption [-] - - ! net longwave radiation for last time temperature change - real(r8), allocatable :: lwsun_ (:) !net longwave of sunlit wall [W/m2] - real(r8), allocatable :: lwsha_ (:) !net longwave of shaded wall [W/m2] - real(r8), allocatable :: lgimp_ (:) !net longwave of impervious [W/m2] - real(r8), allocatable :: lgper_ (:) !net longwave of pervious [W/m2] - real(r8), allocatable :: lveg_ (:) !net longwave of vegetation [W/m2] - - real(r8), allocatable :: z_sno_roof_ (:,:) !node depth of roof [m] - real(r8), allocatable :: z_sno_gimp_ (:,:) !node depth of impervious [m] - real(r8), allocatable :: z_sno_gper_ (:,:) !node depth pervious [m] - real(r8), allocatable :: z_sno_lake_ (:,:) !node depth lake [m] - - real(r8), allocatable :: dz_sno_roof_ (:,:) !interface depth of roof [m] - real(r8), allocatable :: dz_sno_gimp_ (:,:) !interface depth of impervious [m] - real(r8), allocatable :: dz_sno_gper_ (:,:) !interface depth pervious [m] - real(r8), allocatable :: dz_sno_lake_ (:,:) !interface depth lake [m] - - real(r8), allocatable :: troof_inner_ (:) !temperature of roof [K] - real(r8), allocatable :: twsun_inner_ (:) !temperature of sunlit wall [K] - real(r8), allocatable :: twsha_inner_ (:) !temperature of shaded wall [K] - - real(r8), allocatable :: t_roofsno_ (:,:) !temperature of roof [K] - real(r8), allocatable :: t_wallsun_ (:,:) !temperature of sunlit wall [K] - real(r8), allocatable :: t_wallsha_ (:,:) !temperature of shaded wall [K] - real(r8), allocatable :: t_gimpsno_ (:,:) !temperature of impervious [K] - real(r8), allocatable :: t_gpersno_ (:,:) !temperature of pervious [K] - real(r8), allocatable :: t_lakesno_ (:,:) !temperature of pervious [K] - - real(r8), allocatable :: wliq_roofsno_ (:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wliq_gimpsno_ (:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wliq_gpersno_ (:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wliq_lakesno_ (:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wice_roofsno_ (:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: wice_gimpsno_ (:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: wice_gpersno_ (:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: wice_lakesno_ (:,:) !ice lens in layers [kg/m2] - - real(r8), allocatable :: sag_roof_ (:) !roof snow age [-] - real(r8), allocatable :: sag_gimp_ (:) !impervious ground snow age [-] - real(r8), allocatable :: sag_gper_ (:) !pervious ground snow age [-] - real(r8), allocatable :: sag_lake_ (:) !urban lake snow age [-] - - real(r8), allocatable :: scv_roof_ (:) !roof snow cover [-] - real(r8), allocatable :: scv_gimp_ (:) !impervious ground snow cover [-] - real(r8), allocatable :: scv_gper_ (:) !pervious ground snow cover [-] - real(r8), allocatable :: scv_lake_ (:) !urban lake snow cover [-] - - real(r8), allocatable :: fsno_roof_ (:) !roof snow fraction [-] - real(r8), allocatable :: fsno_gimp_ (:) !impervious ground snow fraction [-] - real(r8), allocatable :: fsno_gper_ (:) !pervious ground snow fraction [-] - real(r8), allocatable :: fsno_lake_ (:) !urban lake snow fraction [-] - - real(r8), allocatable :: snowdp_roof_ (:) !roof snow depth [m] - real(r8), allocatable :: snowdp_gimp_ (:) !impervious ground snow depth [m] - real(r8), allocatable :: snowdp_gper_ (:) !pervious ground snow depth [m] - real(r8), allocatable :: snowdp_lake_ (:) !urban lake snow depth [m] - - !TODO: consider renaming the below variables - real(r8), allocatable :: Fhac_ (:) !sensible flux from heat or cool AC [W/m2] - real(r8), allocatable :: Fwst_ (:) !waste heat flux from heat or cool AC [W/m2] - real(r8), allocatable :: Fach_ (:) !flux from inner and outer air exchange [W/m2] - real(r8), allocatable :: Fahe_ (:) !flux from metabolism and vehicle [W/m2] - real(r8), allocatable :: Fhah_ (:) !sensible heat flux from heating [W/m2] - real(r8), allocatable :: vehc_ (:) !flux from vehicle [W/m2] - real(r8), allocatable :: meta_ (:) !flux from metabolism [W/m2] - - real(r8), allocatable :: t_room_ (:) !temperature of inner building [K] - real(r8), allocatable :: t_roof_ (:) !temperature of roof [K] - real(r8), allocatable :: t_wall_ (:) !temperature of wall [K] - real(r8), allocatable :: tafu_ (:) !temperature of outer building [K] - - real(r8), allocatable :: urb_green_ (:) !fractional of green leaf in urban patch [-] - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTimeVariables - PUBLIC :: deallocate_LulccTimeVariables - PUBLIC :: SAVE_LulccTimeVariables - PUBLIC :: REST_LulccTimeVariables - -! PRIVATE MEMBER FUNCTIONS: - -!----------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_LulccTimeVariables - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time variant variables - ! -------------------------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeVariables - USE MOD_LandPFT -#endif -#ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables - USE MOD_LandUrban -#endif - - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (z_sno_ (maxsnl+1:0,numpatch)) - allocate (dz_sno_ (maxsnl+1:0,numpatch)) - allocate (t_soisno_ (maxsnl+1:nl_soil,numpatch)) - allocate (wliq_soisno_ (maxsnl+1:nl_soil,numpatch)) - allocate (wice_soisno_ (maxsnl+1:nl_soil,numpatch)) - allocate (smp_ (1:nl_soil,numpatch)) - allocate (hk_ (1:nl_soil,numpatch)) - allocate (t_grnd_ (numpatch)) - allocate (tleaf_ (numpatch)) - allocate (ldew_ (numpatch)) - allocate (ldew_rain_ (numpatch)) - allocate (ldew_snow_ (numpatch)) - allocate (fwet_snow_ (numpatch)) - allocate (sag_ (numpatch)) - allocate (scv_ (numpatch)) - allocate (snowdp_ (numpatch)) - allocate (fsno_ (numpatch)) - allocate (sigf_ (numpatch)) - allocate (zwt_ (numpatch)) - allocate (wa_ (numpatch)) - allocate (wdsrf_ (numpatch)) - allocate (rss_ (numpatch)) - - allocate (t_lake_ (nl_lake,numpatch)) - allocate (lake_icefrac_ (nl_lake,numpatch)) - allocate (savedtke1_ (numpatch)) - - !Plant Hydraulic variables - allocate (vegwp_ (1:nvegwcs,numpatch)) - allocate (gs0sun_ (numpatch)) - allocate (gs0sha_ (numpatch)) - !END plant hydraulic variables - - !Ozone Stress variables - allocate (lai_old_ (numpatch)) - allocate (o3uptakesun_ (numpatch)) - allocate (o3uptakesha_ (numpatch)) - !End ozone stress variables - - allocate (snw_rds_ (maxsnl+1:0,numpatch)) - allocate (mss_bcpho_ (maxsnl+1:0,numpatch)) - allocate (mss_bcphi_ (maxsnl+1:0,numpatch)) - allocate (mss_ocpho_ (maxsnl+1:0,numpatch)) - allocate (mss_ocphi_ (maxsnl+1:0,numpatch)) - allocate (mss_dst1_ (maxsnl+1:0,numpatch)) - allocate (mss_dst2_ (maxsnl+1:0,numpatch)) - allocate (mss_dst3_ (maxsnl+1:0,numpatch)) - allocate (mss_dst4_ (maxsnl+1:0,numpatch)) - allocate (ssno_lyr_ (2,2,maxsnl+1:1,numpatch)) - - allocate (trad_ (numpatch)) - allocate (tref_ (numpatch)) - allocate (qref_ (numpatch)) - allocate (rst_ (numpatch)) - allocate (emis_ (numpatch)) - allocate (z0m_ (numpatch)) - allocate (zol_ (numpatch)) - allocate (rib_ (numpatch)) - allocate (ustar_ (numpatch)) - allocate (qstar_ (numpatch)) - allocate (tstar_ (numpatch)) - allocate (fm_ (numpatch)) - allocate (fh_ (numpatch)) - allocate (fq_ (numpatch)) - - allocate (sum_irrig_ (numpatch)) - allocate (sum_irrig_count_ (numpatch)) - ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - allocate (tleaf_p_ (numpft)) - allocate (ldew_p_ (numpft)) - allocate (ldew_rain_p_ (numpft)) - allocate (ldew_snow_p_ (numpft)) - allocate (fwet_snow_p_ (numpft)) - allocate (sigf_p_ (numpft)) - allocate (tref_p_ (numpft)) - allocate (qref_p_ (numpft)) - allocate (rst_p_ (numpft)) - allocate (z0m_p_ (numpft)) - - ! Plant Hydraulic variables - allocate (vegwp_p_ (1:nvegwcs,numpft)) - allocate (gs0sun_p_ (numpft)) - allocate (gs0sha_p_ (numpft)) - ! end plant hydraulic variables - - ! Allocate Ozone Stress Variables - allocate (lai_old_p_ (numpft)) - allocate (o3uptakesun_p_ (numpft)) - allocate (o3uptakesha_p_ (numpft)) - ! End allocate Ozone Stress Variables - ENDIF -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - allocate (fwsun_ (numurban)) - allocate (dfwsun_ (numurban)) - - allocate (sroof_ (2,2,numurban)) - allocate (swsun_ (2,2,numurban)) - allocate (swsha_ (2,2,numurban)) - allocate (sgimp_ (2,2,numurban)) - allocate (sgper_ (2,2,numurban)) - allocate (slake_ (2,2,numurban)) - - allocate (lwsun_ (numurban)) - allocate (lwsha_ (numurban)) - allocate (lgimp_ (numurban)) - allocate (lgper_ (numurban)) - allocate (lveg_ (numurban)) - - allocate (z_sno_roof_ (maxsnl+1:0,numurban)) - allocate (z_sno_gimp_ (maxsnl+1:0,numurban)) - allocate (z_sno_gper_ (maxsnl+1:0,numurban)) - allocate (z_sno_lake_ (maxsnl+1:0,numurban)) - - allocate (dz_sno_roof_ (maxsnl+1:0,numurban)) - allocate (dz_sno_gimp_ (maxsnl+1:0,numurban)) - allocate (dz_sno_gper_ (maxsnl+1:0,numurban)) - allocate (dz_sno_lake_ (maxsnl+1:0,numurban)) - - allocate (t_roofsno_ (maxsnl+1:nl_roof,numurban)) - allocate (t_wallsun_ (maxsnl+1:nl_wall,numurban)) - allocate (t_wallsha_ (maxsnl+1:nl_wall,numurban)) - allocate (t_gimpsno_ (maxsnl+1:nl_soil,numurban)) - allocate (t_gpersno_ (maxsnl+1:nl_soil,numurban)) - allocate (t_lakesno_ (maxsnl+1:nl_soil,numurban)) - - allocate (troof_inner_ (numurban)) - allocate (twsun_inner_ (numurban)) - allocate (twsha_inner_ (numurban)) - - allocate (wliq_roofsno_(maxsnl+1:nl_roof,numurban)) - allocate (wice_roofsno_(maxsnl+1:nl_roof,numurban)) - allocate (wliq_gimpsno_(maxsnl+1:nl_soil,numurban)) - allocate (wice_gimpsno_(maxsnl+1:nl_soil,numurban)) - allocate (wliq_gpersno_(maxsnl+1:nl_soil,numurban)) - allocate (wice_gpersno_(maxsnl+1:nl_soil,numurban)) - allocate (wliq_lakesno_(maxsnl+1:nl_soil,numurban)) - allocate (wice_lakesno_(maxsnl+1:nl_soil,numurban)) - - allocate (sag_roof_ (numurban)) - allocate (sag_gimp_ (numurban)) - allocate (sag_gper_ (numurban)) - allocate (sag_lake_ (numurban)) - allocate (scv_roof_ (numurban)) - allocate (scv_gimp_ (numurban)) - allocate (scv_gper_ (numurban)) - allocate (scv_lake_ (numurban)) - allocate (fsno_roof_ (numurban)) - allocate (fsno_gimp_ (numurban)) - allocate (fsno_gper_ (numurban)) - allocate (fsno_lake_ (numurban)) - allocate (snowdp_roof_ (numurban)) - allocate (snowdp_gimp_ (numurban)) - allocate (snowdp_gper_ (numurban)) - allocate (snowdp_lake_ (numurban)) - - allocate (Fhac_ (numurban)) - allocate (Fwst_ (numurban)) - allocate (Fach_ (numurban)) - allocate (Fahe_ (numurban)) - allocate (Fhah_ (numurban)) - allocate (vehc_ (numurban)) - allocate (meta_ (numurban)) - allocate (t_room_ (numurban)) - allocate (t_roof_ (numurban)) - allocate (t_wall_ (numurban)) - allocate (tafu_ (numurban)) - allocate (urb_green_ (numurban)) - ENDIF -#endif - ENDIF - END SUBROUTINE allocate_LulccTimeVariables - - - SUBROUTINE SAVE_LulccTimeVariables - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global - USE MOD_Vars_TimeVariables -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeVariables -#endif -#ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables -#endif - - IMPLICIT NONE - - IF (p_is_worker) THEN - z_sno_ = z_sno - dz_sno_ = dz_sno - t_soisno_ = t_soisno - wliq_soisno_ = wliq_soisno - wice_soisno_ = wice_soisno - smp_ = smp - hk_ = hk - t_grnd_ = t_grnd - tleaf_ = tleaf - ldew_ = ldew - ldew_rain_ = ldew_rain - ldew_snow_ = ldew_snow - fwet_snow_ = fwet_snow - sag_ = sag - scv_ = scv - snowdp_ = snowdp - fsno_ = fsno - sigf_ = sigf - zwt_ = zwt - wa_ = wa - wdsrf_ = wdsrf - rss_ = rss - - t_lake_ = t_lake - lake_icefrac_ = lake_icefrac - savedtke1_ = savedtke1 - -IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_ = vegwp - gs0sun_ = gs0sun - gs0sha_ = gs0sha -ENDIF - -IF(DEF_USE_OZONESTRESS)THEN - lai_old_ = lai_old - o3uptakesun_ = o3uptakesun - o3uptakesha_ = o3uptakesha -ENDIF - snw_rds_ = snw_rds - mss_bcpho_ = mss_bcpho - mss_bcphi_ = mss_bcphi - mss_ocpho_ = mss_ocpho - mss_ocphi_ = mss_ocphi - mss_dst1_ = mss_dst1 - mss_dst2_ = mss_dst2 - mss_dst3_ = mss_dst3 - mss_dst4_ = mss_dst4 - ssno_lyr_ = ssno_lyr - - trad_ = trad - tref_ = tref - qref_ = qref - rst_ = rst - emis_ = emis - z0m_ = z0m - displa_ = displa - zol_ = zol - rib_ = rib - ustar_ = ustar - qstar_ = qstar - tstar_ = tstar - fm_ = fm - fh_ = fh - fq_ = fq - -IF (DEF_USE_IRRIGATION) THEN - sum_irrig_ = sum_irrig - sum_irrig_count_ = sum_irrig_count -ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - tleaf_p_ = tleaf_p - ldew_p_ = ldew_p - ldew_rain_p_ = ldew_rain_p - ldew_snow_p_ = ldew_snow_p - fwet_snow_p_ = fwet_snow_p - sigf_p_ = sigf_p - - tref_p_ = tref_p - qref_p_ = qref_p - rst_p_ = rst_p - z0m_p_ = z0m_p -IF(DEF_USE_PLANTHYDRAULICS)THEN - ! Plant Hydraulic variables - vegwp_p_ = vegwp_p - gs0sun_p_ = gs0sun_p - gs0sha_p_ = gs0sha_p - ! end plant hydraulic variables -ENDIF -IF(DEF_USE_OZONESTRESS)THEN - ! Ozone Stress Variables - lai_old_p_ = lai_old_p - o3uptakesun_p_ = o3uptakesun_p - o3uptakesha_p_ = o3uptakesha_p - ! End allocate Ozone Stress Variables -ENDIF -#endif - -#ifdef URBAN_MODEL - fwsun_ = fwsun - dfwsun_ = dfwsun - - sroof_ = sroof - swsun_ = swsun - swsha_ = swsha - sgimp_ = sgimp - sgper_ = sgper - slake_ = slake - - lwsun_ = lwsun - lwsha_ = lwsha - lgimp_ = lgimp - lgper_ = lgper - lveg_ = lveg - - z_sno_roof_ = z_sno_roof - z_sno_gimp_ = z_sno_gimp - z_sno_gper_ = z_sno_gper - z_sno_lake_ = z_sno_lake - - dz_sno_roof_ = dz_sno_roof - dz_sno_gimp_ = dz_sno_gimp - dz_sno_gper_ = dz_sno_gper - dz_sno_lake_ = dz_sno_lake - - t_roofsno_ = t_roofsno - t_wallsun_ = t_wallsun - t_wallsha_ = t_wallsha - t_gimpsno_ = t_gimpsno - t_gpersno_ = t_gpersno - t_lakesno_ = t_lakesno - - troof_inner_ = troof_inner - twsun_inner_ = twsun_inner - twsha_inner_ = twsha_inner - - wliq_roofsno_ = wliq_roofsno - wice_roofsno_ = wice_roofsno - wliq_gimpsno_ = wliq_gimpsno - wice_gimpsno_ = wice_gimpsno - wliq_gpersno_ = wliq_gpersno - wice_gpersno_ = wice_gpersno - wliq_lakesno_ = wliq_lakesno - wice_lakesno_ = wice_lakesno - - sag_roof_ = sag_roof - sag_gimp_ = sag_gimp - sag_gper_ = sag_gper - sag_lake_ = sag_lake - scv_roof_ = scv_roof - scv_gimp_ = scv_gimp - scv_gper_ = scv_gper - scv_lake_ = scv_lake - fsno_roof_ = fsno_roof - fsno_gimp_ = fsno_gimp - fsno_gper_ = fsno_gper - fsno_lake_ = fsno_lake - snowdp_roof_ = snowdp_roof - snowdp_gimp_ = snowdp_gimp - snowdp_gper_ = snowdp_gper - snowdp_lake_ = snowdp_lake - - Fhac_ = Fhac - Fwst_ = Fwst - Fach_ = Fach - Fahe_ = Fahe - Fhah_ = Fhah - vehc_ = vehc - meta_ = meta - t_room_ = t_room - t_roof_ = t_roof - t_wall_ = t_wall - tafu_ = tafu - urb_green_ = urb_green -#endif - ENDIF - - END SUBROUTINE SAVE_LulccTimeVariables - - - SUBROUTINE REST_LulccTimeVariables - - USE MOD_SPMD_Task - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_LandElm - USE MOD_Mesh - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Lulcc_Vars_TimeInvariants -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables - USE MOD_LandPFT -#endif -#ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables - USE MOD_LandUrban -#endif - - IMPLICIT NONE - - real(r8), allocatable, dimension(:) :: grid_patch_s , grid_patch_e - real(r8), allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ - integer , allocatable, dimension(:) :: locpxl - integer i, j, np, np_, ip, ip_, pc, pc_, u, u_ - integer ps, ps_, pe, pe_ - integer numpxl, ipxl - - IF (p_is_worker) THEN - ! allocate with numelm - allocate(grid_patch_s (numelm )) - allocate(grid_patch_e (numelm )) - allocate(grid_patch_s_(numelm_)) - allocate(grid_patch_e_(numelm_)) - - grid_patch_e (:) = -1. - grid_patch_s (:) = -1. - grid_patch_e_(:) = -1. - grid_patch_s_(:) = -1. - - ! loop for numelm of next year, patches at the beginning and end of - ! the element were recorded landpatch%eindex is arranged in order, - ! and the not land element is skipped so, IF element is missing, the - ! recorder is -1. - DO i=1, numelm - ! how many patches in ith element in this worker - numpxl = count(landpatch%eindex==landelm%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - ! get all patches' index that eindex is equal the i element - locpxl = pack([(ipxl, ipxl=1, numpatch)], & - landpatch%eindex==landelm%eindex(i)) - ! the min index is the start of patch's index - grid_patch_s(i) = minval(locpxl) - ! the max index is the end of patch's index - grid_patch_e(i) = maxval(locpxl) - ENDDO - - ! same as above, loop for numelm of previous year - ! patches at the beginning and end of the element were recorded - DO i=1, numelm_ - numpxl = count(landpatch_%eindex==landelm_%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - locpxl = pack([(ipxl, ipxl=1, numpatch_)], & - landpatch_%eindex==landelm_%eindex(i)) - - grid_patch_s_(i) = minval(locpxl) - grid_patch_e_(i) = maxval(locpxl) - ENDDO - - ! loop for element - ! print*, 'minelm is', minelm, 'maxelm is', maxelm - DO i=1, numelm - DO j=1,numelm_ - IF (landelm%eindex(i) == landelm_%eindex(j)) THEN - np = grid_patch_s (i) - np_= grid_patch_s_(j) - - IF (np.le.0 .or. np_.le.0) CYCLE - - ! IF element is still present, loop for patches in same element - DO WHILE (np.le.grid_patch_e(i) .and. np_.le.grid_patch_e_(j)) - - ! IF a patch is missing, CYCLE - IF (patchclass(np) > patchclass_(np_)) THEN - np_= np_+ 1 - CYCLE - ENDIF - - ! IF a patch is added, CYCLE - IF (patchclass(np) < patchclass_(np_)) THEN - np = np + 1 - CYCLE - ENDIF - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - u = patch2urban (np ) - u_= patch2urban_(np_) - - ! vars assignment needs same urb class for urban patch - IF (patchclass(np) == URBAN) THEN - ! IF a Urban type is missing, CYCLE - IF (landurban%settyp(u) > urbclass_(u_)) THEN - np_= np_+ 1 - CYCLE - ENDIF - - ! IF a urban type is added, CYCLE - IF (landurban%settyp(u) < urbclass_(u_)) THEN - np = np + 1 - CYCLE - ENDIF - ENDIF - ENDIF -#endif - ! otherwise, set patch value - ! only for the same patch type - z_sno (:,np) = z_sno_ (:,np_) - dz_sno (:,np) = dz_sno_ (:,np_) - t_soisno (:,np) = t_soisno_ (:,np_) - wliq_soisno (:,np) = wliq_soisno_ (:,np_) - wice_soisno (:,np) = wice_soisno_ (:,np_) - scv (np) = scv_ (np_) - smp (:,np) = smp_ (:,np_) - hk (:,np) = hk_ (:,np_) - t_grnd (np) = t_grnd_ (np_) - tleaf (np) = tleaf_ (np_) - ldew (np) = ldew_ (np_) - ldew_rain (np) = ldew_rain_ (np_) - ldew_snow (np) = ldew_snow_ (np_) - fwet_snow (np) = fwet_snow_ (np_) - sag (np) = sag_ (np_) - snowdp (np) = snowdp_ (np_) - fsno (np) = fsno_ (np_) - sigf (np) = sigf_ (np_) - ! In case lai+sai come into existence this year, set sigf to 1 - IF ( (sigf(np) .eq. 0) .and. ((lai(np) + sai(np)) .gt. 0) ) THEN - sigf(np) = 1 - ENDIF - zwt (np) = zwt_ (np_) - wa (np) = wa_ (np_) - wdsrf (np) = wdsrf_ (np_) - rss (np) = rss_ (np_) - - t_lake (:,np) = t_lake_ (:,np_) - lake_icefrac(:,np) = lake_icefrac_(:,np_) - savedtke1 (np) = savedtke1_ (np_) -IF(DEF_USE_PLANTHYDRAULICS)THEN - !Plant Hydraulic variables - vegwp (:,np) = vegwp_ (:,np_) - gs0sun (np) = gs0sun_ (np_) - gs0sha (np) = gs0sha_ (np_) - !END plant hydraulic variables -ENDIF -IF(DEF_USE_OZONESTRESS)THEN - !Ozone Stress variables - lai_old (np) = lai_old_ (np_) - o3uptakesun (np) = o3uptakesun_ (np_) - o3uptakesha (np) = o3uptakesha_ (np_) - !End ozone stress variables -ENDIF - snw_rds (:,np) = snw_rds_ (:,np_) - mss_bcpho (:,np) = mss_bcpho_ (:,np_) - mss_bcphi (:,np) = mss_bcphi_ (:,np_) - mss_ocpho (:,np) = mss_ocpho_ (:,np_) - mss_ocphi (:,np) = mss_ocphi_ (:,np_) - mss_dst1 (:,np) = mss_dst1_ (:,np_) - mss_dst2 (:,np) = mss_dst2_ (:,np_) - mss_dst3 (:,np) = mss_dst3_ (:,np_) - mss_dst4 (:,np) = mss_dst4_ (:,np_) - ssno_lyr(2,2,:,np) = ssno_lyr_(2,2,:,np_) - - trad (np) = trad_ (np_) - tref (np) = tref_ (np_) - qref (np) = qref_ (np_) - rst (np) = rst_ (np_) - emis (np) = emis_ (np_) - z0m (np) = z0m_ (np_) - zol (np) = zol_ (np_) - rib (np) = rib_ (np_) - ustar (np) = ustar_ (np_) - qstar (np) = qstar_ (np_) - tstar (np) = tstar_ (np_) - fm (np) = fm_ (np_) - fh (np) = fh_ (np_) - fq (np) = fq_ (np_) - -IF(DEF_USE_IRRIGATION)THEN - sum_irrig (np) = sum_irrig_ (np_) - sum_irrig_count (np) = sum_irrig_count_ (np_) -ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) -IF (patchtype(np)==0 .and. patchtype_(np_)==0) THEN - ip = patch_pft_s (np ) - ip_= patch_pft_s_(np_) - - IF (ip.le.0 .or. ip_.le.0) THEN - print *, "Error in REST_LulccTimeVariables LULC_IGBP_PFT|LULC_IGBP_PC!" - CALL CoLM_stop () - ENDIF - - DO WHILE (ip.le.patch_pft_e(np) .and. ip_.le.patch_pft_e_(np_)) - - ! IF a PFT is missing, CYCLE - IF (pftclass(ip) > pftclass_(ip_)) THEN - ip_= ip_+ 1 - CYCLE - ENDIF - - ! IF a PFT is added, CYCLE - IF (pftclass(ip) < pftclass_(ip_)) THEN - ip = ip + 1 - CYCLE - ENDIF - - ! for the same PFT, set PFT value - tleaf_p (ip) = tleaf_p_ (ip_) - ldew_p (ip) = ldew_p_ (ip_) - ldew_rain_p(ip) = ldew_rain_p_(ip_) - ldew_snow_p(ip) = ldew_snow_p_(ip_) - fwet_snow_p(ip) = fwet_snow_p_(ip_) - sigf_p (ip) = sigf_p_ (ip_) - - tref_p (ip) = tref_p_ (ip_) - qref_p (ip) = qref_p_ (ip_) - rst_p (ip) = rst_p_ (ip_) - z0m_p (ip) = z0m_p_ (ip_) - -IF(DEF_USE_PLANTHYDRAULICS)THEN - ! Plant Hydraulic variables - vegwp_p (:,ip) = vegwp_p_ (:,ip_) - gs0sun_p (ip) = gs0sun_p_ (ip_) - gs0sha_p (ip) = gs0sha_p_ (ip_) - ! end plant hydraulic variables -ENDIF -IF(DEF_USE_OZONESTRESS)THEN - ! Ozone Stress Variables - lai_old_p (ip) = lai_old_p_ (ip_) - o3uptakesun_p (ip) = o3uptakesun_p_ (ip_) - o3uptakesha_p (ip) = o3uptakesha_p_ (ip_) - ! End allocate Ozone Stress Variables -ENDIF - ip = ip + 1 - ip_= ip_+ 1 - ENDDO - ps = patch_pft_s(np) - pe = patch_pft_e(np) - ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) -ENDIF -#endif - -#ifdef URBAN_MODEL -IF (patchclass(np)==URBAN .and. patchclass_(np_)==URBAN) THEN - - ! u = patch2urban (np ) - ! u_= patch2urban_(np_) - - IF (u.le.0 .or. u_.le.0) THEN - print *, "Error in REST_LulccTimeVariables URBAN_MODEL!" - CALL CoLM_stop () - ENDIF - - ! ! IF a Urban type is missing, CYCLE - ! IF (landurban%settyp(u) > urbclass_(u_)) THEN - ! np_= np_+ 1 - ! CYCLE - ! ENDIF - - ! ! IF a urban type is added, CYCLE - ! IF (landurban%settyp(u) < urbclass_(u_)) THEN - ! np = np + 1 - ! CYCLE - ! ENDIF - - ! otherwise, set urban value - ! include added urban and the same urban type - fwsun (u) = fwsun_ (u_) - dfwsun (u) = dfwsun_ (u_) - - sroof (:,:,u) = sroof_ (:,:,u_) - swsun (:,:,u) = swsun_ (:,:,u_) - swsha (:,:,u) = swsha_ (:,:,u_) - sgimp (:,:,u) = sgimp_ (:,:,u_) - sgper (:,:,u) = sgper_ (:,:,u_) - slake (:,:,u) = slake_ (:,:,u_) - - lwsun (u) = lwsun_ (u_) - lwsha (u) = lwsha_ (u_) - lgimp (u) = lgimp_ (u_) - lgper (u) = lgper_ (u_) - lveg (u) = lveg_ (u_) - - z_sno_roof (:,u) = z_sno_roof_ (:,u_) - z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) - z_sno_gper (:,u) = z_sno_gper_ (:,u_) - z_sno_lake (:,u) = z_sno_lake_ (:,u_) - - dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) - dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) - dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) - dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) - - t_roofsno (:,u) = t_roofsno_ (:,u_) - t_wallsun (:,u) = t_wallsun_ (:,u_) - t_wallsha (:,u) = t_wallsha_ (:,u_) - t_gimpsno (:,u) = t_gimpsno_ (:,u_) - t_gpersno (:,u) = t_gpersno_ (:,u_) - t_lakesno (:,u) = t_lakesno_ (:,u_) - - troof_inner (u) = troof_inner_ (u_) - twsun_inner (u) = twsun_inner_ (u_) - twsha_inner (u) = twsha_inner_ (u_) - - wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) - wice_roofsno (:,u) = wice_roofsno_ (:,u_) - wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) - wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) - wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) - wice_gpersno (:,u) = wice_gpersno_ (:,u_) - wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) - wice_lakesno (:,u) = wice_lakesno_ (:,u_) - - sag_roof (u) = sag_roof_ (u_) - sag_gimp (u) = sag_gimp_ (u_) - sag_gper (u) = sag_gper_ (u_) - sag_lake (u) = sag_lake_ (u_) - scv_roof (u) = scv_roof_ (u_) - scv_gimp (u) = scv_gimp_ (u_) - scv_gper (u) = scv_gper_ (u_) - scv_lake (u) = scv_lake_ (u_) - fsno_roof (u) = fsno_roof_ (u_) - fsno_gimp (u) = fsno_gimp_ (u_) - fsno_gper (u) = fsno_gper_ (u_) - fsno_lake (u) = fsno_lake_ (u_) - snowdp_roof (u) = snowdp_roof_ (u_) - snowdp_gimp (u) = snowdp_gimp_ (u_) - snowdp_gper (u) = snowdp_gper_ (u_) - snowdp_lake (u) = snowdp_lake_ (u_) - - Fhac (u) = Fhac_ (u_) - Fwst (u) = Fwst_ (u_) - Fach (u) = Fach_ (u_) - Fahe (u) = Fahe_ (u_) - Fhah (u) = Fhah_ (u_) - vehc (u) = vehc_ (u_) - meta (u) = meta_ (u_) - t_room (u) = t_room_ (u_) - t_roof (u) = t_roof_ (u_) - t_wall (u) = t_wall_ (u_) - tafu (u) = tafu_ (u_) - urb_green (u) = urb_green_ (u_) - - wliq_soisno(: ,np) = 0. - wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) - wliq_soisno(: ,np) = wliq_soisno (: ,np) & - + wliq_gpersno(: ,u )*(1-froof(u))*fgper(u) - wliq_soisno(:1,np) = wliq_soisno (:1,np) & - + wliq_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) - - wice_soisno(: ,np) = 0. - wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) - wice_soisno(: ,np) = wice_soisno (: ,np) & - + wice_gpersno(: ,u )*(1-froof(u))*fgper(u) - wice_soisno(:1,np) = wice_soisno (:1,np) & - + wice_gimpsno(:1,u )*(1-froof(u))*(1-fgper(u)) - - scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) & - + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) -ENDIF -#endif - np = np + 1 - np_= np_+ 1 - ENDDO - ENDIF - ENDDO - ENDDO - ENDIF - - IF (p_is_worker) THEN - IF (allocated(grid_patch_s )) deallocate (grid_patch_s ) - IF (allocated(grid_patch_e )) deallocate (grid_patch_e ) - IF (allocated(grid_patch_s_)) deallocate (grid_patch_s_ ) - IF (allocated(grid_patch_e_)) deallocate (grid_patch_e_ ) - IF (allocated(locpxl )) deallocate (locpxl ) - ENDIF - END SUBROUTINE REST_LulccTimeVariables - - - SUBROUTINE deallocate_LulccTimeVariables - - USE MOD_SPMD_Task - USE MOD_Lulcc_Vars_TimeInvariants, only: numpatch_, numpft_, numpc_, numurban_ - -! -------------------------------------------------- -! Deallocates memory for Lulcc time variant variables -! -------------------------------------------------- - IF (p_is_worker) THEN - IF (numpatch_ > 0) THEN - deallocate (z_sno_ ) - deallocate (dz_sno_ ) - deallocate (t_soisno_ ) - deallocate (wliq_soisno_ ) - deallocate (wice_soisno_ ) - deallocate (smp_ ) - deallocate (hk_ ) - deallocate (t_grnd_ ) - deallocate (tleaf_ ) - deallocate (ldew_ ) - deallocate (ldew_rain_ ) - deallocate (ldew_snow_ ) - deallocate (fwet_snow_ ) - deallocate (sag_ ) - deallocate (scv_ ) - deallocate (snowdp_ ) - deallocate (fsno_ ) - deallocate (sigf_ ) - deallocate (zwt_ ) - deallocate (wa_ ) - deallocate (wdsrf_ ) - deallocate (rss_ ) - - deallocate (t_lake_ ) - deallocate (lake_icefrac_ ) - deallocate (savedtke1_ ) - - !Plant Hydraulic variables - deallocate (vegwp_ ) - deallocate (gs0sun_ ) - deallocate (gs0sha_ ) - !END plant hydraulic variables - - !Ozone Stress variables - deallocate (lai_old_ ) - deallocate (o3uptakesun_ ) - deallocate (o3uptakesha_ ) - !End ozone stress variables - - deallocate (snw_rds_ ) - deallocate (mss_bcpho_ ) - deallocate (mss_bcphi_ ) - deallocate (mss_ocpho_ ) - deallocate (mss_ocphi_ ) - deallocate (mss_dst1_ ) - deallocate (mss_dst2_ ) - deallocate (mss_dst3_ ) - deallocate (mss_dst4_ ) - deallocate (ssno_lyr_ ) - - deallocate (trad_ ) - deallocate (tref_ ) - deallocate (qref_ ) - deallocate (rst_ ) - deallocate (emis_ ) - deallocate (z0m_ ) - deallocate (zol_ ) - deallocate (rib_ ) - deallocate (ustar_ ) - deallocate (qstar_ ) - deallocate (tstar_ ) - deallocate (fm_ ) - deallocate (fh_ ) - deallocate (fq_ ) - - deallocate (sum_irrig_ ) - deallocate (sum_irrig_count_ ) - - ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft_ > 0) THEN - deallocate (tleaf_p_ ) - deallocate (ldew_p_ ) - deallocate (ldew_rain_p_ ) - deallocate (ldew_snow_p_ ) - deallocate (fwet_snow_p_ ) - deallocate (sigf_p_ ) - deallocate (tref_p_ ) - deallocate (qref_p_ ) - deallocate (rst_p_ ) - deallocate (z0m_p_ ) - - ! Plant Hydraulic variables - deallocate (vegwp_p_ ) - deallocate (gs0sun_p_ ) - deallocate (gs0sha_p_ ) - ! end plant hydraulic variables - - ! Allocate Ozone Stress Variables - deallocate (lai_old_p_ ) - deallocate (o3uptakesun_p_ ) - deallocate (o3uptakesha_p_ ) - ! End allocate Ozone Stress Variables - ENDIF -#endif - -#ifdef URBAN_MODEL - IF (numurban_ > 0) THEN - deallocate (fwsun_ ) - deallocate (dfwsun_ ) - - deallocate (sroof_ ) - deallocate (swsun_ ) - deallocate (swsha_ ) - deallocate (sgimp_ ) - deallocate (sgper_ ) - deallocate (slake_ ) - - deallocate (lwsun_ ) - deallocate (lwsha_ ) - deallocate (lgimp_ ) - deallocate (lgper_ ) - deallocate (lveg_ ) - - deallocate (z_sno_roof_ ) - deallocate (z_sno_gimp_ ) - deallocate (z_sno_gper_ ) - deallocate (z_sno_lake_ ) - - deallocate (dz_sno_roof_ ) - deallocate (dz_sno_gimp_ ) - deallocate (dz_sno_gper_ ) - deallocate (dz_sno_lake_ ) - - deallocate (t_roofsno_ ) - deallocate (t_wallsun_ ) - deallocate (t_wallsha_ ) - deallocate (t_gimpsno_ ) - deallocate (t_gpersno_ ) - deallocate (t_lakesno_ ) - - deallocate (troof_inner_ ) - deallocate (twsun_inner_ ) - deallocate (twsha_inner_ ) - - deallocate (wliq_roofsno_ ) - deallocate (wice_roofsno_ ) - deallocate (wliq_gimpsno_ ) - deallocate (wice_gimpsno_ ) - deallocate (wliq_gpersno_ ) - deallocate (wice_gpersno_ ) - deallocate (wliq_lakesno_ ) - deallocate (wice_lakesno_ ) - - deallocate (sag_roof_ ) - deallocate (sag_gimp_ ) - deallocate (sag_gper_ ) - deallocate (sag_lake_ ) - deallocate (scv_roof_ ) - deallocate (scv_gimp_ ) - deallocate (scv_gper_ ) - deallocate (scv_lake_ ) - deallocate (fsno_roof_ ) - deallocate (fsno_gimp_ ) - deallocate (fsno_gper_ ) - deallocate (fsno_lake_ ) - deallocate (snowdp_roof_ ) - deallocate (snowdp_gimp_ ) - deallocate (snowdp_gper_ ) - deallocate (snowdp_lake_ ) - - deallocate (Fhac_ ) - deallocate (Fwst_ ) - deallocate (Fach_ ) - deallocate (Fahe_ ) - deallocate (Fhah_ ) - deallocate (vehc_ ) - deallocate (meta_ ) - deallocate (t_room_ ) - deallocate (t_roof_ ) - deallocate (t_wall_ ) - deallocate (tafu_ ) - deallocate (urb_green_ ) - ENDIF -#endif - ENDIF - - END SUBROUTINE deallocate_LulccTimeVariables - -END MODULE MOD_Lulcc_Vars_TimeVariables -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 deleted file mode 100644 index 09dbd7cbfc..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_DBedrockReadin.F90 +++ /dev/null @@ -1,72 +0,0 @@ -#include - -MODULE MOD_DBedrockReadin - - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: dbedrock_readin - -CONTAINS - - SUBROUTINE dbedrock_readin (dir_landdata, lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_UserDefFun - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_Vars_Global, only: nl_soil, dz_soi - USE MOD_Vars_TimeInvariants, only: dbedrock, ibedrock -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - - IMPLICIT NONE - - integer, intent(in) :: lc_year ! which year of data used - character(len=256), intent(in) :: dir_landdata - - ! Local Variables - character(len=256) :: lndname, cyear - integer :: ipatch, L - -#ifdef SinglePoint - dbedrock(:) = SITE_dbedrock -#else - write(cyear,'(i4.4)') lc_year - lndname = trim(dir_landdata)//'/dbedrock/'//trim(cyear)//'/dbedrock_patches.nc' - CALL ncio_read_vector (lndname, 'dbedrock_patches', landpatch, dbedrock) -#endif - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - - L = landpatch%settyp(ipatch) - - IF (L == 0) THEN - ibedrock(ipatch) = 0 - ELSE - - dbedrock(ipatch) = dbedrock(ipatch) / 100.0 ! from cm to meter - dbedrock(ipatch) = max(dbedrock(ipatch), dz_soi(1)) - - IF (dbedrock(ipatch) > zi_soi(1)) THEN - ibedrock(ipatch) = findloc_ud(dbedrock(ipatch)>zi_soi, back=.true.) + 1 - ELSE - ibedrock(ipatch) = 1 - ENDIF - - ENDIF - - ENDDO - - ENDIF - - END SUBROUTINE dbedrock_readin - -END MODULE MOD_DBedrockReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 deleted file mode 100644 index 860dcd9bfe..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_HtopReadin.F90 +++ /dev/null @@ -1,152 +0,0 @@ -#include - -MODULE MOD_HtopReadin - - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: HTOP_readin - -CONTAINS - - SUBROUTINE HTOP_readin (dir_landdata, lc_year) - -! =========================================================== -! Read in the canopy tree top height -! =========================================================== - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global - USE MOD_Const_LC - USE MOD_Const_PFT - USE MOD_Vars_TimeInvariants - USE MOD_LandPatch -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables -#endif - USE MOD_NetCDFVector -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - - IMPLICIT NONE - - integer, intent(in) :: lc_year ! which year of land cover data used - character(len=256), intent(in) :: dir_landdata - - ! Local Variables - character(len=256) :: c - character(len=256) :: landdir, lndname, cyear - integer :: i,j,t,p,ps,pe,m,n,npatch - - real(r8), allocatable :: htoplc (:) - real(r8), allocatable :: htoppft (:) - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_landdata) // '/htop/' // trim(cyear) - - -#ifdef LULC_USGS - - IF (p_is_worker) THEN - DO npatch = 1, numpatch - m = patchclass(npatch) - - htop(npatch) = htop0(m) - hbot(npatch) = hbot0(m) - - ENDDO - ENDIF - -#endif - -#ifdef LULC_IGBP -#ifdef SinglePoint - allocate (htoplc (numpatch)) - htoplc(:) = SITE_htop -#else - lndname = trim(landdir)//'/htop_patches.nc' - CALL ncio_read_vector (lndname, 'htop_patches', landpatch, htoplc) -#endif - - IF (p_is_worker) THEN - DO npatch = 1, numpatch - m = patchclass(npatch) - - htop(npatch) = htop0(m) - hbot(npatch) = hbot0(m) - - ! trees or woody savannas - IF ( m<6 .or. m==8 ) THEN - ! 01/06/2020, yuan: adjust htop reading - ! 11/15/2021, yuan: adjust htop setting - htop(npatch) = max(2., htoplc(npatch)) - hbot(npatch) = htoplc(npatch)*hbot0(m)/htop0(m) - hbot(npatch) = max(1., hbot(npatch)) - ENDIF - - ENDDO - ENDIF - - IF (allocated(htoplc)) deallocate ( htoplc ) -#endif - - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) -#ifdef SinglePoint - IF (numpft > 0) THEN - allocate(htoppft(numpft)) - htoppft = pack(SITE_htop_pfts, SITE_pctpfts > 0.) - ENDIF -#else - lndname = trim(landdir)//'/htop_pfts.nc' - CALL ncio_read_vector (lndname, 'htop_pfts', landpft, htoppft) -#endif - - IF (p_is_worker) THEN - DO npatch = 1, numpatch - t = patchtype(npatch) - m = patchclass(npatch) - - IF (t == 0) THEN - ps = patch_pft_s(npatch) - pe = patch_pft_e(npatch) - - DO p = ps, pe - n = pftclass(p) - - htop_p(p) = htop0_p(n) - hbot_p(p) = hbot0_p(n) - - ! for trees - ! 01/06/2020, yuan: adjust htop reading - ! 11/15/2021, yuan: adjust htop setting - IF ( n>0 .and. n<9 ) THEN - htop_p(p) = max(2., htoppft(p)) - hbot_p(p) = htoppft(p)*hbot0_p(n)/htop0_p(n) - hbot_p(p) = max(1., hbot_p(p)) - ENDIF - ENDDO - - htop(npatch) = sum(htop_p(ps:pe)*pftfrac(ps:pe)) - hbot(npatch) = sum(hbot_p(ps:pe)*pftfrac(ps:pe)) - - ELSE - htop(npatch) = htop0(m) - hbot(npatch) = hbot0(m) - ENDIF - - ENDDO - ENDIF - - IF (allocated(htoppft)) deallocate(htoppft) -#endif - - END SUBROUTINE HTOP_readin - -END MODULE MOD_HtopReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 deleted file mode 100644 index 68725e5078..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_IniTimeVariable.F90 +++ /dev/null @@ -1,1376 +0,0 @@ -#include - -MODULE MOD_IniTimeVariable - -!----------------------------------------------------------------------- - USE MOD_Precision -#ifdef BGC - USE MOD_BGC_CNSummary, only: CNDriverSummarizeStates, CNDriverSummarizeFluxes -#endif - IMPLICIT NONE - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: IniTimeVar - - -CONTAINS - - SUBROUTINE IniTimeVar(ipatch, patchtype& - ,porsl,psi0,hksati,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb& - ,z0m,zlnd,htop,z0mr,chil,rho,tau,z_soisno,dz_soisno& - ,t_soisno,wliq_soisno,wice_soisno,smp,hk,zwt,wa& -!Plant Hydraulic parameters - ,vegwp,gs0sun,gs0sha& -!End plant hydraulic parameter - ,t_grnd,tleaf,ldew,ldew_rain,ldew_snow,fwet_snow,sag,scv& - ,snowdp,fveg,fsno,sigf,green,lai,sai,lai_old,coszen& - ,snw_rds,mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi& - ,mss_dst1,mss_dst2,mss_dst3,mss_dst4& - ,alb,ssun,ssha,ssoi,ssno,ssno_lyr& -#ifdef HYPERSPECTRAL - ,alb_hires& -#endif - ,thermk,extkb,extkd& - ,trad,tref,qref,rst,emis,zol,rib& - ,ustar,qstar,tstar,fm,fh,fq& -#ifdef HYPERSPECTRAL - ,clr_frac, cld_frac & - ,reflectance, transmittance, soil_alb, kw, nw& - ,reflectance_out, transmittance_out& - ,patchlatr, patchlonr& - ,urban_albedo, mean_albedo, lat_north, lat_south, lon_east, lon_west& -#endif -!Ozone Variables - ,o3coefv_sun,o3coefv_sha,o3coefg_sun,o3coefg_sha& -#if (defined BGC) - ,use_cnini, totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_veg, ctrunc_soil, ctrunc_vr & - ,totlitn, totsomn, totcwdn, decomp_npools, decomp_npools_vr, ntrunc_veg, ntrunc_soil, ntrunc_vr & - ,totvegc, totvegn, totcolc, totcoln, col_endcb, col_begcb, col_endnb, col_begnb & - ,col_vegendcb, col_vegbegcb, col_soilendcb, col_soilbegcb & - ,col_vegendnb, col_vegbegnb, col_soilendnb, col_soilbegnb & - ,col_sminnendnb, col_sminnbegnb & - ,altmax, altmax_lastyear, altmax_lastyear_indx, lag_npp & - ,sminn_vr, sminn, smin_no3_vr, smin_nh4_vr & - ,prec10, prec60, prec365, prec_today, prec_daily, tsoi17, rh30, accumnstep, skip_balance_check & -!------------------------SASU variables----------------- - ,decomp0_cpools_vr , decomp0_npools_vr & - ,I_met_c_vr_acc , I_cel_c_vr_acc , I_lig_c_vr_acc , I_cwd_c_vr_acc & - ,AKX_met_to_soil1_c_vr_acc , AKX_cel_to_soil1_c_vr_acc , AKX_lig_to_soil2_c_vr_acc , AKX_soil1_to_soil2_c_vr_acc & - ,AKX_cwd_to_cel_c_vr_acc , AKX_cwd_to_lig_c_vr_acc , AKX_soil1_to_soil3_c_vr_acc, AKX_soil2_to_soil1_c_vr_acc & - ,AKX_soil2_to_soil3_c_vr_acc, AKX_soil3_to_soil1_c_vr_acc & - ,AKX_met_exit_c_vr_acc , AKX_cel_exit_c_vr_acc , AKX_lig_exit_c_vr_acc , AKX_cwd_exit_c_vr_acc & - ,AKX_soil1_exit_c_vr_acc , AKX_soil2_exit_c_vr_acc , AKX_soil3_exit_c_vr_acc & - ,diagVX_c_vr_acc , upperVX_c_vr_acc , lowerVX_c_vr_acc & - ,I_met_n_vr_acc , I_cel_n_vr_acc , I_lig_n_vr_acc , I_cwd_n_vr_acc & - ,AKX_met_to_soil1_n_vr_acc , AKX_cel_to_soil1_n_vr_acc , AKX_lig_to_soil2_n_vr_acc , AKX_soil1_to_soil2_n_vr_acc & - ,AKX_cwd_to_cel_n_vr_acc , AKX_cwd_to_lig_n_vr_acc , AKX_soil1_to_soil3_n_vr_acc, AKX_soil2_to_soil1_n_vr_acc & - ,AKX_soil2_to_soil3_n_vr_acc, AKX_soil3_to_soil1_n_vr_acc & - ,AKX_met_exit_n_vr_acc , AKX_cel_exit_n_vr_acc , AKX_lig_exit_n_vr_acc , AKX_cwd_exit_n_vr_acc & - ,AKX_soil1_exit_n_vr_acc , AKX_soil2_exit_n_vr_acc , AKX_soil3_exit_n_vr_acc & - ,diagVX_n_vr_acc , upperVX_n_vr_acc , lowerVX_n_vr_acc & -!------------------------------------------------------------ -#endif - ,use_soilini, nl_soil_ini, soil_z, soil_t, soil_w, use_snowini, snow_d & - ,use_wtd, zwtmm, zc_soimm, zi_soimm, vliq_r, nprms, prms) - -!======================================================================= -! Created by Yongjiu Dai, 09/15/1999 -! Revised by Yongjiu Dai, 08/30/2002 -! 03/2014 -!======================================================================= - - USE MOD_Precision - USE MOD_Utils - USE MOD_Const_Physical, only: tfrz, denh2o, denice - USE MOD_Vars_TimeVariables, only: tlai, tsai - USE MOD_Const_PFT, only: isevg, woody, leafcn, frootcn, livewdcn, deadwdcn, slatop, manure - USE MOD_Vars_TimeInvariants, only: ibedrock, dbedrock -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT, only: patch_pft_s, patch_pft_e - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables -#endif - USE MOD_Vars_Global -#ifdef HYPERSPECTRAL - USE MOD_Albedo_HiRes -#else - USE MOD_Albedo -#endif - USE MOD_Namelist - USE MOD_Hydro_SoilWater - USE MOD_SnowFraction - USE MOD_SPMD_Task - - IMPLICIT NONE - - integer, intent(in) :: &! - ipatch, &! patch index - patchtype ! index for land cover type [-] - - real(r8), intent(in) :: &! - fveg, &! fraction of vegetation cover - green, &! leaf greenness - coszen, &! cosine of solar zenith angle - soil_s_v_alb, &! albedo of visible of the saturated soil - soil_d_v_alb, &! albedo of visible of the dry soil - soil_s_n_alb, &! albedo of near infrared of the saturated soil - soil_d_n_alb, &! albedo of near infrared of the dry soil - zlnd, &! aerodynamic roughness length over soil surface [m] - z0mr, &! ratio to calculate roughness length z0m - htop, &! canopy top height [m] - chil, &! leaf angle distribution factor - rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) - tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) - porsl(1:nl_soil), &! porosity of soil - psi0 (1:nl_soil), &! saturated soil suction (mm) (NEGATIVE) - hksati(1:nl_soil) ! hydraulic conductivity at saturation [mm h2o/s] -#ifdef HYPERSPECTRAL - real(r8), intent(in) :: &! - clr_frac ( 211, 89, 5 ) ,& - cld_frac ( 211, 5 ) ,& - reflectance ( 0:15, 211, 2 ) ,& - transmittance ( 0:15, 211, 2 ) ,& - soil_alb ( 211 ), kw(211), nw(211) - - real(r8), intent(in) :: &! - patchlatr, &! patch latitude - patchlonr ! patch longitude - ! Urban hyperspectral albedo - REAL(r8), ALLOCATABLE :: urban_albedo( :, :, : ) ! (cluster_id, season wavelength) - REAL(r8), ALLOCATABLE :: mean_albedo ( :, : ) ! (season, wavelength) - REAL(r8), ALLOCATABLE :: lat_north ( : ) ! (cluster_id) - REAL(r8), ALLOCATABLE :: lat_south ( : ) ! (cluster_id) - REAL(r8), ALLOCATABLE :: lon_east ( : ) ! (cluster_id) - REAL(r8), ALLOCATABLE :: lon_west ( : ) ! (cluster_id) -#endif - real(r8), intent(inout) :: & - z0m ! aerodynamic roughness length [m] - - logical, intent(in) :: use_soilini -#ifdef BGC - logical, intent(in) :: use_cnini -#endif - integer, intent(in) :: nl_soil_ini - real(r8), intent(in) :: &! - soil_z(nl_soil_ini), &! soil layer depth for initial (m) - soil_t(nl_soil_ini), &! soil temperature from initial file (K) - soil_w(nl_soil_ini) ! soil wetness from initial file (-) - - logical, intent(in) :: use_snowini - real(r8), intent(in) :: snow_d ! snow depth (m) - - logical, intent(in) :: use_wtd - real(r8), intent(in) :: zwtmm - real(r8), intent(in) :: zc_soimm(1:nl_soil) - real(r8), intent(in) :: zi_soimm(0:nl_soil) - real(r8), intent(in) :: vliq_r (1:nl_soil) - integer, intent(in) :: nprms - real(r8), intent(in) :: prms(nprms, 1:nl_soil) - - real(r8), intent(inout) :: &! - z_soisno (maxsnl+1:nl_soil), &! node depth [m] - dz_soisno(maxsnl+1:nl_soil) ! layer thickness [m] - - real(r8), intent(out) :: &! - t_soisno (maxsnl+1:nl_soil), &! soil temperature [K] - wliq_soisno(maxsnl+1:nl_soil), &! liquid water in layers [kg/m2] - wice_soisno(maxsnl+1:nl_soil), &! ice lens in layers [kg/m2] - smp (1:nl_soil) , &! soil matrix potential - hk (1:nl_soil) , &! soil hydraulic conductance -!Plant Hydraulic parameters - vegwp(1:nvegwcs), &! vegetation water potential - gs0sun, &! working copy of sunlit stomata conductance - gs0sha, &! working copy of shaded stomata conductance -!end plant hydraulic parameters - t_grnd, &! ground surface temperature [K] - tleaf, &! sunlit leaf temperature [K] -!#ifdef CLM5_INTERCEPTION - ldew_rain, &! depth of rain on foliage [mm] - ldew_snow, &! depth of snow on foliage [mm] -!#endif - fwet_snow, &! vegetation snow fractional cover [-] - ldew, &! depth of water on foliage [mm] - sag, &! non dimensional snow age [-] - scv, &! snow cover, water equivalent [mm] - snowdp, &! snow depth [meter] - fsno, &! fraction of snow cover on ground - sigf, &! fraction of veg cover, excluding snow-covered veg [-] - lai, &! leaf area index - sai, &! stem area index - lai_old, &! leaf area index - - alb (2,2), &! averaged albedo [-] - ssun(2,2), &! sunlit canopy absorption for solar radiation - ssha(2,2), &! shaded canopy absorption for solar radiation - ssoi(2,2), &! ground soil absorption [-] - ssno(2,2), &! ground snow absorption [-] -#ifdef HYPERSPECTRAL - alb_hires (211,2), &! averaged albedo [-] - reflectance_out (211, 0:15) ,& - transmittance_out(211, 0:15) ,& -#endif - thermk, &! canopy gap fraction for tir radiation - extkb, &! (k, g(mu)/mu) direct solar extinction coefficient - extkd, &! diffuse and scattered diffuse PAR extinction coefficient - wa ! water storage in aquifer [mm] - real(r8), intent(inout) :: &! - zwt ! the depth to water table [m] - - real(r8), intent(out) :: &! - snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] - mss_bcphi( maxsnl+1:0 ), &! mass concentration of hydrophilic BC (col,lyr) [kg/kg] - mss_bcpho( maxsnl+1:0 ), &! mass concentration of hydrophobic BC (col,lyr) [kg/kg] - mss_ocphi( maxsnl+1:0 ), &! mass concentration of hydrophilic OC (col,lyr) [kg/kg] - mss_ocpho( maxsnl+1:0 ), &! mass concentration of hydrophobic OC (col,lyr) [kg/kg] - mss_dst1 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] - mss_dst2 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] - mss_dst3 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] - mss_dst4 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] - ssno_lyr (2,2,maxsnl+1:1 ), &! snow layer absorption [-] - - ! Additional variables required by regional model (WRF & RSM) - ! --------------------------------------------------------- - trad, &! radiative temperature of surface [K] - tref, &! 2 m height air temperature [kelvin] - qref, &! 2 m height air specific humidity - rst, &! canopy stomatal resistance (s/m) - emis, &! averaged bulk surface emissivity - zol, &! dimensionless height (z/L) used in Monin-Obukhov theory - rib, &! bulk Richardson number in surface layer - ustar, &! u* in similarity theory [m/s] - qstar, &! q* in similarity theory [kg/kg] - tstar, &! t* in similarity theory [K] - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture - real(r8), intent(out) :: & - o3coefv_sun, &! Ozone stress factor for photosynthesis on sunlit leaf - o3coefv_sha, &! Ozone stress factor for photosynthesis on sunlit leaf - o3coefg_sun, &! Ozone stress factor for stomata on shaded leaf - o3coefg_sha ! Ozone stress factor for stomata on shaded leaf - -#ifdef BGC - real(r8),intent(out) :: & - totlitc , & - totsomc , & - totcwdc , & - totvegc , & - totcolc , & - totlitn , & - totsomn , & - totcwdn , & - totvegn , & - totcoln , & - col_endcb , & - col_begcb , & - col_vegendcb , & - col_vegbegcb , & - col_soilendcb , & - col_soilbegcb , & - col_endnb , & - col_begnb , & - col_vegendnb , & - col_vegbegnb , & - col_soilendnb , & - col_soilbegnb , & - col_sminnendnb , & - col_sminnbegnb , & - decomp_cpools_vr (nl_soil_full,ndecomp_pools), & - decomp_cpools (ndecomp_pools) , & - ctrunc_vr (nl_soil) , & - ctrunc_veg , & - ctrunc_soil , & - altmax , & - altmax_lastyear , & - lag_npp - integer, intent(out) :: altmax_lastyear_indx - real(r8),intent(out) :: & - decomp_npools_vr (nl_soil_full,ndecomp_pools), & - decomp_npools (ndecomp_pools) , & - ntrunc_vr (nl_soil) , & - ntrunc_veg , & - ntrunc_soil , & - sminn_vr (nl_soil) , & - sminn , & - smin_no3_vr (nl_soil) , & - smin_nh4_vr (nl_soil) , & - prec10 , & - prec60 , & - prec365 , & - prec_today , & - prec_daily (365) , & - tsoi17 , & - rh30 , & - accumnstep - - !---------------SASU variables----------------------- - real(r8),intent(out) :: & - decomp0_cpools_vr (nl_soil,ndecomp_pools) , & - decomp0_npools_vr (nl_soil,ndecomp_pools) , & - - I_met_c_vr_acc (nl_soil) , & - I_cel_c_vr_acc (nl_soil) , & - I_lig_c_vr_acc (nl_soil) , & - I_cwd_c_vr_acc (nl_soil) , & - AKX_met_to_soil1_c_vr_acc (nl_soil) , & - AKX_cel_to_soil1_c_vr_acc (nl_soil) , & - AKX_lig_to_soil2_c_vr_acc (nl_soil) , & - AKX_soil1_to_soil2_c_vr_acc(nl_soil) , & - AKX_cwd_to_cel_c_vr_acc (nl_soil) , & - AKX_cwd_to_lig_c_vr_acc (nl_soil) , & - AKX_soil1_to_soil3_c_vr_acc(nl_soil) , & - AKX_soil2_to_soil1_c_vr_acc(nl_soil) , & - AKX_soil2_to_soil3_c_vr_acc(nl_soil) , & - AKX_soil3_to_soil1_c_vr_acc(nl_soil) , & - AKX_met_exit_c_vr_acc (nl_soil) , & - AKX_cel_exit_c_vr_acc (nl_soil) , & - AKX_lig_exit_c_vr_acc (nl_soil) , & - AKX_cwd_exit_c_vr_acc (nl_soil) , & - AKX_soil1_exit_c_vr_acc (nl_soil) , & - AKX_soil2_exit_c_vr_acc (nl_soil) , & - AKX_soil3_exit_c_vr_acc (nl_soil) , & - - I_met_n_vr_acc (nl_soil) , & - I_cel_n_vr_acc (nl_soil) , & - I_lig_n_vr_acc (nl_soil) , & - I_cwd_n_vr_acc (nl_soil) , & - AKX_met_to_soil1_n_vr_acc (nl_soil) , & - AKX_cel_to_soil1_n_vr_acc (nl_soil) , & - AKX_lig_to_soil2_n_vr_acc (nl_soil) , & - AKX_soil1_to_soil2_n_vr_acc(nl_soil) , & - AKX_cwd_to_cel_n_vr_acc (nl_soil) , & - AKX_cwd_to_lig_n_vr_acc (nl_soil) , & - AKX_soil1_to_soil3_n_vr_acc(nl_soil) , & - AKX_soil2_to_soil1_n_vr_acc(nl_soil) , & - AKX_soil2_to_soil3_n_vr_acc(nl_soil) , & - AKX_soil3_to_soil1_n_vr_acc(nl_soil) , & - AKX_met_exit_n_vr_acc (nl_soil) , & - AKX_cel_exit_n_vr_acc (nl_soil) , & - AKX_lig_exit_n_vr_acc (nl_soil) , & - AKX_cwd_exit_n_vr_acc (nl_soil) , & - AKX_soil1_exit_n_vr_acc (nl_soil) , & - AKX_soil2_exit_n_vr_acc (nl_soil) , & - AKX_soil3_exit_n_vr_acc (nl_soil) , & - - diagVX_c_vr_acc (nl_soil,ndecomp_pools) , & - upperVX_c_vr_acc (nl_soil,ndecomp_pools) , & - lowerVX_c_vr_acc (nl_soil,ndecomp_pools) , & - diagVX_n_vr_acc (nl_soil,ndecomp_pools) , & - upperVX_n_vr_acc (nl_soil,ndecomp_pools) , & - lowerVX_n_vr_acc (nl_soil,ndecomp_pools) - - !---------------------------------------------------- - logical, intent(out) :: & - skip_balance_check - -#endif - - integer j, snl, m, ivt - real(r8) wet(nl_soil), zi_soi_a(0:nl_soil), psi, vliq, wt, ssw, oro, rhosno_ini, a - - ! SNICAR - real(r8) pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] - real(r8) snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] - - integer ps, pe - - !----------------------------------------------------------------------- - IF(patchtype <= 5)THEN ! land grid - - ! (1) SOIL temperature, water and SNOW - ! Variables: t_soisno, wliq_soisno, wice_soisno, wa, zwt - IF (use_soilini) THEN - ! (1.1) all temperature, water and zwt from data. - - zi_soi_a(:) = (/0., zi_soi/) - - DO j = 1, nl_soil - CALL polint(soil_z,soil_t,nl_soil_ini,z_soisno(j),t_soisno(j)) - ENDDO - - IF (patchtype <= 1) THEN ! soil or urban - - DO j = 1, nl_soil - - CALL polint(soil_z,soil_w,nl_soil_ini,z_soisno(j),wet(j)) - - wet(j) = min(max(wet(j),0.), porsl(j)) - - IF (zwt <= zi_soi_a(j-1)) THEN - wet(j) = porsl(j) - ELSEIF (zwt < zi_soi_a(j)) THEN - wet(j) = ((zi_soi_a(j)-zwt)*porsl(j) + (zwt-zi_soi_a(j-1))*wet(j)) & - / (zi_soi_a(j)-zi_soi_a(j-1)) - ENDIF - - IF(t_soisno(j).ge.tfrz)THEN - wliq_soisno(j) = wet(j)*dz_soisno(j)*denh2o - wice_soisno(j) = 0. - ELSE - wliq_soisno(j) = 0. - wice_soisno(j) = wet(j)*dz_soisno(j)*denice - ENDIF - ENDDO - - ! get wa from zwt - IF (zwt > zi_soi_a(nl_soil)) THEN - psi = psi0(nl_soil) - (zwt*1000. - zi_soi_a(nl_soil)*1000.) * 0.5 - vliq = soil_vliq_from_psi (psi, porsl(nl_soil), vliq_r(nl_soil), psi0(nl_soil), & - nprms, prms(:,nl_soil)) - wa = -(zwt*1000. - zi_soi_a(nl_soil)*1000.)*(porsl(nl_soil)-vliq) - ELSE - wa = 0. - ENDIF - - ELSEIF ((patchtype == 2) .or. (patchtype == 4)) THEN ! (2) wetland or (4) lake - - DO j = 1, nl_soil - IF(t_soisno(j).ge.tfrz)THEN - wliq_soisno(j) = porsl(j)*dz_soisno(j)*denh2o - wice_soisno(j) = 0. - ELSE - wliq_soisno(j) = 0. - wice_soisno(j) = porsl(j)*dz_soisno(j)*denice - ENDIF - ENDDO - - wa = 0. - zwt = 0. - - ELSEIF (patchtype == 3) THEN ! land ice - - DO j = 1, nl_soil - wliq_soisno(j) = 0. - wice_soisno(j) = dz_soisno(j)*denice - ENDDO - - wa = 0. - zwt = 0. - - ENDIF - - IF (.not. DEF_USE_VariablySaturatedFlow) THEN - wa = wa + 5000. - ENDIF - - ELSEIF (use_wtd) THEN - ! (1.2) only zwt is from data. - - DO j = 1, nl_soil - IF(patchtype==3)THEN !land ice - t_soisno(j) = 253. - wliq_soisno(j) = 0. - wice_soisno(j) = dz_soisno(j)*denice - ELSE - t_soisno(j) = 283. - wliq_soisno(j) = dz_soisno(j)*porsl(j)*denh2o - wice_soisno(j) = 0. - ENDIF - ENDDO - - IF (patchtype <= 1) THEN - CALL get_water_equilibrium_state (zwtmm, nl_soil, wliq_soisno(1:nl_soil), smp, hk, wa, & - zc_soimm, zi_soimm, porsl, vliq_r, psi0, hksati, nprms, prms) - ELSE - wa = 0. - zwt = 0. - ENDIF - - IF (.not. DEF_USE_VariablySaturatedFlow) THEN - wa = wa + 5000. - ENDIF - - ELSE - ! (1.3) cold start - - DO j = 1, nl_soil - IF(patchtype==3)THEN !land ice - t_soisno(j) = 253. - wliq_soisno(j) = 0. - wice_soisno(j) = dz_soisno(j)*denice - ELSE - t_soisno(j) = 283. - wliq_soisno(j) = dz_soisno(j)*porsl(j)*denh2o - wice_soisno(j) = 0. - ENDIF - ENDDO - - IF (patchtype <= 1) THEN - IF (DEF_USE_VariablySaturatedFlow) THEN - wa = 0. - zwt = zi_soimm(nl_soil)/1000. - ELSE - ! water table depth (initially at 1.0 m below the model bottom; wa when zwt - ! is below the model bottom zi(nl_soil) - wa = 4800. !assuming aquifer capacity is 5000 mm - zwt = (25. + z_soisno(nl_soil))+dz_soisno(nl_soil)/2. - wa/1000./0.2 !to result in zwt = zi(nl_soil) + 1.0 m - ENDIF - ELSE - wa = 0. - zwt = 0. - ENDIF - - ENDIF - - - ! (2) snow initialization - ! variables: snowdp, sag, scv, fsno, snl, z_soisno, dz_soisno - z0m = htop * z0mr -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF(patchtype==0)THEN - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - IF (ps>0 .and. pe>0) THEN - z0m_p(ps:pe) = htop_p(ps:pe) * z0mr - ENDIF - ENDIF -#endif - - IF (use_snowini) THEN - - rhosno_ini = 250. - snowdp = snow_d - sag = 0. - scv = snowdp*rhosno_ini - - ! 08/02/2019, yuan: NOTE! need to be changed in future. - ! 12/05/2023, yuan: DONE for snowini, change sai. - CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) - CALL snow_ini (patchtype,maxsnl,snowdp,snl,z_soisno,dz_soisno) - - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf - - IF (patchtype == 0) THEN -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) - IF(DEF_USE_LAIFEEDBACK)THEN - lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) - ELSE - lai_p(ps:pe) = tlai_p(ps:pe) - lai = tlai(ipatch) - ENDIF - sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) -#endif - ENDIF - - IF(snl.lt.0)THEN - DO j = snl+1, 0 - t_soisno(j) = min(tfrz-1., t_soisno(1)) - wliq_soisno(j) = 0. - wice_soisno(j) = dz_soisno(j)*rhosno_ini !m * kg m-3 = kg m-2 - ENDDO - ENDIF - - IF(snl>maxsnl)THEN - t_soisno (maxsnl+1:snl) = -999. - wice_soisno(maxsnl+1:snl) = 0. - wliq_soisno(maxsnl+1:snl) = 0. - z_soisno (maxsnl+1:snl) = 0. - dz_soisno (maxsnl+1:snl) = 0. - ENDIF - - ELSE - - snowdp = 0. - sag = 0. - scv = 0. - fsno = 0. - snl = 0 - - ! snow temperature and water content - t_soisno (maxsnl+1:0) = -999. - wice_soisno(maxsnl+1:0) = 0. - wliq_soisno(maxsnl+1:0) = 0. - z_soisno (maxsnl+1:0) = 0. - dz_soisno (maxsnl+1:0) = 0. - - ENDIF - - - ! (3) soil matrix potential hydraulic conductivity - ! Variables: smp, hk - DO j = 1, nl_soil - IF ((patchtype==3) .or. (t_soisno(j) < tfrz)) THEN !land ice or frozen soil - smp(j) = 1.e3 * 0.3336e6/9.80616*(t_soisno(j)-tfrz)/t_soisno(j) - hk(j) = 0. - ELSE - vliq = wliq_soisno(j) / (zi_soimm(j)-zi_soimm(j-1)) - smp(j) = soil_psi_from_vliq (vliq, porsl(j), vliq_r(j), psi0(j), nprms, prms(:,j)) - hk (j) = soil_hk_from_psi (smp(j), psi0(j), hksati(j), nprms, prms(:,j)) - ENDIF - ENDDO - - ! (4) Vegetation water and temperature - ! Variables: ldew_rain, ldew_snow, ldew, t_leaf, vegwp, gs0sun, gs0sha - ldew_rain = 0. - ldew_snow = 0. - fwet_snow = 0. - ldew = 0. - tleaf = t_soisno(1) - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp(1:nvegwcs) = -2.5e4 - gs0sun = 1.0e4 - gs0sha = 1.0e4 - ENDIF - - IF (patchtype == 0) THEN -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - ldew_rain_p(ps:pe) = 0. - ldew_snow_p(ps:pe) = 0. - fwet_snow_p(ps:pe) = 0. - ldew_p(ps:pe) = 0. - tleaf_p(ps:pe)= t_soisno(1) - tref_p(ps:pe) = t_soisno(1) - qref_p(ps:pe) = 0.3 - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_p(1:nvegwcs,ps:pe) = -2.5e4 - gs0sun_p(ps:pe) = 1.0e4 - gs0sha_p(ps:pe) = 1.0e4 - ENDIF -#endif - ENDIF - - ! (5) Ground - ! Variables: t_grnd - t_grnd = t_soisno(1) - - ! (6) Leaf area - ! Variables: sigf, lai, sai - - IF (.not. use_snowini) THEN - IF (patchtype == 0) THEN -#if (defined LULC_USGS || defined LULC_IGBP) - sigf = fveg - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf - IF(DEF_USE_OZONESTRESS)THEN - lai_old = lai - ENDIF -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - sigf_p (ps:pe) = 1. - lai_p(ps:pe) = tlai_p(ps:pe) - sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - - sigf = 1. - lai = tlai(ipatch) - sai = sum(sai_p(ps:pe) * pftfrac(ps:pe)) - IF(DEF_USE_OZONESTRESS)THEN - lai_old = lai - lai_old_p(ps:pe) = lai_p(ps:pe) - ENDIF -#endif - ELSE - sigf = fveg - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf - IF(DEF_USE_OZONESTRESS)THEN - lai_old = lai - ENDIF - ENDIF - ENDIF - - ! (7) SNICAR - ! Variables: snw_rds, mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi, - ! mss_dst1, mss_dst2, mss_dst3, mss_dst4 - snw_rds (:) = 54.526_r8 - mss_bcpho (:) = 0. - mss_bcphi (:) = 0. - mss_ocpho (:) = 0. - mss_ocphi (:) = 0. - mss_dst1 (:) = 0. - mss_dst2 (:) = 0. - mss_dst3 (:) = 0. - mss_dst4 (:) = 0. - -#ifdef BGC - totlitc = 0.0 - totsomc = 0.0 - totcwdc = 0.0 - totvegc = 0.0 - totcolc = 0.0 - totlitn = 0.0 - totsomn = 0.0 - totcwdn = 0.0 - totvegn = 0.0 - col_endcb = 0.0 - col_begcb = 0.0 - col_vegendcb = 0.0 - col_vegbegcb = 0.0 - col_soilendcb = 0.0 - col_soilbegcb = 0.0 - col_endnb = 0.0 - col_begnb = 0.0 - col_vegendnb = 0.0 - col_vegbegnb = 0.0 - col_soilendnb = 0.0 - col_soilbegnb = 0.0 - IF(.not. use_cnini)THEN - decomp_cpools_vr (:,:) = 0.0 - ENDIF - decomp_cpools (:) = 0.0 - ctrunc_vr (:) = 0.0 - ctrunc_veg = 0.0 - ctrunc_soil = 0.0 - altmax = 10.0 - altmax_lastyear = 10.0 - altmax_lastyear_indx = 10 - lag_npp = 0.0 - IF(.not. use_cnini)THEN - decomp_npools_vr (:,:) = 0.0 - ENDIF - decomp_npools (:) = 0.0 - ntrunc_vr (:) = 0.0 - ntrunc_veg = 0.0 - ntrunc_soil = 0.0 - IF(.not. use_cnini)THEN - smin_no3_vr (:) = 5.0 - smin_nh4_vr (:) = 5.0 - sminn_vr (:) = 10.0 - ENDIF - sminn = 0.0 - DO j = 1, nl_soil - sminn = sminn + sminn_vr(j) * dz_soisno(j) - ENDDO - col_sminnendnb = sminn - col_sminnbegnb = sminn - totcoln = totvegn + totcwdn + totlitn + totsomn + sminn + ntrunc_veg + ntrunc_soil - prec10 = 0._r8 - prec60 = 0._r8 - prec365 = 0._r8 - prec_today = 0._r8 - prec_daily (:) = 0._r8 - tsoi17 = 273.15_r8 - rh30 = 0._r8 - accumnstep = 0._r8 - - !---------------SASU variables----------------------- - decomp0_cpools_vr (:,:) = 0.0 - I_met_c_vr_acc (:) = 0.0 - I_cel_c_vr_acc (:) = 0.0 - I_lig_c_vr_acc (:) = 0.0 - I_cwd_c_vr_acc (:) = 0.0 - AKX_met_to_soil1_c_vr_acc (:) = 0.0 - AKX_cel_to_soil1_c_vr_acc (:) = 0.0 - AKX_lig_to_soil2_c_vr_acc (:) = 0.0 - AKX_soil1_to_soil2_c_vr_acc (:) = 0.0 - AKX_cwd_to_cel_c_vr_acc (:) = 0.0 - AKX_cwd_to_lig_c_vr_acc (:) = 0.0 - AKX_soil1_to_soil3_c_vr_acc (:) = 0.0 - AKX_soil2_to_soil1_c_vr_acc (:) = 0.0 - AKX_soil2_to_soil3_c_vr_acc (:) = 0.0 - AKX_soil3_to_soil1_c_vr_acc (:) = 0.0 - AKX_met_exit_c_vr_acc (:) = 0.0 - AKX_cel_exit_c_vr_acc (:) = 0.0 - AKX_lig_exit_c_vr_acc (:) = 0.0 - AKX_cwd_exit_c_vr_acc (:) = 0.0 - AKX_soil1_exit_c_vr_acc (:) = 0.0 - AKX_soil2_exit_c_vr_acc (:) = 0.0 - AKX_soil3_exit_c_vr_acc (:) = 0.0 - - decomp0_npools_vr (:,:) = 0.0 - I_met_n_vr_acc (:) = 0.0 - I_cel_n_vr_acc (:) = 0.0 - I_lig_n_vr_acc (:) = 0.0 - I_cwd_n_vr_acc (:) = 0.0 - AKX_met_to_soil1_n_vr_acc (:) = 0.0 - AKX_cel_to_soil1_n_vr_acc (:) = 0.0 - AKX_lig_to_soil2_n_vr_acc (:) = 0.0 - AKX_soil1_to_soil2_n_vr_acc (:) = 0.0 - AKX_cwd_to_cel_n_vr_acc (:) = 0.0 - AKX_cwd_to_lig_n_vr_acc (:) = 0.0 - AKX_soil1_to_soil3_n_vr_acc (:) = 0.0 - AKX_soil2_to_soil1_n_vr_acc (:) = 0.0 - AKX_soil2_to_soil3_n_vr_acc (:) = 0.0 - AKX_soil3_to_soil1_n_vr_acc (:) = 0.0 - AKX_met_exit_n_vr_acc (:) = 0.0 - AKX_cel_exit_n_vr_acc (:) = 0.0 - AKX_lig_exit_n_vr_acc (:) = 0.0 - AKX_cwd_exit_n_vr_acc (:) = 0.0 - AKX_soil1_exit_n_vr_acc (:) = 0.0 - AKX_soil2_exit_n_vr_acc (:) = 0.0 - AKX_soil3_exit_n_vr_acc (:) = 0.0 - - diagVX_c_vr_acc (:,:) = 0.0 - upperVX_c_vr_acc (:,:) = 0.0 - lowerVX_c_vr_acc (:,:) = 0.0 - diagVX_n_vr_acc (:,:) = 0.0 - upperVX_n_vr_acc (:,:) = 0.0 - lowerVX_n_vr_acc (:,:) = 0.0 - - !---------------------------------------------------- - skip_balance_check = .false. - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtype == 0) THEN - DO m = ps, pe - ivt = pftclass(m) - IF(ivt .eq. 0)THEN !no vegetation - leafc_p (m) = 0.0 - leafc_storage_p (m) = 0.0 - leafn_p (m) = 0.0 - leafn_storage_p (m) = 0.0 - frootc_p (m) = 0.0 - frootc_storage_p (m) = 0.0 - frootn_p (m) = 0.0 - frootn_storage_p (m) = 0.0 - ELSE - IF(isevg(ivt))THEN - IF(.not. use_cnini)THEN - leafc_p (m) = 100.0 - frootc_p (m) = 0.0 - ENDIF - leafc_storage_p (m) = 0.0 - frootc_storage_p (m) = 0.0 - ELSE IF(ivt >= npcropmin) THEN - leafc_p (m) = 0.0 - leafc_storage_p (m) = 0.0 - frootc_p (m) = 0.0 - frootc_storage_p (m) = 0.0 - ELSE - IF(.not. use_cnini)THEN - leafc_p (m) = 0.0 - leafc_storage_p (m) = 100.0 - frootc_p (m) = 0.0 - frootc_storage_p (m) = 0.0 - ENDIF - ENDIF - leafn_p (m) = leafc_p (m) / leafcn (ivt) - leafn_storage_p (m) = leafc_storage_p(m) / leafcn (ivt) - frootn_p (m) = frootc_p (m) / frootcn (ivt) - frootn_storage_p (m) = frootc_storage_p(m) / frootcn (ivt) - ENDIF - IF(woody(ivt) .eq. 1)THEN - IF(.not. use_cnini)THEN - deadstemc_p (m) = 0.1 - livestemc_p (m) = 0.0 - deadcrootc_p (m) = 0.0 - livecrootc_p (m) = 0.0 - ENDIF - livestemn_p (m) = livestemc_p (m) / livewdcn(ivt) - deadstemn_p (m) = deadstemc_p (m) / deadwdcn(ivt) - livecrootn_p (m) = livecrootc_p (m) / livewdcn(ivt) - deadcrootn_p (m) = deadcrootc_p (m) / deadwdcn(ivt) - ELSE - livestemc_p (m) = 0.0 - deadstemc_p (m) = 0.0 - livestemn_p (m) = 0.0 - deadstemn_p (m) = 0.0 - livecrootc_p (m) = 0.0 - deadcrootc_p (m) = 0.0 - livecrootn_p (m) = 0.0 - deadcrootn_p (m) = 0.0 - ENDIF - ! totcolc = totcolc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) - ! totvegc = totvegc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) - ! totcoln = totcoln + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) - ! totvegn = totvegn + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) - ENDDO - IF(DEF_USE_OZONESTRESS)THEN - o3uptakesun_p (ps:pe) = 0._r8 - o3uptakesha_p (ps:pe) = 0._r8 - o3coefv_sun_p (ps:pe) = 1._r8 - o3coefv_sha_p (ps:pe) = 1._r8 - o3coefg_sun_p (ps:pe) = 1._r8 - o3coefg_sha_p (ps:pe) = 1._r8 - ENDIF - leafc_xfer_p (ps:pe) = 0.0 - frootc_xfer_p (ps:pe) = 0.0 - livestemc_storage_p (ps:pe) = 0.0 - livestemc_xfer_p (ps:pe) = 0.0 - deadstemc_storage_p (ps:pe) = 0.0 - deadstemc_xfer_p (ps:pe) = 0.0 - livecrootc_storage_p (ps:pe) = 0.0 - livecrootc_xfer_p (ps:pe) = 0.0 - deadcrootc_storage_p (ps:pe) = 0.0 - deadcrootc_xfer_p (ps:pe) = 0.0 - grainc_p (ps:pe) = 0.0 - grainc_storage_p (ps:pe) = 0.0 - grainc_xfer_p (ps:pe) = 0.0 - cropseedc_deficit_p (ps:pe) = 0.0 - xsmrpool_p (ps:pe) = 0.0 - gresp_storage_p (ps:pe) = 0.0 - gresp_xfer_p (ps:pe) = 0.0 - cpool_p (ps:pe) = 0.0 - ctrunc_p (ps:pe) = 0.0 - cropprod1c_p (ps:pe) = 0.0 - - leafn_xfer_p (ps:pe) = 0.0 - frootn_xfer_p (ps:pe) = 0.0 - livestemn_storage_p (ps:pe) = 0.0 - livestemn_xfer_p (ps:pe) = 0.0 - deadstemn_storage_p (ps:pe) = 0.0 - deadstemn_xfer_p (ps:pe) = 0.0 - livecrootn_storage_p (ps:pe) = 0.0 - livecrootn_xfer_p (ps:pe) = 0.0 - deadcrootn_storage_p (ps:pe) = 0.0 - deadcrootn_xfer_p (ps:pe) = 0.0 - grainn_p (ps:pe) = 0.0 - grainn_storage_p (ps:pe) = 0.0 - grainn_xfer_p (ps:pe) = 0.0 - npool_p (ps:pe) = 0.0 - ntrunc_p (ps:pe) = 0.0 - cropseedn_deficit_p (ps:pe) = 0.0 - retransn_p (ps:pe) = 0.0 - - harvdate_p (ps:pe) = 99999999 - - tempsum_potential_gpp_p (ps:pe) = 0.0 - tempmax_retransn_p (ps:pe) = 0.0 - tempavg_tref_p (ps:pe) = 0.0 - tempsum_npp_p (ps:pe) = 0.0 - tempsum_litfall_p (ps:pe) = 0.0 - annsum_potential_gpp_p (ps:pe) = 0.0 - annmax_retransn_p (ps:pe) = 0.0 - annavg_tref_p (ps:pe) = 280.0 - annsum_npp_p (ps:pe) = 0.0 - annsum_litfall_p (ps:pe) = 0.0 - - bglfr_p (ps:pe) = 0.0 - bgtr_p (ps:pe) = 0.0 - lgsf_p (ps:pe) = 0.0 - gdd0_p (ps:pe) = 0.0 - gdd8_p (ps:pe) = 0.0 - gdd10_p (ps:pe) = 0.0 - gdd020_p (ps:pe) = 0.0 - gdd820_p (ps:pe) = 0.0 - gdd1020_p (ps:pe) = 0.0 - nyrs_crop_active_p (ps:pe) = 0 - - offset_flag_p (ps:pe) = 0.0 - offset_counter_p (ps:pe) = 0.0 - onset_flag_p (ps:pe) = 0.0 - onset_counter_p (ps:pe) = 0.0 - onset_gddflag_p (ps:pe) = 0.0 - onset_gdd_p (ps:pe) = 0.0 - onset_fdd_p (ps:pe) = 0.0 - onset_swi_p (ps:pe) = 0.0 - offset_fdd_p (ps:pe) = 0.0 - offset_swi_p (ps:pe) = 0.0 - dormant_flag_p (ps:pe) = 1.0 - prev_leafc_to_litter_p (ps:pe) = 0.0 - prev_frootc_to_litter_p (ps:pe) = 0.0 - days_active_p (ps:pe) = 0.0 - - burndate_p (ps:pe) = 10000 - grain_flag_p (ps:pe) = 0.0 - -#ifdef CROP - ! crop variables - croplive_p (ps:pe) = .false. - hui_p (ps:pe) = spval - gddplant_p (ps:pe) = spval - peaklai_p (ps:pe) = 0 - aroot_p (ps:pe) = spval - astem_p (ps:pe) = spval - arepr_p (ps:pe) = spval - aleaf_p (ps:pe) = spval - astemi_p (ps:pe) = spval - aleafi_p (ps:pe) = spval - gddmaturity_p (ps:pe) = spval - - cropplant_p (ps:pe) = .false. - idop_p (ps:pe) = 99999999 - cumvd_p (ps:pe) = spval - vf_p (ps:pe) = 0._r8 - cphase_p (ps:pe) = 4._r8 - fert_counter_p (ps:pe) = 0._r8 - tref_min_p (ps:pe) = 273.15_r8 - tref_max_p (ps:pe) = 273.15_r8 - tref_min_inst_p (ps:pe) = spval - tref_max_inst_p (ps:pe) = spval - latbaset_p (ps:pe) = spval - fert_p (ps:pe) = 0._r8 - IF(DEF_FERT_SOURCE == 1)THEN - manunitro_p (ps:pe) = manure(pftclass(ps:pe)) * 1000 - ENDIF -#endif - - IF(DEF_USE_LAIFEEDBACK)THEN - tlai_p (ps:pe) = slatop(pftclass(ps:pe)) * leafc_p(ps:pe) - tlai_p (ps:pe) = max(0._r8, tlai_p(ps:pe)) - lai_p (ps:pe) = tlai_p(ps:pe) - lai = sum(lai_p(ps:pe) * pftfrac(ps:pe)) - IF(DEF_USE_OZONESTRESS)THEN - lai_old = lai - lai_old_p (ps:pe) = lai_p(ps:pe) - ENDIF - ENDIF - -#ifdef BGC - CALL CNDriverSummarizeStates(ipatch,ps,pe,nl_soil,dz_soi,ndecomp_pools,.true.) -#endif - - ! SASU varaibles - leafc0_p (ps:pe) = 0.0 - leafc0_storage_p (ps:pe) = 0.0 - leafc0_xfer_p (ps:pe) = 0.0 - frootc0_p (ps:pe) = 0.0 - frootc0_storage_p (ps:pe) = 0.0 - frootc0_xfer_p (ps:pe) = 0.0 - livestemc0_p (ps:pe) = 0.0 - livestemc0_storage_p (ps:pe) = 0.0 - livestemc0_xfer_p (ps:pe) = 0.0 - deadstemc0_p (ps:pe) = 0.0 - deadstemc0_storage_p (ps:pe) = 0.0 - deadstemc0_xfer_p (ps:pe) = 0.0 - livecrootc0_p (ps:pe) = 0.0 - livecrootc0_storage_p (ps:pe) = 0.0 - livecrootc0_xfer_p (ps:pe) = 0.0 - deadcrootc0_p (ps:pe) = 0.0 - deadcrootc0_storage_p (ps:pe) = 0.0 - deadcrootc0_xfer_p (ps:pe) = 0.0 - grainc0_p (ps:pe) = 0.0 - grainc0_storage_p (ps:pe) = 0.0 - grainc0_xfer_p (ps:pe) = 0.0 - - leafn0_p (ps:pe) = 0.0 - leafn0_storage_p (ps:pe) = 0.0 - leafn0_xfer_p (ps:pe) = 0.0 - frootn0_p (ps:pe) = 0.0 - frootn0_storage_p (ps:pe) = 0.0 - frootn0_xfer_p (ps:pe) = 0.0 - livestemn0_p (ps:pe) = 0.0 - livestemn0_storage_p (ps:pe) = 0.0 - livestemn0_xfer_p (ps:pe) = 0.0 - deadstemn0_p (ps:pe) = 0.0 - deadstemn0_storage_p (ps:pe) = 0.0 - deadstemn0_xfer_p (ps:pe) = 0.0 - livecrootn0_p (ps:pe) = 0.0 - livecrootn0_storage_p (ps:pe) = 0.0 - livecrootn0_xfer_p (ps:pe) = 0.0 - deadcrootn0_p (ps:pe) = 0.0 - deadcrootn0_storage_p (ps:pe) = 0.0 - deadcrootn0_xfer_p (ps:pe) = 0.0 - grainn0_p (ps:pe) = 0.0 - grainn0_storage_p (ps:pe) = 0.0 - grainn0_xfer_p (ps:pe) = 0.0 - retransn0_p (ps:pe) = 0.0 - - I_leafc_p_acc (ps:pe) = 0._r8 - I_leafc_st_p_acc (ps:pe) = 0._r8 - I_frootc_p_acc (ps:pe) = 0._r8 - I_frootc_st_p_acc (ps:pe) = 0._r8 - I_livestemc_p_acc (ps:pe) = 0._r8 - I_livestemc_st_p_acc (ps:pe) = 0._r8 - I_deadstemc_p_acc (ps:pe) = 0._r8 - I_deadstemc_st_p_acc (ps:pe) = 0._r8 - I_livecrootc_p_acc (ps:pe) = 0._r8 - I_livecrootc_st_p_acc (ps:pe) = 0._r8 - I_deadcrootc_p_acc (ps:pe) = 0._r8 - I_deadcrootc_st_p_acc (ps:pe) = 0._r8 - I_grainc_p_acc (ps:pe) = 0._r8 - I_grainc_st_p_acc (ps:pe) = 0._r8 - I_leafn_p_acc (ps:pe) = 0._r8 - I_leafn_st_p_acc (ps:pe) = 0._r8 - I_frootn_p_acc (ps:pe) = 0._r8 - I_frootn_st_p_acc (ps:pe) = 0._r8 - I_livestemn_p_acc (ps:pe) = 0._r8 - I_livestemn_st_p_acc (ps:pe) = 0._r8 - I_deadstemn_p_acc (ps:pe) = 0._r8 - I_deadstemn_st_p_acc (ps:pe) = 0._r8 - I_livecrootn_p_acc (ps:pe) = 0._r8 - I_livecrootn_st_p_acc (ps:pe) = 0._r8 - I_deadcrootn_p_acc (ps:pe) = 0._r8 - I_deadcrootn_st_p_acc (ps:pe) = 0._r8 - I_grainn_p_acc (ps:pe) = 0._r8 - I_grainn_st_p_acc (ps:pe) = 0._r8 - - AKX_leafc_xf_to_leafc_p_acc (ps:pe) = 0._r8 - AKX_frootc_xf_to_frootc_p_acc (ps:pe) = 0._r8 - AKX_livestemc_xf_to_livestemc_p_acc (ps:pe) = 0._r8 - AKX_deadstemc_xf_to_deadstemc_p_acc (ps:pe) = 0._r8 - AKX_livecrootc_xf_to_livecrootc_p_acc (ps:pe) = 0._r8 - AKX_deadcrootc_xf_to_deadcrootc_p_acc (ps:pe) = 0._r8 - AKX_grainc_xf_to_grainc_p_acc (ps:pe) = 0._r8 - AKX_livestemc_to_deadstemc_p_acc (ps:pe) = 0._r8 - AKX_livecrootc_to_deadcrootc_p_acc (ps:pe) = 0._r8 - - AKX_leafc_st_to_leafc_xf_p_acc (ps:pe) = 0._r8 - AKX_frootc_st_to_frootc_xf_p_acc (ps:pe) = 0._r8 - AKX_livestemc_st_to_livestemc_xf_p_acc (ps:pe) = 0._r8 - AKX_deadstemc_st_to_deadstemc_xf_p_acc (ps:pe) = 0._r8 - AKX_livecrootc_st_to_livecrootc_xf_p_acc (ps:pe) = 0._r8 - AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (ps:pe) = 0._r8 - AKX_grainc_st_to_grainc_xf_p_acc (ps:pe) = 0._r8 - - AKX_leafc_exit_p_acc (ps:pe) = 0._r8 - AKX_frootc_exit_p_acc (ps:pe) = 0._r8 - AKX_livestemc_exit_p_acc (ps:pe) = 0._r8 - AKX_deadstemc_exit_p_acc (ps:pe) = 0._r8 - AKX_livecrootc_exit_p_acc (ps:pe) = 0._r8 - AKX_deadcrootc_exit_p_acc (ps:pe) = 0._r8 - AKX_grainc_exit_p_acc (ps:pe) = 0._r8 - - AKX_leafc_st_exit_p_acc (ps:pe) = 0._r8 - AKX_frootc_st_exit_p_acc (ps:pe) = 0._r8 - AKX_livestemc_st_exit_p_acc (ps:pe) = 0._r8 - AKX_deadstemc_st_exit_p_acc (ps:pe) = 0._r8 - AKX_livecrootc_st_exit_p_acc (ps:pe) = 0._r8 - AKX_deadcrootc_st_exit_p_acc (ps:pe) = 0._r8 - AKX_grainc_st_exit_p_acc (ps:pe) = 0._r8 - - AKX_leafc_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_frootc_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_livestemc_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_deadstemc_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_livecrootc_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_deadcrootc_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_grainc_xf_exit_p_acc (ps:pe) = 0._r8 - - AKX_leafn_xf_to_leafn_p_acc (ps:pe) = 0._r8 - AKX_frootn_xf_to_frootn_p_acc (ps:pe) = 0._r8 - AKX_livestemn_xf_to_livestemn_p_acc (ps:pe) = 0._r8 - AKX_deadstemn_xf_to_deadstemn_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_xf_to_livecrootn_p_acc (ps:pe) = 0._r8 - AKX_deadcrootn_xf_to_deadcrootn_p_acc (ps:pe) = 0._r8 - AKX_grainn_xf_to_grainn_p_acc (ps:pe) = 0._r8 - AKX_livestemn_to_deadstemn_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_to_deadcrootn_p_acc (ps:pe) = 0._r8 - - AKX_leafn_st_to_leafn_xf_p_acc (ps:pe) = 0._r8 - AKX_frootn_st_to_frootn_xf_p_acc (ps:pe) = 0._r8 - AKX_livestemn_st_to_livestemn_xf_p_acc (ps:pe) = 0._r8 - AKX_deadstemn_st_to_deadstemn_xf_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_st_to_livecrootn_xf_p_acc (ps:pe) = 0._r8 - AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (ps:pe) = 0._r8 - AKX_grainn_st_to_grainn_xf_p_acc (ps:pe) = 0._r8 - - AKX_leafn_to_retransn_p_acc (ps:pe) = 0._r8 - AKX_frootn_to_retransn_p_acc (ps:pe) = 0._r8 - AKX_livestemn_to_retransn_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_to_retransn_p_acc (ps:pe) = 0._r8 - - AKX_retransn_to_leafn_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_frootn_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_livestemn_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_deadstemn_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_livecrootn_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_deadcrootn_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_grainn_p_acc (ps:pe) = 0._r8 - - AKX_retransn_to_leafn_st_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_frootn_st_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_livestemn_st_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_deadstemn_st_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_livecrootn_st_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_deadcrootn_st_p_acc (ps:pe) = 0._r8 - AKX_retransn_to_grainn_st_p_acc (ps:pe) = 0._r8 - - AKX_leafn_exit_p_acc (ps:pe) = 0._r8 - AKX_frootn_exit_p_acc (ps:pe) = 0._r8 - AKX_livestemn_exit_p_acc (ps:pe) = 0._r8 - AKX_deadstemn_exit_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_exit_p_acc (ps:pe) = 0._r8 - AKX_deadcrootn_exit_p_acc (ps:pe) = 0._r8 - AKX_grainn_exit_p_acc (ps:pe) = 0._r8 - AKX_retransn_exit_p_acc (ps:pe) = 0._r8 - - AKX_leafn_st_exit_p_acc (ps:pe) = 0._r8 - AKX_frootn_st_exit_p_acc (ps:pe) = 0._r8 - AKX_livestemn_st_exit_p_acc (ps:pe) = 0._r8 - AKX_deadstemn_st_exit_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_st_exit_p_acc (ps:pe) = 0._r8 - AKX_deadcrootn_st_exit_p_acc (ps:pe) = 0._r8 - AKX_grainn_st_exit_p_acc (ps:pe) = 0._r8 - - AKX_leafn_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_frootn_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_livestemn_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_deadstemn_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_livecrootn_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_deadcrootn_xf_exit_p_acc (ps:pe) = 0._r8 - AKX_grainn_xf_exit_p_acc (ps:pe) = 0._r8 - - ENDIF -#endif -#endif - - ! (8) surface albedo - ! Variables: alb, ssun, ssha, ssno, thermk, extkb, extkd - !NOTE: max(0.001,coszen) will make it always run to calculate initial values for the above. - wt = 0. - pg_snow = 0. - snofrz (:) = 0. - ssw = min(1.,1.e-3*wliq_soisno(1)/dz_soisno(1)) -#ifdef HYPERSPECTRAL - CALL albland_HiRes (ipatch,patchtype,1800.,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& - chil,rho,tau,fveg,green,lai,sai,fwet_snow,max(0.001,coszen),& - wt,fsno,scv,scv,sag,ssw,pg_snow,273.15,t_grnd,t_soisno(:1),dz_soisno(:1),& - snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& - mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& - mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd, & - alb_hires, & - clr_frac(1:, 89, 1), cld_frac(1:, 1), & - reflectance, transmittance, & - soil_alb, kw, nw, 0.8, & - reflectance_out, transmittance_out, & - 1, patchlatr, patchlonr, & - urban_albedo, mean_albedo, lat_north, lat_south, lon_west, lon_east ) - -#else - CALL albland (ipatch,patchtype,1800.,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& - chil,rho,tau,fveg,green,lai,sai,fwet_snow,max(0.001,coszen),& - wt,fsno,scv,scv,sag,ssw,pg_snow,273.15,t_grnd,t_soisno(:1),dz_soisno(:1),& - snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& - mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& - mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) -#endif - ELSE !ocean grid - t_soisno(:) = 300. - wice_soisno(:) = 0. - wliq_soisno(:) = 1000. - z_soisno (maxsnl+1:0) = 0. - dz_soisno(maxsnl+1:0) = 0. - sigf = 0. - fsno = 0. - ldew_rain = 0. - ldew_snow = 0. - ldew = 0. - scv = 0. - sag = 0. - snowdp = 0. - tleaf = 300. - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp(1:nvegwcs) = -2.5e4 - gs0sun = 1.0e4 - gs0sha = 1.0e4 - ENDIF - t_grnd = 300. - - oro = 0 - CALL albocean (oro,scv,coszen,alb) - ssun(:,:) = 0.0 - ssha(:,:) = 0.0 - ssoi(:,:) = 0.0 - ssno(:,:) = 0.0 - ssno_lyr(:,:,:) = 0.0 - thermk = 0.0 - extkb = 0.0 - extkd = 0.0 - ENDIF - - ! Additional variables required by regional model (WRF & RSM) - ! totally arbitrarily assigned here - trad = t_grnd - tref = t_grnd - qref = 0.3 - ! rst = 1.e36 - emis = 1.0 - zol = -1.0 - rib = -0.1 - ustar = 0.25 - qstar = 0.001 - tstar = -1.5 - fm = alog(30.) - fh = alog(30.) - fq = alog(30.) - o3coefv_sun = 1.0 - o3coefv_sha = 1.0 - o3coefg_sun = 1.0 - o3coefg_sha = 1.0 - - END SUBROUTINE IniTimeVar - !----------------------------------------------------------------------- - ! EOP - - - SUBROUTINE snow_ini(patchtype,maxsnl,snowdp,snl,z_soisno,dz_soisno) - - ! Snow spatial discretization initially - - USE MOD_Precision - IMPLICIT NONE - - integer, intent(in) :: maxsnl !maximum of snow layers - integer, intent(in) :: patchtype !index for land cover type [-] - real(r8), intent(in) :: snowdp !snow depth [m] - real(r8), intent(out) :: z_soisno (maxsnl+1:0) !node depth [m] - real(r8), intent(out) :: dz_soisno(maxsnl+1:0) !layer thickness [m] - integer, intent(out) :: snl !number of snow layer - real(r8) zi - integer i - - dz_soisno(:0) = 0. - z_soisno(:0) = 0. - snl = 0 - IF(patchtype.le.3)THEN !non water bodies - - IF(snowdp.lt.0.01)THEN - snl = 0 - ELSE - IF(snowdp>=0.01 .and. snowdp<=0.03)THEN - snl = -1 - dz_soisno(0) = snowdp - ELSE IF(snowdp>0.03 .and. snowdp<=0.04)THEN - snl = -2 - dz_soisno(-1) = snowdp/2. - dz_soisno( 0) = dz_soisno(-1) - ELSE IF(snowdp>0.04 .and. snowdp<=0.07)THEN - snl = -2 - dz_soisno(-1) = 0.02 - dz_soisno( 0) = snowdp - dz_soisno(-1) - ELSE IF(snowdp>0.07 .and. snowdp<=0.12)THEN - snl = -3 - dz_soisno(-2) = 0.02 - dz_soisno(-1) = (snowdp - 0.02)/2. - dz_soisno( 0) = dz_soisno(-1) - ELSE IF(snowdp>0.12 .and. snowdp<=0.18)THEN - snl = -3 - dz_soisno(-2) = 0.02 - dz_soisno(-1) = 0.05 - dz_soisno( 0) = snowdp - dz_soisno(-2) - dz_soisno(-1) - ELSE IF(snowdp>0.18 .and. snowdp<=0.29)THEN - snl = -4 - dz_soisno(-3) = 0.02 - dz_soisno(-2) = 0.05 - dz_soisno(-1) = (snowdp - dz_soisno(-3) - dz_soisno(-2))/2. - dz_soisno( 0) = dz_soisno(-1) - ELSE IF(snowdp>0.29 .and. snowdp<=0.41)THEN - snl = -4 - dz_soisno(-3) = 0.02 - dz_soisno(-2) = 0.05 - dz_soisno(-1) = 0.11 - dz_soisno( 0) = snowdp - dz_soisno(-3) - dz_soisno(-2) - dz_soisno(-1) - ELSE IF(snowdp>0.41 .and. snowdp<=0.64)THEN - snl = -5 - dz_soisno(-4) = 0.02 - dz_soisno(-3) = 0.05 - dz_soisno(-2) = 0.11 - dz_soisno(-1) = (snowdp - dz_soisno(-4) - dz_soisno(-3) - dz_soisno(-2))/2. - dz_soisno( 0) = dz_soisno(-1) - ELSE IF(snowdp>0.64)THEN - snl = -5 - dz_soisno(-4) = 0.02 - dz_soisno(-3) = 0.05 - dz_soisno(-2) = 0.11 - dz_soisno(-1) = 0.23 - dz_soisno( 0) = snowdp - dz_soisno(-4) - dz_soisno(-3) - dz_soisno(-2) - dz_soisno(-1) - ENDIF - - zi = 0. - DO i = 0, snl+1, -1 - z_soisno(i) = zi - dz_soisno(i)/2. - zi = -zi-dz_soisno(i) - ENDDO - ENDIF - - ENDIF - - END SUBROUTINE snow_ini - -END MODULE MOD_IniTimeVariable -!----------------------------------------------------------------------- -! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 deleted file mode 100644 index 2aa2525ed0..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_Initialize.F90 +++ /dev/null @@ -1,1662 +0,0 @@ -#include - -MODULE MOD_Initialize - - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: initialize - -CONTAINS - - SUBROUTINE initialize (casename, dir_landdata, dir_restart, & - idate, lc_year, greenwich, lulcc_call) - -!======================================================================= -! initialization routine for land surface model. -! -! Created by Yongjiu Dai, 09/15/1999 -! Revised by Yongjiu Dai, 08/30/2002 -! Revised by Yongjiu Dai, 03/2014 -! -!======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Pixel - USE MOD_LandPatch -#ifdef URBAN_MODEL - USE MOD_LandUrban - USE MOD_UrbanIniTimeVariable - USE MOD_UrbanReadin - USE MOD_Urban_LAIReadin - USE MOD_Urban_Albedo -#endif - USE MOD_Const_Physical - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables -#endif -#ifdef DataAssimilation - USE MOD_DA_Vars_TimeVariables -#endif - USE MOD_Const_LC - USE MOD_Const_PFT - USE MOD_TimeManager - - USE MOD_Grid - USE MOD_DataType - USE MOD_NetCDFSerial - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - USE MOD_Hydro_SoilFunction -#endif - USE MOD_SpatialMapping -#ifdef CatchLateralFlow - USE MOD_Mesh - USE MOD_Utils - USE MOD_LandHRU - USE MOD_Catch_BasinNetwork - USE MOD_ElementNeighbour - USE MOD_Catch_RiverLakeNetwork -#endif -#ifdef GridRiverLakeFlow - USE MOD_Grid_RiverLakeNetwork - USE MOD_Grid_Reservoir -#endif -#ifdef CROP - USE MOD_CropReadin -#endif - USE MOD_LAIEmpirical - USE MOD_LAIReadin - USE MOD_OrbCoszen - USE MOD_DBedrockReadin - USE MOD_HtopReadin - USE MOD_IniTimeVariable - USE MOD_LakeDepthReadin - USE MOD_PercentagesPFTReadin - USE MOD_SoilParametersReadin -#ifdef HYPERSPECTRAL - USE MOD_HighRes_Parameters -#endif - USE MOD_SoilTextureReadin - USE MOD_VicParaReadin -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif -#ifdef EXTERNAL_LAKE - USE MOD_Lake_TimeVars - USE MOD_Lake_Namelist, only: DEF_External_Lake -#endif - - IMPLICIT NONE - - ! ---------------------------------------------------------------------- - character(len=*), intent(in) :: casename ! case name - character(len=*), intent(in) :: dir_landdata - character(len=*), intent(in) :: dir_restart - integer, intent(inout) :: idate(3) ! year, julian day, seconds of the starting time - integer, intent(in) :: lc_year ! year, land cover year - logical, intent(in) :: greenwich ! true: greenwich time, false: local time - logical, optional, intent(in) :: lulcc_call ! whether it is a lulcc CALL - - ! ------------------------ local variables ----------------------------- - real(r8) :: rlon, rlat - - ! for SOIL INIT of water, temperature, snow depth - logical :: use_soilini - logical :: use_cnini - logical :: use_snowini - - character(len=256) :: fsoildat - character(len=256) :: fsnowdat - character(len=256) :: fcndat - character(len=256) :: ftopo, lndname - type(grid_type) :: gsoil - type(grid_type) :: gsnow - type(grid_type) :: gcn - type(spatial_mapping_type) :: ms2p - type(spatial_mapping_type) :: mc2p - type(spatial_mapping_type) :: mc2f - type(spatial_mapping_type) :: msoil2p, msnow2p - - integer :: nl_soil_ini - real(r8) :: missing_value - - real(r8), allocatable :: soil_z(:) - - type(block_data_real8_2d) :: snow_d_grid - type(block_data_real8_3d) :: soil_t_grid - type(block_data_real8_3d) :: soil_w_grid - type(block_data_real8_2d) :: zwt_grid - - type(block_data_real8_3d) :: litr1c_grid - type(block_data_real8_3d) :: litr2c_grid - type(block_data_real8_3d) :: litr3c_grid - type(block_data_real8_3d) :: cwdc_grid - type(block_data_real8_3d) :: soil1c_grid - type(block_data_real8_3d) :: soil2c_grid - type(block_data_real8_3d) :: soil3c_grid - type(block_data_real8_3d) :: litr1n_grid - type(block_data_real8_3d) :: litr2n_grid - type(block_data_real8_3d) :: litr3n_grid - type(block_data_real8_3d) :: cwdn_grid - type(block_data_real8_3d) :: soil1n_grid - type(block_data_real8_3d) :: soil2n_grid - type(block_data_real8_3d) :: soil3n_grid - type(block_data_real8_3d) :: sminn_grid - type(block_data_real8_3d) :: smin_nh4_grid - type(block_data_real8_3d) :: smin_no3_grid - type(block_data_real8_2d) :: leafc_grid - type(block_data_real8_2d) :: leafc_storage_grid - type(block_data_real8_2d) :: frootc_grid - type(block_data_real8_2d) :: frootc_storage_grid - type(block_data_real8_2d) :: livestemc_grid - type(block_data_real8_2d) :: deadstemc_grid - type(block_data_real8_2d) :: livecrootc_grid - type(block_data_real8_2d) :: deadcrootc_grid - - real(r8), allocatable :: snow_d(:) - real(r8), allocatable :: soil_t(:,:) - real(r8), allocatable :: soil_w(:,:) - logical , allocatable :: validval(:) - - real(r8), allocatable :: litr1c_vr(:,:) - real(r8), allocatable :: litr2c_vr(:,:) - real(r8), allocatable :: litr3c_vr(:,:) - real(r8), allocatable :: cwdc_vr (:,:) - real(r8), allocatable :: soil1c_vr(:,:) - real(r8), allocatable :: soil2c_vr(:,:) - real(r8), allocatable :: soil3c_vr(:,:) - real(r8), allocatable :: litr1n_vr(:,:) - real(r8), allocatable :: litr2n_vr(:,:) - real(r8), allocatable :: litr3n_vr(:,:) - real(r8), allocatable :: cwdn_vr (:,:) - real(r8), allocatable :: soil1n_vr(:,:) - real(r8), allocatable :: soil2n_vr(:,:) - real(r8), allocatable :: soil3n_vr(:,:) - real(r8), allocatable :: min_nh4_vr(:,:) - real(r8), allocatable :: min_no3_vr(:,:) - real(r8), allocatable :: leafcin_p(:) - real(r8), allocatable :: leafc_storagein_p(:) - real(r8), allocatable :: frootcin_p(:) - real(r8), allocatable :: frootc_storagein_p(:) - real(r8), allocatable :: livestemcin_p(:) - real(r8), allocatable :: deadstemcin_p(:) - real(r8), allocatable :: livecrootcin_p(:) - real(r8), allocatable :: deadcrootcin_p(:) - ! for SOIL Water INIT by using water table depth - logical :: use_wtd - - character(len=256) :: fwtd - type(grid_type) :: gwtd - type(block_data_real8_2d) :: wtd_xy ! [m] - type(spatial_mapping_type) :: m_wtd2p - - real(r8) :: zwtmm - real(r8) :: zc_soimm(1:nl_soil) - real(r8) :: zi_soimm(0:nl_soil) - real(r8) :: vliq_r (1:nl_soil) -#ifdef Campbell_SOIL_MODEL - integer, parameter :: nprms = 1 -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - integer, parameter :: nprms = 5 -#endif - real(r8) :: prms(nprms, 1:nl_soil) - - real(r8) :: wdsrfm, depthratio - real(r8), dimension(10) :: dzlak = (/0.1, 1., 2., 3., 4., 5., 7., 7., 10.45, 10.45/) ! m -#ifdef CatchLateralFlow - integer :: ip, ie, ipxl - real(r8), allocatable :: patcharea (:) ! m^2 -#endif - - ! CoLM soil layer thickness and depths - real(r8), allocatable :: z_soisno (:,:) - real(r8), allocatable :: dz_soisno(:,:) - - real(r8) :: calday ! Julian cal day (1.xx to 365.xx) - integer :: year, jday ! Julian day and seconds - integer :: month, mday - character(len=4) :: cyear - - integer :: i,j,ipatch,nsl,hs,he,ps,pe,ivt,m, u ! indices - real(r8) :: totalvolume - - integer :: Julian_8day - integer :: ltyp - -#ifdef BGC - real(r8) f_s1s2 (1:nl_soil) - real(r8) f_s1s3 (1:nl_soil) - real(r8) rf_s1s2(1:nl_soil) - real(r8) rf_s1s3(1:nl_soil) - real(r8) f_s2s1 - real(r8) f_s2s3 - real(r8) t -#endif - - integer :: txt_id - real(r8) :: vic_b_infilt_, vic_Dsmax_, vic_Ds_, vic_Ws_, vic_c_ - - logical :: use_soiltext - ! for USDA soil texture class: - ! 0: undefined - ! 1: clay; 2: silty clay; 3: sandy clay; 4: clay loam; 5: silty clay loam; 6: sandy clay loam; & - ! 7: loam; 8: silty loam; 9: sandy loam; 10: silt; 11: loamy sand; 12: sand - - ! original VIC soil texture class in noahmp: - ! 1: SAND 2: LOAMY SAND 3: SANDY LOAM 4: SILT LOAM 5: SILT 6: LOAM 7: SANDY CLAY LOAM 8: SILTY CLAY LOAM 9: CLAY LOAM 10: SANDY CLAY 11: SILTY CLAY 12: CLAY 13: ORGANIC MATERIAL 14: WATER 15: BEDROCK 16: OTHER(land-ice) 17: PLAYA 18: LAVA 19: WHITE SAND - ! 9: CLAY LOAM 10: SANDY CLAY 11: SILTY CLAY 12: CLAY - !soil type 0 1 2 3 4 5 6 7 8 9 10 11 12 - !BVIC = 1.0 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300 - !re-arranged BVIC for USDA soil texture class: - real(r8), parameter :: BVIC_USDA(0:12) = (/ 1., 0.300, 0.280, 0.250, 0.230, 0.220, 0.200, 0.180, 0.100, 0.090, 0.150, 0.080, 0.050/) - - - -#ifdef CatchLateralFlow - CALL build_basin_network () -#endif - -#ifdef GridRiverLakeFlow - CALL build_riverlake_network () - - IF (DEF_Reservoir_Method > 0) THEN - CALL reservoir_init () - ENDIF -#endif - -! -------------------------------------------------------------------- -! Allocates memory for CoLM 1d [numpatch] variables -! -------------------------------------------------------------------- - - CALL allocate_TimeInvariants - CALL allocate_TimeVariables - -! --------------------------------------------------------------- -! 1. INITIALIZE TIME INVARIANT VARIABLES -! --------------------------------------------------------------- - - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN - patchclass = landpatch%settyp - patchmask = .true. - ENDIF - - DO ipatch = 1, numpatch - - m = patchclass(ipatch) - patchtype(ipatch) = patchtypes(m) - - ! ***** patch mask setting ***** - ! --------------------------------------- - - IF (DEF_URBAN_ONLY .and. m.ne.URBAN) THEN - patchmask(ipatch) = .false. - CYCLE - ENDIF - - ! 2m WMO virtual patch, modeling but not for aggregation -IF (DEF_Output_2mWMO) THEN - IF (landpatch%ipxstt(ipatch) == -1) THEN - patchmask(ipatch) = .false. - CYCLE - ENDIF -ENDIF - - ENDDO - -#ifndef SinglePoint - CALL landpatch%get_lonlat_radian (patchlonr, patchlatr) -#else - patchlonr(:) = SITE_lon_location * pi/180. - patchlatr(:) = SITE_lat_location * pi/180. -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) pftclass = landpft%settyp -#endif - - ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL pct_readin (dir_landdata, lc_year) -#endif - -! ------------------------------------------ -! 1.1 Ponding water -! ------------------------------------------ - IF(DEF_USE_BEDROCK)THEN - CALL dbedrock_readin (dir_landdata, lc_year) - ENDIF - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - wdsrf(:) = 0._r8 - - wetwat(:) = 0._r8 - WHERE (patchtype == 2) wetwat = 200._r8 ! for wetland - ENDIF - ENDIF -! ------------------------------------------ -! 1.2 Lake depth and layers' thickness -! ------------------------------------------ - CALL lakedepth_readin (dir_landdata, lc_year) - - IF (p_is_worker .and. (numpatch > 0)) THEN - WHERE (patchtype == 4) wdsrf = lakedepth * 1.e3 - ENDIF - -! ............................................................... -! 1.3 Read in the soil parameters of the patches of the gridcells -! ............................................................... - - CALL soil_parameters_readin (dir_landdata, lc_year) - - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - DO ipatch = 1, numpatch - DO i = 1, nl_soil - CALL get_derived_parameters_vGM ( & - psi0(i,ipatch), alpha_vgm(i,ipatch), n_vgm(i,ipatch), & - sc_vgm(i,ipatch), fc_vgm(i,ipatch)) - ENDDO - ENDDO - ENDIF - ENDIF -#endif - -#ifdef CatchLateralFlow - use_soiltext = .true. -#else - use_soiltext = (DEF_Runoff_SCHEME == 3) ! only for Simple VIC -#endif - IF (use_soiltext) THEN - CALL soiltext_readin (dir_landdata, lc_year) - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - DO ipatch = 1, numpatch - BVIC(ipatch)=BVIC_USDA(soiltext(ipatch)) - ENDDO - ENDIF - ENDIF - ENDIF - -! ............................................................... -! 1.4 Plant time-invariant variables -! ............................................................... - - ! read global tree top height from nc file - CALL HTOP_readin (dir_landdata, lc_year) -#ifdef URBAN_MODEL - CALL Urban_readin (dir_landdata, lc_year) -#endif -! ................................ -! 1.5 Initialize topography data -! ................................ -#ifdef SinglePoint - elvmean(:) = SITE_elevation - elvstd (:) = SITE_elvstd - slpratio(:) = SITE_sloperatio -#else - write(cyear,'(i4.4)') lc_year - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/elevation_patches.nc' - CALL ncio_read_vector (ftopo, 'elevation_patches', landpatch, elvmean) - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/elvstd_patches.nc' - CALL ncio_read_vector (ftopo, 'elvstd_patches', landpatch, elvstd) - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/sloperatio_patches.nc' - CALL ncio_read_vector (ftopo, 'sloperatio_patches', landpatch, slpratio) -#endif -! ...................................... -! 1.5 Initialize topography factor data -! ...................................... - IF (DEF_USE_Forcing_Downscaling) THEN -#ifdef SinglePoint - slp_type_patches(:,1) = SITE_slp_type - asp_type_patches(:,1) = SITE_asp_type - area_type_patches(:,1) = SITE_area_type - svf_patches(:) = SITE_svf - cur_patches(:) = SITE_cur - sf_lut_patches(:,:,1) = SITE_sf_lut -#else - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/slp_type_patches.nc' ! slope - CALL ncio_read_vector (lndname, 'slp_type_patches', num_slope_type, landpatch, slp_type_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/svf_patches.nc' ! sky view factor - CALL ncio_read_vector (lndname, 'svf_patches', landpatch, svf_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/asp_type_patches.nc' ! aspect - CALL ncio_read_vector (lndname, 'asp_type_patches', num_slope_type, landpatch, asp_type_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/area_type_patches.nc' ! area percent - CALL ncio_read_vector (lndname, 'area_type_patches', num_slope_type, landpatch, area_type_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/sf_curve_patches.nc' ! shadow mask - CALL ncio_read_vector (lndname, 'sf_curve_patches', num_azimuth, num_zenith_parameter, landpatch, sf_curve_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/cur_patches.nc' ! curvature - CALL ncio_read_vector (lndname, 'cur_patches', landpatch, cur_patches) -#endif - ENDIF - - IF (DEF_USE_Forcing_Downscaling_Simple) THEN - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/slp_type_patches.nc' ! slope - CALL ncio_read_vector (lndname, 'slp_type_patches', num_aspect_type, landpatch, slp_type_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/asp_type_patches.nc' ! aspect - CALL ncio_read_vector (lndname, 'asp_type_patches', num_aspect_type, landpatch, asp_type_patches) - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/cur_patches.nc' ! curvature - CALL ncio_read_vector (lndname, 'cur_patches', landpatch, cur_patches) - ENDIF - -! ................................ -! 1.6 Initialize TUNABLE constants -! ................................ - zlnd = 0.01 !Roughness length for soil [m] - zsno = 0.0024 !Roughness length for snow [m] - csoilc = 0.004 !Drag coefficient for soil under canopy [-] - dewmx = 0.1 !maximum dew - - ! 'wtfact' is updated to gridded 'fsatmax' data. (by Shupeng Zhang) - ! wtfact = 0.38 !Maximum saturated fraction (global mean; see Niu et al., 2005) - - capr = 0.34 !Tuning factor to turn first layer T into surface T - cnfac = 0.5 !Crank Nicholson factor between 0 and 1 - ssi = 0.033 !Irreducible water saturation of snow - wimp = 0.05 !Water impremeable if porosity less than wimp - pondmx = 10.0 !Ponding depth (mm) - smpmax = -1.5e5 !Wilting point potential in mm - smpmin = -1.e8 !Restriction for min of soil poten. (mm) - smpmax_hr = -2.e2 !Wilting point potential in mm - smpmin_hr = -2.e5 !Restriction for min of soil poten. (mm) - trsmx0 = 2.e-4 !Max transpiration for moist soil+100% veg. [mm/s] - tcrit = 2.5 !critical temp. to determine rain or snow - wetwatmax = 200.0 !maximum wetland water (mm) - - ! for TOPMODEL: read saturated fraction parameter data from files. - ! (see Niu et al., 2005) - IF (DEF_Runoff_SCHEME == 0) THEN - - IF (DEF_TOPMOD_method == 0) THEN - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - ! equal to 'wtfact = 0.38' and 'fff = 0.5' - fsatmax(:) = 0.38 - fsatdcf(:) = 0.125 - ENDIF - ENDIF - - ELSEIF (DEF_TOPMOD_method == 1) THEN - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/fsatmax_patches.nc' - CALL ncio_read_vector (ftopo, 'fsatmax_patches', landpatch, fsatmax) - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/fsatdcf_patches.nc' - CALL ncio_read_vector (ftopo, 'fsatdcf_patches', landpatch, fsatdcf) - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/mean_twi_patches.nc' - CALL ncio_read_vector (ftopo, 'mean_twi_patches', landpatch, topoweti) - -#ifdef RangeCheck - CALL check_vector_data ('maximum saturated fraction', fsatmax ) - CALL check_vector_data ('fsat decay factor ', fsatdcf ) - CALL check_vector_data ('topographic wetness index ', topoweti) -#endif - - ELSEIF (DEF_TOPMOD_method == 2) THEN - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/mean_twi_patches.nc' - CALL ncio_read_vector (ftopo, 'mean_twi_patches', landpatch, topoweti) - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/alp_twi_patches.nc' - CALL ncio_read_vector (ftopo, 'alp_twi_patches', landpatch, alp_twi) - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/chi_twi_patches.nc' - CALL ncio_read_vector (ftopo, 'chi_twi_patches', landpatch, chi_twi) - - ftopo = trim(dir_landdata)//'/topography/'//trim(cyear)//'/mu_twi_patches.nc' - CALL ncio_read_vector (ftopo, 'mu_twi_patches', landpatch, mu_twi) - -#ifdef RangeCheck - CALL check_vector_data ('topographic wetness index ', topoweti) - CALL check_vector_data ('twi alpha in three gamma ', alp_twi ) - CALL check_vector_data ('twi chi in three gamma ', chi_twi ) - CALL check_vector_data ('twi mu in three gamma ', mu_twi ) -#endif - - ENDIF - ENDIF - - IF (DEF_Runoff_SCHEME == 1) THEN - IF (DEF_VIC_OPT) THEN - CALL vicpara_readin () - ELSE - IF (p_is_master) THEN - txt_id = 111 - open(txt_id, file=trim(DEF_file_VIC_para), status='old', form='formatted') - READ(txt_id, *) - READ(txt_id, *) vic_b_infilt_, vic_Dsmax_, vic_Ds_, vic_Ws_, vic_c_ - close(txt_id) - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (vic_b_infilt_, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (vic_Dsmax_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (vic_Ds_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (vic_Ws_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (vic_c_ , 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) -#endif - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - vic_b_infilt = vic_b_infilt_ - vic_Dsmax = vic_Dsmax_ - vic_Ds = vic_Ds_ - vic_Ws = vic_Ws_ - vic_c = vic_c_ - ENDIF - ENDIF - ENDIF - ELSE - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - vic_b_infilt = 0 - vic_Dsmax = 0 - vic_Ds = 0 - vic_Ws = 0 - vic_c = 0 - ENDIF - ENDIF - ENDIF - -#ifdef BGC - ! bgc constant - i_met_lit = 1 - i_cel_lit = 2 - i_lig_lit = 3 - i_cwd = 4 - i_soil1 = 5 - i_soil2 = 6 - i_soil3 = 7 - i_atm = 0 - - donor_pool = (/i_met_lit, i_cel_lit, i_lig_lit, i_soil1, i_cwd , i_cwd , i_soil1, i_soil2, i_soil2, i_soil3/) - receiver_pool = (/i_soil1 , i_soil1 , i_soil2 , i_soil2, i_cel_lit, i_lig_lit, i_soil3, i_soil1, i_soil3, i_soil1/) - am = 0.02_r8 - floating_cn_ratio = (/.true., .true., .true., .true., .false. ,.false., .false./) - initial_cn_ratio = (/90._r8, 90._r8, 90._r8, 90._r8, 8._r8, 11._r8, 11._r8/) ! 1:ndecomp_pools - - f_s2s1 = 0.42_r8/(0.45_r8) - f_s2s3 = 0.03_r8/(0.45_r8) - IF (p_is_worker) THEN - IF(numpatch > 0)THEN - DO j=1,nl_soil - DO i = 1, numpatch - t = 0.85_r8 - 0.68_r8 * 0.01_r8 * (100._r8 - 50._r8) - f_s1s2 (j) = 1._r8 - .004_r8 / (1._r8 - t) - f_s1s3 (j) = .004_r8 / (1._r8 - t) - rf_s1s2(j) = t - rf_s1s3(j) = t - rf_decomp(j,:,i) = (/0.55_r8, 0.5_r8, 0.5_r8, rf_s1s2(j), 0._r8 , 0._r8 , rf_s1s3(j), 0.55_r8, 0.55_r8, 0.55_r8/) - pathfrac_decomp(j,:,i) = (/1.0_r8 ,1.0_r8 , 1.0_r8, f_s1s2(j) , 0.76_r8, 0.24_r8, f_s1s3(j) , f_s2s1 , f_s2s3 , 1._r8/) - ENDDO - ENDDO - ENDIF - ENDIF - - is_cwd = (/.false.,.false.,.false.,.true. ,.false.,.false.,.false./) - is_litter = (/.true. ,.true. ,.true. ,.false.,.false.,.false.,.false./) - is_soil = (/.false.,.false.,.false.,.false.,.true. ,.true. ,.true./) - cmb_cmplt_fact = (/0.5_r8,0.25_r8/) - - nitrif_n2o_loss_frac = 6.e-4 !fraction of N lost as N2O in nitrification (Li et al., 2000) - dnp = 0.01_r8 - bdnr = 0.5_r8 - compet_plant_no3 = 1._r8 - compet_plant_nh4 = 1._r8 - compet_decomp_no3 = 1._r8 - compet_decomp_nh4 = 1._r8 - compet_denit = 1._r8 - compet_nit = 1._r8 - surface_tension_water = 0.073 - rij_kro_a = 1.5e-10_r8 - rij_kro_alpha = 1.26_r8 - rij_kro_beta = 0.6_r8 - rij_kro_gamma = 0.6_r8 - rij_kro_delta = 0.85_r8 - IF(DEF_USE_NITRIF)THEN - nfix_timeconst = 10._r8 - ELSE - nfix_timeconst = 0._r8 - ENDIF - organic_max = 130 - d_con_g21 = 0.1759_r8 - d_con_g22 = 0.00117_r8 - d_con_w21 = 1.172_r8 - d_con_w22 = 0.03443_r8 - d_con_w23 = 0.0005048_r8 - denit_resp_coef = 0.1_r8 - denit_resp_exp = 1.3_r8 - denit_nitrate_coef = 1.15_r8 - denit_nitrate_exp = 0.57_r8 - k_nitr_max = 1.1574074e-06_r8 - Q10 = 1.5_r8 - froz_q10 = 1.5_r8 - tau_l1 = 1._r8/18.5_r8 - tau_l2_l3 = 1._r8/4.9_r8 - tau_s1 = 1._r8/7.3_r8 - tau_s2 = 1._r8/0.2_r8 - tau_s3 = 1._r8/.0045_r8 - tau_cwd = 1._r8/0.3_r8 - lwtop = 0.7_r8/31536000.0_r8 - - som_adv_flux = 0._r8 - som_diffus = 3.170979198376459e-12_r8 - cryoturb_diffusion_k = 1.585489599188229e-11_r8 - max_altdepth_cryoturbation = 2._r8 - max_depth_cryoturb = 3._r8 - - br = 2.525e-6_r8 - br_root = 2.000e-6_r8 - - fstor2tran = 0.5 - ndays_on = 30 - ndays_off = 15 - crit_dayl = 39300 - crit_onset_fdd = 15 - crit_onset_swi = 15 - crit_offset_fdd = 15 - crit_offset_swi = 15 - soilpsi_on = -0.6 - soilpsi_off = -0.8 - - ! constant for fire module - occur_hi_gdp_tree = 0.39_r8 - lfuel = 75._r8 - ufuel = 650._r8 - cropfire_a1 = 0.3_r8 - borealat = 40._r8/(4.*atan(1.)) - troplat = 23.5_r8/(4.*atan(1.)) - non_boreal_peatfire_c = 0.001_r8 - boreal_peatfire_c = 4.2e-5_r8 - rh_low = 30.0_r8 - rh_hgh = 80.0_r8 - bt_min = 0.3_r8 - bt_max = 0.7_r8 - pot_hmn_ign_counts_alpha = 0.0035_r8 - g0_fire = 0.05_r8 - - sf = 0.1_r8 - sf_no3 = 1._r8 -#endif - -! ............................................... -! 1.6 Write out as a restart file [histTimeConst] -! ............................................... - -#ifdef RangeCheck - CALL check_TimeInvariants () -#endif - - CALL WRITE_TimeInvariants (lc_year, casename, dir_restart) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_master) write (6,*) ('Successfully Initialize the Land Time-Invariants') - -! ---------------------------------------------------------------------- -! [2] INITIALIZE TIME-VARYING VARIABLES -! as subgrid vectors of length [numpatch] -! initial run: create the time-varying variables based on : -! i) observation (NOT CODING CURRENTLY), or -! ii) some already-known information (NO CODING CURRENTLY), or -! iii) arbitrarily -! continuation run: time-varying data read in from restart file -! ---------------------------------------------------------------------- - -! 2.1 current time of model run -! ............................ - - CALL initimetype(greenwich) - - IF (p_is_master) THEN - IF(.not. greenwich)THEN - write(*,*) char(27)//"[1;31m"//"Notice: greenwich false, local time is used."//char(27)//"[0m" - ENDIF - ENDIF - - -! ................................ -! 2.2 cosine of solar zenith angle -! ................................ - calday = calendarday(idate) - IF (p_is_worker) THEN - DO i = 1, numpatch - coszen(i) = orb_coszen(calday, patchlonr(i), patchlatr(i)) - ENDDO - ENDIF - -! ........................................... -!2.3 READ in or GUSSES land state information -! ........................................... - - ! for SOIL INIT of water, temperature - IF (DEF_USE_SoilInit) THEN - - fsoildat = DEF_file_SoilInit - - IF (p_is_master) THEN - inquire (file=trim(fsoildat), exist=use_soilini) - IF (use_soilini) THEN - write(*,'(/,2A)') 'Use soil water content, soil temperature and water table depth ' & - // 'to initialize soil state from file ', trim(fsoildat) - ELSE - write(*,*) 'No initial data for soil state from ', trim(fsoildat) - ENDIF - ENDIF -#ifdef USEMPI - CALL mpi_bcast (use_soilini, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) -#endif - - IF (use_soilini) THEN - - ! soil layer depth (m) - CALL ncio_read_bcast_serial (fsoildat, 'soildepth', soil_z) - - nl_soil_ini = size(soil_z) - - CALL gsoil%define_from_file (fsoildat, latname = 'lat', lonname = 'lon') - - CALL julian2monthday (idate(1), idate(2), month, mday) - - IF (p_is_master) THEN - CALL ncio_get_attr (fsoildat, 'zwt', 'missing_value', missing_value) - ENDIF -#ifdef USEMPI - CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) -#endif - - IF (p_is_io) THEN - ! soil layer temperature (K) - CALL allocate_block_data (gsoil, soil_t_grid, nl_soil_ini) - CALL ncio_read_block_time (fsoildat, 'soiltemp', & - gsoil, nl_soil_ini, month, soil_t_grid) - ! soil layer wetness (-) - CALL allocate_block_data (gsoil, soil_w_grid, nl_soil_ini) - CALL ncio_read_block_time (fsoildat, 'soilwat', & - gsoil, nl_soil_ini, month, soil_w_grid) - ! water table depth (m) - CALL allocate_block_data (gsoil, zwt_grid) - CALL ncio_read_block_time (fsoildat, 'zwt', gsoil, month, zwt_grid) - ENDIF - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (soil_t (nl_soil_ini,numpatch)) - allocate (soil_w (nl_soil_ini,numpatch)) - allocate (validval (numpatch)) - ENDIF - ENDIF - - CALL msoil2p%build_arealweighted (gsoil, landpatch) - CALL msoil2p%set_missing_value (zwt_grid, missing_value, validval) - - CALL msoil2p%grid2pset (soil_t_grid, nl_soil_ini, soil_t) - CALL msoil2p%grid2pset (soil_w_grid, nl_soil_ini, soil_w) - CALL msoil2p%grid2pset (zwt_grid, zwt) - - IF (p_is_worker) THEN - DO i = 1, numpatch - IF (.not. validval(i)) THEN - IF (patchtype(i) == 3) THEN - soil_t(:,i) = 250. - ELSE - soil_t(:,i) = 280. - ENDIF - - soil_w(:,i) = 1. - zwt(i) = 0. - - ENDIF - ENDDO - ENDIF - - IF (allocated(validval)) deallocate(validval) - - ENDIF - - ELSE - use_soilini = .false. - ENDIF - - IF (.not. use_soilini) THEN - !! not used, just for filling arguments - IF (p_is_worker) THEN - allocate (soil_z (nl_soil)) - allocate (soil_t (nl_soil,numpatch)) - allocate (soil_w (nl_soil,numpatch)) - ENDIF - ENDIF - -#ifdef BGC - IF (DEF_USE_CN_INIT) THEN - fcndat = DEF_file_cn_init - IF (p_is_master) THEN - inquire (file=trim(fcndat), exist=use_cnini) - IF (use_cnini) THEN - write(*,'(/, 2A)') 'Use carbon & nitrogen and derived equilibrium state ' & - // ' to initialize soil & vegetation biogeochemistry: ', trim(fcndat) - ELSE - write(*,*) 'no initial data for biogeochemistry: ',trim(fcndat) - ENDIF - ENDIF -#ifdef USEMPI - CALL mpi_bcast (use_cnini, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) -#endif - - IF (use_cnini) THEN - - CALL gcn%define_from_file (fcndat,"lat","lon") - CALL mc2p%build_arealweighted (gcn, landpatch) - CALL mc2f%build_arealweighted (gcn, landpft) - - IF (p_is_io) THEN - ! soil layer litter & carbon (gC m-3) - CALL allocate_block_data (gcn, litr1c_grid, nl_soil) - CALL ncio_read_block (fcndat, 'litr1c_vr', gcn, nl_soil, litr1c_grid) - - CALL allocate_block_data (gcn, litr2c_grid, nl_soil) - CALL ncio_read_block (fcndat, 'litr2c_vr', gcn, nl_soil, litr2c_grid) - - CALL allocate_block_data (gcn, litr3c_grid, nl_soil) - CALL ncio_read_block (fcndat, 'litr3c_vr', gcn, nl_soil, litr3c_grid) - - CALL allocate_block_data (gcn, cwdc_grid, nl_soil) - CALL ncio_read_block (fcndat, 'cwdc_vr', gcn, nl_soil , cwdc_grid) - - CALL allocate_block_data (gcn, soil1c_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil1c_vr', gcn, nl_soil, soil1c_grid) - - CALL allocate_block_data (gcn, soil2c_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil2c_vr', gcn, nl_soil, soil2c_grid) - - CALL allocate_block_data (gcn, soil3c_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil3c_vr', gcn, nl_soil, soil3c_grid) - - ! soil layer litter & nitrogen (gN m-3) - CALL allocate_block_data (gcn, litr1n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'litr1n_vr', gcn, nl_soil, litr1n_grid) - - CALL allocate_block_data (gcn, litr2n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'litr2n_vr', gcn, nl_soil, litr2n_grid) - - CALL allocate_block_data (gcn, litr3n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'litr3n_vr', gcn, nl_soil, litr3n_grid) - - CALL allocate_block_data (gcn, cwdn_grid, nl_soil) - CALL ncio_read_block (fcndat, 'cwdn_vr', gcn, nl_soil , cwdn_grid) - - CALL allocate_block_data (gcn, soil1n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil1n_vr', gcn, nl_soil, soil1n_grid) - - CALL allocate_block_data (gcn, soil2n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil2n_vr', gcn, nl_soil, soil2n_grid) - - CALL allocate_block_data (gcn, soil3n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil3n_vr', gcn, nl_soil, soil3n_grid) - - CALL allocate_block_data (gcn, soil3n_grid, nl_soil) - CALL ncio_read_block (fcndat, 'soil3n_vr', gcn, nl_soil, soil3n_grid) - - CALL allocate_block_data (gcn, smin_nh4_grid, nl_soil) - CALL ncio_read_block (fcndat, 'smin_nh4_vr', gcn, nl_soil, smin_nh4_grid) - - CALL allocate_block_data (gcn, smin_no3_grid, nl_soil) - CALL ncio_read_block (fcndat, 'smin_no3_vr', gcn, nl_soil, smin_no3_grid) - - CALL allocate_block_data (gcn, leafc_grid) - CALL ncio_read_block (fcndat, 'leafc', gcn, leafc_grid) - - CALL allocate_block_data (gcn, leafc_storage_grid) - CALL ncio_read_block (fcndat, 'leafc_storage', gcn, leafc_storage_grid) - - CALL allocate_block_data (gcn, frootc_grid) - CALL ncio_read_block (fcndat, 'frootc', gcn, frootc_grid) - - CALL allocate_block_data (gcn, frootc_storage_grid) - CALL ncio_read_block (fcndat, 'frootc_storage', gcn, frootc_storage_grid) - - CALL allocate_block_data (gcn, livestemc_grid) - CALL ncio_read_block (fcndat, 'livestemc', gcn, livestemc_grid) - - CALL allocate_block_data (gcn, deadstemc_grid) - CALL ncio_read_block (fcndat, 'deadstemc', gcn, deadstemc_grid) - - CALL allocate_block_data (gcn, livecrootc_grid) - CALL ncio_read_block (fcndat, 'livecrootc', gcn, livecrootc_grid) - - CALL allocate_block_data (gcn, deadcrootc_grid) - CALL ncio_read_block (fcndat, 'deadcrootc', gcn, deadcrootc_grid) - - ENDIF - - IF (p_is_worker) THEN - - allocate (litr1c_vr (nl_soil,numpatch)) - allocate (litr2c_vr (nl_soil,numpatch)) - allocate (litr3c_vr (nl_soil,numpatch)) - allocate (cwdc_vr (nl_soil,numpatch)) - allocate (soil1c_vr (nl_soil,numpatch)) - allocate (soil2c_vr (nl_soil,numpatch)) - allocate (soil3c_vr (nl_soil,numpatch)) - allocate (litr1n_vr (nl_soil,numpatch)) - allocate (litr2n_vr (nl_soil,numpatch)) - allocate (litr3n_vr (nl_soil,numpatch)) - allocate (cwdn_vr (nl_soil,numpatch)) - allocate (soil1n_vr (nl_soil,numpatch)) - allocate (soil2n_vr (nl_soil,numpatch)) - allocate (soil3n_vr (nl_soil,numpatch)) - allocate (min_nh4_vr(nl_soil,numpatch)) - allocate (min_no3_vr(nl_soil,numpatch)) - allocate (leafcin_p (numpft)) - allocate (leafc_storagein_p (numpft)) - allocate (frootcin_p (numpft)) - allocate (frootc_storagein_p (numpft)) - allocate (livestemcin_p (numpft)) - allocate (deadstemcin_p (numpft)) - allocate (livecrootcin_p (numpft)) - allocate (deadcrootcin_p (numpft)) - - ENDIF - - CALL mc2p%grid2pset (litr1c_grid, nl_soil, litr1c_vr) - CALL mc2p%grid2pset (litr2c_grid, nl_soil, litr2c_vr) - CALL mc2p%grid2pset (litr3c_grid, nl_soil, litr3c_vr) - CALL mc2p%grid2pset (cwdc_grid , nl_soil, cwdc_vr ) - CALL mc2p%grid2pset (soil1c_grid, nl_soil, soil1c_vr) - CALL mc2p%grid2pset (soil2c_grid, nl_soil, soil2c_vr) - CALL mc2p%grid2pset (soil3c_grid, nl_soil, soil3c_vr) - CALL mc2p%grid2pset (litr1n_grid, nl_soil, litr1n_vr) - CALL mc2p%grid2pset (litr2n_grid, nl_soil, litr2n_vr) - CALL mc2p%grid2pset (litr3n_grid, nl_soil, litr3n_vr) - CALL mc2p%grid2pset (cwdn_grid , nl_soil, cwdn_vr ) - CALL mc2p%grid2pset (soil1n_grid, nl_soil, soil1n_vr) - CALL mc2p%grid2pset (soil2n_grid, nl_soil, soil2n_vr) - CALL mc2p%grid2pset (soil3n_grid, nl_soil, soil3n_vr) - CALL mc2p%grid2pset (smin_nh4_grid , nl_soil, min_nh4_vr ) - CALL mc2p%grid2pset (smin_no3_grid , nl_soil, min_no3_vr ) - CALL mc2f%grid2pset (leafc_grid, leafcin_p ) - CALL mc2f%grid2pset (leafc_storage_grid, leafc_storagein_p ) - CALL mc2f%grid2pset (frootc_grid, frootcin_p ) - CALL mc2f%grid2pset (frootc_storage_grid, frootc_storagein_p ) - CALL mc2f%grid2pset (livestemc_grid, livestemcin_p ) - CALL mc2f%grid2pset (deadstemc_grid, deadstemcin_p ) - CALL mc2f%grid2pset (livecrootc_grid, livecrootcin_p ) - CALL mc2f%grid2pset (deadcrootc_grid, deadcrootcin_p ) - - IF (p_is_worker) THEN - DO i = 1, numpatch - IF (patchtype(i) == 0)THEN - ps = patch_pft_s(i) - pe = patch_pft_e(i) - DO nsl = 1, nl_soil - decomp_cpools_vr(nsl, i_met_lit, i) = litr1c_vr(nsl, i) - decomp_cpools_vr(nsl, i_cel_lit, i) = litr2c_vr(nsl, i) - decomp_cpools_vr(nsl, i_lig_lit, i) = litr3c_vr(nsl, i) - decomp_cpools_vr(nsl, i_cwd , i) = cwdc_vr (nsl, i) - decomp_cpools_vr(nsl, i_soil1 , i) = soil1c_vr(nsl, i) - decomp_cpools_vr(nsl, i_soil2 , i) = soil2c_vr(nsl, i) - decomp_cpools_vr(nsl, i_soil3 , i) = soil3c_vr(nsl, i) - decomp_npools_vr(nsl, i_met_lit, i) = litr1n_vr(nsl, i) - decomp_npools_vr(nsl, i_cel_lit, i) = litr2n_vr(nsl, i) - decomp_npools_vr(nsl, i_lig_lit, i) = litr3n_vr(nsl, i) - decomp_npools_vr(nsl, i_cwd , i) = cwdn_vr (nsl, i) - decomp_npools_vr(nsl, i_soil1 , i) = soil1n_vr(nsl, i) - decomp_npools_vr(nsl, i_soil2 , i) = soil2n_vr(nsl, i) - decomp_npools_vr(nsl, i_soil3 , i) = soil3n_vr(nsl, i) - smin_nh4_vr (nsl, i) = min_nh4_vr(nsl,i) - smin_no3_vr (nsl, i) = min_no3_vr(nsl,i) - sminn_vr (nsl, i) = min_nh4_vr(nsl,i)+min_no3_vr(nsl,i) - ENDDO - ENDIF - IF (patchtype(i) == 0)THEN - DO m = ps, pe - ivt = pftclass(m) - IF(isevg(ivt))THEN - leafc_p (m) = amin1(leafcin_p(m),300._r8) - frootc_p (m) = frootcin_p(m) - ELSE - leafc_p (m) = amin1(leafcin_p(m),300._r8) - leafc_storage_p (m) = amin1(leafc_storagein_p(m),600._r8) - frootc_p (m) = frootcin_p(m) - frootc_storage_p (m) = frootc_storagein_p(m) - ENDIF - IF(woody(ivt).eq. 1)THEN - deadstemc_p (m) = deadstemcin_p(m) - livestemc_p (m) = livestemcin_p(m) - deadcrootc_p (m) = deadcrootcin_p(m) - livecrootc_p (m) = livecrootcin_p(m) - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - - ENDIF - - ELSE - use_cnini = .false. - ENDIF -#endif - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (snow_d (numpatch)) - ENDIF - ENDIF - - IF (DEF_USE_SnowInit) THEN - - fsnowdat = DEF_file_SnowInit - IF (p_is_master) THEN - inquire (file=trim(fsnowdat), exist=use_snowini) - ENDIF -#ifdef USEMPI - CALL mpi_bcast (use_snowini, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) -#endif - - IF (use_snowini) THEN - - CALL gsnow%define_from_file (fsnowdat, latname = 'lat', lonname = 'lon') - - CALL julian2monthday (idate(1), idate(2), month, mday) - - IF (p_is_master) THEN - CALL ncio_get_attr (fsnowdat, 'snowdepth', 'missing_value', missing_value) - ENDIF -#ifdef USEMPI - CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) -#endif - - IF (p_is_io) THEN - ! snow depth (m) - CALL allocate_block_data (gsnow, snow_d_grid) - CALL ncio_read_block_time (fsnowdat, 'snowdepth', gsnow, month, snow_d_grid) - ENDIF - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (validval (numpatch)) - ENDIF - ENDIF - - CALL msnow2p%build_arealweighted (gsnow, landpatch) - CALL msnow2p%set_missing_value (snow_d_grid, missing_value, validval) - - CALL msnow2p%grid2pset (snow_d_grid, snow_d) - - IF (p_is_worker) THEN - WHERE (.not. validval) - snow_d = 0. - END WHERE - ENDIF - - IF (allocated(validval)) deallocate(validval) - - ENDIF - - ELSE - use_snowini = .false. - ENDIF - - - ! for SOIL Water INIT by using water table depth - use_wtd = (.not. use_soilini) .and. DEF_USE_WaterTableInit - - IF (use_wtd) THEN - - fwtd = DEF_file_WaterTable - - IF (p_is_master) THEN - inquire (file=trim(fwtd), exist=use_wtd) - IF (use_wtd) THEN - write(*,'(/, 2A)') 'Use water table depth and derived equilibrium state ' & - // ' to initialize soil water content from file ', trim(fwtd) - ELSE - write(*,*) 'No initial data for water table depth from ', trim(fwtd) - ENDIF - ENDIF -#ifdef USEMPI - CALL mpi_bcast (use_wtd, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) -#endif - ENDIF - - IF (use_wtd) THEN - - CALL julian2monthday (idate(1), idate(2), month, mday) - CALL gwtd%define_from_file (fwtd) - - IF (p_is_io) THEN - CALL allocate_block_data (gwtd, wtd_xy) - CALL ncio_read_block_time (fwtd, 'wtd', gwtd, month, wtd_xy) - ENDIF - - CALL m_wtd2p%build_arealweighted (gwtd, landpatch) - CALL m_wtd2p%grid2pset (wtd_xy, zwt) - - ENDIF - -! ................... -! 2.4 LEAF area index -! ................... -#if (defined DYN_PHENOLOGY) - ! CREATE fraction of vegetation cover, greenness, leaf area index, stem index - IF (p_is_worker) THEN - - DO i = 1, numpatch - IF (use_soilini) THEN - DO nsl = 1, nl_soil - CALL polint(soil_z,soil_t(:,i),nl_soil_ini,z_soi(nsl),t_soisno(nsl,i)) - ENDDO - ELSE - t_soisno(1:,i) = 283. - ENDIF - ENDDO - - tlai(:)=0.0; tsai(:)=0.0; green(:)=0.0; fveg(:)=0.0 - DO i = 1, numpatch - ! Call Ecological Model() - ltyp = patchtype(i) - IF(ltyp > 0) THEN - CALL lai_empirical(ltyp, nl_soil,rootfr(1:,i), t_soisno(1:,i),tlai(i),tsai(i),fveg(i),green(i)) - ENDIF - ENDDO - - ENDIF -#else - - year = idate(1) - jday = idate(2) - - IF (DEF_LAI_MONTHLY) THEN - CALL julian2monthday (year, jday, month, mday) - IF (DEF_LAI_CHANGE_YEARLY) THEN - ! 08/03/2019, yuan: read global LAI/SAI data - CALL LAI_readin (year, month, dir_landdata) -#ifdef URBAN_MODEL - CALL UrbanLAI_readin (year, month, dir_landdata) -#endif - ELSE - CALL LAI_readin (lc_year, month, dir_landdata) -#ifdef URBAN_MODEL - CALL UrbanLAI_readin (lc_year, month, dir_landdata) -#endif - ENDIF - ELSE - Julian_8day = int(calendarday(idate)-1)/8*8 + 1 - CALL LAI_readin (year, Julian_8day, dir_landdata) - ENDIF -#ifdef RangeCheck - CALL check_vector_data ('LAI ', tlai) - CALL check_vector_data ('SAI ', tsai) -#endif - -#ifdef CROP - CALL CROP_readin () - IF (p_is_worker) THEN - DO i = 1, numpatch - IF(patchtype(i) .eq. 0)THEN - ps = patch_pft_s(i) - pe = patch_pft_e(i) - DO m = ps, pe - ivt = pftclass(m) - IF(ivt >= npcropmin)THEN - leafc_p (m) = 0._r8 - frootc_p(m) = 0._r8 - tlai (i) = 0._r8 - tsai (i) = 0._r8 - tlai_p (m) = 0._r8 - tsai_p (m) = 0._r8 - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - IF (p_is_worker) THEN - IF(DEF_USE_IRRIGATION)THEN - sum_irrig(:) = 0._r8 - sum_deficit_irrig(:) = 0._r8 - sum_irrig_count(:) = 0._r8 - waterstorage(:) = 0._r8 - DO i = 1, numpatch - zwt_stand(i) = zwt(i) + 1._r8 - zwt_stand(i) = max(0., zwt_stand(i)) - zwt_stand(i) = min(80., zwt_stand(i)) - ENDDO - ENDIF - ENDIF -#endif -#endif - -! .............................................................................. -! 2.5 initialize time-varying variables, as subgrid vectors of length [numpatch] -! .............................................................................. - ! ------------------------------------------ - ! PLEASE - ! PLEASE UPDATE - ! PLEASE UPDATE when have the observed lake status - IF (p_is_worker) THEN - - t_lake (:,:) = 285. - lake_icefrac(:,:) = 0. - savedtke1 (:) = tkwat -#ifdef EXTERNAL_LAKE - DO i = 1, numpatch - IF(patchtype(i) == 4) THEN - CALL InitLakeTimeVars(i, lakedepth(i), t_lake(:,i), lake_icefrac(:,i), savedtke1(i)) - ENDIF - ENDDO -#endif - ENDIF - ! ------------------------------------------ - - IF (p_is_worker) THEN - - !TODO: can be removed as CLMDRIVER.F90 yuan@ - allocate ( z_soisno (maxsnl+1:nl_soil,numpatch) ); z_soisno (:,:) = spval - allocate ( dz_soisno(maxsnl+1:nl_soil,numpatch) ); dz_soisno(:,:) = spval - - DO i = 1, numpatch - z_soisno (1:nl_soil ,i) = z_soi (1:nl_soil) - dz_soisno(1:nl_soil ,i) = dz_soi(1:nl_soil) - ENDDO - - zc_soimm = z_soi * 1000. - zi_soimm(0) = 0. - zi_soimm(1:nl_soil) = zi_soi * 1000. - - DO i = 1, numpatch - m = patchclass(i) - - IF (use_wtd) THEN - zwtmm = zwt(i) * 1000. - ENDIF - -#ifdef Campbell_SOIL_MODEL - vliq_r(:) = 0. - prms(1,1:nl_soil) = bsw(1:nl_soil,i) -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - vliq_r(:) = theta_r(1:nl_soil,i) - prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,i) - prms(2,1:nl_soil) = n_vgm (1:nl_soil,i) - prms(3,1:nl_soil) = L_vgm (1:nl_soil,i) - prms(4,1:nl_soil) = sc_vgm (1:nl_soil,i) - prms(5,1:nl_soil) = fc_vgm (1:nl_soil,i) -#endif -#ifdef HYPERSPECTRAL - CALL flux_frac_init ( ) - CALL leaf_property_init ( rho_p, tau_p ) - CALL get_water_optical_properties( ) - CALL readin_urban_albedo ( ) -#endif - CALL iniTimeVar(i, patchtype(i)& - ,porsl(1:,i),psi0(1:,i),hksati(1:,i)& - ,soil_s_v_alb(i),soil_d_v_alb(i),soil_s_n_alb(i),soil_d_n_alb(i)& - ,z0m(i),zlnd,htop(i),z0mr(m),chil(m),rho(1:,1:,m),tau(1:,1:,m)& - ,z_soisno(maxsnl+1:,i),dz_soisno(maxsnl+1:,i)& - ,t_soisno(maxsnl+1:,i),wliq_soisno(maxsnl+1:,i),wice_soisno(maxsnl+1:,i)& - ,smp(1:,i),hk(1:,i),zwt(i),wa(i)& -!Plant hydraulic variables - ,vegwp(1:,i),gs0sun(i),gs0sha(i)& -!END plant hydraulic variables - ,t_grnd(i),tleaf(i),ldew(i),ldew_rain(i),ldew_snow(i),fwet_snow(i),sag(i),scv(i)& - ,snowdp(i),fveg(i),fsno(i),sigf(i),green(i),lai(i),sai(i),lai_old(i),coszen(i)& - ,snw_rds(:,i),mss_bcpho(:,i),mss_bcphi(:,i),mss_ocpho(:,i),mss_ocphi(:,i)& - ,mss_dst1(:,i),mss_dst2(:,i),mss_dst3(:,i),mss_dst4(:,i)& - ,alb(1:,1:,i),ssun(1:,1:,i),ssha(1:,1:,i)& - ,ssoi(1:,1:,i),ssno(1:,1:,i),ssno_lyr(1:,1:,:,i)& -#ifdef HYPERSPECTRAL - ,alb_hires(1:,1:,i)& -#endif - ,thermk(i),extkb(i),extkd(i)& - ,trad(i),tref(i),qref(i),rst(i),emis(i),zol(i),rib(i)& - ,ustar(i),qstar(i),tstar(i),fm(i),fh(i),fq(i)& -#ifdef HYPERSPECTRAL - ! New added: hyperspectral scheme - ,clr_frac, cld_frac & - ,reflectance(0:,1:,1:), transmittance(0:,1:,1:), soil_alb(1:,i), kw(1:), nw(1:)& - ,reflectance_out(:,:,i), transmittance_out(:,:,i)& - ,patchlatr(i), patchlonr(i)& - ,urban_albedo, mean_albedo, lat_north, lat_south, lon_east, lon_west& -#endif -!Ozone Vairables - ,o3coefv_sun(i),o3coefv_sha(i),o3coefg_sun(i),o3coefg_sha(i)& -#ifdef BGC - ,use_cnini, totlitc(i), totsomc(i), totcwdc(i), decomp_cpools(:,i), decomp_cpools_vr(:,:,i) & - ,ctrunc_veg(i), ctrunc_soil(i), ctrunc_vr(:,i) & - ,totlitn(i), totsomn(i), totcwdn(i), decomp_npools(:,i), decomp_npools_vr(:,:,i) & - ,ntrunc_veg(i), ntrunc_soil(i), ntrunc_vr(:,i) & - ,totvegc(i), totvegn(i), totcolc(i), totcoln(i), col_endcb(i), col_begcb(i), col_endnb(i), col_begnb(i) & - ,col_vegendcb(i), col_vegbegcb(i), col_soilendcb(i), col_soilbegcb(i) & - ,col_vegendnb(i), col_vegbegnb(i), col_soilendnb(i), col_soilbegnb(i) & - ,col_sminnendnb(i), col_sminnbegnb(i) & - ,altmax(i) , altmax_lastyear(i), altmax_lastyear_indx(i), lag_npp(i) & - ,sminn_vr(:,i), sminn(i), smin_no3_vr (:,i), smin_nh4_vr (:,i)& - ,prec10(i), prec60(i), prec365 (i), prec_today(i), prec_daily(:,i), tsoi17(i), rh30(i), accumnstep(i) , skip_balance_check(i) & -!------------------------SASU variables----------------------- ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & - ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & - ,I_met_c_vr_acc (:,i), I_cel_c_vr_acc (:,i), I_lig_c_vr_acc (:,i), I_cwd_c_vr_acc (:,i) & - ,AKX_met_to_soil1_c_vr_acc (:,i), AKX_cel_to_soil1_c_vr_acc (:,i), AKX_lig_to_soil2_c_vr_acc (:,i), AKX_soil1_to_soil2_c_vr_acc(:,i) & - ,AKX_cwd_to_cel_c_vr_acc (:,i), AKX_cwd_to_lig_c_vr_acc (:,i), AKX_soil1_to_soil3_c_vr_acc(:,i), AKX_soil2_to_soil1_c_vr_acc(:,i) & - ,AKX_soil2_to_soil3_c_vr_acc(:,i), AKX_soil3_to_soil1_c_vr_acc(:,i) & - ,AKX_met_exit_c_vr_acc (:,i), AKX_cel_exit_c_vr_acc (:,i), AKX_lig_exit_c_vr_acc (:,i), AKX_cwd_exit_c_vr_acc (:,i) & - ,AKX_soil1_exit_c_vr_acc (:,i), AKX_soil2_exit_c_vr_acc (:,i), AKX_soil3_exit_c_vr_acc (:,i) & - ,diagVX_c_vr_acc (:,:,i), upperVX_c_vr_acc (:,:,i), lowerVX_c_vr_acc (:,:,i) & - ,I_met_n_vr_acc (:,i), I_cel_n_vr_acc (:,i), I_lig_n_vr_acc (:,i), I_cwd_n_vr_acc (:,i) & - ,AKX_met_to_soil1_n_vr_acc (:,i), AKX_cel_to_soil1_n_vr_acc (:,i), AKX_lig_to_soil2_n_vr_acc (:,i), AKX_soil1_to_soil2_n_vr_acc(:,i) & - ,AKX_cwd_to_cel_n_vr_acc (:,i), AKX_cwd_to_lig_n_vr_acc (:,i), AKX_soil1_to_soil3_n_vr_acc(:,i), AKX_soil2_to_soil1_n_vr_acc(:,i) & - ,AKX_soil2_to_soil3_n_vr_acc(:,i), AKX_soil3_to_soil1_n_vr_acc(:,i) & - ,AKX_met_exit_n_vr_acc (:,i), AKX_cel_exit_n_vr_acc (:,i), AKX_lig_exit_n_vr_acc (:,i), AKX_cwd_exit_n_vr_acc (:,i) & - ,AKX_soil1_exit_n_vr_acc (:,i), AKX_soil2_exit_n_vr_acc (:,i), AKX_soil3_exit_n_vr_acc (:,i) & - ,diagVX_n_vr_acc (:,:,i), upperVX_n_vr_acc (:,:,i), lowerVX_n_vr_acc (:,:,i) & - !------------------------------------------------------------ -#endif - ! for SOIL INIT of water, temperature, snow depth - ,use_soilini, nl_soil_ini, soil_z, soil_t(1:,i), soil_w(1:,i), use_snowini, snow_d(i) & - ! for SOIL Water INIT by using water table depth - ,use_wtd, zwtmm, zc_soimm, zi_soimm, vliq_r, nprms, prms) - -#ifdef EXTERNAL_LAKE - IF(patchtype(i) == 4) THEN - z0m(i) = DEF_External_Lake%DEF_LAKE_Z0M - ENDIF -#endif - -#ifdef URBAN_MODEL - IF (m == URBAN) THEN - - u = patch2urban(i) - lwsun (u) = 0. !net longwave radiation of sunlit wall - lwsha (u) = 0. !net longwave radiation of shaded wall - lgimp (u) = 0. !net longwave radiation of impervious road - lgper (u) = 0. !net longwave radiation of pervious road - lveg (u) = 0. !net longwave radiation of vegetation [W/m2] - - t_roofsno (:,u) = 283. !temperatures of roof layers - t_wallsun (:,u) = 283. !temperatures of sunlit wall layers - t_wallsha (:,u) = 283. !temperatures of shaded wall layers - t_gimpsno (:,u) = 283. !temperatures of impervious road layers - t_gpersno (:,u) = 283. !soil temperature [K] - t_lakesno (:,u) = 283. !lake soil temperature [K] - - wice_roofsno(:,u) = 0. !ice lens [kg/m2] - wice_gimpsno(:,u) = 0. !ice lens [kg/m2] - wice_gpersno(:,u) = 0. !ice lens [kg/m2] - wice_lakesno(:,u) = 0. !ice lens [kg/m2] - wliq_roofsno(:,u) = 0. !liquid water [kg/m2] - wliq_gimpsno(:,u) = 0. !liquid water [kg/m2] - wliq_gpersno(:,u) = wliq_soisno(:,i) !liquid water [kg/m2] - wliq_lakesno(:,u) = wliq_soisno(:,i) !liquid water [kg/m2] - - wliq_soisno(: ,i) = 0. - wliq_soisno(:1,i) = wliq_roofsno(:1,u)*froof(u) - wliq_soisno(: ,i) = wliq_soisno(: ,i) + wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) - wliq_soisno(:1,i) = wliq_soisno(:1,i) + wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) - - snowdp_roof (u) = 0. !snow depth [m] - snowdp_gimp (u) = 0. !snow depth [m] - snowdp_gper (u) = 0. !snow depth [m] - snowdp_lake (u) = 0. !snow depth [m] - - z_sno_roof (:,u) = 0. !node depth of roof [m] - z_sno_gimp (:,u) = 0. !node depth of impervious [m] - z_sno_gper (:,u) = 0. !node depth pervious [m] - z_sno_lake (:,u) = 0. !node depth lake [m] - - dz_sno_roof (:,u) = 0. !interface depth of roof [m] - dz_sno_gimp (:,u) = 0. !interface depth of impervious [m] - dz_sno_gper (:,u) = 0. !interface depth pervious [m] - dz_sno_lake (:,u) = 0. !interface depth lake [m] - - t_room (u) = 283. !temperature of inner building [K] - troof_inner (u) = 283. !temperature of inner roof [K] - twsun_inner (u) = 283. !temperature of inner sunlit wall [K] - twsha_inner (u) = 283. !temperature of inner shaded wall [K] - Fhac (u) = 0. !sensible flux from heat or cool AC [W/m2] - Fwst (u) = 0. !waste heat flux from heat or cool AC [W/m2] - Fach (u) = 0. !flux from inner and outer air exchange [W/m2] - meta (u) = 0. !flux from metabolic [W/m2] - vehc (u) = 0. !flux from vehicle [W/m2] - - CALL UrbanIniTimeVar(i,froof(u),fgper(u),flake(u),hlr(u),hroof(u),& - alb_roof(:,:,u),alb_wall(:,:,u),alb_gimp(:,:,u),alb_gper(:,:,u),& - rho(:,:,m),tau(:,:,m),fveg(i),htop(i),hbot(i),lai(i),sai(i),coszen(i),& - fsno_roof(u),fsno_gimp(u),fsno_gper(u),fsno_lake(u),& - scv_roof(u),scv_gimp(u),scv_gper(u),scv_lake(u),fwet_snow(u),& - sag_roof(u),sag_gimp(u),sag_gper(u),sag_lake(u),t_lake(1,i),& - fwsun(u),dfwsun(u),extkd(i),alb(:,:,i),ssun(:,:,i),ssha(:,:,i),sroof(:,:,u),& - swsun(:,:,u),swsha(:,:,u),sgimp(:,:,u),sgper(:,:,u),slake(:,:,u)) - - ENDIF -#endif - ENDDO - - DO i = 1, numpatch - z_sno (maxsnl+1:0,i) = z_soisno (maxsnl+1:0,i) - dz_sno(maxsnl+1:0,i) = dz_soisno(maxsnl+1:0,i) - ENDDO - - ENDIF - ! ------------------------------------------ - - ! ----- -#ifdef CatchLateralFlow - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (patcharea (numpatch)) - patcharea(:) = 0. - DO ip = 1, numpatch - ie = landpatch%ielm(ip) - DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) - patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) - ENDDO - ENDDO - ENDIF - ENDIF - - CALL element_neighbour_init (patcharea,lc_year) - CALL river_lake_network_init (patcharea) - - IF (p_is_worker) THEN - - ! set variables "veloc_bsnhru", "wdsrf_bsnhru_prev" - DO i = 1, numbasin - hs = basin_hru%substt(i) - he = basin_hru%subend(i) - - wdsrf_bsnhru(hs:he) = 0. - IF (lake_id(i) == 0) THEN - wdsrf_bsnhru(hs) = riverdpth(i) - ELSEIF (lake_id(i) > 0) THEN - wdsrf_bsnhru(hs:he) = lakeinfo(i)%depth0 - ENDIF - - veloc_bsnhru(hs:he) = 0. - wdsrf_bsnhru_prev(hs:he) = wdsrf_bsnhru(hs:he) - ENDDO - - ! set variables "veloc_riv", "wdsrf_bsn_prev" - DO i = 1, numbasin - hs = basin_hru%substt(i) - he = basin_hru%subend(i) - IF (lake_id(i) <= 0) THEN - wdsrf_bsn(i) = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he)) - handmin(i) - ELSE - ! lake - totalvolume = sum(wdsrf_bsnhru(hs:he) * lakeinfo(i)%area0) - wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume) - ENDIF - veloc_riv(i) = 0 - wdsrf_bsn_prev(i) = wdsrf_bsn(i) - ENDDO - - CALL worker_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval) - - ! adjust "wdsrf" according to river and lake water depth - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - wdsrf(ps:pe) = wdsrf_hru(i) * 1.0e3 ! m to mm - ENDDO - - ! adjust lake levels "dz_lake" according to lake depth - DO i = 1, numpatch - IF (wdsrf(i) > 0.) THEN - wdsrfm = wdsrf(i)*1.e-3 - IF(wdsrfm > 1. .and. wdsrfm < 2000.)THEN - depthratio = wdsrfm / sum(dzlak(1:nl_lake)) - dz_lake(1,i) = dzlak(1) - dz_lake(2:nl_lake-1,i) = dzlak(2:nl_lake-1)*depthratio - dz_lake(nl_lake,i) = dzlak(nl_lake)*depthratio - (dz_lake(1,i) - dzlak(1)*depthratio) - ELSEIF(wdsrfm > 0. .and. wdsrfm <= 1.)THEN - dz_lake(:,i) = wdsrfm / nl_lake - ENDIF - ELSE - dz_lake(:,i) = 0. - ENDIF - ENDDO - - ENDIF - -#ifdef RangeCheck - CALL check_vector_data ('Basin Water Depth [m] ', wdsrf_bsn) - CALL check_vector_data ('HRU Water Depth [m] ', wdsrf_bsnhru) -#endif - - IF (allocated(patcharea)) deallocate(patcharea) - -#endif - -#ifdef GridRiverLakeFlow - IF (p_is_worker) THEN - IF (numucat > 0) THEN - wdsrf_ucat = topo_rivhgt - veloc_riv = 0 - ENDIF - - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv > 0) THEN - WHERE (idate(1) >= dam_build_year) - volresv = volresv_normal - ELSEWHERE - volresv = spval - END WHERE - ENDIF - ENDIF - ENDIF -#endif - -#ifdef DataAssimilation - IF (p_is_worker) THEN - DO i = 1, DEF_DA_ENS_NUM - z_sno_ens(:, i, :) = z_sno - dz_sno_ens(:, i, :) = dz_sno - t_soisno_ens(:, i, :) = t_soisno - wliq_soisno_ens(:, i, :) = wliq_soisno - wice_soisno_ens(:, i, :) = wice_soisno - smp_ens(:, i, :) = smp - hk_ens(:, i, :) = hk - t_grnd_ens(i, :) = t_grnd - tleaf_ens(i, :) = tleaf - ldew_ens(i, :) = ldew - ldew_rain_ens(i, :) = ldew_rain - ldew_snow_ens(i, :) = ldew_snow - fwet_snow_ens(i, :) = fwet_snow - sag_ens(i, :) = sag - scv_ens(i, :) = scv - snowdp_ens(i, :) = snowdp - fveg_ens(i, :) = fveg - fsno_ens(i, :) = fsno - sigf_ens(i, :) = sigf - green_ens(i, :) = green - tlai_ens(i, :) = tlai - lai_ens(i, :) = lai - sai_ens(i, :) = sai - tsai_ens(i, :) = tsai - alb_ens(:, :, i, :) = alb - ssun_ens(:, :, i, :) = ssun - ssha_ens(:, :, i, :) = ssha - ssoi_ens(:, :, i, :) = ssoi - ssno_ens(:, :, i, :) = ssno - thermk_ens(i, :) = thermk - extkb_ens(i, :) = extkb - extkd_ens(i, :) = extkd - zwt_ens(i, :) = zwt - wdsrf_ens(i, :) = wdsrf - wa_ens(i, :) = wa - wetwat_ens(i, :) = wetwat - t_lake_ens(:, i, :) = t_lake - lake_icefrac_ens(:, i, :) = lake_icefrac - savedtke1_ens(i, :) = savedtke1 - ENDDO - ENDIF -#endif - - -! ............................................................... -! 2.6 Write out the model variables for restart run [histTimeVar] -! ............................................................... - -#ifdef RangeCheck - CALL check_TimeVariables () -#endif - - IF ( .not. present(lulcc_call) ) THEN - ! only be called in running MKINI, LULCC will be executed later - CALL WRITE_TimeVariables (idate, lc_year, casename, dir_restart) - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_master) write (6,*) ('Successfully Initialize the Land Time-Vraying Variables') - - -! -------------------------------------------------- -! Deallocates memory for CoLM 1d [numpatch] variables -! -------------------------------------------------- - IF ( .not. present(lulcc_call) ) THEN - ! only be called in running MKINI, LULCC will be executed later - CALL deallocate_TimeInvariants - CALL deallocate_TimeVariables - ENDIF - - IF (allocated(z_soisno )) deallocate (z_soisno ) - IF (allocated(dz_soisno)) deallocate (dz_soisno) - - IF (allocated(soil_z)) deallocate (soil_z) - IF (allocated(snow_d)) deallocate (snow_d) - IF (allocated(soil_t)) deallocate (soil_t) - IF (allocated(soil_w)) deallocate (soil_w) - - END SUBROUTINE initialize - -END MODULE MOD_Initialize -! -------------------------------------------------- -! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 deleted file mode 100644 index 087c941de5..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_LakeDepthReadin.F90 +++ /dev/null @@ -1,110 +0,0 @@ -#include - -MODULE MOD_LakeDepthReadin - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Read in lakedepth and assign lake thickness of each layer. -! -! Original author: Yongjiu Dai, 03/2018 -!----------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: lakedepth_readin - - -CONTAINS - - - SUBROUTINE lakedepth_readin (dir_landdata, lc_year) - - USE MOD_Precision - USE MOD_Vars_Global, only: nl_lake - USE MOD_SPMD_Task - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_Vars_TimeInvariants, only: lakedepth, dz_lake -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - - IMPLICIT NONE - - integer, intent(in) :: lc_year ! which year of land cover data used - character(len=256), intent(in) :: dir_landdata - - ! Local Variables - character(len=256) :: lndname, cyear - real(r8) :: depthratio ! ratio of lake depth to standard deep lake depth - integer :: ipatch - - ! ----------------------------------------------------------- - ! For global simulations with 10 body layers, - ! the default (50 m lake) body layer thicknesses are given by : - ! The node depths zlak located at the center of each layer - real(r8), dimension(10) :: dzlak - real(r8), dimension(10) :: zlak - - dzlak = (/0.1, 1., 2., 3., 4., 5., 7., 7., 10.45, 10.45/) ! m - zlak = (/0.05, 0.6, 2.1, 4.6, 8.1, 12.6, 18.6, 25.6, 34.325, 44.775/) - - ! For site simulations with 25 layers, the default thicknesses are (m): - ! real(r8), dimension(25) :: dzlak - ! dzlak = (/0.1, & ! 0.1 for layer 1; - ! 0.25, 0.25, 0.25, 0.25, & ! 0.25 for layers 2-5; - ! 0.50, 0.50, 0.50, 0.50, & ! 0.5 for layers 6-9; - ! 0.75, 0.75, 0.75, 0.75, & ! 0.75 for layers 10-13; - ! 2.00, 2.00, & ! 2 for layers 14-15; - ! 2.50, 2.50, & ! 2.5 for layers 16-17; - ! 3.50, 3.50, 3.50, 3.50, & ! 2.5 for layers 16-17; - ! 5.225, 5.225, 5.225, 5.225/) ! 5.225 for layers 22-25. - ! - ! For lakes with depth d /= 50 m and d >= 1 m, - ! the top layer is kept at 10 cm and - ! the other 9 layer thicknesses are adjusted to maintain fixed - ! proportions. - ! - ! For lakes with d < 1 m, all layers have equal thickness. - ! ----------------------------------------------------------- - - ! Read lakedepth -#ifdef SinglePoint - lakedepth(:) = SITE_lakedepth -#else - write(cyear,'(i4.4)') lc_year - lndname = trim(dir_landdata)//'/lakedepth/'//trim(cyear)//'/lakedepth_patches.nc' - CALL ncio_read_vector (lndname, 'lakedepth_patches', landpatch, lakedepth) -#endif - - ! Define lake levels - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - - ! testing 14/05/2021, Zhang - IF(lakedepth(ipatch) < 0.1) lakedepth(ipatch) = 0.1 - - IF(lakedepth(ipatch) > 1. .and. lakedepth(ipatch) < 2000.)THEN - depthratio = lakedepth(ipatch) / sum(dzlak(1:nl_lake)) - dz_lake(1,ipatch) = dzlak(1) - dz_lake(2:nl_lake-1,ipatch) = dzlak(2:nl_lake-1)*depthratio - dz_lake(nl_lake,ipatch) = dzlak(nl_lake)*depthratio & - - (dz_lake(1,ipatch) - dzlak(1)*depthratio) - ELSEIF(lakedepth(ipatch) > 0. .and. lakedepth(ipatch) <= 1.)THEN - dz_lake(:,ipatch) = lakedepth(ipatch) / nl_lake - ELSE ! non land water bodies or missing value of the lake depth - lakedepth(ipatch) = sum(dzlak(1:nl_lake)) - dz_lake(1:nl_lake,ipatch) = dzlak(1:nl_lake) - ENDIF - - ENDDO - - ENDIF - - END SUBROUTINE lakedepth_readin - -END MODULE MOD_LakeDepthReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 deleted file mode 100644 index 9169b2a0c0..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_PercentagesPFTReadin.F90 +++ /dev/null @@ -1,94 +0,0 @@ -#include - -MODULE MOD_PercentagesPFTReadin - -!----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: pct_readin - -CONTAINS - - SUBROUTINE pct_readin (dir_landdata, lc_year) - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_NetCDFVector - USE MOD_LandPatch -#ifdef RangeCheck - USE MOD_RangeCheck -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT - USE MOD_Vars_PFTimeInvariants -#endif -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - IMPLICIT NONE - - integer, intent(in) :: lc_year - character(len=256), intent(in) :: dir_landdata - ! Local Variables - character(len=256) :: lndname, cyear - real(r8), allocatable :: sumpct (:) - integer :: npatch, ipatch - - write(cyear,'(i4.4)') lc_year -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) -#ifdef SinglePoint - IF (patchtypes(SITE_landtype) /= 0) RETURN -#endif - -#ifndef SinglePoint - lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_pfts.nc' - CALL ncio_read_vector (lndname, 'pct_pfts', landpft, pftfrac) -#else - pftfrac = pack(SITE_pctpfts, SITE_pctpfts > 0.) -#endif - -#if (defined CROP) -#ifndef SinglePoint - lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_crops.nc' - CALL ncio_read_vector (lndname, 'pct_crops', landpatch, cropfrac) -#else - IF (SITE_landtype == CROPLAND) THEN - cropfrac = pack(SITE_pctcrop, SITE_pctcrop > 0.) - ELSE - cropfrac = 0. - ENDIF -#endif -#endif - -#ifdef RangeCheck - IF (p_is_worker) THEN - npatch = count(patchtypes(landpatch%settyp) == 0) - allocate (sumpct (npatch)) - - npatch = 0 - DO ipatch = 1, numpatch - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN - npatch = npatch + 1 - sumpct(npatch) = sum(pftfrac(patch_pft_s(ipatch):patch_pft_e(ipatch))) - ENDIF - ENDDO - - ENDIF - - CALL check_vector_data ('Sum PFT pct', sumpct) -#if (defined CROP) - CALL check_vector_data ('CROP pct', cropfrac) -#endif -#endif - -#endif - - IF (allocated(sumpct)) deallocate(sumpct) - - END SUBROUTINE pct_readin - -END MODULE MOD_PercentagesPFTReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 deleted file mode 100644 index f11842481e..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilColorRefl.F90 +++ /dev/null @@ -1,115 +0,0 @@ -#include - -MODULE MOD_SoilColorRefl - -!======================================================================= -! Guess the soil color (reflectance) based on the land cover types -! -! Created by Yongjiu Dai, 03/2014 -!======================================================================= - - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: soil_color_refl - -CONTAINS - - SUBROUTINE soil_color_refl(L,soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb) - - USE MOD_Precision - IMPLICIT NONE - - integer, intent(in) :: L ! land cover types (GLCC USGS/MODIS IGBP) - real(r8), intent(out) :: soil_s_v_alb ! albedo of visible of the saturated soil - real(r8), intent(out) :: soil_d_v_alb ! albedo of visible of the dry soil - real(r8), intent(out) :: soil_s_n_alb ! albedo of near infrared of the saturated soil - real(r8), intent(out) :: soil_d_n_alb ! albedo of near infrared of the dry soil - - integer :: isc ! soil color - - real(r8) soil_s_v_refl(20) ! Saturated visible soil reflectance - real(r8) soil_d_v_refl(20) ! Dry visible soil reflectance - real(r8) soil_s_n_refl(20) ! Saturated near infrared soil reflectance - real(r8) soil_d_n_refl(20) ! Dry near infrared soil reflectance - - ! ---------------------------------------------------------------------- - ! The soil color and reflectance is from the work: - ! Peter J. Lawrence and Thomas N. Chase, 2007: - ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0): - ! Part 1 generating MODIS consistent land surface parameters - - soil_s_v_refl = (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, & - 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /) - - soil_d_v_refl = (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, & - 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /) - - soil_s_n_refl = (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, & - 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /) - - soil_d_n_refl = (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, & - 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /) - - ! Guessed soil color of the Lawrence's classification -#if (defined LULC_USGS) - IF(L.eq. 0) isc = 1 ! 0 Ocean (not used) - IF(L.eq. 1) isc = 16 ! 1 Urban and Built-Up Land - IF(L.eq. 2) isc = 3 ! 2 Dryland Cropland and Pasture - IF(L.eq. 3) isc = 9 ! 3 Irrigated Cropland and Pasture - IF(L.eq. 4) isc = 10 ! 4 Mixed Dryland/Irrigated Cropland and Pasture - IF(L.eq. 5) isc = 4 ! 5 Cropland/Grassland Mosaic - IF(L.eq. 6) isc = 6 ! 6 Cropland/Woodland Mosaic - IF(L.eq. 7) isc = 2 ! 7 Grassland - IF(L.eq. 8) isc = 8 ! 8 Shrubland - IF(L.eq. 9) isc = 7 ! 9 Mixed Shrubland/Grassland - IF(L.eq.10) isc = 5 !10 Savanna - IF(L.eq.11) isc = 19 !11 Deciduous Broadleaf Forest - IF(L.eq.12) isc = 20 !12 Deciduous Needleleaf Forest - IF(L.eq.13) isc = 18 !13 Evergreen Broadleaf Forest - IF(L.eq.14) isc = 17 !14 Evergreen Needleleaf Forest - IF(L.eq.15) isc = 16 !15 Mixed Forest - IF(L.eq.16) isc = 1 !16 Water Bodies (not used) - IF(L.eq.17) isc = 15 !17 Herbaceous Wetland - IF(L.eq.18) isc = 14 !18 Wooded Wetland - IF(L.eq.19) isc = 1 !19 Barren or Sparsely Vegetated - IF(L.eq.20) isc = 12 !20 Herbaceous Tundra - IF(L.eq.21) isc = 12 !21 Wooded Tundra - IF(L.eq.22) isc = 13 !22 Mixed Tundra - IF(L.eq.23) isc = 11 !23 Bare Ground Tundra - IF(L.eq.24) isc = 1 !24 Snow or Ice (not used) -#endif - -#if (defined LULC_IGBP) - IF(L.eq. 0) isc = 1 !0 Ocean (not used) - IF(L.eq. 1) isc = 17 !1 Evergreen Needleleaf Forest - IF(L.eq. 2) isc = 18 !2 Evergreen Broadleaf Forest - IF(L.eq. 3) isc = 20 !3 Deciduous Needleleaf Forest - IF(L.eq. 4) isc = 19 !4 Deciduous Broadleaf Forest - IF(L.eq. 5) isc = 13 !5 Mixed Forest - IF(L.eq. 6) isc = 9 !6 Closed Shrublands - IF(L.eq. 7) isc = 8 !7 Open Shrublands - IF(L.eq. 8) isc = 4 !8 Woody Savannas - IF(L.eq. 9) isc = 3 !9 Savannas - IF(L.eq.10) isc = 2 !10 Grasslands - IF(L.eq.11) isc = 15 !11 Permanent Wetlands - IF(L.eq.12) isc = 6 !12 Croplands - IF(L.eq.13) isc = 16 !13 Urban and Built-Up - IF(L.eq.14) isc = 12 !14 Cropland/Natural Vegetation Mosaic - IF(L.eq.15) isc = 1 !15 Snow and Ice (not used) - IF(L.eq.16) isc = 1 !16 Barren or Sparsely Vegetated - IF(L.eq.17) isc = 1 !17 Land Water Bodies -#endif - - soil_s_v_alb = soil_s_v_refl(isc) - soil_d_v_alb = soil_d_v_refl(isc) - soil_s_n_alb = soil_s_n_refl(isc) - soil_d_n_alb = soil_d_n_refl(isc) - - END SUBROUTINE soil_color_refl - -END MODULE MOD_SoilColorRefl -! ---------------------------------------------------------------------- -! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 deleted file mode 100644 index 6e76162c2b..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilParametersReadin.F90 +++ /dev/null @@ -1,550 +0,0 @@ -#include - -MODULE MOD_SoilParametersReadin - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Read in soil parameters; make unit conversion for soil physical process -! modeling; soil parameters 8 layers => 10 layers -! -! Original author: Yongjiu Dai, 03/2014 -! -! !REVISIONS: -! Nan Wei, 01/2019: read more parameters from mksrfdata results -! Shupeng Zhang and Nan Wei, 01/2022: porting codes to parallel version -!----------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: soil_parameters_readin - -CONTAINS - - SUBROUTINE soil_parameters_readin (dir_landdata, lc_year) - - USE MOD_Precision - USE MOD_Vars_Global, only: nl_soil - USE MOD_Namelist, only: DEF_SOIL_REFL_SCHEME - USE MOD_SPMD_Task - USE MOD_NetCDFVector - USE MOD_LandPatch - USE MOD_Vars_TimeInvariants -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - USE MOD_SoilColorRefl - - IMPLICIT NONE - - ! ---------------------------------------------------------------------- - integer, intent(in) :: lc_year ! which year of land cover data used - character(len=*), intent(in) :: dir_landdata - character(len=4) :: wavelength ! wavelength in nm - - ! Local Variables - - real(r8), allocatable :: soil_vf_quartz_mineral_s_l (:) ! volumetric fraction of quartz within mineral soil - real(r8), allocatable :: soil_vf_gravels_s_l (:) ! volumetric fraction of gravels - real(r8), allocatable :: soil_vf_om_s_l (:) ! volumetric fraction of organic matter - real(r8), allocatable :: soil_vf_sand_s_l (:) ! volumetric fraction of sand - real(r8), allocatable :: soil_vf_clay_s_l (:) ! volumetric fraction of clay - real(r8), allocatable :: soil_wf_gravels_s_l (:) ! gravimetric fraction of gravels - real(r8), allocatable :: soil_wf_sand_s_l (:) ! gravimetric fraction of sand - real(r8), allocatable :: soil_wf_clay_s_l (:) ! gravimetric fraction of clay - real(r8), allocatable :: soil_wf_om_s_l (:) ! gravimetric fraction of om - real(r8), allocatable :: soil_OM_density_s_l (:) ! OM_density (kg/m3) - real(r8), allocatable :: soil_BD_all_s_l (:) ! bulk density of soil (GRAVELS + OM + mineral soils, kg/m3) - real(r8), allocatable :: soil_theta_s_l (:) ! saturated water content (cm3/cm3) - real(r8), allocatable :: soil_psi_s_l (:) ! matric potential at saturation (cm) - real(r8), allocatable :: soil_lambda_l (:) ! pore size distribution index (dimensionless) -#ifdef HYPERSPECTRAL - real(r8), allocatable :: soil_hyper_alb_wl (:) -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8), allocatable :: soil_theta_r_l (:) ! residual water content (cm3/cm3) - real(r8), allocatable :: soil_alpha_vgm_l (:) - real(r8), allocatable :: soil_L_vgm_l (:) - real(r8), allocatable :: soil_n_vgm_l (:) -#endif - real(r8), allocatable :: soil_k_s_l (:) ! saturated hydraulic conductivity (cm/day) - real(r8), allocatable :: soil_csol_l (:) ! heat capacity of soil solids [J/(m3 K)] - real(r8), allocatable :: soil_k_solids_l(:) ! thermal conductivity of minerals soil [W/m-K] - real(r8), allocatable :: soil_tksatu_l (:) ! thermal conductivity of saturated unfrozen soil [W/m-K] - real(r8), allocatable :: soil_tksatf_l (:) ! thermal conductivity of saturated frozen soil [W/m-K] - real(r8), allocatable :: soil_tkdry_l (:) ! thermal conductivity for dry soil [W/(m-K)] - real(r8), allocatable :: soil_BA_alpha_l(:) ! alpha in Balland and Arp(2005) thermal conductivity scheme - real(r8), allocatable :: soil_BA_beta_l (:) ! beta in Balland and Arp(2005) thermal conductivity scheme - - integer :: ipatch, m, nsl, wl ! indices - integer :: wl_nm ! wavelength in nm (integer) - character(len=256) :: c - character(len=256) :: landdir, lndname, cyear, wl_str, hyper_dir - logical :: is_singlepoint - - ! ............................................................... - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_landdata) // '/soil/' // trim(cyear) - - ! write(*,*) 'soil parameter readin',landdir - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN - - allocate ( soil_vf_quartz_mineral_s_l (numpatch) ) - allocate ( soil_vf_gravels_s_l (numpatch) ) - allocate ( soil_vf_om_s_l (numpatch) ) - allocate ( soil_vf_sand_s_l (numpatch) ) - allocate ( soil_vf_clay_s_l (numpatch) ) - allocate ( soil_wf_gravels_s_l (numpatch) ) - allocate ( soil_wf_sand_s_l (numpatch) ) - allocate ( soil_wf_clay_s_l (numpatch) ) - allocate ( soil_wf_om_s_l (numpatch) ) - allocate ( soil_OM_density_s_l (numpatch) ) - allocate ( soil_BD_all_s_l (numpatch) ) - allocate ( soil_theta_s_l (numpatch) ) - allocate ( soil_psi_s_l (numpatch) ) - allocate ( soil_lambda_l (numpatch) ) -#ifdef HYPERSPECTRAL - allocate ( soil_hyper_alb_wl (numpatch) ) -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - allocate ( soil_theta_r_l (numpatch) ) - allocate ( soil_alpha_vgm_l (numpatch) ) - allocate ( soil_L_vgm_l (numpatch) ) - allocate ( soil_n_vgm_l (numpatch) ) -#endif - allocate ( soil_k_s_l (numpatch) ) - allocate ( soil_csol_l (numpatch) ) - allocate ( soil_k_solids_l(numpatch) ) - allocate ( soil_tksatu_l (numpatch) ) - allocate ( soil_tksatf_l (numpatch) ) - allocate ( soil_tkdry_l (numpatch) ) - allocate ( soil_BA_alpha_l(numpatch) ) - allocate ( soil_BA_beta_l (numpatch) ) - ENDIF - - ENDIF ! end if (p_is_worker) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - DO nsl = 1, 8 - -#ifdef SinglePoint - soil_vf_quartz_mineral_s_l (:) = SITE_soil_vf_quartz_mineral (nsl) - soil_vf_gravels_s_l (:) = SITE_soil_vf_gravels (nsl) - soil_vf_om_s_l (:) = SITE_soil_vf_om (nsl) - soil_vf_sand_s_l (:) = SITE_soil_vf_sand (nsl) - soil_vf_clay_s_l (:) = SITE_soil_vf_clay (nsl) - soil_wf_gravels_s_l (:) = SITE_soil_wf_gravels (nsl) - soil_wf_sand_s_l (:) = SITE_soil_wf_sand (nsl) - soil_wf_clay_s_l (:) = SITE_soil_wf_clay (nsl) - soil_wf_om_s_l (:) = SITE_soil_wf_om (nsl) - soil_OM_density_s_l (:) = SITE_soil_OM_density (nsl) - soil_BD_all_s_l (:) = SITE_soil_BD_all (nsl) - soil_theta_s_l (:) = SITE_soil_theta_s (nsl) - soil_psi_s_l (:) = SITE_soil_psi_s (nsl) - soil_lambda_l (:) = SITE_soil_lambda (nsl) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - soil_theta_r_l (:) = SITE_soil_theta_r (nsl) - soil_alpha_vgm_l (:) = SITE_soil_alpha_vgm(nsl) - soil_L_vgm_l (:) = SITE_soil_L_vgm (nsl) - soil_n_vgm_l (:) = SITE_soil_n_vgm (nsl) -#endif - soil_k_s_l (:) = SITE_soil_k_s (nsl) - soil_csol_l (:) = SITE_soil_csol (nsl) - soil_k_solids_l(:) = SITE_soil_k_solids (nsl) - soil_tksatu_l (:) = SITE_soil_tksatu (nsl) - soil_tksatf_l (:) = SITE_soil_tksatf (nsl) - soil_tkdry_l (:) = SITE_soil_tkdry (nsl) - soil_BA_alpha_l(:) = SITE_soil_BA_alpha (nsl) - soil_BA_beta_l (:) = SITE_soil_BA_beta (nsl) - -#else - write(c,'(i1)') nsl - - ! (1) read in the volumetric fraction of quartz within mineral soil - lndname = trim(landdir)//'/vf_quartz_mineral_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'vf_quartz_mineral_s_l'//trim(c)//'_patches', & - landpatch, soil_vf_quartz_mineral_s_l) - - ! (2) read in the volumetric fraction of gravels - lndname = trim(landdir)//'/vf_gravels_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'vf_gravels_s_l'//trim(c)//'_patches', & - landpatch, soil_vf_gravels_s_l) - - ! (3) read in the volumetric fraction of organic matter - lndname = trim(landdir)//'/vf_om_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'vf_om_s_l'//trim(c)//'_patches', & - landpatch, soil_vf_om_s_l) - - ! (4) read in the volumetric fraction of sand - lndname = trim(landdir)//'/vf_sand_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'vf_sand_s_l'//trim(c)//'_patches', & - landpatch, soil_vf_sand_s_l) - - ! (5) read in the gravimetric fraction of gravels - lndname = trim(landdir)//'/wf_gravels_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'wf_gravels_s_l'//trim(c)//'_patches', & - landpatch, soil_wf_gravels_s_l) - - ! (6) read in the gravimetric fraction of sand - lndname = trim(landdir)//'/wf_sand_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'wf_sand_s_l'//trim(c)//'_patches', & - landpatch, soil_wf_sand_s_l) - - ! (7) read in the saturated water content [cm3/cm3] - lndname = trim(landdir)//'/theta_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'theta_s_l'//trim(c)//'_patches', & - landpatch, soil_theta_s_l) - - ! (8) read in the matric potential at saturation [cm] - lndname = trim(landdir)//'/psi_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'psi_s_l'//trim(c)//'_patches', & - landpatch, soil_psi_s_l) - - ! (9) read in the pore size distribution index [dimensionless] - lndname = trim(landdir)//'/lambda_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'lambda_l'//trim(c)//'_patches', & - landpatch, soil_lambda_l) - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - ! (10) read in residual water content [cm3/cm3] - lndname = trim(landdir)//'/theta_r_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'theta_r_l'//trim(c)//'_patches', & - landpatch, soil_theta_r_l) - - ! (11) read in alpha in VGM model - lndname = trim(landdir)//'/alpha_vgm_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'alpha_vgm_l'//trim(c)//'_patches', & - landpatch, soil_alpha_vgm_l) - - ! (12) read in L in VGM model - lndname = trim(landdir)//'/L_vgm_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'L_vgm_l'//trim(c)//'_patches', & - landpatch, soil_L_vgm_l) - - ! (13) read in n in VGM model - lndname = trim(landdir)//'/n_vgm_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'n_vgm_l'//trim(c)//'_patches', & - landpatch, soil_n_vgm_l) -#endif - - ! (14) read in the saturated hydraulic conductivity [cm/day] - lndname = trim(landdir)//'/k_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'k_s_l'//trim(c)//'_patches', & - landpatch, soil_k_s_l) - - ! (15) read in the heat capacity of soil solids [J/(m3 K)] - lndname = trim(landdir)//'/csol_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'csol_l'//trim(c)//'_patches', & - landpatch, soil_csol_l) - - ! (16) read in the thermal conductivity of unfrozen saturated soil [W/m-K] - lndname = trim(landdir)//'/tksatu_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'tksatu_l'//trim(c)//'_patches', & - landpatch, soil_tksatu_l) - - ! (17) read in the thermal conductivity of frozen saturated soil [W/m-K] - lndname = trim(landdir)//'/tksatf_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'tksatf_l'//trim(c)//'_patches', & - landpatch, soil_tksatf_l) - - ! (18) read in the thermal conductivity for dry soil [W/(m-K)] - lndname = trim(landdir)//'/tkdry_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'tkdry_l'//trim(c)//'_patches', & - landpatch, soil_tkdry_l) - - ! (19) read in the thermal conductivity of solid soil [W/m-K] - lndname = trim(landdir)//'/k_solids_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'k_solids_l'//trim(c)//'_patches', & - landpatch, soil_k_solids_l) - - ! (20) read in the parameter alpha in the Balland V. and P. A. Arp (2005) model - lndname = trim(landdir)//'/BA_alpha_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'BA_alpha_l'//trim(c)//'_patches', & - landpatch, soil_BA_alpha_l) - - ! (21) read in the parameter beta in the Balland V. and P. A. Arp (2005) model - lndname = trim(landdir)//'/BA_beta_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'BA_beta_l'//trim(c)//'_patches', & - landpatch, soil_BA_beta_l) - - ! (22) read in the OM density (kg/m3) - lndname = trim(landdir)//'/OM_density_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'OM_density_s_l'//trim(c)//'_patches', & - landpatch, soil_OM_density_s_l) - - ! (23) read in the bulk density of soil (kg/m3) - lndname = trim(landdir)//'/BD_all_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'BD_all_s_l'//trim(c)//'_patches', & - landpatch, soil_BD_all_s_l) - - ! (24) read in the volumetric fraction of clay - lndname = trim(landdir)//'/vf_clay_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'vf_clay_s_l'//trim(c)//'_patches', & - landpatch, soil_vf_clay_s_l, defval = 0.1) - - ! (25) read in the gravimetric fraction of clay - lndname = trim(landdir)//'/wf_clay_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'wf_clay_s_l'//trim(c)//'_patches', & - landpatch, soil_wf_clay_s_l, defval = 0.1) - - ! (26) read in the gravimetric fraction of om - lndname = trim(landdir)//'/wf_om_s_l'//trim(c)//'_patches.nc' - CALL ncio_read_vector (lndname, 'wf_om_s_l'//trim(c)//'_patches', & - landpatch, soil_wf_om_s_l, defval = 0.01) - -#endif - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - m = landpatch%settyp(ipatch) - IF( m == 0 )THEN ! ocean - vf_quartz (nsl,ipatch) = -1.e36 - vf_gravels(nsl,ipatch) = -1.e36 - vf_om (nsl,ipatch) = -1.e36 - vf_sand (nsl,ipatch) = -1.e36 - vf_clay (nsl,ipatch) = -1.e36 - wf_gravels(nsl,ipatch) = -1.e36 - wf_sand (nsl,ipatch) = -1.e36 - wf_clay (nsl,ipatch) = -1.e36 - wf_om (nsl,ipatch) = -1.e36 - OM_density(nsl,ipatch) = -1.e36 - BD_all (nsl,ipatch) = -1.e36 - wfc (nsl,ipatch) = -1.e36 - porsl (nsl,ipatch) = -1.e36 - psi0 (nsl,ipatch) = -1.e36 - bsw (nsl,ipatch) = -1.e36 - theta_r (nsl,ipatch) = -1.e36 -#ifdef vanGenuchten_Mualem_SOIL_MODEL - alpha_vgm (nsl,ipatch) = -1.e36 - L_vgm (nsl,ipatch) = -1.e36 - n_vgm (nsl,ipatch) = -1.e36 -#endif - hksati (nsl,ipatch) = -1.e36 - csol (nsl,ipatch) = -1.e36 - k_solids (nsl,ipatch) = -1.e36 - dksatu (nsl,ipatch) = -1.e36 - dksatf (nsl,ipatch) = -1.e36 - dkdry (nsl,ipatch) = -1.e36 - BA_alpha (nsl,ipatch) = -1.e36 - BA_beta (nsl,ipatch) = -1.e36 - ELSE ! non ocean - vf_quartz (nsl,ipatch) = soil_vf_quartz_mineral_s_l(ipatch) - vf_gravels (nsl,ipatch) = soil_vf_gravels_s_l (ipatch) - vf_om (nsl,ipatch) = soil_vf_om_s_l (ipatch) - vf_sand (nsl,ipatch) = soil_vf_sand_s_l (ipatch) - vf_clay (nsl,ipatch) = soil_vf_clay_s_l (ipatch) - wf_gravels (nsl,ipatch) = soil_wf_gravels_s_l (ipatch) - wf_sand (nsl,ipatch) = soil_wf_sand_s_l (ipatch) - wf_clay (nsl,ipatch) = soil_wf_clay_s_l (ipatch) - wf_om (nsl,ipatch) = soil_wf_om_s_l (ipatch) - OM_density (nsl,ipatch) = soil_OM_density_s_l (ipatch) - BD_all (nsl,ipatch) = soil_BD_all_s_l (ipatch) - porsl (nsl,ipatch) = soil_theta_s_l (ipatch) ! cm/cm - psi0 (nsl,ipatch) = soil_psi_s_l (ipatch) * 10. ! cm -> mm - bsw (nsl,ipatch) = 1./soil_lambda_l (ipatch) ! dimensionless - wfc (nsl,ipatch) = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch))& - * soil_theta_s_l(ipatch) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - psi0 (nsl,ipatch) = -10. ! mm - theta_r (nsl,ipatch) = soil_theta_r_l (ipatch) - alpha_vgm (nsl,ipatch) = soil_alpha_vgm_l(ipatch) - L_vgm (nsl,ipatch) = soil_L_vgm_l (ipatch) - n_vgm (nsl,ipatch) = soil_n_vgm_l (ipatch) - wfc (nsl,ipatch) = soil_theta_r_l (ipatch)+(soil_theta_s_l(ipatch)-soil_theta_r_l(ipatch))*& - (1+(soil_alpha_vgm_l(ipatch)*339.9)**soil_n_vgm_l(ipatch))**(1.0/soil_n_vgm_l(ipatch)-1) -#else - theta_r (nsl,ipatch) = 0. -#endif - hksati (nsl,ipatch) = soil_k_s_l (ipatch) * 10./86400. ! cm/day -> mm/s - csol (nsl,ipatch) = soil_csol_l (ipatch) ! J/(m2 K) - k_solids (nsl,ipatch) = soil_k_solids_l (ipatch) ! W/(m K) - dksatu (nsl,ipatch) = soil_tksatu_l (ipatch) ! W/(m K) - dksatf (nsl,ipatch) = soil_tksatf_l (ipatch) ! W/(m K) - dkdry (nsl,ipatch) = soil_tkdry_l (ipatch) ! W/(m K) - BA_alpha (nsl,ipatch) = soil_BA_alpha_l (ipatch) - BA_beta (nsl,ipatch) = soil_BA_beta_l (ipatch) - ENDIF - ENDDO - - ENDIF - - ENDDO - - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN - deallocate ( soil_vf_quartz_mineral_s_l ) - deallocate ( soil_vf_gravels_s_l ) - deallocate ( soil_vf_om_s_l ) - deallocate ( soil_vf_sand_s_l ) - deallocate ( soil_vf_clay_s_l ) - deallocate ( soil_wf_gravels_s_l ) - deallocate ( soil_wf_sand_s_l ) - deallocate ( soil_wf_clay_s_l ) - deallocate ( soil_wf_om_s_l ) - deallocate ( soil_OM_density_s_l ) - deallocate ( soil_BD_all_s_l ) - deallocate ( soil_theta_s_l ) - deallocate ( soil_psi_s_l ) - deallocate ( soil_lambda_l ) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - deallocate ( soil_theta_r_l ) - deallocate ( soil_alpha_vgm_l ) - deallocate ( soil_L_vgm_l ) - deallocate ( soil_n_vgm_l ) -#endif - deallocate ( soil_k_s_l ) - deallocate ( soil_csol_l ) - deallocate ( soil_k_solids_l) - deallocate ( soil_tksatu_l ) - deallocate ( soil_tksatf_l ) - deallocate ( soil_tkdry_l ) - deallocate ( soil_BA_alpha_l) - deallocate ( soil_BA_beta_l ) - ENDIF - - ENDIF - - ! The parameters of the top NINTH soil layers were given by datasets - ! [0-0.045 (LAYER 1-2), 0.045-0.091, 0.091-0.166, 0.166-0.289, - ! 0.289-0.493, 0.493-0.829, 0.829-1.383 and 1.383-2.296 m]. - ! The NINTH layer's soil parameters will assigned to the bottom soil layer (2.296 - 3.8019m). - - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN - DO nsl = 9, 2, -1 - vf_quartz (nsl,:) = vf_quartz (nsl-1,:) - vf_gravels (nsl,:) = vf_gravels(nsl-1,:) - vf_om (nsl,:) = vf_om (nsl-1,:) - vf_sand (nsl,:) = vf_sand (nsl-1,:) - vf_clay (nsl,:) = vf_clay (nsl-1,:) - wf_gravels (nsl,:) = wf_gravels(nsl-1,:) - wf_sand (nsl,:) = wf_sand (nsl-1,:) - wf_clay (nsl,:) = wf_clay (nsl-1,:) - wf_om (nsl,:) = wf_om (nsl-1,:) - OM_density (nsl,:) = OM_density(nsl-1,:) - BD_all (nsl,:) = BD_all (nsl-1,:) - wfc (nsl,:) = wfc (nsl-1,:) - porsl (nsl,:) = porsl (nsl-1,:) - psi0 (nsl,:) = psi0 (nsl-1,:) - bsw (nsl,:) = bsw (nsl-1,:) - theta_r (nsl,:) = theta_r (nsl-1,:) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - alpha_vgm (nsl,:) = alpha_vgm (nsl-1,:) - L_vgm (nsl,:) = L_vgm (nsl-1,:) - n_vgm (nsl,:) = n_vgm (nsl-1,:) -#endif - hksati (nsl,:) = hksati (nsl-1,:) - csol (nsl,:) = csol (nsl-1,:) - k_solids (nsl,:) = k_solids (nsl-1,:) - dksatu (nsl,:) = dksatu (nsl-1,:) - dksatf (nsl,:) = dksatf (nsl-1,:) - dkdry (nsl,:) = dkdry (nsl-1,:) - BA_alpha (nsl,:) = BA_alpha (nsl-1,:) - BA_beta (nsl,:) = BA_beta (nsl-1,:) - ENDDO - - DO nsl = nl_soil, 10, -1 - vf_quartz (nsl,:) = vf_quartz (9,:) - vf_gravels (nsl,:) = vf_gravels(9,:) - vf_om (nsl,:) = vf_om (9,:) - vf_sand (nsl,:) = vf_sand (9,:) - vf_clay (nsl,:) = vf_clay (9,:) - wf_gravels (nsl,:) = wf_gravels(9,:) - wf_sand (nsl,:) = wf_sand (9,:) - wf_clay (nsl,:) = wf_clay (9,:) - wf_om (nsl,:) = wf_om (9,:) - OM_density (nsl,:) = OM_density(9,:) - BD_all (nsl,:) = BD_all (9,:) - wfc (nsl,:) = wfc (9,:) - porsl (nsl,:) = porsl (9,:) - psi0 (nsl,:) = psi0 (9,:) - bsw (nsl,:) = bsw (9,:) - theta_r (nsl,:) = theta_r (9,:) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - alpha_vgm (nsl,:) = alpha_vgm (9,:) - L_vgm (nsl,:) = L_vgm (9,:) - n_vgm (nsl,:) = n_vgm (9,:) -#endif - hksati (nsl,:) = hksati (9,:) - csol (nsl,:) = csol (9,:) - k_solids (nsl,:) = k_solids (9,:) - dksatu (nsl,:) = dksatu (9,:) - dksatf (nsl,:) = dksatf (9,:) - dkdry (nsl,:) = dkdry (9,:) - BA_alpha (nsl,:) = BA_alpha (9,:) - BA_beta (nsl,:) = BA_beta (9,:) - ENDDO - - ENDIF - ENDIF - - ! Soil reflectance of broadband of visible(_v) and near-infrared(_n) of - ! the saturated(_s) and dry(_d) soil - ! SCHEME 1: Guessed soil color type according to land cover classes - IF (DEF_SOIL_REFL_SCHEME .eq. 1) THEN - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - m = landpatch%settyp(ipatch) - CALL soil_color_refl(m,soil_s_v_alb(ipatch),soil_d_v_alb(ipatch),& - soil_s_n_alb(ipatch),soil_d_n_alb(ipatch)) - ENDDO - ENDIF - ENDIF - - ! SCHEME 2: Read a global soil color map from CLM - IF (DEF_SOIL_REFL_SCHEME .eq. 2) THEN - -#ifdef SinglePoint - soil_s_v_alb(:) = SITE_soil_s_v_alb - soil_d_v_alb(:) = SITE_soil_d_v_alb - soil_s_n_alb(:) = SITE_soil_s_n_alb - soil_d_n_alb(:) = SITE_soil_d_n_alb -#else - ! (1) Read in the albedo of visible of the saturated soil - lndname = trim(landdir)//'/soil_s_v_alb_patches.nc' - CALL ncio_read_vector (lndname, 'soil_s_v_alb', landpatch, soil_s_v_alb) - - ! (2) Read in the albedo of visible of the dry soil - lndname = trim(landdir)//'/soil_d_v_alb_patches.nc' - CALL ncio_read_vector (lndname, 'soil_d_v_alb', landpatch, soil_d_v_alb) - - ! (3) Read in the albedo of near infrared of the saturated soil - lndname = trim(landdir)//'/soil_s_n_alb_patches.nc' - CALL ncio_read_vector (lndname, 'soil_s_n_alb', landpatch, soil_s_n_alb) - - ! (4) Read in the albedo of near infrared of the dry soil - lndname = trim(landdir)//'/soil_d_n_alb_patches.nc' - CALL ncio_read_vector (lndname, 'soil_d_n_alb', landpatch, soil_d_n_alb) -#endif - ENDIF ! end of DEF_SOIL_REFL_SCHEME -#ifdef HYPERSPECTRAL - ! Hyper spectral soil albedo - ! special treatment for the hyper spectral soil albedo - hyper_dir = trim(dir_landdata) // '/HyperAlbedo/' // trim(cyear) - - DO wl = 1, 211 - ! 计算波长编号并读取对应单波段文件 - wl_nm = 400 + 10 * (wl - 1) - write(wavelength,'(i0)') wl_nm - lndname = trim(hyper_dir)//'/soil_hyper_alb_'//trim(wavelength)//'nm_patches.nc' - CALL ncio_read_vector (lndname, 'soil_hyper_alb', landpatch, soil_hyper_alb_wl) - - ! 存储至波段矩阵 - soil_alb(wl, :) = soil_hyper_alb_wl(:) - ENDDO -#endif - END SUBROUTINE soil_parameters_readin - -END MODULE MOD_SoilParametersReadin -! -------------------------------------------------- -! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 deleted file mode 100644 index 69f52071b7..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_SoilTextureReadin.F90 +++ /dev/null @@ -1,54 +0,0 @@ -#include - -MODULE MOD_SoilTextureReadin - - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: soiltext_readin - -CONTAINS - - SUBROUTINE soiltext_readin (dir_landdata, lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_UserDefFun - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_Vars_TimeInvariants, only: soiltext -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - - IMPLICIT NONE - - character(len=256), intent(in) :: dir_landdata - integer, intent(in) :: lc_year ! which year of land cover data used - - ! Local Variables - character(len=256) :: lndname - character(len=4) :: cyear - integer :: ipatch - -#ifdef SinglePoint - soiltext(:) = SITE_soil_texture -#else - write(cyear,'(i4.4)') lc_year - lndname = trim(dir_landdata)// '/soil/' // trim(cyear) // '/soiltexture_patches.nc' - CALL ncio_read_vector (lndname, 'soiltext_patches', landpatch, soiltext) -#endif - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - WHERE (soiltext < 0 ) soiltext = 0 - WHERE (soiltext > 12) soiltext = 0 - ENDIF - ENDIF - - END SUBROUTINE soiltext_readin - -END MODULE MOD_SoilTextureReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 deleted file mode 100644 index 173f2cf402..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanIniTimeVariable.F90 +++ /dev/null @@ -1,132 +0,0 @@ -#include - -#ifdef URBAN_MODEL -MODULE MOD_UrbanIniTimeVariable - -!----------------------------------------------------------------------- -! -! !DESCRIPTION: -! Initialize urban model time variables. -! -! Created by Hua Yuan, 09/16/2021 -! -! !REVISIONS: -! 05/2023, Wenzong Dong, Hua Yuan: porting codes to MPI parallel version. -! -!----------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - SAVE - - PUBLIC :: UrbanIniTimeVar - -CONTAINS - - SUBROUTINE UrbanIniTimeVar(ipatch,froof,fgper,flake,hlr,hroof,& - alb_roof,alb_wall,alb_gimp,alb_gper,& - rho,tau,fveg,htop,hbot,lai,sai,coszen,& - fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& - scv_roof,scv_gimp,scv_gper,scv_lake,fwet_snow,& - sag_roof,sag_gimp,sag_gper,sag_lake,tlake,fwsun,dfwsun,& - extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Urban_Albedo - - IMPLICIT NONE - - integer, intent(in) :: & - ipatch ! patch index - - real(r8), intent(in) :: & - froof, &! roof fraction - fgper, &! impervious ground weight fraction - flake, &! lake fraction - hlr, &! average building height to their side length - hroof ! average building height - - real(r8), intent(in) :: & - alb_roof(2,2), &! roof albedo (iband,direct/diffuse) - alb_wall(2,2), &! wall albedo (iband,direct/diffuse) - alb_gimp(2,2), &! impervious albedo (iband,direct/diffuse) - alb_gper(2,2) ! pervious albedo (iband,direct/diffuse) - - real(r8), intent(in) :: & - fveg, &! fraction of vegetation cover - lai, &! leaf area index - sai, &! stem area index - htop, &! canopy crown top height - hbot, &! canopy crown bottom height - coszen, &! cosine of solar zenith angle - rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) - tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) - - real(r8), intent(out) :: & - fsno_roof, &! fraction of soil covered by snow [-] - fsno_gimp, &! fraction of soil covered by snow [-] - fsno_gper, &! fraction of soil covered by snow [-] - fsno_lake, &! fraction of soil covered by snow [-] - scv_roof, &! snow cover, water equivalent [mm] - scv_gimp, &! snow cover, water equivalent [mm] - scv_gper, &! snow cover, water equivalent [mm] - scv_lake, &! snow cover, water equivalent [mm] - sag_roof, &! non dimensional snow age [-] - sag_gimp, &! non dimensional snow age [-] - sag_gper, &! non dimensional snow age [-] - sag_lake, &! non dimensional snow age [-] - fwet_snow, &! vegetation snow fractional cover [-] - tlake ! lake temperature - - real(r8), intent(out) :: & - fwsun, &! sunlit wall fraction [-] - dfwsun, &! change of fwsun - extkd, &! diffuse and scattered diffuse PAR extinction coefficient - alb (2,2), &! averaged albedo [-] - ssun(2,2), &! sunlit canopy absorption for solar radiation - ssha(2,2), &! shaded canopy absorption for solar radiation - sroof(2,2), &! roof absorption for solar radiation, - swsun(2,2), &! sunlit wall absorption for solar radiation, - swsha(2,2), &! shaded wall absorption for solar radiation, - sgimp(2,2), &! impervious ground absorption for solar radiation, - sgper(2,2), &! pervious ground absorption for solar radiation, - slake(2,2) ! lake absorption for solar radiation, - - !----------------------------------------------------------------------- - real(r8) :: hveg ! height of crown central hight - - fsno_roof = 0. ! fraction of ground covered by snow - fsno_gimp = 0. ! fraction of ground covered by snow - fsno_gper = 0. ! fraction of ground covered by snow - fsno_lake = 0. ! fraction of soil covered by snow [-] - scv_roof = 0. ! snow cover, water equivalent [mm, kg/m2] - scv_gimp = 0. ! snow cover, water equivalent [mm, kg/m2] - scv_gper = 0. ! snow cover, water equivalent [mm, kg/m2] - scv_lake = 0. ! snow cover, water equivalent [mm] - sag_roof = 0. ! roof snow age [-] - sag_gimp = 0. ! impervious ground snow age [-] - sag_gper = 0. ! pervious ground snow age [-] - sag_lake = 0. ! urban lake snow age [-] - fwet_snow = 0. ! vegetation snow fractional cover [-] - - fwsun = 0.5 ! Fraction of sunlit wall [-] - dfwsun = 0. ! change of fwsun - - hveg = min(hroof, (htop+hbot)/2.) - - ! urban surface albedo - CALL alburban (ipatch,froof,fgper,flake,hlr,hroof,& - alb_roof,alb_wall,alb_gimp,alb_gper,& - rho,tau,fveg,hveg,lai,sai,fwet_snow,max(0.01,coszen),fwsun,tlake,& - fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& - scv_roof,scv_gimp,scv_gper,scv_lake,& - sag_roof,sag_gimp,sag_gper,sag_lake,& - dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) - - END SUBROUTINE UrbanIniTimeVar - -END MODULE MOD_UrbanIniTimeVariable -!----------------------------------------------------------------------- -! EOP -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 deleted file mode 100644 index 2d960095fc..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mkinidata/MOD_UrbanReadin.F90 +++ /dev/null @@ -1,321 +0,0 @@ -#include - -#ifdef URBAN_MODEL - -MODULE MOD_UrbanReadin - -!----------------------------------------------------------------------- -! -! !DESCRIPTION: -! Read in the Urban dataset. -! -! Created by Hua Yuan, 11/26/2021 -! -! !REVISIONS: -! 05/2023, Wenzong Dong, Hua Yuan: porting codes to MPI parallel version. -! -! 08/2025, Wenzong Dong, Hua Yuan: unifying the urban surface data -! code for different urban type schemes. -! -!----------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: Urban_readin - -CONTAINS - - SUBROUTINE Urban_readin (dir_landdata, lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global - USE MOD_Namelist - USE MOD_Const_LC - USE MOD_Vars_TimeVariables - USE MOD_Vars_TimeInvariants - USE MOD_Urban_Vars_TimeInvariants - USE MOD_NetCDFVector - USE MOD_NetCDFSerial - USE MOD_LandPatch - USE MOD_LandUrban - USE MOD_Urban_Const_LCZ -#ifdef SinglePoint - USE MOD_SingleSrfdata -#endif - - IMPLICIT NONE - - integer, intent(in) :: lc_year ! which year of land cover data used - character(len=256), intent(in) :: dir_landdata - character(len=256) :: dir_rawdata, dir_runtime - character(len=256) :: lndname - character(len=256) :: cyear - - integer :: i, u, m, l, lucy_id, ns, nr - - real(r8) :: thick_roof, thick_wall - - ! parameters for LUCY - integer , allocatable :: lucyid(:) ! LUCY region id - real(r8), allocatable :: popden(:) ! population density [person/km2] - - integer , allocatable :: lweek_holiday(:,:) ! week holidays - real(r8), allocatable :: lwdh_prof (:,:) ! Diurnal traffic flow profile [-] - real(r8), allocatable :: lweh_prof (:,:) ! Diurnal traffic flow profile [-] - real(r8), allocatable :: lhum_prof (:,:) ! Diurnal metabolic heat profile profile [W/person] - real(r8), allocatable :: lfix_holiday (:,:) ! Fixed public holidays, holiday(0) or workday(1) - real(r8), allocatable :: lvehicle (:,:) ! vehicle numbers per thousand people - - ! thickness of roof and wall - real(r8), allocatable :: thickroof(:) ! thickness of roof [m] - real(r8), allocatable :: thickwall(:) ! thickness of wall [m] - - write(cyear,'(i4.4)') lc_year - - allocate (lucyid (numurban)) - allocate (thickroof (numurban)) - allocate (thickwall (numurban)) - -#ifdef SinglePoint - froof (:) = SITE_froof - hroof (:) = SITE_hroof - hlr (:) = SITE_hlr - fgper (:) = SITE_fgper - - flake (:) = SITE_flake_urb - fveg_urb (:) = SITE_fveg_urb - htop_urb (:) = SITE_htop_urb - - em_roof (:) = SITE_em_roof - em_wall (:) = SITE_em_wall - em_gimp (:) = SITE_em_gimp - em_gper (:) = SITE_em_gper - - t_roommax (:) = SITE_t_roommax - t_roommin (:) = SITE_t_roommin - thickroof (:) = SITE_thickroof - thickwall (:) = SITE_thickwall - - alb_roof (:,:,1) = SITE_alb_roof - alb_wall (:,:,1) = SITE_alb_wall - alb_gimp (:,:,1) = SITE_alb_gimp - alb_gper (:,:,1) = SITE_alb_gper - - cv_roof (:,1) = SITE_cv_roof - cv_wall (:,1) = SITE_cv_wall - cv_gimp (:,1) = SITE_cv_gimp - tk_roof (:,1) = SITE_tk_roof - tk_wall (:,1) = SITE_tk_wall - tk_gimp (:,1) = SITE_tk_gimp - - lucyid (:) = SITE_lucyid - pop_den (:) = SITE_popden - -#else - ! READ in urban data - !----------------------------------- - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/WT_ROOF.nc' - CALL ncio_read_vector (lndname, 'WT_ROOF' , landurban, froof ) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/HT_ROOF.nc' - CALL ncio_read_vector (lndname, 'HT_ROOF' , landurban, hroof ) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/HLR_BLD.nc' - CALL ncio_read_vector (lndname, 'BUILDING_HLR' , landurban, hlr ) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/PCT_Tree.nc' - CALL ncio_read_vector (lndname, 'PCT_Tree' , landurban, fveg_urb) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/htop_urb.nc' - CALL ncio_read_vector (lndname, 'URBAN_TREE_TOP', landurban, htop_urb) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/PCT_Water.nc' - CALL ncio_read_vector (lndname, 'PCT_Water' , landurban, flake ) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LUCY_region_id.nc' - CALL ncio_read_vector (lndname, 'LUCY_id' , landurban, lucyid ) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/POP.nc' - CALL ncio_read_vector (lndname, 'POP_DEN' , landurban, pop_den ) - - lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/urban.nc' - - ! pervious fraction to ground area - CALL ncio_read_vector (lndname, 'WTROAD_PERV' , landurban, fgper ) - - ! emissivity of roof - CALL ncio_read_vector (lndname, 'EM_ROOF' , landurban, em_roof) - ! emissivity of wall - CALL ncio_read_vector (lndname, 'EM_WALL' , landurban, em_wall) - ! emissivity of impervious road - CALL ncio_read_vector (lndname, 'EM_IMPROAD' , landurban, em_gimp) - ! emissivity of pervious road - CALL ncio_read_vector (lndname, 'EM_PERROAD' , landurban, em_gper) - - ! maximum temperature of inner room [K] - CALL ncio_read_vector (lndname, 'T_BUILDING_MAX', landurban, t_roommax) - ! minimum temperature of inner room [K] - CALL ncio_read_vector (lndname, 'T_BUILDING_MIN', landurban, t_roommin) - ! thickness of roof [m] - CALL ncio_read_vector (lndname, 'THICK_ROOF' , landurban, thickroof) - ! thickness of wall [m] - CALL ncio_read_vector (lndname, 'THICK_WALL' , landurban, thickwall) - - ! albedo of roof - CALL ncio_read_vector (lndname, 'ALB_ROOF' , 2, 2, landurban, alb_roof) - ! albedo of wall - CALL ncio_read_vector (lndname, 'ALB_WALL' , 2, 2, landurban, alb_wall) - ! albedo of impervious - CALL ncio_read_vector (lndname, 'ALB_IMPROAD' , 2, 2, landurban, alb_gimp) - ! albedo of pervious road - CALL ncio_read_vector (lndname, 'ALB_PERROAD' , 2, 2, landurban, alb_gper) - - ! heat capacity of roof [J/(m2 K)] - CALL ncio_read_vector (lndname, 'CV_ROOF' , nl_roof, landurban, cv_roof) - ! heat capacity of wall [J/(m2 K)] - CALL ncio_read_vector (lndname, 'CV_WALL' , nl_wall, landurban, cv_wall) - ! heat capacity of impervious road [J/(m2 K)] - CALL ncio_read_vector (lndname, 'CV_IMPROAD' , nl_soil, landurban, cv_gimp) - ! thermal conductivity of roof [W/m-K] - CALL ncio_read_vector (lndname, 'TK_ROOF' , nl_roof, landurban, tk_roof) - ! thermal conductivity of wall [W/m-K] - CALL ncio_read_vector (lndname, 'TK_WALL' , nl_wall, landurban, tk_wall) - ! thermal conductivity of impervious road [W/m-K] - CALL ncio_read_vector (lndname, 'TK_IMPROAD' , nl_soil, landurban, tk_gimp) - -#endif - - dir_runtime = DEF_dir_runtime - lndname = trim(dir_runtime)//'/urban/'//'/LUCY_rawdata.nc' - - CALL ncio_read_bcast_serial (lndname, "NUMS_VEHC" , lvehicle ) - CALL ncio_read_bcast_serial (lndname, "WEEKEND_DAY" , lweek_holiday) - CALL ncio_read_bcast_serial (lndname, "TraffProf_24hr_holiday", lweh_prof ) - CALL ncio_read_bcast_serial (lndname, "TraffProf_24hr_work" , lwdh_prof ) - CALL ncio_read_bcast_serial (lndname, "HumMetabolic_24hr" , lhum_prof ) - CALL ncio_read_bcast_serial (lndname, "FIXED_HOLIDAY" , lfix_holiday ) - - IF (p_is_worker) THEN - - DO u = 1, numurban - - i = urban2patch (u) - lucy_id = lucyid (u) - - IF (all(cv_gimp(:,u)==0)) THEN - fgper(u) = 1. - ENDIF - - IF (DEF_URBAN_WATER) THEN - flake(u) = flake(u)/100. !urban water fractional cover - ELSE - flake(u) = 0. - ENDIF - - IF (DEF_URBAN_TREE) THEN - ! set tree fractional cover (<= 1.-froof) - fveg_urb(u) = fveg_urb(u)/100. !urban tree percent - IF (flake(u) < 1.) THEN - fveg_urb(u) = fveg_urb(u)/(1.-flake(u)) - ELSE - fveg_urb(u) = 0. - ENDIF - - ! Assuming that the tree coverage is less than or equal - ! to the ground cover (assume no trees on the roof) - fveg_urb(u) = min(fveg_urb(u), 1.-froof(u)) - fveg (i) = fveg_urb(u) - ELSE - fveg_urb(u) = 0. - fveg (i) = fveg_urb(u) - ENDIF - - ! set urban tree crown top and bottom [m] - htop_urb(u) = min(hroof(u), htop_urb(u)) - htop_urb(u) = max(2., htop_urb(u)) - - hbot_urb(u) = htop_urb(u)*hbot0(URBAN)/htop0(URBAN) - hbot_urb(u) = max(1., hbot_urb(u)) - - htop (i) = htop_urb (u) - hbot (i) = hbot_urb (u) - - thick_roof = thickroof (u) !thickness of roof [m] - thick_wall = thickwall (u) !thickness of wall [m] - - ! roof and wall layer node depth - DO l=1, nl_roof - z_roof(l,u) = (l-0.5)*(thickroof(u)/nl_roof) - ENDDO - - DO l=1, nl_wall - z_wall(l,u) = (l-0.5)*(thickwall(u)/nl_wall) - ENDDO - - ! roof and wall layer depth - dz_roof(1,u) = 0.5*(z_roof(1,u)+z_roof(2,u)) - DO l = 2, nl_roof-1 - dz_roof(l,u) = 0.5*(z_roof(l+1,u)-z_roof(l-1,u)) - ENDDO - dz_roof(nl_roof,u) = z_roof(nl_roof,u)-z_roof(nl_roof-1,u) - - dz_wall(1,u) = 0.5*(z_wall(1,u)+z_wall(2,u)) - DO l = 2, nl_wall-1 - dz_wall(l,u) = 0.5*(z_wall(l+1,u)-z_wall(l-1,u)) - ENDDO - dz_wall(nl_wall,u) = z_wall(nl_wall,u)-z_wall(nl_wall-1,u) - - ! lake depth and layer depth - !NOTE: USE global lake depth right now, the below set to 1m - !lakedepth(npatch) = 1. - !dz_lake(:,npatch) = lakedepth(npatch) / nl_lake - - IF ( .not. DEF_URBAN_BEM) THEN - t_roommax(u) = 373.16 - t_roommin(u) = 180.00 - ENDIF - - IF (DEF_URBAN_LUCY) THEN - IF (lucy_id > 0) THEN - vehicle (:,u) = lvehicle (lucy_id,:) - week_holiday (:,u) = lweek_holiday (lucy_id,:) - weh_prof (:,u) = lweh_prof (lucy_id,:) - wdh_prof (:,u) = lwdh_prof (lucy_id,:) - hum_prof (:,u) = lhum_prof (lucy_id,:) - fix_holiday (:,u) = lfix_holiday (lucy_id,:) - ENDIF - ELSE - pop_den (u) = 0. - vehicle (:,u) = 0. - week_holiday (:,u) = 0. - weh_prof (:,u) = 0. - wdh_prof (:,u) = 0. - hum_prof (:,u) = 0. - fix_holiday (:,u) = 0. - ENDIF - - ENDDO - ENDIF - - IF (p_is_worker) THEN - IF (allocated(lvehicle )) deallocate ( lvehicle ) - IF (allocated(lwdh_prof )) deallocate ( lwdh_prof ) - IF (allocated(lweh_prof )) deallocate ( lweh_prof ) - IF (allocated(lhum_prof )) deallocate ( lhum_prof ) - IF (allocated(lweek_holiday )) deallocate ( lweek_holiday ) - IF (allocated(lfix_holiday )) deallocate ( lfix_holiday ) - IF (allocated(thickroof )) deallocate ( thickroof ) - IF (allocated(thickwall )) deallocate ( thickwall ) - IF (allocated(lucyid )) deallocate ( lucyid ) - ENDIF - - END SUBROUTINE Urban_readin - -END MODULE MOD_UrbanReadin - -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 deleted file mode 100644 index fb20db1e19..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_DBedrock.F90 +++ /dev/null @@ -1,129 +0,0 @@ -#include - -SUBROUTINE Aggregation_DBedrock ( & - gland, dir_rawdata, dir_model_landdata, lc_year) - -!----------------------------------------------------------------------- -! Depth to bedrock -! -! Shangguan, W., Hengl, T., Mendes de Jesus, J., Yuan, H., Dai, Y. (2017). -! Mapping the global depth to bedrock for land surface modeling. -! Journal of Advances in Modeling Earth Systems, 9(1), 65-88. -! -! Created by Shupeng Zhang, 05/2023 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_RangeCheck - USE MOD_AggregationRequestData - -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - character(len=256) :: landdir, lndname, cyear - - type (block_data_real8_2d) :: dbedrock - real(r8), allocatable :: dbedrock_patches(:) - real(r8), allocatable :: dbedrock_one(:), area_one(:) - integer :: ipatch - integer :: wmo_src - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/dbedrock/' //trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate depth to bedrock ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_io) THEN - - CALL allocate_block_data (gland, dbedrock) - - lndname = trim(dir_rawdata)//'/bedrock.nc' - CALL ncio_read_block (lndname, 'dbedrock', gland, dbedrock) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = dbedrock) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (dbedrock_patches (numpatch)) - - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - dbedrock_patches (ipatch) = dbedrock_patches (wmo_src) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = dbedrock, data_r8_2d_out1 = dbedrock_one) - dbedrock_patches (ipatch) = sum(dbedrock_one * area_one) / sum(area_one) - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('dbedrock_patches ', dbedrock_patches, -9999.0) -#endif - - ! Write-out the depth of the pacth in the gridcell - lndname = trim(landdir)//'/dbedrock_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'dbedrock_patches', 'patch', & - landpatch, dbedrock_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/dbedrock_patch_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (dbedrock_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'dbedrock', compress = 1, write_mode = 'one', create_mode=.true.) -#endif - - IF (p_is_worker) THEN - deallocate ( dbedrock_patches ) - ENDIF - -END SUBROUTINE Aggregation_DBedrock diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 deleted file mode 100644 index f8dc1ab7af..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_ForestHeight.F90 +++ /dev/null @@ -1,332 +0,0 @@ -#include - -SUBROUTINE Aggregation_ForestHeight ( & - gland, dir_rawdata, dir_model_landdata, lc_year) - -!----------------------------------------------------------------------- -! Global Forest Height -! (http://lidarradar.jpl.nasa.gov/) -! Simard, M., N. Pinto, J. B. Fisher, and A. Baccini, 2011: Mapping -! forest canopy height globally with spaceborne lidar. -! J. Geophys. Res., 116, G04021. -! -! Created by Yongjiu Dai, 02/2014 -! -! !REVISIONS: -! Hua Yuan, ?/2020 : for land cover land use classifications -! Shupeng Zhang, 01/2022: porting codes to MPI parallel version -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils - - USE MOD_Const_LC - USE MOD_5x5DataReadin -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif - -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - integer :: L, ipatch, p - integer :: wmo_src - - type (block_data_real8_2d) :: tree_height - real(r8), allocatable :: tree_height_patches(:), tree_height_one(:) - - ! for IGBP data - character(len=256) :: dir_5x5, suffix - type (block_data_real8_2d) :: htop - type (block_data_real8_3d) :: pftPCT - real(r8), allocatable :: htop_patches(:), htop_pfts(:), htop_pcs(:,:) - real(r8), allocatable :: htop_one(:), area_one(:), pct_one(:,:) - integer :: ip, ipft - real(r8) :: sumarea - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#ifndef CROP - integer :: typpft (N_PFT) -#else - integer :: typpft (N_PFT+N_CFT) -#endif - integer :: typpc (N_land_classification+1) -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/htop/' //trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate forest height ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef LULC_USGS - lndname = trim(dir_rawdata)//'/Forest_Height.nc' - - IF (p_is_io) THEN - CALL allocate_block_data (gland, tree_height) - CALL ncio_read_block (lndname, 'forest_height', gland, tree_height) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tree_height) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (tree_height_patches (numpatch)) - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF(L/=0 .and. L/=1 .and. L/=16 .and. L/=24)THEN - ! NOT OCEAN(0)/URBAN and BUILT-UP(1)/WATER BODIES(16)/ICE(24) - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = tree_height, data_r8_2d_out1 = tree_height_one) - tree_height_patches (ipatch) = median (tree_height_one, size(tree_height_one)) - ELSE - tree_height_patches (ipatch) = -1.0e36_r8 - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('htop_patches ', tree_height_patches) -#endif - - lndname = trim(landdir)//'/htop_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, tree_height_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (tree_height_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) -#endif - - IF (p_is_worker) THEN - deallocate ( tree_height_patches ) - ENDIF -#endif - - -#ifdef LULC_IGBP - IF (p_is_io) THEN - CALL allocate_block_data (gland, htop) - ENDIF - - IF (p_is_io) THEN - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(cyear) - CALL read_5x5_data (dir_5x5, suffix, gland, 'HTOP', htop) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = htop) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (htop_patches (numpatch)) - - DO ipatch = 1, numpatch - - IF (landpatch%settyp(ipatch) /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & - area = area_one, data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one) - htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('HTOP_patches ', htop_patches) -#endif - - lndname = trim(landdir)//'/htop_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, htop_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (htop_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) -#endif - - IF (p_is_worker) THEN - IF (allocated(htop_patches)) deallocate (htop_patches) - IF (allocated(htop_one )) deallocate (htop_one ) - IF (allocated(area_one )) deallocate (area_one ) - ENDIF -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (p_is_io) THEN - CALL allocate_block_data (gland, htop) - CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) - ENDIF - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(cyear) - - IF (p_is_io) THEN - CALL read_5x5_data (dir_5x5, suffix, gland, 'HTOP', htop ) - CALL read_5x5_data_pft (dir_5x5, suffix, gland, 'PCT_PFT', pftPCT) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, & - data_r8_2d_in1 = htop, data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (htop_patches (numpatch)) - allocate (htop_pfts (numpft )) - - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - ! set patch htop - htop_patches(ipatch) = htop_patches(wmo_src) - - ! set pft htop at the same time - ip = patch_pft_s(ipatch) - htop_pfts(ip) = htop_patches(ipatch) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & - area = area_one, data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0) - - htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) - pct_one = max(pct_one , 0.0) - -#ifndef CROP - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN -#else - IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN -#endif - DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) - p = landpft%settyp(ip) - sumarea = sum(pct_one(p,:) * area_one) - IF (sumarea > 0) THEN - htop_pfts(ip) = sum(htop_one * pct_one(p,:) * area_one) / sumarea - ELSE - htop_pfts(ip) = htop_patches(ipatch) - ENDIF - ENDDO -#ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN - ip = patch_pft_s(ipatch) - htop_pfts(ip) = htop_patches(ipatch) -#endif - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('HTOP_patches ', htop_patches) - CALL check_vector_data ('HTOP_pfts ', htop_pfts ) -#endif - - lndname = trim(landdir)//'/htop_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, htop_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (htop_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) -#endif - - lndname = trim(landdir)//'/htop_pfts.nc' - CALL ncio_create_file_vector (lndname, landpft) - CALL ncio_define_dimension_vector (lndname, landpft, 'pft') - CALL ncio_write_vector (lndname, 'htop_pfts', 'pft', landpft, htop_pfts, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag -#ifndef CROP - typpft = (/(ityp, ityp = 0, N_PFT-1)/) -#else - typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) -#endif - lndname = trim(dir_model_landdata) // '/diag/htop_pft_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (htop_pfts, landpft%settyp, typpft, m_pft2diag, & - -1.0e36_r8, lndname, 'htop_pft', compress = 1, write_mode = 'one', defval=0._r8, create_mode=.true.) -#endif - - IF (p_is_worker) THEN - IF (allocated(htop_patches)) deallocate (htop_patches) - IF (allocated(htop_pfts )) deallocate (htop_pfts ) - IF (allocated(htop_one )) deallocate (htop_one ) - IF (allocated(pct_one )) deallocate (pct_one ) - IF (allocated(area_one )) deallocate (area_one ) - ENDIF -#endif - -END SUBROUTINE Aggregation_ForestHeight diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 deleted file mode 100644 index cfc7679cfe..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LAI.F90 +++ /dev/null @@ -1,759 +0,0 @@ -#include - -SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! 1. Global Plant Leaf Area Index (http://globalchange.bnu.edu.cn) -! -! !REFERENCES: -! Yuan H., et al., 2011: -! Reprocessing the MODIS Leaf Area Index products for land surface -! and climate modelling. Remote Sensing of Environment, 115: 1171-1187. -! -! Lin, W., Yuan, H., Dong, W., Zhang, S., Liu, S., Wei, N., et al. -! (2023). Reprocessed MODIS version 6.1 leaf area index dataset and -! its evaluation for land surface and climate modeling. Remote -! Sensing, 15(7), 1780. https://doi.org/10.3390/rs15071780 -! -! Created by Yongjiu Dai, 02/2014 -! -! !REVISIONS: -! Hua Yuan, ?/2020 : for land cover land use classifications -! Shupeng Zhang, 01/2022: porting codes to MPI parallel version -! Hua Yuan, 05/2023: TODO -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_TimeManager - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFBlock - USE MOD_NetCDFVector -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - - USE MOD_AggregationRequestData - - USE MOD_Const_LC - USE MOD_5x5DataReadin -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gridlai - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! ---------------------------------------------------------------------- - character(len=256) :: landdir, lndname - - integer :: simulation_lai_year_start, simulation_lai_year_end - integer :: idate(3) - - type (block_data_real8_2d) :: LAI ! plant leaf area index (m2/m2) - real(r8), allocatable :: LAI_patches(:), lai_one(:), area_one(:) - integer :: itime, ntime, Julian_day, ipatch - character(len=4) :: c2, c3, cyear, cyear_bk - integer :: start_year, end_year, iy - - ! for IGBP data - character(len=256) :: dir_5x5, suffix - integer :: month - type (block_data_real8_2d) :: SAI ! plant stem area index (m2/m2) - real(r8), allocatable :: SAI_patches(:), sai_one(:) - - ! for PFT and PC - type (block_data_real8_3d) :: pftLSAI, pftPCT - real(r8), allocatable :: pct_one (:), pct_pft_one(:,:) - real(r8), allocatable :: LAI_pfts(:), lai_pft_one(:,:) - real(r8), allocatable :: SAI_pfts(:), sai_pft_one(:,:) - integer :: p, ip - integer :: wmo_src, ip_, p_ - real(r8) :: sumarea - logical :: first_call_LAI_patch, first_call_SAI_patch - logical :: first_call_LAI_pft, first_call_SAI_pft - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#ifndef CROP - integer :: typpft (N_PFT) -#else - integer :: typpft (N_PFT+N_CFT) -#endif - character(len=256) :: varname -#endif - - ! LAI data root directory->case/landdata/LAI - landdir = trim(dir_model_landdata) // '/LAI/' - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate LAI ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - idate(1) = DEF_simulation_time%start_year - IF (.not. isgreenwich) THEN - idate(3) = DEF_simulation_time%start_sec - CALL monthday2julian (idate(1), & - DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2)) - CALL localtime2gmt(idate) - ENDIF - - simulation_lai_year_start = idate(1) - - idate(1) = DEF_simulation_time%end_year - IF (.not. isgreenwich) THEN - idate(3) = DEF_simulation_time%end_sec - CALL monthday2julian (idate(1), & - DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2)) - CALL localtime2gmt(idate) - ENDIF - - simulation_lai_year_end = idate(1) - - first_call_LAI_patch = .true. - first_call_SAI_patch = .true. - first_call_LAI_pft = .true. - first_call_SAI_pft = .true. - -! ................................................ -! ... global plant leaf area index -! ................................................ - -#if (defined LULC_USGS || defined LULC_IGBP) - ! add time variation of LAI - IF (DEF_LAI_MONTHLY) THEN - ! monthly average LAI - ! if use lai change, LAI data of simulation start year and end year will be made - ! if do not use lai change, only make LAI data of defined lc year -#ifdef LULCC - ! 07/2023, NOTE: if defined LULCC, only one year (lc_year) lai processed. - start_year = lc_year - end_year = lc_year - ntime = 12 -#else - IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) - start_year = min(start_year, DEF_LAI_END_YEAR ) - end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) - end_year = max(end_year, DEF_LAI_START_YEAR ) - ntime = 12 - ELSE - start_year = lc_year - end_year = lc_year - ntime = 12 - ENDIF -#endif - ! 8-day LAI - ELSE - start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR) - end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) - ntime = 46 - ENDIF - - ! ----- LAI ----- - IF (p_is_io) THEN - CALL allocate_block_data (gridlai, LAI) - ENDIF - - IF (p_is_worker) THEN - allocate (LAI_patches (numpatch)) - ENDIF - - - IF(.not. DEF_USE_LAIFEEDBACK)THEN - DO iy = start_year, end_year - - write(cyear,'(i4.4)') iy - CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) - - ! loop for month or 8-day - DO itime = 1, ntime - ! ----------------------- - ! read in leaf area index - ! ----------------------- - IF (DEF_LAI_MONTHLY) THEN - write(c3, '(i2.2)') itime - ELSE - Julian_day = 1 + (itime-1)*8 - write(c3, '(i3.3)') Julian_day - ENDIF - - IF (p_is_master) THEN - write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate LAI :', iy, ':', itime, '/', ntime - ENDIF - - IF (p_is_io) THEN - IF (DEF_LAI_MONTHLY) THEN - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - IF (iy < 2000) THEN - ! every 5 years one file - write(cyear_bk,'(i4.4)') (iy / 5) * 5 - suffix = 'MOD'//trim(cyear_bk) - CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_LC_LAI_'//trim(cyear), itime, LAI) - ELSE - suffix = 'MOD'//trim(cyear) - CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_LC_LAI', itime, LAI) - ENDIF - ELSE - lndname = trim(dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc' - CALL ncio_read_block_time (lndname, 'lai', gridlai, itime, LAI) - CALL block_data_linear_transform (LAI, scl = 0.1) - ENDIF - -#ifdef USEMPI - CALL aggregation_data_daemon (gridlai, data_r8_2d_in1 = LAI) -#endif - ENDIF - -! ------------------------------------------------------------------------------------------- -! aggregate the plant leaf area index from the resolution of raw data to modelling resolution -! ------------------------------------------------------------------------------------------- - - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gridlai, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = LAI, data_r8_2d_out1 = lai_one) - LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef RangeCheck - CALL check_vector_data ('LAI value '//trim(c3), LAI_patches) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif -! --------------------------------------------------- -! write out the plant leaf area index of grid patches -! --------------------------------------------------- - IF (DEF_LAI_MONTHLY) THEN - lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' - ELSE - !TODO: rename filename of 8-day LAI - lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' - ENDIF - - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', & - landpatch, LAI_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' - IF (DEF_LAI_MONTHLY) THEN - varname = 'LAI' - ELSE - !TODO: rename file name of 8-day LAI - varname = 'LAI_8-day' - ENDIF - CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & - lastdimname = 'Itime', lastdimvalue = itime, create_mode=first_call_LAI_patch) - IF ( first_call_LAI_patch ) first_call_LAI_patch = .false. -#endif - ENDDO - first_call_LAI_patch = .true. - ENDDO - ENDIF - - ! ----- SAI ----- - IF (DEF_LAI_MONTHLY) THEN - - IF (p_is_io) THEN - CALL allocate_block_data (gridlai, SAI) - ENDIF - - IF (p_is_worker) THEN - allocate (SAI_patches (numpatch)) - ENDIF - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - DO iy = start_year, end_year - write(cyear,'(i4.4)') iy - IF (iy < 2000) THEN - write(cyear_bk,'(i4.4)') (iy / 5) * 5 - suffix = 'MOD'//trim(cyear_bk) - ELSE - suffix = 'MOD'//trim(cyear) - ENDIF - - DO itime = 1, 12 - write(c3, '(i2.2)') itime - - IF (p_is_master) THEN - write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate SAI :', iy, ':', itime, '/', ntime - ENDIF - - IF (p_is_io) THEN - IF (iy < 2000) THEN - CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_LC_SAI_'//trim(cyear), itime, SAI) - ELSE - CALL read_5x5_data_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_LC_SAI', itime, SAI) - ENDIF - -#ifdef USEMPI - CALL aggregation_data_daemon (gridlai, data_r8_2d_in1 = SAI) -#endif - ENDIF - -! ------------------------------------------------------------------------------------------- -! aggregate the plant stem area index from the resolution of raw data to modelling resolution -! ------------------------------------------------------------------------------------------- - - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - - CALL aggregation_request_data (landpatch, ipatch, gridlai, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = SAI, data_r8_2d_out1 = sai_one) - SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef RangeCheck - CALL check_vector_data ('SAI value '//trim(c3), SAI_patches) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif -! --------------------------------------------------- -! write out the plant leaf area index of grid patches -! --------------------------------------------------- - lndname = trim(landdir) // trim(cyear) // '/SAI_patches' // trim(c3) // '.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'SAI_patches', 'patch', landpatch, SAI_patches, & - DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/SAI_patch_'// trim(cyear) // '.nc' - IF (DEF_LAI_MONTHLY) THEN - varname = 'SAI' - ELSE - !TODO: rename varname - varname = 'SAI_8-day' - ENDIF - CALL srfdata_map_and_write (SAI_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & - lastdimname = 'Itime', lastdimvalue = itime, create_mode=first_call_SAI_patch) - IF ( first_call_SAI_patch ) first_call_SAI_patch = .false. - -#endif - ENDDO - first_call_SAI_patch = .true. - ENDDO - ENDIF -#endif - -! For both PFT and PC run LAI!!!!! -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - ! add time variation of LAI - ! monthly average LAI - ! if use lai change, LAI data of simulation start year and end year will be made - ! if not use lai change, only make LAI data of defined lc year -#ifdef LULCC - ! 07/2023, NOTE: if defined LULCC, only one year (lc_year) lai processed. - start_year = lc_year - end_year = lc_year - ntime = 12 -#else - IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) - start_year = min(start_year, DEF_LAI_END_YEAR ) - end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) - end_year = max(end_year, DEF_LAI_START_YEAR ) - ntime = 12 - ELSE - start_year = lc_year - end_year = lc_year - ntime = 12 - ENDIF -#endif - - IF (p_is_io) THEN - CALL allocate_block_data (gridlai, pftLSAI, N_PFT_modis, lb1 = 0) - CALL allocate_block_data (gridlai, pftPCT, N_PFT_modis, lb1 = 0) - ENDIF - - IF (p_is_worker) THEN - allocate(LAI_patches (numpatch)) - allocate(LAI_pfts (numpft )) - allocate(SAI_patches (numpatch)) - allocate(SAI_pfts (numpft )) - ENDIF - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - DO iy = start_year, end_year - write(cyear,'(i4.4)') iy - CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) - - IF (iy < 2000) THEN - write(cyear_bk,'(i4.4)') (iy / 5) * 5 - suffix = 'MOD'//trim(cyear_bk) - ELSE - suffix = 'MOD'//trim(cyear) - ENDIF - - IF (p_is_master) THEN - write(*,'(A,I4)') 'Aggregate LAI : ', iy - ENDIF - - IF (p_is_io) THEN - CALL read_5x5_data_pft (dir_5x5, suffix, gridlai, 'PCT_PFT', pftPCT) - ENDIF - - IF(.not. DEF_USE_LAIFEEDBACK)THEN - DO month = 1, 12 - IF (p_is_io) THEN - IF (iy < 2000) THEN - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_PFT_LAI_'//trim(cyear), month, pftLSAI) - ELSE - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_PFT_LAI', month, pftLSAI) - ENDIF -#ifdef USEMPI - CALL aggregation_data_daemon (gridlai, & - data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & - data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) -#endif - ENDIF - -! ------------------------------------------------------------------------------------------- -! aggregate the plant leaf area index from the resolution of raw data to modelling resolution -! ------------------------------------------------------------------------------------------- - - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - ip = patch_pft_s(ipatch) - p = landpft%settyp(ip) - - IF (p>=12 .and. p<=14) THEN - DO ip_ = patch_pft_s(wmo_src), patch_pft_e(wmo_src) - p_ = landpft%settyp(ip_) - IF (p_ == p) LAI_pfts(ip) = LAI_pfts(ip_) - ENDDO - ELSE - LAI_pfts(ip) = 0. - ENDIF - - LAI_patches(ipatch) = LAI_pfts(ip) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gridlai, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, & - n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & - data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = lai_pft_one, & - n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) - - IF (allocated(lai_one)) deallocate(lai_one) - allocate(lai_one(size(area_one))) - - IF (allocated(pct_one)) deallocate(pct_one) - allocate(pct_one(size(area_one))) - - pct_pft_one = max(pct_pft_one , 0.0) - pct_one = sum(pct_pft_one,dim=1) - pct_one = max(pct_one, 1.0e-6) - - lai_one = sum(lai_pft_one * pct_pft_one, dim=1) / pct_one - LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) - -#ifndef CROP - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN -#else - IF (patchtypes(landpatch%settyp(ipatch)) == 0 & - .and. landpatch%settyp(ipatch)/=CROPLAND) THEN -#endif - DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) - p = landpft%settyp(ip) - sumarea = sum(pct_pft_one(p,:) * area_one) - IF (sumarea > 0) THEN - LAI_pfts(ip) = sum(lai_pft_one(p,:) * pct_pft_one(p,:) * area_one) & - / sumarea - ELSE - ! 07/2023, yuan: bug may exist below - !LAI_pfts(ip) = LAI_patches(ipatch) - LAI_pfts(ip) = 0. - ENDIF - ENDDO -#ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN - ip = patch_pft_s(ipatch) - LAI_pfts(ip) = LAI_patches(ipatch) -#endif - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - write(c2,'(i2.2)') month -#ifdef RangeCheck - CALL check_vector_data ('LAI_patches ' // trim(c2), LAI_patches) - CALL check_vector_data ('LAI_pfts ' // trim(c2), LAI_pfts ) -#endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -! --------------------------------------------------- -! write out the plant leaf area index of grid patches -! --------------------------------------------------- - lndname = trim(landdir)//trim(cyear)//'/LAI_patches'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', & - landpatch, LAI_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' - varname = 'LAI' - CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & - lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_LAI_patch) - IF ( first_call_LAI_patch ) first_call_LAI_patch = .false. -#endif - - lndname = trim(landdir)//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpft) - CALL ncio_define_dimension_vector (lndname, landpft, 'pft') - CALL ncio_write_vector (lndname, 'LAI_pfts', 'pft', & - landpft, LAI_pfts, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag -#ifndef CROP - typpft = (/(ityp, ityp = 0, N_PFT-1)/) -#else - typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) -#endif - lndname = trim(dir_model_landdata) // '/diag/LAI_pft_'// trim(cyear) // '.nc' - varname = 'LAI_pft' - CALL srfdata_map_and_write (LAI_pfts, landpft%settyp, typpft, m_pft2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & - lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_LAI_pft) - IF ( first_call_LAI_pft ) first_call_LAI_pft = .false. -#endif - ! loop end of month - ENDDO - - ENDIF - - DO month = 1, 12 - IF (p_is_io) THEN - IF (iy < 2000) THEN - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_PFT_SAI_'//trim(cyear), month, pftLSAI) - ELSE - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, & - 'MONTHLY_PFT_SAI', month, pftLSAI) - ENDIF -#ifdef USEMPI - CALL aggregation_data_daemon (gridlai, & - data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & - data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) -#endif - ENDIF - -! ------------------------------------------------------------------------------------------- -! aggregate the plant leaf area index from the resolution of raw data to modelling resolution -! ------------------------------------------------------------------------------------------- - - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - ip = patch_pft_s(ipatch) - p = landpft%settyp(ip) - - IF (p>=12 .and. p<=14) THEN - DO ip_ = patch_pft_s(wmo_src), patch_pft_e(wmo_src) - p_ = landpft%settyp(ip_) - IF (p_ == p) SAI_pfts(ip) = SAI_pfts(ip_) - ENDDO - ELSE - SAI_pfts (ip) = 0. - ENDIF - - SAI_patches(ipatch) = SAI_pfts(ip) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gridlai, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, & - n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & - data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = sai_pft_one, & - n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) - - IF (allocated(sai_one)) deallocate(sai_one) - allocate(sai_one(size(area_one))) - - IF (allocated(pct_one)) deallocate(pct_one) - allocate(pct_one(size(area_one))) - - pct_pft_one = max(pct_pft_one , 0.0) - pct_one = sum(pct_pft_one,dim=1) - pct_one = max(pct_one, 1.0e-6) - - sai_one = sum(sai_pft_one * pct_pft_one, dim=1) / pct_one - SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) - -#ifndef CROP - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN -#else - IF (patchtypes(landpatch%settyp(ipatch)) == 0 & - .and. landpatch%settyp(ipatch)/=CROPLAND) THEN -#endif - DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) - p = landpft%settyp(ip) - sumarea = sum(pct_pft_one(p,:) * area_one) - IF (sumarea > 0) THEN - SAI_pfts(ip) = sum(sai_pft_one(p,:) * pct_pft_one(p,:) * area_one) & - / sumarea - ELSE - ! 07/2023, yuan: bug may exist below - !SAI_pfts(ip) = SAI_patches(ipatch) - SAI_pfts(ip) = 0. - ENDIF - ENDDO -#ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN - ip = patch_pft_s(ipatch) - SAI_pfts(ip) = SAI_patches(ipatch) -#endif - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - write(c2,'(i2.2)') month -#ifdef RangeCheck - CALL check_vector_data ('SAI_patches ' // trim(c2), SAI_patches) - CALL check_vector_data ('SAI_pfts ' // trim(c2), SAI_pfts ) -#endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -! --------------------------------------------------- -! write out the plant stem area index of grid patches -! --------------------------------------------------- - lndname = trim(landdir)//trim(cyear)//'/SAI_patches'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'SAI_patches', 'patch', & - landpatch, SAI_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/SAI_patch_'// trim(cyear) // '.nc' - varname = 'SAI' - CALL srfdata_map_and_write (SAI_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & - lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_SAI_patch) - IF ( first_call_SAI_patch ) first_call_SAI_patch = .false. -#endif - - lndname = trim(landdir)//trim(cyear)//'/SAI_pfts'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpft) - CALL ncio_define_dimension_vector (lndname, landpft, 'pft') - CALL ncio_write_vector (lndname, 'SAI_pfts', 'pft', & - landpft, SAI_pfts, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag -#ifndef CROP - typpft = (/(ityp, ityp = 0, N_PFT-1)/) -#else - typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) -#endif - lndname = trim(dir_model_landdata) // '/diag/SAI_pft_'// trim(cyear) // '.nc' - varname = 'SAI_pft' - CALL srfdata_map_and_write (SAI_pfts, landpft%settyp, typpft, m_pft2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', defval=0._r8, & - lastdimname = 'Itime', lastdimvalue = month, create_mode=first_call_SAI_pft) - IF ( first_call_SAI_pft ) first_call_SAI_pft = .false. -#endif - ! loop end of month - ENDDO - - ! new year, new data file - first_call_LAI_patch = .true. - first_call_SAI_patch = .true. - first_call_LAI_pft = .true. - first_call_SAI_pft = .true. - - ! loop end of year - ENDDO - - IF (p_is_worker) THEN - - IF (allocated(LAI_patches)) deallocate(LAI_patches) - IF (allocated(LAI_pfts )) deallocate(LAI_pfts ) - IF (allocated(lai_one )) deallocate(lai_one ) - - IF (allocated(SAI_patches)) deallocate(SAI_patches) - IF (allocated(SAI_pfts )) deallocate(SAI_pfts ) - IF (allocated(sai_one )) deallocate(sai_one ) - IF (allocated(pct_one )) deallocate(pct_one ) - IF (allocated(pct_pft_one)) deallocate(pct_pft_one) - IF (allocated(area_one )) deallocate(area_one ) - - ENDIF -#endif - -END SUBROUTINE Aggregation_LAI diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 deleted file mode 100644 index 7f2b991614..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_LakeDepth.F90 +++ /dev/null @@ -1,145 +0,0 @@ -#include - -SUBROUTINE Aggregation_LakeDepth ( & - gland, dir_rawdata, dir_model_landdata, lc_year) - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Aggregate lake depth of multiple pixels within a lake patch based on -! Global land cover types (updated with the specific dataset) -! -! Global Lake Coverage and Lake Depth (1km resolution) -! (http://nwpi.krc.karelia.run/flake/) -! Lake depth data legend -! Value Description -! 0 no lake indicated in this pixel -! 1 no any information about this lake and set the default value of 10 m -! 2 no information about depth for this lake and set the default value of 10 m -! 3 have the information about lake depth in this pixel -! 4 this is the river pixel according to our map, set the default value of 3 m -! -! !REFERENCES: -! Kourzeneva, E., H. Asensio, E. Martin, and S. Faroux, 2012: Global gridded -! dataset of lake coverage and lake depth for USE in numerical weather -! prediction and climate modelling. Tellus A, 64, 15640. -! -! Created by Yongjiu Dai, 02/2014 -! -! !REVISIONS: -! Shupeng Zhang, 01/2022: porting codes to MPI parallel version -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - ! arguments: - - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - integer :: L, ipatch - - type (block_data_real8_2d) :: lakedepth - real(r8), allocatable :: lakedepth_patches(:), lakedepth_one(:) -#ifdef SrfdataDiag - integer :: typlake(1) = (/17/) -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/lakedepth/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate lake depth ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -! ................................................ -! global lake coverage and lake depth -! ................................................ - lndname = trim(dir_rawdata)//'/lake_depth.nc' - - IF (p_is_io) THEN - CALL allocate_block_data (gland, lakedepth) - CALL ncio_read_block (lndname, 'lake_depth', gland, lakedepth) - CALL block_data_linear_transform (lakedepth, scl = 0.1) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = lakedepth) -#endif - ENDIF - -! ---------------------------------------------------------------------------------- -! aggregate the lake depth from the resolution of raw data to modelling resolution -! ---------------------------------------------------------------------------------- - - IF (p_is_worker) THEN - - allocate (lakedepth_patches (numpatch)) - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - IF(L==WATERBODY)THEN ! LAND WATER BODIES (17) - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = lakedepth, data_r8_2d_out1 = lakedepth_one) - lakedepth_patches (ipatch) = median (lakedepth_one, size(lakedepth_one)) - ELSE - lakedepth_patches (ipatch) = -1.0e36_r8 - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('lakedepth_patches ', lakedepth_patches) -#endif - - lndname = trim(landdir)//'/lakedepth_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'lakedepth_patches', 'patch', & - landpatch, lakedepth_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - lndname = trim(dir_model_landdata)//'/diag/lakedepth_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (lakedepth_patches, landpatch%settyp, typlake, m_patch2diag, & - -1.0e36_r8, lndname, 'lakedepth', compress = 1, write_mode = 'one', create_mode=.true.) -#endif - - IF (p_is_worker) THEN - deallocate ( lakedepth_patches ) - ENDIF - -END SUBROUTINE Aggregation_LakeDepth diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 deleted file mode 100644 index 9245af9bbd..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_PercentagesPFT.F90 +++ /dev/null @@ -1,218 +0,0 @@ -#include - -SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, lc_year) - -!----------------------------------------------------------------------- -! Percentage of Plant Function Types -! -! Original from Hua Yuan's OpenMP version. -! -! !REVISIONS: -! Hua Yuan, ?/2020 : for land cover land use classifications -! Shupeng Zhang, 01/2022: porting codes to MPI parallel version -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO -#ifdef CROP - USE MOD_LandCrop -#endif - USE MOD_NetCDFBlock - USE MOD_NetCDFVector -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - - USE MOD_Const_LC - USE MOD_5x5DataReadin - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! ---------------------------------------------------------------------- - character(len=256) :: landdir, lndname - - ! for IGBP data - character(len=256) :: dir_5x5, suffix, cyear - ! for PFT - type (block_data_real8_3d) :: pftPCT - real(r8), allocatable :: pct_one(:), area_one(:) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - real(r8), allocatable :: pct_pft_one(:,:) - real(r8), allocatable :: pct_pfts(:) -#endif - integer :: ipatch, ipc, ipft, p - integer :: wmo_pth - real(r8) :: sumarea, sum_pct_pfts -#ifdef SrfdataDiag - integer :: typpft(0:N_PFT-1) -#ifdef CROP - integer :: typcrop(N_CFT), ityp -#endif -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/pctpft/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A43)') 'Aggregate plant function type fractions ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - ! add parameter input for time year - !write(cyear,'(i4.4)') lc_year - suffix = 'MOD'//trim(cyear) - - IF (p_is_io) THEN - CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) - CALL read_5x5_data_pft (dir_5x5, suffix, gland, 'PCT_PFT', pftPCT) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = N_PFT_modis) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate(pct_pfts (numpft)) - pct_pfts(:) = 0. - - DO ipatch = 1, numpatch - - wmo_pth = wmo_patch(landpatch%ielm(ipatch)) - IF (ipatch == wmo_pth) THEN - ipft = patch_pft_s(ipatch) - - pct_pfts(ipft) = 1. - - CYCLE - ENDIF - -#ifndef CROP - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN -#else - IF (patchtypes(landpatch%settyp(ipatch)) == 0 & - .and. landpatch%settyp(ipatch)/=CROPLAND) THEN -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, & - n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) - -#ifdef CROP - pct_pft_one(N_PFT_modis-1,:) = 0. -#endif - - pct_pft_one = max(pct_pft_one , 0.0) - pct_one = sum(pct_pft_one, dim=1) - pct_one = max(pct_one, 1.0e-6) - sumarea = sum(area_one) - - DO ipft = patch_pft_s(ipatch), patch_pft_e(ipatch) - p = landpft%settyp(ipft) - pct_pfts(ipft) = sum(pct_pft_one(p,:) / pct_one * area_one) / sumarea - ENDDO - - sum_pct_pfts = sum(pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch))) - - IF (sum_pct_pfts > 0) THEN - pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) = & - pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) / sum_pct_pfts - ELSE - ! in case of no PFT exist, but there is a patch type: - ! set bare soil 100%, be consistent with MOD_LandPFT.F90 - pct_pfts(patch_pft_s(ipatch)) = 1. - ENDIF - -#ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN - pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) = 1. -#endif - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - -#ifdef RangeCheck - CALL check_vector_data ('PCT_PFTs ', pct_pfts) -#endif - - lndname = trim(landdir)//'/pct_pfts.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpft, 'pft') - CALL ncio_write_vector (lndname, 'pct_pfts', 'pft', & - landpft, pct_pfts, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpft = (/(ipft, ipft = 0, N_PFT-1)/) - lndname = trim(dir_model_landdata)//'/diag/pftfrac_elm_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (pct_pfts, landpft%settyp, typpft, m_pft2diag, & - -1.0e36_r8, lndname, 'pftfrac_elm', compress = 1, write_mode = 'one', & - defval=0._r8, stat_mode = 'fraction', pctshared = landpft%pctshared, & - create_mode=.true.) -#endif - - IF (p_is_worker) THEN - IF (allocated(pct_pfts )) deallocate(pct_pfts ) - IF (allocated(pct_one )) deallocate(pct_one ) - IF (allocated(area_one )) deallocate(area_one ) - IF (allocated(pct_pft_one)) deallocate(pct_pft_one) - ENDIF - -#if (defined CROP) - lndname = trim(landdir)//'/pct_crops.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'pct_crops', 'patch', & - landpatch, cropfrac, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typcrop = (/(ityp, ityp = 1, N_CFT)/) - lndname = trim(dir_model_landdata) // '/diag/cropfrac_elm_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (cropfrac, cropclass, typcrop, m_patch2diag, & - -1.0e36_r8, lndname, 'cropfrac_elm', compress = 1, write_mode = 'one', & - defval=0._r8, stat_mode = 'fraction', pctshared = landpatch%pctshared, & - create_mode=.true.) -#endif -#endif - -#endif - -END SUBROUTINE Aggregation_PercentagesPFT diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 deleted file mode 100644 index 1c6286cbd4..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilBrightness.F90 +++ /dev/null @@ -1,409 +0,0 @@ -#include - -SUBROUTINE Aggregation_SoilBrightness ( & - gland, dir_rawdata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! Creates land model surface dataset from original "raw" data files - -! data with 30 arc seconds resolution -! -! Created by Yongjiu Dai, 03/2014 -! -! !REVISIONS: -! Shupeng Zhang, 01/2022: porting codes to MPI parallel version. -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFBlock - USE MOD_NetCDFVector -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - USE MOD_Vars_Global, only: spval - - IMPLICIT NONE - - ! arguments: - - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - - type (block_data_int32_2d) :: isc - type (block_data_real8_2d) :: a_s_v_refl - type (block_data_real8_2d) :: a_d_v_refl - type (block_data_real8_2d) :: a_s_n_refl - type (block_data_real8_2d) :: a_d_n_refl - - real(r8), allocatable :: soil_s_v_alb (:) - real(r8), allocatable :: soil_d_v_alb (:) - real(r8), allocatable :: soil_s_n_alb (:) - real(r8), allocatable :: soil_d_n_alb (:) - - integer :: ii, L - integer :: ipatch, iblkme, iblk, jblk, ix, iy - integer :: wmo_src - real(r8), allocatable :: soil_one(:) - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#endif - - ! ---------------------------------------------------------------------- - ! The soil color and reflectance is from the work: - ! Peter J. Lawrence and Thomas N. Chase, 2007: - ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0): - ! Part 1 generating MODIS consistent land surface parameters - real(r8) soil_s_v_refl(20) ! Saturated visible soil reflectance - real(r8) soil_d_v_refl(20) ! Dry visible soil reflectance - real(r8) soil_s_n_refl(20) ! Saturated near infrared soil reflectance - real(r8) soil_d_n_refl(20) ! Dry near infrared soil reflectance - - soil_s_v_refl = (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, & - 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /) - - soil_d_v_refl = (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, & - 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /) - - soil_s_n_refl = (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, & - 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /) - - soil_d_n_refl = (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, & - 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /) - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A29)') 'Aggregate Soil Brightness ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -! ------------------------------------------------------------------------------------- -! aggregate the soil parameters from the resolution of raw data to modelling resolution -! ------------------------------------------------------------------------------------- - - lndname = trim(dir_rawdata)//'/soil_brightness.nc' - - IF (p_is_io) THEN - - CALL allocate_block_data (gland, isc) - CALL allocate_block_data (gland, a_s_v_refl) - CALL allocate_block_data (gland, a_d_v_refl) - CALL allocate_block_data (gland, a_s_n_refl) - CALL allocate_block_data (gland, a_d_n_refl) - - ! Read in the index of soil brightness (color) - CALL ncio_read_block (lndname, 'soil_brightness', gland, isc) - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - DO iy = 1, gland%ycnt(jblk) - DO ix = 1, gland%xcnt(iblk) - - ii = isc%blk(iblk,jblk)%val(ix,iy) - IF ((ii >= 1) .and. (ii <= 20)) THEN - a_s_v_refl%blk(iblk,jblk)%val(ix,iy) = soil_s_v_refl( ii ) - a_d_v_refl%blk(iblk,jblk)%val(ix,iy) = soil_d_v_refl( ii ) - a_s_n_refl%blk(iblk,jblk)%val(ix,iy) = soil_s_n_refl( ii ) - a_d_n_refl%blk(iblk,jblk)%val(ix,iy) = soil_d_n_refl( ii ) - ELSE - a_s_v_refl%blk(iblk,jblk)%val(ix,iy) = spval - a_d_v_refl%blk(iblk,jblk)%val(ix,iy) = spval - a_s_n_refl%blk(iblk,jblk)%val(ix,iy) = spval - a_d_n_refl%blk(iblk,jblk)%val(ix,iy) = spval - ENDIF - - ENDDO - ENDDO - - ENDDO - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_io) THEN - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_s_v_refl) - ENDIF -#endif - - IF (p_is_worker) THEN - - allocate ( soil_s_v_alb (numpatch) ) - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - soil_s_v_alb(ipatch) = soil_s_v_alb(wmo_src) - - CYCLE - ENDIF - -#ifdef LULC_USGS - IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = a_s_v_refl, data_r8_2d_out1 = soil_one) - soil_s_v_alb (ipatch) = median (soil_one, size(soil_one), spval) - - ELSE - soil_s_v_alb (ipatch) = spval - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_io) THEN - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_d_v_refl) - ENDIF -#endif - - IF (p_is_worker) THEN - - allocate ( soil_d_v_alb (numpatch) ) - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - soil_d_v_alb(ipatch) = soil_d_v_alb(wmo_src) - - CYCLE - ENDIF - -#ifdef LULC_USGS - IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = a_d_v_refl, data_r8_2d_out1 = soil_one) - soil_d_v_alb (ipatch) = median (soil_one, size(soil_one), spval) - - ELSE - soil_d_v_alb (ipatch) = spval - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_io) THEN - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_s_n_refl) - ENDIF -#endif - - IF (p_is_worker) THEN - - allocate ( soil_s_n_alb (numpatch) ) - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - soil_s_n_alb(ipatch) = soil_s_n_alb(wmo_src) - - CYCLE - ENDIF - -#ifdef LULC_USGS - IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = a_s_n_refl, data_r8_2d_out1 = soil_one) - soil_s_n_alb (ipatch) = median (soil_one, size(soil_one), spval) - - ELSE - soil_s_n_alb (ipatch) = spval - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_io) THEN - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_d_n_refl) - ENDIF -#endif - - IF (p_is_worker) THEN - - allocate ( soil_d_n_alb (numpatch) ) - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - soil_d_n_alb(ipatch) = soil_d_n_alb(wmo_src) - - CYCLE - ENDIF - -#ifdef LULC_USGS - IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = a_d_n_refl, data_r8_2d_out1 = soil_one) - soil_d_n_alb (ipatch) = median (soil_one, size(soil_one), spval) - - ELSE - soil_d_n_alb (ipatch) = spval - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('s_v_alb ', soil_s_v_alb) - CALL check_vector_data ('d_v_alb ', soil_d_v_alb) - CALL check_vector_data ('s_n_alb ', soil_s_n_alb) - CALL check_vector_data ('d_n_alb ', soil_d_n_alb) -#endif - - ! (1) Write-out the albedo of visible of the saturated soil - lndname = trim(landdir)//'/soil_s_v_alb_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'soil_s_v_alb', 'patch', & - landpatch, soil_s_v_alb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (soil_s_v_alb, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'soil_s_v_alb', compress = 1, write_mode = 'one', create_mode=.true.) -#endif - - ! (2) Write-out the albedo of visible of the dry soil - lndname = trim(landdir)//'/soil_d_v_alb_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'soil_d_v_alb', 'patch', & - landpatch, soil_d_v_alb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (soil_d_v_alb, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'soil_d_v_alb', compress = 1, write_mode = 'one') -#endif - - ! (3) Write-out the albedo of near infrared of the saturated soil - lndname = trim(landdir)//'/soil_s_n_alb_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'soil_s_n_alb', 'patch', & - landpatch, soil_s_n_alb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (soil_s_n_alb, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'soil_s_n_alb', compress = 1, write_mode = 'one') -#endif - - ! (4) Write-out the albedo of near infrared of the dry soil - lndname = trim(landdir)//'/soil_d_n_alb_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'soil_d_n_alb', 'patch', & - landpatch, soil_d_n_alb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_brightness_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (soil_d_n_alb, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'soil_d_n_alb', compress = 1, write_mode = 'one') -#endif - - ! Deallocate the allocatable array - ! -------------------------------- - IF (p_is_worker) THEN - deallocate ( soil_s_v_alb ) - deallocate ( soil_d_v_alb ) - deallocate ( soil_s_n_alb ) - deallocate ( soil_d_n_alb ) - ENDIF - -END SUBROUTINE Aggregation_SoilBrightness -!----------------------------------------------------------------------- -!EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 deleted file mode 100644 index b7e0c1966a..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilHyperAlbedo.F90 +++ /dev/null @@ -1,166 +0,0 @@ -#include - -SUBROUTINE Aggregation_SoilHyperAlbedo ( & - gland, dir_rawdata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! Creates land model surface dataset from original "raw" data files - -! data with 30 arc seconds resolution -! -! Created by Yongjiu Dai, 03/2014 -! -! !REVISIONS: -! Shupeng Zhang, 01/2022: porting codes to MPI parallel version. -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Grid - USE MOD_LandPatch - USE MOD_NetCDFBlock - USE MOD_NetCDFVector -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - character(len=4) :: wavelength ! wavelength in nm - - ! type (block_data_real8_2d) :: a_s_v_refl - type (block_data_real8_2d) :: a_soil_hyper_alb - - ! real(r8), allocatable :: soil_s_v_alb (:) - real(r8), allocatable :: soil_hyper_alb (:) - - integer :: ii, L - integer :: ipatch, iblkme, iblk, jblk, ix, iy, wl - real(r8), allocatable :: soil_one(:) - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/HyperAlbedo/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A29)') 'Aggregate Hyper Albedo ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! 为 worker 在循环外分配一次，避免每次循环重复分配引发错误 - IF (p_is_worker) THEN - IF (.NOT. ALLOCATED(soil_hyper_alb)) ALLOCATE(soil_hyper_alb(numpatch)) - ENDIF - - DO wl = 400, 2500, 10 - IF (p_is_master) write(*,'(A, i0, A)') ' Processing wavelength (nm): ', wl, ' ...' - write(wavelength,'(i0)') wl - - ! Read in the hyper albedo - IF (p_is_io) THEN - - CALL allocate_block_data (gland, a_soil_hyper_alb) - lndname = trim(dir_rawdata)//'/colm_input_ghsad/colm_soil_albedo_'//trim(wavelength)//'nm.nc' - ! Read in the soil albedo - CALL ncio_read_block (lndname, 'albedo', gland, a_soil_hyper_alb) - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - DO iy = 1, gland%ycnt(jblk) - DO ix = 1, gland%xcnt(iblk) - a_soil_hyper_alb%blk(iblk,jblk)%val(ix,iy) = a_soil_hyper_alb%blk(iblk,jblk)%val(ix,iy) / 10000.0 - END DO - END DO - END DO - - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = a_soil_hyper_alb) -#endif - - ENDIF - - IF (p_is_worker) THEN - - ! allocate 已在循环外完成，移除这里的重复分配 - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) -#ifdef LULC_USGS - IF(L/=16 .and. L/=24)THEN ! NOT OCEAN(0)/WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = a_soil_hyper_alb, data_r8_2d_out1 = soil_one) - soil_hyper_alb (ipatch) = median (soil_one, size(soil_one)) - - ELSE - soil_hyper_alb (ipatch) = -1.0e36_r8 - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF ! IF (p_is_worker) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('soil_hyper_alb ', soil_hyper_alb) -#endif - - ! Write-out the hyper spectral soil albedo - lndname = trim(landdir)//'/soil_hyper_alb_'//trim(wavelength)//'nm_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'soil_hyper_alb', 'patch', & - landpatch, soil_hyper_alb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_hyper_alb_' // trim(wavelength) // 'nm_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (soil_hyper_alb, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'soil_hyper_alb', compress = 1, write_mode = 'one') -#endif - - END DO ! loop over "wl" - - ! Deallocate the allocatable array - ! -------------------------------- - IF (p_is_worker) THEN - deallocate ( soil_hyper_alb ) - ENDIF - -END SUBROUTINE Aggregation_SoilHyperAlbedo -!----------------------------------------------------------------------- -!EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 deleted file mode 100644 index 2c30ba0244..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilParameters.F90 +++ /dev/null @@ -1,2042 +0,0 @@ -#include - -SUBROUTINE Aggregation_SoilParameters ( & - gland, dir_rawdata, dir_model_landdata, lc_year) - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Create soil hydraulic and thermal parameters for the modeling reolustion -! -! !REFERENCES: -! 1) Dai, Y., Q. Xin, N. Wei, Y. Zhang, W. Shangguan, H. Yuan, S. Zhang, S. -! Liu, X. Lu, 2019. A global high-resolution dataset of soil hydraulic and -! thermal properties for land surface modeling. Journal of Advances in -! Modeling Earth Systems,11, 2996-3023. -! -! 2) Dai, Y., N. Wei, H. Yuan, S. Zhang, W. Shangguan, S. Liu, and X. Lu, 2019. -! Evaluation of soil thermal conductivity schemes for use in land surface -! modelling, Journal of Advances in Modeling Earth Systems, 11, 3454-3473. -! -! 3) Dai, Y., W. Shangguan, Q. Duan, B. Liu, S. Fu, and G. Niu, 2013. -! Development of a China dataset of soil hydraulic parameters using -! pedotransfer functions for land surface modeling. Journal of -! Hydrometeorology 14, 869-887 -! -! Original author: Yongjiu Dai and Wei Shangguan, 02/2014 -! -! !REVISIONS: -! 06/2019, Nan Wei: add algorithms of fitting soil water retention curves to -! aggregate soil hydraulic parameters from pixels to a patch. -! -! 01/2022, Shupeng Zhang and Nan Wei: porting codes to MPI parallel version. -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFBlock - USE MOD_NetCDFVector - USE MOD_AggregationRequestData -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_Utils - USE MOD_UserDefFun -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - character(len=256) :: c - integer :: nsl, ipatch, L, np, LL, ipxstt, ipxend - integer :: wmo_src - - type (block_data_real8_2d) :: vf_quartz_mineral_s_grid - type (block_data_real8_2d) :: vf_gravels_s_grid - type (block_data_real8_2d) :: vf_om_s_grid - type (block_data_real8_2d) :: vf_sand_s_grid - type (block_data_real8_2d) :: vf_clay_s_grid - type (block_data_real8_2d) :: wf_gravels_s_grid - type (block_data_real8_2d) :: wf_sand_s_grid - type (block_data_real8_2d) :: wf_om_s_grid - type (block_data_real8_2d) :: wf_clay_s_grid - type (block_data_real8_2d) :: OM_density_s_grid - type (block_data_real8_2d) :: BD_all_s_grid - type (block_data_real8_2d) :: theta_s_grid - type (block_data_real8_2d) :: psi_s_grid - type (block_data_real8_2d) :: lambda_grid -#ifdef vanGenuchten_Mualem_SOIL_MODEL - type (block_data_real8_2d) :: theta_r_grid - type (block_data_real8_2d) :: alpha_vgm_grid - type (block_data_real8_2d) :: L_vgm_grid - type (block_data_real8_2d) :: n_vgm_grid -#endif - type (block_data_real8_2d) :: k_s_grid - type (block_data_real8_2d) :: csol_grid - type (block_data_real8_2d) :: tksatu_grid - type (block_data_real8_2d) :: tksatf_grid - type (block_data_real8_2d) :: tkdry_grid - type (block_data_real8_2d) :: k_solids_grid - - real(r8), allocatable :: vf_quartz_mineral_s_patches (:) - real(r8), allocatable :: vf_gravels_s_patches (:) - real(r8), allocatable :: vf_om_s_patches (:) - real(r8), allocatable :: vf_sand_s_patches (:) - real(r8), allocatable :: vf_clay_s_patches (:) - real(r8), allocatable :: wf_gravels_s_patches (:) - real(r8), allocatable :: wf_sand_s_patches (:) - real(r8), allocatable :: wf_om_s_patches (:) - real(r8), allocatable :: wf_clay_s_patches (:) - real(r8), allocatable :: OM_density_s_patches (:) - real(r8), allocatable :: BD_all_s_patches (:) - real(r8), allocatable :: theta_s_patches (:) - real(r8), allocatable :: psi_s_patches (:) - real(r8), allocatable :: lambda_patches (:) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8), allocatable :: theta_r_patches (:) - real(r8), allocatable :: alpha_vgm_patches (:) - real(r8), allocatable :: L_vgm_patches (:) - real(r8), allocatable :: n_vgm_patches (:) -#endif - real(r8), allocatable :: k_s_patches (:) - real(r8), allocatable :: csol_patches (:) - real(r8), allocatable :: tksatu_patches (:) - real(r8), allocatable :: tksatf_patches (:) - real(r8), allocatable :: tkdry_patches (:) - real(r8), allocatable :: k_solids_patches (:) - real(r8), allocatable :: BA_alpha_patches (:) - real(r8), allocatable :: BA_beta_patches (:) - - real(r8), allocatable :: vf_quartz_mineral_s_one (:) - real(r8), allocatable :: vf_gravels_s_one (:) - real(r8), allocatable :: vf_om_s_one (:) - real(r8), allocatable :: vf_sand_s_one (:) - real(r8), allocatable :: vf_clay_s_one (:) - real(r8), allocatable :: wf_gravels_s_one (:) - real(r8), allocatable :: wf_sand_s_one (:) - real(r8), allocatable :: wf_om_s_one (:) - real(r8), allocatable :: wf_clay_s_one (:) - real(r8), allocatable :: OM_density_s_one (:) - real(r8), allocatable :: BD_all_s_one (:) - real(r8), allocatable :: theta_s_one (:) - real(r8), allocatable :: psi_s_one (:) - real(r8), allocatable :: lambda_one (:) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8), allocatable :: theta_r_one (:) - real(r8), allocatable :: alpha_vgm_one (:) - real(r8), allocatable :: L_vgm_one (:) - real(r8), allocatable :: n_vgm_one (:) -#endif - real(r8), allocatable :: k_s_one (:) - real(r8), allocatable :: csol_one (:) - real(r8), allocatable :: tksatu_one (:) - real(r8), allocatable :: tksatf_one (:) - real(r8), allocatable :: tkdry_one (:) - real(r8), allocatable :: k_solids_one (:) - real(r8), allocatable :: area_one (:) - real(r8), allocatable :: BA_alpha_one (:) - real(r8), allocatable :: BA_beta_one (:) - -! local variables for estimating the upscaled soil parameters using the Levenberg-Marquardt fitting method -! --------------------------------------------------------------- - integer, parameter :: npointw = 24 - integer, parameter :: npointb = 20 - real(r8),parameter :: xdat(npointw) = (/1.,5.,10.,20.,30.,40.,50.,60.,70.,90.,110.,130.,150.,& - 170.,210.,300.,345.,690.,1020.,5100.,15300.,20000.,100000.,1000000./) - ! points of soil pressure heads used for fitting SW retention curves - - real(r8),parameter :: xdatsr(npointb)=(/0.05,0.1,0.15,0.2,0.25,0.3,0.35,0.4,0.45,0.5,0.55,0.6,& - 0.65,0.7,0.75,0.8,0.85,0.9,0.95,1.0/) - ! points of soil saturation levels (Sr) used for fitting Ke-Sr relationship - - real(r8),allocatable :: ydatc (:,:) ! the Campbell SW retentions at fine grids - real(r8),allocatable :: ydatcks(:,:) ! the Campbell SW hydraulic conductivity at fine grids - real(r8),allocatable :: ydatv (:,:) ! the van Genuchten & Mualem SW retentions at fine grids - real(r8),allocatable :: ydatvks(:,:) ! the van Genuchten & Mualem SW hydraulic conductivity at fine grids - real(r8),allocatable :: THETA (:) ! the van Genuchten & Mualem relative SW at fine grids - real(r8),allocatable :: ydatb(:,:) ! the Balland and Arp (2005) Ke-Sr relationship at fine grids - - integer, parameter :: nc = 3 ! the number of fitted parameters in Campbell SW retention curve (psi and lambda) - integer, parameter :: nv = 4 ! the number of fitted parameters in van Genuchten SW retention curve - ! (theta_r, alpha and n) - integer, parameter :: nb = 2 ! the number of fitted parameters in Ke-Sr relationship (alpha and beta) - -! Variables needed for Levenberg-Marquardt algorithm in MINPACK library - real(r8),parameter :: factor = 0.1 - real(r8),parameter :: ftol = 1.0e-5 - real(r8),parameter :: xtol = 1.0e-4 - real(r8),parameter :: gtol = 0.0 - integer, parameter :: mode = 1 - integer, parameter :: nprint = 0 - integer :: ldfjac,info,ipvtc(nc),ipvtv(nv),ipvtb(nb),maxfev,nfev,njev - real(r8) :: xc(nc),xv(nv),xb(nb),diagc(nc),diagv(nv),diagb(nb),qtfc(nc),qtfv(nv),qtfb(nb) - real(r8),allocatable :: fjacc(:,:),fvecc(:),fjacv(:,:),fvecv(:),fjacb(:,:),fvecb(:) - integer isiter ! flags to tell whether the iteration is completed, 1=Yes, 0=No - - ! Parameters to fill water body patches - real(r8), parameter :: vf_quartz_mineral_fill_water(8) = 0.1 - real(r8), parameter :: vf_gravels_fill_water(8) = 0.0 - real(r8), parameter :: vf_sand_fill_water(8) = 0.09 - real(r8), parameter :: vf_clay_fill_water(8) = 0.189 - real(r8), parameter :: vf_om_fill_water(8) = 0.102 - real(r8), parameter :: wf_gravels_fill_water(8) = 0.0 - real(r8), parameter :: wf_sand_fill_water(8) = 0.1 - real(r8), parameter :: wf_om_fill_water(8) = 0.1 - real(r8), parameter :: wf_clay_fill_water(8) = 0.2 - real(r8), parameter :: theta_r_fill_water(8) = 0.116 - real(r8), parameter :: alpha_vgm_fill_water(8) = 0.01 - real(r8), parameter :: n_vgm_fill_water(8) = 1.352 - real(r8), parameter :: theta_s_fill_water(8) = 0.532 - real(r8), parameter :: k_s_fill_water(8) = 11.616 - real(r8), parameter :: L_vgm_fill_water(8) = 0.5 - real(r8), parameter :: psi_s_fill_water(8) = -35.446 - real(r8), parameter :: lambda_fill_water(8) = 0.108 - real(r8), parameter :: csol_fill_water(8) = 1.102e6 - real(r8), parameter :: tksatu_fill_water(8) = 1.145 - real(r8), parameter :: tksatf_fill_water(8) = 2.401 - real(r8), parameter :: tkdry_fill_water(8) = 0.136 - real(r8), parameter :: k_solids_fill_water(8) = 1.545 - real(r8), parameter :: OM_density_fill_water(8) = 62.064 - real(r8), parameter :: BD_all_fill_water(8) = 1200 - real(r8), parameter :: BA_alpha_fill_water(8) = 0.2 - real(r8), parameter :: BA_beta_fill_water (8) = 10 - - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#endif - - external SW_CB_dist ! the objective function to be fitted for Campbell SW retention curve - external SW_VG_dist ! the objective function to be fitted for van Genuchten SW retention curve -! external Ke_Sr_dist ! the objective function to be fitted for Balland and Arp (2005) Ke-Sr relationship - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) - -! --------------------------------------------------------------------------------------------- -! ... [2] aggregate the soil parameters from the resolution of raw data to modelling resolution -! --------------------------------------------------------------------------------------------- -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A29)') 'Aggregate Soil Parameters ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_worker) THEN - - allocate ( vf_quartz_mineral_s_patches(numpatch) ) - allocate ( vf_gravels_s_patches (numpatch) ) - allocate ( vf_om_s_patches (numpatch) ) - allocate ( vf_sand_s_patches (numpatch) ) - allocate ( vf_clay_s_patches (numpatch) ) - allocate ( wf_gravels_s_patches (numpatch) ) - allocate ( wf_sand_s_patches (numpatch) ) - allocate ( wf_om_s_patches (numpatch) ) - allocate ( wf_clay_s_patches (numpatch) ) - allocate ( OM_density_s_patches (numpatch) ) - allocate ( BD_all_s_patches (numpatch) ) - allocate ( theta_s_patches (numpatch) ) - allocate ( psi_s_patches (numpatch) ) - allocate ( lambda_patches (numpatch) ) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - allocate ( theta_r_patches (numpatch) ) - allocate ( alpha_vgm_patches (numpatch) ) - allocate ( L_vgm_patches (numpatch) ) - allocate ( n_vgm_patches (numpatch) ) -#endif - allocate ( k_s_patches (numpatch) ) - allocate ( csol_patches (numpatch) ) - allocate ( tksatu_patches (numpatch) ) - allocate ( tksatf_patches (numpatch) ) - allocate ( tkdry_patches (numpatch) ) - allocate ( k_solids_patches (numpatch) ) - allocate ( BA_alpha_patches (numpatch) ) - allocate ( BA_beta_patches (numpatch) ) - - ENDIF - - DO nsl = 1, 8 - - write(c,'(i1)') nsl - - ! (1) volumetric fraction of quartz within mineral soil - IF (p_is_io) THEN - - CALL allocate_block_data (gland, vf_quartz_mineral_s_grid) - lndname = trim(dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' - CALL ncio_read_block (lndname, 'vf_quartz_mineral_s_l'//trim(c), gland, vf_quartz_mineral_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_quartz_mineral_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - vf_quartz_mineral_s_patches (ipatch) = vf_quartz_mineral_s_patches (wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = vf_quartz_mineral_s_grid, data_r8_2d_out1 = vf_quartz_mineral_s_one) - CALL fillnan (vf_quartz_mineral_s_one, L == WATERBODY, vf_quartz_mineral_fill_water(nsl)) - CALL fillnan (vf_quartz_mineral_s_one, L == GLACIERS , vf_quartz_mineral_fill_water(nsl)) - vf_quartz_mineral_s_patches (ipatch) = sum (vf_quartz_mineral_s_one * (area_one/sum(area_one))) - ELSE - vf_quartz_mineral_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(vf_quartz_mineral_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in vf_quartz_mineral_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('vf_quartz_mineral_s lev '//trim(c), vf_quartz_mineral_s_patches) -#endif - - lndname = trim(landdir)//'/vf_quartz_mineral_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'vf_quartz_mineral_s_l'//trim(c)//'_patches', 'patch',& - landpatch, vf_quartz_mineral_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (vf_quartz_mineral_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'vf_quartz_mineral_s_l'//trim(c), compress = 1, write_mode = 'one', & - create_mode = (nsl==1)) -#endif - - ! (2) volumetric fraction of gravels - ! (3) volumetric fraction of sand - ! (4) volumetric fraction of organic matter - ! with the parameter alpha and beta in the Balland V. and P. A. Arp (2005) model - IF (p_is_io) THEN - - CALL allocate_block_data (gland, vf_gravels_s_grid) - lndname = trim(dir_rawdata)//'/soil/vf_gravels_s.nc' - CALL ncio_read_block (lndname, 'vf_gravels_s_l'//trim(c), gland, vf_gravels_s_grid) - - CALL allocate_block_data (gland, vf_sand_s_grid) - lndname = trim(dir_rawdata)//'/soil/vf_sand_s.nc' - CALL ncio_read_block (lndname, 'vf_sand_s_l'//trim(c), gland, vf_sand_s_grid) - - CALL allocate_block_data (gland, vf_om_s_grid) - lndname = trim(dir_rawdata)//'/soil/vf_om_s.nc' - CALL ncio_read_block (lndname, 'vf_om_s_l'//trim(c), gland, vf_om_s_grid) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_gravels_s_grid, & - data_r8_2d_in2 = vf_sand_s_grid, data_r8_2d_in3 = vf_om_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - vf_gravels_s_patches (ipatch) = vf_gravels_s_patches (wmo_src) - vf_sand_s_patches (ipatch) = vf_sand_s_patches (wmo_src) - vf_om_s_patches (ipatch) = vf_om_s_patches (wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = vf_gravels_s_grid, data_r8_2d_out1 = vf_gravels_s_one, & - data_r8_2d_in2 = vf_sand_s_grid, data_r8_2d_out2 = vf_sand_s_one, & - data_r8_2d_in3 = vf_om_s_grid, data_r8_2d_out3 = vf_om_s_one) - - CALL fillnan (vf_gravels_s_one, L == WATERBODY, vf_gravels_fill_water(nsl)) - CALL fillnan (vf_sand_s_one , L == WATERBODY, vf_sand_fill_water(nsl) ) - CALL fillnan (vf_om_s_one , L == WATERBODY, vf_om_fill_water(nsl) ) - - CALL fillnan (vf_gravels_s_one, L == GLACIERS , vf_gravels_fill_water(nsl)) - CALL fillnan (vf_sand_s_one , L == GLACIERS , vf_sand_fill_water(nsl) ) - CALL fillnan (vf_om_s_one , L == GLACIERS , vf_om_fill_water(nsl) ) - - vf_gravels_s_patches (ipatch) = sum (vf_gravels_s_one * (area_one/sum(area_one))) - vf_sand_s_patches (ipatch) = sum (vf_sand_s_one * (area_one/sum(area_one))) - vf_om_s_patches (ipatch) = sum (vf_om_s_one * (area_one/sum(area_one))) - - ! the parameter values of Balland and Arp (2005) Ke-Sr relationship, - ! modified by Barry-Macaulay et al.(2015), Evaluation of soil thermal conductivity models - - allocate(BA_alpha_one (size(area_one))) - allocate(BA_beta_one (size(area_one))) - WHERE ((vf_gravels_s_one + vf_sand_s_one) > 0.4) - BA_alpha_one = 0.38 - BA_beta_one = 35.0 - ELSEWHERE ((vf_gravels_s_one + vf_sand_s_one) > 0.25) - BA_alpha_one = 0.24 - BA_beta_one = 26.0 - ELSEWHERE - BA_alpha_one = 0.2 - BA_beta_one = 10.0 - END WHERE - - BA_alpha_patches (ipatch) = median (BA_alpha_one, size(BA_alpha_one), spval) - BA_beta_patches (ipatch) = median (BA_beta_one, size(BA_beta_one), spval) - - deallocate(BA_alpha_one) - deallocate(BA_beta_one) - - ELSE - vf_gravels_s_patches (ipatch) = -1.0e36_r8 - vf_sand_s_patches (ipatch) = -1.0e36_r8 - vf_om_s_patches (ipatch) = -1.0e36_r8 - BA_alpha_patches (ipatch) = -1.0e36_r8 - BA_beta_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(vf_gravels_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in vf_gravels_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(vf_sand_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in vf_sand_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(vf_om_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in vf_om_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(BA_alpha_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in BA_alpha_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(BA_beta_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in BA_beta_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('vf_gravels_s lev '//trim(c), vf_gravels_s_patches) - CALL check_vector_data ('vf_sand_s lev '//trim(c), vf_sand_s_patches) - CALL check_vector_data ('vf_om_s lev '//trim(c), vf_om_s_patches) - CALL check_vector_data ('BA_alpha lev '//trim(c), BA_alpha_patches) - CALL check_vector_data ('BA_beta lev '//trim(c), BA_beta_patches) -#endif - - lndname = trim(landdir)//'/vf_gravels_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'vf_gravels_s_l'//trim(c)//'_patches', 'patch',& - landpatch, vf_gravels_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (vf_gravels_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'vf_gravels_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/vf_sand_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'vf_sand_s_l'//trim(c)//'_patches', 'patch',& - landpatch, vf_sand_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (vf_sand_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'vf_sand_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/vf_om_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'vf_om_s_l'//trim(c)//'_patches', 'patch',& - landpatch, vf_om_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (vf_om_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'vf_om_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/BA_alpha_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'BA_alpha_l'//trim(c)//'_patches', 'patch',& - landpatch, BA_alpha_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (BA_alpha_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'BA_alpha_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/BA_beta_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'BA_beta_l'//trim(c)//'_patches', 'patch',& - landpatch, BA_beta_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (BA_beta_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'BA_beta_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (5) gravimetric fraction of gravels - IF (p_is_io) THEN - - CALL allocate_block_data (gland, wf_gravels_s_grid) - lndname = trim(dir_rawdata)//'/soil/wf_gravels_s.nc' - CALL ncio_read_block (lndname, 'wf_gravels_s_l'//trim(c), gland, wf_gravels_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_gravels_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - wf_gravels_s_patches (ipatch) = wf_gravels_s_patches (wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = wf_gravels_s_grid, data_r8_2d_out1 = wf_gravels_s_one) - CALL fillnan (wf_gravels_s_one, L == WATERBODY, wf_gravels_fill_water(nsl)) - CALL fillnan (wf_gravels_s_one, L == GLACIERS , wf_gravels_fill_water(nsl)) - wf_gravels_s_patches (ipatch) = sum (wf_gravels_s_one * (area_one/sum(area_one))) - ELSE - wf_gravels_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(wf_gravels_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in wf_gravels_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('wf_gravels_s lev '//trim(c), wf_gravels_s_patches) -#endif - - lndname = trim(landdir)//'/wf_gravels_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'wf_gravels_s_l'//trim(c)//'_patches', 'patch',& - landpatch, wf_gravels_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (wf_gravels_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'wf_gravels_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (6) gravimetric fraction of sand - IF (p_is_io) THEN - - CALL allocate_block_data (gland, wf_sand_s_grid) - lndname = trim(dir_rawdata)//'/soil/wf_sand_s.nc' - CALL ncio_read_block (lndname, 'wf_sand_s_l'//trim(c), gland, wf_sand_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_sand_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - wf_sand_s_patches (ipatch) = wf_sand_s_patches (wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = wf_sand_s_grid, data_r8_2d_out1 = wf_sand_s_one) - CALL fillnan (wf_sand_s_one, L == WATERBODY, wf_sand_fill_water(nsl)) - CALL fillnan (wf_sand_s_one, L == GLACIERS , wf_sand_fill_water(nsl)) - wf_sand_s_patches (ipatch) = sum (wf_sand_s_one * (area_one/sum(area_one))) - ELSE - wf_sand_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(wf_sand_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in wf_sand_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('wf_sand_s lev '//trim(c), wf_sand_s_patches) -#endif - - lndname = trim(landdir)//'/wf_sand_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'wf_sand_s_l'//trim(c)//'_patches', 'patch',& - landpatch, wf_sand_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (wf_sand_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'wf_sand_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - - ! (7) VGM's pore-connectivity parameter (L) - ! (8) VGM's residual water content (theta_r) [cm3/cm3] - ! (9) VGM's parameter corresponding approximately to the inverse of the air-entry value (alpha) - ! (10) VGM's shape parameter (n) - ! (11) saturated water content [cm3/cm3] - ! (12) saturated hydraulic conductivity [cm/day] - - IF (p_is_io) THEN - - CALL allocate_block_data (gland, L_vgm_grid) - lndname = trim(dir_rawdata)//'/soil/VGM_L.nc' - CALL ncio_read_block (lndname, 'VGM_L_l'//trim(c), gland, L_vgm_grid) - - CALL allocate_block_data (gland, theta_r_grid) - lndname = trim(dir_rawdata)//'/soil/VGM_theta_r.nc' - CALL ncio_read_block (lndname, 'VGM_theta_r_l'//trim(c), gland, theta_r_grid) - - CALL allocate_block_data (gland, alpha_vgm_grid) - lndname = trim(dir_rawdata)//'/soil/VGM_alpha.nc' - CALL ncio_read_block (lndname, 'VGM_alpha_l'//trim(c), gland, alpha_vgm_grid) - - CALL allocate_block_data (gland, n_vgm_grid) - lndname = trim(dir_rawdata)//'/soil/VGM_n.nc' - CALL ncio_read_block (lndname, 'VGM_n_l'//trim(c), gland, n_vgm_grid) - - CALL allocate_block_data (gland, theta_s_grid) - lndname = trim(dir_rawdata)//'/soil/theta_s.nc' - CALL ncio_read_block (lndname, 'theta_s_l'//trim(c), gland, theta_s_grid) - - CALL allocate_block_data (gland, k_s_grid) - lndname = trim(dir_rawdata)//'/soil/k_s.nc' - CALL ncio_read_block (lndname, 'k_s_l'//trim(c), gland, k_s_grid) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, & - data_r8_2d_in1 = theta_r_grid, data_r8_2d_in2 = alpha_vgm_grid, & - data_r8_2d_in3 = n_vgm_grid, data_r8_2d_in4 = theta_s_grid, & - data_r8_2d_in5 = k_s_grid, data_r8_2d_in6 = L_vgm_grid ) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - theta_r_patches (ipatch) = theta_r_patches (wmo_src) - alpha_vgm_patches (ipatch) = alpha_vgm_patches (wmo_src) - n_vgm_patches (ipatch) = n_vgm_patches (wmo_src) - theta_s_patches (ipatch) = theta_s_patches (wmo_src) - k_s_patches (ipatch) = k_s_patches (wmo_src) - L_vgm_patches (ipatch) = L_vgm_patches (wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = theta_r_grid, data_r8_2d_out1 = theta_r_one, & - data_r8_2d_in2 = alpha_vgm_grid, data_r8_2d_out2 = alpha_vgm_one, & - data_r8_2d_in3 = n_vgm_grid, data_r8_2d_out3 = n_vgm_one, & - data_r8_2d_in4 = theta_s_grid, data_r8_2d_out4 = theta_s_one, & - data_r8_2d_in5 = k_s_grid, data_r8_2d_out5 = k_s_one, & - data_r8_2d_in6 = L_vgm_grid, data_r8_2d_out6 = L_vgm_one ) - - CALL fillnan (theta_r_one , L == WATERBODY, theta_r_fill_water(nsl) ) - CALL fillnan (alpha_vgm_one, L == WATERBODY, alpha_vgm_fill_water(nsl)) - CALL fillnan (n_vgm_one , L == WATERBODY, n_vgm_fill_water(nsl) ) - CALL fillnan (theta_s_one , L == WATERBODY, theta_s_fill_water(nsl) ) - CALL fillnan (k_s_one , L == WATERBODY, k_s_fill_water(nsl) ) - CALL fillnan (L_vgm_one , L == WATERBODY, L_vgm_fill_water(nsl) ) - - CALL fillnan (theta_r_one , L == GLACIERS , theta_r_fill_water(nsl) ) - CALL fillnan (alpha_vgm_one, L == GLACIERS , alpha_vgm_fill_water(nsl)) - CALL fillnan (n_vgm_one , L == GLACIERS , n_vgm_fill_water(nsl) ) - CALL fillnan (theta_s_one , L == GLACIERS , theta_s_fill_water(nsl) ) - CALL fillnan (k_s_one , L == GLACIERS , k_s_fill_water(nsl) ) - CALL fillnan (L_vgm_one , L == GLACIERS , L_vgm_fill_water(nsl) ) - - theta_r_patches (ipatch) = sum (theta_r_one * (area_one/sum(area_one))) - alpha_vgm_patches (ipatch) = median (alpha_vgm_one, size(alpha_vgm_one), spval) - n_vgm_patches (ipatch) = median (n_vgm_one, size(n_vgm_one), spval) - theta_s_patches (ipatch) = sum (theta_s_one * (area_one/sum(area_one))) - k_s_patches (ipatch) = product(k_s_one**(area_one/sum(area_one))) - L_vgm_patches (ipatch) = median (L_vgm_one, size(L_vgm_one), spval) - - IF (DEF_USE_SOILPAR_UPS_FIT) THEN - np = size(theta_r_one) - - IF( np > 1 ) THEN - allocate ( ydatv (1:np,npointw) ) - allocate ( ydatvks(1:np,npointw) ) - allocate ( THETA ( npointw) ) -! the jacobian matrix required in Levenberg-Marquardt fitting method - allocate ( fjacv (npointw,nv) ) ! calculated in SW_VG_dist -! the values of objective functions to be fitted - allocate ( fvecv (npointw) ) ! calculated in SW_VG_dist - -! SW VG retentions and hydraulic conductivity at fine grids for each patch - DO LL = 1,np - THETA = (1 + (alpha_vgm_one(LL)*xdat)**n_vgm_one(LL))**(1.0/n_vgm_one(LL)-1) - ydatv(LL,:) = theta_r_one(LL)+(theta_s_one(LL) - theta_r_one(LL)) * THETA - ydatvks(LL,:) = k_s_one(LL) * THETA**L_vgm_one(LL) & - * (1-(1-THETA**(n_vgm_one(LL)/(n_vgm_one(LL)-1)))**(1.0-1.0/n_vgm_one(LL)))**2 - ENDDO - -! Fitting the van Genuchten SW retention parameters - ldfjac = npointw - xv(1) = theta_r_patches (ipatch) - xv(2) = alpha_vgm_patches (ipatch) - xv(3) = n_vgm_patches (ipatch) - xv(4) = k_s_patches (ipatch) - maxfev = 100 * ( nv + 1 ) - isiter = 1 - - CALL lmder ( SW_VG_dist, npointw, nv, xv, fvecv, fjacv, ldfjac, ftol, xtol, gtol, maxfev, & - diagv, mode, factor, nprint, info, nfev, njev, ipvtv, qtfv,& - xdat, npointw, ydatv, ydatvks, np, theta_s_patches(ipatch),& - k_s_patches (ipatch), isiter, L_vgm_patches (ipatch)) - - IF ( xv(1) >= 0.0 .and. xv(1) <= theta_s_patches(ipatch) .and. xv(2) >= 1.0e-5 .and. xv(2) <= 1.0 .and. & - xv(3) >= 1.1 .and. xv(3) <= 10.0 .and. xv(4) > 0.0 .and. xv(4) <= 1.0e7 .and. isiter == 1) THEN - theta_r_patches(ipatch) = xv(1) - alpha_vgm_patches(ipatch) = xv(2) - n_vgm_patches(ipatch) = xv(3) - k_s_patches (ipatch) = xv(4) - ENDIF - - deallocate(ydatv) - deallocate(ydatvks) - deallocate(THETA) - deallocate(fjacv) - deallocate(fvecv) - - ENDIF - ENDIF - - ELSE - theta_r_patches (ipatch) = -1.0e36_r8 - alpha_vgm_patches (ipatch) = -1.0e36_r8 - n_vgm_patches (ipatch) = -1.0e36_r8 - theta_s_patches (ipatch) = -1.0e36_r8 - k_s_patches (ipatch) = -1.0e36_r8 - L_vgm_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(theta_r_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in theta_r_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(alpha_vgm_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in alpha_vgm_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(n_vgm_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in n_vgm_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(theta_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in theta_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(k_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in k_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(L_vgm_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in L_vgm_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('theta_r lev '//trim(c), theta_r_patches) - CALL check_vector_data ('alpha VGM lev '//trim(c), alpha_vgm_patches) - CALL check_vector_data ('n VGM lev '//trim(c), n_vgm_patches) - CALL check_vector_data ('theta_s lev '//trim(c), theta_s_patches) - CALL check_vector_data ('k_s lev '//trim(c), k_s_patches) - CALL check_vector_data ('L VGM lev '//trim(c), L_vgm_patches) -#endif - - lndname = trim(landdir)//'/theta_r_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'theta_r_l'//trim(c)//'_patches', 'patch', landpatch, & - theta_r_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (theta_r_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'theta_r_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/alpha_vgm_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'alpha_vgm_l'//trim(c)//'_patches', 'patch', landpatch, & - alpha_vgm_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (alpha_vgm_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'alpha_vgm_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/n_vgm_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'n_vgm_l'//trim(c)//'_patches', 'patch', landpatch, & - n_vgm_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (n_vgm_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'n_vgm_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/theta_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'theta_s_l'//trim(c)//'_patches', 'patch', landpatch, & - theta_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (theta_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'theta_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/k_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'k_s_l'//trim(c)//'_patches', 'patch', landpatch, & - k_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (k_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'k_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/L_vgm_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'L_vgm_l'//trim(c)//'_patches', 'patch', landpatch, & - L_vgm_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (L_vgm_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'L_vgm_l'//trim(c), compress = 1, write_mode = 'one') -#endif - -#endif - - ! (11) saturated water content [cm3/cm3] - ! (12) saturated hydraulic conductivity [cm/day] - ! (13) matric potential at saturation (psi_s) [cm] - ! (14) pore size distribution index [dimensionless] - - IF (p_is_io) THEN - - CALL allocate_block_data (gland, theta_s_grid) - lndname = trim(dir_rawdata)//'/soil/theta_s.nc' - CALL ncio_read_block (lndname, 'theta_s_l'//trim(c), gland, theta_s_grid) - - CALL allocate_block_data (gland, k_s_grid) - lndname = trim(dir_rawdata)//'/soil/k_s.nc' - CALL ncio_read_block (lndname, 'k_s_l'//trim(c), gland, k_s_grid) - - CALL allocate_block_data (gland, psi_s_grid) - lndname = trim(dir_rawdata)//'/soil/psi_s.nc' - CALL ncio_read_block (lndname, 'psi_s_l'//trim(c), gland, psi_s_grid) - - CALL allocate_block_data (gland, lambda_grid) - lndname = trim(dir_rawdata)//'/soil/lambda.nc' - CALL ncio_read_block (lndname, 'lambda_l'//trim(c), gland, lambda_grid) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = theta_s_grid, data_r8_2d_in2 = k_s_grid, & - data_r8_2d_in3 = psi_s_grid, data_r8_2d_in4 = lambda_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - theta_s_patches (ipatch) = theta_s_patches (wmo_src) - k_s_patches (ipatch) = k_s_patches (wmo_src) - psi_s_patches (ipatch) = psi_s_patches (wmo_src) - lambda_patches (ipatch) = lambda_patches (wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = theta_s_grid, data_r8_2d_out1 = theta_s_one, & - data_r8_2d_in2 = k_s_grid, data_r8_2d_out2 = k_s_one, & - data_r8_2d_in3 = psi_s_grid, data_r8_2d_out3 = psi_s_one, & - data_r8_2d_in4 = lambda_grid, data_r8_2d_out4 = lambda_one) - - CALL fillnan (theta_s_one, L == WATERBODY, theta_s_fill_water(nsl)) - CALL fillnan (k_s_one , L == WATERBODY, k_s_fill_water(nsl) ) - CALL fillnan (psi_s_one , L == WATERBODY, psi_s_fill_water(nsl) ) - CALL fillnan (lambda_one , L == WATERBODY, lambda_fill_water(nsl) ) - - CALL fillnan (theta_s_one, L == GLACIERS , theta_s_fill_water(nsl)) - CALL fillnan (k_s_one , L == GLACIERS , k_s_fill_water(nsl)) - CALL fillnan (psi_s_one , L == GLACIERS , psi_s_fill_water(nsl) ) - CALL fillnan (lambda_one , L == GLACIERS , lambda_fill_water(nsl) ) - - theta_s_patches (ipatch) = sum (theta_s_one * (area_one/sum(area_one))) - k_s_patches (ipatch) = product(k_s_one**(area_one/sum(area_one))) - psi_s_patches (ipatch) = median (psi_s_one, size(psi_s_one), spval) - lambda_patches (ipatch) = median (lambda_one, size(lambda_one), spval) - - IF (DEF_USE_SOILPAR_UPS_FIT) THEN - np = size(psi_s_one) - - IF( np > 1 ) THEN - allocate ( ydatc (1:np,npointw-7) ) - allocate ( ydatcks(1:np,npointw-7) ) -! the jacobian matrix required in Levenberg-Marquardt fitting method - allocate ( fjacc (npointw-7,nc) ) ! calculated in SW_CB_dist -! the values of objective functions to be fitted - allocate ( fvecc (npointw-7) ) ! calculated in SW_CB_dist - -! SW CB retentions at fine grids for each patch - DO LL = 1,np - ydatc(LL,:) = (-1.0*xdat(8:)/psi_s_one(LL))**(-1.0*lambda_one(LL)) * theta_s_one(LL) - ydatcks(LL,:) = (-1.0*xdat(8:)/psi_s_one(LL))**(-3.0*lambda_one(LL)-2) * k_s_one(LL) - ENDDO - -! Fitting the Campbell SW retention parameters - ldfjac = npointw-7 - xc(1) = psi_s_patches (ipatch) - xc(2) = lambda_patches (ipatch) - xc(3) = k_s_patches (ipatch) - maxfev = 100 * ( nc + 1 ) - isiter = 1 - - CALL lmder ( SW_CB_dist, npointw-7, nc, xc, fvecc, fjacc, ldfjac, ftol, xtol, gtol, maxfev, & - diagc, mode, factor, nprint, info, nfev, njev, ipvtc, qtfc,& - xdat(8:), npointw-7, ydatc, ydatcks, np, theta_s_patches(ipatch),k_s_patches(ipatch), isiter) - - IF( xc(1) >= -300. .and. xc(1) < 0.0 .and. xc(2) > 0.0 .and. xc(2) <= 1.0 .and. & - xc(3) > 0.0 .and. xc(3) <= 1.0e7 .and. isiter == 1) THEN - psi_s_patches (ipatch) = xc(1) - lambda_patches(ipatch) = xc(2) - k_s_patches (ipatch) = xc(3) - ENDIF - - deallocate(ydatc) - deallocate(ydatcks) - deallocate(fjacc) - deallocate(fvecc) - - ENDIF - ENDIF - - ELSE - theta_s_patches (ipatch) = -1.0e36_r8 - k_s_patches (ipatch) = -1.0e36_r8 - psi_s_patches (ipatch) = -1.0e36_r8 - lambda_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(theta_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in theta_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(k_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in k_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(psi_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in psi_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - IF (isnan_ud(lambda_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in lambda_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('theta_s lev '//trim(c), theta_s_patches) - CALL check_vector_data ('k_s lev '//trim(c), k_s_patches) - CALL check_vector_data ('psi_s lev '//trim(c), psi_s_patches) - CALL check_vector_data ('lambda lev '//trim(c), lambda_patches) -#endif - -#ifndef vanGenuchten_Mualem_SOIL_MODEL - lndname = trim(landdir)//'/theta_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'theta_s_l'//trim(c)//'_patches', 'patch', landpatch, & - theta_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (theta_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'theta_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/k_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'k_s_l'//trim(c)//'_patches', 'patch', landpatch, & - k_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (k_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'k_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif -#endif - - lndname = trim(landdir)//'/psi_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'psi_s_l'//trim(c)//'_patches', 'patch', landpatch, & - psi_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (psi_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'psi_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/lambda_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'lambda_l'//trim(c)//'_patches', 'patch', landpatch, & - lambda_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (lambda_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'lambda_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (15) heat capacity of soil solids [J/(m3 K)] - IF (p_is_io) THEN - CALL allocate_block_data (gland, csol_grid) - lndname = trim(dir_rawdata)//'/soil/csol.nc' - CALL ncio_read_block (lndname, 'csol_l'//trim(c), gland, csol_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = csol_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - csol_patches(ipatch) = csol_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = csol_grid, data_r8_2d_out1 = csol_one) - CALL fillnan (csol_one, L == WATERBODY, csol_fill_water(nsl)) - CALL fillnan (csol_one, L == GLACIERS , csol_fill_water(nsl)) - csol_patches (ipatch) = sum(csol_one*(area_one/sum(area_one))) - ELSE - csol_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(csol_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in csol_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('csol lev '//trim(c), csol_patches) -#endif - - lndname = trim(landdir)//'/csol_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'csol_l'//trim(c)//'_patches', 'patch', landpatch, & - csol_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (csol_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'csol_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (16) thermal conductivity of unfrozen saturated soil [W/m-K] - IF (p_is_io) THEN - CALL allocate_block_data (gland, tksatu_grid) - lndname = trim(dir_rawdata)//'/soil/tksatu.nc' - CALL ncio_read_block (lndname, 'tksatu_l'//trim(c), gland, tksatu_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tksatu_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - tksatu_patches(ipatch) = tksatu_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = tksatu_grid, data_r8_2d_out1 = tksatu_one) - CALL fillnan (tksatu_one, L == WATERBODY, tksatu_fill_water(nsl)) - CALL fillnan (tksatu_one, L == GLACIERS , tksatu_fill_water(nsl)) - tksatu_patches (ipatch) = product(tksatu_one**(area_one/sum(area_one))) - ELSE - tksatu_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(tksatu_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in tksatu_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('tksatu lev '//trim(c), tksatu_patches) -#endif - - lndname = trim(landdir)//'/tksatu_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'tksatu_l'//trim(c)//'_patches', 'patch', landpatch, & - tksatu_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (tksatu_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'tksatu_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (17) thermal conductivity of frozen saturated soil [W/m-K] - IF (p_is_io) THEN - CALL allocate_block_data (gland, tksatf_grid) - lndname = trim(dir_rawdata)//'/soil/tksatf.nc' - CALL ncio_read_block (lndname, 'tksatf_l'//trim(c), gland, tksatf_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tksatf_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - tksatf_patches(ipatch) = tksatf_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = tksatf_grid, data_r8_2d_out1 = tksatf_one) - CALL fillnan (tksatf_one, L == WATERBODY, tksatf_fill_water(nsl)) - CALL fillnan (tksatf_one, L == GLACIERS , tksatf_fill_water(nsl)) - tksatf_patches (ipatch) = product(tksatf_one**(area_one/sum(area_one))) - ELSE - tksatf_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(tksatf_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in tksatf_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('tksatf lev '//trim(c), tksatf_patches) -#endif - - lndname = trim(landdir)//'/tksatf_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'tksatf_l'//trim(c)//'_patches', 'patch', landpatch, & - tksatf_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (tksatf_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'tksatf_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (18) thermal conductivity for dry soil [W/(m-K)] - IF (p_is_io) THEN - CALL allocate_block_data (gland, tkdry_grid) - lndname = trim(dir_rawdata)//'/soil/tkdry.nc' - CALL ncio_read_block (lndname, 'tkdry_l'//trim(c), gland, tkdry_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tkdry_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - tkdry_patches(ipatch) = tkdry_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = tkdry_grid, data_r8_2d_out1 = tkdry_one) - CALL fillnan (tkdry_one, L == WATERBODY, tkdry_fill_water(nsl)) - CALL fillnan (tkdry_one, L == GLACIERS , tkdry_fill_water(nsl)) - tkdry_patches (ipatch) = product(tkdry_one**(area_one/sum(area_one))) - ELSE - tkdry_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(tkdry_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in tkdry_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('tkdry lev '//trim(c), tkdry_patches) -#endif - - lndname = trim(landdir)//'/tkdry_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'tkdry_l'//trim(c)//'_patches', 'patch', landpatch, & - tkdry_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (tkdry_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'tkdry_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (19) thermal conductivity of soil solids [W/m-K] - IF (p_is_io) THEN - CALL allocate_block_data (gland, k_solids_grid) - lndname = trim(dir_rawdata)//'/soil/k_solids.nc' - CALL ncio_read_block (lndname, 'k_solids_l'//trim(c), gland, k_solids_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = k_solids_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - k_solids_patches(ipatch) = k_solids_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = k_solids_grid, data_r8_2d_out1 = k_solids_one) - CALL fillnan (k_solids_one, L == WATERBODY, k_solids_fill_water(nsl)) - CALL fillnan (k_solids_one, L == GLACIERS , k_solids_fill_water(nsl)) - k_solids_patches (ipatch) = product(k_solids_one**(area_one/sum(area_one))) - ELSE - k_solids_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(k_solids_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in k_solids_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('k_solids lev '//trim(c), k_solids_patches) -#endif - - lndname = trim(landdir)//'/k_solids_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'k_solids_l'//trim(c)//'_patches', 'patch', landpatch, & - k_solids_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (k_solids_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'k_solids_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (20) OM_density [kg/m3] - IF (p_is_io) THEN - - CALL allocate_block_data (gland, OM_density_s_grid) - lndname = trim(dir_rawdata)//'/soil/OM_density_s.nc' - CALL ncio_read_block (lndname, 'OM_density_s_l'//trim(c), gland, OM_density_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = OM_density_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - OM_density_s_patches(ipatch) = OM_density_s_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = OM_density_s_grid, data_r8_2d_out1 = OM_density_s_one) - CALL fillnan (OM_density_s_one, L == WATERBODY, OM_density_fill_water(nsl)) - CALL fillnan (OM_density_s_one, L == GLACIERS , OM_density_fill_water(nsl)) - OM_density_s_patches (ipatch) = sum (OM_density_s_one * (area_one/sum(area_one))) - ELSE - OM_density_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(OM_density_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in OM_density_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('OM_density_s lev '//trim(c), OM_density_s_patches) -#endif - - lndname = trim(landdir)//'/OM_density_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'OM_density_s_l'//trim(c)//'_patches', 'patch',& - landpatch, OM_density_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (OM_density_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'OM_density_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (21) bulk density of soil (GRAVELS + OM + Mineral Soils) - IF (p_is_io) THEN - - CALL allocate_block_data (gland, BD_all_s_grid) - lndname = trim(dir_rawdata)//'/soil/BD_all_s.nc' - CALL ncio_read_block (lndname, 'BD_all_s_l'//trim(c), gland, BD_all_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = BD_all_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - BD_all_s_patches(ipatch) = BD_all_s_patches(wmo_src) - - CYCLE - ENDIF - - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = BD_all_s_grid, data_r8_2d_out1 = BD_all_s_one) - CALL fillnan (BD_all_s_one, L == WATERBODY, BD_all_fill_water(nsl)) - CALL fillnan (BD_all_s_one, L == GLACIERS , BD_all_fill_water(nsl)) - BD_all_s_patches (ipatch) = sum (BD_all_s_one * (area_one/sum(area_one))) - ELSE - BD_all_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(BD_all_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in BD_all_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('BD_all_s lev '//trim(c), BD_all_s_patches) -#endif - - lndname = trim(landdir)//'/BD_all_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'BD_all_s_l'//trim(c)//'_patches', 'patch',& - landpatch, BD_all_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (BD_all_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'BD_all_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - ! (22) volumetric fraction of clay - IF (p_is_io) THEN - - CALL allocate_block_data (gland, vf_clay_s_grid) - lndname = trim(dir_rawdata)//'/soil/vf_clay_s.nc' - CALL ncio_read_block (lndname, 'vf_clay_s_l'//trim(c), gland, vf_clay_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_clay_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - vf_clay_s_patches(ipatch) = vf_clay_s_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = vf_clay_s_grid, data_r8_2d_out1 = vf_clay_s_one) - CALL fillnan (vf_clay_s_one, L == WATERBODY, vf_clay_fill_water(nsl)) - CALL fillnan (vf_clay_s_one, L == GLACIERS , vf_clay_fill_water(nsl)) - vf_clay_s_patches (ipatch) = sum (vf_clay_s_one * (area_one/sum(area_one))) - ELSE - vf_clay_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(vf_clay_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in vf_clay_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('vf_clay_s lev '//trim(c), vf_clay_s_patches) -#endif - - lndname = trim(landdir)//'/vf_clay_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'vf_clay_s_l'//trim(c)//'_patches', 'patch',& - landpatch, vf_clay_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (vf_clay_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'vf_clay_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - - ! (23) gravimetric fraction of om - IF (p_is_io) THEN - - CALL allocate_block_data (gland, wf_om_s_grid) - lndname = trim(dir_rawdata)//'/soil/wf_om_s.nc' - CALL ncio_read_block (lndname, 'wf_om_s_l'//trim(c), gland, wf_om_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_om_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - wf_om_s_patches(ipatch) = wf_om_s_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = wf_om_s_grid, data_r8_2d_out1 = wf_om_s_one) - CALL fillnan (wf_om_s_one, L == WATERBODY, wf_om_fill_water(nsl)) - CALL fillnan (wf_om_s_one, L == GLACIERS , wf_om_fill_water(nsl)) - wf_om_s_patches (ipatch) = sum (wf_om_s_one * (area_one/sum(area_one))) - ELSE - wf_om_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(wf_om_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in wf_om_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('wf_om_s lev '//trim(c), wf_om_s_patches) -#endif - - lndname = trim(landdir)//'/wf_om_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'wf_om_s_l'//trim(c)//'_patches', 'patch',& - landpatch, wf_om_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (wf_om_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'wf_om_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - - - ! (24) gravimetric fraction of clay - IF (p_is_io) THEN - - CALL allocate_block_data (gland, wf_clay_s_grid) - lndname = trim(dir_rawdata)//'/soil/wf_clay_s.nc' - CALL ncio_read_block (lndname, 'wf_clay_s_l'//trim(c), gland, wf_clay_s_grid) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_clay_s_grid) -#endif - ENDIF - - IF (p_is_worker) THEN - - DO ipatch = 1, numpatch - L = landpatch%settyp(ipatch) - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - wf_clay_s_patches(ipatch) = wf_clay_s_patches(wmo_src) - - CYCLE - ENDIF - - IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = wf_clay_s_grid, data_r8_2d_out1 = wf_clay_s_one) - CALL fillnan (wf_clay_s_one, L == WATERBODY, wf_clay_fill_water(nsl)) - CALL fillnan (wf_clay_s_one, L == GLACIERS , wf_clay_fill_water(nsl)) - wf_clay_s_patches (ipatch) = sum (wf_clay_s_one * (area_one/sum(area_one))) - ELSE - wf_clay_s_patches (ipatch) = -1.0e36_r8 - ENDIF - - IF (isnan_ud(wf_clay_s_patches(ipatch))) THEN - write(*,*) "Warning: NAN appears in wf_clay_s_patches." - write(*,*) landpatch%eindex(ipatch), landpatch%settyp(ipatch) - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('wf_clay_s lev '//trim(c), wf_clay_s_patches) -#endif - - lndname = trim(landdir)//'/wf_clay_s_l'//trim(c)//'_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'wf_clay_s_l'//trim(c)//'_patches', 'patch',& - landpatch, wf_clay_s_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/soil_parameters_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (wf_clay_s_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'wf_clay_s_l'//trim(c), compress = 1, write_mode = 'one') -#endif - ENDDO - - - ! Deallocate the allocatable array - ! -------------------------------- - - IF (p_is_worker) THEN - - deallocate ( vf_quartz_mineral_s_patches ) - deallocate ( vf_gravels_s_patches ) - deallocate ( vf_om_s_patches ) - deallocate ( vf_sand_s_patches ) - deallocate ( vf_clay_s_patches ) - deallocate ( wf_gravels_s_patches ) - deallocate ( wf_sand_s_patches ) - deallocate ( wf_om_s_patches ) - deallocate ( wf_clay_s_patches ) - deallocate ( OM_density_s_patches ) - deallocate ( BD_all_s_patches ) - deallocate ( theta_s_patches ) - deallocate ( psi_s_patches ) - deallocate ( lambda_patches ) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - deallocate ( theta_r_patches ) - deallocate ( alpha_vgm_patches) - deallocate ( L_vgm_patches ) - deallocate ( n_vgm_patches ) -#endif - deallocate ( k_s_patches ) - deallocate ( csol_patches ) - deallocate ( tksatu_patches ) - deallocate ( tkdry_patches ) - deallocate ( tksatf_patches ) - deallocate ( k_solids_patches) - deallocate ( BA_alpha_patches) - deallocate ( BA_beta_patches ) - - IF (allocated(vf_quartz_mineral_s_one)) deallocate (vf_quartz_mineral_s_one) - IF (allocated(vf_gravels_s_one)) deallocate (vf_gravels_s_one) - IF (allocated(vf_om_s_one)) deallocate (vf_om_s_one) - IF (allocated(vf_sand_s_one)) deallocate (vf_sand_s_one) - IF (allocated(vf_clay_s_one)) deallocate (vf_clay_s_one) - IF (allocated(wf_gravels_s_one)) deallocate (wf_gravels_s_one) - IF (allocated(wf_sand_s_one)) deallocate (wf_sand_s_one) - IF (allocated(wf_om_s_one)) deallocate (wf_om_s_one) - IF (allocated(wf_clay_s_one)) deallocate (wf_clay_s_one) - IF (allocated(OM_density_s_one)) deallocate (OM_density_s_one) - IF (allocated(BD_all_s_one)) deallocate (BD_all_s_one) - IF (allocated(theta_s_one)) deallocate (theta_s_one) - IF (allocated(psi_s_one )) deallocate (psi_s_one ) - IF (allocated(lambda_one )) deallocate (lambda_one ) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - IF (allocated ( theta_r_one )) deallocate ( theta_r_one ) - IF (allocated ( alpha_vgm_one)) deallocate ( alpha_vgm_one) - IF (allocated ( L_vgm_one )) deallocate ( L_vgm_one ) - IF (allocated ( n_vgm_one )) deallocate ( n_vgm_one ) -#endif - IF (allocated(k_s_one )) deallocate (k_s_one ) - IF (allocated(csol_one )) deallocate (csol_one ) - IF (allocated(tksatu_one )) deallocate (tksatu_one ) - IF (allocated(tkdry_one )) deallocate (tkdry_one ) - IF (allocated(tksatf_one )) deallocate (tksatf_one) - IF (allocated(k_solids_one)) deallocate (k_solids_one) - IF (allocated(area_one)) deallocate (area_one) - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -END SUBROUTINE Aggregation_SoilParameters - - -SUBROUTINE SW_CB_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatc, ydatcks, nptf, phi, k_s, isiter) - -!================================================================= -! DESCRIPTION: -! This is the subroutine for calculating the function/jacobian matrix -! of the distance between the fitted and prescribed SW retention and -! hydraulic conductivity curves for the Campbell model. -! -! Created by Nan Wei, 01/2019 -! ---------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - integer m,n,ldfjac,iflag,i,nptf,isiter,npoint - real(r8) x(n),fjac(ldfjac,n),fvec(m),xdat(npoint),ydatc(nptf,npoint),ydatcks(nptf,npoint),phi,k_s - - IF ( iflag == 0 ) THEN - - print*,x - - ELSEIF ( iflag == 1 ) THEN - - IF (x(1) >= 0.0 .or. abs(x(2)) >= 100. .or. x(3) <= 0.0) THEN - isiter = 0 - RETURN - ENDIF - - DO i = 1, m - fvec(i) = sum((((-1.0*xdat(i)/x(1))**(-1.0*x(2)) * phi - ydatc(:,i))/phi)**2) & - + sum(((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))**2) - ENDDO - - ELSEIF ( iflag == 2 ) THEN - - IF (x(1) >= 0.0 .or. abs(x(2)) >= 100. .or. x(3) <= 0.0) THEN - isiter = 0 - RETURN - ENDIF - - DO i = 1, m - fjac(i,1) = sum(2.0*(((-1.0*xdat(i)/x(1))**(-1.0*x(2)) * phi - ydatc(:,i))/phi)*& - x(2) * (-1.0*xdat(i)/x(1))**(-1.0*x(2)) / x(1)) & - + sum(2.0*((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))*& - (3.0*x(2)+2)/(x(1)*log(10.))/log10(k_s)) - fjac(i,2) = sum(-2.0*(((-1.0*xdat(i)/x(1))**(-1.0*x(2)) * phi - ydatc(:,i))/phi)*& - (-1.0*xdat(i)/x(1))**(-1.0*x(2)) * log(-1.0*xdat(i)/x(1))) & - + sum(-6.0*((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))*& - log10(-1.0*xdat(i)/x(1))/log10(k_s)) - fjac(i,3) = sum(2.0*((log10(-1.0*xdat(i)/x(1))*(-3.0*x(2)-2) + log10(x(3)) - log10(ydatcks(:,i)))/log10(k_s))/& - (x(3)*log(10.)*log10(k_s))) - ENDDO - - ENDIF - -END SUBROUTINE SW_CB_dist - -SUBROUTINE SW_VG_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatv, ydatvks, nptf, phi, k_s, isiter, L_vgm) - -!================================================================= -! DESCRIPTION: -! This is the subroutine for calculating the function/jacobian matrix -! of the distance between the fitted and prescribed SW retention and -! hydraulic conductivity curves for the van Genuchten model. -! -! Created by Nan Wei, 01/2019 -! ---------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - integer m,n,ldfjac,iflag,i,nptf,isiter,npoint - real(r8) x(n),fjac(ldfjac,n),fvec(m),xdat(npoint),ydatv(nptf,npoint),ydatvks(nptf,npoint),phi,k_s,L_vgm - - IF ( iflag == 0 ) THEN - - print*,x - - ELSEIF ( iflag == 1 ) THEN - - IF (x(2) <= 0.0 .or. x(3) <= 0.1 .or. x(3) >= 100. .or. x(4) <= 0.0) THEN - isiter = 0 - RETURN - ENDIF - - DO i = 1, m - fvec(i) = sum(((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)**2) & - + sum(((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & - log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s))**2) - ENDDO - - ELSEIF ( iflag == 2 ) THEN - - IF (x(2) <= 0.0 .or. x(3) <= 0.1 .or. x(3) >= 100. .or. x(4) <= 0.0) THEN - isiter = 0 - RETURN - ENDIF - - DO i = 1, m - fjac(i,1) = sum(2*((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)*& - (1 - (1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1))/phi) - fjac(i,2) = sum(2*((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)/phi*& - (phi - x(1)) * (1 - x(3)) * (1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-2) * x(2)**(x(3)-1) * xdat(i)**x(3)) & - + sum(2*((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & - log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s)) * & - (L_vgm*(1.0-x(3))*x(2)**(x(3)-1)*xdat(i)**x(3)/((1+(x(2)*xdat(i))**x(3))*log(10.)) + & - 2.0*(1.0-x(3))*(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(-1.0/x(3))* & - x(2)**(x(3)-1)*xdat(i)**x(3)*(1+(x(2)*xdat(i))**x(3))**(-2)/ & - ((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))*log(10.)))/log10(k_s)) - fjac(i,3) = sum(2*((x(1) + (phi - x(1))*(1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) - ydatv(:,i))/phi)/phi*& - (phi - x(1)) * (1+(x(2)*xdat(i))**x(3))**(1.0/x(3)-1) *& - ((1.0-x(3))*(x(2)*xdat(i))**x(3)*log(x(2)*xdat(i))/(x(3)*(1+(x(2)*xdat(i))**x(3))) & - - log(1+(x(2)*xdat(i))**x(3))/x(3)**2)) & - + sum(2*((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & - log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s)) * & - (-1.0*L_vgm*log10(1+(x(2)*xdat(i))**x(3))/x(3)**2 + & - (1.0/x(3)-1)*L_vgm*(x(2)*xdat(i))**x(3)*log10(x(2)*xdat(i))/(1+(x(2)*xdat(i))**x(3)) - & - 2.0*(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3))/ & - (1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3))) * & - (log10(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))/x(3)**2 + & - (1-1.0/x(3))*log10(x(2)*xdat(i))/(1+(x(2)*xdat(i))**x(3))))/log10(k_s)) - fjac(i,4) = sum(2*((log10(x(4)) + (1.0/x(3)-1)*L_vgm*log10(1+(x(2)*xdat(i))**x(3)) + & - log10((1.0-(1.0-1.0/(1+(x(2)*xdat(i))**x(3)))**(1-1.0/x(3)))**2) - log10(ydatvks(:,i)))/log10(k_s)) / & - (x(4)*log(10.))/log10(k_s)) - ENDDO - - ENDIF - -END SUBROUTINE SW_VG_dist - -!----------------------------------------------------------------------- -!EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 deleted file mode 100644 index 789741a153..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_SoilTexture.F90 +++ /dev/null @@ -1,139 +0,0 @@ -#include - -SUBROUTINE Aggregation_SoilTexture ( & - gland, dir_rawdata, dir_model_landdata, lc_year) - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Aggregate soil texture class within a patch. -! -! Use the USDA soil texture triangle (using the amount of sand, clay, and -! silt contents) to identify the soil texture in fine grid resolution and -! then finding the major soil type in a patch by counting number of fine -! grids with each type of soil and adopting the major one. -! -! Created by Shupeng Zhang, 01/2025 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils, only: num_max_frequency -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - ! arguments: - - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gland - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - integer :: ipatch - integer :: wmo_src - - type(block_data_int32_2d) :: soiltext - integer, allocatable :: soiltext_patches(:), soiltext_one(:) -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp - real(r8), allocatable :: soiltext_r8 (:) -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate soil texture ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - lndname = trim(dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc' - - IF (p_is_io) THEN - CALL allocate_block_data (gland, soiltext) - CALL ncio_read_block (lndname, 'soiltexture', gland, soiltext) - -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_i4_2d_in1 = soiltext) -#endif - ENDIF - - IF (p_is_worker) THEN - - IF (numpatch > 0) allocate (soiltext_patches (numpatch)) - - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - soiltext_patches(ipatch) = soiltext_patches(wmo_src) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gland, & - zip = USE_zip_for_aggregation, & - data_i4_2d_in1 = soiltext, data_i4_2d_out1 = soiltext_one) - soiltext_patches(ipatch) = num_max_frequency (soiltext_one) - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('soiltext_patches ', soiltext_patches) -#endif - - lndname = trim(landdir)//'/soiltexture_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'soiltext_patches', 'patch', & - landpatch, soiltext_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata)//'/diag/soiltexture_'//trim(cyear)//'.nc' - IF (allocated(soiltext_patches)) THEN - allocate (soiltext_r8 (size(soiltext_patches))) - soiltext_r8 = real(soiltext_patches,r8) - ENDIF - - CALL srfdata_map_and_write (soiltext_r8, landpatch%settyp, typpatch, & - m_patch2diag, -1., lndname, 'soiltexture', compress = 1, write_mode = 'one', & - create_mode=.true.) - - IF (allocated(soiltext_r8)) deallocate(soiltext_r8) -#endif - - IF (p_is_worker) THEN - IF (numpatch > 0) deallocate ( soiltext_patches ) - ENDIF - -END SUBROUTINE Aggregation_SoilTexture diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 deleted file mode 100644 index 1d5f6aadd8..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopoWetness.F90 +++ /dev/null @@ -1,345 +0,0 @@ -#include - -SUBROUTINE Aggregation_TopoWetness ( & - gridtwi, dir_rawdata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! Topographic Wetness Index data ln(a/tanB), calculated by using -! -! Yamazaki, D., Ikeshima, D., Sosa, J.,Bates, P. D., Allen, G. H., -! Pavelsky, T. M. (2019). -! MERIT Hydro: ahigh‐resolution global hydrographymap based on -! latest topography dataset.Water Resources Research, 55, 5053-5073. -! -! Created by Shupeng Zhang, 06/2025 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_CatchmentDataReadin -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - ! arguments: - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gridtwi - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - integer :: ipatch, npxl, i, im, ielm, istt, iend - integer :: wmo_src - real(r8) :: mean_twi, sigma_twi, skew_twi, fsatmax, fsatdcf, alp_twi, chi_twi, mu_twi - - type (block_data_real8_3d) :: twi - - real(r8), allocatable :: twi_one (:,:) - logical, allocatable :: mask (:,:) - - real(r8), allocatable :: mean_twi_patches(:) - real(r8), allocatable :: fsatmax_patches (:), fsatdcf_patches (:) - real(r8), allocatable :: alp_twi_patches (:), chi_twi_patches (:), mu_twi_patches (:) - - real(r8), allocatable :: twi_sort(:), xx(:), yy(:) - integer, allocatable :: order (:) - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate topographic wetness index ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -! ----------------------------------------------------------------------------------------- -! aggregate the topographic index from the resolution of raw data to modelling resolution -! ----------------------------------------------------------------------------------------- - - IF (p_is_io) THEN - - lndname = trim(dir_rawdata)//'/TWI.nc' - CALL allocate_block_data (gridtwi, twi, 25) - CALL ncio_read_block (lndname, 'twi', gridtwi, 25, twi) - -#ifdef USEMPI - CALL aggregation_data_daemon (gridtwi, data_r8_3d_in1 = twi, n1_r8_3d_in1 = 25) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (mean_twi_patches (numpatch)); mean_twi_patches(:) = spval - allocate (fsatmax_patches (numpatch)); fsatmax_patches (:) = spval - allocate (fsatdcf_patches (numpatch)); fsatdcf_patches (:) = spval - allocate (alp_twi_patches (numpatch)); alp_twi_patches (:) = spval - allocate (chi_twi_patches (numpatch)); chi_twi_patches (:) = spval - allocate (mu_twi_patches (numpatch)); mu_twi_patches (:) = spval - - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - fsatmax_patches(ipatch) = fsatmax_patches(wmo_src) - fsatdcf_patches(ipatch) = fsatdcf_patches(wmo_src) - alp_twi_patches(ipatch) = alp_twi_patches(wmo_src) - chi_twi_patches(ipatch) = chi_twi_patches(wmo_src) - mu_twi_patches (ipatch) = mu_twi_patches (wmo_src) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gridtwi, zip = USE_zip_for_aggregation, & - data_r8_3d_in1 = twi, data_r8_3d_out1 = twi_one, n1_r8_3d_in1 = 25, lb1_r8_3d_in1 = 1 ) - - allocate (mask (size(twi_one,1),size(twi_one,2))) - mask = (twi_one > -1.e3) - npxl = count(mask) - - IF (npxl >= 25) THEN - - allocate (twi_sort (npxl)) - allocate (order (npxl)) - - twi_sort = pack(twi_one, mask) - - CALL quicksort (npxl, twi_sort, order) - - mean_twi_patches(ipatch) = sum(twi_sort) / npxl - - im = 1 - DO WHILE ((twi_sort(im) < mean_twi_patches(ipatch)) .and. (im < npxl-1)) - im = im + 1 - ENDDO - - fsatmax_patches(ipatch) = 1 - real(im-1)/npxl - - allocate (xx (npxl-im)) - allocate (yy (npxl-im)) - - xx = -(twi_sort(im:(npxl-1)) - mean_twi_patches(ipatch)) - yy = (/(log((1-real(i)/npxl)/fsatmax_patches(ipatch)), i = im, npxl-1)/) - - fsatdcf_patches(ipatch) = sum(xx*yy)/sum(xx**2) - - mean_twi = mean_twi_patches(ipatch) - sigma_twi = sqrt(sum((twi_sort-mean_twi)**2) / (npxl-1)) - - IF (sigma_twi > 0) THEN - skew_twi = real(npxl)/((npxl-1)*(npxl-2)) * sum((twi_sort-mean_twi)**3) / sigma_twi**3 - IF (skew_twi > 0) THEN - alp_twi_patches(ipatch) = (2./skew_twi)**2 - chi_twi_patches(ipatch) = sigma_twi*skew_twi/2 - mu_twi_patches (ipatch) = mean_twi - 2.*sigma_twi/skew_twi - ENDIF - ENDIF - - fsatmax_patches(ipatch) = min(max(fsatmax_patches(ipatch), 0.1), 1.0) - fsatdcf_patches(ipatch) = min(max(fsatdcf_patches(ipatch), 0.2), 2.0) - alp_twi_patches(ipatch) = min(max(alp_twi_patches(ipatch), 0.1), 50.) - chi_twi_patches(ipatch) = min(max(chi_twi_patches(ipatch), 0.01), 4.0) - mu_twi_patches (ipatch) = min(max(mu_twi_patches (ipatch), 0.), 12.) - - deallocate (twi_sort) - deallocate (order ) - deallocate (xx ) - deallocate (yy ) - - ENDIF - - deallocate (mask) - - ENDDO - - DO ielm = 1, numelm - - ! default value is set as global median at 0.1 degree resolution - mean_twi = 9.27 - fsatmax = 0.38 - fsatdcf = 0.55 - alp_twi = 1.34 - chi_twi = 1.61 - mu_twi = 6.95 - - CALL aggregation_request_data (landelm, ielm, gridtwi, zip = USE_zip_for_aggregation, & - data_r8_3d_in1 = twi, data_r8_3d_out1 = twi_one, n1_r8_3d_in1 = 25, lb1_r8_3d_in1 = 1 ) - - allocate (mask (size(twi_one,1),size(twi_one,2))) - mask = (twi_one > -1.e3) - npxl = count(mask) - - IF (npxl >= 25) THEN - - allocate (twi_sort (npxl)) - allocate (order (npxl)) - - twi_sort = pack(twi_one, mask) - - CALL quicksort (npxl, twi_sort, order) - - mean_twi = sum(twi_sort) / npxl - - im = 1 - DO WHILE ((twi_sort(im) < mean_twi) .and. (im < npxl-1)) - im = im + 1 - ENDDO - - fsatmax = 1 - real(im-1)/npxl - - allocate (xx (npxl-im)) - allocate (yy (npxl-im)) - - xx = -(twi_sort(im:(npxl-1)) - mean_twi) - yy = (/(log((1-real(i)/npxl)/fsatmax), i = im, npxl-1)/) - - fsatdcf = sum(xx*yy)/sum(xx**2) - - sigma_twi = sqrt(sum((twi_sort-mean_twi)**2) / (npxl-1)) - - IF (sigma_twi > 0) THEN - skew_twi = real(npxl)/((npxl-1)*(npxl-2)) * sum((twi_sort-mean_twi)**3) / sigma_twi**3 - IF (skew_twi > 0) THEN - alp_twi = (2./skew_twi)**2 - chi_twi = sigma_twi*skew_twi/2 - mu_twi = mean_twi - 2.*sigma_twi/skew_twi - ENDIF - ENDIF - - fsatmax = min(max(fsatmax, 0.1), 1.0) - fsatdcf = min(max(fsatdcf, 0.2), 2.0) - alp_twi = min(max(alp_twi, 0.1), 50.) - chi_twi = min(max(chi_twi, 0.01), 4.0) - mu_twi = min(max(mu_twi , 0.), 12.) - - deallocate (twi_sort) - deallocate (order ) - deallocate (xx ) - deallocate (yy ) - - ENDIF - - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - DO ipatch = istt, iend - IF (mean_twi_patches(ipatch) == spval) mean_twi_patches(ipatch) = mean_twi - IF (fsatmax_patches (ipatch) == spval) fsatmax_patches (ipatch) = fsatmax - IF (fsatdcf_patches (ipatch) == spval) fsatdcf_patches (ipatch) = fsatdcf - IF (alp_twi_patches (ipatch) == spval) alp_twi_patches (ipatch) = alp_twi - IF (chi_twi_patches (ipatch) == spval) chi_twi_patches (ipatch) = chi_twi - IF (mu_twi_patches (ipatch) == spval) mu_twi_patches (ipatch) = mu_twi - ENDDO - - deallocate (mask) - - ENDDO - - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('mean_twi_patches ', mean_twi_patches) - CALL check_vector_data ('fsatmax_patches ', fsatmax_patches ) - CALL check_vector_data ('fsatdcf_patches ', fsatdcf_patches ) - CALL check_vector_data ('alp_twi_patches ', alp_twi_patches ) - CALL check_vector_data ('chi_twi_patches ', chi_twi_patches ) - CALL check_vector_data ('mu_twi_patches ', mu_twi_patches ) -#endif - - lndname = trim(landdir)//'/mean_twi_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'mean_twi_patches', 'patch', landpatch, & - mean_twi_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/fsatmax_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'fsatmax_patches', 'patch', landpatch, & - fsatmax_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/fsatdcf_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'fsatdcf_patches', 'patch', landpatch, & - fsatdcf_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/alp_twi_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'alp_twi_patches', 'patch', landpatch, & - alp_twi_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/chi_twi_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'chi_twi_patches', 'patch', landpatch, & - chi_twi_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/mu_twi_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'mu_twi_patches', 'patch', landpatch, & - mu_twi_patches, DEF_Srfdata_CompressLevel) - - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - - lndname = trim(dir_model_landdata) // '/diag/twi_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (mean_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'mean_twi', compress = 1, write_mode = 'one', create_mode=.true.) - CALL srfdata_map_and_write (fsatmax_patches, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'fsatmax', compress = 1, write_mode = 'one') - CALL srfdata_map_and_write (fsatdcf_patches, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'fsatdcf', compress = 1, write_mode = 'one') - CALL srfdata_map_and_write (alp_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'alp_twi', compress = 1, write_mode = 'one') - CALL srfdata_map_and_write (chi_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'chi_twi', compress = 1, write_mode = 'one') - CALL srfdata_map_and_write (mu_twi_patches, landpatch%settyp, typpatch, m_patch2diag, & - spval, lndname, 'mu_twi', compress = 1, write_mode = 'one') -#endif - - IF (p_is_worker) THEN - deallocate ( mean_twi_patches ) - deallocate ( fsatmax_patches ) - deallocate ( fsatdcf_patches ) - deallocate ( alp_twi_patches ) - deallocate ( chi_twi_patches ) - deallocate ( mu_twi_patches ) - ENDIF - -END SUBROUTINE Aggregation_TopoWetness diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 deleted file mode 100644 index 7e8585a14c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Topography.F90 +++ /dev/null @@ -1,206 +0,0 @@ -#include - -SUBROUTINE Aggregation_Topography ( & - gtopo, dir_rawdata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! Global Topography data -! -! Yamazaki, D., Ikeshima, D., Sosa, J.,Bates, P. D., Allen, G. H., -! Pavelsky, T. M. (2019). -! MERIT Hydro: a high‐resolution global hydrographymap based on -! latest topography dataset.Water Resources Research, 55, 5053-5073. -! -! Created by Shupeng Zhang, 05/2023 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils - -#ifdef SrfdataDiag - USE MOD_Mesh, only: numelm - USE MOD_LandElm - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - ! arguments: - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: gtopo - character(len=*), intent(in) :: dir_rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - integer :: ipatch, i, ps, pe - integer :: wmo_src - real(r8) :: sumarea - - type (block_data_real8_2d) :: landarea - type (block_data_real8_2d) :: elevation - type (block_data_real8_2d) :: elvstd - type (block_data_real8_2d) :: sloperatio - - real(r8), allocatable :: elevation_one (:), elvstd_one (:), sloperatio_one (:) - real(r8), allocatable :: elevation_patches(:), elvstd_patches(:), sloperatio_patches(:) - real(r8), allocatable :: landarea_one (:) - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp -#endif - - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate topography ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - lndname = trim(dir_rawdata)//'/topography.nc' - -! --------------------------------------------------------------------------------- -! aggregate the elevation from the resolution of raw data to modelling resolution -! --------------------------------------------------------------------------------- - - IF (p_is_io) THEN - - CALL allocate_block_data (gtopo, landarea) - CALL ncio_read_block (lndname, 'landarea', gtopo, landarea) - - CALL allocate_block_data (gtopo, elevation) - CALL ncio_read_block (lndname, 'elevation', gtopo, elevation) - - CALL allocate_block_data (gtopo, elvstd) - CALL ncio_read_block (lndname, 'elvstd', gtopo, elvstd) - - CALL allocate_block_data (gtopo, sloperatio) - CALL ncio_read_block (lndname, 'slope', gtopo, sloperatio) - -#ifdef USEMPI - CALL aggregation_data_daemon (gtopo, & - data_r8_2d_in1 = landarea, data_r8_2d_in2 = elevation, & - data_r8_2d_in3 = elvstd , data_r8_2d_in4 = sloperatio ) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (elevation_patches (numpatch)) - allocate (elvstd_patches (numpatch)) - allocate (sloperatio_patches (numpatch)) - - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - elevation_patches (ipatch) = elevation_patches (wmo_src) - elvstd_patches (ipatch) = elvstd_patches (wmo_src) - sloperatio_patches(ipatch) = sloperatio_patches(wmo_src) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, gtopo, & - zip = USE_zip_for_aggregation, & - data_r8_2d_in1 = landarea , data_r8_2d_out1 = landarea_one , & - data_r8_2d_in2 = elevation , data_r8_2d_out2 = elevation_one , & - data_r8_2d_in3 = elvstd , data_r8_2d_out3 = elvstd_one , & - data_r8_2d_in4 = sloperatio, data_r8_2d_out4 = sloperatio_one ) - - IF (any(elevation_one /= -9999.0)) THEN - - sumarea = sum(landarea_one, mask = elevation_one /= -9999.0) - - elevation_patches(ipatch) = & - sum(elevation_one * landarea_one, mask = elevation_one /= -9999.0) / sumarea - - elvstd_patches(ipatch) = sqrt( & - sum(((elevation_one - elevation_patches(ipatch))**2 + elvstd_one**2) * landarea_one, & - mask = elevation_one /= -9999.0) / sumarea) - - sloperatio_patches(ipatch) = & - sum(sloperatio_one * landarea_one, mask = elevation_one /= -9999.0) / sumarea - - ELSE - elevation_patches (ipatch) = 0. - elvstd_patches (ipatch) = 0. - sloperatio_patches(ipatch) = 0. - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('elevation_patches ', elevation_patches ) - CALL check_vector_data ('elvstd_patches ', elvstd_patches ) - CALL check_vector_data ('sloperatio_patches', sloperatio_patches) -#endif - - lndname = trim(landdir)//'/elevation_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'elevation_patches', 'patch', landpatch, & - elevation_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/elvstd_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'elvstd_patches', 'patch', landpatch, & - elvstd_patches, DEF_Srfdata_CompressLevel) - - lndname = trim(landdir)//'/sloperatio_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'sloperatio_patches', 'patch', landpatch, & - sloperatio_patches, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/topography_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (elevation_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'elevation', compress = 1, write_mode = 'one', create_mode=.true.) - - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/topography_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (elvstd_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'elvstd', compress = 1, write_mode = 'one') - - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/topography_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (sloperatio_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'sloperatio', compress = 1, write_mode = 'one') -#endif - - IF (p_is_worker) THEN - deallocate ( elevation_patches ) - deallocate ( elvstd_patches ) - deallocate ( sloperatio_patches ) - ENDIF - -END SUBROUTINE Aggregation_Topography diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 deleted file mode 100644 index 6437a2be13..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors.F90 +++ /dev/null @@ -1,522 +0,0 @@ -#include - -SUBROUTINE Aggregation_TopographyFactors ( & - grid_topo_factor , dir_topodata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! Global topography-based factors data -! -! Created by Sisi Chen, Lu Li, 06/2024 -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_Mesh, only: numelm - USE MOD_LandElm - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - ! --------------------------------------------------------------- - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: grid_topo_factor ! Grid structure for high resolution topography factors - character(len=*), intent(in) :: dir_topodata ! Direct of Rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - character(len=3) :: sdir, sdir1 - - type (block_data_real8_2d) :: slp_grid ! slope - type (block_data_real8_2d) :: asp_grid ! aspect - type (block_data_real8_2d) :: svf_grid ! sky view factor - type (block_data_real8_2d) :: cur_grid ! curvature - type (block_data_real8_3d) :: tea_f_grid ! sine of terrain elevation angle at front of grid - type (block_data_real8_3d) :: tea_b_grid ! sine of terrain elevation angle at back of grid - - ! patch - real(r8), allocatable :: svf_patches (:) - real(r8), allocatable :: cur_patches (:) - real(r8), allocatable :: tea_f_azi_patches (:,:) ! shape as (azimuth, patches) - real(r8), allocatable :: tea_b_azi_patches (:,:) - real(r8), allocatable :: sf_lut_patches (:,:,:) ! shape as (azimuth, zenith, patches) - real(r8), allocatable :: sf_curve_patches(:,:,:) ! shape as (azimuth, parameters, patches) - - ! four defined types at all patches - real(r8), allocatable :: asp_type_patches (:,:) ! shape as (type, patches) - real(r8), allocatable :: slp_type_patches (:,:) - real(r8), allocatable :: area_type_patches (:,:) - - ! pixelsets - real(r8), allocatable :: slp_one (:) - real(r8), allocatable :: asp_one (:) - real(r8), allocatable :: svf_one (:) - real(r8), allocatable :: cur_one (:) - real(r8), allocatable :: area_one (:) - real(r8), allocatable :: sf_one (:) - real(r8), allocatable :: tea_f_azi_one (:,:) - real(r8), allocatable :: tea_b_azi_one (:,:) - real(r8), allocatable :: tea_f_one (:) - real(r8), allocatable :: tea_b_one (:) - logical , allocatable :: sf_mask_one (:) - logical , allocatable :: asp_mask_one (:) - logical , allocatable :: area_mask_one (:) - logical , allocatable :: slp_mask_one (:) - - ! pixelsets of four defined types at each patch - real(r8), allocatable :: asp_type_one (:,:) - real(r8), allocatable :: slp_type_one (:,:) - real(r8), allocatable :: area_type_one (:,:) - - real(r8) :: sum_area_one ! sum of pixel area of a patch - real(r8) :: zenith_angle(num_zenith) ! sine of sun zenith angle (divided by num_zenith part) - - ! Intermediate variables used in reducing the dimensionality of masking factors - real(r8) :: x2_sum - real(r8) :: x_sum - real(r8) :: y_sum - real(r8) :: xy_sum - real(r8) :: a1 ! Function Parameters - real(r8) :: a2 ! Function Parameters - real(r8) :: y(num_zenith) ! shadow factor under a single azimuth and single patch - real(r8) :: x(num_zenith) ! Solar zenith angle used as a predictor - real(r8), allocatable :: y_train(:) ! The part of y used to fit the function - real(r8), allocatable :: x_train(:) ! The part of x used to fit the function - real(r8), allocatable :: y_train_transform(:) ! The transform function of y_train - - ! local variables - integer :: ipatch, i, ps, pe, type, a, z, count_pixels, num_pixels, j, index, n - integer :: wmo_src - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp ! number of land classification -#endif - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate topography factor ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! ------------------------------------------------------------------- - ! read topography-based factor data - ! ------------------------------------------------------------------- - IF (p_is_io) THEN - lndname = trim(dir_topodata)//"/slope.nc" - CALL allocate_block_data (grid_topo_factor, slp_grid) - CALL ncio_read_block (lndname, 'slope', grid_topo_factor, slp_grid) - - lndname = trim(dir_topodata)//"/aspect.nc" - CALL allocate_block_data (grid_topo_factor, asp_grid) - CALL ncio_read_block (lndname, 'aspect', grid_topo_factor, asp_grid) - - lndname = trim(dir_topodata)//"/terrain_elev_angle_front.nc" - CALL allocate_block_data (grid_topo_factor, tea_f_grid, num_azimuth) - CALL ncio_read_block (lndname, 'tea_front', grid_topo_factor, num_azimuth, tea_f_grid) - - lndname = trim(dir_topodata)//"/terrain_elev_angle_back.nc" - CALL allocate_block_data (grid_topo_factor, tea_b_grid, num_azimuth) - CALL ncio_read_block (lndname, 'tea_back', grid_topo_factor, num_azimuth, tea_b_grid) - - lndname = trim(dir_topodata)//"/sky_view_factor.nc" - CALL allocate_block_data (grid_topo_factor, svf_grid) - CALL ncio_read_block (lndname, 'svf', grid_topo_factor, svf_grid) - - lndname = trim(dir_topodata)//"/curvature.nc" - CALL allocate_block_data (grid_topo_factor, cur_grid) - CALL ncio_read_block (lndname, 'curvature', grid_topo_factor, cur_grid) - - ! -------------------------------------------------------------------------- - ! aggregate the terrain factor data from the resolution of raw data to patch - ! -------------------------------------------------------------------------- -#ifdef USEMPI - ! mpi send - CALL aggregation_data_daemon ( grid_topo_factor, & - data_r8_2d_in1 = slp_grid, data_r8_2d_in2 = asp_grid, & - data_r8_2d_in3 = svf_grid, data_r8_2d_in4 = cur_grid, & - data_r8_3d_in1 = tea_f_grid, n1_r8_3d_in1 = num_azimuth, & - data_r8_3d_in2 = tea_b_grid, n1_r8_3d_in2 = num_azimuth) -#endif - ENDIF - - - IF (p_is_worker) THEN - ! allocate for output variables at patches - allocate (svf_patches (numpatch)) - allocate (cur_patches (numpatch)) - allocate (asp_type_patches (num_slope_type, numpatch)) - allocate (slp_type_patches (num_slope_type, numpatch)) - allocate (area_type_patches(num_slope_type, numpatch)) - allocate (sf_lut_patches (num_azimuth, num_zenith, numpatch)) - ! generate sine of sun zenith angles at equal intervals - DO i = 1, num_zenith - zenith_angle(i) = pi/(2*num_zenith)*(i-1) - ENDDO - - ! aggregate loop - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - svf_patches (ipatch) = svf_patches (wmo_src) - cur_patches (ipatch) = cur_patches (wmo_src) - asp_type_patches (:, ipatch) = asp_type_patches (:, wmo_src) - slp_type_patches (:, ipatch) = slp_type_patches (:, wmo_src) - area_type_patches(:, ipatch) = area_type_patches(:, wmo_src) - sf_lut_patches (:, :, ipatch) = sf_lut_patches(:, :, wmo_src) - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, grid_topo_factor, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = slp_grid, data_r8_2d_out1 = slp_one, & - data_r8_2d_in2 = asp_grid, data_r8_2d_out2 = asp_one, & - data_r8_2d_in3 = svf_grid, data_r8_2d_out3 = svf_one, & - data_r8_2d_in4 = cur_grid, data_r8_2d_out4 = cur_one, & - data_r8_3d_in1 = tea_f_grid, data_r8_3d_out1 = tea_f_azi_one, n1_r8_3d_in1 = num_azimuth, & - data_r8_3d_in2 = tea_b_grid, data_r8_3d_out2 = tea_b_azi_one, n1_r8_3d_in2 = num_azimuth) - - ! ------------------------------------------------------------------ - ! aggregate sky view factor, curvature at patches - ! ------------------------------------------------------------------ - IF (any(svf_one /= -9999.0)) THEN - svf_patches (ipatch) = & - sum(svf_one * area_one, mask = svf_one /= -9999.0) & - / sum(area_one, mask = svf_one /= -9999.0) - ELSE - svf_patches (ipatch) = -1.0e36 - ENDIF - - IF (any(cur_one /= -9999.0)) THEN - cur_patches (ipatch) = & - sum(cur_one * area_one, mask = cur_one /= -9999.0) & - / sum(area_one, mask = cur_one /= -9999.0) - ELSE - cur_patches (ipatch) = -1.0e36 - ENDIF - - ! ------------------------------------------------------------------------------ - ! aggregate look up table of shadow factor at patches - ! ------------------------------------------------------------------------------ - ! number of pixels - num_pixels = size(area_one) - - ! allocate pixel variables - allocate(tea_f_one (num_pixels)) - allocate(tea_b_one (num_pixels)) - allocate(sf_one (num_pixels)) - allocate(sf_mask_one (num_pixels)) - - ! sum of areas of one patch - sum_area_one = sum(area_one, mask = area_one>0) - - DO a = 1, num_azimuth - DO z = 1, num_zenith - ! terrain elevation angle at each azimuth - tea_f_one(:) = tea_f_azi_one(a,:) - tea_b_one(:) = tea_b_azi_one(a,:) - - ! count the pixels which are not missing value - count_pixels = 0 - - DO i = 1, num_pixels - IF ((isnan(tea_f_one(i))).or.(isnan(tea_b_one(i)))) THEN - sf_one(i) = 1 ! Not consider the effect of casting shadows - ELSE - IF (tea_f_one(i)>1) tea_f_one(i) = 1 - IF (tea_f_one(i)<-1) tea_f_one(i) = -1 - IF (tea_b_one(i)>1) tea_b_one(i) = 1 - IF (tea_b_one(i)<-1) tea_b_one(i) = -1 - tea_f_one(i) = asin(tea_f_one(i)) - tea_b_one(i) = asin(tea_b_one(i)) - - ! Compare the sun's altitude angle to the terrain's altitude angle - ! to determine the value of the shadow factor. - ! ----------------------------------------------------------------- - ! Sisi Chen, Lu Li, Yongjiu Dai, et al. Exploring Topography Downscaling - ! Methods for Hyper-Resolution Land Surface Modeling. - ! DOI: 10.22541/au.171403656.68476353/v1 - ! ----------------------------------------------------------------- - IF ((tea_b_one(i) /= -9999).and.(tea_f_one(i) /= -9999)) THEN - count_pixels = count_pixels+1 - - IF (pi*0.5 - zenith_angle(z) < tea_b_one(i)) THEN - sf_one(i) = 0 - ELSEIF (pi*0.5 - zenith_angle(z) > tea_f_one(i)) THEN - sf_one(i) = 1 - ELSE - IF (tea_f_one(i).eq.tea_b_one(i)) tea_f_one(i) = tea_b_one(i)+0.001 - sf_one(i) = (0.5*pi - zenith_angle(z) - tea_b_one(i))/(tea_f_one(i) - tea_b_one(i)) - ENDIF - - ENDIF - ENDIF - ENDDO - sf_mask_one(:) = sf_one(:) /= -9999 - sf_lut_patches(a,z,ipatch) = sum(sf_one(:), mask = sf_mask_one)/count_pixels - ENDDO - ENDDO - - ! deallocate - deallocate(tea_f_one) - deallocate(tea_b_one) - deallocate(sf_one) - deallocate(sf_mask_one) - - ! ----------------------------------------------------------------------------------------------- - ! aggregate slope and aspect at four defined types at patches - ! ----------------------------------------------------------------------------------------------- - ! allocate pixelsets variables - allocate(asp_type_one(1:num_slope_type,1:num_pixels)) - allocate(slp_type_one(1:num_slope_type,1:num_pixels)) - allocate(area_type_one(1:num_slope_type,1:num_pixels)) - allocate(slp_mask_one(1:num_pixels)) - allocate(asp_mask_one(1:num_pixels)) - allocate(area_mask_one(1:num_pixels)) - - DO i = 1, num_slope_type - asp_type_one(i,:) = -9999 - slp_type_one(i,:) = -9999 - area_type_one(i,:) = -9999 - ENDDO - - DO i = 1, num_pixels - ! Define the south slope, north slope, abrupt slope and gentle lope of target pixel - IF (((asp_one(i).ge.0 .and. asp_one(i).le.90*pi/180) .or. (asp_one(i).ge.270*pi/180 .and. & - asp_one(i).le.360*pi/180)).and.(slp_one(i).ge.15*pi/180)) THEN ! north abrupt slope - type = 1 - ELSEIF (((asp_one(i).ge.0 .and. asp_one(i).le.90*pi/180) .or. (asp_one(i).ge.270*pi/180 .and. & - asp_one(i).le.360*pi/180)).and.(slp_one(i)<15*pi/180)) THEN ! north gentle slope - type = 2 - ELSEIF ((asp_one(i).gt.90*pi/180) .and. (asp_one(i).lt.270*pi/180) .and. & - (slp_one(i).ge.15*pi/180)) THEN ! south abrupt slope - type = 3 - ELSEIF ((asp_one(i).gt.90*pi/180) .and. (asp_one(i).lt.270*pi/180) .and. & - (slp_one(i).lt.15*pi/180)) THEN ! south gentle slope - type = 4 - ELSE ! missing value=-9999 - CYCLE - ENDIF - - IF ((area_one(i)>0).and.(area_one(i)<=sum_area_one)) THEN ! quality control - area_type_one(type,i) = area_one(i) - asp_type_one (type,i) = asp_one(i)*area_one(i) - slp_type_one (type,i) = slp_one(i)*area_one(i) - ENDIF - ENDDO - - ! assign value to four types at patches - DO i = 1, num_slope_type - IF (sum_area_one.eq.0.0) THEN - area_type_patches(i,ipatch) = 0 - asp_type_patches(i,ipatch) = 0 - slp_type_patches(i,ipatch) = 0 - ELSE - area_mask_one(:) = area_type_one(i,:) /= -9999 - area_type_patches(i,ipatch) = sum(area_type_one(i,:), mask = area_mask_one(:))/sum_area_one - asp_mask_one(:) = asp_type_one(i,:) /= -9999 - asp_type_patches(i,ipatch) = sum(asp_type_one(i,:), mask = asp_mask_one(:))/sum_area_one - slp_mask_one(:) = slp_type_one(i,:) /= -9999 - slp_type_patches(i,ipatch) = sum(slp_type_one(i,:), mask = slp_mask_one(:))/sum_area_one - ENDIF - ENDDO - - ! deallocate - deallocate(asp_type_one) - deallocate(slp_type_one) - deallocate(area_type_one) - deallocate(slp_mask_one) - deallocate(asp_mask_one) - deallocate(area_mask_one) - ENDDO - - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('svf_patches ', svf_patches ) - CALL check_vector_data ('cur_patches ', cur_patches ) - CALL check_vector_data ('slp_type_patches ', slp_type_patches ) - CALL check_vector_data ('asp_type_patches ', asp_type_patches ) - CALL check_vector_data ('area_type_patches ', area_type_patches) - CALL check_vector_data ('sf_lut_patches ', sf_lut_patches ) -#endif - -! Reduce the dimension of the shadow factor array -! Construct a new array with dimensions of sf_curve_patches(azimuth, shadow factor parameters, patches) - IF (p_is_worker) THEN - allocate(sf_curve_patches(num_azimuth,num_zenith_parameter,numpatch)) - DO a = 1, num_azimuth - DO ipatch = 1, numpatch - y(:) = sf_lut_patches(a,:,ipatch) - x(:) = zenith_angle(:) - - ! Obtain the last position of y==1 - index = 1 - DO z = 1, num_zenith-1 - IF ((y(z)==1.).and.(y(z+1)<1.)) THEN - index = z+1 - ENDIF - ENDDO - - ! allocate Allocate memory to dynamic arrays - n = num_zenith - index +1 - allocate(y_train(n)) - allocate(x_train(n)) - allocate(y_train_transform(n)) - - ! Obtain the predicted value y_train and prediction factor x_train for fitting, - ! the form of the fitting function is - ! ln(-ln(y_train)) = a1*x_train+a2 - y_train(:) = y(index:) - x_train(:) = x(index:) - - ! Transform y_train to enable linear regression fitting - DO i = 1, n - IF (y_train(i) <= 0.) y_train(i) = 0.001 - IF (y_train(i) >= 1.) y_train(i) = 0.999 - ENDDO - y_train_transform(:) = log(-1*log(y_train(:))) - - ! Obtain parameters a1 and a2 using the least squares method - x_sum = 0. - xy_sum = 0. - y_sum = 0. - x2_sum = 0. - DO z = 1, n - xy_sum = xy_sum + x_train(z)*y_train_transform(z) - x_sum = x_sum + x_train(z) - y_sum = y_sum + y_train_transform(z) - x2_sum = x2_sum + x_train(z)*x_train(z) - ENDDO - IF (n*x2_sum - x_sum*x_sum == 0.) THEN - a1 = 0 - a2 = 0 - ELSE - a1 = (n*xy_sum - x_sum*y_sum)/(n*x2_sum - x_sum*x_sum) - a2 = (y_sum - a1*x_sum)/n - ENDIF - sf_curve_patches(a,1,ipatch) = x(index-1) ! Minimum zenith angle at which occlusion begins - sf_curve_patches(a,2,ipatch) = a1 - sf_curve_patches(a,3,ipatch) = a2 - - ! deallocate - deallocate(y_train) - deallocate(x_train) - deallocate(y_train_transform) - ENDDO - ENDDO - ENDIF - - lndname = trim(landdir)//'/svf_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'svf_patches', 'patch', landpatch, svf_patches, 1) - - lndname = trim(landdir)//'/cur_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'cur_patches', 'patch', landpatch, cur_patches, 1) - - lndname = trim(landdir)//'/slp_type_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_slope_type) - CALL ncio_write_vector (lndname, 'slp_type_patches', 'slope_type', num_slope_type, 'patch', landpatch, slp_type_patches, 1) - - lndname = trim(landdir)//'/asp_type_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_slope_type) - CALL ncio_write_vector (lndname, 'asp_type_patches', 'slope_type', num_slope_type, 'patch', landpatch, asp_type_patches, 1) - - lndname = trim(landdir)//'/area_type_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_slope_type) - CALL ncio_write_vector (lndname, 'area_type_patches', 'slope_type', num_slope_type, 'patch', landpatch, area_type_patches, 1) - - lndname = trim(landdir)//'/sf_curve_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_define_dimension_vector (lndname, landpatch, 'azimuth', num_azimuth) - CALL ncio_define_dimension_vector (lndname, landpatch, 'zenith_p', num_zenith_parameter) - CALL ncio_write_vector (lndname, 'sf_curve_patches', 'azimuth', num_azimuth, 'zenith_p', num_zenith_parameter, 'patch', & - landpatch, sf_curve_patches, 1) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - - ! only write the first type of slope and aspect at patches - lndname = trim(dir_model_landdata) // '/diag/topo_factor_slp_' // trim(cyear) // '.nc' - DO i = 1, num_slope_type - write(sdir,'(I0)') i - CALL srfdata_map_and_write (slp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'slp_'//trim(sdir), compress = 1, write_mode = 'one') - ENDDO - - lndname = trim(dir_model_landdata) // '/diag/topo_factor_asp_' // trim(cyear) // '.nc' - DO i = 1, num_slope_type - write(sdir,'(I0)') i - CALL srfdata_map_and_write (asp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'asp_'//trim(sdir), compress = 1, write_mode = 'one') - ENDDO - - lndname = trim(dir_model_landdata) // '/diag/topo_factor_svf_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (svf_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'svf', compress = 1, write_mode = 'one') - - lndname = trim(dir_model_landdata) // '/diag/topo_factor_cur_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (cur_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'cur', compress = 1, write_mode = 'one') - - lndname = trim(dir_model_landdata) // '/diag/topo_factor_sf_lut_' // trim(cyear) // '.nc' - - DO j = 1, num_azimuth - DO i = 1, num_zenith - write(sdir,'(I0)') j - write(sdir1,'(I0)') i - CALL srfdata_map_and_write (sf_lut_patches(j,i,:), landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'sf_'//trim(sdir)//'_'//trim(sdir1), compress = 1, write_mode = 'one') - ENDDO - ENDDO -#endif - - IF (p_is_worker) THEN - IF (allocated(slp_type_patches)) deallocate ( slp_type_patches ) - IF (allocated(asp_type_patches)) deallocate ( asp_type_patches ) - IF (allocated(sf_lut_patches )) deallocate ( sf_lut_patches ) - IF (allocated(sf_curve_patches)) deallocate ( sf_curve_patches ) - IF (allocated(svf_patches )) deallocate ( svf_patches ) - IF (allocated(cur_patches )) deallocate ( cur_patches ) - ENDIF - -END SUBROUTINE Aggregation_TopographyFactors diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 deleted file mode 100644 index 1eea5400f4..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_TopographyFactors_Simple.F90 +++ /dev/null @@ -1,242 +0,0 @@ -#include - -SUBROUTINE Aggregation_TopographyFactors_Simple ( & - grid_topo_factor , dir_topodata, dir_model_landdata, lc_year) -!----------------------------------------------------------------------- -! Global topography-based factors data -! -! Created by Sisi Chen, 08/2025 -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_AggregationRequestData - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_Mesh, only: numelm - USE MOD_LandElm - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - ! arguments: - ! --------------------------------------------------------------- - integer, intent(in) :: lc_year - type(grid_type), intent(in) :: grid_topo_factor ! Grid structure for high resolution topography factors - character(len=*), intent(in) :: dir_topodata ! Direct of Rawdata - character(len=*), intent(in) :: dir_model_landdata - - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: landdir, lndname, cyear - character(len=3) :: sdir, sdir1 - integer :: wmo_src - - type (block_data_real8_3d) :: slp_grid ! slope - type (block_data_real8_3d) :: asp_grid ! aspect - type (block_data_real8_2d) :: cur_grid ! curvature - - ! patch - real(r8), allocatable :: cur_patches (:) - - ! nine defined types at all patches - real(r8), allocatable :: asp_type_patches (:,:) ! shape as (type, patches) - real(r8), allocatable :: slp_type_patches (:,:) - - ! pixelsets - real(r8), allocatable :: cur_one (:) - real(r8), allocatable :: area_one (:) - - ! pixelsets of nine defined types at each patch - real(r8), allocatable :: slp_one (:,:) - real(r8), allocatable :: asp_one (:,:) - - ! local variables - integer :: ipatch, i - -#ifdef SrfdataDiag - integer :: typpatch(N_land_classification+1), ityp ! number of land classification -#endif - write(cyear,'(i4.4)') lc_year - landdir = trim(dir_model_landdata) // '/topography/' // trim(cyear) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Aggregate topography factor ...' - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! ------------------------------------------------------------------- - ! read topography-based factor data - ! ------------------------------------------------------------------- - IF (p_is_io) THEN - lndname = trim(dir_topodata)//"/topography_MERITHydro.nc" - CALL allocate_block_data (grid_topo_factor, slp_grid, num_aspect_type) - CALL ncio_read_block (lndname, 'slp_aspect', grid_topo_factor, num_aspect_type, slp_grid) - - lndname = trim(dir_topodata)//"/topography_MERITHydro.nc" - CALL allocate_block_data (grid_topo_factor, asp_grid, num_aspect_type) - CALL ncio_read_block (lndname, 'pct_aspect', grid_topo_factor, num_aspect_type, asp_grid) - - lndname = trim(dir_topodata)//"/curvature_MERITHydro.nc" - CALL allocate_block_data (grid_topo_factor, cur_grid) - CALL ncio_read_block (lndname, 'curvature', grid_topo_factor, cur_grid) - - ! -------------------------------------------------------------------------- - ! aggregate the terrain factor data from the resolution of raw data to patch - ! -------------------------------------------------------------------------- -#ifdef USEMPI - ! mpi send - CALL aggregation_data_daemon ( grid_topo_factor, & - data_r8_2d_in1 = cur_grid, & - data_r8_3d_in1 = slp_grid, n1_r8_3d_in1 = num_aspect_type, & - data_r8_3d_in2 = asp_grid, n1_r8_3d_in2 = num_aspect_type) -#endif - ENDIF - - - IF (p_is_worker) THEN - ! allocate for output variables at patches - allocate (cur_patches (numpatch)) - allocate (asp_type_patches (num_aspect_type, numpatch)) - allocate (slp_type_patches (num_aspect_type, numpatch)) - - ! aggregate loop - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - wmo_src = wmo_source (landpatch%ielm(ipatch)) - - cur_patches ( ipatch) = cur_patches ( wmo_src) - asp_type_patches(:,ipatch) = asp_type_patches(:,wmo_src) - slp_type_patches(:,ipatch) = slp_type_patches(:,wmo_src) - - CYCLE - ENDIF - - CALL aggregation_request_data (landpatch, ipatch, grid_topo_factor, & - zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = cur_grid, data_r8_2d_out1 = cur_one, & - data_r8_3d_in1 = slp_grid, data_r8_3d_out1 = slp_one, n1_r8_3d_in1 = num_aspect_type, & - data_r8_3d_in2 = asp_grid, data_r8_3d_out2 = asp_one, n1_r8_3d_in2 = num_aspect_type) - - ! ------------------------------------------------------------------ - ! aggregate curvature at patches - ! ------------------------------------------------------------------ - - IF (any(cur_one /= -9999.0)) THEN - cur_patches (ipatch) = & - sum(cur_one * area_one, mask = cur_one /= -9999.0) & - / sum(area_one, mask = cur_one /= -9999.0) - ELSE - cur_patches (ipatch) = -1.0e36 - ENDIF - - ! ------------------------------------------------------------------ - ! aggregate slope and aspect at each direction of aspect of patches. - ! num_aspect_type = 1:north, 2:northeast, 3:east, 4:southeast, 5:south, 6:southwest, 7:west, 8:northwest, 9:flat - ! ------------------------------------------------------------------ - DO i = 1, num_aspect_type - IF (any(asp_one(i,:) /= -9999.0)) THEN - asp_type_patches (i, ipatch) = & - sum(asp_one(i,:) * area_one(:), mask = asp_one(i,:) /= -9999.0) & - / sum(area_one, mask = asp_one(i,:) /= -9999.0) - ELSE - asp_type_patches (i, ipatch) = -1.0e36 - ENDIF - IF (any(slp_one(i,:) /= -9999.0)) THEN - slp_type_patches (i, ipatch) = & - sum(slp_one(i,:) * area_one(:), mask = slp_one(i,:) /= -9999.0) & - / sum(area_one, mask = slp_one(i,:) /= -9999.0) - ELSE - slp_type_patches (i, ipatch) = -1.0e36 - ENDIF - - ENDDO - - ENDDO - - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('cur_patches ', cur_patches ) - CALL check_vector_data ('slp_type_patches ', slp_type_patches ) - CALL check_vector_data ('asp_type_patches ', asp_type_patches ) -#endif - - ! -------------------------------------------------------------------------- - ! write aggregated data to netcdf files - ! -------------------------------------------------------------------------- - - lndname = trim(landdir)//'/cur_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'cur_patches', 'patch', landpatch, cur_patches, 1) - - lndname = trim(landdir)//'/slp_type_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_aspect_type) - CALL ncio_write_vector (lndname, 'slp_type_patches', 'slope_type', num_aspect_type, 'patch', landpatch, slp_type_patches, 1) - - lndname = trim(landdir)//'/asp_type_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_define_dimension_vector (lndname, landpatch, 'slope_type', num_aspect_type) - CALL ncio_write_vector (lndname, 'asp_type_patches', 'slope_type', num_aspect_type, 'patch', landpatch, asp_type_patches, 1) - - ! -------------------------------------------------------------------------- -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - - ! only write the first type of slope and aspect at patches - lndname = trim(dir_model_landdata) // '/diag/topo_factor_slp_' // trim(cyear) // '.nc' - DO i = 1, num_aspect_type - write(sdir,'(I0)') i - CALL srfdata_map_and_write (slp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'slp_'//trim(sdir), compress = 1, write_mode = 'one') - ENDDO - - lndname = trim(dir_model_landdata) // '/diag/topo_factor_asp_' // trim(cyear) // '.nc' - DO i = 1, num_aspect_type - write(sdir,'(I0)') i - CALL srfdata_map_and_write (asp_type_patches(i,:), landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'asp_'//trim(sdir), compress = 1, write_mode = 'one') - ENDDO - - ! write curvature at patches - lndname = trim(dir_model_landdata) // '/diag/topo_factor_cur_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (cur_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'cur', compress = 1, write_mode = 'one') - -#endif - - IF (p_is_worker) THEN - IF (allocated(slp_type_patches)) deallocate ( slp_type_patches ) - IF (allocated(asp_type_patches)) deallocate ( asp_type_patches ) - IF (allocated(cur_patches )) deallocate ( cur_patches ) - ENDIF - -END SUBROUTINE Aggregation_TopographyFactors_Simple diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 deleted file mode 100644 index 8dd0d9d677..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/Aggregation_Urban.F90 +++ /dev/null @@ -1,1293 +0,0 @@ -#include - -!----------------------------------------------------------------------- -! -! !DESCRIPTION: -! Aggregate/screen high-resolution urban dataset to a lower -! resolution/subset data, suitable for running regional or point -! cases. -! -! Original authors: Hua Yuan and Wenzong Dong, 2021, OpenMP version. -! -! !REVISIONS: -! 05/2023, Wenzong Dong, Hua Yuan, Shupeng Zhang: porting codes to MPI -! parallel version. -! -! 08/2025, Wenzong Dong, Hua Yuan: unifying the urban surface data -! code for different urban type schemes. -!----------------------------------------------------------------------- - -#ifdef URBAN_MODEL -SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & - grid_urban_5km, grid_urban_500m) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_NetCDFSerial - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_AggregationRequestData - USE MOD_5x5DataReadin - USE MOD_DataType - USE MOD_Utils, only: num_max_frequency - USE MOD_LandUrban - USE MOD_LandElm - USE MOD_Mesh - USE MOD_Vars_Global, only: N_URB, nl_roof, nl_wall, nl_soil - USE MOD_Urban_Const_LCZ -#ifdef RangeCheck - USE MOD_RangeCheck -#endif -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif - - IMPLICIT NONE - - character(len=256), intent(in) :: dir_rawdata - character(len=256), intent(in) :: dir_srfdata - - integer , intent(in) :: lc_year - - type(grid_type), intent(in) :: grid_urban_5km - !type(grid_type), intent(in) :: grid_urban_100m - type(grid_type), intent(in) :: grid_urban_500m - - ! dimensions - integer, parameter :: rid = 33 - integer, parameter :: ns = 2 - integer, parameter :: nr = 2 - integer, parameter :: ulev = 10 - - ! input variables - type(block_data_int32_2d) :: LUCY_reg - type(block_data_real8_2d) :: pop - type(block_data_real8_2d) :: fvegu - type(block_data_real8_2d) :: htopu - type(block_data_real8_2d) :: flakeu - type(block_data_real8_2d) :: wtroof - type(block_data_real8_2d) :: htroof - type(block_data_real8_2d) :: ulai - type(block_data_real8_2d) :: usai - type(block_data_int32_2d) :: reg_typid - - ! output variables - integer , ALLOCATABLE, dimension(:) :: LUCY_rid - real(r8), ALLOCATABLE, dimension(:) :: pop_den - real(r8), ALLOCATABLE, dimension(:) :: pct_tree - real(r8), ALLOCATABLE, dimension(:) :: htop_urb - real(r8), ALLOCATABLE, dimension(:) :: pct_water - real(r8), ALLOCATABLE, dimension(:) :: wt_roof - real(r8), ALLOCATABLE, dimension(:) :: ht_roof - real(r8), ALLOCATABLE, dimension(:) :: lai_urb - real(r8), ALLOCATABLE, dimension(:) :: sai_urb - - ! delete variables not used - integer , allocatable, dimension(:) :: reg_typid_one - integer , allocatable, dimension(:) :: LUCY_reg_one - real(r8), allocatable, dimension(:) :: area_one - real(r8), allocatable, dimension(:) :: pop_one - real(r8), allocatable, dimension(:) :: fvegu_one - real(r8), allocatable, dimension(:) :: htopu_one - real(r8), allocatable, dimension(:) :: flakeu_one - real(r8), allocatable, dimension(:) :: wt_roof_one - real(r8), allocatable, dimension(:) :: ht_roof_one - real(r8), allocatable, dimension(:) :: hlr_bld_one - real(r8), allocatable, dimension(:) :: ulai_one - real(r8), allocatable, dimension(:) :: slai_one - - ! urban morphological and thermal paras of NCAR data - ! input variables, NCAR look-up-table data - real(r8), allocatable, dimension(:,:) :: hwrbld_ncar , fgper_ncar , & - htroof_ncar , wtroof_ncar - real(r8), allocatable, dimension(:,:) :: emroof_ncar , emwall_ncar , & - emgimp_ncar , emgper_ncar - real(r8), allocatable, dimension(:,:) :: thkroof_ncar, thkwall_ncar, & - tbldmin_ncar, tbldmax_ncar - real(r8), allocatable, dimension(:,:,:) :: cvroof_ncar , cvwall_ncar , cvgimp_ncar , & - tkroof_ncar , tkwall_ncar , tkgimp_ncar - real(r8), allocatable, dimension(:,:,:,:) :: albroof_ncar, albwall_ncar, & - albgimp_ncar, albgper_ncar - - ! output variables, vector data - real(r8), ALLOCATABLE, dimension(:) :: area_urb - real(r8), ALLOCATABLE, dimension(:) :: sarea_urb - real(r8), ALLOCATABLE, dimension(:) :: urb_pct - - real(r8), ALLOCATABLE, dimension(:) :: hlr_bld - real(r8), ALLOCATABLE, dimension(:) :: fgper - real(r8), ALLOCATABLE, dimension(:) :: em_roof - real(r8), ALLOCATABLE, dimension(:) :: em_wall - real(r8), ALLOCATABLE, dimension(:) :: em_gimp - real(r8), ALLOCATABLE, dimension(:) :: em_gper - real(r8), ALLOCATABLE, dimension(:) :: thk_roof - real(r8), ALLOCATABLE, dimension(:) :: thk_wall - real(r8), ALLOCATABLE, dimension(:) :: tbld_min - real(r8), ALLOCATABLE, dimension(:) :: tbld_max - - real(r8), ALLOCATABLE, dimension(:,:) :: cv_wgt - real(r8), ALLOCATABLE, dimension(:,:) :: tk_wgt - real(r8), ALLOCATABLE, dimension(:,:) :: cv_roof - real(r8), ALLOCATABLE, dimension(:,:) :: cv_wall - real(r8), ALLOCATABLE, dimension(:,:) :: cv_gimp - real(r8), ALLOCATABLE, dimension(:,:) :: tk_roof - real(r8), ALLOCATABLE, dimension(:,:) :: tk_wall - real(r8), ALLOCATABLE, dimension(:,:) :: tk_gimp - - real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_roof - real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_wall - real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_gimp - real(r8), ALLOCATABLE, dimension(:,:,:) :: alb_gper - - integer , allocatable, dimension(:) :: locpth - - ! landfile variables - character(len=256) landsrfdir, landdir, landname, suffix - character(len=4 ) cyear, c5year, cmonth, clay, c1, iyear - - ! local vars - real(r8) :: sumarea - real(r8) :: hlrbld, fgper_, thkroof, thkwall, tbldmin, tbldmax - real(r8) :: emroof, emwall, emgper , emgimp - real(r8) :: cvroof(nl_roof), cvwall(nl_wall), cvgimp(nl_soil) - real(r8) :: tkroof(nl_roof), tkwall(nl_wall), tkgimp(nl_soil) - real(r8) :: albroof(nr,ns), albwall(nr,ns), albgper(nr,nr), albgimp(nr,ns) - - ! index - integer :: iurban, urb_typidx, urb_regidx - integer :: pop_i, imonth, start_year, end_year - integer :: ipth, ipxl, il, iy, ielm, numpth, urb_s, urb_e - - ! for surface data diag -#ifdef SrfdataDiag - integer :: ityp - integer , allocatable, dimension(:) :: typindex - real(r8), allocatable :: LUCY_rid_r8 (:) -#endif - logical :: first_call_LSAI_urban - -#ifdef SrfdataDiag - allocate( typindex(N_URB) ) -#endif - - write(cyear,'(i4.4)') lc_year - landsrfdir = trim(dir_srfdata) // '/urban/' // trim(cyear) - - first_call_LSAI_urban = .true. - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_master) THEN - write(*,'(/, A)') 'Making urban data ('//trim(cyear)//') ...' - CALL system('mkdir -p ' // trim(adjustl(landsrfdir))) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - write(c5year, '(i4.4)') int(lc_year/5)*5 - - - ! ******* Building morphology: WT_ROOF, HT_ROOF, and HL ******* - ! if building data is missing, how to use look-up-table? - ! a new array with urban type was used for look-up-table -IF (DEF_URBAN_type_scheme == 1) THEN - ! only used when urban patch have nan data of building height, building fraction and HL - landname = TRIM(dir_rawdata)//'urban/NCAR_urban_properties.nc' - - CALL ncio_read_bcast_serial (landname, "WTLUNIT_ROOF", wtroof_ncar ) - CALL ncio_read_bcast_serial (landname, "HT_ROOF" , htroof_ncar ) - CALL ncio_read_bcast_serial (landname, "CANYON_HWR" , hwrbld_ncar ) -ENDIF - - ! allocate and read grided building height and fraction raw data - IF (p_is_io) THEN - CALL allocate_block_data (grid_urban_500m, reg_typid) - CALL allocate_block_data (grid_urban_500m, wtroof ) - CALL allocate_block_data (grid_urban_500m, htroof ) - -IF (DEF_URBAN_type_scheme == 1) THEN - landdir = TRIM(dir_rawdata)//'urban_type/' - suffix = 'URBTYP' - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "REGION_ID", reg_typid) -ENDIF - - landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URBSRF'//trim(c5year) -IF (DEF_Urban_geom_data == 1) THEN - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_ROOF_GHSL", wtroof) - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HT_ROOF_GHSL" , htroof) -ELSE - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_ROOF_Li", wtroof) - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HT_ROOF_Li" , htroof) -ENDIF - -#ifdef USEMPI -IF (DEF_URBAN_type_scheme == 1) THEN - CALL aggregation_data_daemon (grid_urban_500m, data_i4_2d_in1 = reg_typid, & - data_r8_2d_in1 = wtroof, data_r8_2d_in2 = htroof) -ELSE - CALL aggregation_data_daemon (grid_urban_500m, data_r8_2d_in1 = wtroof, data_r8_2d_in2 = htroof) -ENDIF -#endif - ENDIF - - IF (p_is_worker) THEN - allocate (wt_roof (numurban)) - allocate (ht_roof (numurban)) - allocate (hlr_bld (numurban)) - - ! loop for urban patch to aggregate building height and fraction data with area-weighted average - DO iurban = 1, numurban - - ! when urban patch has no data, use table data to fill gap - ! urban type and region id for look-up-table - urb_typidx = landurban%settyp(iurban) - -IF (DEF_URBAN_type_scheme == 1) THEN - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & - data_i4_2d_in1 = reg_typid, data_i4_2d_out1 = reg_typid_one, & - data_r8_2d_in1 = wtroof, data_r8_2d_out1 = wt_roof_one, & - data_r8_2d_in2 = htroof, data_r8_2d_out2 = ht_roof_one) - - IF (.not. allocated(hlr_bld_one)) THEN - allocate (hlr_bld_one (size(area_one))) - hlr_bld_one = 0. - ELSE - deallocate (hlr_bld_one) - allocate (hlr_bld_one (size(area_one))) - hlr_bld_one = 0. - ENDIF - - ! RG_-45_65_-50_70 of NCAR has no urban data, - ! all urban patches of this area are assigned to region 30 - IF (all(reg_typid_one==0)) THEN - reg_typid_one(:) = 30 - ENDIF - - IF (any(reg_typid_one==0)) THEN - WHERE(reg_typid_one==0) reg_typid_one = num_max_frequency(reg_typid_one) - ENDIF - - WHERE (wt_roof_one <= 0) - wt_roof_one = wtroof_ncar(urb_typidx,reg_typid_one) - END WHERE - - WHERE (ht_roof_one <= 0) - ht_roof_one = htroof_ncar(urb_typidx,reg_typid_one) - END WHERE - -IF (DEF_USE_CANYON_HWR) THEN - WHERE (hlr_bld_one <= 0) - hlr_bld_one = hwrbld_ncar(urb_typidx,reg_typid_one) - END WHERE -ELSE - WHERE (hlr_bld_one <= 0) - hlr_bld_one = hwrbld_ncar(urb_typidx,reg_typid_one) & - *(1-sqrt(wtroof_ncar(urb_typidx,reg_typid_one))) & - /sqrt(wtroof_ncar(urb_typidx,reg_typid_one)) - END WHERE -ENDIF - -ELSE IF (DEF_URBAN_type_scheme == 2) THEN - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = wtroof, data_r8_2d_out1 = wt_roof_one, & - data_r8_2d_in2 = htroof, data_r8_2d_out2 = ht_roof_one) - - IF (.not. allocated(hlr_bld_one)) THEN - allocate (hlr_bld_one (size(area_one))) - hlr_bld_one = 0. - ELSE - deallocate (hlr_bld_one) - allocate (hlr_bld_one (size(area_one))) - hlr_bld_one = 0. - ENDIF - - WHERE (wt_roof_one <= 0) - wt_roof_one = wtroof_lcz(urb_typidx) - END WHERE - - WHERE (ht_roof_one <= 0) - ht_roof_one = htroof_lcz(urb_typidx) - END WHERE - -IF (DEF_USE_CANYON_HWR) THEN - WHERE (hlr_bld_one <= 0) - hlr_bld_one = hwrbld_lcz(urb_typidx) - END WHERE -ELSE - WHERE (hlr_bld_one <= 0) - hlr_bld_one = hwrbld_lcz(urb_typidx) & - *(1-sqrt(wtroof_lcz(urb_typidx))) & - /sqrt(wtroof_lcz(urb_typidx)) - END WHERE -ENDIF - -ENDIF - ! area-weight average - wt_roof(iurban) = sum(wt_roof_one * area_one) / sum(area_one) - ht_roof(iurban) = sum(ht_roof_one * area_one) / sum(area_one) - hlr_bld(iurban) = sum(hlr_bld_one * area_one) / sum(area_one) - -IF (DEF_USE_CANYON_HWR) THEN - ! IF the parameter read is canyon H/W ratio, convert it to H/R ratio - hlr_bld(iurban) = hlr_bld(iurban)*(1-sqrt(wt_roof(iurban)))/sqrt(wt_roof(iurban)) -ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/WT_ROOF.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'WT_ROOF', 'urban', landurban, wt_roof, DEF_Srfdata_CompressLevel) - - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/HT_ROOF.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'HT_ROOF', 'urban', landurban, ht_roof, DEF_Srfdata_CompressLevel) - - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/HLR_BLD.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'BUILDING_HLR' , 'urban', landurban, hlr_bld, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/ht_roof_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (ht_roof, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'HT_ROOF', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) - - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/wt_roof_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (wt_roof, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'WT_ROOF', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) - - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/hlr_bld_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (wt_roof, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'BUILDING_HLR', compress = 0, write_mode = 'one', defval=0._r8, create_mode = .true.) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('Urban Roof Fraction ', wt_roof) - CALL check_vector_data ('Urban Roof Height ' , ht_roof) - CALL check_vector_data ('Urban Building HLR ' , hlr_bld) -#endif - - - ! ******* Tree : PCT_Tree, HTOP ******* - ! allocate and read the grided tree cover and tree height raw data(500m) - ! NOTE, tree cover raw data is available every five years, - ! tree height raw data is same from year to year - IF (p_is_io) THEN - - landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URBSRF'//trim(c5year) - - CALL allocate_block_data (grid_urban_500m, fvegu) - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_Tree", fvegu) - - CALL allocate_block_data (grid_urban_500m, htopu) - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HTOP", htopu) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_urban_500m, & - data_r8_2d_in1 = fvegu, data_r8_2d_in2 = htopu) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (pct_tree(numurban)) - allocate (htop_urb(numurban)) - - pct_tree(:) = 0. - htop_urb(:) = 0. - - ! loop for urban patch to aggregate tree cover and height data with area-weighted average - DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = fvegu, data_r8_2d_out1 = fvegu_one, & - data_r8_2d_in2 = htopu, data_r8_2d_out2 = htopu_one) - - ! missing tree cover and tree height data (-999) were filtered - WHERE (fvegu_one < 0) - area_one = 0 - END WHERE - - WHERE (htopu_one < 0) - area_one = 0 - END WHERE - - ! area-weighted average - IF (sum(area_one) > 0._r8) THEN - ! print*, sum(area_one) - pct_tree(iurban) = sum(fvegu_one * area_one) / sum(area_one) - htop_urb(iurban) = sum(htopu_one * area_one) / sum(area_one) - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/PCT_Tree.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'PCT_Tree', 'urban', landurban, pct_tree, DEF_Srfdata_CompressLevel) - - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/htop_urb.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'URBAN_TREE_TOP', 'urban', landurban, htop_urb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/pct_urban_tree_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (pct_tree, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'PCT_Urban_Tree', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) - - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/htop_urban_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (htop_urb, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'Urban_Tree_HTOP', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('Urban Tree Cover ', pct_tree) - CALL check_vector_data ('Urban Tree Top ' , htop_urb) -#endif - - - ! ******* LAI, SAI ******* -#ifndef LULCC -IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = max(DEF_LAI_START_YEAR, DEF_simulation_time%start_year) - end_year = min(DEF_LAI_END_YEAR, DEF_simulation_time%end_year ) -ELSE - start_year = lc_year - end_year = lc_year -ENDIF -#else - start_year = lc_year - end_year = lc_year -#endif - - IF (p_is_io) THEN - CALL allocate_block_data (grid_urban_500m, ulai) - CALL allocate_block_data (grid_urban_500m, usai) - ENDIF - - IF (p_is_worker) THEN - allocate (lai_urb (numurban)) - allocate (sai_urb (numurban)) - - lai_urb(:) = 0. - sai_urb(:) = 0. - ENDIF - - DO iy = start_year, end_year - - IF (iy < 2000) THEN - write(iyear,'(i4.4)') 2000 - ELSE - write(iyear,'(i4.4)') iy - ENDIF - - landsrfdir = trim(dir_srfdata) // '/urban/' // trim(iyear) // '/LAI' - CALL system('mkdir -p ' // trim(adjustl(landsrfdir))) - - ! allocate and read grided LSAI raw data - landdir = trim(dir_rawdata)//'/urban_lai_500m/' - suffix = 'URBLAI_'//trim(iyear) - - ! loop for month - DO imonth = 1, 12 - - write(cmonth, '(i2.2)') imonth - - IF (p_is_master) THEN - write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate LAI&SAI :', iy, ':', imonth, '/', 12 - ENDIF - - IF (p_is_io) THEN - - CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "URBAN_TREE_LAI", imonth, ulai) - CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "URBAN_TREE_SAI", imonth, usai) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_urban_500m, & - data_r8_2d_in1 = fvegu, data_r8_2d_in2 = ulai, data_r8_2d_in3 = usai) -#endif - ENDIF - - IF (p_is_worker) THEN - - ! loop for urban patch to aggregate LSAI data - DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = fvegu, data_r8_2d_out1 = fvegu_one, & - data_r8_2d_in2 = ulai , data_r8_2d_out2 = ulai_one , & - data_r8_2d_in3 = usai , data_r8_2d_out3 = slai_one ) - - WHERE (fvegu_one < 0) - area_one = 0 - END WHERE - - ! area-weight average - IF (sum(fvegu_one * area_one) > 0) THEN - lai_urb(iurban) = sum(ulai_one * fvegu_one * area_one) / & - sum(fvegu_one * area_one) - sai_urb(iurban) = sum(slai_one * fvegu_one * area_one) / & - sum(fvegu_one * area_one) - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(iyear)//'/LAI/urban_LAI_'//trim(cmonth)//'.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'TREE_LAI', 'urban', landurban, lai_urb, DEF_Srfdata_CompressLevel) - - landname = trim(dir_srfdata) // '/urban/'//trim(iyear)//'/LAI/urban_SAI_'//trim(cmonth)//'.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'TREE_SAI', 'urban', landurban, sai_urb, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/LAI_urban_'//trim(iyear)//'.nc' - CALL srfdata_map_and_write (lai_urb, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'Urban_Tree_LAI', compress = 0, write_mode = 'one', & - lastdimname = 'Itime', lastdimvalue = imonth, defval = 0._r8, create_mode = first_call_LSAI_urban) - - landname = trim(dir_srfdata) // '/diag/SAI_urban_'//trim(iyear)//'.nc' - CALL srfdata_map_and_write (sai_urb, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'Urban_Tree_SAI', compress = 0, write_mode = 'one', & - lastdimname = 'Itime', lastdimvalue = imonth, defval = 0._r8, create_mode = first_call_LSAI_urban) - - IF (first_call_LSAI_urban) first_call_LSAI_urban = .false. -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - write(c1,'(i2.2)') imonth - -#ifdef RangeCheck - CALL check_vector_data ('Urban Tree LAI '//trim(c1), lai_urb) - CALL check_vector_data ('Urban Tree SAI '//trim(c1), sai_urb) -#endif - ENDDO - first_call_LSAI_urban = .true. - ENDDO - - - ! ******* PCT_Water ******* - ! allocate and read grided water cover raw data - IF (p_is_io) THEN - - CALL allocate_block_data (grid_urban_500m, flakeu) - - landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URBSRF'//trim(c5year) - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_Water", flakeu) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_urban_500m, flakeu) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (pct_water (numurban)) - - pct_water (:) = 0. - ! loop for urban patch to aggregate water cover data with area-weighted average - DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & - data_r8_2d_in1 = flakeu, data_r8_2d_out1 = flakeu_one) - - WHERE (flakeu_one < 0) - area_one = 0 - END WHERE - ! only calculate when urban patch have water cover - IF (sum(area_one) > 0) THEN - pct_water(iurban) = sum(flakeu_one * area_one) / sum(area_one) - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/PCT_Water.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'PCT_Water', 'urban', landurban, pct_water, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/pct_urban_water_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (pct_water, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'PCT_Urban_Water', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('Urban Water Cover ', pct_water) -#endif - - - ! ******* LUCY_id ******* - ! allocate and read the LUCY id - IF (p_is_io) THEN - - landname = TRIM(dir_rawdata)//'urban/LUCY_regionid.nc' - CALL allocate_block_data (grid_urban_5km, LUCY_reg) - CALL ncio_read_block (landname, 'LUCY_REGION_ID', grid_urban_5km, LUCY_reg) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_urban_5km, data_i4_2d_in1 = LUCY_reg) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate ( LUCY_rid (numurban)) - - LUCY_rid (:) = 0 - - ! loop for each urban patch to get the LUCY id of all fine grid - ! of iurban patch, then assign the most frequency id to this urban patch - DO iurban = 1, numurban - - CALL aggregation_request_data (landurban, iurban, grid_urban_5km, & - zip = USE_zip_for_aggregation, & - data_i4_2d_in1 = LUCY_reg, data_i4_2d_out1 = LUCY_reg_one) - ! the most frequency id to this urban patch - LUCY_rid(iurban) = num_max_frequency (LUCY_reg_one) - ENDDO -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/LUCY_region_id.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'LUCY_id', 'urban', landurban, LUCY_rid, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/LUCY_region_id_'//trim(cyear)//'.nc' - - IF (allocated(LUCY_rid)) THEN - allocate (LUCY_rid_r8 (size(LUCY_rid))) - LUCY_rid_r8 = real(LUCY_rid, r8) - ENDIF - - CALL srfdata_map_and_write (LUCY_rid_r8, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'LUCY_id', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('LUCY_ID ', LUCY_rid) -#endif - - - ! ******* POP_DEN ******* - ! allocate and read the grided population raw data(500m) - ! NOTE, the population is year-by-year - IF (p_is_io) THEN - - CALL allocate_block_data (grid_urban_500m, pop) - - landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URBSRF'//trim(c5year) - - ! population data is year by year, - ! so pop_i is calculated to determine the dimension of POP data reads - IF (mod(lc_year,5) == 0) THEN - pop_i = 1 - ELSE - pop_i = 5 - (ceiling(lc_year*1./5.)*5 - lc_year) + 1 - ENDIF - - ! read the population data of total 5x5 region - CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "POP_DEN", pop_i, pop) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_urban_500m, data_r8_2d_in1 = pop) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (pop_den (numurban)) - - pop_den (:) = 0. - - ! loop for urban patch to aggregate population data with area-weighted average - DO iurban = 1, numurban - ! request all fine grid data and area of the iurban urban patch - ! a one dimension vector will be returned - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, & - area = area_one, data_r8_2d_in1 = pop, data_r8_2d_out1 = pop_one) - - WHERE (pop_one < 0) - area_one = 0 - END WHERE - ! area-weighted average - IF (sum(area_one) > 0._r8) THEN - pop_den(iurban) = sum(pop_one * area_one) / sum(area_one) - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/POP.nc' - CALL ncio_create_file_vector (landname, landurban) - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_write_vector (landname, 'POP_DEN', 'urban', landurban, pop_den, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/population_urban_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (pop_den, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'POP_DEN', compress = 0, write_mode = 'one', defval = 0._r8, create_mode = .true.) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('POP_DEN ', pop_den) -#endif - - -IF (DEF_URBAN_type_scheme == 1) THEN - ! look up table of NCAR urban properties (using look-up tables) - landname = TRIM(dir_rawdata)//'urban/NCAR_urban_properties.nc' - - CALL ncio_read_bcast_serial (landname, "WTROAD_PERV" , fgper_ncar ) - CALL ncio_read_bcast_serial (landname, "EM_ROOF" , emroof_ncar ) - CALL ncio_read_bcast_serial (landname, "EM_WALL" , emwall_ncar ) - CALL ncio_read_bcast_serial (landname, "EM_IMPROAD" , emgimp_ncar ) - CALL ncio_read_bcast_serial (landname, "EM_PERROAD" , emgper_ncar ) - CALL ncio_read_bcast_serial (landname, "ALB_ROOF" , albroof_ncar) - CALL ncio_read_bcast_serial (landname, "ALB_WALL" , albwall_ncar) - CALL ncio_read_bcast_serial (landname, "ALB_IMPROAD" , albgimp_ncar) - CALL ncio_read_bcast_serial (landname, "ALB_PERROAD" , albgper_ncar) - CALL ncio_read_bcast_serial (landname, "TK_ROOF" , tkroof_ncar ) - CALL ncio_read_bcast_serial (landname, "TK_WALL" , tkwall_ncar ) - CALL ncio_read_bcast_serial (landname, "TK_IMPROAD" , tkgimp_ncar ) - CALL ncio_read_bcast_serial (landname, "CV_ROOF" , cvroof_ncar ) - CALL ncio_read_bcast_serial (landname, "CV_WALL" , cvwall_ncar ) - CALL ncio_read_bcast_serial (landname, "CV_IMPROAD" , cvgimp_ncar ) - CALL ncio_read_bcast_serial (landname, "THICK_ROOF" , thkroof_ncar) - CALL ncio_read_bcast_serial (landname, "THICK_WALL" , thkwall_ncar) - CALL ncio_read_bcast_serial (landname, "T_BUILDING_MIN", tbldmin_ncar) - CALL ncio_read_bcast_serial (landname, "T_BUILDING_MAX", tbldmax_ncar) -ENDIF - - IF (p_is_io) THEN - -#ifdef USEMPI -IF (DEF_URBAN_type_scheme == 1) THEN - CALL aggregation_data_daemon (grid_urban_500m, data_i4_2d_in1 = reg_typid) -ENDIF -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (fgper (numurban)) - allocate (em_roof (numurban)) - allocate (em_wall (numurban)) - allocate (em_gimp (numurban)) - allocate (em_gper (numurban)) - allocate (thk_roof (numurban)) - allocate (thk_wall (numurban)) - allocate (tbld_min (numurban)) - allocate (tbld_max (numurban)) - allocate (tk_wgt (ulev, numurban)) - allocate (cv_wgt (ulev, numurban)) - allocate (cv_roof (ulev, numurban)) - allocate (cv_wall (ulev, numurban)) - allocate (cv_gimp (ulev, numurban)) - allocate (tk_roof (ulev, numurban)) - allocate (tk_wall (ulev, numurban)) - allocate (tk_gimp (ulev, numurban)) - allocate (alb_roof (nr, ns, numurban)) - allocate (alb_wall (nr, ns, numurban)) - allocate (alb_gimp (nr, ns, numurban)) - allocate (alb_gper (nr, ns, numurban)) - - allocate (urb_pct (numurban)) - allocate (sarea_urb (numurban)) - allocate (area_urb (numurban)) - - ! initialization - urb_pct (:) = 0. - sarea_urb(:) = 0. - area_urb (:) = 0. - - fgper (:) = 0. - em_roof (:) = 0. - em_wall (:) = 0. - em_gimp (:) = 0. - em_gper (:) = 0. - thk_roof (:) = 0. - thk_wall (:) = 0. - tbld_min (:) = 0. - tbld_max (:) = 0. - tk_wgt (:,:) = 0. - cv_wgt (:,:) = 0. - cv_roof (:,:) = 0. - cv_wall (:,:) = 0. - cv_gimp (:,:) = 0. - tk_roof (:,:) = 0. - tk_wall (:,:) = 0. - tk_gimp (:,:) = 0. - alb_roof (:,:,:) = 0. - alb_wall (:,:,:) = 0. - alb_gimp (:,:,:) = 0. - alb_gper (:,:,:) = 0. - - ! loop for each urban patch to aggregate urban morphological and thermal paras with area-weighted average - DO iurban = 1, numurban - ! urban region and type id for look-up-table - urb_typidx = landurban%settyp(iurban) - -IF (DEF_URBAN_type_scheme == 1) THEN - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, & - area = area_one, data_i4_2d_in2 = reg_typid, data_i4_2d_out2 = reg_typid_one) -ENDIF - - sumarea = sum(area_one) - area_urb(iurban) = sumarea - - ! loop for each finer grid to aggregate data - DO ipxl = 1, size(area_one) - -IF (DEF_URBAN_type_scheme == 1) THEN - ! same for above, assign reg id for RG_-45_65_-50_70 - IF (all(reg_typid_one==0)) THEN - reg_typid_one(:) = 30 - ENDIF - - IF (any(reg_typid_one==0)) THEN - WHERE(reg_typid_one==0) reg_typid_one = num_max_frequency(reg_typid_one) - ENDIF - - urb_regidx = reg_typid_one(ipxl) - - fgper_ = fgper_ncar (urb_typidx,urb_regidx) - - emroof = emroof_ncar (urb_typidx,urb_regidx) - emwall = emwall_ncar (urb_typidx,urb_regidx) - emgper = emgper_ncar (urb_typidx,urb_regidx) - emgimp = emgimp_ncar (urb_typidx,urb_regidx) - - thkroof = thkroof_ncar(urb_typidx,urb_regidx) - thkwall = thkwall_ncar(urb_typidx,urb_regidx) - tbldmax = tbldmax_ncar(urb_typidx,urb_regidx) - tbldmin = tbldmin_ncar(urb_typidx,urb_regidx) - - cvroof (:) = cvroof_ncar (urb_typidx,urb_regidx,:) - cvwall (:) = cvwall_ncar (urb_typidx,urb_regidx,:) - cvgimp (:) = cvgimp_ncar (urb_typidx,urb_regidx,:) - - tkroof (:) = tkroof_ncar (urb_typidx,urb_regidx,:) - tkwall (:) = tkwall_ncar (urb_typidx,urb_regidx,:) - tkgimp (:) = tkgimp_ncar (urb_typidx,urb_regidx,:) - - albroof(:,:) = albroof_ncar(urb_typidx,urb_regidx,:,:) - albwall(:,:) = albwall_ncar(urb_typidx,urb_regidx,:,:) - albgper(:,:) = albgper_ncar(urb_typidx,urb_regidx,:,:) - albgimp(:,:) = albgimp_ncar(urb_typidx,urb_regidx,:,:) - -ELSE IF (DEF_URBAN_type_scheme == 2) THEN - - fgper_ = fgper_lcz (urb_typidx) / (1-wtroof_lcz(urb_typidx)) - - emroof = emroof_lcz (urb_typidx) - emwall = emwall_lcz (urb_typidx) - emgper = emgper_lcz (urb_typidx) - emgimp = emgimp_lcz (urb_typidx) - - thkroof = thkroof_lcz(urb_typidx) - thkwall = thkwall_lcz(urb_typidx) - tbldmax = tbldmax_lcz(urb_typidx) - tbldmin = tbldmin_lcz(urb_typidx) - - cvroof (:) = cvroof_lcz (urb_typidx) - cvwall (:) = cvwall_lcz (urb_typidx) - cvgimp (:) = cvgimp_lcz (urb_typidx) - - tkroof (:) = tkroof_lcz (urb_typidx) - tkwall (:) = tkwall_lcz (urb_typidx) - tkgimp (:) = tkgimp_lcz (urb_typidx) - - albroof(:,:) = albroof_lcz(urb_typidx) - albwall(:,:) = albwall_lcz(urb_typidx) - albgper(:,:) = albgper_lcz(urb_typidx) - albgimp(:,:) = albgimp_lcz(urb_typidx) -ENDIF - - fgper (iurban) = fgper (iurban) + fgper_ * area_one(ipxl) - - em_roof (iurban) = em_roof (iurban) + emroof * area_one(ipxl) - em_wall (iurban) = em_wall (iurban) + emwall * area_one(ipxl) - em_gimp (iurban) = em_gimp (iurban) + emgimp * area_one(ipxl) - em_gper (iurban) = em_gper (iurban) + emgper * area_one(ipxl) - - thk_roof(iurban) = thk_roof (iurban) + thkroof * area_one(ipxl) - thk_wall(iurban) = thk_wall (iurban) + thkwall * area_one(ipxl) - tbld_min(iurban) = tbld_min (iurban) + tbldmin * area_one(ipxl) - tbld_max(iurban) = tbld_max (iurban) + tbldmax * area_one(ipxl) - - ! tkgimp and cvgimp may have nan-values, and need to be calculated separately - DO il = 1, 10 - IF (tkgimp(il) .ne. -999.) THEN - tk_gimp(il,iurban) = tk_gimp(il,iurban) + tkgimp(il) * area_one(ipxl) - tk_wgt (il,iurban) = tk_wgt (il,iurban) + area_one(ipxl) - ENDIF - - IF (cvgimp(il) .ne. -999.) THEN - cv_gimp(il,iurban) = cv_gimp(il,iurban) + cvgimp(il) * area_one(ipxl) - cv_wgt (il,iurban) = cv_wgt (il,iurban) + area_one(ipxl) - ENDIF - ENDDO - - cv_roof (:,iurban) = cv_roof (:,iurban) + cvroof(:) * area_one(ipxl) - cv_wall (:,iurban) = cv_wall (:,iurban) + cvwall(:) * area_one(ipxl) - tk_roof (:,iurban) = tk_roof (:,iurban) + tkroof(:) * area_one(ipxl) - tk_wall (:,iurban) = tk_wall (:,iurban) + tkwall(:) * area_one(ipxl) - - alb_roof(:,:,iurban) = alb_roof(:,:,iurban) + albroof(:,:) * area_one(ipxl) - alb_wall(:,:,iurban) = alb_wall(:,:,iurban) + albwall(:,:) * area_one(ipxl) - alb_gimp(:,:,iurban) = alb_gimp(:,:,iurban) + albgimp(:,:) * area_one(ipxl) - alb_gper(:,:,iurban) = alb_gper(:,:,iurban) + albgper(:,:) * area_one(ipxl) - - ENDDO - - fgper (iurban) = fgper (iurban) / sumarea - em_roof (iurban) = em_roof (iurban) / sumarea - em_wall (iurban) = em_wall (iurban) / sumarea - em_gimp (iurban) = em_gimp (iurban) / sumarea - em_gper (iurban) = em_gper (iurban) / sumarea - thk_roof (iurban) = thk_roof (iurban) / sumarea - thk_wall (iurban) = thk_wall (iurban) / sumarea - tbld_min (iurban) = tbld_min (iurban) / sumarea - tbld_max (iurban) = tbld_max (iurban) / sumarea - - cv_roof(:,iurban) = cv_roof (:,iurban) / sumarea - cv_wall(:,iurban) = cv_wall (:,iurban) / sumarea - tk_roof(:,iurban) = tk_roof (:,iurban) / sumarea - tk_wall(:,iurban) = tk_wall (:,iurban) / sumarea - - DO il = 1, 10 - IF (tk_wgt(il,iurban) > 0.) THEN - tk_gimp(il,iurban) = tk_gimp(il,iurban) / tk_wgt(il,iurban) - ENDIF - - IF (cv_wgt(il,iurban) > 0.) THEN - cv_gimp(il,iurban) = cv_gimp(il,iurban) / cv_wgt(il,iurban) - ENDIF - ENDDO - - alb_roof(:,:,iurban) = alb_roof(:,:,iurban) / sumarea - alb_wall(:,:,iurban) = alb_wall(:,:,iurban) / sumarea - alb_gimp(:,:,iurban) = alb_gimp(:,:,iurban) / sumarea - alb_gper(:,:,iurban) = alb_gper(:,:,iurban) / sumarea - - ENDDO - - DO ielm = 1, numelm - numpth = count(landurban%eindex==landelm%eindex(ielm)) - - IF (allocated(locpth)) deallocate(locpth) - allocate(locpth(numpth)) - - locpth = pack([(ipth, ipth=1, numurban)], & - landurban%eindex==landelm%eindex(ielm)) - - urb_s = minval(locpth) - urb_e = maxval(locpth) - - DO iurban = urb_s, urb_e - sarea_urb(urb_s:urb_e) = sarea_urb(urb_s:urb_e) + area_urb(iurban) - ENDDO - ENDDO - - urb_pct(:) = area_urb(:)/sarea_urb(:) - -#ifdef USEMPI -IF (DEF_URBAN_type_scheme == 1) THEN - CALL aggregation_worker_done () -ENDIF -#endif - ENDIF - - !output - write(cyear,'(i4.4)') lc_year - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/urban.nc' - CALL ncio_create_file_vector (landname, landurban) - - CALL ncio_define_dimension_vector (landname, landurban, 'urban') - CALL ncio_define_dimension_vector (landname, landurban, 'numsolar', ns) - CALL ncio_define_dimension_vector (landname, landurban, 'numrad' , nr) - CALL ncio_define_dimension_vector (landname, landurban, 'ulev' , ulev) - - CALL ncio_write_vector (landname, 'WTROAD_PERV' , 'urban', landurban, fgper , DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'EM_ROOF' , 'urban', landurban, em_roof , DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'EM_WALL' , 'urban', landurban, em_wall , DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'EM_IMPROAD' , 'urban', landurban, em_gimp , DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'EM_PERROAD' , 'urban', landurban, em_gper , DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'THICK_ROOF' , 'urban', landurban, thk_roof, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'THICK_WALL' , 'urban', landurban, thk_wall, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'T_BUILDING_MIN', 'urban', landurban, tbld_min, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'T_BUILDING_MAX', 'urban', landurban, tbld_max, DEF_Srfdata_CompressLevel) - - CALL ncio_write_vector (landname, 'CV_ROOF' , 'ulev', ulev, 'urban', landurban, cv_roof, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'CV_WALL' , 'ulev', ulev, 'urban', landurban, cv_wall, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'TK_ROOF' , 'ulev', ulev, 'urban', landurban, tk_roof, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'TK_WALL' , 'ulev', ulev, 'urban', landurban, tk_wall, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'TK_IMPROAD', 'ulev', ulev, 'urban', landurban, tk_gimp, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'CV_IMPROAD', 'ulev', ulev, 'urban', landurban, cv_gimp, DEF_Srfdata_CompressLevel) - - CALL ncio_write_vector (landname, 'ALB_ROOF' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_roof, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'ALB_WALL' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_wall, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'ALB_IMPROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gimp, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (landname, 'ALB_PERROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gper, DEF_Srfdata_CompressLevel) - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/pct_urban_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (urb_pct, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'URBAN_PCT', compress = 0, write_mode = 'one', & - stat_mode = 'fraction', defval = 0._r8, pctshared = urb_pct, create_mode = .true.) - - typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/urban_phyical_paras_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (fgper, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'WTROAD_PERV', compress = 0, write_mode = 'one', & - stat_mode = 'fraction', defval = 0._r8, create_mode = .true.) - - CALL srfdata_map_and_write (em_roof, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'EM_ROOF', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (em_wall, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'EM_WALL', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (em_gper, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'EM_PERROAD', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (em_gimp, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'EM_IMPROAD', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (thk_roof, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'THICK_ROOF', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (thk_wall, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'THICK_WALL', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (tbld_min, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'T_BUILDING_MIN', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (tbld_max, landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'T_BUILDING_MAX', compress = 0, write_mode = 'one', defval = 0._r8) - - DO il = 1, nl_roof - CALL srfdata_map_and_write (cv_roof(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'CV_ROOF', compress = 0, write_mode = 'one', & - lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) - - CALL srfdata_map_and_write (tk_roof(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'TK_ROOF', compress = 0, write_mode = 'one', & - lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) - ENDDO - - DO il = 1, nl_wall - CALL srfdata_map_and_write (cv_wall(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'CV_WALL', compress = 0, write_mode = 'one', & - lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) - - CALL srfdata_map_and_write (tk_wall(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'TK_WALL', compress = 0, write_mode = 'one', & - lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) - ENDDO - - DO il = 1, nl_soil - CALL srfdata_map_and_write (cv_gimp(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'CV_IMPROAD', compress = 0, write_mode = 'one', & - lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) - - CALL srfdata_map_and_write (tk_gimp(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'TK_IMPROAD', compress = 0, write_mode = 'one', & - lastdimname = 'ulev', lastdimvalue = il, defval = 0._r8) - ENDDO - - CALL srfdata_map_and_write (alb_roof(1,1,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'ALB_ROOF', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (alb_wall(1,1,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'ALB_WALL', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (alb_gper(1,1,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'ALB_PERROAD', compress = 0, write_mode = 'one', defval = 0._r8) - - CALL srfdata_map_and_write (alb_gimp(1,1,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'ALB_IMPROAD', compress = 0, write_mode = 'one', defval = 0._r8) - - deallocate (typindex) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('WTROAD_PERV ' , fgper ) - CALL check_vector_data ('EM_ROOF ' , em_roof ) - CALL check_vector_data ('EM_WALL ' , em_wall ) - CALL check_vector_data ('EM_IMPROAD ' , em_gimp ) - CALL check_vector_data ('EM_PERROAD ' , em_gper ) - CALL check_vector_data ('ALB_ROOF ' , alb_roof) - CALL check_vector_data ('ALB_WALL ' , alb_wall) - CALL check_vector_data ('ALB_IMPROAD ' , alb_gimp) - CALL check_vector_data ('ALB_PERROAD ' , alb_gper) - CALL check_vector_data ('TK_ROOF ' , tk_roof ) - CALL check_vector_data ('TK_WALL ' , tk_wall ) - CALL check_vector_data ('TK_IMPROAD ' , tk_gimp ) - CALL check_vector_data ('CV_ROOF ' , cv_roof ) - CALL check_vector_data ('CV_WALL ' , cv_wall ) - CALL check_vector_data ('CV_IMPROAD ' , cv_gimp ) - CALL check_vector_data ('THICK_ROOF ' , thk_roof) - CALL check_vector_data ('THICK_WALL ' , thk_wall) - CALL check_vector_data ('T_BUILDING_MIN ', tbld_min) - CALL check_vector_data ('T_BUILDING_MAX ', tbld_max) -#endif - - IF (p_is_worker) THEN - - IF ( allocated (LUCY_rid ) ) deallocate (LUCY_rid ) - IF ( allocated (pop_den ) ) deallocate (pop_den ) - IF ( allocated (pct_tree ) ) deallocate (pct_tree ) - IF ( allocated (htop_urb ) ) deallocate (htop_urb ) - IF ( allocated (pct_water) ) deallocate (pct_water ) - IF ( allocated (wt_roof ) ) deallocate (wt_roof ) - IF ( allocated (ht_roof ) ) deallocate (ht_roof ) - IF ( allocated (lai_urb ) ) deallocate (lai_urb ) - IF ( allocated (sai_urb ) ) deallocate (sai_urb ) - IF ( allocated (area_urb ) ) deallocate (area_urb ) - IF ( allocated (sarea_urb) ) deallocate (sarea_urb ) - IF ( allocated (urb_pct ) ) deallocate (urb_pct ) - -IF (DEF_URBAN_type_scheme == 1) THEN - IF ( allocated (htroof_ncar ) ) deallocate (htroof_ncar ) - IF ( allocated (wtroof_ncar ) ) deallocate (wtroof_ncar ) - IF ( allocated (hwrbld_ncar ) ) deallocate (hwrbld_ncar ) - IF ( allocated (fgper_ncar ) ) deallocate (fgper_ncar ) - IF ( allocated (emroof_ncar ) ) deallocate (emroof_ncar ) - IF ( allocated (emwall_ncar ) ) deallocate (emwall_ncar ) - IF ( allocated (emgper_ncar ) ) deallocate (emgper_ncar ) - IF ( allocated (emgimp_ncar ) ) deallocate (emgimp_ncar ) - IF ( allocated (albroof_ncar) ) deallocate (albroof_ncar) - IF ( allocated (albwall_ncar) ) deallocate (albwall_ncar) - IF ( allocated (albgper_ncar) ) deallocate (albgper_ncar) - IF ( allocated (albgimp_ncar) ) deallocate (albgimp_ncar) - IF ( allocated (thkroof_ncar) ) deallocate (thkroof_ncar) - IF ( allocated (thkwall_ncar) ) deallocate (thkwall_ncar) - IF ( allocated (tbldmin_ncar) ) deallocate (tbldmin_ncar) - IF ( allocated (tbldmax_ncar) ) deallocate (tbldmax_ncar) - IF ( allocated (cvroof_ncar ) ) deallocate (cvroof_ncar ) - IF ( allocated (cvwall_ncar ) ) deallocate (cvwall_ncar ) - IF ( allocated (cvgimp_ncar ) ) deallocate (cvgimp_ncar ) - IF ( allocated (tkroof_ncar ) ) deallocate (tkroof_ncar ) - IF ( allocated (tkwall_ncar ) ) deallocate (tkwall_ncar ) - IF ( allocated (tkgimp_ncar ) ) deallocate (tkgimp_ncar ) -ENDIF - - IF ( allocated (hlr_bld ) ) deallocate (hlr_bld ) - IF ( allocated (fgper ) ) deallocate (fgper ) - IF ( allocated (em_roof ) ) deallocate (em_roof ) - IF ( allocated (em_wall ) ) deallocate (em_wall ) - IF ( allocated (em_gimp ) ) deallocate (em_gimp ) - IF ( allocated (em_gper ) ) deallocate (em_gper ) - IF ( allocated (thk_roof) ) deallocate (thk_roof) - IF ( allocated (thk_wall) ) deallocate (thk_wall) - IF ( allocated (tbld_min) ) deallocate (tbld_min) - IF ( allocated (tbld_max) ) deallocate (tbld_max) - IF ( allocated (tk_wgt ) ) deallocate (tk_wgt ) - IF ( allocated (cv_wgt ) ) deallocate (cv_wgt ) - IF ( allocated (cv_roof ) ) deallocate (cv_roof ) - IF ( allocated (cv_wall ) ) deallocate (cv_wall ) - IF ( allocated (cv_gimp ) ) deallocate (cv_gimp ) - IF ( allocated (cv_wgt ) ) deallocate (cv_wgt ) - IF ( allocated (tk_roof ) ) deallocate (tk_roof ) - IF ( allocated (tk_wall ) ) deallocate (tk_wall ) - IF ( allocated (tk_gimp ) ) deallocate (tk_gimp ) - IF ( allocated (tk_wgt ) ) deallocate (tk_wgt ) - IF ( allocated (alb_roof) ) deallocate (alb_roof) - IF ( allocated (alb_wall) ) deallocate (alb_wall) - IF ( allocated (alb_gimp) ) deallocate (alb_gimp) - IF ( allocated (alb_gper) ) deallocate (alb_gper) - - IF ( allocated (area_one ) ) deallocate (area_one ) - IF ( allocated (LUCY_reg_one ) ) deallocate (LUCY_reg_one ) - IF ( allocated (pop_one ) ) deallocate (pop_one ) - IF ( allocated (fvegu_one ) ) deallocate (fvegu_one ) - IF ( allocated (htopu_one ) ) deallocate (htopu_one ) - IF ( allocated (flakeu_one ) ) deallocate (flakeu_one ) - IF ( allocated (wt_roof_one ) ) deallocate (wt_roof_one ) - IF ( allocated (ht_roof_one ) ) deallocate (ht_roof_one ) - IF ( allocated (ulai_one ) ) deallocate (ulai_one ) - IF ( allocated (slai_one ) ) deallocate (slai_one ) - - ENDIF - -END SUBROUTINE Aggregation_Urban -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 index e7be9e00df..cfebf1dc34 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 @@ -136,8 +136,7 @@ SUBROUTINE landpft_build (lc_year) sumarea = sum(area_one * sum(pctpft_one(0:N_PFT-1,:),dim=1)) - ! in case of no PFT data, set to 100% bare when patchtype=0, - ! be consistent with Aggregation_PercentagesPFT.F90. + ! In case of no PFT data, set patchtype=0 to 100% bare. IF (sumarea <= 0.0) THEN pctpft_patch(0,ipatch) = 1. ELSE diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 deleted file mode 100644 index 70cba64e16..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Lulcc_TransferTrace.F90 +++ /dev/null @@ -1,293 +0,0 @@ -#include - -MODULE MOD_Lulcc_TransferTrace - -!------------------------------------------------------------------------ -! -! !DESCRIPTION: -! The transfer matrix and patch tracing vector were created using the -! land cover type data of the adjacent two years. Based on next year's -! patch, the pixels within the patch and last years' land cover type of -! these pixels were obtained. Then the percent of source land cover -! type of each patch was derived. -! -! Created by Wanyi Lin, Shupeng Zhang and Hua Yuan, 07/2023 -! -! !HISTORY: -! 05/2025, Wanyi Lin and Hua Yuan: code moved from main/LULCC/, now generate -! the transfer matrix and patch tracing vector when making surface -! data and SAVE it to a type (lulcc) of surface data. -!------------------------------------------------------------------------ - - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE - - real(r8), allocatable, dimension(:,:) :: lccpct_patches(:,:) !frac of source patches in a patch - real(r8), allocatable, dimension(:,:) :: lccpct_matrix (:,:) !frac of source patches in a grid - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTransferTrace - PUBLIC :: deallocate_LulccTransferTrace - PUBLIC :: MAKE_LulccTransferTrace - - ! PRIVATE MEMBER FUNCTIONS: - - -CONTAINS - - - SUBROUTINE allocate_LulccTransferTrace - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time invariant variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_SPMD_Task - - IMPLICIT NONE - - integer :: nlc = N_land_classification - - IF (p_is_worker) THEN - allocate (lccpct_patches (numpatch, 0:nlc)) - lccpct_patches (:,:) = 0 - allocate (lccpct_matrix (numpatch, 0:nlc)) - lccpct_matrix (:,:) = 0 - ENDIF - - END SUBROUTINE allocate_LulccTransferTrace - - - SUBROUTINE MAKE_LulccTransferTrace (lc_year) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_AggregationRequestData - USE MOD_Mesh - USE MOD_MeshFilter - USE MOD_LandElm - USE MOD_DataType - USE MOD_Block - USE MOD_Pixel - USE MOD_5x5DataReadin - USE MOD_RegionClip - USE MOD_Utils -#ifdef SrfdataDiag - USE MOD_SrfdataDiag -#endif -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - - IMPLICIT NONE - - integer, intent(in) :: lc_year - -!-------------------------- Local Variables ---------------------------- - character(len=256) :: dir_5x5, suffix, lastyr, thisyr, dir_landdata, lndname - character(len=4) :: c2 - integer :: i,ipatch,ipxl,ipxstt,ipxend,numpxl,ilc - integer, allocatable, dimension(:) :: locpxl - type (block_data_int32_2d) :: lcdatafr !land cover data of last year - integer, allocatable, dimension(:) :: lcdatafr_one(:), lcfrbuff(:) - real(r8),allocatable, dimension(:) :: area_one(:) , areabuff(:) - real(r8) :: sum_areabuff, gridarea - integer, allocatable, dimension(:) :: grid_patch_s, grid_patch_e - logical :: first_call -! for surface data diag -#ifdef SrfdataDiag - integer :: ityp - integer, allocatable, dimension(:) :: typindex -#endif -!----------------------------------------------------------------------- - - IF ( (lc_year < 1990) .or. (lc_year < 2000 .and. MOD(lc_year, 5) /= 0) ) RETURN - - write(thisyr,'(i4.4)') lc_year - IF (lc_year <= 2000 .and. MOD(lc_year, 5) == 0) THEN - write(lastyr,'(i4.4)') MAX(1985, lc_year-5) - ELSE - write(lastyr,'(i4.4)') MAX(1985, lc_year-1) - ENDIF - - first_call = .true. - -#ifdef SrfdataDiag - allocate( typindex(N_land_classification+1) ) -#endif - - CALL allocate_LulccTransferTrace - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - CALL grid_patch%define_by_name ('colm_500m') - CALL pixel%assimilate_grid (grid_patch) - CALL pixel%map_to_grid (grid_patch) - - IF (p_is_io) THEN - CALL allocate_block_data (grid_patch, lcdatafr) - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(lastyr) - ! read the previous year land cover data - ! TODO: Add IF statement for using different LC products - ! IF use MODIS data THEN - CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'LC', lcdatafr) - ! ELSE - ! 'LC_GLC' is not recomended for IGBP - !CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'LC_GLC', lcdatafr) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_patch, data_i4_2d_in1 = lcdatafr) -#endif - ENDIF - - ! ----------------------------------------------------------------- - ! extract the land cover type of pixels of last year for each patch - ! ----------------------------------------------------------------- - IF (p_is_worker) THEN - - ! allocate with numelm - allocate(grid_patch_s (numelm )) - allocate(grid_patch_e (numelm )) - - grid_patch_e (:) = -1 - grid_patch_s (:) = -1 - - DO i=1, numelm - ! how many patches in ith element in this worker - numpxl = count(landpatch%eindex==landelm%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - ! get all patches' index that eindex is equal the i element - locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) - ! the min index is the start of patch's index - grid_patch_s(i) = minval(locpxl) - ! the max index is the end of patch's index - grid_patch_e(i) = maxval(locpxl) - ENDDO - - DO i=1, numelm - ipatch = grid_patch_s (i) - - IF (ipatch.le.0) CYCLE - gridarea = 0 - - DO WHILE (ipatch.le.grid_patch_e(i)) - - !TODO-done: need to skip the 2m WMO patches - IF (ipatch == wmo_patch(landpatch%ielm(ipatch)) ) THEN - ipatch = ipatch + 1 - CYCLE - ENDIF - - ! using this year patch mapping to aggregate the previous year land cover data - CALL aggregation_request_data (landpatch, ipatch, grid_patch, zip = .true., & - area = area_one, data_i4_2d_in1 = lcdatafr, data_i4_2d_out1 = lcdatafr_one) - - ipxstt = landpatch%ipxstt(ipatch) - ipxend = landpatch%ipxend(ipatch) - - IF (allocated(lcfrbuff)) deallocate(lcfrbuff) - allocate(lcfrbuff(ipxstt:ipxend)) - lcfrbuff(:) = lcdatafr_one(:) - - IF (allocated(areabuff)) deallocate(areabuff) - allocate(areabuff(ipxstt:ipxend)) - areabuff(:) = area_one(:) - - sum_areabuff = sum(areabuff) - DO ipxl = ipxstt, ipxend - ! Transfer trace - the key codes to count for the source land cover types of LULCC - lccpct_patches(ipatch, lcfrbuff(ipxl)) = lccpct_patches(ipatch, lcfrbuff(ipxl)) & - + areabuff(ipxl) / sum_areabuff - lccpct_matrix (ipatch, lcfrbuff(ipxl)) = lccpct_matrix (ipatch, lcfrbuff(ipxl)) & - + areabuff(ipxl) - ENDDO - gridarea = gridarea + sum_areabuff - ipatch = ipatch + 1 - ENDDO - - lccpct_matrix(grid_patch_s(i):grid_patch_e(i), :) = & - lccpct_matrix (grid_patch_s(i):grid_patch_e(i), :) / gridarea - - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - dir_landdata = DEF_dir_landdata - CALL system('mkdir -p ' // trim(dir_landdata) // '/lulcc/' // trim(thisyr)) - DO ilc = 0, N_land_classification - write(c2, '(i2.2)') ilc - lndname = trim(dir_landdata)//'/lulcc/'//trim(thisyr)//& - '/lccpct_patches_lc'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'lccpct_patches', 'patch', & - landpatch, lccpct_patches(:,ilc), DEF_Srfdata_CompressLevel) - ENDDO - -#ifdef SrfdataDiag - typindex = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_landdata) // & - '/diag/lccpct_matrix_' // trim(thisyr) // '.nc' - DO ilc = 0, N_land_classification - CALL srfdata_map_and_write (lccpct_matrix(:,ilc), landpatch%settyp, typindex, & - m_patch2diag, -1.0e36_r8, lndname, 'lccpct_matrix', compress = 0, & - write_mode = 'one', defval=0._r8, lastdimname = 'source_patch', lastdimvalue = ilc, & - create_mode=first_call) - IF ( first_call ) first_call = .false. - ENDDO - deallocate(typindex) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('lccpct_patches', lccpct_patches) - CALL check_vector_data ('lccpct_matrix' , lccpct_matrix ) -#endif - - IF (p_is_worker) THEN - IF (allocated(area_one)) deallocate (area_one) - ENDIF - - CALL deallocate_LulccTransferTrace - - END SUBROUTINE MAKE_LulccTransferTrace - - - - SUBROUTINE deallocate_LulccTransferTrace - ! -------------------------------------------------- - ! Deallocates memory for Lulcc time invariant variables - ! -------------------------------------------------- - USE MOD_SPMD_Task - - IF (p_is_worker) THEN - IF (allocated(lccpct_patches)) deallocate (lccpct_patches) - IF (allocated(lccpct_matrix )) deallocate (lccpct_matrix ) - ENDIF - - END SUBROUTINE deallocate_LulccTransferTrace - -END MODULE MOD_Lulcc_TransferTrace -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 deleted file mode 100644 index de6d9bb6c5..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_RegionClip.F90 +++ /dev/null @@ -1,809 +0,0 @@ -#include - -MODULE MOD_RegionClip -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! This module includes subroutines to clip surface data from an existing -! data in a larger region. -! -! Please use namelist variable "USE_srfdata_from_larger_region" to call -! these subroutines. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - -CONTAINS - - ! ----- region clip ----- - SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Utils - USE MOD_Pixel - USE MOD_Block - USE MOD_NetCDFSerial - - IMPLICIT NONE - - character(len=*), intent(in) :: dir_landdata_in, dir_landdata_out - - ! Local Variables - real(r8) :: edges, edgen, edgew, edgee - character(len=256) :: file_in, file_out, fileblock - integer :: iproc, iblk, jblk, ie, ipxl, ilon, ilat, i1 - integer :: nelm_in, nelm_out - integer, allocatable :: nelm_blk(:,:), IOproc(:,:) - integer*8, allocatable :: elmindex(:) - integer, allocatable :: elmnpxl(:), elmpixels(:,:,:) - - logical, allocatable :: elmmask (:) - logical, allocatable :: patchmask(:) -#ifdef CATCHMENT - logical, allocatable :: hrumask (:) -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - logical, allocatable :: pftmask (:) -#endif - - integer :: month, YY, itime, Julian_day, nsl - integer :: start_year, end_year - character(len=1) :: c1 - character(len=2) :: c2, cx - character(len=3) :: c3 - character(len=4) :: cyear - - - IF (p_is_master) THEN - IF (trim(adjustl(dir_landdata_in)) == trim(adjustl(dir_landdata_out))) THEN - write(*,*) 'Warning : Surface Data from ', trim(adjustl(dir_landdata_in)), & - ' to ', trim(adjustl(dir_landdata_out)) - write(*,*) 'Data will be overwritten, please CHANGE directory.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, 1, p_err) -#else - CALL EXIT(1) -#endif - ELSE - CALL system('mkdir -p ' // trim(dir_landdata_out)) - ENDIF - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - edges = DEF_domain%edges - edgen = DEF_domain%edgen - edgew = DEF_domain%edgew - edgee = DEF_domain%edgee - - CALL normalize_longitude (edgew) - CALL normalize_longitude (edgee) - - CALL pixel%load_from_file (dir_landdata_in) - - file_in = trim(dir_landdata_in) // '/block.nc' - CALL ncio_read_bcast_serial (file_in, 'lat_s', gblock%lat_s) - CALL ncio_read_bcast_serial (file_in, 'lat_n', gblock%lat_n) - CALL ncio_read_bcast_serial (file_in, 'lon_w', gblock%lon_w) - CALL ncio_read_bcast_serial (file_in, 'lon_e', gblock%lon_e) - - gblock%nyblk = size(gblock%lat_s) - gblock%nxblk = size(gblock%lon_w) - - IF (p_is_master) THEN - - file_in = trim(dir_landdata_in ) // '/mesh/mesh.nc' - file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' - CALL system('cp ' // trim(file_in) // ' ' // trim(file_out)) - - file_in = trim(dir_landdata_in ) // '/pixel.nc' - file_out = trim(dir_landdata_out) // '/pixel.nc' - CALL system('cp ' // trim(file_in) // ' ' // trim(file_out)) - - file_in = trim(dir_landdata_in ) // '/block.nc' - file_out = trim(dir_landdata_out) // '/block.nc' - CALL system('cp ' // trim(file_in) // ' ' // trim(file_out)) - - ENDIF - - file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' - CALL ncio_read_bcast_serial (file_in, 'nelm_blk', nelm_blk) - - allocate (IOproc (gblock%nxblk, gblock%nyblk)) - IOproc (:,:) = -1 - - iproc = -1 - DO jblk = 1, gblock%nyblk - IF ((gblock%lat_s(jblk) >= edgen) .or. (gblock%lat_n(jblk) <= edges)) THEN - CYCLE - ENDIF - - DO iblk = 1, gblock%nxblk - IF ((gblock%lon_w(iblk) == gblock%lon_e(iblk)) .or. (edgew == edgee)) THEN - IF (nelm_blk(iblk,jblk) > 0) THEN - iproc = mod(iproc + 1, p_np_glb) - IOproc(iblk,jblk) = iproc - ENDIF - ELSE - IF ( lon_between_floor(gblock%lon_w(iblk), edgew, edgee) & - .or. lon_between_ceil (gblock%lon_e(iblk), edgew, edgee) & - .or. lon_between_floor(edgew, gblock%lon_w(iblk), gblock%lon_e(iblk)) & - .or. lon_between_ceil (edgee, gblock%lon_w(iblk), gblock%lon_e(iblk))) THEN - IF (nelm_blk(iblk,jblk) > 0) THEN - iproc = mod(iproc + 1, p_np_glb) - IOproc(iblk,jblk) = iproc - ENDIF - ENDIF - ENDIF - ENDDO - ENDDO - - WHERE (IOproc /= p_iam_glb) - nelm_blk = 0 - END WHERE - - DO jblk = 1, gblock%nyblk - DO iblk = 1, gblock%nxblk - IF (IOproc(iblk,jblk) == p_iam_glb) THEN - - file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' - CALL get_filename_block (file_in, iblk, jblk, fileblock) - - CALL ncio_read_serial (fileblock, 'elmindex' , elmindex ) - CALL ncio_read_serial (fileblock, 'elmnpxl' , elmnpxl ) - CALL ncio_read_serial (fileblock, 'elmpixels', elmpixels) - - nelm_in = nelm_blk(iblk,jblk) - - allocate (elmmask (nelm_in)) - elmmask(:) = .false. - - DO ie = 1, nelm_in - DO ipxl = 1, elmnpxl(ie) - ilon = elmpixels(1,ipxl,ie) - ilat = elmpixels(2,ipxl,ie) - - IF (((pixel%lat_s(ilat) < edgen) .and. (pixel%lat_n(ilat) > edges)) & - .and. (lon_between_floor(pixel%lon_w(ilon), edgew, edgee) & - .or. lon_between_ceil(pixel%lon_e(ilon), edgew, edgee))) THEN - - elmmask(ie) = .true. - - EXIT - ELSE - CYCLE - ENDIF - ENDDO - ENDDO - - nelm_out = count(elmmask) - nelm_blk(iblk,jblk) = nelm_out - - IF (nelm_out > 0) THEN - - CALL clip_pixelset (dir_landdata_in, 'landpatch', iblk, jblk, elmmask, elmindex, patchmask) -#ifdef CATCHMENT - CALL clip_pixelset (dir_landdata_in, 'landhru' , iblk, jblk, elmmask, elmindex, hrumask ) -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL clip_pixelset (dir_landdata_in, 'landpft' , iblk, jblk, elmmask, elmindex, pftmask ) -#endif - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/mesh') - file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' - file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'elmindex' , elmmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'elmnpxl' , elmmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'elmpixels', elmmask) - - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landelm') - file_in = trim(dir_landdata_in) // '/landelm/landelm.nc' - file_out = trim(dir_landdata_out) // '/landelm/landelm.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', elmmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', elmmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', elmmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', elmmask) - - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landpatch') - file_in = trim(dir_landdata_in) // '/landpatch/landpatch.nc' - file_out = trim(dir_landdata_out) // '/landpatch/landpatch.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', patchmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', patchmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', patchmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', patchmask) - - file_in = trim(dir_landdata_in) // '/landpatch/patchfrac_elm.nc' - file_out = trim(dir_landdata_out) // '/landpatch/patchfrac_elm.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'patchfrac_elm', patchmask) - -#ifdef CATCHMENT - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landhru') - file_in = trim(dir_landdata_in) // '/landhru/landhru.nc' - file_out = trim(dir_landdata_out) // '/landhru/landhru.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', hrumask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', hrumask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', hrumask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', hrumask) - - file_in = trim(dir_landdata_in) // '/landpatch/patchfrac_hru.nc' - file_out = trim(dir_landdata_out) // '/landpatch/patchfrac_hru.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'patchfrac_hru', patchmask) -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landpft') - file_in = trim(dir_landdata_in) // '/landpft/landpft.nc' - file_out = trim(dir_landdata_out) // '/landpft/landpft.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', pftmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', pftmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', pftmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', pftmask) -#endif - ENDIF - - ! Leaf Area Index - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/LAI') - - IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = DEF_simulation_time%start_year - end_year = DEF_simulation_time%end_year - ELSE - start_year = DEF_LC_YEAR - end_year = DEF_LC_YEAR - ENDIF - - DO YY = start_year, end_year - - write(cyear,'(i4.4)') YY - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/LAI/' // trim(cyear)) - - IF (DEF_LAI_MONTHLY) THEN - DO month = 1, 12 - write(c2,'(i2.2)') month - - file_in = trim(dir_landdata_in) // '/LAI/' // trim(cyear) // '/LAI_patches' // trim(c2) // '.nc' - file_out = trim(dir_landdata_out) // '/LAI/' // trim(cyear) // '/LAI_patches' // trim(c2) // '.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_patches', patchmask) - - file_in = trim(dir_landdata_in) // '/LAI/' // trim(cyear) // '/SAI_patches' // trim(c2) // '.nc' - file_out = trim(dir_landdata_out) // '/LAI/' // trim(cyear) // '/SAI_patches' // trim(c2) // '.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'SAI_patches', patchmask) - ENDDO - ELSE - DO itime = 1, 46 - Julian_day = 1 + (itime-1)*8 - write(c3, '(i3.3)') Julian_day - file_in = trim(dir_landdata_in) //'/LAI/'//trim(cyear)//'/LAI_patches'//trim(c3)// '.nc' - file_out = trim(dir_landdata_out)//'/LAI/'//trim(cyear)//'/LAI_patches'//trim(c3)// '.nc' - - CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_patches', patchmask) - ENDDO - ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - DO month = 1, 12 - write(c2,'(i2.2)') month - - file_in = trim(dir_landdata_in) //'/LAI/'//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' - file_out = trim(dir_landdata_out)//'/LAI/'//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_pfts', pftmask) - - file_in = trim(dir_landdata_in) //'/LAI/'//trim(cyear)//'/SAI_pfts'//trim(c2)//'.nc' - file_out = trim(dir_landdata_out)//'/LAI/'//trim(cyear)//'/SAI_pfts'//trim(c2)//'.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'SAI_pfts', pftmask) - ENDDO -#endif - ENDDO - - ! depth to bedrock - IF(DEF_USE_BEDROCK)THEN - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/dbedrock') - file_in = trim(dir_landdata_in) // '/dbedrock/dbedrock_patches.nc' - file_out = trim(dir_landdata_out) // '/dbedrock/dbedrock_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'dbedrock_patches', patchmask) - ENDIF - - ! forest height - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/htop') - file_in = trim(dir_landdata_in) // '/htop/htop_patches.nc' - file_out = trim(dir_landdata_out) // '/htop/htop_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_patches', patchmask) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - file_in = trim(dir_landdata_in) // '/htop/htop_pfts.nc' - file_out = trim(dir_landdata_out) // '/htop/htop_pfts.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_pfts', pftmask) -#endif - - ! lake depth - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/lakedepth') - file_in = trim(dir_landdata_in) // '/lakedepth/lakedepth_patches.nc' - file_out = trim(dir_landdata_out) // '/lakedepth/lakedepth_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'lakedepth_patches', patchmask) - - ! plant function type percentage - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/pctpft') -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - file_in = trim(dir_landdata_in) // '/pctpft/pct_pfts.nc' - file_out = trim(dir_landdata_out) // '/pctpft/pct_pfts.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_pfts', pftmask) -#ifdef CROP - file_in = trim(dir_landdata_in) // '/pctpft/pct_crops.nc' - file_out = trim(dir_landdata_out) // '/pctpft/pct_crops.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_crops', patchmask) -#endif -#endif - - ! soil - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/soil') - - file_in = trim(dir_landdata_in) // '/soil/soil_s_v_alb_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/soil_s_v_alb_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_s_v_alb', patchmask) - - file_in = trim(dir_landdata_in) // '/soil/soil_d_v_alb_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/soil_d_v_alb_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_d_v_alb', patchmask) - - file_in = trim(dir_landdata_in) // '/soil/soil_s_n_alb_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/soil_s_n_alb_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_s_n_alb', patchmask) - - file_in = trim(dir_landdata_in) // '/soil/soil_d_n_alb_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/soil_d_n_alb_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'soil_d_n_alb', patchmask) - - DO nsl = 1, 8 - - write(c1,'(i1)') nsl - - ! (1) volumetric fraction of quartz within mineral soil - file_in = trim(dir_landdata_in) // '/soil/vf_quartz_mineral_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/vf_quartz_mineral_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'vf_quartz_mineral_s_l'//trim(c1)//'_patches', patchmask) - - ! (2) volumetric fraction of gravels - file_in = trim(dir_landdata_in) // '/soil/vf_gravels_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/vf_gravels_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'vf_gravels_s_l'//trim(c1)//'_patches', patchmask) - - ! (3) volumetric fraction of sand - file_in = trim(dir_landdata_in) // '/soil/vf_sand_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/vf_sand_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'vf_sand_s_l'//trim(c1)//'_patches', patchmask) - - ! (4) volumetric fraction of organic matter with the parameter alpha and beta in the Balland V. and P. A. Arp (2005) model - file_in = trim(dir_landdata_in) // '/soil/vf_om_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/vf_om_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'vf_om_s_l'//trim(c1)//'_patches', patchmask) - - file_in = trim(dir_landdata_in) // '/soil/BA_alpha_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/BA_alpha_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'BA_alpha_l'//trim(c1)//'_patches', patchmask) - - file_in = trim(dir_landdata_in) // '/soil/BA_beta_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/BA_beta_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'BA_beta_l'//trim(c1)//'_patches', patchmask) - - ! (5) gravimetric fraction of gravels - file_in = trim(dir_landdata_in) // '/soil/wf_gravels_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/wf_gravels_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'wf_gravels_s_l'//trim(c1)//'_patches', patchmask) - - ! (6) gravimetric fraction of sand - file_in = trim(dir_landdata_in) // '/soil/wf_sand_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/wf_sand_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'wf_sand_s_l'//trim(c1)//'_patches', patchmask) - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - ! (7) VGM's pore-connectivity parameter (L) - file_in = trim(dir_landdata_in) // '/soil/L_vgm_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/L_vgm_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'L_vgm_l'//trim(c1)//'_patches', patchmask) - - ! (8) VGM's residual water content (theta_r) [cm3/cm3] - file_in = trim(dir_landdata_in) // '/soil/theta_r_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/theta_r_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'theta_r_l'//trim(c1)//'_patches', patchmask) - - ! (9) VGM's parameter corresponding approximately to the inverse of the air-entry value (alpha) - file_in = trim(dir_landdata_in) // '/soil/alpha_vgm_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/alpha_vgm_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'alpha_vgm_l'//trim(c1)//'_patches', patchmask) - - ! (10) VGM's shape parameter (n) - file_in = trim(dir_landdata_in) // '/soil/n_vgm_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/n_vgm_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'n_vgm_l'//trim(c1)//'_patches', patchmask) -#endif - ! (11) saturated water content [cm3/cm3] - file_in = trim(dir_landdata_in) // '/soil/theta_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/theta_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'theta_s_l'//trim(c1)//'_patches', patchmask) - - ! (12) matric potential at saturation (psi_s) [cm] - file_in = trim(dir_landdata_in) // '/soil/psi_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/psi_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'psi_s_l'//trim(c1)//'_patches', patchmask) - - ! (13) pore size distribution index [dimensionless] - file_in = trim(dir_landdata_in) // '/soil/lambda_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/lambda_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'lambda_l'//trim(c1)//'_patches', patchmask) - - ! (14) saturated hydraulic conductivity [cm/day] - file_in = trim(dir_landdata_in) // '/soil/k_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/k_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'k_s_l'//trim(c1)//'_patches', patchmask) - - ! (15) heat capacity of soil solids [J/(m3 K)] - file_in = trim(dir_landdata_in) // '/soil/csol_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/csol_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'csol_l'//trim(c1)//'_patches', patchmask) - - ! (16) thermal conductivity of unfrozen saturated soil [W/m-K] - file_in = trim(dir_landdata_in) // '/soil/tksatu_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/tksatu_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'tksatu_l'//trim(c1)//'_patches', patchmask) - - ! (17) thermal conductivity of frozen saturated soil [W/m-K] - file_in = trim(dir_landdata_in) // '/soil/tksatf_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/tksatf_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'tksatf_l'//trim(c1)//'_patches', patchmask) - - ! (18) thermal conductivity for dry soil [W/(m-K)] - file_in = trim(dir_landdata_in) // '/soil/tkdry_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/tkdry_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'tkdry_l'//trim(c1)//'_patches', patchmask) - - ! (19) thermal conductivity of soil solids [W/m-K] - file_in = trim(dir_landdata_in) // '/soil/k_solids_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/k_solids_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'k_solids_l'//trim(c1)//'_patches', patchmask) - - ! (20) OM_density [kg/m3] - file_in = trim(dir_landdata_in) // '/soil/OM_density_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/OM_density_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'OM_density_s_l'//trim(c1)//'_patches', patchmask) - - ! (21) bulk density of soil (GRAVELS + OM + Mineral Soils) - file_in = trim(dir_landdata_in) // '/soil/BD_all_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/BD_all_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'BD_all_s_l'//trim(c1)//'_patches', patchmask) - - ! (22) volumetric fraction of clay - file_in = trim(dir_landdata_in) // '/soil/vf_clay_s_l'//trim(c1)//'_patches.nc' - file_out = trim(dir_landdata_out) // '/soil/vf_clay_s_l'//trim(c1)//'_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, & - 'vf_clay_s_l'//trim(c1)//'_patches', patchmask) - - ENDDO - - ! topography - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/topography') - file_in = trim(dir_landdata_in) // '/topography/topography_patches.nc' - file_out = trim(dir_landdata_out) // '/topography/topography_patches.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'topography_patches', patchmask) - - ENDIF - ENDDO - ENDDO - -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, & - MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) -#endif - - IF (p_is_master) THEN - file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' - CALL ncio_write_serial (file_out, 'nelm_blk', nelm_blk, 'xblk', 'yblk') - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_master) THEN - write(*,*) 'Clip surface data from large region successful.' - ENDIF - - IF (allocated(nelm_blk )) deallocate(nelm_blk ) - IF (allocated(IOproc )) deallocate(IOproc ) - IF (allocated(elmindex )) deallocate(elmindex ) - IF (allocated(elmnpxl )) deallocate(elmnpxl ) - IF (allocated(elmpixels)) deallocate(elmpixels) - IF (allocated(elmmask )) deallocate(elmmask ) - IF (allocated(patchmask)) deallocate(patchmask) -#ifdef CATCHMENT - IF (allocated(hrumask )) deallocate(hrumask ) -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (allocated(pftmask )) deallocate(pftmask ) -#endif - - END SUBROUTINE srfdata_region_clip - - ! ----- pixelset clip ----- - SUBROUTINE clip_pixelset (dir_landdata_in, psetname, iblk, jblk, elmmask, elmindex, psetmask) - - USE MOD_NetCDFSerial - USE MOD_Block - - IMPLICIT NONE - - character(len=*), intent(in) :: dir_landdata_in - character(len=*), intent(in) :: psetname - integer, intent(in) :: iblk, jblk - logical, intent(in) :: elmmask (:) - - integer*8, intent(in) :: elmindex(:) - - logical, allocatable, intent(out) :: psetmask (:) - - ! Local Variables - character(len=256) :: filename, fileblock - logical :: fexists - integer :: nset, ie, iset - integer*8, allocatable :: eindex_p(:) - - filename = trim(dir_landdata_in) // '/' // trim(psetname) // '/' // trim(psetname) // '.nc' - CALL get_filename_block (filename, iblk, jblk, fileblock) - - inquire (file=trim(fileblock), exist=fexists) - IF (fexists) THEN - CALL ncio_inquire_length (fileblock, 'eindex', nset) - - IF (nset > 0) THEN - - CALL ncio_read_serial (fileblock, 'eindex', eindex_p) - - allocate (psetmask (nset)) - psetmask(:) = .false. - - ie = 1 - DO iset = 1, nset - DO WHILE ((eindex_p(iset) /= elmindex(ie))) - ie = ie + 1 - ENDDO - psetmask(iset) = elmmask(ie) - ENDDO - - deallocate(eindex_p) - ENDIF - ENDIF - - END SUBROUTINE clip_pixelset - - ! ----- vector clip ----- - SUBROUTINE clip_vector (file_in, file_out, iblk, jblk, varname, vecmask) - - USE netcdf - USE MOD_NetCDFSerial - USE MOD_Block - IMPLICIT NONE - - character(len=*), intent(in) :: file_in, file_out - character(len=*), intent(in) :: varname - integer, intent(in) :: iblk, jblk - logical, intent(in) :: vecmask(:) - - ! Local Variables - character(len=256) :: input, output - integer :: ncidin, ncidout - integer :: varidin, varidout - integer :: vlen_in, vlen_out, xtype, ndims, id, i1, i2 - logical :: fexists, dim_exist - integer, allocatable :: dimids (:), dimlens (:) - character(len=256), allocatable :: dimnames (:) - - integer, allocatable :: data_i4_in1 (:) - integer, allocatable :: data_i4_in2 (:,:) - integer, allocatable :: data_i4_in3 (:,:,:) - - integer, allocatable :: data_i4_out1 (:) - integer, allocatable :: data_i4_out2 (:,:) - integer, allocatable :: data_i4_out3 (:,:,:) - - integer*8, allocatable :: data_i8_in1 (:) - integer*8, allocatable :: data_i8_out1 (:) - - real(r8), allocatable :: data_r8_in1 (:) - real(r8), allocatable :: data_r8_in2 (:,:) - real(r8), allocatable :: data_r8_in3 (:,:,:) - - real(r8), allocatable :: data_r8_out1 (:) - real(r8), allocatable :: data_r8_out2 (:,:) - real(r8), allocatable :: data_r8_out3 (:,:,:) - - CALL get_filename_block (file_in, iblk, jblk, input ) - CALL get_filename_block (file_out, iblk, jblk, output) - - write(*,*) 'Copy and clip ', trim(varname), ' from ', trim(input), ' to ', trim(output) - - IF (.not. ncio_var_exist(input, varname)) THEN - write(*,*) 'Variable ', trim(varname), ' in ', trim(input), ' not found.' - ENDIF - - vlen_in = size (vecmask) - vlen_out = count(vecmask) - - CALL nccheck( nf90_open (trim(input), NF90_NOWRITE, ncidin) ) - CALL nccheck( nf90_inq_varid (ncidin, trim(varname), varidin) ) - CALL nccheck( nf90_inquire_variable (ncidin, varidin, xtype = xtype, ndims = ndims) ) - allocate (dimids (ndims)) - allocate (dimnames (ndims)) - allocate (dimlens (ndims)) - CALL nccheck( nf90_inquire_variable (ncidin, varidin, dimids = dimids) ) - DO id = 1, ndims - CALL nccheck( nf90_inquire_dimension (ncidin, dimids(id), dimnames(id), dimlens(id)) ) - ENDDO - CALL nccheck( nf90_close (ncidin) ) - - inquire (file=trim(output), exist=fexists) - IF (.not. fexists) THEN - CALL ncio_create_file (output) - ENDIF - - DO id = 1, ndims - CALL nccheck( nf90_open (trim(output), NF90_NOWRITE, ncidout) ) - dim_exist = (nf90_inq_dimid (ncidout, trim(dimnames(id)), dimids(id)) == NF90_NOERR) - CALL nccheck( nf90_close (ncidout) ) - - IF (.not. dim_exist) THEN - IF (id < ndims) THEN - CALL nccheck( nf90_open (trim(input), NF90_NOWRITE, ncidin) ) - CALL nccheck( nf90_inq_dimid (ncidin, trim(dimnames(id)), dimids(id)) ) - CALL nccheck( nf90_inquire_dimension (ncidin, dimids(id), len = dimlens(id)) ) - CALL nccheck( nf90_close (ncidin) ) - ELSE - dimlens(ndims) = vlen_out - ENDIF - - CALL nccheck( nf90_open (trim(output), NF90_WRITE, ncidout) ) - CALL nccheck( nf90_redef (ncidout) ) - CALL nccheck( nf90_def_dim (ncidout, trim(dimnames(id)), dimlens(id), dimids(id)) ) - CALL nccheck( nf90_enddef (ncidout) ) - CALL nccheck( nf90_close (ncidout) ) - ENDIF - ENDDO - - CALL nccheck( nf90_open (trim(output), NF90_WRITE, ncidout) ) - DO id = 1, ndims - CALL nccheck( nf90_inq_dimid (ncidout, dimnames(id), dimids(id)) ) - ENDDO - - IF (nf90_inq_varid(ncidout,trim(varname),varidout) /= nf90_noerr) THEN - CALL nccheck( nf90_redef (ncidout) ) - CALL nccheck( nf90_def_var (ncidout, trim(varname), xtype, dimids, varidout, deflate_level = 1) ) - CALL nccheck( nf90_enddef (ncidout) ) - ENDIF - - CALL nccheck( nf90_open (trim(input), NF90_NOWRITE, ncidin) ) - CALL nccheck( nf90_inq_varid (ncidin, trim(varname), varidin ) ) - - SELECTCASE (ndims) - CASE (1) - IF (xtype == NF90_INT) THEN - allocate (data_i4_in1 (vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_i4_in1) ) - - allocate (data_i4_out1 (vlen_out)) - data_i4_out1 = pack(data_i4_in1, vecmask) - CALL nccheck( nf90_put_var (ncidout, varidout, data_i4_out1) ) - - deallocate (data_i4_in1 ) - deallocate (data_i4_out1) - ELSEIF (xtype == NF90_INT64) THEN - allocate (data_i8_in1 (vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_i8_in1) ) - - allocate (data_i8_out1 (vlen_out)) - data_i8_out1 = pack(data_i8_in1, vecmask) - CALL nccheck( nf90_put_var (ncidout, varidout, data_i8_out1) ) - - deallocate (data_i8_in1 ) - deallocate (data_i8_out1) - ELSEIF (xtype == NF90_DOUBLE) THEN - allocate (data_r8_in1 (vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in1) ) - - allocate (data_r8_out1 (vlen_out)) - data_r8_out1 = pack(data_r8_in1, vecmask) - CALL nccheck( nf90_put_var (ncidout, varidout, data_r8_out1) ) - - deallocate (data_r8_in1 ) - deallocate (data_r8_out1) - ENDIF - - CASE (2) - IF (xtype == NF90_INT) THEN - allocate (data_i4_in2 (dimlens(1),vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_i4_in2) ) - - allocate (data_i4_out2 (dimlens(1),vlen_out)) - DO i1 = 1, dimlens(1) - data_i4_out2(i1,:) = pack(data_i4_in2(i1,:), vecmask) - ENDDO - CALL nccheck( nf90_put_var (ncidout, varidout, data_i4_out2) ) - - deallocate (data_i4_in2 ) - deallocate (data_i4_out2) - ELSEIF (xtype == NF90_DOUBLE) THEN - allocate (data_r8_in2 (dimlens(1),vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in2) ) - - allocate (data_r8_out2 (dimlens(1),vlen_out)) - DO i1 = 1, dimlens(1) - data_r8_out2(i1,:) = pack(data_r8_in2(i1,:), vecmask) - ENDDO - CALL nccheck( nf90_put_var (ncidout, varidout, data_r8_out2) ) - - deallocate (data_r8_in2 ) - deallocate (data_r8_out2) - ENDIF - - CASE (3) - IF (xtype == NF90_INT) THEN - allocate (data_i4_in3 (dimlens(1),dimlens(2),vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_i4_in3) ) - - allocate (data_i4_out3 (dimlens(1),dimlens(2),vlen_out)) - DO i1 = 1, dimlens(1) - DO i2 = 1, dimlens(2) - data_i4_out3(i1,i2,:) = pack(data_i4_in3(i1,i2,:), vecmask) - ENDDO - ENDDO - CALL nccheck( nf90_put_var (ncidout, varidout, data_i4_out3) ) - - deallocate (data_i4_in3 ) - deallocate (data_i4_out3) - ELSEIF (xtype == NF90_DOUBLE) THEN - allocate (data_r8_in3 (dimlens(1),dimlens(2),vlen_in)) - CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in3) ) - - allocate (data_r8_out3 (dimlens(1),dimlens(2),vlen_out)) - DO i1 = 1, dimlens(1) - DO i2 = 1, dimlens(2) - data_r8_out3(i1,i2,:) = pack(data_r8_in3(i1,i2,:), vecmask) - ENDDO - ENDDO - CALL nccheck( nf90_put_var (ncidout, varidout, data_r8_out3) ) - - deallocate (data_r8_in3 ) - deallocate (data_r8_out3) - ENDIF - - CASE default - write(*,*) 'Warning: there is no case for variable: ', trim(varname) - ENDSELECT - - CALL nccheck( nf90_close (ncidin) ) - CALL nccheck( nf90_close (ncidout) ) - - END SUBROUTINE clip_vector - -END MODULE MOD_RegionClip diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 deleted file mode 100644 index 3c83ff459f..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataDiag.F90 +++ /dev/null @@ -1,553 +0,0 @@ -#include - -#ifdef SrfdataDiag -MODULE MOD_SrfdataDiag -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! This module includes subroutines for checking the results of making -! surface data. -! -! The surface data in vector form is mapped to gridded data with last three -! dimensions of [type,longitude,latitude], which can be viewed by other -! softwares. -! -! In GRIDBASED, the grid of gridded data is just the grid of the mesh. In -! UNSTRUCTURED or CATCHMENT, the grid is user defined and the mapping uses -! area weighted scheme. -! -! Created by Shupeng Zhang, May 2023 -! -! !REVISIONS: -! TODO -!----------------------------------------------------------------------- - - USE MOD_Grid - USE MOD_SpatialMapping - - IMPLICIT NONE - - ! PUBLIC variables and subroutines - type(grid_type) :: gdiag - - type(spatial_mapping_type) :: m_elm2diag - - type(spatial_mapping_type) :: m_patch2diag -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - type(spatial_mapping_type) :: m_pft2diag -#endif -#ifdef URBAN_MODEL - type(spatial_mapping_type) :: m_urb2diag -#endif - - PUBLIC :: srfdata_diag_init - PUBLIC :: srfdata_map_and_write - - ! PRIVATE - type(grid_concat_type), PRIVATE :: srf_concat - integer, PRIVATE :: srf_data_id - -CONTAINS - - ! ------ SUBROUTINE ------ - SUBROUTINE srfdata_diag_init (dir_landdata, lc_year) - - USE MOD_SPMD_Task - USE MOD_LandElm - USE MOD_LandPatch -#ifdef CROP - USE MOD_LandCrop -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif -#ifdef URBAN_MODEL - USE MOD_LandUrban -#endif - - IMPLICIT NONE - - character(len=256), intent(in) :: dir_landdata - integer , intent(in) :: lc_year - - ! Local Variables - character(len=256) :: landdir, landname - integer :: ityp - integer :: typindex(N_land_classification+1) - real(r8), allocatable :: elmid_r8(:) - character(len=4) :: cyear - - landdir = trim(dir_landdata) // '/diag/' - IF (p_is_master) THEN - CALL system('mkdir -p ' // trim(adjustl(landdir))) - ENDIF - - CALL srf_concat%set (gdiag) - - CALL m_elm2diag%build_arealweighted (gdiag, landelm) - - CALL m_patch2diag%build_arealweighted (gdiag, landpatch) - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL m_pft2diag%build_arealweighted (gdiag, landpft) -#endif - -#ifdef URBAN_MODEL - CALL m_urb2diag%build_arealweighted (gdiag, landurban) -#endif - - srf_data_id = 666 - - IF (p_is_worker) THEN - allocate (elmid_r8 (landelm%nset)); elmid_r8 = real(landelm%eindex, r8) - ENDIF - - write(cyear,'(i4.4)') lc_year - landname = trim(dir_landdata)//'/diag/element_'//trim(cyear)//'.nc' - CALL srfdata_map_and_write (elmid_r8, landelm%settyp, (/0,1/), m_elm2diag, & - -1.0e36_r8, landname, 'element', compress = 1, write_mode = 'one', & - defval=0._r8, create_mode=.true.) - - IF (p_is_worker) deallocate (elmid_r8) - - typindex = (/(ityp, ityp = 0, N_land_classification)/) - landname = trim(dir_landdata)//'/diag/patchfrac_elm_'//trim(cyear)//'.nc' - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - IF (.not. allocated(landpatch%pctshared)) THEN - allocate (landpatch%pctshared (numpatch)) - landpatch%pctshared = 1. - ENDIF - ENDIF - ENDIF - - CALL srfdata_map_and_write (landpatch%pctshared, landpatch%settyp, typindex, m_patch2diag, & - -1.0e36_r8, landname, 'patchfrac_elm', compress = 1, write_mode = 'one', defval=0._r8, & - stat_mode = 'fraction', pctshared = landpatch%pctshared, create_mode=.true.) - - END SUBROUTINE srfdata_diag_init - - ! ------ SUBROUTINE ------ - SUBROUTINE srfdata_map_and_write ( & - vsrfdata, settyp, typindex, m_srf, spv, filename, & - dataname, compress, write_mode, lastdimname, lastdimvalue, defval, & - stat_mode, pctshared, create_mode) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_NetCDFSerial - IMPLICIT NONE - - real(r8), intent(in) :: vsrfdata (:) - integer , intent(in) :: settyp (:) - integer , intent(in) :: typindex (:) - - type(spatial_mapping_type), intent(in) :: m_srf - - real(r8), intent(in) :: spv - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - integer, intent(in) :: compress - - character (len=*), intent(in), optional :: write_mode - - character (len=*), intent(in), optional :: lastdimname - integer, intent(in), optional :: lastdimvalue - - real(r8), intent(in), optional :: defval - - character (len=*), intent(in), optional :: stat_mode - real(r8), intent(in), optional :: pctshared (:) - logical , intent(in), optional :: create_mode - - ! Local variables - type(block_data_real8_3d) :: wdata, wtone - type(block_data_real8_2d) :: wdsum, wtsum - real(r8), allocatable :: vecone (:) - real(r8), allocatable :: areafrac (:) - real(r8), allocatable :: vdata (:,:,:), vdsum (:,:) - real(r8), allocatable :: rbuf (:,:,:), sbuf (:,:,:) - - character(len=10) :: wmode, smode - integer :: iblkme, ib, jb, iblk, jblk, idata, ixseg, iyseg - integer :: ntyps, ityp, xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp - integer :: rmesg(3), smesg(3), isrc - character(len=256) :: fileblock - logical :: fexists, cmode - integer :: ilastdim - - IF (present(write_mode)) THEN - wmode = trim(write_mode) - ELSE - wmode = 'one' - ENDIF - - IF (present(stat_mode)) THEN - smode = trim(stat_mode) - ELSE - smode = 'mean' - ENDIF - - IF (present(create_mode)) THEN - cmode = create_mode - ELSE - cmode = .false. - ENDIF - - ntyps = size(typindex) - - IF (p_is_io) THEN - CALL allocate_block_data (gdiag, wtone, ntyps) - CALL allocate_block_data (gdiag, wdata, ntyps) - CALL allocate_block_data (gdiag, wdsum) - CALL allocate_block_data (gdiag, wtsum) - ENDIF - - IF (p_is_worker) THEN - IF (m_srf%npset > 0) THEN - allocate (vecone (m_srf%npset)) - vecone(:) = 1.0 - ENDIF - ENDIF - - CALL m_srf%pset2grid_split (vecone, settyp, typindex, wtone, spv) - - IF (trim(smode) == 'mean') THEN - CALL m_srf%pset2grid_split (vsrfdata, settyp, typindex, wdata, spv) - ELSEIF (trim(smode) == 'fraction') THEN - IF (p_is_worker) THEN - IF (m_srf%npset > 0) THEN - allocate (areafrac (m_srf%npset)) - areafrac = vsrfdata - IF (present(pctshared)) THEN - WHERE (pctshared > 0.) areafrac = areafrac / pctshared - ENDIF - ENDIF - ENDIF - CALL m_srf%pset2grid_split (areafrac, settyp, typindex, wdata, spv) - ENDIF - - IF (p_is_io) THEN - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - wtsum%blk(ib,jb)%val = sum(wtone%blk(ib,jb)%val, & - mask = (wtone%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv), dim = 1) - wdsum%blk(ib,jb)%val = sum(wdata%blk(ib,jb)%val, & - mask = (wtone%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv), dim = 1) - - IF (trim(smode) == 'mean') THEN - - WHERE ((wtone%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv)) - wdata%blk(ib,jb)%val = wdata%blk(ib,jb)%val / wtone%blk(ib,jb)%val - ELSEWHERE - wdata%blk(ib,jb)%val = spv - END WHERE - - ELSEIF (trim(smode) == 'fraction') THEN - - DO ityp = 1, ntyps - WHERE ((wtsum%blk(ib,jb)%val(:,:) > 0.) .and. (wtone%blk(ib,jb)%val(ityp,:,:) /= spv)) - wdata%blk(ib,jb)%val(ityp,:,:) = wtone%blk(ib,jb)%val(ityp,:,:) / wtsum%blk(ib,jb)%val - ELSEWHERE - wdata%blk(ib,jb)%val(ityp,:,:) = spv - END WHERE - ENDDO - - ENDIF - - WHERE (wtsum%blk(ib,jb)%val > 0.) - wdsum%blk(ib,jb)%val = wdsum%blk(ib,jb)%val / wtsum%blk(ib,jb)%val - ELSEWHERE - wdsum%blk(ib,jb)%val = spv - END WHERE - - ENDDO - ENDIF - - IF (trim(wmode) == 'one') THEN - - IF (p_is_master) THEN - - allocate (vdata (srf_concat%ginfo%nlon, srf_concat%ginfo%nlat, ntyps)) - vdata(:,:,:) = spv - - allocate (vdsum (srf_concat%ginfo%nlon, srf_concat%ginfo%nlat)) - vdsum(:,:) = spv - -#ifdef USEMPI - DO idata = 1, srf_concat%ndatablk - - CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & - srf_data_id, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - - xgdsp = srf_concat%xsegs(ixseg)%gdsp - ygdsp = srf_concat%ysegs(iyseg)%gdsp - xcnt = srf_concat%xsegs(ixseg)%cnt - ycnt = srf_concat%ysegs(iyseg)%cnt - - allocate (rbuf (ntyps,xcnt,ycnt)) - - CALL mpi_recv (rbuf, ntyps * xcnt * ycnt, MPI_REAL8, & - isrc, srf_data_id, p_comm_glb, p_stat, p_err) - - DO ityp = 1, ntyps - vdata (xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt,ityp) = rbuf(ityp,:,:) - ENDDO - - CALL mpi_recv (rbuf(1,:,:), xcnt * ycnt, MPI_REAL8, & - isrc, srf_data_id, p_comm_glb, p_stat, p_err) - - vdsum (xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf(1,:,:) - - deallocate (rbuf) - ENDDO -#else - DO iyseg = 1, srf_concat%nyseg - DO ixseg = 1, srf_concat%nxseg - iblk = srf_concat%xsegs(ixseg)%blk - jblk = srf_concat%ysegs(iyseg)%blk - xbdsp = srf_concat%xsegs(ixseg)%bdsp - ybdsp = srf_concat%ysegs(iyseg)%bdsp - xgdsp = srf_concat%xsegs(ixseg)%gdsp - ygdsp = srf_concat%ysegs(iyseg)%gdsp - xcnt = srf_concat%xsegs(ixseg)%cnt - ycnt = srf_concat%ysegs(iyseg)%cnt - - DO ityp = 1, ntyps - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt,ityp) = & - wdata%blk(iblk,jblk)%val(ityp,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - ENDDO - - vdsum (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & - wdsum%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - ENDDO - ENDDO -#endif - - IF (present(defval)) THEN - WHERE (vdata == spv) vdata = defval - WHERE (vdsum == spv) vdsum = defval - ENDIF - - write(*,*) 'Please check gridded data < ', trim(dataname), ' > in ', trim(filename) - - inquire (file=trim(filename), exist=fexists) - IF (.not. fexists .or. cmode) THEN - - CALL ncio_create_file (filename) - - IF (ntyps > 1) THEN - CALL ncio_define_dimension (filename, 'TypeIndex', ntyps) - CALL ncio_write_serial (filename, 'TypeIndex', typindex, 'TypeIndex') - ENDIF - - CALL ncio_define_dimension (filename, 'lon' , srf_concat%ginfo%nlon) - CALL ncio_define_dimension (filename, 'lat' , srf_concat%ginfo%nlat) - - CALL ncio_write_serial (filename, 'lat', srf_concat%ginfo%lat_c, 'lat') - CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') - CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - - CALL ncio_write_serial (filename, 'lon', srf_concat%ginfo%lon_c, 'lon') - CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') - CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') - - CALL ncio_write_serial (filename, 'lat_s', srf_concat%ginfo%lat_s, 'lat') - CALL ncio_put_attr (filename, 'lat_s', 'long_name', 'southern latitude boundary') - CALL ncio_put_attr (filename, 'lat_s', 'units', 'degrees_north') - - CALL ncio_write_serial (filename, 'lat_n', srf_concat%ginfo%lat_n, 'lat') - CALL ncio_put_attr (filename, 'lat_n', 'long_name', 'northern latitude boundary') - CALL ncio_put_attr (filename, 'lat_n', 'units', 'degrees_north') - - CALL ncio_write_serial (filename, 'lon_w', srf_concat%ginfo%lon_w, 'lon') - CALL ncio_put_attr (filename, 'lon_w', 'long_name', 'western longitude boundary') - CALL ncio_put_attr (filename, 'lon_w', 'units', 'degrees_east') - - CALL ncio_write_serial (filename, 'lon_e', srf_concat%ginfo%lon_e, 'lon') - CALL ncio_put_attr (filename, 'lon_e', 'long_name', 'eastern longitude boundary') - CALL ncio_put_attr (filename, 'lon_e', 'units', 'degrees_east') - - ENDIF - - IF (present(lastdimname) .and. present(lastdimvalue)) THEN - - CALL ncio_write_lastdim (filename, lastdimname, lastdimvalue, ilastdim) - - IF (ntyps > 1) THEN - CALL ncio_write_serial_time (filename, dataname, ilastdim, vdata, & - 'lon', 'lat', 'TypeIndex', trim(lastdimname), compress) - CALL ncio_write_serial_time (filename, trim(dataname)//'_grid', ilastdim, vdsum, & - 'lon', 'lat', trim(lastdimname), compress) - ELSE - CALL ncio_write_serial_time (filename, dataname, ilastdim, vdata(:,:,1), & - 'lon', 'lat', trim(lastdimname), compress) - ENDIF - - ELSE - - IF (ntyps > 1) THEN - CALL ncio_write_serial (filename, dataname, vdata, 'lon', 'lat', 'TypeIndex', compress) - CALL ncio_write_serial (filename, trim(dataname)//'_grid', vdsum, 'lon', 'lat', compress) - ELSE - CALL ncio_write_serial (filename, dataname, vdata(:,:,1), 'lon', 'lat', compress) - ENDIF - - ENDIF - - CALL ncio_put_attr (filename, dataname, 'missing_value', spv) - - IF (ntyps > 1) THEN - CALL ncio_put_attr (filename, trim(dataname)//'_grid', 'missing_value', spv) - ENDIF - - deallocate (vdata) - deallocate (vdsum) - - ENDIF - -#ifdef USEMPI - IF (p_is_io) THEN - - DO iyseg = 1, srf_concat%nyseg - DO ixseg = 1, srf_concat%nxseg - - iblk = srf_concat%xsegs(ixseg)%blk - jblk = srf_concat%ysegs(iyseg)%blk - - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - xbdsp = srf_concat%xsegs(ixseg)%bdsp - ybdsp = srf_concat%ysegs(iyseg)%bdsp - xcnt = srf_concat%xsegs(ixseg)%cnt - ycnt = srf_concat%ysegs(iyseg)%cnt - - smesg = (/p_iam_glb, ixseg, iyseg/) - CALL mpi_send (smesg, 3, MPI_INTEGER, & - p_address_master, srf_data_id, p_comm_glb, p_err) - - allocate (sbuf (ntyps,xcnt,ycnt)) - - sbuf = wdata%blk(iblk,jblk)%val(:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - CALL mpi_send (sbuf, ntyps*xcnt*ycnt, MPI_REAL8, & - p_address_master, srf_data_id, p_comm_glb, p_err) - - sbuf(1,:,:) = wdsum%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - CALL mpi_send (sbuf(1,:,:), xcnt*ycnt, MPI_REAL8, & - p_address_master, srf_data_id, p_comm_glb, p_err) - - deallocate (sbuf) - ENDIF - ENDDO - ENDDO - ENDIF -#endif - - srf_data_id = srf_data_id + 1 - - ELSEIF (trim(wmode) == 'block') THEN - - IF (p_is_io) THEN - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF ((gdiag%xcnt(iblk) == 0) .or. (gdiag%ycnt(jblk) == 0)) CYCLE - - CALL get_filename_block (filename, iblk, jblk, fileblock) - - inquire (file=trim(filename), exist=fexists) - IF (.not. fexists) THEN - CALL ncio_create_file (fileblock) - CALL ncio_define_dimension (fileblock, 'TypeIndex', ntyps) - CALL srf_write_grid_info (fileblock, gdiag, iblk, jblk) - ENDIF - - IF (present(lastdimname) .and. present(lastdimvalue)) THEN - CALL ncio_write_lastdim (fileblock, lastdimname, lastdimvalue, ilastdim) - CALL ncio_write_serial_time (fileblock, dataname, ilastdim, wdata%blk(iblk,jblk)%val, & - 'TypeIndex', 'lon', 'lat', trim(lastdimname), compress) - ELSE - CALL ncio_write_serial (fileblock, dataname, & - wdata%blk(iblk,jblk)%val, 'TypeIndex', 'lon', 'lat', compress) - ENDIF - - CALL ncio_put_attr (fileblock, dataname, 'missing_value', spv) - - ENDDO - - ENDIF - ENDIF - - IF (allocated(vecone)) deallocate(vecone) - - END SUBROUTINE srfdata_map_and_write - - !------------------ - SUBROUTINE srf_write_grid_info (fileblock, grid, iblk, jblk) - - USE MOD_Block - USE MOD_Grid - USE MOD_NetCDFSerial - IMPLICIT NONE - - character(len=*), intent(in) :: fileblock - type (grid_type), intent(in) :: grid - integer, intent(in) :: iblk, jblk - - ! Local variable - integer :: yl, yu, xl, xu, nx - real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:) - - allocate (lon_w (grid%xcnt(iblk))) - allocate (lon_e (grid%xcnt(iblk))) - allocate (lat_s (grid%ycnt(jblk))) - allocate (lat_n (grid%ycnt(jblk))) - - yl = grid%ydsp(jblk) + 1 - yu = grid%ydsp(jblk) + grid%ycnt(jblk) - - lat_s = grid%lat_s(yl:yu) - lat_n = grid%lat_n(yl:yu) - - IF (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) THEN - xl = grid%xdsp(iblk) + 1 - xu = grid%nlon - nx = grid%nlon - grid%xdsp(iblk) - lon_w(1:nx) = grid%lon_w(xl:xu) - lon_e(1:nx) = grid%lon_e(xl:xu) - - xl = 1 - xu = grid%xcnt(iblk) - nx - lon_w(nx+1:grid%xcnt(iblk)) = grid%lon_w(xl:xu) - lon_e(nx+1:grid%xcnt(iblk)) = grid%lon_e(xl:xu) - ELSE - xl = grid%xdsp(iblk) + 1 - xu = grid%xdsp(iblk) + grid%xcnt(iblk) - lon_w = grid%lon_w(xl:xu) - lon_e = grid%lon_e(xl:xu) - ENDIF - - CALL ncio_define_dimension (fileblock, 'lat', grid%ycnt(jblk)) - CALL ncio_define_dimension (fileblock, 'lon', grid%xcnt(iblk)) - CALL ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat') - CALL ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat') - CALL ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon') - CALL ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon') - - END SUBROUTINE srf_write_grid_info - -END MODULE MOD_SrfdataDiag -#endif From 08c56ddbf0e090cac4263a3e0400441ac550e168 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 18:52:08 +0800 Subject: [PATCH 03/17] Remove obsolete CoLM process-pool names MPAS owns CoLM decomposition now, so the embedded SPMD layer should expose root/active/compute names instead of standalone master/io/worker compatibility names. The compute push/remap API was renamed with the same boundary; local loop variables were left alone. Constraint: CoLM runtime still uses its existing MPI collectives and history routines, only the deprecated process-pool API names were removed. Rejected: renaming every local iworker/comment occurrence | that is churn without changing the exported process model. Confidence: high Scope-risk: moderate Directive: Do not reintroduce master/io/worker SPMD aliases in MOD_SPMD_Task. Tested: rg --no-ignore scans for old SPMD and WorkerPushData API names; git diff --check; cmake -S . -B build-cmake-colm-debug; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; NETCDF=/opt/homebrew/Cellar/netcdf/4.10.0 NETCDFF=/opt/homebrew/Cellar/netcdf-fortran/4.6.2 PNETCDF=/opt/homebrew/Cellar/pnetcdf/1.14.1 make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true -j 8. Not-tested: real MPAS+CoLM runtime case with production landdata/restart inputs. --- .../physics/physics_colm2024/Makefile | 2 +- .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 12 +- .../main/BGC/MOD_BGC_Vars_1DFluxes.F90 | 6 +- .../main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 | 6 +- .../main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 | 4 +- .../main/BGC/MOD_BGC_Vars_TimeInvariants.F90 | 6 +- .../main/BGC/MOD_BGC_Vars_TimeVariables.F90 | 4 +- .../physics_colm2024/main/DA/MOD_DA_Main.F90 | 8 +- .../physics_colm2024/main/DA/MOD_DA_SM.F90 | 104 ++-- .../physics_colm2024/main/DA/MOD_DA_TWS.F90 | 22 +- .../main/DA/MOD_DA_Vars_1DFluxes.F90 | 4 +- .../main/DA/MOD_DA_Vars_TimeVariables.F90 | 12 +- .../main/HYDRO/MOD_Catch_BasinNetwork.F90 | 74 +-- .../main/HYDRO/MOD_Catch_HillslopeFlow.F90 | 2 +- .../main/HYDRO/MOD_Catch_HillslopeNetwork.F90 | 38 +- .../main/HYDRO/MOD_Catch_Hist.F90 | 50 +- .../main/HYDRO/MOD_Catch_LateralFlow.F90 | 32 +- .../main/HYDRO/MOD_Catch_Reservoir.F90 | 58 +- .../main/HYDRO/MOD_Catch_RiverLakeFlow.F90 | 4 +- .../main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 | 90 ++-- .../main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 | 14 +- .../main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 | 2 +- .../HYDRO/MOD_Catch_Vars_TimeVariables.F90 | 20 +- .../main/HYDRO/MOD_Catch_WriteParameters.F90 | 34 +- .../main/HYDRO/MOD_ElementNeighbour.F90 | 78 +-- .../main/HYDRO/MOD_Grid_Reservoir.F90 | 40 +- .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 46 +- .../main/HYDRO/MOD_Grid_RiverLakeHist.F90 | 98 ++-- .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 344 ++++++------ .../main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 | 14 +- .../main/HYDRO/MOD_Hydro_SoilWater.F90 | 26 +- .../main/HYDRO/MOD_Vector_ReadWrite.F90 | 40 +- .../main/MOD_CheckEquilibrium.F90 | 40 +- .../physics_colm2024/main/MOD_CropReadin.F90 | 58 +- .../physics_colm2024/main/MOD_FireData.F90 | 10 +- .../physics_colm2024/main/MOD_Forcing.F90 | 38 +- .../physics_colm2024/main/MOD_Hist.F90 | 308 +++++------ .../physics_colm2024/main/MOD_HistGridded.F90 | 60 +-- .../physics_colm2024/main/MOD_HistVector.F90 | 50 +- .../main/MOD_HistWriteBack.F90 | 56 +- .../physics_colm2024/main/MOD_LAIReadin.F90 | 4 +- .../physics_colm2024/main/MOD_NdepData.F90 | 8 +- .../physics_colm2024/main/MOD_NitrifData.F90 | 14 +- .../physics_colm2024/main/MOD_SnowSnicar.F90 | 44 +- .../main/MOD_SnowSnicar_HiRes.F90 | 44 +- .../main/MOD_Vars_1DAccFluxes.F90 | 10 +- .../main/MOD_Vars_1DFluxes.F90 | 4 +- .../main/MOD_Vars_1DForcing.F90 | 4 +- .../main/MOD_Vars_1DPFTFluxes.F90 | 6 +- .../main/MOD_Vars_2DForcing.F90 | 2 +- .../main/MOD_Vars_TimeInvariants.F90 | 20 +- .../main/MOD_Vars_TimeVariables.F90 | 16 +- .../main/MOD_VicParaReadin.F90 | 10 +- .../main/ParaOpt/MOD_Opt_Baseflow.F90 | 12 +- .../main/URBAN/MOD_Urban_LAIReadin.F90 | 2 +- .../main/URBAN/MOD_Urban_Vars_1DFluxes.F90 | 6 +- .../URBAN/MOD_Urban_Vars_TimeInvariants.F90 | 4 +- .../URBAN/MOD_Urban_Vars_TimeVariables.F90 | 4 +- .../mksrfdata/MOD_AggregationRequestData.F90 | 32 +- .../mksrfdata/MOD_ElmVector.F90 | 40 +- .../mksrfdata/MOD_HRUVector.F90 | 36 +- .../mksrfdata/MOD_Land2mWMO.F90 | 10 +- .../mksrfdata/MOD_LandCrop.F90 | 16 +- .../mksrfdata/MOD_LandElm.F90 | 10 +- .../mksrfdata/MOD_LandHRU.F90 | 42 +- .../mksrfdata/MOD_LandPFT.F90 | 16 +- .../mksrfdata/MOD_LandPatch.F90 | 14 +- .../mksrfdata/MOD_LandUrban.F90 | 22 +- .../mksrfdata/MOD_MeshFilter.F90 | 22 +- .../mksrfdata/MOD_PixelsetShared.F90 | 8 +- .../mksrfdata/MOD_SrfdataRestart.F90 | 42 +- .../share/MOD_5x5DataReadin.F90 | 10 +- .../physics_colm2024/share/MOD_Block.F90 | 44 +- .../share/MOD_CatchmentDataReadin.F90 | 8 +- ...erPushData.F90 => MOD_ComputePushData.F90} | 248 ++++----- .../physics_colm2024/share/MOD_DataType.F90 | 2 +- .../physics_colm2024/share/MOD_Grid.F90 | 2 +- .../physics_colm2024/share/MOD_Mesh.F90 | 80 +-- .../physics_colm2024/share/MOD_Namelist.F90 | 498 +++++++++--------- .../share/MOD_NetCDFBlock.F90 | 14 +- .../share/MOD_NetCDFSerial.F90 | 72 +-- .../share/MOD_NetCDFVector.F90 | 110 ++-- .../physics_colm2024/share/MOD_Pixel.F90 | 4 +- .../physics_colm2024/share/MOD_Pixelset.F90 | 10 +- .../physics_colm2024/share/MOD_RangeCheck.F90 | 214 ++++---- .../physics_colm2024/share/MOD_SPMD_Task.F90 | 107 ++-- .../share/MOD_SpatialMapping.F90 | 334 ++++++------ 87 files changed, 2096 insertions(+), 2099 deletions(-) rename src/core_atmosphere/physics/physics_colm2024/share/{MOD_WorkerPushData.F90 => MOD_ComputePushData.F90} (82%) diff --git a/src/core_atmosphere/physics/physics_colm2024/Makefile b/src/core_atmosphere/physics/physics_colm2024/Makefile index 8a922e1cb3..e3015c7d70 100644 --- a/src/core_atmosphere/physics/physics_colm2024/Makefile +++ b/src/core_atmosphere/physics/physics_colm2024/Makefile @@ -49,7 +49,7 @@ OBJS_SHARED = \ MOD_NetCDFVector.o \ MOD_RangeCheck.o \ MOD_SpatialMapping.o \ - MOD_WorkerPushData.o \ + MOD_ComputePushData.o \ MOD_AggregationRequestData.o \ MOD_PixelsetShared.o \ MOD_LandElm.o \ diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index cfa36ee200..356f48cf58 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -275,35 +275,35 @@ END SUBROUTINE colm_mpas_initialize_from_namelist #if defined(GridRiverLakeFlow) && defined(MPAS_EMBEDDED_COLM) SUBROUTINE colm_mpas_check_embedded_riverlake(ierr) USE MOD_Namelist, only: DEF_USE_SEDIMENT - USE MOD_SPMD_Task, only: p_np_glb, p_is_master + USE MOD_SPMD_Task, only: p_np_glb, p_is_root integer, intent(out) :: ierr ierr = 0 IF (DEF_USE_SEDIMENT) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded mode does not support GridRiverLakeSediment yet.' write(*,'(A)') 'Set DEF_USE_SEDIMENT = .false. until sediment routing is migrated to MPAS-owned rank decomposition.' ENDIF ierr = 1 RETURN ENDIF - IF (p_np_glb > 1 .and. p_is_master) THEN + IF (p_np_glb > 1 .and. p_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded GridRiverLakeFlow uses MPAS communicator ranks for distributed routing.' - write(*,'(A)') 'CoLM standalone master/io/worker MPI pools and replicated full-river-network fallback are disabled.' + write(*,'(A)') 'CoLM standalone MPI process pools and replicated full-river-network fallback are disabled.' ENDIF END SUBROUTINE colm_mpas_check_embedded_riverlake #endif SUBROUTINE colm_mpas_check_embedded_io(ierr) USE MOD_Namelist, only: DEF_HIST_FREQ, DEF_HIST_WriteBack, USE_SITE_HistWriteBack - USE MOD_SPMD_Task, only: p_is_master + USE MOD_SPMD_Task, only: p_is_root integer, intent(out) :: ierr ierr = 0 USE_SITE_HistWriteBack = .false. IF ((trim(adjustl(DEF_HIST_FREQ)) /= 'none' .and. trim(adjustl(DEF_HIST_FREQ)) /= 'NONE') .or. & DEF_HIST_WriteBack) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded mode currently writes fluxes through MPAS streams.' write(*,'(A)') 'Disable CoLM DEF_HIST_FREQ/DEF_HIST_WriteBack; CoLM restart files remain supported for patch/PFT state.' write(*,'(A)') 'CoLM USE_SITE_HistWriteBack is forced off in MPAS embedded mode.' diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 index 79e7a927ba..ae192eb1c3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 @@ -201,7 +201,7 @@ SUBROUTINE allocate_1D_BGCFluxes IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -380,7 +380,7 @@ SUBROUTINE deallocate_1D_BGCFluxes () USE MOD_SPMD_Task USE MOD_LandPatch - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -564,7 +564,7 @@ SUBROUTINE set_1D_BGCFluxes(Values, Nan) real(r8),intent(in) :: Nan - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 index 2cfbe3eda7..916ac32018 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 @@ -343,7 +343,7 @@ SUBROUTINE allocate_1D_BGCPFTFluxes USE MOD_LandPFT IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN ! bgc variables @@ -665,7 +665,7 @@ SUBROUTINE deallocate_1D_BGCPFTFluxes USE MOD_SPMD_Task USE MOD_LandPFT - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN ! bgc variables @@ -991,7 +991,7 @@ SUBROUTINE set_1D_BGCPFTFluxes(Values, Nan) real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN ! bgc variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 index 4bc5a1675f..b91c4e7301 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 @@ -414,7 +414,7 @@ SUBROUTINE allocate_BGCPFTimeVariables () USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN ! bgc variables allocate (leafc_p (numpft)); leafc_p (:) = spval @@ -1949,7 +1949,7 @@ SUBROUTINE deallocate_BGCPFTimeVariables () USE MOD_SPMD_Task USE MOD_LandPFT - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN ! bgc variables deallocate (leafc_p ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 index d0a115898f..6d9d9605a9 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 @@ -147,7 +147,7 @@ SUBROUTINE allocate_BGCTimeInvariants () USE MOD_LandPatch, only: numpatch IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN ! bgc variables @@ -346,7 +346,7 @@ SUBROUTINE WRITE_BGCTimeInvariants (file_restart) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN #if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) CALL ncio_create_file (file_restart) @@ -464,7 +464,7 @@ SUBROUTINE deallocate_BGCTimeInvariants () ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 index 2f97a68863..ec3ee02169 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 @@ -323,7 +323,7 @@ SUBROUTINE allocate_BGCTimeVariables IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -619,7 +619,7 @@ SUBROUTINE deallocate_BGCTimeVariables () ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 index eaa662796f..70ab7e8981 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 @@ -47,7 +47,7 @@ SUBROUTINE init_DA () ENDIF IF (DEF_DA_SM) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN print *, '[CoLM-DA] initialize surface soil moisture & temperature data assimilation.' ENDIF CALL init_DA_SM () @@ -89,7 +89,7 @@ SUBROUTINE run_DA (idate, deltim, dolai, doalb, dosst, oro) !############################################################################# ! Generate ensemble members !############################################################################# - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! store the non-DA trajectory z_sno_noda = z_sno @@ -323,7 +323,7 @@ SUBROUTINE run_DA (idate, deltim, dolai, doalb, dosst, oro) ! data assimilation IF (DEF_DA_SM) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN print *, '[CoLM-DA] Start surface soil moisture & temperature data assimilation.' ENDIF CALL mpi_barrier (p_comm_glb, p_err) @@ -335,7 +335,7 @@ SUBROUTINE run_DA (idate, deltim, dolai, doalb, dosst, oro) ! Use ensemble mean for important outputs !############################################################################# IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO np = 1, numpatch ! important state variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 index 676449c40d..9aa4ef5a8d 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 @@ -341,7 +341,7 @@ SUBROUTINE init_DA_SM() !############################################################################# ! Makeup derived types of pixel index for fast access at each worker !############################################################################# - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (counter (pixel%nlat)) counter(:) = 0 @@ -403,7 +403,7 @@ SUBROUTINE init_DA_SM() ! find the located pixel of each site & broadcast workers allocate (iloc_synop (2, nsite)) iloc_synop(:,:) = -1 - IF (p_is_master) THEN + IF (p_is_root) THEN DO i = 1, nsite numpxl_lat = count(pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i)) numpxl_lon = count(pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i)) @@ -425,7 +425,7 @@ SUBROUTINE init_DA_SM() ENDIF ENDDO ENDIF - CALL mpi_bcast(iloc_synop, 2*nsite, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(iloc_synop, 2*nsite, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -434,7 +434,7 @@ SUBROUTINE init_DA_SM() !############################################################################# ! Assess the patch id of pixel that cover each observation at each worker !############################################################################# - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! count the number of site that located in pixels of each worker counter_worker_nsite = 0 DO i = 1, nsite @@ -474,11 +474,11 @@ SUBROUTINE init_DA_SM() ! send the number of site and their patch id to master #ifdef USEMPI mesg = (/p_iam_glb, counter_worker_nsite/) - CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (counter_worker_nsite > 0) THEN CALL mpi_send(ip_worker, 2*counter_worker_nsite, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -496,12 +496,12 @@ SUBROUTINE init_DA_SM() !############################################################################# ! Generate look-up-table (contains the worker/patch id of each site) at master !############################################################################# - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (synop_lut (2, nsite)) synop_lut(:,:) = -1 #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) @@ -712,7 +712,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF ! print info of observations - IF (p_is_master) THEN + IF (p_is_root) THEN IF (has_smap_obs) THEN print *, '[CoLM-DA] Have SMAP observations:', trim(file_smap) ELSE @@ -735,7 +735,7 @@ SUBROUTINE run_DA_SM(idate, deltim) !############################################################################# IF (DEF_DA_SM_SMAP) THEN ! allocate memory for ensemble predicted observations at patch (for DA or no DA) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN IF (allocated(pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) IF (allocated(pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) @@ -757,7 +757,7 @@ SUBROUTINE run_DA_SM(idate, deltim) IF (DEF_DA_SM_FY) THEN ! allocate memory for ensemble predicted observations at patch (for DA or no DA) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN IF (allocated(pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) IF (allocated(pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) @@ -793,7 +793,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ! Calculate predicted observations using observation operator !############################################################################# ! forward model (for no DA) - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! SMAP forward model DO np = 1, numpatch lat_p = patchlatr(np)*180/pi @@ -824,7 +824,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF ! forward model for ensemble DA - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (DEF_DA_SM_SMAP) THEN IF (DEF_DA_ENS_NUM > 1) THEN DO iens = 1, DEF_DA_ENS_NUM @@ -919,18 +919,18 @@ SUBROUTINE run_DA_SM(idate, deltim) IF (has_smap_obs) THEN ! prepare filter for land patches allocate (filter(numpatch)) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype <= 2 ENDIF ENDIF ! calculate area of each patch across world grid - IF (p_is_io) CALL allocate_block_data(grid_smap, area_smap_wgrid) + IF (p_is_active) CALL allocate_block_data(grid_smap, area_smap_wgrid) CALL mg2p_smap%get_sumarea(area_smap_wgrid, filter) ! mapping predicted observations from patch to world grid - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data(grid_smap, pred_smap_tb_h_wgrid_ens, DEF_DA_ENS_NUM) CALL allocate_block_data(grid_smap, pred_smap_tb_v_wgrid_ens, DEF_DA_ENS_NUM) ENDIF @@ -939,7 +939,7 @@ SUBROUTINE run_DA_SM(idate, deltim) deallocate (filter) ! crop the predicted observations - IF (p_is_io) THEN + IF (p_is_active) THEN allocate (iloc(num_smap_obs)) pred_smap_tb_h_ogrid_ens = -9999.0 pred_smap_tb_v_ogrid_ens = -9999.0 @@ -972,16 +972,16 @@ SUBROUTINE run_DA_SM(idate, deltim) ! send data from io to masters #ifdef USEMPI smesg = (/p_iam_glb, ndata/) - CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (ndata > 0) THEN - CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) allocate (dtemp(ndata, DEF_DA_ENS_NUM)) dtemp = pred_smap_tb_h_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) dtemp = pred_smap_tb_v_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data + 1, p_comm_glb, p_err) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data + 1, p_comm_glb, p_err) deallocate (dtemp) ENDIF #endif @@ -991,10 +991,10 @@ SUBROUTINE run_DA_SM(idate, deltim) ! broadcast from master to all workers #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN pred_smap_tb_h_ogrid_ens = -9999.0 pred_smap_tb_v_ogrid_ens = -9999.0 - DO ip = 0, p_np_io - 1 + DO ip = 0, p_np_active - 1 CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) ndata = rmesg(2) @@ -1014,8 +1014,8 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF ENDDO ENDIF - CALL mpi_bcast(pred_smap_tb_h_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast(pred_smap_tb_v_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(pred_smap_tb_h_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast(pred_smap_tb_v_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) #endif ENDIF ENDIF @@ -1024,18 +1024,18 @@ SUBROUTINE run_DA_SM(idate, deltim) IF (has_fy3d_obs) THEN ! prepare filter for land patches allocate (filter(numpatch)) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype <= 2 ENDIF ENDIF ! calculate area of each patch across world grid - IF (p_is_io) CALL allocate_block_data(grid_fy3d, area_fy3d_wgrid) + IF (p_is_active) CALL allocate_block_data(grid_fy3d, area_fy3d_wgrid) CALL mg2p_fy3d%get_sumarea(area_fy3d_wgrid, filter) ! mapping predicted observations from patch to world grid - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_h_wgrid_ens, DEF_DA_ENS_NUM) CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_v_wgrid_ens, DEF_DA_ENS_NUM) ENDIF @@ -1044,7 +1044,7 @@ SUBROUTINE run_DA_SM(idate, deltim) deallocate (filter) ! crop the predicted observations - IF (p_is_io) THEN + IF (p_is_active) THEN allocate (iloc(num_fy3d_obs)) pred_fy3d_tb_h_ogrid_ens = -9999.0 pred_fy3d_tb_v_ogrid_ens = -9999.0 @@ -1077,16 +1077,16 @@ SUBROUTINE run_DA_SM(idate, deltim) ! send data from io to masters #ifdef USEMPI smesg = (/p_iam_glb, ndata/) - CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (ndata > 0) THEN - CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) allocate (dtemp(ndata, DEF_DA_ENS_NUM)) dtemp = pred_fy3d_tb_h_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) dtemp = pred_fy3d_tb_v_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, mpi_tag_data + 1, p_comm_glb, p_err) + CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data + 1, p_comm_glb, p_err) deallocate (dtemp) ENDIF #endif @@ -1096,10 +1096,10 @@ SUBROUTINE run_DA_SM(idate, deltim) ! broadcast from master to all workers #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN pred_fy3d_tb_h_ogrid_ens = -9999.0 pred_fy3d_tb_v_ogrid_ens = -9999.0 - DO ip = 0, p_np_io - 1 + DO ip = 0, p_np_active - 1 CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) ndata = rmesg(2) @@ -1119,8 +1119,8 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF ENDDO ENDIF - CALL mpi_bcast(pred_fy3d_tb_h_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast(pred_fy3d_tb_v_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(pred_fy3d_tb_h_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast(pred_fy3d_tb_v_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) #endif ENDIF ENDIF @@ -1129,15 +1129,15 @@ SUBROUTINE run_DA_SM(idate, deltim) ! crop corresponding index (worker id and patch id) of each observation IF (has_synop_obs) THEN synop_idx(:,:) = -1 - IF (p_is_master) THEN + IF (p_is_root) THEN synop_idx = synop_lut(:, synop_id) ENDIF - CALL mpi_bcast(synop_idx, 2*num_synop_obs, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(synop_idx, 2*num_synop_obs, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ENDIF ! recount the number of observations at each worker IF (has_synop_obs) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN counter_worker_nsite = 0 DO i = 1, num_synop_obs IF (synop_idx(1, i) == p_iam_glb) THEN @@ -1149,7 +1149,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ! allocate memory for worker IF (has_synop_obs) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (counter_worker_nsite > 0) THEN IF (allocated(tref_ens_worker)) deallocate (tref_ens_worker) IF (allocated(qref_ens_worker)) deallocate (qref_ens_worker) @@ -1163,7 +1163,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ! crop observations at each worker according index & send to master IF (has_synop_obs) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN counter_worker_nsite = 0 DO i = 1, num_synop_obs IF (synop_idx(1, i) == p_iam_glb) THEN @@ -1177,12 +1177,12 @@ SUBROUTINE run_DA_SM(idate, deltim) #ifdef USEMPI ! send the number of site and their patch id to master mesg = (/p_iam_glb, counter_worker_nsite/) - CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (counter_worker_nsite > 0) THEN - CALL mpi_send(tref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send(qref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send(site_id_worker, counter_worker_nsite, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(tref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(qref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(site_id_worker, counter_worker_nsite, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -1196,9 +1196,9 @@ SUBROUTINE run_DA_SM(idate, deltim) IF (has_synop_obs) THEN qref_ens_o = spval tref_ens_o = spval - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) ndata = mesg(2) @@ -1222,8 +1222,8 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDDO #endif ENDIF - CALL mpi_bcast(qref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast(tref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast(qref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast(tref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_root, p_comm_glb, p_err) ENDIF ENDIF #endif @@ -1234,7 +1234,7 @@ SUBROUTINE run_DA_SM(idate, deltim) has_DA = .false. IF (has_smap_obs .or. has_fy3d_obs .or. has_synop_obs) THEN ! for grid data assimilation - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO np = 1, numpatch !############################################################################# @@ -1607,7 +1607,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ! Calculate ensemble brightness temperature after DA for diagnostic !############################################################################# IF (has_DA) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (DEF_DA_SM_SMAP) THEN IF (DEF_DA_ENS_NUM > 1) THEN DO iens = 1, DEF_DA_ENS_NUM diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 index 78c7ada569..90d2e17f9a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 @@ -99,7 +99,7 @@ SUBROUTINE init_DA_GRACE () CALL retrieve_yymm_from_days (time_real8(itime), obsyear(itime), obsmonth(itime)) ENDDO - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Assimilate GRACE data at' DO itime = 1, nobstime write(*,*) obsyear(itime), obsmonth(itime) @@ -113,7 +113,7 @@ SUBROUTINE init_DA_GRACE () CALL mg2p_grace%build_arealweighted (grid_grace, landelm) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN allocate (lwe_obs_this (numelm)) allocate (err_obs_this (numelm)) @@ -138,11 +138,11 @@ SUBROUTINE init_DA_GRACE () ENDIF ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN CALL elm_patch%build (landelm, landpatch, use_frac = .true.) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN rnofmask = patchtype == 0 IF (DEF_forcing%has_missing_value) THEN @@ -157,7 +157,7 @@ SUBROUTINE init_DA_GRACE () nac_grace_this = 0 nac_grace_prev = 0 - IF (p_is_worker) THEN + IF (p_is_compute) THEN wat_this_m (:) = 0. rnof_acc_this_m(:) = 0. rnof_this_m (:) = 0. @@ -205,13 +205,13 @@ SUBROUTINE run_DA_GRACE (idate, deltim) is_obs_time = any((obsyear == idate(1)) .and. (obsmonth == month)) - IF (p_is_master) THEN + IF (p_is_root) THEN IF (is_obs_time) THEN write(*,*) 'GRACE at this time.' ENDIF ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (has_prev_grace_obs) THEN @@ -243,7 +243,7 @@ SUBROUTINE run_DA_GRACE (idate, deltim) itime = findloc_ud((obsyear == idate(1)) .and. (obsmonth == month)) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_grace, f_grace_lwe) CALL allocate_block_data (grid_grace, f_grace_err) CALL ncio_read_block_time (file_grace, 'lwe_thickness', grid_grace, itime, f_grace_lwe) @@ -253,7 +253,7 @@ SUBROUTINE run_DA_GRACE (idate, deltim) CALL mg2p_grace%grid2pset (f_grace_lwe, lwe_obs_this) CALL mg2p_grace%grid2pset (f_grace_err, err_obs_this) - IF (p_is_worker) THEN + IF (p_is_compute) THEN lwe_obs_this = lwe_obs_this * 10.0 ! from cm to mm err_obs_this = err_obs_this * 10.0 ! from cm to mm @@ -271,7 +271,7 @@ SUBROUTINE run_DA_GRACE (idate, deltim) .or. ((idate(1) == year_prev+1) .and. (month_prev == 12) .and. (month == 1)))) & THEN - ! write(sid,'(I0)') p_iam_worker + ! write(sid,'(I0)') p_iam_compute ! logfile = 'log/grace_log_' // trim(sid) // '.txt' ! open(12, file = trim(logfile), position = 'append') @@ -366,7 +366,7 @@ SUBROUTINE run_DA_GRACE (idate, deltim) ENDIF IF (isendofmonth(idate, deltim)) THEN - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN nextmonth = mod(month+1,12)+1 fslp_k = fslp_k_mon(nextmonth,:) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 index 26854ea42b..eb71a15d76 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 @@ -46,7 +46,7 @@ SUBROUTINE allocate_1D_DAFluxes () IMPLICIT NONE !----------------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate ( fsena_ens (DEF_DA_ENS_NUM, numpatch) ) ; fsena_ens (:,:) = spval allocate ( lfevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; lfevpa_ens (:,:) = spval @@ -71,7 +71,7 @@ SUBROUTINE deallocate_1D_DAFluxes() USE MOD_LandPatch !----------------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN deallocate ( fsena_ens ) deallocate ( lfevpa_ens ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 index 5ae2abecc7..c082dcdfac 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 @@ -175,7 +175,7 @@ SUBROUTINE allocate_DATimeVariables() IMPLICIT NONE !----------------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (z_sno_noda (maxsnl+1:0, numpatch)); z_sno_noda (:,:) = spval allocate (dz_sno_noda (maxsnl+1:0, numpatch)); dz_sno_noda (:,:) = spval @@ -324,7 +324,7 @@ SUBROUTINE deallocate_DATimeVariables() IMPLICIT NONE !----------------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN deallocate (z_sno_noda ) deallocate (dz_sno_noda ) @@ -490,7 +490,7 @@ SUBROUTINE WRITE_DATimeVariables (idate, lc_year, site, dir_restart) write(cyear,'(i4.4)') lc_year write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) ENDIF #ifdef USEMPI @@ -584,7 +584,7 @@ SUBROUTINE READ_DATimeVariables (idate, lc_year, site, dir_restart) CALL mpi_barrier(p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write (*, *) 'Loading DA Time Variables ...' END IF @@ -639,7 +639,7 @@ SUBROUTINE READ_DATimeVariables (idate, lc_year, site, dir_restart) CALL check_DATimeVariables #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write (*, *) 'Loading DA Time Variables done.' END IF @@ -660,7 +660,7 @@ SUBROUTINE check_DATimeVariables () #ifdef USEMPI CALL mpi_barrier(p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write (*, *) 'Checking DA Time Variables ...' END IF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 index 28942ac5f0..95a5ec9b43 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 @@ -9,7 +9,7 @@ MODULE MOD_Catch_BasinNetwork !-------------------------------------------------------------------------------- USE MOD_Pixelset - USE MOD_WorkerPushData + USE MOD_ComputePushData IMPLICIT NONE ! -- instances -- @@ -30,11 +30,11 @@ MODULE MOD_Catch_BasinNetwork integer, allocatable :: bsn2lake (:) integer, allocatable :: bsn2resv (:) - type(worker_pushdata_type) :: push_elm2bsn - type(worker_pushdata_type) :: push_bsn2elm + type(compute_pushdata_type) :: push_elm2bsn + type(compute_pushdata_type) :: push_bsn2elm - type(worker_pushdata_type) :: push_elmhru2bsnhru - type(worker_pushdata_type) :: push_bsnhru2elmhru + type(compute_pushdata_type) :: push_elmhru2bsnhru + type(compute_pushdata_type) :: push_bsnhru2elmhru CONTAINS @@ -81,14 +81,14 @@ SUBROUTINE build_basin_network () basin_file = DEF_CatchmentMesh_data ! read in parameters from file. - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (basin_file, 'basin_downstream', basindown) totalnumbasin = size(basindown) ENDIF #ifdef USEMPI ! divide basins into groups and assign to workers - IF (p_is_master) THEN + IF (p_is_root) THEN IF (ncio_var_exist(basin_file, 'weightbasin')) THEN CALL ncio_read_serial (basin_file, 'weightbasin', wtbsn) @@ -165,7 +165,7 @@ SUBROUTINE build_basin_network () iwrkdsp = -1 DO i = 1, numrivmth - nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_worker) + nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) IF (nwrk_rs(i) > 1) THEN nave_rs(i) = nb_rs(i) / nwrk_rs(i) @@ -189,8 +189,8 @@ SUBROUTINE build_basin_network () allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 - allocate (wt_wrk (0:p_np_worker-1)); wt_wrk(:) = 0 - allocate (nb_wrk (0:p_np_worker-1)); nb_wrk(:) = 0 + allocate (wt_wrk (0:p_np_compute-1)); wt_wrk(:) = 0 + allocate (nb_wrk (0:p_np_compute-1)); nb_wrk(:) = 0 allocate (orderbsn(totalnumbasin)) orderbsn(b_up2down) = (/(i, i = 1, totalnumbasin)/) @@ -219,7 +219,7 @@ SUBROUTINE build_basin_network () iworker = iwrk_rs(iriv) IF (nups_all(i) <= nave_rs(iriv)-nb_wrk(iworker)) THEN - addrbasin(i) = p_address_worker(iworker) + addrbasin(i) = p_address_compute(iworker) nb_wrk(iworker) = nb_wrk(iworker) + nups_all(i) IF (nb_wrk(iworker) == nave_rs(iriv)) THEN @@ -240,9 +240,9 @@ SUBROUTINE build_basin_network () ithis = ithis - 1 ENDIF ELSE - iworker = minloc(wt_wrk(iwrkdsp+1:p_np_worker-1), dim=1) + iwrkdsp + iworker = minloc(wt_wrk(iwrkdsp+1:p_np_compute-1), dim=1) + iwrkdsp - addrbasin(i) = p_address_worker(iworker) + addrbasin(i) = p_address_compute(iworker) wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv) ithis = ithis - 1 @@ -267,21 +267,21 @@ SUBROUTINE build_basin_network () ! send basin index to workers - IF (p_is_master) THEN + IF (p_is_root) THEN allocate(basinindex (totalnumbasin)) basinindex = (/(i, i = 1, totalnumbasin)/) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 - nbasin = count(addrbasin == p_address_worker(iworker)) - CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_worker(iworker), mpi_tag_mesg, p_comm_glb, p_err) + nbasin = count(addrbasin == p_address_compute(iworker)) + CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_compute(iworker), mpi_tag_mesg, p_comm_glb, p_err) IF (nbasin > 0) THEN allocate (bindex (nbasin)) - bindex = pack(basinindex, mask = (addrbasin == p_address_worker(iworker))) - CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_worker(iworker), & + bindex = pack(basinindex, mask = (addrbasin == p_address_compute(iworker))) + CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) deallocate (bindex) @@ -291,14 +291,14 @@ SUBROUTINE build_basin_network () deallocate (basinindex) - ELSEIF (p_is_worker) THEN + ELSEIF (p_is_compute) THEN - CALL mpi_recv (numbasin, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (numbasin, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_stat, p_err) IF (numbasin > 0) THEN allocate (basinindex (numbasin)) - CALL mpi_recv (basinindex, numbasin, MPI_INTEGER, p_address_master, & + CALL mpi_recv (basinindex, numbasin, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -313,20 +313,20 @@ SUBROUTINE build_basin_network () #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN allocate (elmindex (numelm)) elmindex = landelm%eindex ENDIF ENDIF - CALL build_worker_pushdata (numelm, elmindex, numbasin, basinindex, push_elm2bsn) - CALL build_worker_pushdata (numbasin, basinindex, numelm, elmindex, push_bsn2elm) + CALL build_compute_pushdata (numelm, elmindex, numbasin, basinindex, push_elm2bsn) + CALL build_compute_pushdata (numbasin, basinindex, numelm, elmindex, push_bsn2elm) - CALL build_worker_pushdata_subset ( & + CALL build_compute_pushdata_subset ( & numelm, numbasin, push_elm2bsn, elm_hru, push_elmhru2bsnhru, basin_hru, numbsnhru) - CALL build_worker_pushdata_subset ( & + CALL build_compute_pushdata_subset ( & numbasin, numelm, push_bsn2elm, basin_hru, push_bsnhru2elmhru) #ifdef USEMPI @@ -337,7 +337,7 @@ SUBROUTINE build_basin_network () IF (allocated(elmindex )) deallocate(elmindex ) - IF (p_is_master) THEN + IF (p_is_root) THEN lake_info_file = DEF_CatchmentMesh_data CALL ncio_read_serial (lake_info_file, 'lake_id', all_lake_id) @@ -372,7 +372,7 @@ SUBROUTINE build_basin_network () ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numbasin > 0) THEN allocate (lake_id (numbasin)); lake_id (:) = 0 allocate (lake_type (numbasin)); lake_type(:) = 0 @@ -382,25 +382,25 @@ SUBROUTINE build_basin_network () #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_worker) THEN + IF (p_is_compute) THEN mesg = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, & + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) IF (numbasin > 0) THEN CALL mpi_send (basinindex, numbasin, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) CALL mpi_recv (lake_id, numbasin, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) CALL mpi_recv (lake_type, numbasin, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF - IF (p_is_master) THEN - DO iworker = 0, p_np_worker-1 + IF (p_is_root) THEN + DO iworker = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -436,7 +436,7 @@ SUBROUTINE build_basin_network () lake_type = all_lake_type(basinindex) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numbasin > 0) THEN numlake = count(lake_type /= 0) numresv = count(lake_type >= 2) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 index b300f8bbec..fdcff24d4c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 @@ -69,7 +69,7 @@ SUBROUTINE hillslope_flow (dt) logical, allocatable :: mask(:) real(r8) :: srfbsn, dvol, nextl, nexta, nextv, ddep - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ibasin = 1, numbasin diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 index bded7bd9d9..63f3802660 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 @@ -74,7 +74,7 @@ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) hillslope_network_file = DEF_CatchmentMesh_data - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (hillslope_network_file, 'basin_numhru', nhru_all) CALL ncio_read_serial (hillslope_network_file, 'hydrounit_index', indxhru) @@ -87,18 +87,18 @@ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) ENDIF - IF (p_is_master) maxnumhru = size(indxhru,1) - IF (p_is_master) nfldstep = size(fldstep,1) + IF (p_is_root) maxnumhru = size(indxhru,1) + IF (p_is_root) nfldstep = size(fldstep,1) #ifdef USEMPI - CALL mpi_bcast (maxnumhru, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (nfldstep, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (maxnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (nfldstep, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #endif hillslope_network => null() - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - DO iworker = 1, p_np_worker + DO iworker = 1, p_np_compute CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) nrecv = mesg(2) @@ -218,48 +218,48 @@ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) #endif ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef USEMPI mesg(1:2) = (/p_iam_glb, ne/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (ne > 0) THEN CALL mpi_send (elmindex, ne, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) allocate (nhru_in_bsn (ne)) CALL mpi_recv (nhru_in_bsn, ne, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (indxhru (maxnumhru,ne)) CALL mpi_recv (indxhru, maxnumhru*ne, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (handhru (maxnumhru,ne)) CALL mpi_recv (handhru, maxnumhru*ne, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (elvahru (maxnumhru,ne)) CALL mpi_recv (elvahru, maxnumhru*ne, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (plenhru (maxnumhru,ne)) CALL mpi_recv (plenhru, maxnumhru*ne, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (lfachru (maxnumhru,ne)) CALL mpi_recv (lfachru, maxnumhru*ne, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (nexthru (maxnumhru,ne)) CALL mpi_recv (nexthru, maxnumhru*ne, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (fldstep (nfldstep,maxnumhru,ne)) CALL mpi_recv (fldstep, nfldstep*maxnumhru*ne, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF #endif @@ -352,7 +352,7 @@ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_master) write(*,'(A)') 'Read hillslope network information done.' + IF (p_is_root) write(*,'(A)') 'Read hillslope network information done.' CALL mpi_barrier (p_comm_glb, p_err) #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 index 84454ec069..b773a0d304 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 @@ -61,7 +61,7 @@ SUBROUTINE hist_basin_init IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numbsnhru > 0) THEN allocate (a_wdsrf_bsnhru (numbsnhru)) allocate (a_veloc_bsnhru (numbsnhru)) @@ -130,7 +130,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) real(r8), allocatable :: varhist(:) integer :: i - IF (p_is_master) THEN + IF (p_is_root) THEN i = len_trim (file_hist) DO WHILE (file_hist(i:i) /= '_') @@ -171,7 +171,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numhru > 0) THEN allocate (a_wdsrf_hru (numhru)) allocate (a_veloc_hru (numhru)) @@ -187,13 +187,13 @@ SUBROUTINE hist_basin_out (file_hist, idate) ! ----- water depth in basin ----- IF (DEF_hist_vars%riv_height) THEN - IF ((p_is_worker) .and. allocated(a_wdsrf_bsn)) THEN + IF ((p_is_compute) .and. allocated(a_wdsrf_bsn)) THEN WHERE(a_wdsrf_bsn /= spval) a_wdsrf_bsn = a_wdsrf_bsn / nac_basin END WHERE ENDIF - CALL worker_push_data (push_bsn2elm, a_wdsrf_bsn, a_wdsrf_elm, spval) + CALL compute_push_data (push_bsn2elm, a_wdsrf_bsn, a_wdsrf_elm, spval) CALL vector_gather_and_write (& a_wdsrf_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_wdsrf_bsn', 'basin', & @@ -202,13 +202,13 @@ SUBROUTINE hist_basin_out (file_hist, idate) ! ----- water velocity in river ----- IF (DEF_hist_vars%riv_veloct) THEN - IF ((p_is_worker) .and. allocated(a_veloc_riv)) THEN + IF ((p_is_compute) .and. allocated(a_veloc_riv)) THEN WHERE(a_veloc_riv /= spval) a_veloc_riv = a_veloc_riv / nac_basin END WHERE ENDIF - CALL worker_push_data (push_bsn2elm, a_veloc_riv, a_veloc_elm, spval) + CALL compute_push_data (push_bsn2elm, a_veloc_riv, a_veloc_elm, spval) CALL vector_gather_and_write (& a_veloc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_veloc_riv', 'basin', & @@ -217,13 +217,13 @@ SUBROUTINE hist_basin_out (file_hist, idate) ! ----- discharge in river ----- IF (DEF_hist_vars%discharge) THEN - IF ((p_is_worker) .and. allocated(a_discharge)) THEN + IF ((p_is_compute) .and. allocated(a_discharge)) THEN WHERE(a_discharge /= spval) a_discharge = a_discharge / nac_basin END WHERE ENDIF - CALL worker_push_data (push_bsn2elm, a_discharge, a_dschg_elm, spval) + CALL compute_push_data (push_bsn2elm, a_discharge, a_dschg_elm, spval) CALL vector_gather_and_write (& a_dschg_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_discharge', 'basin', & @@ -231,23 +231,23 @@ SUBROUTINE hist_basin_out (file_hist, idate) ENDIF ! ----- number of time steps for each basin ----- - CALL worker_push_data (push_bsn2elm, ntacc_bsn, ntacc_elm, spval) + CALL compute_push_data (push_bsn2elm, ntacc_bsn, ntacc_elm, spval) CALL vector_gather_and_write (& ntacc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'timesteps', 'basin', & itime_in_file, 'Number of accumulated timesteps for each basin', '-') - IF (p_is_worker .and. (numbasin > 0)) ntacc_bsn(:) = 0. + IF (p_is_compute .and. (numbasin > 0)) ntacc_bsn(:) = 0. ! ----- water depth in hydro unit ----- IF (DEF_hist_vars%wdsrf_hru) THEN - IF ((p_is_worker) .and. allocated(a_wdsrf_bsnhru)) THEN + IF ((p_is_compute) .and. allocated(a_wdsrf_bsnhru)) THEN WHERE(a_wdsrf_bsnhru /= spval) a_wdsrf_bsnhru = a_wdsrf_bsnhru / nac_basin END WHERE ENDIF - CALL worker_push_data (push_bsnhru2elmhru, a_wdsrf_bsnhru, a_wdsrf_hru, spval) + CALL compute_push_data (push_bsnhru2elmhru, a_wdsrf_bsnhru, a_wdsrf_hru, spval) CALL vector_gather_and_write (& a_wdsrf_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_wdsrf_hru', 'hydrounit', & @@ -256,13 +256,13 @@ SUBROUTINE hist_basin_out (file_hist, idate) ! ----- water velocity in hydro unit ----- IF (DEF_hist_vars%veloc_hru) THEN - IF ((p_is_worker) .and. allocated(a_veloc_bsnhru)) THEN + IF ((p_is_compute) .and. allocated(a_veloc_bsnhru)) THEN WHERE(a_veloc_bsnhru /= spval) a_veloc_bsnhru = a_veloc_bsnhru / nac_basin END WHERE ENDIF - CALL worker_push_data (push_bsnhru2elmhru, a_veloc_bsnhru, a_veloc_hru, spval) + CALL compute_push_data (push_bsnhru2elmhru, a_veloc_bsnhru, a_veloc_hru, spval) CALL vector_gather_and_write (& a_veloc_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_veloc_hru', 'hydrounit', & @@ -271,7 +271,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) ! ----- subsurface water flow between elements ----- IF (DEF_hist_vars%xsubs_bsn) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN WHERE(a_xsubs_elm /= spval) a_xsubs_elm = a_xsubs_elm / nac_basin END WHERE @@ -284,7 +284,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) ! ----- subsurface water flow between hydro units ----- IF (DEF_hist_vars%xsubs_hru) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN WHERE(a_xsubs_hru /= spval) a_xsubs_hru = a_xsubs_hru / nac_basin END WHERE @@ -303,7 +303,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) IF (DEF_hist_vars%volresv) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN WHERE (a_volresv /= spval) a_volresv = a_volresv / nac_basin @@ -313,7 +313,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) CALL reservoir_gather_var (a_volresv, varhist) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_write_serial_time (file_hist_basin, 'volresv', & itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) IF (itime_in_file == 1) THEN @@ -326,7 +326,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) IF (DEF_hist_vars%qresv_in) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN WHERE (a_qresv_in /= spval) a_qresv_in = a_qresv_in / nac_basin @@ -336,7 +336,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) CALL reservoir_gather_var (a_qresv_in, varhist) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_write_serial_time (file_hist_basin, 'qresv_in', & itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) IF (itime_in_file == 1) THEN @@ -349,7 +349,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) IF (DEF_hist_vars%qresv_out) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN WHERE (a_qresv_out /= spval) a_qresv_out = a_qresv_out / nac_basin @@ -359,7 +359,7 @@ SUBROUTINE hist_basin_out (file_hist, idate) CALL reservoir_gather_var (a_qresv_out, varhist) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_write_serial_time (file_hist_basin, 'qresv_out', & itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) IF (itime_in_file == 1) THEN @@ -398,7 +398,7 @@ SUBROUTINE FLUSH_acc_fluxes_basin () USE MOD_Vars_Global, only: spval IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN nac_basin = 0 @@ -432,7 +432,7 @@ SUBROUTINE accumulate_fluxes_basin IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN nac_basin = nac_basin + 1 diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 index fa250d80ef..6f078ba38c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 @@ -60,7 +60,7 @@ SUBROUTINE lateral_flow_init (lc_year) integer :: ip, ie, ipxl - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (patcharea (numpatch)) @@ -81,7 +81,7 @@ SUBROUTINE lateral_flow_init (lc_year) landarea = 0. IF (numpatch > 0) landarea = sum(patcharea) #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, landarea, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, landarea, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) #endif ENDIF @@ -131,7 +131,7 @@ SUBROUTINE lateral_flow (year, deltime) real(r8), allocatable :: wdsrf_bsnhru_p(:), delvol(:) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! a) The smallest unit in surface lateral flow (including hillslope flow and river-lake flow) ! is HRU and the main prognostic variable is "wdsrf_bsnhru" (surface water depth). @@ -169,7 +169,7 @@ SUBROUTINE lateral_flow (year, deltime) IF (numresv > 0) qresv_out_ta(:) = 0. ENDIF - CALL worker_push_data (push_elmhru2bsnhru, wdsrf_hru, wdsrf_bsnhru, spval) + CALL compute_push_data (push_elmhru2bsnhru, wdsrf_hru, wdsrf_bsnhru, spval) #ifdef CoLMDEBUG IF (numbsnhru > 0) THEN @@ -229,7 +229,7 @@ SUBROUTINE lateral_flow (year, deltime) ENDIF ! update surface water depth on patches - CALL worker_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval) + CALL compute_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval) DO i = 1, numhru wdsrf_hru(i) = max(0., wdsrf_hru(i)) ps = hru_patch%substt(i) @@ -369,12 +369,12 @@ SUBROUTINE lateral_flow (year, deltime) ENDIF #ifdef USEMPI - CALL mpi_allreduce (maxdvol, maxdvol_g, 1, MPI_REAL8, MPI_MAX, p_comm_worker, p_err) + CALL mpi_allreduce (maxdvol, maxdvol_g, 1, MPI_REAL8, MPI_MAX, p_comm_compute, p_err) IF (maxdvol < maxdvol_g) THEN bidmax = 0 ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_worker, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, sumdvol, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, sumdvol, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) #else maxdvol_g = maxdvol #endif @@ -419,7 +419,7 @@ SUBROUTINE lateral_flow (year, deltime) ENDIF #ifdef RangeCheck - IF (p_is_worker .and. (p_iam_worker == 0)) THEN + IF (p_is_compute .and. (p_iam_compute == 0)) THEN write(*,'(/,A)') 'Checking Lateral Flow Variables ...' write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', & dt_average/nsubstep, ' seconds' @@ -434,7 +434,7 @@ SUBROUTINE lateral_flow (year, deltime) CALL check_vector_data ('Subsurface bt patch [m/s]', xsubs_pch) #ifdef CoLMDEBUG - IF (p_is_worker) THEN + IF (p_is_compute) THEN dtolw = 0 toldis = 0 @@ -449,11 +449,11 @@ SUBROUTINE lateral_flow (year, deltime) ENDIF #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, tolwat, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, toldis, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, tolwat, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, toldis, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) #endif - IF (p_iam_worker == 0) THEN + IF (p_iam_compute == 0) THEN write(*,'(A,E9.2,A,I0,A,E9.2,A)') 'River system error: max ', maxdvol_g, & ' m^3 in river mouth ', bidmax, ', total ', sumdvol, ' m^3' write(*,'(A,F12.2,A,ES8.1,A,ES10.3,A)') 'Total surface water error: ', dtolw, & @@ -463,9 +463,9 @@ SUBROUTINE lateral_flow (year, deltime) dtolw = 0 IF (numpatch > 0) dtolw = sum(patcharea * xwsub) / 1.e3 * deltime #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) #endif - IF (p_iam_worker == 0) THEN + IF (p_iam_compute == 0) THEN write(*,'(A,F12.2,A,ES8.1,A)') 'Total ground water error: ', dtolw, & ' m^3 in area ', landarea, ' m^2' ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 index bfed81b8bb..b5e2328aca 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 @@ -80,7 +80,7 @@ SUBROUTINE reservoir_init ( ) integer :: nbasin, ibasin, irsv, nrecv, nrsv, iloc - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN @@ -112,7 +112,7 @@ SUBROUTINE reservoir_init ( ) ENDIF ! read in parameters from file. - IF (p_is_master) THEN + IF (p_is_root) THEN basin_info_file = DEF_CatchmentMesh_data CALL ncio_read_serial (basin_info_file, 'lake_id', lake_id_basin ) @@ -174,7 +174,7 @@ SUBROUTINE reservoir_init ( ) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN allocate (resv_bsn_id (numresv)) resv_bsn_id = pack(basinindex, lake_type >= 2) @@ -182,8 +182,8 @@ SUBROUTINE reservoir_init ( ) ENDIF #ifdef USEMPI - IF (p_is_master) THEN - DO iworker = 0, p_np_worker-1 + IF (p_is_root) THEN + DO iworker = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -223,29 +223,29 @@ SUBROUTINE reservoir_init ( ) ENDDO ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN mesg(1:2) = (/p_iam_glb, numresv/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numresv > 0) THEN CALL mpi_send (resv_bsn_id, numresv, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) CALL mpi_recv (volresv_total, numresv, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) CALL mpi_recv (qresv_mean, numresv, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) CALL mpi_recv (qresv_flood, numresv, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) CALL mpi_recv (dam_build_year, numresv, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) CALL mpi_recv (dam_height, numresv, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF #else @@ -258,7 +258,7 @@ SUBROUTINE reservoir_init ( ) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ibasin = 1, numbasin IF (lake_type(ibasin) >= 2) THEN @@ -282,7 +282,7 @@ SUBROUTINE reservoir_init ( ) ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN nrsv = count(lake_id2typ(lake_id_basin) >= 2) @@ -310,15 +310,15 @@ SUBROUTINE reservoir_init ( ) ENDIF #ifdef USEMPI - CALL mpi_bcast (numresv_uniq, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (numresv_uniq, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) IF (numresv_uniq > 0) THEN - IF (.not. p_is_master) allocate (resv_hylak_id (numresv_uniq)) - CALL mpi_bcast (resv_hylak_id, numresv_uniq, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (resv_hylak_id (numresv_uniq)) + CALL mpi_bcast (resv_hylak_id, numresv_uniq, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN allocate (resv_loc2glb (numresv)) DO ibasin = 1, numbasin @@ -408,7 +408,7 @@ SUBROUTINE reservoir_gather_var (varin, varout) IF (numresv_uniq == 0) RETURN - IF (p_is_worker) THEN + IF (p_is_compute) THEN varout(:) = spval DO irsv = 1, numresv IF (varin(irsv) /= spval) THEN @@ -420,17 +420,17 @@ SUBROUTINE reservoir_gather_var (varin, varout) ENDIF ENDDO #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (varall (numresv_uniq,0:p_np_worker-1)) + IF (p_iam_compute == p_root) THEN + allocate (varall (numresv_uniq,0:p_np_compute-1)) ENDIF CALL mpi_gather (varout, numresv_uniq, MPI_REAL8, & - varall, numresv_uniq, MPI_REAL8, p_root, p_comm_worker, p_err) + varall, numresv_uniq, MPI_REAL8, p_root, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN DO irsv = 1, numresv_uniq - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (iworker /= p_root) THEN IF (varall(irsv,iworker) /= spval) THEN IF (varout(irsv) /= spval) THEN @@ -449,12 +449,12 @@ SUBROUTINE reservoir_gather_var (varin, varout) ENDIF #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - CALL mpi_send (varout, numresv_uniq, MPI_REAL8, p_address_master, & + IF (p_iam_compute == p_root) THEN + CALL mpi_send (varout, numresv_uniq, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_err) ENDIF - IF (p_is_master) THEN - CALL mpi_recv (varout, numresv_uniq, MPI_REAL8, p_address_worker(p_root), & + IF (p_is_root) THEN + CALL mpi_recv (varout, numresv_uniq, MPI_REAL8, p_address_compute(p_root), & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 index 3a88650e29..f0c83ba2d8 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 @@ -77,7 +77,7 @@ SUBROUTINE river_lake_flow (year, dt) logical, allocatable :: hmask(:), bsnfilter(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! update water depth in basin by aggregating water depths in patches DO i = 1, numbasin @@ -572,7 +572,7 @@ SUBROUTINE river_lake_flow (year, dt) IF (numbasin > 0) wdsrf_bsn_prev(:) = wdsrf_bsn(:) #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, ntimestep_riverlake, 1, MPI_INTEGER, MPI_MAX, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, ntimestep_riverlake, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err) #endif IF (allocated(wdsrf_bsn_ds )) deallocate(wdsrf_bsn_ds ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 index a24cc0d483..4b84d4347a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 @@ -157,7 +157,7 @@ SUBROUTINE river_lake_network_init (patcharea) river_file = DEF_CatchmentMesh_data ! step 1: read in parameters from file. - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (river_file, 'lake_id', all_lake_id) @@ -189,9 +189,9 @@ SUBROUTINE river_lake_network_init (patcharea) ENDIF #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -239,38 +239,38 @@ SUBROUTINE river_lake_network_init (patcharea) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN mesg(1:2) = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numbasin > 0) THEN CALL mpi_send (basinindex, numbasin, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) allocate (riverdown (numbasin)) CALL mpi_recv (riverdown, numbasin, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (to_lake (numbasin)) CALL mpi_recv (to_lake, numbasin, MPI_LOGICAL, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (riverlen (numbasin)) CALL mpi_recv (riverlen, numbasin, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (riverelv (numbasin)) CALL mpi_recv (riverelv, numbasin, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (riverdpth (numbasin)) CALL mpi_recv (riverdpth, numbasin, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (basinelv (numbasin)) CALL mpi_recv (basinelv, numbasin, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF @@ -291,11 +291,11 @@ SUBROUTINE river_lake_network_init (patcharea) #ifdef USEMPI ! get address of basins - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -314,20 +314,20 @@ SUBROUTINE river_lake_network_init (patcharea) ENDDO - ELSEIF (p_is_worker) THEN + ELSEIF (p_is_compute) THEN mesg(1:2) = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numbasin > 0) THEN - CALL mpi_send (basinindex, numbasin, MPI_INTEGER, p_address_master, & + CALL mpi_send (basinindex, numbasin, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_err) ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (addrdown (totalnumbasin)) allocate (is_link (totalnumbasin)); is_link = .false. @@ -359,16 +359,16 @@ SUBROUTINE river_lake_network_init (patcharea) ENDIF - CALL mpi_bcast (nblink_all, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (nblink_all, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) IF (nblink_all > 0) THEN IF (.not. allocated(linkbindex_all)) allocate (linkbindex_all (nblink_all)) IF (.not. allocated(linkrivmth_all)) allocate (linkrivmth_all (nblink_all)) - CALL mpi_bcast (linkbindex_all, nblink_all, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (linkrivmth_all, nblink_all, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (linkbindex_all, nblink_all, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (linkrivmth_all, nblink_all, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numbasin > 0) THEN allocate (basin_sorted (numbasin)) @@ -434,9 +434,9 @@ SUBROUTINE river_lake_network_init (patcharea) ENDIF IF (riversystem /= -1) THEN - CALL mpi_comm_split (p_comm_worker, riversystem, p_iam_worker, p_comm_rivsys, p_err) + CALL mpi_comm_split (p_comm_compute, riversystem, p_iam_compute, p_comm_rivsys, p_err) ELSE - CALL mpi_comm_split (p_comm_worker, MPI_UNDEFINED, p_iam_worker, p_comm_rivsys, p_err) + CALL mpi_comm_split (p_comm_compute, MPI_UNDEFINED, p_iam_compute, p_comm_rivsys, p_err) ENDIF #endif @@ -505,7 +505,7 @@ SUBROUTINE river_lake_network_init (patcharea) CALL hillslope_network_init (numbasin, basinindex, hillslope_basin) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) allocate (lake_id_elm (numelm)) IF (numhru > 0) allocate (lakedepth_hru (numhru)) @@ -533,10 +533,10 @@ SUBROUTINE river_lake_network_init (patcharea) ENDIF - CALL worker_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) - CALL worker_push_data (push_bsn2elm, lakedown_id_bsn, lakedown_id_elm, -9999) + CALL compute_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) + CALL compute_push_data (push_bsn2elm, lakedown_id_bsn, lakedown_id_elm, -9999) - IF (p_is_worker) THEN + IF (p_is_compute) THEN unitarea_hru = 0. lakedepth_hru = 0. @@ -563,10 +563,10 @@ SUBROUTINE river_lake_network_init (patcharea) ENDDO ENDIF - CALL worker_push_data (push_elm2bsn, lakeoutlet_elm, lakeoutlet_bsn, spval) + CALL compute_push_data (push_elm2bsn, lakeoutlet_elm, lakeoutlet_bsn, spval) - CALL worker_push_data (push_elmhru2bsnhru, unitarea_hru, unitarea_bsnhru, spval) - CALL worker_push_data (push_elmhru2bsnhru, lakedepth_hru, lakedepth_bsnhru, spval) + CALL compute_push_data (push_elmhru2bsnhru, unitarea_hru, unitarea_bsnhru, spval) + CALL compute_push_data (push_elmhru2bsnhru, lakedepth_hru, lakedepth_bsnhru, spval) IF (allocated (lake_id_elm )) deallocate (lake_id_elm ) IF (allocated (lakedepth_hru )) deallocate (lakedepth_hru ) @@ -575,7 +575,7 @@ SUBROUTINE river_lake_network_init (patcharea) IF (allocated (lakeoutlet_elm )) deallocate (lakeoutlet_elm ) IF (allocated (unitarea_hru )) deallocate (unitarea_hru ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numbasin > 0) THEN @@ -730,7 +730,7 @@ SUBROUTINE river_lake_network_init (patcharea) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_master) write(*,'(A)') 'Building river network information done.' + IF (p_is_root) write(*,'(A)') 'Building river network information done.' CALL mpi_barrier (p_comm_glb, p_err) #endif @@ -751,7 +751,7 @@ SUBROUTINE pull_from_downstream (datain, dataout, bsnfilter) integer :: i, ibasin real(r8), allocatable :: datalink(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef USEMPI IF (riversystem /= -1) THEN @@ -800,7 +800,7 @@ SUBROUTINE push_to_downstream (datain, dataout, bsnfilter) real(r16), allocatable :: datalink(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef USEMPI IF (numbsnlink > 0) THEN @@ -885,7 +885,7 @@ SUBROUTINE calc_riverdepth_from_runoff (patcharea) CALL mg2p_rnof%build_arealweighted (grid_rnof, landelm) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_rnof, f_rnof) CALL ncio_read_block (file_rnof, 'ro', grid_rnof, f_rnof) @@ -900,13 +900,13 @@ SUBROUTINE calc_riverdepth_from_runoff (patcharea) ENDDO ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) allocate (bsnrnof (numelm)) ENDIF CALL mg2p_rnof%grid2pset (f_rnof, bsnrnof) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN bsnrnof = bsnrnof /24.0/3600.0 ! from m/day to m/s DO i = 1, numelm @@ -922,19 +922,19 @@ SUBROUTINE calc_riverdepth_from_runoff (patcharea) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_worker) THEN + IF (p_is_compute) THEN mesg = (/p_iam_glb, numelm/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numelm > 0) THEN - CALL mpi_send (bsnrnof, numelm, MPI_REAL8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (bsnrnof, numelm, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (bsnrnof (totalnumelm)) - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -946,7 +946,7 @@ SUBROUTINE calc_riverdepth_from_runoff (patcharea) CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) - bsnrnof(elm_data_address(p_itis_worker(isrc))%val) = rcache + bsnrnof(elm_data_address(p_itis_compute(isrc))%val) = rcache deallocate (rcache) ENDIF @@ -959,7 +959,7 @@ SUBROUTINE calc_riverdepth_from_runoff (patcharea) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (nups_riv (totalnumelm)) allocate (iups_riv (totalnumelm)) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 index 8876b6392d..7bbcf51834 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 @@ -59,7 +59,7 @@ SUBROUTINE subsurface_network_init (patcharea) USE MOD_LandElm USE MOD_LandPatch USE MOD_ElementNeighbour - USE MOD_WorkerPushData, only: worker_push_data + USE MOD_ComputePushData, only: compute_push_data USE MOD_Catch_BasinNetwork, only: push_bsn2elm USE MOD_Catch_RiverLakeNetwork, only: lake_id, riverdpth USE MOD_Vars_TimeInvariants, only: patchtype, lakedepth @@ -79,7 +79,7 @@ SUBROUTINE subsurface_network_init (patcharea) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN allocate (eindex (numelm)) eindex = landelm%eindex @@ -90,15 +90,15 @@ SUBROUTINE subsurface_network_init (patcharea) IF (allocated(eindex)) deallocate (eindex) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) allocate (lake_id_elm (numelm)) IF (numelm > 0) allocate (riverdpth_elm(numelm)) IF (numelm > 0) allocate (lakedepth_elm(numelm)) IF (numelm > 0) allocate (wdsrf_elm (numelm)) - CALL worker_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) - CALL worker_push_data (push_bsn2elm, riverdpth, riverdpth_elm, spval) + CALL compute_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) + CALL compute_push_data (push_bsn2elm, riverdpth, riverdpth_elm, spval) DO ielm = 1, numelm IF (lake_id_elm(ielm) <= 0) THEN @@ -246,7 +246,7 @@ SUBROUTINE subsurface_flow (deltime) real(r8) :: w_sum_before, w_sum_after, errblc - IF (p_is_worker) THEN + IF (p_is_compute) THEN xsubs_elm(:) = 0. ! subsurface lateral flow between element basins xsubs_hru(:) = 0. ! subsurface lateral flow between hydrological response units @@ -644,7 +644,7 @@ SUBROUTINE subsurface_flow (deltime) ENDIF ! Exchange between soil water and aquifer. - IF (p_is_worker) THEN + IF (p_is_compute) THEN sp_zi(0) = 0. sp_zi(1:nl_soil) = zi_soi(1:nl_soil) * 1000.0 ! from meter to mm diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 index b75974f46f..3eab827aab 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 @@ -49,7 +49,7 @@ SUBROUTINE allocate_1D_CatchFluxes USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (xsubs_pch (numpatch)) ; xsubs_pch (:) = spval diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 index a65744277d..37b9af417f 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 @@ -50,7 +50,7 @@ SUBROUTINE allocate_CatchTimeVariables USE MOD_LandHRU, only: numhru IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN allocate (veloc_elm (numelm)) @@ -89,16 +89,16 @@ SUBROUTINE READ_CatchTimeVariables (file_restart) character(len=*), intent(in) :: file_restart CALL vector_read_and_scatter (file_restart, veloc_elm, numelm, 'veloc_riv', elm_data_address) - CALL worker_push_data (push_elm2bsn, veloc_elm, veloc_riv, spval) + CALL compute_push_data (push_elm2bsn, veloc_elm, veloc_riv, spval) CALL vector_read_and_scatter (file_restart, wdsrf_elm_prev, numelm, 'wdsrf_bsn_prev', elm_data_address) - CALL worker_push_data (push_elm2bsn, wdsrf_elm_prev, wdsrf_bsn_prev, spval) + CALL compute_push_data (push_elm2bsn, wdsrf_elm_prev, wdsrf_bsn_prev, spval) CALL vector_read_and_scatter (file_restart, veloc_hru, numhru, 'veloc_hru', hru_data_address) - CALL worker_push_data (push_elmhru2bsnhru, veloc_hru, veloc_bsnhru, spval) + CALL compute_push_data (push_elmhru2bsnhru, veloc_hru, veloc_bsnhru, spval) CALL vector_read_and_scatter (file_restart, wdsrf_hru_prev, numhru, 'wdsrf_hru_prev', hru_data_address) - CALL worker_push_data (push_elmhru2bsnhru, wdsrf_hru_prev, wdsrf_bsnhru_prev, spval) + CALL compute_push_data (push_elmhru2bsnhru, wdsrf_hru_prev, wdsrf_bsnhru_prev, spval) END SUBROUTINE READ_CatchTimeVariables @@ -116,7 +116,7 @@ SUBROUTINE WRITE_CatchTimeVariables (file_restart) integer :: iwork character(len=*), intent(in) :: file_restart - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_create_file (trim(file_restart)) CALL ncio_define_dimension(file_restart, 'basin', totalnumelm) CALL ncio_define_dimension(file_restart, 'hydrounit', totalnumhru) @@ -133,19 +133,19 @@ SUBROUTINE WRITE_CatchTimeVariables (file_restart) 'long_name', 'index of hydrological units inside basin') ENDIF - CALL worker_push_data (push_bsn2elm, veloc_riv, veloc_elm, spval) + CALL compute_push_data (push_bsn2elm, veloc_riv, veloc_elm, spval) CALL vector_gather_and_write (& veloc_elm, numelm, totalnumelm, elm_data_address, file_restart, 'veloc_riv', 'basin') - CALL worker_push_data (push_bsn2elm, wdsrf_bsn_prev, wdsrf_elm_prev, spval) + CALL compute_push_data (push_bsn2elm, wdsrf_bsn_prev, wdsrf_elm_prev, spval) CALL vector_gather_and_write (& wdsrf_elm_prev, numelm, totalnumelm, elm_data_address, file_restart, 'wdsrf_bsn_prev', 'basin') - CALL worker_push_data (push_bsnhru2elmhru, veloc_bsnhru, veloc_hru, spval) + CALL compute_push_data (push_bsnhru2elmhru, veloc_bsnhru, veloc_hru, spval) CALL vector_gather_and_write (& veloc_hru, numhru, totalnumhru, hru_data_address, file_restart, 'veloc_hru', 'hydrounit') - CALL worker_push_data (push_bsnhru2elmhru, wdsrf_bsnhru_prev, wdsrf_hru_prev, spval) + CALL compute_push_data (push_bsnhru2elmhru, wdsrf_bsnhru_prev, wdsrf_hru_prev, spval) CALL vector_gather_and_write (& wdsrf_hru_prev, numhru, totalnumhru, hru_data_address, file_restart, 'wdsrf_hru_prev', 'hydrounit') diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 index 6cb7781616..c872b4ebf4 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 @@ -30,7 +30,7 @@ SUBROUTINE write_catch_parameters file_parameters = trim(DEF_dir_output) // '/' // trim(DEF_CASE_NAME) // '/catch_parameters.nc' - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_create_file (trim(file_parameters)) CALL ncio_define_dimension(file_parameters, 'hydrounit', totalnumhru) @@ -43,7 +43,7 @@ SUBROUTINE write_catch_parameters 'long_name', 'index of hydrological units inside basin') ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numhru > 0) allocate (hrupara (numhru)) ENDIF @@ -52,7 +52,7 @@ SUBROUTINE write_catch_parameters write(slev,'(i1.1)') ilev ! sand - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO i = 1, numhru ps = hru_patch%substt(i) pe = hru_patch%subend(i) @@ -64,7 +64,7 @@ SUBROUTINE write_catch_parameters hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_sand_l'//slev, 'hydrounit') ! clay - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO i = 1, numhru ps = hru_patch%substt(i) pe = hru_patch%subend(i) @@ -76,7 +76,7 @@ SUBROUTINE write_catch_parameters hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_clay_l'//slev, 'hydrounit') ! organic matter - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO i = 1, numhru ps = hru_patch%substt(i) pe = hru_patch%subend(i) @@ -88,7 +88,7 @@ SUBROUTINE write_catch_parameters hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_om_l'//slev, 'hydrounit') ! silt - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO i = 1, numhru ps = hru_patch%substt(i) pe = hru_patch%subend(i) @@ -102,7 +102,7 @@ SUBROUTINE write_catch_parameters - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO i = 1, numhru ps = hru_patch%substt(i) pe = hru_patch%subend(i) @@ -113,7 +113,7 @@ SUBROUTINE write_catch_parameters CALL vector_gather_and_write (& hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'lulc_igbp', 'hydrounit') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numhru > 0) hrupara(:) = spval DO ielm = 1, numelm IF (lake_id_elm(ielm) <= 0) THEN @@ -130,12 +130,12 @@ SUBROUTINE write_catch_parameters CALL vector_gather_and_write (& hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_length', 'hydrounit') - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_put_attr (file_parameters, 'slope_length', 'units', 'm') CALL ncio_put_attr (file_parameters, 'slope_length', 'missing_value', spval) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numhru > 0) hrupara(:) = spval DO ielm = 1, numelm IF (lake_id_elm(ielm) <= 0) THEN @@ -152,12 +152,12 @@ SUBROUTINE write_catch_parameters CALL vector_gather_and_write (& hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'elevation', 'hydrounit') - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_put_attr (file_parameters, 'elevation', 'units', 'm') CALL ncio_put_attr (file_parameters, 'elevation', 'missing_value', spval) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numhru > 0) hrupara(:) = spval DO ielm = 1, numelm IF (lake_id_elm(ielm) <= 0) THEN @@ -180,7 +180,7 @@ SUBROUTINE write_catch_parameters CALL vector_gather_and_write (& hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_ratio', 'hydrounit') - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_put_attr (file_parameters, 'slope_ratio', 'units', '-') CALL ncio_put_attr (file_parameters, 'slope_ratio', 'missing_value', spval) ENDIF @@ -192,7 +192,7 @@ SUBROUTINE write_catch_parameters IF (DEF_Reservoir_Method > 0) THEN IF (numresv_uniq > 0) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_define_dimension (file_parameters, 'reservoir', numresv_uniq) CALL ncio_write_serial (file_parameters, 'resv_hylak_id' , resv_hylak_id, 'reservoir') CALL ncio_put_attr (file_parameters, 'resv_hylak_id' , 'long_name', & @@ -202,19 +202,19 @@ SUBROUTINE write_catch_parameters allocate (varpara (numresv_uniq)) CALL reservoir_gather_var (volresv_total, varpara) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_write_serial (file_parameters, 'volresv_total', varpara, 'reservoir', 1) CALL ncio_put_attr (file_parameters, 'volresv_total', 'units', 'm^3') ENDIF CALL reservoir_gather_var (qresv_mean, varpara) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_write_serial (file_parameters, 'qresv_mean', varpara, 'reservoir', 1) CALL ncio_put_attr (file_parameters, 'qresv_mean', 'units', 'm^3/s') ENDIF CALL reservoir_gather_var (qresv_flood, varpara) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_write_serial (file_parameters, 'qresv_flood', varpara, 'reservoir', 1) CALL ncio_put_attr (file_parameters, 'qresv_flood', 'units', 'm^3/s') ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 index 42cd6c7dcf..8897bb1f3c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 @@ -117,7 +117,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) neighbour_file = DEF_ElementNeighbour_file - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (neighbour_file, 'num_neighbour', nnball ) CALL ncio_read_serial (neighbour_file, 'idx_neighbour', idxnball) CALL ncio_read_serial (neighbour_file, 'len_border' , lenbdall) @@ -129,14 +129,14 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) #ifdef USEMPI - CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (addrelement (size(nnball))) addrelement(:) = -1 - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -183,7 +183,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN allocate (eindex (numelm)) @@ -192,23 +192,23 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) #ifdef USEMPI mesg(1:2) = (/p_iam_glb, numelm/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numelm > 0) THEN CALL mpi_send (eindex, numelm, MPI_INTEGER8, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) allocate (nnball (numelm)) CALL mpi_recv (nnball, numelm, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (idxnball (maxnnb,numelm)) CALL mpi_recv (idxnball, maxnnb*numelm, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (lenbdall (maxnnb,numelm)) CALL mpi_recv (lenbdall, maxnnb*numelm, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF #else allocate (icache1 (numelm)) @@ -255,8 +255,8 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) #endif #ifdef USEMPI - IF (p_is_master) THEN - DO iwork = 0, p_np_worker-1 + IF (p_is_root) THEN + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -282,7 +282,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numelm > 0) THEN allocate (elm_sorted (numelm)) @@ -320,25 +320,25 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) #ifdef USEMPI mesg(1:2) = (/p_iam_glb, nnbinq/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (nnbinq > 0) THEN CALL mpi_send (idxinq(1:nnbinq), nnbinq, MPI_INTEGER8, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) allocate (addrinq (nnbinq)) CALL mpi_recv (addrinq, nnbinq, MPI_INTEGER, & - p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF IF (nnbinq > 0) allocate(mask (nnbinq)) - allocate (recvaddr (0:p_np_worker-1)) - DO iwork = 0, p_np_worker-1 + allocate (recvaddr (0:p_np_compute-1)) + DO iwork = 0, p_np_compute-1 IF (nnbinq > 0) THEN - mask = (addrinq == p_address_worker(iwork)) + mask = (addrinq == p_address_compute(iwork)) ndata = count(mask) ELSE ndata = 0 @@ -361,7 +361,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & nnbinq, idxinq(1:nnbinq)) - iwork = p_itis_worker(addrinq(iloc)) + iwork = p_itis_compute(addrinq(iloc)) iloc1 = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & recvaddr(iwork)%ndata, recvaddr(iwork)%glbindex) @@ -371,8 +371,8 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) ENDDO ENDDO - allocate (sendaddr (0:p_np_worker-1)) - DO iwork = 0, p_np_worker-1 + allocate (sendaddr (0:p_np_compute-1)) + DO iwork = 0, p_np_compute-1 sendaddr(iwork)%ndata = 0 ENDDO @@ -385,7 +385,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) ENDDO ENDDO - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 IF (sendaddr(iwork)%ndata > 0) THEN allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) sendaddr(iwork)%ndata = 0 @@ -402,7 +402,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) ENDDO ENDDO - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 IF (sendaddr(iwork)%ndata > 0) THEN IF (sendaddr(iwork)%ndata < size(sendaddr(iwork)%glbindex)) THEN allocate (icache1 (sendaddr(iwork)%ndata)) @@ -417,7 +417,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) ENDIF ENDDO - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 IF (sendaddr(iwork)%ndata > 0) THEN allocate (sendaddr(iwork)%ielement (sendaddr(iwork)%ndata)) @@ -452,7 +452,7 @@ SUBROUTINE element_neighbour_init (patcharea, lc_year) lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/elevation_patches.nc' CALL ncio_read_vector (lndname, 'elevation_patches', landpatch, elv_patches) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ielm = 1, numelm nnb = elementneighbour(ielm)%nnb @@ -548,7 +548,7 @@ SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) type(pointer_real8_1d), allocatable :: sbuff(:), rbuff(:) integer :: iwork, ielm, inb, iloc - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ielm = 1, numelm DO inb = 1, elementneighbour(ielm)%nnb @@ -560,14 +560,14 @@ SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) ENDDO #ifdef USEMPI - CALL mpi_barrier (p_comm_worker, p_err) + CALL mpi_barrier (p_comm_compute, p_err) - allocate (smask (0:p_np_worker-1)) - allocate (req_send (0:p_np_worker-1)) - allocate (sbuff (0:p_np_worker-1)) + allocate (smask (0:p_np_compute-1)) + allocate (req_send (0:p_np_compute-1)) + allocate (sbuff (0:p_np_compute-1)) smask(:) = .false. - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 IF (sendaddr(iwork)%ndata > 0) THEN smask(iwork) = .true. @@ -575,23 +575,23 @@ SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) sbuff(iwork)%val = vec_in(sendaddr(iwork)%ielement) CALL mpi_isend(sbuff(iwork)%val, sendaddr(iwork)%ndata, MPI_REAL8, & - p_address_worker(iwork), 101, p_comm_glb, req_send(iwork), p_err) + p_address_compute(iwork), 101, p_comm_glb, req_send(iwork), p_err) ENDIF ENDDO - allocate (rmask (0:p_np_worker-1)) - allocate (req_recv (0:p_np_worker-1)) - allocate (rbuff (0:p_np_worker-1)) + allocate (rmask (0:p_np_compute-1)) + allocate (req_recv (0:p_np_compute-1)) + allocate (rbuff (0:p_np_compute-1)) rmask(:) = .false. - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 IF (recvaddr(iwork)%ndata > 0) THEN rmask(iwork) = .true. allocate (rbuff(iwork)%val (recvaddr(iwork)%ndata)) CALL mpi_irecv(rbuff(iwork)%val, recvaddr(iwork)%ndata, MPI_REAL8, & - p_address_worker(iwork), 101, p_comm_glb, req_recv(iwork), p_err) + p_address_compute(iwork), 101, p_comm_glb, req_recv(iwork), p_err) ENDIF ENDDO @@ -623,7 +623,7 @@ SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) IF (allocated(sbuff)) deallocate(sbuff) IF (allocated(rbuff)) deallocate(rbuff) - CALL mpi_barrier (p_comm_worker, p_err) + CALL mpi_barrier (p_comm_compute, p_err) #endif ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 index 0eae2905a6..9857bf3acf 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -70,7 +70,7 @@ SUBROUTINE reservoir_init ( ) parafile = DEF_ReservoirPara_file #ifndef MPAS_EMBEDDED_COLM - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (parafile, 'dam_GRAND_ID', dam_GRAND_ID) ENDIF @@ -81,7 +81,7 @@ SUBROUTINE reservoir_init ( ) CALL ncio_inquire_length (parafile, 'dam_seq', totalnumresv) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (ucat2resv (numucat)) ucat2resv = 0 @@ -144,38 +144,38 @@ SUBROUTINE reservoir_init ( ) ! with resv_global_index, so no master-side global address table is needed. #else #ifdef COLM_PARALLEL - IF (p_is_master) THEN + IF (p_is_root) THEN - allocate (resv_data_address (0:p_np_worker-1)) + allocate (resv_data_address (0:p_np_compute-1)) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN nresv = numresv ELSE CALL mpi_recv (nresv, 1, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + p_address_compute(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) ENDIF IF (nresv > 0) THEN allocate (resv_data_address(iworker)%val (nresv)) - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN resv_data_address(iworker)%val = resv_global_index(1:nresv) ELSE CALL mpi_recv (resv_data_address(iworker)%val, nresv, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF ENDDO ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN - CALL mpi_send (numresv, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (numresv, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numresv > 0) THEN - CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, p_address_master, & + CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -189,7 +189,7 @@ SUBROUTINE reservoir_init ( ) #endif #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN @@ -212,7 +212,7 @@ SUBROUTINE reservoir_init ( ) ENDIF #ifdef MPAS_EMBEDDED_COLM - IF (p_is_worker .and. (numresv > 0)) THEN + IF (p_is_compute .and. (numresv > 0)) THEN CALL ncio_read_indexed_serial (parafile, 'dam_year', resv_global_index(1:numresv), icache) dam_build_year = icache @@ -230,33 +230,33 @@ SUBROUTINE reservoir_init ( ) ENDIF #else CALL ncio_read_bcast_serial (parafile, 'dam_year', icache) - IF (p_is_worker .and. (numresv > 0)) THEN + IF (p_is_compute .and. (numresv > 0)) THEN dam_build_year = icache(resv_global_index(1:numresv)) ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_TotalVol_mcm', rcache) - IF (p_is_worker .and. (numresv > 0)) THEN + IF (p_is_compute .and. (numresv > 0)) THEN volresv_total = rcache(resv_global_index(1:numresv))*1.e6 ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_ConVol_mcm', rcache) - IF (p_is_worker .and. (numresv > 0)) THEN + IF (p_is_compute .and. (numresv > 0)) THEN volresv_normal = rcache(resv_global_index(1:numresv))*1.e6 ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_Qn', rcache) - IF (p_is_worker .and. (numresv > 0)) THEN + IF (p_is_compute .and. (numresv > 0)) THEN qresv_normal = rcache(resv_global_index(1:numresv)) ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_Qf', rcache) - IF (p_is_worker .and. (numresv > 0)) THEN + IF (p_is_compute .and. (numresv > 0)) THEN qresv_flood = rcache(resv_global_index(1:numresv)) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO irsv = 1, numresv volresv_emerg (irsv) = volresv_total(irsv) * 0.94 volresv_adjust(irsv) = volresv_total(irsv) * 0.77 diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index f82bd0f75d..a0b26850bf 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -44,7 +44,7 @@ SUBROUTINE grid_riverlake_flow_init () acctime_rnof_max = DEF_GRIDBASED_ROUTING_MAX_DT acctime_rnof = 0. - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! Allocate on all workers (zero-length if numucat/numpatch=0) ! to avoid passing unallocated arrays to assumed-shape MPI wrappers. allocate (acc_rnof_uc (numucat)) @@ -52,7 +52,7 @@ SUBROUTINE grid_riverlake_flow_init () ENDIF ! excluding (patchtype >= 99), virtual patches and those forcing missed - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (filter_rnof (numpatch)) IF (numpatch > 0) THEN filter_rnof = patchtype < 99 @@ -137,12 +137,12 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (rnof_gd (numinpm)) allocate (rnof_uc (numucat)) - CALL worker_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & + CALL compute_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & fillvalue = 0., filter = filter_rnof) IF (numinpm > 0) THEN @@ -151,7 +151,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) END WHERE ENDIF - CALL worker_push_data (push_inpm2ucat, rnof_gd, rnof_uc, & + CALL compute_push_data (push_inpm2ucat, rnof_gd, rnof_uc, & fillvalue = 0., mode = 'sum') IF (numucat > 0) THEN @@ -182,7 +182,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) allocate (prcp_uc (0)) ENDIF - CALL worker_remap_data_pset2grid (remap_patch2inpm, prcp_pch, prcp_gd, & + CALL compute_remap_data_pset2grid (remap_patch2inpm, prcp_pch, prcp_gd, & fillvalue = 0., filter = filter_rnof) IF (numinpm > 0) THEN @@ -191,7 +191,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) END WHERE ENDIF - CALL worker_push_data (push_inpm2ucat, prcp_gd, prcp_uc, & + CALL compute_push_data (push_inpm2ucat, prcp_gd, prcp_uc, & fillvalue = 0., mode = 'sum') ! Convert from area-integrated [mm/s * m²] back to flux density [mm/s]. @@ -220,7 +220,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) RETURN ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN @@ -310,9 +310,9 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ntimestep = ntimestep + 1 - CALL worker_push_data (push_next2ucat, wdsrf_ucat, wdsrf_next, fillvalue = spval) + CALL compute_push_data (push_next2ucat, wdsrf_ucat, wdsrf_next, fillvalue = spval) ! velocity in ocean or inland depression is assumed to be 0. - CALL worker_push_data (push_next2ucat, veloc_riv, veloc_next, fillvalue = 0.) + CALL compute_push_data (push_next2ucat, veloc_riv, veloc_next, fillvalue = 0.) dt_all(:) = min(dt_res(:), 60.) @@ -455,9 +455,9 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDDO - CALL worker_push_data (push_ups2ucat, hflux_fc, hflux_sumups, fillvalue = 0., mode = 'sum') - CALL worker_push_data (push_ups2ucat, mflux_fc, mflux_sumups, fillvalue = 0., mode = 'sum') - CALL worker_push_data (push_ups2ucat, zgrad_dn, zgrad_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, hflux_fc, hflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, mflux_fc, mflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, zgrad_dn, zgrad_sumups, fillvalue = 0., mode = 'sum') IF (numucat > 0) THEN WHERE (ucatfilter) @@ -501,8 +501,8 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDDO - CALL worker_push_data (push_ups2ucat, hflux_resv, hflux_sumups, fillvalue = 0., mode = 'sum') - CALL worker_push_data (push_ups2ucat, mflux_resv, mflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, hflux_resv, hflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, mflux_resv, mflux_sumups, fillvalue = 0., mode = 'sum') IF (numucat > 0) THEN WHERE (ucatfilter) @@ -681,20 +681,20 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #ifdef CoLMDEBUG #ifdef COLM_PARALLEL - IF (.not. p_is_worker) ntimestep = 0 + IF (.not. p_is_compute) ntimestep = 0 CALL mpi_allreduce (MPI_IN_PLACE, ntimestep, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err) - IF (.not. p_is_worker) totalvol_bef = 0. - IF (.not. p_is_worker) totalvol_aft = 0. - IF (.not. p_is_worker) totalrnof = 0. - IF (.not. p_is_worker) totaldis = 0. + IF (.not. p_is_compute) totalvol_bef = 0. + IF (.not. p_is_compute) totalvol_aft = 0. + IF (.not. p_is_compute) totalrnof = 0. + IF (.not. p_is_compute) totaldis = 0. CALL mpi_allreduce (MPI_IN_PLACE, totalvol_bef, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) CALL mpi_allreduce (MPI_IN_PLACE, totalvol_aft, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) CALL mpi_allreduce (MPI_IN_PLACE, totalrnof, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) CALL mpi_allreduce (MPI_IN_PLACE, totaldis, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(/,A)') 'Checking River Routing Flow ...' write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', acctime_rnof/ntimestep, ' seconds' write(*,'(A,ES8.1,A)') 'Total water before : ', totalvol_bef, ' m^3' @@ -706,7 +706,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #endif #ifdef GridRiverLakeSediment - IF (DEF_USE_SEDIMENT .and. p_is_worker) THEN + IF (DEF_USE_SEDIMENT .and. p_is_compute) THEN ! All workers must participate (MPI point-to-point inside push_data). ! fldfrc is now computed inside grid_sediment_calc from per-routing-period ! accumulators (sed_acc_floodarea), not from history-period averages. @@ -716,7 +716,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) acctime_rnof = 0. - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN acc_rnof_uc = 0. ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 index 23953f875a..67d569eb9c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 @@ -68,7 +68,7 @@ MODULE MOD_Grid_RiverLakeHist SUBROUTINE hist_grid_riverlake_init (histform) USE MOD_Block - USE MOD_WorkerPushData + USE MOD_ComputePushData USE MOD_HistGridded USE MOD_Grid_RiverLakeNetwork USE MOD_Grid_Reservoir, only: numresv @@ -87,7 +87,7 @@ SUBROUTINE hist_grid_riverlake_init (histform) ! ----- allocate memory for accumulative variables ----- - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (acctime_ucat (numucat)) allocate (a_wdsrf_ucat (numucat)) @@ -111,7 +111,7 @@ SUBROUTINE hist_grid_riverlake_init (histform) CALL flush_acc_fluxes_riverlake () ! ----- get longitude and latitude ----- - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (lon_ucat (griducat%nlon)) allocate (lat_ucat (griducat%nlat)) @@ -128,7 +128,7 @@ SUBROUTINE hist_grid_riverlake_init (histform) ENDIF ! ----- for auxiliary data ----- - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (vec_ucat (numucat )) allocate (vec_grid (numinpm )) allocate (vec_inpm (numinpm )) @@ -146,12 +146,12 @@ SUBROUTINE hist_grid_riverlake_init (histform) ENDIF ! ----- 1) area and filter covered by unit catchments ----- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) vec_ucat = 1. - CALL worker_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) - CALL worker_remap_data_grid2pset ( & + CALL compute_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) + CALL compute_remap_data_grid2pset ( & remap_patch2inpm, vec_grid, vec_patch, fillvalue = spval, mode = 'average') allocate (filter_ucat (numpatch)) @@ -166,20 +166,20 @@ SUBROUTINE hist_grid_riverlake_init (histform) ENDIF allocate (sum_grid_area (numinpm)) - CALL worker_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & + CALL compute_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & fillvalue = spval, filter = filter_ucat) - CALL worker_push_data (allreduce_inpm, vec_grid, sum_grid_area, fillvalue = spval) + CALL compute_push_data (allreduce_inpm, vec_grid, sum_grid_area, fillvalue = spval) ENDIF #ifndef MPAS_EMBEDDED_COLM IF (trim(histform) == 'Gridded') THEN - IF (p_is_io) CALL allocate_block_data (ghist, sumarea_ucat) + IF (p_is_active) CALL allocate_block_data (ghist, sumarea_ucat) CALL mp2g_hist%get_sumarea (sumarea_ucat, filter_ucat) ENDIF #endif ! ----- 2) area and filter covered by river mouth ----- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN WHERE (ucat_next == -9) vec_ucat = 1. @@ -188,8 +188,8 @@ SUBROUTINE hist_grid_riverlake_init (histform) END WHERE ENDIF - CALL worker_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) - CALL worker_remap_data_grid2pset (remap_patch2inpm, vec_grid, vec_patch, & + CALL compute_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) + CALL compute_remap_data_grid2pset (remap_patch2inpm, vec_grid, vec_patch, & fillvalue = spval, mode = 'average') allocate (filter_rivmth (numpatch)) @@ -205,17 +205,17 @@ SUBROUTINE hist_grid_riverlake_init (histform) allocate (sum_rmth_area (numinpm)) - CALL worker_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & + CALL compute_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & fillvalue = spval, filter = filter_rivmth) - CALL worker_push_data (allreduce_inpm, vec_grid, sum_rmth_area, fillvalue = spval) + CALL compute_push_data (allreduce_inpm, vec_grid, sum_rmth_area, fillvalue = spval) ENDIF ! ----- 3) area covered by input matrix ----- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) vec_ucat = 1. - CALL worker_push_data (push_ucat2inpm, vec_ucat, vec_inpm, & + CALL compute_push_data (push_ucat2inpm, vec_ucat, vec_inpm, & fillvalue = spval, mode = 'average') - CALL worker_remap_data_grid2pset (remap_patch2inpm, vec_inpm, vec_patch, & + CALL compute_remap_data_grid2pset (remap_patch2inpm, vec_inpm, vec_patch, & fillvalue = spval, mode = 'average') allocate (filter_inpm (numpatch)) @@ -226,32 +226,32 @@ SUBROUTINE hist_grid_riverlake_init (histform) #ifndef MPAS_EMBEDDED_COLM IF (trim(histform) == 'Gridded') THEN - IF (p_is_io) CALL allocate_block_data (ghist, sumarea_inpm) + IF (p_is_active) CALL allocate_block_data (ghist, sumarea_inpm) CALL mp2g_hist%get_sumarea (sumarea_inpm, filter_inpm) ENDIF #endif ! ----- 4) mask of unit catchments with all upstreams in simulation region ----- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (allups_mask_pch (numpatch)) ENDIF ENDIF - IF (p_is_worker) THEN - CALL worker_push_data (push_ucat2grid, allups_mask_ucat, vec_grid, fillvalue = spval) - CALL worker_remap_data_grid2pset ( & + IF (p_is_compute) THEN + CALL compute_push_data (push_ucat2grid, allups_mask_ucat, vec_grid, fillvalue = spval) + CALL compute_remap_data_grid2pset ( & remap_patch2inpm, vec_grid, allups_mask_pch, fillvalue = spval, mode = 'average') ENDIF #ifndef MPAS_EMBEDDED_COLM IF (trim(histform) == 'Gridded') THEN - IF (p_is_io) CALL allocate_block_data (ghist, allups_mask_grid) + IF (p_is_active) CALL allocate_block_data (ghist, allups_mask_grid) CALL mp2g_hist%pset2grid (allups_mask_pch, allups_mask_grid, spv = spval, msk = filter_ucat) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) @@ -281,7 +281,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i USE MOD_SPMD_Task USE MOD_Namelist USE MOD_NetCDFSerial - USE MOD_WorkerPushData + USE MOD_ComputePushData USE MOD_Grid_RiverLakeNetwork USE MOD_Grid_Reservoir USE MOD_Vector_ReadWrite @@ -309,7 +309,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i real(r8), allocatable :: a_floodfrc_inpm (:) ! flooded area fraction - IF (p_is_master) THEN + IF (p_is_root) THEN i = len_trim (file_hist) DO WHILE (file_hist(i:i) /= '_') i = i - 1 @@ -352,15 +352,15 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i longname = 'Mask of grids with all upstream located in simulation region', units = '100%') ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (acc_vec_grid (numinpm )) ENDIF IF (DEF_hist_vars%riv_height) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) a_wdsrf_ucat = a_wdsrf_ucat / acctime_ucat - CALL worker_push_data (push_ucat2grid, a_wdsrf_ucat, acc_vec_grid, fillvalue = spval) - CALL worker_remap_data_grid2pset ( remap_patch2inpm, acc_vec_grid, a_wdsrf_ucat_pch, & + CALL compute_push_data (push_ucat2grid, a_wdsrf_ucat, acc_vec_grid, fillvalue = spval) + CALL compute_remap_data_grid2pset ( remap_patch2inpm, acc_vec_grid, a_wdsrf_ucat_pch, & fillvalue = spval, mode = 'average') ENDIF @@ -371,10 +371,10 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i ENDIF IF (DEF_hist_vars%riv_veloct) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) a_veloc_riv = a_veloc_riv / acctime_ucat - CALL worker_push_data (push_ucat2grid, a_veloc_riv, acc_vec_grid, fillvalue = spval) - CALL worker_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_veloc_riv_pch, & + CALL compute_push_data (push_ucat2grid, a_veloc_riv, acc_vec_grid, fillvalue = spval) + CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_veloc_riv_pch, & fillvalue = spval, mode = 'average') ENDIF @@ -385,9 +385,9 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i ENDIF IF (DEF_hist_vars%discharge) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) a_discharge = a_discharge / acctime_ucat - CALL worker_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) + CALL compute_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) IF (numinpm > 0) THEN WHERE ((sum_grid_area /= spval) .and. (acc_vec_grid /= spval)) @@ -397,7 +397,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i END WHERE ENDIF - CALL worker_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_discharge_pch, & + CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_discharge_pch, & fillvalue = spval, mode = 'sum') ENDIF @@ -406,11 +406,11 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i file_hist_ucat, 'f_discharge', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & 'discharge in river and flood plain', 'm^3/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN WHERE (ucat_next /= -9) a_discharge = spval ENDIF - CALL worker_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) + CALL compute_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) IF (numinpm > 0) THEN WHERE ((sum_rmth_area /= spval) .and. (acc_vec_grid /= spval)) @@ -420,7 +420,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i END WHERE ENDIF - CALL worker_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_dis_rmth_pch, & + CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_dis_rmth_pch, & fillvalue = spval, mode = 'sum') ENDIF @@ -432,7 +432,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i IF (DEF_hist_vars%floodfrc) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) a_floodarea = a_floodarea / acctime_ucat @@ -447,10 +447,10 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i allocate (a_floodfrc_inpm (numinpm)) - CALL worker_push_data (push_ucat2inpm, a_floodfrc_ucat, a_floodfrc_inpm, & + CALL compute_push_data (push_ucat2inpm, a_floodfrc_ucat, a_floodfrc_inpm, & fillvalue = spval, mode = 'average') - CALL worker_remap_data_grid2pset (remap_patch2inpm, a_floodfrc_inpm, a_floodfrc_pch, & + CALL compute_remap_data_grid2pset (remap_patch2inpm, a_floodfrc_inpm, a_floodfrc_pch, & fillvalue = spval, mode = 'average') ENDIF @@ -469,7 +469,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i IF (DEF_Reservoir_Method > 0) THEN IF (totalnumresv > 0) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN IF (.not. fexists) THEN CALL ncio_define_dimension(file_hist_ucat, 'reservoir', totalnumresv) CALL ncio_write_serial (file_hist_ucat, 'resv_GRAND_ID' , dam_GRAND_ID, 'reservoir') @@ -478,7 +478,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i ENDIF IF (DEF_hist_vars%volresv) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN WHERE (acctime_resv > 0) a_volresv = a_volresv / acctime_resv @@ -493,7 +493,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i ENDIF IF (DEF_hist_vars%qresv_in) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN WHERE (acctime_resv > 0) a_qresv_in = a_qresv_in / acctime_resv @@ -508,7 +508,7 @@ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, i ENDIF IF (DEF_hist_vars%qresv_out) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numresv > 0) THEN WHERE (acctime_resv > 0) a_qresv_out = a_qresv_out / acctime_resv @@ -538,7 +538,7 @@ SUBROUTINE flush_acc_fluxes_riverlake () USE MOD_Grid_Reservoir, only: numresv IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN acctime_ucat (:) = 0. @@ -635,7 +635,7 @@ SUBROUTINE write_sediment_history (file_hist_ucat, itime_in_file_ucat) ! Allocate on ALL processes (zero-size on non-workers) to avoid ! passing unallocated arrays to vector_gather_map2grid_and_write - IF (p_is_worker .and. numucat > 0) THEN + IF (p_is_compute .and. numucat > 0) THEN allocate (a_sedcon_avg (nsed, numucat)) allocate (a_sedout_avg (nsed, numucat)) allocate (a_bedout_avg (nsed, numucat)) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index c70313d794..11f396c173 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -7,7 +7,7 @@ MODULE MOD_Grid_RiverLakeNetwork !-------------------------------------------------------------------------------- USE MOD_Grid - USE MOD_WorkerPushData + USE MOD_ComputePushData IMPLICIT NONE ! ----- River Lake network ----- @@ -36,11 +36,11 @@ MODULE MOD_Grid_RiverLakeNetwork integer, allocatable :: idmap_uc2gd (:,:) real(r8), allocatable :: area_uc2gd (:,:) - type(worker_remapdata_type) :: remap_patch2inpm - type(worker_pushdata_type) :: push_inpm2ucat - type(worker_pushdata_type) :: push_ucat2inpm - type(worker_pushdata_type) :: push_ucat2grid - type(worker_pushdata_type) :: allreduce_inpm + type(compute_remapdata_type) :: remap_patch2inpm + type(compute_pushdata_type) :: push_inpm2ucat + type(compute_pushdata_type) :: push_ucat2inpm + type(compute_pushdata_type) :: push_ucat2grid + type(compute_pushdata_type) :: allreduce_inpm ! ----- Part 2: between upstream and downstream unit catchments ----- integer, allocatable :: ucat_next (:) ! next unit catchment @@ -48,8 +48,8 @@ MODULE MOD_Grid_RiverLakeNetwork integer, allocatable :: ucat_ups (:,:) ! upstream unit catchments real(r8), allocatable :: wts_ups (:,:) - type(worker_pushdata_type) :: push_next2ucat - type(worker_pushdata_type) :: push_ups2ucat + type(compute_pushdata_type) :: push_next2ucat + type(compute_pushdata_type) :: push_ups2ucat ! ----- Part 3: river systems ----- integer :: numrivsys @@ -164,7 +164,7 @@ SUBROUTINE build_riverlake_network () ! read in parameters from file. parafile = DEF_UnitCatchment_file - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef MPAS_EMBEDDED_COLM CALL ncio_inquire_length (parafile, 'seq_next', totalnumucat) @@ -187,7 +187,7 @@ SUBROUTINE build_riverlake_network () ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (nups_nst (totalnumucat)) allocate (iups_nst (totalnumucat)) @@ -234,7 +234,7 @@ SUBROUTINE build_riverlake_network () #ifdef COLM_PARALLEL ! divide unit catchments into groups and assign to workers - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (wt_uc (totalnumucat)); wt_uc(:) = 1. @@ -265,7 +265,7 @@ SUBROUTINE build_riverlake_network () iwrkdsp = -1 DO i = 1, numrivmth - nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_worker) + nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) IF (nwrk_rs(i) > 1) THEN nave_rs(i) = nuc_rs(i) / nwrk_rs(i) @@ -289,8 +289,8 @@ SUBROUTINE build_riverlake_network () allocate (addr_ucat (totalnumucat)); addr_ucat(:) = -1 - allocate (wt_wrk (0:p_np_worker-1)); wt_wrk (:) = 0 - allocate (nuc_wrk(0:p_np_worker-1)); nuc_wrk(:) = 0 + allocate (wt_wrk (0:p_np_compute-1)); wt_wrk (:) = 0 + allocate (nuc_wrk(0:p_np_compute-1)); nuc_wrk(:) = 0 allocate (order_ucat (totalnumucat)) order_ucat(uc_up2down) = (/(i, i = 1, totalnumucat)/) @@ -319,7 +319,7 @@ SUBROUTINE build_riverlake_network () iworker = iwrk_rs(iriv) IF (nups_all(i) <= nave_rs(iriv)-nuc_wrk(iworker)) THEN - addr_ucat(i) = p_address_worker(iworker) + addr_ucat(i) = p_address_compute(iworker) nuc_wrk(iworker) = nuc_wrk(iworker) + nups_all(i) IF (nuc_wrk(iworker) == nave_rs(iriv)) THEN @@ -340,9 +340,9 @@ SUBROUTINE build_riverlake_network () ithis = ithis - 1 ENDIF ELSE - iworker = minloc(wt_wrk(iwrkdsp+1:p_np_worker-1), dim=1) + iwrkdsp + iworker = minloc(wt_wrk(iwrkdsp+1:p_np_compute-1), dim=1) + iwrkdsp - addr_ucat(i) = p_address_worker(iworker) + addr_ucat(i) = p_address_compute(iworker) wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv) ithis = ithis - 1 @@ -363,60 +363,60 @@ SUBROUTINE build_riverlake_network () ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN allocate(ucat_ucid (totalnumucat)) ucat_ucid = (/(i, i = 1, totalnumucat)/) - allocate (numucat_wrk (0:p_np_worker-1)) - allocate (ucat_data_address (0:p_np_worker-1)) + allocate (numucat_wrk (0:p_np_compute-1)) + allocate (ucat_data_address (0:p_np_compute-1)) - DO iworker = 0, p_np_worker-1 - nucat = count(addr_ucat == p_address_worker(iworker)) + DO iworker = 0, p_np_compute-1 + nucat = count(addr_ucat == p_address_compute(iworker)) numucat_wrk(iworker) = nucat IF (nucat > 0) THEN allocate (ucat_data_address(iworker)%val (nucat)) ucat_data_address(iworker)%val = & - pack(ucat_ucid, mask = (addr_ucat == p_address_worker(iworker))) + pack(ucat_ucid, mask = (addr_ucat == p_address_compute(iworker))) ENDIF ENDDO ENDIF - CALL mpi_bcast (totalnumucat, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (totalnumucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ! send unit catchment index to workers - IF (p_is_master) THEN + IF (p_is_root) THEN self_worker = -1 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 nucat = numucat_wrk(iworker) - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN numucat = nucat self_worker = iworker CYCLE ENDIF - CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_mesg, p_comm_glb, p_err) IF (nucat > 0) THEN CALL mpi_send (ucat_data_address(iworker)%val, nucat, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_err) #ifndef MPAS_EMBEDDED_COLM allocate (idata1d (nucat)) idata1d = x_ucat (ucat_data_address(iworker)%val) CALL mpi_send (idata1d, nucat, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_err) idata1d = y_ucat (ucat_data_address(iworker)%val) CALL mpi_send (idata1d, nucat, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_err) deallocate (idata1d) #endif @@ -454,9 +454,9 @@ SUBROUTINE build_riverlake_network () ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN - CALL mpi_recv (numucat, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (numucat, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_stat, p_err) IF (numucat > 0) THEN allocate (ucat_ucid (numucat)) @@ -464,12 +464,12 @@ SUBROUTINE build_riverlake_network () allocate (x_ucat (numucat)) allocate (y_ucat (numucat)) #endif - CALL mpi_recv (ucat_ucid, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (ucat_ucid, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) #ifndef MPAS_EMBEDDED_COLM - CALL mpi_recv (x_ucat, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (x_ucat, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (y_ucat, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (y_ucat, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) #endif ENDIF @@ -492,7 +492,7 @@ SUBROUTINE build_riverlake_network () #endif #ifdef MPAS_EMBEDDED_COLM - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN CALL ncio_read_indexed_serial (parafile, 'seq_x', ucat_ucid, x_ucat) CALL ncio_read_indexed_serial (parafile, 'seq_y', ucat_ucid, y_ucat) @@ -503,7 +503,7 @@ SUBROUTINE build_riverlake_network () ENDIF #endif - IF (p_is_worker .and. numucat == 0) THEN + IF (p_is_compute .and. numucat == 0) THEN IF (.not. allocated(ucat_ucid)) allocate (ucat_ucid (0)) IF (.not. allocated(x_ucat )) allocate (x_ucat (0)) IF (.not. allocated(y_ucat )) allocate (y_ucat (0)) @@ -514,15 +514,15 @@ SUBROUTINE build_riverlake_network () ! ----- Part 1: between runoff input elements and unit catchments ----- #ifdef COLM_PARALLEL - CALL mpi_bcast (nlon_ucat, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (nlat_ucat, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (nlon_ucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (nlat_ucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #endif CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) - CALL build_worker_remapdata (landpatch, griducat, remap_patch2inpm) + CALL build_compute_remapdata (landpatch, griducat, remap_patch2inpm) - IF (p_is_worker) THEN + IF (p_is_compute) THEN numinpm = remap_patch2inpm%num_grid IF (numinpm > 0) THEN allocate (inpm_gdid (numinpm)) @@ -537,7 +537,7 @@ SUBROUTINE build_riverlake_network () inpn = varsize(1) deallocate (varsize) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) @@ -559,7 +559,7 @@ SUBROUTINE build_riverlake_network () nucpart, idmap_uc2gd, area_uc2gd) ENDIF #else - IF (p_is_master) THEN + IF (p_is_root) THEN inpn = size(idmap_x,1) @@ -617,17 +617,17 @@ SUBROUTINE build_riverlake_network () ENDIF #ifdef COLM_PARALLEL - CALL mpi_bcast (inpn, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (inpn, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (p_is_master) THEN + IF (p_is_root) THEN self_worker = -1 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 nucat = numucat_wrk(iworker) IF (nucat > 0) THEN - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN self_worker = iworker CYCLE ENDIF @@ -642,9 +642,9 @@ SUBROUTINE build_riverlake_network () rdata2d(:,i) = area_gd2uc(:,ucat_data_address(iworker)%val(i)) ENDDO - CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_worker(iworker), & + CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) deallocate (idata2d) @@ -677,10 +677,10 @@ SUBROUTINE build_riverlake_network () ENDIF ENDIF - IF (.not. (p_is_worker .and. numucat > 0)) THEN + IF (.not. (p_is_compute .and. numucat > 0)) THEN IF (allocated(idmap_gd2uc)) deallocate (idmap_gd2uc) IF (allocated(area_gd2uc )) deallocate (area_gd2uc ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (idmap_gd2uc (inpn,0)) allocate (area_gd2uc (inpn,0)) ENDIF @@ -688,33 +688,33 @@ SUBROUTINE build_riverlake_network () ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (numucat > 0) THEN allocate (idmap_gd2uc (inpn, numucat)) - CALL mpi_recv (idmap_gd2uc, inpn*numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (idmap_gd2uc, inpn*numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (area_gd2uc (inpn, numucat)) - CALL mpi_recv (area_gd2uc, inpn*numucat, MPI_REAL8, p_address_master, & + CALL mpi_recv (area_gd2uc, inpn*numucat, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF - CALL mpi_bcast (nucpart, 1, mpi_integer, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (nucpart, 1, mpi_integer, p_address_root, p_comm_glb, p_err) - IF (p_is_master) THEN + IF (p_is_root) THEN - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN ngrd = numinpm ELSE CALL mpi_recv (ngrd, 1, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + p_address_compute(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) ENDIF IF (ngrd > 0) THEN @@ -723,11 +723,11 @@ SUBROUTINE build_riverlake_network () allocate (idata2d (nucpart, ngrd)); idata2d(:,:) = 0 allocate (rdata2d (nucpart, ngrd)); rdata2d(:,:) = 0. - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN grdindex = inpm_gdid ELSE CALL mpi_recv (grdindex, ngrd, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF DO i = 1, ngrd @@ -738,7 +738,7 @@ SUBROUTINE build_riverlake_network () ENDIF ENDDO - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN IF (allocated(idmap_uc2gd)) deallocate(idmap_uc2gd) IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) allocate (idmap_uc2gd (nucpart, ngrd)) @@ -746,9 +746,9 @@ SUBROUTINE build_riverlake_network () idmap_uc2gd = idata2d area_uc2gd = rdata2d ELSE - CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_worker(iworker), & + CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -760,21 +760,21 @@ SUBROUTINE build_riverlake_network () ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN - CALL mpi_send (numinpm, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (numinpm, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numinpm > 0) THEN - CALL mpi_send (inpm_gdid, numinpm, MPI_INTEGER, p_address_master, & + CALL mpi_send (inpm_gdid, numinpm, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_err) allocate (idmap_uc2gd (nucpart,numinpm)) - CALL mpi_recv (idmap_uc2gd, nucpart*numinpm, MPI_INTEGER, p_address_master, & + CALL mpi_recv (idmap_uc2gd, nucpart*numinpm, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (area_uc2gd (nucpart,numinpm)) - CALL mpi_recv (area_uc2gd, nucpart*numinpm, MPI_REAL8, p_address_master, & + CALL mpi_recv (area_uc2gd, nucpart*numinpm, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -798,14 +798,14 @@ SUBROUTINE build_riverlake_network () #endif #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (.not. allocated(idmap_gd2uc)) allocate (idmap_gd2uc (inpn,0)) IF (.not. allocated(area_gd2uc )) allocate (area_gd2uc (inpn,0)) IF (.not. allocated(idmap_uc2gd)) allocate (idmap_uc2gd (nucpart,0)) IF (.not. allocated(area_uc2gd )) allocate (area_uc2gd (nucpart,0)) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN allocate (ucat_gdid (numucat)) ucat_gdid = (y_ucat-1)*nlon_ucat + x_ucat @@ -814,14 +814,14 @@ SUBROUTINE build_riverlake_network () ENDIF ENDIF - CALL build_worker_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) - CALL build_worker_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) - CALL build_worker_pushdata (numucat, ucat_gdid, numinpm, inpm_gdid, push_ucat2grid) - CALL build_worker_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) + CALL build_compute_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) + CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) + CALL build_compute_pushdata (numucat, ucat_gdid, numinpm, inpm_gdid, push_ucat2grid) + CALL build_compute_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) IF (allocated(idmap_x)) deallocate (idmap_x) IF (allocated(idmap_y)) deallocate (idmap_y) - IF (p_is_master) THEN + IF (p_is_root) THEN IF (allocated(allgrd_in_inp )) deallocate (allgrd_in_inp ) IF (allocated(nucat_g2d )) deallocate (nucat_g2d ) IF (allocated(iucat_g )) deallocate (iucat_g ) @@ -831,7 +831,7 @@ SUBROUTINE build_riverlake_network () ! ----- Part 2: between upstream and downstream unit catchments ----- - IF (p_is_master) THEN + IF (p_is_root) THEN upnmax = maxval(nups_nst) allocate (ucat_ups (upnmax,totalnumucat)) @@ -852,17 +852,17 @@ SUBROUTINE build_riverlake_network () #ifdef COLM_PARALLEL - CALL mpi_bcast (upnmax, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (upnmax, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (p_is_master) THEN + IF (p_is_root) THEN self_worker = -1 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 nucat = numucat_wrk(iworker) IF (nucat > 0) THEN - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN self_worker = iworker CYCLE ENDIF @@ -875,9 +875,9 @@ SUBROUTINE build_riverlake_network () idata2d(:,i) = ucat_ups(:,ucat_data_address(iworker)%val(i)) ENDDO - CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) deallocate (idata1d) @@ -913,22 +913,22 @@ SUBROUTINE build_riverlake_network () ENDIF ENDIF - IF (.not. (p_is_worker .and. numucat > 0)) THEN + IF (.not. (p_is_compute .and. numucat > 0)) THEN IF (allocated(ucat_ups)) deallocate (ucat_ups) ENDIF ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (numucat > 0) THEN allocate (ucat_next (numucat)) - CALL mpi_recv (ucat_next, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (ucat_next, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (ucat_ups (upnmax, numucat)) - CALL mpi_recv (ucat_ups, upnmax*numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (ucat_ups, upnmax*numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -938,19 +938,19 @@ SUBROUTINE build_riverlake_network () CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (.not. allocated(ucat_next)) allocate (ucat_next (0)) IF (.not. allocated(ucat_ups )) allocate (ucat_ups (upnmax,0)) allocate (wts_ups (upnmax,numucat)) IF (numucat > 0) wts_ups(:,:) = 1. ENDIF - CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) - CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) #ifdef CoLMDEBUG - ! IF (p_is_worker) THEN - ! write(*,'(A,I0,A,I0,A,I0,A)') 'worker ', p_iam_worker, ' has ', numucat, & + ! IF (p_is_compute) THEN + ! write(*,'(A,I0,A,I0,A,I0,A)') 'worker ', p_iam_compute, ' has ', numucat, & ! ' unit catchment with ', sum(push_next2ucat%n_from_other), ' downstream to other workers' ! ENDIF #endif @@ -958,19 +958,19 @@ SUBROUTINE build_riverlake_network () ! ----- Part 3: river systems ----- #ifdef COLM_PARALLEL - IF (p_is_master) THEN + IF (p_is_root) THEN self_worker = -1 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 nucat = numucat_wrk(iworker) IF (nucat > 0) THEN - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN self_worker = iworker CYCLE ENDIF allocate (idata1d (nucat)) idata1d = rivermouth(ucat_data_address(iworker)%val) - CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) deallocate (idata1d) ENDIF @@ -987,20 +987,20 @@ SUBROUTINE build_riverlake_network () ENDIF ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (numucat > 0) THEN allocate (rivermouth (numucat)) - CALL mpi_recv (rivermouth, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (rivermouth, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN color = maxval(rivermouth) - CALL mpi_comm_split (p_comm_worker, color, p_iam_worker, p_comm_rivsys, p_err) + CALL mpi_comm_split (p_comm_compute, color, p_iam_compute, p_comm_rivsys, p_err) ELSE - CALL mpi_comm_split (p_comm_worker, MPI_UNDEFINED, p_iam_worker, p_comm_rivsys, p_err) + CALL mpi_comm_split (p_comm_compute, MPI_UNDEFINED, p_iam_compute, p_comm_rivsys, p_err) ENDIF rivsys_by_multiple_procs = .false. @@ -1015,7 +1015,7 @@ SUBROUTINE build_riverlake_network () rivsys_by_multiple_procs = .false. #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) allocate (irivsys (numucat)) @@ -1058,7 +1058,7 @@ SUBROUTINE build_riverlake_network () CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN allocate (lake_type (numucat)) @@ -1109,10 +1109,10 @@ SUBROUTINE build_riverlake_network () ENDIF ENDIF - CALL worker_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) - CALL worker_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) + CALL compute_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) + CALL compute_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN WHERE (ucat_next > 0) outletwth = (outletwth + topo_rivwth) * 0.5 @@ -1124,28 +1124,28 @@ SUBROUTINE build_riverlake_network () ! ----- Mask of Grids with all upstream area in the simulation region ----- - IF (p_is_master) allocate (ucat_area_all (totalnumucat)) + IF (p_is_root) allocate (ucat_area_all (totalnumucat)) #ifdef COLM_PARALLEL - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (numucat > 0) THEN - CALL mpi_send (push_inpm2ucat%sum_area, numucat, MPI_REAL8, p_address_master, & + CALL mpi_send (push_inpm2ucat%sum_area, numucat, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_err) ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (numucat_wrk(iworker) > 0) THEN allocate (rdata1d (numucat_wrk(iworker))) - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN rdata1d = push_inpm2ucat%sum_area ELSE - CALL mpi_recv (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_worker(iworker), & + CALL mpi_recv (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -1160,7 +1160,7 @@ SUBROUTINE build_riverlake_network () ucat_area_all = push_inpm2ucat%sum_area #endif - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (allups_mask_ucat (totalnumucat)) allups_mask_ucat (:) = 0 @@ -1183,11 +1183,11 @@ SUBROUTINE build_riverlake_network () ENDIF #ifdef COLM_PARALLEL - IF (p_is_master) THEN + IF (p_is_root) THEN self_worker = -1 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (numucat_wrk(iworker) > 0) THEN - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN self_worker = iworker CYCLE ENDIF @@ -1195,7 +1195,7 @@ SUBROUTINE build_riverlake_network () allocate (rdata1d (numucat_wrk(iworker))) rdata1d = allups_mask_ucat(ucat_data_address(iworker)%val) - CALL mpi_send (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_worker(iworker), & + CALL mpi_send (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) deallocate (rdata1d) @@ -1213,16 +1213,16 @@ SUBROUTINE build_riverlake_network () ENDIF ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (numucat > 0) THEN allocate (allups_mask_ucat (numucat)) - CALL mpi_recv (allups_mask_ucat, numucat, MPI_REAL8, p_address_master, & + CALL mpi_recv (allups_mask_ucat, numucat, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF #endif - IF (p_is_worker .and. numucat == 0) THEN + IF (p_is_compute .and. numucat == 0) THEN IF (.not. allocated(allups_mask_ucat)) allocate (allups_mask_ucat (0)) ENDIF @@ -1262,9 +1262,9 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL ncio_inquire_length (parafile, 'lat', nlat_ucat) CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) - CALL build_worker_remapdata (landpatch, griducat, remap_patch2inpm) + CALL build_compute_remapdata (landpatch, griducat, remap_patch2inpm) - IF (p_is_worker) THEN + IF (p_is_compute) THEN numinpm = remap_patch2inpm%num_grid IF (numinpm > 0) THEN allocate (inpm_gdid (numinpm)) @@ -1280,7 +1280,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () inpn = varsize(1) deallocate (varsize) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) @@ -1305,27 +1305,27 @@ SUBROUTINE build_riverlake_network_mpas_embedded () nucpart, idmap_uc2gd, area_uc2gd) ENDIF - IF (p_is_worker) THEN - CALL build_worker_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) - CALL build_worker_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) - CALL build_worker_pushdata (numucat, ucat_ucid, numinpm, inpm_gdid, push_ucat2grid) - CALL build_worker_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) + IF (p_is_compute) THEN + CALL build_compute_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) + CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) + CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, inpm_gdid, push_ucat2grid) + CALL build_compute_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) ENDIF CALL build_mpas_embedded_local_topology (parafile) - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (wts_ups (upnmax,numucat)) IF (numucat > 0) wts_ups(:,:) = 1._r8 - CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) - CALL build_worker_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) ENDIF #ifdef COLM_PARALLEL - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN - p_comm_rivsys = p_comm_worker + p_comm_rivsys = p_comm_compute CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) rivsys_by_multiple_procs = p_np_rivsys > 1 ELSE @@ -1337,7 +1337,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () rivsys_by_multiple_procs = .false. #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN allocate (irivsys (numucat)) numrivsys = 1 @@ -1356,7 +1356,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN allocate (lake_type (numucat)) lake_type(:) = 0 @@ -1404,10 +1404,10 @@ SUBROUTINE build_riverlake_network_mpas_embedded () ENDIF ENDIF - CALL worker_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) - CALL worker_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) + CALL compute_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) + CALL compute_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numucat > 0) THEN WHERE (ucat_next > 0) outletwth = (outletwth + topo_rivwth) * 0.5_r8 @@ -1445,7 +1445,7 @@ SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_g integer, allocatable :: seq_x_blk(:), seq_y_blk(:) integer :: istart, iend, iucat, iloc, grid_id, nfound - IF (.not. p_is_worker) RETURN + IF (.not. p_is_compute) RETURN IF (numinpm > 0) THEN allocate (inpm_sorted (numinpm)) @@ -1524,25 +1524,25 @@ SUBROUTINE gather_mpas_embedded_ucat_addresses() integer :: iworker, nrecv - allocate (numucat_wrk (0:p_np_worker-1)) - allocate (ucat_data_address (0:p_np_worker-1)) + allocate (numucat_wrk (0:p_np_compute-1)) + allocate (ucat_data_address (0:p_np_compute-1)) numucat_wrk(:) = 0 #ifdef COLM_PARALLEL - IF (p_is_worker .and. (.not. p_is_master)) THEN - CALL mpi_send (numucat, 1, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (p_is_compute .and. (.not. p_is_root)) THEN + CALL mpi_send (numucat, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numucat > 0) THEN - CALL mpi_send (ucat_ucid, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_send (ucat_ucid, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_err) ENDIF ENDIF - IF (p_is_master) THEN - DO iworker = 0, p_np_worker-1 - IF (p_is_worker .and. p_address_worker(iworker) == p_iam_glb) THEN + IF (p_is_root) THEN + DO iworker = 0, p_np_compute-1 + IF (p_is_compute .and. p_address_compute(iworker) == p_iam_glb) THEN nrecv = numucat ELSE - CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) ENDIF @@ -1550,11 +1550,11 @@ SUBROUTINE gather_mpas_embedded_ucat_addresses() allocate (ucat_data_address(iworker)%val (nrecv)) IF (nrecv > 0) THEN - IF (p_is_worker .and. p_address_worker(iworker) == p_iam_glb) THEN + IF (p_is_compute .and. p_address_compute(iworker) == p_iam_glb) THEN ucat_data_address(iworker)%val = ucat_ucid ELSE CALL mpi_recv (ucat_data_address(iworker)%val, nrecv, MPI_INTEGER, & - p_address_worker(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF ENDDO @@ -1584,7 +1584,7 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) integer, allocatable :: seq_next_blk(:) integer :: istart, iend, iucat, iloc, idn, local_upnmax - IF (.not. p_is_worker) RETURN + IF (.not. p_is_compute) RETURN IF (numucat > 0) THEN CALL ncio_read_indexed_serial (parafile, 'seq_next', ucat_ucid, ucat_next) @@ -1622,7 +1622,7 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) ENDIF #ifdef COLM_PARALLEL - CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, p_comm_worker, p_err) + CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err) #else upnmax = local_upnmax #endif @@ -1802,7 +1802,7 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat integer, allocatable :: isend1d (:) #ifdef MPAS_EMBEDDED_COLM - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (present(rdata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata1d) IF (present(rdata2d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata2d) IF (present(idata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, idata1d) @@ -1813,7 +1813,7 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat RETURN #endif - IF (p_is_master) THEN + IF (p_is_root) THEN IF (present(rdata1d)) CALL ncio_read_serial (parafile, varname, rdata1d) IF (present(rdata2d)) CALL ncio_read_serial (parafile, varname, rdata2d) IF (present(idata1d)) CALL ncio_read_serial (parafile, varname, idata1d) @@ -1823,14 +1823,14 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat CALL mpi_barrier (p_comm_glb, p_err) IF (present(rdata2d)) THEN - IF (p_is_master) ndim1 = size(rdata2d,1) - CALL mpi_bcast (ndim1, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + IF (p_is_root) ndim1 = size(rdata2d,1) + CALL mpi_bcast (ndim1, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ENDIF ! send unit catchment index to workers - IF (p_is_master) THEN + IF (p_is_root) THEN - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 nucat = numucat_wrk(iworker) @@ -1839,12 +1839,12 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat allocate (rsend1d (nucat)) rsend1d = rdata1d(ucat_data_address(iworker)%val) - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN IF (allocated(rdata1d)) deallocate(rdata1d) allocate (rdata1d (nucat)) rdata1d = rsend1d ELSE - CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_worker(iworker), & + CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1857,12 +1857,12 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat DO i = 1, nucat rsend2d(:,i) = rdata2d(:,ucat_data_address(iworker)%val(i)) ENDDO - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN IF (allocated(rdata2d)) deallocate(rdata2d) allocate (rdata2d (ndim1,nucat)) rdata2d = rsend2d ELSE - CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_worker(iworker), & + CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1873,12 +1873,12 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat allocate (isend1d (nucat)) isend1d = idata1d(ucat_data_address(iworker)%val) - IF (p_address_worker(iworker) == p_iam_glb) THEN + IF (p_address_compute(iworker) == p_iam_glb) THEN IF (allocated(idata1d)) deallocate(idata1d) allocate (idata1d (nucat)) idata1d = isend1d ELSE - CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_worker(iworker), & + CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_compute(iworker), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1887,7 +1887,7 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat ENDIF ENDDO - IF (.not. p_is_worker) THEN + IF (.not. p_is_compute) THEN IF (present(rdata1d)) deallocate (rdata1d) IF (present(rdata2d)) deallocate (rdata2d) IF (present(idata1d)) deallocate (idata1d) @@ -1895,24 +1895,24 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (numucat > 0) THEN IF (present(rdata1d)) THEN allocate (rdata1d (numucat)) - CALL mpi_recv (rdata1d, numucat, MPI_REAL8, p_address_master, & + CALL mpi_recv (rdata1d, numucat, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF IF (present(rdata2d)) THEN allocate (rdata2d (ndim1,numucat)) - CALL mpi_recv (rdata2d, ndim1*numucat, MPI_REAL8, p_address_master, & + CALL mpi_recv (rdata2d, ndim1*numucat, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF IF (present(idata1d)) THEN allocate (idata1d (numucat)) - CALL mpi_recv (idata1d, numucat, MPI_INTEGER, p_address_master, & + CALL mpi_recv (idata1d, numucat, MPI_INTEGER, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF @@ -1922,7 +1922,7 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_worker .and. numucat == 0) THEN + IF (p_is_compute .and. numucat == 0) THEN IF (present(rdata1d)) THEN IF (.not. allocated(rdata1d)) allocate (rdata1d (0)) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 index cc041fb766..fc05ceb3c9 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 @@ -41,7 +41,7 @@ SUBROUTINE allocate_GridRiverLakeTimeVars USE MOD_Grid_Reservoir, only: numresv IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (wdsrf_ucat (numucat)) allocate (veloc_riv (numucat)) @@ -73,7 +73,7 @@ SUBROUTINE READ_GridRiverLakeTimeVars (file_restart) gridriver_restart_file = trim(file_restart) #ifdef MPAS_EMBEDDED_COLM - IF (p_is_worker .and. numucat > 0) THEN + IF (p_is_compute .and. numucat > 0) THEN CALL ncio_read_indexed_serial (file_restart, 'wdsrf_ucat', ucat_ucid, wdsrf_ucat) CALL ncio_read_indexed_serial (file_restart, 'veloc_riv', ucat_ucid, veloc_riv ) ENDIF @@ -85,7 +85,7 @@ SUBROUTINE READ_GridRiverLakeTimeVars (file_restart) IF (DEF_Reservoir_Method > 0) THEN IF (totalnumresv > 0) THEN #ifdef MPAS_EMBEDDED_COLM - IF (p_is_worker .and. numresv > 0) THEN + IF (p_is_compute .and. numresv > 0) THEN CALL ncio_read_indexed_serial (file_restart, 'volresv', resv_global_index, volresv) ENDIF #else @@ -117,7 +117,7 @@ SUBROUTINE WRITE_GridRiverLakeTimeVars (file_restart) #ifdef MPAS_EMBEDDED_COLM CALL write_gridriver_restart_mpas_embedded (file_restart) #else - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_create_file (trim(file_restart)) CALL ncio_define_dimension(file_restart, 'ucatch', totalnumucat) ENDIF @@ -131,7 +131,7 @@ SUBROUTINE WRITE_GridRiverLakeTimeVars (file_restart) IF (DEF_Reservoir_Method > 0) THEN IF (totalnumresv > 0) THEN - IF (p_is_master) CALL ncio_define_dimension(file_restart, 'reservoir', totalnumresv) + IF (p_is_root) CALL ncio_define_dimension(file_restart, 'reservoir', totalnumresv) CALL vector_gather_and_write (& volresv, numresv, totalnumresv, resv_data_address, file_restart, 'volresv', 'reservoir') @@ -152,7 +152,7 @@ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) USE mpi, only: MPI_INFO_NULL, MPI_OFFSET_KIND USE pnetcdf - USE MOD_SPMD_Task, only: p_comm_worker + USE MOD_SPMD_Task, only: p_comm_compute USE MOD_Namelist, only: DEF_Reservoir_Method USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_ucid USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index @@ -171,7 +171,7 @@ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) write_reservoir = DEF_Reservoir_Method > 0 .and. totalnumresv > 0 - ierr = nf90mpi_create(p_comm_worker, trim(file_restart), & + ierr = nf90mpi_create(p_comm_compute, trim(file_restart), & IOR(NF90_CLOBBER, NF90_64BIT_OFFSET), MPI_INFO_NULL, ncid) CALL pnetcdf_check(ierr, 'create', file_restart) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 index 90f83eee1e..e5ef3018ca 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 @@ -3570,32 +3570,32 @@ SUBROUTINE print_VSF_iteration_stat_info () integer :: iwork #ifdef CoLMDEBUG - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err) #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN count_implicit_accum = count_implicit_accum + count_implicit count_explicit_accum = count_explicit_accum + count_explicit count_wet2dry_accum = count_wet2dry_accum + count_wet2dry #ifdef USEMPI - CALL mpi_send (count_implicit, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_explicit, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_wet2dry, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_implicit_accum, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_explicit_accum, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_wet2dry_accum, 1, MPI_INTEGER8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_implicit, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_explicit, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_wet2dry, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_implicit_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_explicit_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_wet2dry_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - iwork = p_address_worker(p_root) + iwork = p_address_compute(p_root) CALL mpi_recv (count_implicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (count_explicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (count_wet2dry , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 index bd27bd3051..308e06f20b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 @@ -38,29 +38,29 @@ SUBROUTINE vector_gather_to_master ( & IF (totalvlen <= 0) RETURN - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (wdata (totalvlen)) ENDIF #ifdef COLM_PARALLEL CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN mesg = (/p_iam_glb, vlen/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (vlen > 0) THEN CALL mpi_send (vector, vlen, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF ENDIF - IF (p_is_master) THEN - IF (p_is_worker .and. vlen > 0) THEN - wdata(data_address(p_iam_worker)%val) = vector + IF (p_is_root) THEN + IF (p_is_compute .and. vlen > 0) THEN + wdata(data_address(p_iam_compute)%val) = vector ENDIF - DO iwork = 0, p_np_worker-1 - IF (p_address_worker(iwork) == p_iam_glb) CYCLE + DO iwork = 0, p_np_compute-1 + IF (p_address_compute(iwork) == p_iam_glb) CYCLE CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -73,7 +73,7 @@ SUBROUTINE vector_gather_to_master ( & CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) - wdata(data_address(p_itis_worker(isrc))%val) = rcache + wdata(data_address(p_itis_compute(isrc))%val) = rcache deallocate (rcache) ENDIF @@ -120,7 +120,7 @@ SUBROUTINE vector_gather_and_write ( vector, vlen, totalvlen, data_address, & CALL vector_gather_to_master (vector, vlen, totalvlen, data_address, wdata) - IF (p_is_master) THEN + IF (p_is_root) THEN IF (present(itime_in_file)) THEN CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata, & @@ -184,7 +184,7 @@ SUBROUTINE vector_gather_map2grid_and_write ( & CALL vector_gather_to_master (vector, vlen, totalvlen, data_address, wdata) - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (wdata2d (nlon,nlat)) wdata2d(:,:) = spval @@ -240,29 +240,29 @@ SUBROUTINE vector_read_and_scatter ( & integer :: iwork, ndata real(r8), allocatable :: rdata(:), rcache(:) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (filein, varname, rdata) ENDIF #ifdef COLM_PARALLEL CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_master) THEN - DO iwork = 0, p_np_worker-1 + IF (p_is_root) THEN + DO iwork = 0, p_np_compute-1 IF (allocated(data_address(iwork)%val)) THEN ndata = size(data_address(iwork)%val) allocate(rcache (ndata)) rcache = rdata(data_address(iwork)%val) - IF (p_address_worker(iwork) == p_iam_glb) THEN + IF (p_address_compute(iwork) == p_iam_glb) THEN IF (ndata > 0) THEN IF (.not. allocated(vector)) allocate(vector(ndata)) vector = rcache ENDIF ELSE CALL mpi_send (rcache, ndata, MPI_REAL8, & - p_address_worker(iwork), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(iwork), mpi_tag_data, p_comm_glb, p_err) ENDIF deallocate (rcache) @@ -270,10 +270,10 @@ SUBROUTINE vector_read_and_scatter ( & ENDDO ENDIF - IF (p_is_worker .and. (.not. p_is_master)) THEN + IF (p_is_compute .and. (.not. p_is_root)) THEN IF (vlen > 0) THEN IF (.not. allocated(vector)) allocate(vector(vlen)) - CALL mpi_recv (vector, vlen, MPI_REAL8, p_address_master, & + CALL mpi_recv (vector, vlen, MPI_REAL8, p_address_root, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF @@ -284,7 +284,7 @@ SUBROUTINE vector_read_and_scatter ( & vector = rdata(data_address(0)%val) #endif - IF (p_is_master) deallocate(rdata) + IF (p_is_root) deallocate(rdata) END SUBROUTINE vector_read_and_scatter diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 index b47138a4e5..d479bf8cea 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 @@ -75,7 +75,7 @@ SUBROUTINE CheckEqb_init (n_spinupcycle, lc_year) IF (.not. DEF_CheckEquilibrium) RETURN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (tws_last (numpatch)); tws_last (:) = spval; @@ -122,7 +122,7 @@ SUBROUTINE CheckEqb_init (n_spinupcycle, lc_year) CALL map_check%build_arealweighted (gridcheck, landpatch) #endif - IF ((p_is_worker) .and. (numpatch > 0)) THEN + IF ((p_is_compute) .and. (numpatch > 0)) THEN tws_last = wdsrf ! 1. surface water CALL add_spv (ldew, tws_last) ! 2. water on foliage CALL add_spv (scv , tws_last) ! 3. snow cover water equivalent @@ -136,7 +136,7 @@ SUBROUTINE CheckEqb_init (n_spinupcycle, lc_year) CALL add_spv (wa, tws_last) ! 7. water in aquifer ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (patcharea (numpatch)) @@ -218,7 +218,7 @@ SUBROUTINE CheckEquilibrium ( & IF (.not. DEF_CheckEquilibrium) RETURN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN CALL add_spv (forc_prc, prcp_year, deltim) CALL add_spv (forc_prl, prcp_year, deltim) @@ -241,7 +241,7 @@ SUBROUTINE CheckEquilibrium ( & IF (docheck) THEN - IF ((p_is_worker) .and. (numpatch > 0)) THEN + IF ((p_is_compute) .and. (numpatch > 0)) THEN tws_this = wdsrf ! 1. surface water CALL add_spv (ldew, tws_this) ! 2. water on foliage CALL add_spv (scv , tws_this) ! 3. snow cover water equivalent @@ -259,7 +259,7 @@ SUBROUTINE CheckEquilibrium ( & IF (nyearcheck >= 1) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN totaldtws = 0. totalprcp = 0. @@ -295,8 +295,8 @@ SUBROUTINE CheckEquilibrium ( & ENDIF #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, totaldtws, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, totalprcp, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, totaldtws, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, totalprcp, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) IF (totalprcp > 0.) THEN pct_dtws_prcp = totaldtws/totalprcp @@ -304,13 +304,13 @@ SUBROUTINE CheckEquilibrium ( & pct_dtws_prcp = spval ENDIF - IF (p_iam_worker == p_root) THEN - CALL mpi_send (pct_dtws_prcp, 1, MPI_REAL8, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + IF (p_iam_compute == p_root) THEN + CALL mpi_send (pct_dtws_prcp, 1, MPI_REAL8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) ENDIF #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN IF (is_spinup) THEN write(timestr,timeform) i_spinupcycle, idate(1) @@ -319,7 +319,7 @@ SUBROUTINE CheckEquilibrium ( & ENDIF #ifdef USEMPI - CALL mpi_recv (pct_dtws_prcp, 1, MPI_REAL8, p_address_worker(p_root), & + CALL mpi_recv (pct_dtws_prcp, 1, MPI_REAL8, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif IF (pct_dtws_prcp /= spval) THEN @@ -373,7 +373,7 @@ SUBROUTINE CheckEquilibrium ( & ENDIF #ifndef SinglePoint - IF (p_is_io) CALL allocate_block_data (gridcheck, sumarea) + IF (p_is_active) CALL allocate_block_data (gridcheck, sumarea) CALL map_check%get_sumarea (sumarea, filter) @@ -458,7 +458,7 @@ SUBROUTINE CheckEquilibrium ( & #endif ENDIF - IF ((p_is_worker) .and. (numpatch > 0)) THEN + IF ((p_is_compute) .and. (numpatch > 0)) THEN prcp_year(:) = spval et_year (:) = spval rnof_year(:) = spval @@ -504,14 +504,14 @@ SUBROUTINE map_and_write_check_var ( & real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) logical :: amount - IF (p_is_io) CALL allocate_block_data (gridcheck, data_xy_2d) + IF (p_is_active) CALL allocate_block_data (gridcheck, data_xy_2d) CALL map_check%pset2grid (vector, data_xy_2d, spv = spval, msk = filter) amount = .false. IF (present(amount_in_grid)) amount = amount_in_grid IF (.not. amount) THEN - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) @@ -541,7 +541,7 @@ SUBROUTINE map_and_write_check_var ( & CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (vdata (gcheck_concat%ginfo%nlon, gcheck_concat%ginfo%nlat)) vdata(:,:) = spval @@ -607,7 +607,7 @@ SUBROUTINE map_and_write_check_var ( & ENDIF #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN DO iyseg = 1, gcheck_concat%nyseg DO ixseg = 1, gcheck_concat%nxseg @@ -626,9 +626,9 @@ SUBROUTINE map_and_write_check_var ( & smesg = (/p_iam_glb, ixseg, iyseg/) CALL mpi_send (smesg, 3, MPI_INTEGER, & - p_address_master, check_data_id, p_comm_glb, p_err) + p_address_root, check_data_id, p_comm_glb, p_err) CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, & - p_address_master, check_data_id, p_comm_glb, p_err) + p_address_root, check_data_id, p_comm_glb, p_err) deallocate (sbuf) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 index 93eb4f91cb..cafdfd6086 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 @@ -86,18 +86,18 @@ SUBROUTINE CROP_readin () CALL grid_crop%define_by_center (lat, lon) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_crop, f_xy_crop) ENDIF ! missing value - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_get_attr (file_crop, 'pdrice2', 'missing_value', missing_value) ENDIF #ifdef USEMPI - CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err) #endif - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) ENDIF @@ -110,7 +110,7 @@ SUBROUTINE CROP_readin () IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) allocate(pdrice2_tmp (numpatch)) IF (numpft > 0) allocate(plantdate_tmp (numpft)) IF (numpft > 0) allocate(fertnitro_tmp (numpft)) @@ -119,13 +119,13 @@ SUBROUTINE CROP_readin () ! (1) Read in plant date for rice2. file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) ENDIF CALL mg2patch_crop%grid2pset (f_xy_crop, pdrice2_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO npatch = 1, numpatch IF (pdrice2_tmp(npatch) /= spval) THEN pdrice2 (npatch) = int(pdrice2_tmp (npatch)) @@ -140,21 +140,21 @@ SUBROUTINE CROP_readin () #endif ! (2) Read in plant date. - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) plantdate_p(:) = -99999999._r8 ENDIF file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' DO cft = 15, 78 write(cx, '(i2.2)') cft - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block_time (file_crop, & 'PLANTDATE_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) ENDIF CALL mg2pft_crop%grid2pset (f_xy_crop, plantdate_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft)THEN plantdate_p(ipft) = plantdate_tmp(ipft) @@ -172,21 +172,21 @@ SUBROUTINE CROP_readin () ! (3) Read in fertlization IF (DEF_FERT_SOURCE == 1) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) fertnitro_p(:) = -99999999._r8 ENDIF file_fert = trim(DEF_dir_runtime) // '/crop/fertnitro_fillcoast.nc' DO cft = 15, 78 write(cx, '(i2.2)') cft - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block_time (file_fert, & 'CONST_FERTNITRO_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) ENDIF CALL mg2pft_crop%grid2pset (f_xy_crop, fertnitro_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft)THEN fertnitro_p(ipft) = fertnitro_tmp(ipft) @@ -199,7 +199,7 @@ SUBROUTINE CROP_readin () ENDDO ELSEIF (DEF_FERT_SOURCE == 2)THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN allocate(fertilizer_tmp(numpft)) allocate(manure_tmp(numpft)) @@ -212,7 +212,7 @@ SUBROUTINE CROP_readin () CALL ncio_read_bcast_serial (file_fert, 'lon', lon) CALL grid_fert%define_by_center (lat, lon) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_fert, f_xy_fert) ENDIF @@ -221,19 +221,19 @@ SUBROUTINE CROP_readin () IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_worker) THEN + IF (p_is_compute) THEN fertnitro_p(:) = -99999999._r8 manunitro_p(:) = -99999999._r8 ENDIF ! read manure - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_fert, 'manure', grid_fert, f_xy_fert) ENDIF CALL mg2pft_fert%grid2pset (f_xy_fert, manure_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipft = 1, numpft IF (landpft%settyp(ipft) .ge. 15) THEN manunitro_p(ipft) = manure_tmp(ipft) @@ -246,13 +246,13 @@ SUBROUTINE CROP_readin () ! read fertilizer DO cft = 1, 64 - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block_time (file_fert, 'fertilizer', grid_fert, cft, f_xy_fert) ENDIF CALL mg2pft_fert%grid2pset (f_xy_fert, fertilizer_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipft = 1, numpft IF (landpft%settyp(ipft) .eq. cft+14) THEN fertnitro_p(ipft) = fertilizer_tmp(ipft) @@ -281,7 +281,7 @@ SUBROUTINE CROP_readin () CALL grid_irrig%define_by_center (lat, lon) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_irrig, f_xy_irrig) ENDIF @@ -290,18 +290,18 @@ SUBROUTINE CROP_readin () IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) irrig_method_p(:) = -99999999 ENDIF DO cft = 1, N_CFT - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig) ENDIF CALL mg2pft_irrig%grid2pset_dominant (f_xy_irrig, irrig_method_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft + 14)THEN @@ -332,7 +332,7 @@ SUBROUTINE CROP_readin () CALL grid_irrigalloc%define_by_center (lat, lon) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_irrigalloc, f_xy_irrigalloc) ENDIF @@ -341,11 +341,11 @@ SUBROUTINE CROP_readin () IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_worker) THEN + IF (p_is_compute) THEN irrig_gw_alloc(:) = 0._r8 ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_irrigalloc, 'irrig_gw_alloc', grid_irrigalloc, f_xy_irrigalloc) ENDIF @@ -356,11 +356,11 @@ SUBROUTINE CROP_readin () #endif ! (6) Read in irrigation allocated to surfacewater - IF (p_is_worker) THEN + IF (p_is_compute) THEN irrig_sw_alloc(:) = 0._r8 ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_irrigalloc, 'irrig_sw_alloc', grid_irrigalloc, f_xy_irrigalloc) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 index b03ec209d1..153f26922b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 @@ -59,12 +59,12 @@ SUBROUTINE init_fire_data (YY) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_fire, f_xy_fire) ENDIF file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_fire, 'abm', grid_fire, f_xy_fire) ENDIF CALL mg2p_fire%grid2pset (f_xy_fire, abm_lf) @@ -73,7 +73,7 @@ SUBROUTINE init_fire_data (YY) #endif file_fire = trim(DEF_dir_runtime) // '/fire/peatf_colm_360x720_c100428.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_fire, 'peatf', grid_fire, f_xy_fire) ENDIF CALL mg2p_fire%grid2pset (f_xy_fire, peatf_lf) @@ -82,7 +82,7 @@ SUBROUTINE init_fire_data (YY) #endif file_fire = trim(DEF_dir_runtime) // '/fire/gdp_colm_360x720_c100428.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_fire, 'gdp', grid_fire, f_xy_fire) ENDIF CALL mg2p_fire%grid2pset (f_xy_fire, gdp_lf) @@ -122,7 +122,7 @@ SUBROUTINE update_hdm_data (YY) file_fire = trim(DEF_dir_runtime) & // '/fire/colmforc.Li_2017_HYDEv3.2_CMIP6_hdm_0.5x0.5_AVHRR_simyr1850-2016_c180202.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_fire, f_xy_fire) CALL ncio_read_block_time (file_fire, 'hdm', grid_fire, itime, f_xy_fire) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 index b20ecf5cc2..feff68e280 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 @@ -162,7 +162,7 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulc CALL metread_latlon (dir_forcing, idate) - IF (p_is_io) THEN + IF (p_is_active) THEN IF (allocated(forcn )) deallocate(forcn ) IF (allocated(forcn_LB)) deallocate(forcn_LB) @@ -187,7 +187,7 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulc ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (forcmask_pch(numpatch)); forcmask_pch(:) = .true. ENDIF @@ -200,12 +200,12 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulc filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) tstamp_LB(1) = timestamp(-1, -1, -1) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_get_attr (filename, vname(1), trim(DEF_forcing%missing_value_name), & forc_missing_value) ENDIF #ifdef USEMPI - CALL mpi_bcast (forc_missing_value, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (forc_missing_value, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err) #endif CALL ncio_read_block_time (filename, vname(1), gforc, time_i, metdata) @@ -224,21 +224,21 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulc CALL mg2p_forc%set_missing_value (metdata, forc_missing_value, forcmask_pch) ENDIF - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN forc_topo = elvmean WHERE(forc_topo == spval) forc_topo = 0. ENDIF IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN - IF (p_is_io) CALL allocate_block_data (gforc, topo_grid) + IF (p_is_active) CALL allocate_block_data (gforc, topo_grid) CALL mg2p_forc%pset2grid (forc_topo, topo_grid, msk = patchmask) - IF (p_is_io) CALL allocate_block_data (gforc, areagrid) + IF (p_is_active) CALL allocate_block_data (gforc, areagrid) CALL mg2p_forc%get_sumarea(areagrid, patchmask) CALL block_data_division (topo_grid, areagrid) - IF (p_is_io) CALL allocate_block_data (gforc, maxelv_grid) + IF (p_is_active) CALL allocate_block_data (gforc, maxelv_grid) CALL mg2p_forc%pset2grid_max (forc_topo, maxelv_grid, msk = patchmask) @@ -273,7 +273,7 @@ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulc CALL mg2p_forc%grid2part (topo_grid, forc_topo_grid ) CALL mg2p_forc%grid2part (maxelv_grid, forc_maxelv_grid) - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN allocate (glacierss(numpatch)) glacierss(:) = patchtype(:) == 3 ENDIF @@ -334,7 +334,7 @@ SUBROUTINE forcing_final () IF (allocated(tstamp_UB )) deallocate(tstamp_UB ) IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN CALL mg2p_forc%deallocate_part (forc_topo_grid ) @@ -429,7 +429,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) real(r8), dimension(12, numpatch) :: spaceship !NOTE: 12 is the dimension size of spaceship integer target_server, ierr - IF (p_is_io) THEN + IF (p_is_active) THEN !------------------------------------------------------------ ! READ in THE ATMOSPHERIC FORCING ! read lower and upper boundary forcing data @@ -686,7 +686,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot ) CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO np = 1, numpatch @@ -751,7 +751,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) calday = calendarday(idate) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO np = 1, numpatch ! patches ! calculate albedo of each patches @@ -874,14 +874,14 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) CALL mg2p_forc%part2pset (forc_us_part, forc_us ) CALL mg2p_forc%part2pset (forc_vs_part, forc_vs ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN forc_psrf = forc_pbot ENDIF ENDIF ! wind downscaling - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (DEF_USE_Forcing_Downscaling) THEN DO np = 1, numpatch IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle @@ -904,7 +904,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) ! Sisi Chen, Lu Li, Yongjiu Dai et al., 2024, JGR ! Using MPI to pass the forcing variable field to Python to ! accomplish precipitation downscaling - IF (p_is_worker) THEN + IF (p_is_compute) THEN spaceship(1,1:numpatch) = forc_topo spaceship(2,1:numpatch) = forc_t spaceship(3,1:numpatch) = forc_pbot @@ -928,7 +928,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) ENDIF ! mapping forc_prl to forc_prl_part, forc_prc to forc_prc_part - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO np = 1, numpatch ! patches DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE @@ -956,7 +956,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) #endif ! divide fractions of downscaled shortwave radiation - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO j = 1, numpatch a = forc_swrad(j) IF (isnan_ud(a)) a = 0 @@ -990,7 +990,7 @@ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) write(*,'(/, A20)') 'Checking forcing ...' + IF (p_is_root) write(*,'(/, A20)') 'Checking forcing ...' CALL check_vector_data ('Forcing us [m/s] ', forc_us ) CALL check_vector_data ('Forcing vs [m/s] ', forc_vs ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 index bdaede3215..96cbcf9b47 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 @@ -280,7 +280,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL hist_write_time (file_hist, file_last, 'time', idate, itime_in_file) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (filter (numpatch)) allocate (filter_dt (numpatch)) @@ -300,7 +300,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (ghist, sumarea) CALL allocate_block_data (ghist, sumarea_dt) #ifdef URBAN_MODEL @@ -316,7 +316,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! --------------------------------------------------- ! Meteorological forcing and patch mask filter applying. ! --------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype < 99 @@ -346,7 +346,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF #ifdef CROP - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter_crop(:) = patchtype < 99 filter_crop(:) = patchclass == 12 @@ -371,7 +371,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (DEF_USE_IRRIGATION) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -479,7 +479,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! ------------------------------------------------------------------------------------------ ! Mapping the fluxes and state variables at patch [numpatch] to grid ! ------------------------------------------------------------------ - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype < 99 @@ -616,7 +616,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #ifdef DataAssimilation IF (DEF_DA_TWS_GRACE) THEN ! slope factors for runoff [-] - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN vecacc = fslp_k_mon(month, :) WHERE (vecacc /= spval) vecacc = vecacc*nac ENDIF @@ -664,7 +664,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'total water storage','mm') ! instantaneous total water storage [mm] - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN vecacc = wat WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF @@ -791,7 +791,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, & '2 m height air specific humidity','kg/kg') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype == 2 @@ -817,7 +817,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! wetland water storage [mm] IF (DEF_USE_Dynamic_Wetland) THEN - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN vecacc = a_wdsrf ENDIF CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & @@ -830,7 +830,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! instantaneous wetland water storage [mm] - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN vecacc = wetwat WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF @@ -838,7 +838,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_wetwat_inst', itime_in_file, sumarea, filter, & 'instantaneous wetland water storage','mm') - IF (p_is_worker .and. (numpatch > 0)) THEN + IF (p_is_compute .and. (numpatch > 0)) THEN vecacc = a_zwt ENDIF CALL write_history_variable_2d ( DEF_hist_vars%wetzwt, & @@ -850,7 +850,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! ------------------------------------------------------------------ #ifdef URBAN_MODEL - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i = 1, numpatch IF (patchtype(i) == 1) THEN @@ -974,7 +974,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! ------------------------------------------------------------------ ! Mapping the fluxes and state variables at patch [numpatch] to grid ! ------------------------------------------------------------------ - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype < 99 IF (DEF_forcing%has_missing_value) THEN @@ -1345,7 +1345,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'crop phase','unitless') ! heat unit index - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_hui (:) ENDIF @@ -1386,7 +1386,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'crop seed deficit','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -1406,7 +1406,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'fertilization','gN/m2/s') IF (DEF_USE_IRRIGATION) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -1431,7 +1431,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! total irrigation amounts at growing season - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_sum_irrig (:) ENDIF @@ -1441,7 +1441,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'total irrigation amounts at growing season','kg/m2') ! total irrigation amounts demand at growing season - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_sum_deficit_irrig (:) ENDIF @@ -1456,7 +1456,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'total irrigation times at growing season','-') ! irrigation waterstorage [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_waterstorage (:) ENDIF @@ -1466,7 +1466,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation waterstorage','kg/m2') ! irrigation demand for ground water [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_groundwater_demand (:) ENDIF @@ -1476,7 +1476,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation demand for ground water','kg/m2') ! irrigation supply from ground water [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_groundwater_supply (:) ENDIF @@ -1486,7 +1486,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation supply from ground water','kg/m2') ! irrigation demand for reservoir or river [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_reservoirriver_demand (:) ENDIF @@ -1496,7 +1496,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation demand for reservoir or river','kg/m2') ! irrigation supply from reservoir or river [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_reservoirriver_supply (:) ENDIF @@ -1506,7 +1506,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation supply from reservoir or river','kg/m2') ! irrigation supply from reservoir [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_reservoir_supply (:) ENDIF @@ -1516,7 +1516,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation supply from reservoir','kg/m2') ! irrigation supply from river [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_river_supply (:) ENDIF @@ -1526,7 +1526,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'irrigation supply from river','kg/m2') ! irrigation supply from runoff [kg/m2] - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_runoff_supply (:) ENDIF @@ -1969,7 +1969,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) .ne. 12 .and. patchtype(i) .eq. 0)THEN @@ -2337,7 +2337,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #ifdef CROP !***************************************** - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2353,7 +2353,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_manunitro (:) ENDIF @@ -2364,7 +2364,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'nitrogen in manure','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2384,7 +2384,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL mp2g_hist%get_sumarea (sumarea, filter) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_hui (:) ENDIF @@ -2394,7 +2394,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'heat unit index (rainfed spring wheat)','unitless') !************************************************************ -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2419,7 +2419,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdcorn, file_hist, 'f_pdcorn', & ! itime_in_file, sumarea, filter, 'planting date of corn', 'day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2443,7 +2443,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdswheat, file_hist, 'f_pdswheat', & ! itime_in_file, sumarea, filter,'planting date of spring wheat','day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2467,7 +2467,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdwwheat, file_hist, 'f_pdwwheat', & ! itime_in_file, sumarea, filter,'planting date of winter wheat','day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2492,7 +2492,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdsoybean, file_hist, 'f_pdsoybean', & ! itime_in_file, sumarea, filter,'planting date of soybean','day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2516,7 +2516,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdcotton, file_hist, 'f_pdcotton', & ! itime_in_file, sumarea, filter,'planting date of cotton','day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2540,7 +2540,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdrice1, file_hist, 'f_pdrice1', & ! itime_in_file, sumarea, filter,'planting date of rice1','day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2564,7 +2564,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdrice2, file_hist, 'f_pdrice2', & ! itime_in_file, sumarea, filter,'planting date of rice2','day') ! -! IF (p_is_worker) THEN +! IF (p_is_compute) THEN ! IF (numpatch > 0) THEN ! DO i=1,numpatch ! IF(patchclass(i) == 12)THEN @@ -2588,7 +2588,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! a_pdsugarcane, file_hist, 'f_pdsugarcane', & ! itime_in_file, sumarea, filter,'planting date of sugarcane','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2613,7 +2613,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_corn, file_hist, 'f_fertnitro_corn', & itime_in_file, sumarea, filter,'nitrogen fertilizer for corn','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2637,7 +2637,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_swheat, file_hist, 'f_fertnitro_swheat', & itime_in_file, sumarea, filter,'nitrogen fertilizer for spring wheat','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2661,7 +2661,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_wwheat, file_hist, 'f_fertnitro_wwheat', & itime_in_file, sumarea, filter,'nitrogen fertilizer for winter wheat','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2686,7 +2686,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_soybean, file_hist, 'f_fertnitro_soybean', & itime_in_file, sumarea, filter,'nitrogen fertilizer for soybean','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2710,7 +2710,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_cotton, file_hist, 'f_fertnitro_cotton', & itime_in_file, sumarea, filter,'nitrogen fertilizer for cotton','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2734,7 +2734,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_rice1, file_hist, 'f_fertnitro_rice1', & itime_in_file, sumarea, filter,'nitrogen fertilizer for rice1','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2758,7 +2758,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_rice2, file_hist, 'f_fertnitro_rice2', & itime_in_file, sumarea, filter,'nitrogen fertilizer for rice2','gN/m2/yr') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2783,7 +2783,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr') IF(DEF_USE_IRRIGATION)THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2807,7 +2807,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_corn, file_hist, 'f_irrig_method_corn', & itime_in_file, sumarea, filter,'irrigation method for corn','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2831,7 +2831,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', & itime_in_file, sumarea, filter,'irrigation method for spring wheat','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2855,7 +2855,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', & itime_in_file, sumarea, filter,'irrigation method for winter wheat','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2880,7 +2880,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', & itime_in_file, sumarea, filter,'irrigation method for soybean','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2904,7 +2904,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', & itime_in_file, sumarea, filter,'irrigation method for cotton','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2928,7 +2928,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', & itime_in_file, sumarea, filter,'irrigation method for rice1','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2952,7 +2952,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', & itime_in_file, sumarea, filter,'irrigation method for rice2','-') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2978,7 +2978,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -2999,7 +2999,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed temperate corn - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3008,7 +3008,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed temperate corn)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3029,7 +3029,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated temperate corn - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3038,7 +3038,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated temperate corn)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3060,7 +3060,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed spring wheat - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3069,7 +3069,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed spring wheat)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3091,7 +3091,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated spring wheat - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3100,7 +3100,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated spring wheat)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3121,7 +3121,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed winter wheat - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3130,7 +3130,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed winter wheat)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3151,7 +3151,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated winter wheat - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3160,7 +3160,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated winter wheat)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3181,7 +3181,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed temperate soybean - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3191,7 +3191,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop planting date (rainfed temperate soybean)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3212,7 +3212,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated temperate soybean - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3222,7 +3222,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop planting date (irrigated temperate soybean)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3243,7 +3243,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed cotton - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3252,7 +3252,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed cotton)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3273,7 +3273,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated cotton - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3282,7 +3282,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated cotton)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3303,7 +3303,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed rice - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3312,7 +3312,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed rice)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3333,7 +3333,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated rice - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3342,7 +3342,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated rice)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3363,7 +3363,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed sugarcane - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3372,7 +3372,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed sugarcane)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3393,7 +3393,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated sugarcane - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3402,7 +3402,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated sugarcane)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3423,7 +3423,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed trop corn - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3432,7 +3432,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed trop corn)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3453,7 +3453,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated trop corn - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3462,7 +3462,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated trop corn)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3483,7 +3483,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of rainfed trop soybean - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3493,7 +3493,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop planting date (rainfed trop soybean)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3514,7 +3514,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of irrigated trop soybean - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3524,7 +3524,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop planting date (irrigated trop soybean)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3546,7 +3546,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! planting date of unmanaged crop production - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_plantdate (:) ENDIF @@ -3555,7 +3555,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, & 'Crop planting date (unmanaged crop production)','day') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3576,7 +3576,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to corn production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3585,7 +3585,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_temp_corn', itime_in_file, sumarea, filter, & 'Crop production (rainfed temperate corn)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3606,7 +3606,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to corn production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3615,7 +3615,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_temp_corn', itime_in_file, sumarea, filter, & 'Crop production (irrigated temperate corn)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3636,7 +3636,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to spring wheat production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3645,7 +3645,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_spwheat', itime_in_file, sumarea, filter, & 'Crop production (rainfed spring wheat)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3666,7 +3666,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to spring wheat production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3675,7 +3675,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_spwheat', itime_in_file, sumarea, filter, & 'Crop production (irrigated spring wheat)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3696,7 +3696,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to winter wheat production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3705,7 +3705,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_wtwheat', itime_in_file, sumarea, filter, & 'Crop production (rainfed winter wheat)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3726,7 +3726,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to winter wheat production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3735,7 +3735,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_wtwheat', itime_in_file, sumarea, filter, & 'Crop production (irrigated winter wheat)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3756,7 +3756,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to soybean production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3766,7 +3766,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop production (rainfed temperate soybean)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3787,7 +3787,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to soybean production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3797,7 +3797,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop production (irrigated temperate soybean)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3818,7 +3818,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to cotton production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3827,7 +3827,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_cotton', itime_in_file, sumarea, filter, & 'Crop production (rainfed cotton)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3848,7 +3848,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to cotton production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3857,7 +3857,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_cotton', itime_in_file, sumarea, filter, & 'Crop production (irrigated cotton)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3878,7 +3878,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to rice production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3887,7 +3887,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_rice', itime_in_file, sumarea, filter, & 'Crop production (rainfed rice)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3908,7 +3908,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to rice production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3917,7 +3917,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_rice', itime_in_file, sumarea, filter, & 'Crop production (irrigated rice)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3938,7 +3938,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to sugarcane production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3947,7 +3947,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_sugarcane', itime_in_file, sumarea, filter, & 'Crop production (rainfed sugarcane)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3968,7 +3968,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to sugarcane production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -3977,7 +3977,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_sugarcane', itime_in_file, sumarea, filter, & 'Crop production (irrigated sugarcane)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -3998,7 +3998,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to sugarcane production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -4007,7 +4007,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_rainfed_trop_corn', itime_in_file, sumarea, filter, & 'Crop production (rainfed_trop_corn)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -4028,7 +4028,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to sugarcane production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -4037,7 +4037,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc, file_hist, 'f_cropprodc_irrigated_trop_corn', itime_in_file, sumarea, filter, & 'Crop production (irrigated_trop_corn)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -4058,7 +4058,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to sugarcane production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -4068,7 +4068,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop production (rainfed trop soybean)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -4089,7 +4089,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to sugarcane production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -4099,7 +4099,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & itime_in_file, sumarea, filter, & 'Crop production (irrigated trop soybean)','gC/m2/s') - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO i=1,numpatch IF(patchclass(i) == 12)THEN @@ -4120,7 +4120,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! grain to unmanaged crop production carbon - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN vecacc (:) = a_grainc_to_cropprodc (:) ENDIF @@ -4136,7 +4136,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! land water bodies => 4; ocean => 99] ! -------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype <= 3 @@ -4173,7 +4173,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #ifdef DataAssimilation - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (a_wliq_h2osoi_5cm (numpatch )); a_wliq_h2osoi_5cm = spval allocate (a_t_soisno_5cm (numpatch )); a_t_soisno_5cm = spval @@ -4194,7 +4194,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & allocate (a_t_brt_fy3d_ens_std (2,numpatch )); a_t_brt_fy3d_ens_std = spval END IF - IF (p_is_worker) THEN + IF (p_is_compute) THEN !############################################################################# ! States before DA !############################################################################# @@ -4293,12 +4293,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------------------------------------------- IF (HistForm == 'Gridded') THEN - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data(ghist, sumarea) END IF END IF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype <= 2 @@ -4350,7 +4350,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN deallocate (a_wliq_h2osoi_5cm) deallocate (a_t_soisno_5cm) deallocate (a_wliq_soisno_ens_mean) @@ -4375,7 +4375,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! land water bodies => 4; ocean => 99] ! -------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype <= 2 @@ -4427,7 +4427,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------------------------------------------- ! depth of surface water (including land ice and ocean patches) ! -------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = (patchtype <= 4) @@ -4450,7 +4450,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'water storage in aquifer','mm') ! instantaneous water storage in aquifer [mm] - IF (p_is_worker) THEN + IF (p_is_compute) THEN vecacc = wa WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF @@ -4464,7 +4464,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'depth of surface water','mm') ! instantaneous depth of surface water [mm] - IF (p_is_worker) THEN + IF (p_is_compute) THEN vecacc = wdsrf WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF @@ -4476,7 +4476,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! Land water bodies' ice fraction and temperature ! ----------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype == 4 IF (DEF_forcing%has_missing_value) THEN @@ -4525,7 +4525,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------- ! Retrieve through averaged fluxes ! -------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = patchtype < 99 @@ -4648,7 +4648,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'reflected diffuse beam nir solar radiation (W/m2)','W/m2') ! local noon fluxes - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN filter(:) = nac_ln > 0 IF (DEF_forcing%has_missing_value) THEN @@ -4702,7 +4702,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & 'reflected diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) - IF ((p_is_worker) .and. (numpatch > 0)) THEN + IF ((p_is_compute) .and. (numpatch > 0)) THEN filter = (patchtype == 0) .and. patchmask IF (DEF_forcing%has_missing_value) filter = filter .and. forcmask_pch ENDIF @@ -4718,7 +4718,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN CALL hist_out_cama (file_hist_cama, itime_in_file_cama) ENDIF #endif @@ -4731,7 +4731,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & CALL hist_grid_riverlake_out (file_hist, HistForm, idate, & itime_in_file, trim(file_hist)/=trim(file_last)) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (nac_one (numpatch)) nac_one = 1. @@ -4739,8 +4739,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF IF (HistForm == 'Gridded') THEN - IF (p_is_io) CALL allocate_block_data (ghist, sumarea_one) - IF (p_is_io) CALL flush_block_data (sumarea_one, 1.) + IF (p_is_active) CALL allocate_block_data (ghist, sumarea_one) + IF (p_is_active) CALL flush_block_data (sumarea_one, 1.) ENDIF CALL write_history_variable_2d ( DEF_hist_vars%riv_height, a_wdsrf_ucat_pch, & @@ -4822,10 +4822,10 @@ SUBROUTINE write_history_variable_2d ( is_hist, & #ifndef SinglePoint IF ( .not. present(acc_num) ) THEN - IF (p_is_worker) & + IF (p_is_compute) & WHERE (acc_vec /= spval) acc_vec = acc_vec / nac ELSE - IF (p_is_worker) & + IF (p_is_compute) & WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num ENDIF #else @@ -4983,10 +4983,10 @@ SUBROUTINE write_history_variable_4d ( is_hist, & #ifndef SinglePoint IF ( .not. present(acc_num) ) THEN - IF (p_is_worker) & + IF (p_is_compute) & WHERE (acc_vec /= spval) acc_vec = acc_vec / nac ELSE - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO i1 = lbound(acc_vec,1), ubound(acc_vec,1) DO i2 = lbound(acc_vec,2), ubound(acc_vec,2) WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) & diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 index 8b3083c58b..f2e366dfd8 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 @@ -78,7 +78,7 @@ SUBROUTINE hist_gridded_init (dir_hist, lulcc_call) CALL mp2g_hist_urb%build_arealweighted (ghist, landurban) #endif - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (ghist, landfraction) CALL allocate_block_data (ghist, gridarea) @@ -136,7 +136,7 @@ SUBROUTINE flux_map_and_write_2d ( & integer :: iblkme, xblk, yblk, xloc, yloc integer :: compress - IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) + IF (p_is_active) CALL allocate_block_data (ghist, flux_xy_2d) IF (present(input_mode)) THEN CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter, input_mode = input_mode) @@ -144,7 +144,7 @@ SUBROUTINE flux_map_and_write_2d ( & CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) @@ -199,12 +199,12 @@ SUBROUTINE flux_map_and_write_urb_2d ( & integer :: iblkme, xblk, yblk, xloc, yloc integer :: compress - IF (p_is_worker) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - IF (p_is_io) CALL allocate_block_data (ghist, flux_xy_2d) + IF (p_is_compute) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac + IF (p_is_active) CALL allocate_block_data (ghist, flux_xy_2d) CALL mp2g_hist_urb%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) @@ -261,16 +261,16 @@ SUBROUTINE flux_map_and_write_3d ( & integer :: iblkme, xblk, yblk, xloc, yloc, i1 integer :: compress - IF (p_is_worker) THEN + IF (p_is_compute) THEN WHERE (acc_vec /= spval) acc_vec = acc_vec / nac ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (ghist, flux_xy_3d, ndim1, lb1) ENDIF CALL mp2g_hist%pset2grid (acc_vec, flux_xy_3d, spv = spval, msk = filter) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) @@ -329,13 +329,13 @@ SUBROUTINE flux_map_and_write_4d ( & integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2 integer :: compress - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (ghist, flux_xy_4d, ndim1, ndim2, lb1 = lb1, lb2 = lb2) ENDIF CALL mp2g_hist%pset2grid (acc_vec, flux_xy_4d, spv = spval, msk = filter) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) yblk = gblock%yblkme(iblkme) @@ -389,7 +389,7 @@ SUBROUTINE hist_gridded_write_time ( & logical :: fexists IF (trim(DEF_HIST_mode) == 'one') THEN - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI IF (DEF_HIST_WriteBack) THEN CALL hist_writeback_latlon_time (filename, filelast, dataname, time, hist_concat) @@ -431,12 +431,12 @@ SUBROUTINE hist_gridded_write_time ( & ENDIF #ifdef USEMPI - CALL mpi_bcast (itime, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (itime, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #endif ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -459,7 +459,7 @@ SUBROUTINE hist_gridded_write_time ( & ENDIF #ifdef USEMPI - IF (.not. p_is_master) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) + IF (.not. p_is_root) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) #endif ENDIF @@ -494,7 +494,7 @@ SUBROUTINE hist_write_var_real8_2d ( & IF (trim(DEF_HIST_mode) == 'one') THEN - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN @@ -583,7 +583,7 @@ SUBROUTINE hist_write_var_real8_2d ( & ENDIF #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN DO iyseg = 1, hist_concat%nyseg DO ixseg = 1, hist_concat%nxseg @@ -603,9 +603,9 @@ SUBROUTINE hist_write_var_real8_2d ( & IF (.not. DEF_HIST_WriteBack) THEN smesg = (/p_iam_glb, ixseg, iyseg/) CALL mpi_send (smesg, 3, MPI_INTEGER, & - p_address_master, hist_data_id, p_comm_glb, p_err) + p_address_root, hist_data_id, p_comm_glb, p_err) CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, & - p_address_master, hist_data_id, p_comm_glb, p_err) + p_address_root, hist_data_id, p_comm_glb, p_err) ELSE CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata2d = sbuf) ENDIF @@ -622,7 +622,7 @@ SUBROUTINE hist_write_var_real8_2d ( & ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -678,7 +678,7 @@ SUBROUTINE hist_write_var_real8_3d ( & IF (trim(DEF_HIST_mode) == 'one') THEN - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN @@ -767,7 +767,7 @@ SUBROUTINE hist_write_var_real8_3d ( & ENDIF #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN DO iyseg = 1, hist_concat%nyseg DO ixseg = 1, hist_concat%nxseg @@ -789,9 +789,9 @@ SUBROUTINE hist_write_var_real8_3d ( & IF (.not. DEF_HIST_WriteBack) THEN smesg = (/p_iam_glb, ixseg, iyseg, ndim1/) CALL mpi_send (smesg, 4, MPI_INTEGER, & - p_address_master, hist_data_id, p_comm_glb, p_err) + p_address_root, hist_data_id, p_comm_glb, p_err) CALL mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_REAL8, & - p_address_master, hist_data_id, p_comm_glb, p_err) + p_address_root, hist_data_id, p_comm_glb, p_err) ELSE CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata3d = sbuf) ENDIF @@ -807,7 +807,7 @@ SUBROUTINE hist_write_var_real8_3d ( & ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -858,7 +858,7 @@ SUBROUTINE hist_write_var_real8_4d ( & IF (trim(DEF_HIST_mode) == 'one') THEN - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI IF (.not. DEF_HIST_WriteBack) THEN @@ -954,7 +954,7 @@ SUBROUTINE hist_write_var_real8_4d ( & ENDIF #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN DO iyseg = 1, hist_concat%nyseg DO ixseg = 1, hist_concat%nxseg @@ -977,9 +977,9 @@ SUBROUTINE hist_write_var_real8_4d ( & IF (.not. DEF_HIST_WriteBack) THEN smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/) CALL mpi_send (smesg, 5, MPI_INTEGER, & - p_address_master, hist_data_id, p_comm_glb, p_err) + p_address_root, hist_data_id, p_comm_glb, p_err) CALL mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & - p_address_master, hist_data_id, p_comm_glb, p_err) + p_address_root, hist_data_id, p_comm_glb, p_err) ELSE CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata4d = sbuf) ENDIF @@ -994,7 +994,7 @@ SUBROUTINE hist_write_var_real8_4d ( & hist_data_id = mod(hist_data_id-10000,10000) + 100001 ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 index e1e48adf9f..3311b4e2e2 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 @@ -46,7 +46,7 @@ SUBROUTINE hist_vector_write_time (filename, filelast, dataname, time, itime_in_ ! Local Variables logical :: fexists - IF (p_is_master) THEN + IF (p_is_root) THEN inquire (file=filename, exist=fexists) IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN @@ -115,7 +115,7 @@ SUBROUTINE aggregate_to_vector_and_write_2d ( & CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef CATCHMENT numset = numhru #else @@ -165,15 +165,15 @@ SUBROUTINE aggregate_to_vector_and_write_2d ( & #ifdef USEMPI mesg = (/p_iam_glb, numset/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN CALL mpi_send (acc_vec, numset, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef CATCHMENT totalnumset = totalnumhru @@ -186,7 +186,7 @@ SUBROUTINE aggregate_to_vector_and_write_2d ( & ENDIF #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -198,9 +198,9 @@ SUBROUTINE aggregate_to_vector_and_write_2d ( & mpi_tag_data, p_comm_glb, p_stat, p_err) #ifdef CATCHMENT - acc_vec(hru_data_address(p_itis_worker(isrc))%val) = rcache + acc_vec(hru_data_address(p_itis_compute(isrc))%val) = rcache #else - acc_vec(elm_data_address(p_itis_worker(isrc))%val) = rcache + acc_vec(elm_data_address(p_itis_compute(isrc))%val) = rcache #endif deallocate (rcache) @@ -215,7 +215,7 @@ SUBROUTINE aggregate_to_vector_and_write_2d ( & #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN compress = DEF_HIST_CompressLevel @@ -290,7 +290,7 @@ SUBROUTINE aggregate_to_vector_and_write_3d ( & ub1 = lb1 + ndim1 - 1 - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef CATCHMENT numset = numhru #else @@ -336,15 +336,15 @@ SUBROUTINE aggregate_to_vector_and_write_3d ( & #ifdef USEMPI mesg = (/p_iam_glb, numset/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN CALL mpi_send (acc_vec, ndim1 * numset, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef CATCHMENT totalnumset = totalnumhru @@ -357,7 +357,7 @@ SUBROUTINE aggregate_to_vector_and_write_3d ( & ENDIF #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -370,9 +370,9 @@ SUBROUTINE aggregate_to_vector_and_write_3d ( & DO i1 = 1, ndim1 #ifdef CATCHMENT - acc_vec(i1,hru_data_address(p_itis_worker(isrc))%val) = rcache(i1,:) + acc_vec(i1,hru_data_address(p_itis_compute(isrc))%val) = rcache(i1,:) #else - acc_vec(i1,elm_data_address(p_itis_worker(isrc))%val) = rcache(i1,:) + acc_vec(i1,elm_data_address(p_itis_compute(isrc))%val) = rcache(i1,:) #endif ENDDO @@ -391,7 +391,7 @@ SUBROUTINE aggregate_to_vector_and_write_3d ( & #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_define_dimension (file_hist, dim1name, ndim1) @@ -471,7 +471,7 @@ SUBROUTINE aggregate_to_vector_and_write_4d ( & ub1 = lb1 + ndim1 - 1 ub2 = lb2 + ndim2 - 1 - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef CATCHMENT numset = numhru #else @@ -519,15 +519,15 @@ SUBROUTINE aggregate_to_vector_and_write_4d ( & #ifdef USEMPI mesg = (/p_iam_glb, numset/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numset > 0) THEN CALL mpi_send (acc_vec, ndim1 * ndim2 * numset, MPI_REAL8, & - p_address_master, mpi_tag_data, p_comm_glb, p_err) + p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef CATCHMENT totalnumset = totalnumhru @@ -540,7 +540,7 @@ SUBROUTINE aggregate_to_vector_and_write_4d ( & ENDIF #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -554,9 +554,9 @@ SUBROUTINE aggregate_to_vector_and_write_4d ( & DO i1 = 1, ndim1 DO i2 = 1, ndim2 #ifdef CATCHMENT - acc_vec(i1,i2,hru_data_address(p_itis_worker(isrc))%val) = rcache(i1,i2,:) + acc_vec(i1,i2,hru_data_address(p_itis_compute(isrc))%val) = rcache(i1,i2,:) #else - acc_vec(i1,i2,elm_data_address(p_itis_worker(isrc))%val) = rcache(i1,i2,:) + acc_vec(i1,i2,elm_data_address(p_itis_compute(isrc))%val) = rcache(i1,i2,:) #endif ENDDO ENDDO @@ -577,7 +577,7 @@ SUBROUTINE aggregate_to_vector_and_write_4d ( & #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_define_dimension (file_hist, dim1name, ndim1) CALL ncio_define_dimension (file_hist, dim2name, ndim2) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 index 9721ad25a9..05397d1516 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 @@ -387,19 +387,19 @@ SUBROUTINE hist_writeback_latlon_time (filename, filelast, timename, time, HistC lasttime%next => null() CALL mpi_isend (dataid_zero, 1, MPI_INTEGER, & - p_address_writeback, tag_next, p_comm_glb_plus, req_zero, p_err) + p_address_history_task, tag_next, p_comm_glb_plus, req_zero, p_err) CALL mpi_isend (lasttime%filename, 256, MPI_CHARACTER, & - p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(1), p_err) + p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(1), p_err) CALL mpi_isend (lasttime%filelast, 256, MPI_CHARACTER, & - p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(2), p_err) + p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(2), p_err) CALL mpi_isend (lasttime%timename, 256, MPI_CHARACTER, & - p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(3), p_err) + p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(3), p_err) CALL mpi_isend (lasttime%time, 3, MPI_INTEGER, & - p_address_writeback, tag_time, p_comm_glb_plus, lasttime%req(4), p_err) + p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(4), p_err) IF (.not. SDimInited) THEN @@ -423,20 +423,20 @@ SUBROUTINE hist_writeback_latlon_time (filename, filelast, timename, time, HistC yGridCnt(i) = HistConcat%ysegs(i)%cnt ENDDO - CALL mpi_send (nGridData, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (nGridData, 1, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (nxGridSeg, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (nxGridSeg, 1, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (nyGridSeg, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (nyGridSeg, 1, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (xGridDsp, nxGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (xGridDsp, nxGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (xGridCnt, nxGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (xGridCnt, nxGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (yGridDsp, nyGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (yGridDsp, nyGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (yGridCnt, nyGridSeg, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (yGridCnt, nyGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) nlat = HistConcat%ginfo%nlat @@ -448,21 +448,21 @@ SUBROUTINE hist_writeback_latlon_time (filename, filelast, timename, time, HistC allocate(lon_w(nlon)); lon_w = HistConcat%ginfo%lon_w allocate(lon_e(nlon)); lon_e = HistConcat%ginfo%lon_e - CALL mpi_send (nlat, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (nlat, 1, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (lat_c, nlat, MPI_REAL8, p_address_writeback, tag_dims, & + CALL mpi_send (lat_c, nlat, MPI_REAL8, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (lat_s, nlat, MPI_REAL8, p_address_writeback, tag_dims, & + CALL mpi_send (lat_s, nlat, MPI_REAL8, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (lat_n, nlat, MPI_REAL8, p_address_writeback, tag_dims, & + CALL mpi_send (lat_n, nlat, MPI_REAL8, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (nlon, 1, MPI_INTEGER, p_address_writeback, tag_dims, & + CALL mpi_send (nlon, 1, MPI_INTEGER, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (lon_c, nlon, MPI_REAL8, p_address_writeback, tag_dims, & + CALL mpi_send (lon_c, nlon, MPI_REAL8, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (lon_w, nlon, MPI_REAL8, p_address_writeback, tag_dims, & + CALL mpi_send (lon_w, nlon, MPI_REAL8, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) - CALL mpi_send (lon_e, nlon, MPI_REAL8, p_address_writeback, tag_dims, & + CALL mpi_send (lon_e, nlon, MPI_REAL8, p_address_history_task, tag_dims, & p_comm_glb_plus, p_err) SDimInited = .true. @@ -549,14 +549,14 @@ SUBROUTINE hist_writeback_var_header (dataid, filename, dataname, & LastSendBuffer%sendchar(9) = units CALL mpi_isend (LastSendBuffer%dataid, 1, MPI_INTEGER, & - p_address_writeback, tag_next, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) + p_address_history_task, tag_next, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) CALL mpi_isend (LastSendBuffer%sendint4(1:2), 2, MPI_INTEGER, & - p_address_writeback, LastSendBuffer%datatag, & + p_address_history_task, LastSendBuffer%datatag, & p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) CALL mpi_isend (LastSendBuffer%sendchar, 256*9, MPI_CHARACTER, & - p_address_writeback, LastSendBuffer%datatag, & + p_address_history_task, LastSendBuffer%datatag, & p_comm_glb_plus, LastSendBuffer%sendreqs(3), p_err) END SUBROUTINE hist_writeback_var_header @@ -644,11 +644,11 @@ SUBROUTINE hist_writeback_var ( dataid, ixseg, iyseg, & LastSendBuffer%sendint4(1:5) = (/p_iam_glb_plus, ixseg, iyseg, ndim1, ndim2/) CALL mpi_isend (LastSendBuffer%sendint4(1:5), 5, MPI_INTEGER, & - p_address_writeback, LastSendBuffer%datatag, & + p_address_history_task, LastSendBuffer%datatag, & p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) CALL mpi_isend (LastSendBuffer%senddata, totalsize, MPI_REAL8, & - p_address_writeback, LastSendBuffer%datatag, & + p_address_history_task, LastSendBuffer%datatag, & p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) END SUBROUTINE hist_writeback_var @@ -702,13 +702,13 @@ SUBROUTINE hist_writeback_exit () IF (allocated(lon_e )) deallocate(lon_e ) - IF (.not. p_is_writeback) THEN + IF (.not. p_is_history_task) THEN CALL mpi_barrier (p_comm_glb, p_err) ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN dataid = -1 - CALL mpi_send (dataid, 1, MPI_INTEGER, p_address_writeback, & + CALL mpi_send (dataid, 1, MPI_INTEGER, p_address_history_task, & tag_next, p_comm_glb_plus, p_err) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 index 26703c90c0..367999943b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 @@ -110,7 +110,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch @@ -189,7 +189,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 index ba27853eb1..4fcb84bd62 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 @@ -132,14 +132,14 @@ SUBROUTINE update_ndep_data_annually (YY, iswrite) itime = max(min(YY,2006),1849) - 1848 - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_ndep, f_xy_ndep) CALL ncio_read_block_time (file_ndep, 'NDEP_year', grid_ndep, itime, f_xy_ndep) ENDIF CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) - IF (p_is_worker .and. iswrite) THEN + IF (p_is_compute .and. iswrite) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) @@ -195,14 +195,14 @@ SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) itime = (max(min(YY,2006),1849) - 1849)*12 + MM - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_ndep, f_xy_ndep) CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) ENDIF CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) - IF (p_is_worker .and. iswrite) THEN + IF (p_is_compute .and. iswrite) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 index d6e73fed5b..21729cfff0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 @@ -83,12 +83,12 @@ SUBROUTINE update_nitrif_data (month) character(len=2) :: cx integer :: nsl, npatch, m - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate(tCONC_O2_UNSAT_tmp (numpatch)) allocate(tO2_DECOMP_DEPTH_UNSAT_tmp(numpatch)) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_nitrif, f_xy_nitrif) ENDIF @@ -97,14 +97,14 @@ SUBROUTINE update_nitrif_data (month) write(cx,'(i2.2)') nsl file_nitrif = trim(DEF_dir_runtime)//& '/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l'//trim(cx)//'.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block_time (file_nitrif, & 'CONC_O2_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tCONC_O2_UNSAT_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) @@ -131,14 +131,14 @@ SUBROUTINE update_nitrif_data (month) write(cx,'(i2.2)') nsl file_nitrif = trim(DEF_dir_runtime)//& '/nitrif/O2_DECOMP_DEPTH_UNSAT/O2_DECOMP_DEPTH_UNSAT_l'//trim(cx)//'.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block_time (file_nitrif, & 'O2_DECOMP_DEPTH_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) @@ -160,7 +160,7 @@ SUBROUTINE update_nitrif_data (month) CALL check_vector_data ('O2_DECOMP_DEPTH_UNSAT', tO2_DECOMP_DEPTH_UNSAT) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN deallocate (tCONC_O2_UNSAT_tmp) deallocate (tO2_DECOMP_DEPTH_UNSAT_tmp) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 index 2cb85a9df9..74df71130c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 @@ -500,7 +500,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Error check for snow grain size: #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." @@ -1027,7 +1027,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN flg_dover = 0 #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) @@ -1053,7 +1053,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) IF (abs(energy_sum) > 0.00001_r8) THEN #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum CALL abort ENDIF @@ -1065,7 +1065,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Check that albedo is less than 1 IF (albout_lcl(bnd_idx) > 1.0) THEN #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & @@ -1511,7 +1511,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN snw_shp_lcl(:) = snow_shape_koch_snowflake ELSE - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "snow_shape = ", snow_shape CALL abort ENDIF @@ -1533,7 +1533,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type CALL abort ENDIF @@ -1615,7 +1615,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) ! Error check for snow grain size: - IF (p_is_master) THEN + IF (p_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." @@ -2248,7 +2248,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & flx_abs_lcl(i,bnd_idx) = F_abs(i) ! ERROR check: negative absorption - IF (p_is_master) THEN + IF (p_is_root) THEN IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) @@ -2301,7 +2301,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! Energy conservation check: ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) - IF (p_is_master) THEN + IF (p_is_root) THEN IF (abs(energy_sum) > 0.00001_r8) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum write(iulog,*) "F_abs_sum: ",F_abs_sum @@ -2318,7 +2318,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & albout_lcl(bnd_idx) = albedo ! Check that albedo is less than 1 - IF (p_is_master) THEN + IF (p_is_root) THEN IF (albout_lcl(bnd_idx) > 1.0) THEN write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx @@ -2607,7 +2607,7 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz ,& IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN dr_fresh = 0.0_r8 ELSEIF ( dr_fresh < 0.0_r8 ) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min CALL abort ENDIF @@ -2749,7 +2749,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type CALL abort ENDIF @@ -2757,7 +2757,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ! ! Open optics file: - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Attempting to read snow optical properties .....' write(iulog,*) subname,trim(fsnowoptics) ENDIF @@ -2781,7 +2781,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) #ifdef MODAL_AER ! size-dependent BC parameters and BC enhancement factors - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' ENDIF ! @@ -2848,13 +2848,13 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ! ! - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Successfully read snow optical properties' ENDIF ! print some diagnostics: - IF (p_is_master) THEN + IF (p_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) @@ -2869,7 +2869,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF ! #ifdef MODAL_AER - IF (p_is_master) THEN + IF (p_is_root) THEN ! unique dimensionality for modal aerosol optical properties write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) @@ -2882,7 +2882,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) ENDIF #else - IF (p_is_master) THEN + IF (p_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & @@ -2890,7 +2890,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF #endif - IF (p_is_master) THEN + IF (p_is_root) THEN IF (DO_SNO_OC) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) @@ -2923,7 +2923,7 @@ SUBROUTINE SnowAge_init( fsnowaging ) character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name ! ! Open snow aging (effective radius evolution) file: - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Attempting to read snow aging parameters .....' write(iulog,*) subname,trim(fsnowaging) ENDIF @@ -2936,12 +2936,12 @@ SUBROUTINE SnowAge_init( fsnowaging ) CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) ! - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Successfully read snow aging properties' ENDIF ! ! print some diagnostics: - IF (p_is_master) THEN + IF (p_is_root) THEN write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 index 98a3ef8b5b..10dad47088 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 @@ -497,7 +497,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Error check for snow grain size: #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." @@ -1024,7 +1024,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN flg_dover = 0 #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) @@ -1050,7 +1050,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) IF (abs(energy_sum) > 0.00001_r8) THEN #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum CALL abort ENDIF @@ -1062,7 +1062,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Check that albedo is less than 1 IF (albout_lcl(bnd_idx) > 1.0) THEN #ifndef _OPENACC - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & @@ -1507,7 +1507,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN snw_shp_lcl(:) = snow_shape_koch_snowflake ELSE - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "snow_shape = ", snow_shape CALL abort ENDIF @@ -1529,7 +1529,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type CALL abort ENDIF @@ -1611,7 +1611,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) ! Error check for snow grain size: - IF (p_is_master) THEN + IF (p_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." @@ -2244,7 +2244,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & flx_abs_lcl(i,bnd_idx) = F_abs(i) ! ERROR check: negative absorption - IF (p_is_master) THEN + IF (p_is_root) THEN IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) @@ -2297,7 +2297,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! Energy conservation check: ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) - IF (p_is_master) THEN + IF (p_is_root) THEN IF (abs(energy_sum) > 0.00001_r8) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum write(iulog,*) "F_abs_sum: ",F_abs_sum @@ -2314,7 +2314,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & albout_lcl(bnd_idx) = albedo ! Check that albedo is less than 1 - IF (p_is_master) THEN + IF (p_is_root) THEN IF (albout_lcl(bnd_idx) > 1.0) THEN write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx @@ -2603,7 +2603,7 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz , & IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN dr_fresh = 0.0_r8 ELSEIF ( dr_fresh < 0.0_r8 ) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min CALL abort ENDIF @@ -2745,7 +2745,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type CALL abort ENDIF @@ -2753,7 +2753,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ! ! Open optics file: - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Attempting to read snow optical properties .....' write(iulog,*) subname,trim(fsnowoptics) ENDIF @@ -2777,7 +2777,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) #ifdef MODAL_AER ! size-dependent BC parameters and BC enhancement factors - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' ENDIF ! @@ -2844,13 +2844,13 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ! ! - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Successfully read snow optical properties' ENDIF ! print some diagnostics: - IF (p_is_master) THEN + IF (p_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) @@ -2865,7 +2865,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF ! #ifdef MODAL_AER - IF (p_is_master) THEN + IF (p_is_root) THEN ! unique dimensionality for modal aerosol optical properties write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) @@ -2878,7 +2878,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) ENDIF #else - IF (p_is_master) THEN + IF (p_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & @@ -2886,7 +2886,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF #endif - IF (p_is_master) THEN + IF (p_is_root) THEN IF (DO_SNO_OC) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) @@ -2919,7 +2919,7 @@ SUBROUTINE SnowAge_init( fsnowaging ) character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name ! ! Open snow aging (effective radius evolution) file: - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Attempting to read snow aging parameters .....' write(iulog,*) subname,trim(fsnowaging) ENDIF @@ -2932,12 +2932,12 @@ SUBROUTINE SnowAge_init( fsnowaging ) CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) ! - IF (p_is_master) THEN + IF (p_is_root) THEN write(iulog,*) 'Successfully read snow aging properties' ENDIF ! ! print some diagnostics: - IF (p_is_master) THEN + IF (p_is_root) THEN write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 index 0f0bb1da03..ee50c2aa0f 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 @@ -498,7 +498,7 @@ SUBROUTINE allocate_acc_fluxes USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (a_us (numpatch)) @@ -978,7 +978,7 @@ SUBROUTINE allocate_acc_fluxes CALL allocate_LakeAccVars #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN CALL elm_patch%build (landelm, landpatch, use_frac = .true.) ENDIF @@ -991,7 +991,7 @@ SUBROUTINE deallocate_acc_fluxes () USE MOD_LandUrban, only: numurban IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN deallocate (a_us ) @@ -1484,7 +1484,7 @@ SUBROUTINE FLUSH_acc_fluxes () USE MOD_Vars_Global, only: spval IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN nac = 0 @@ -2029,7 +2029,7 @@ SUBROUTINE accumulate_fluxes real(r8) obu,fh2m,fq2m real(r8) um,thvstar,beta,zii,wc,wc2 - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN ! count for time steps diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 index 9238a3410d..1eed919be9 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 @@ -112,7 +112,7 @@ SUBROUTINE allocate_1D_Fluxes USE MOD_LandPatch IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -211,7 +211,7 @@ SUBROUTINE deallocate_1D_Fluxes () USE MOD_SPMD_Task USE MOD_LandPatch - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 index 6075b103de..d071335bc7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 @@ -65,7 +65,7 @@ SUBROUTINE allocate_1D_Forcing USE MOD_LandPatch IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -118,7 +118,7 @@ SUBROUTINE deallocate_1D_Forcing () USE MOD_LandPatch IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 index e7ba1d5ec5..0809c19479 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 @@ -60,7 +60,7 @@ SUBROUTINE allocate_1D_PFTFluxes USE MOD_LandPFT IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN allocate (taux_p (numpft)) ; taux_p (:) = spval !wind stress: E-W [kg/m/s2] @@ -96,7 +96,7 @@ SUBROUTINE deallocate_1D_PFTFluxes USE MOD_SPMD_Task USE MOD_LandPFT - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN deallocate (taux_p ) @@ -138,7 +138,7 @@ SUBROUTINE set_1D_PFTFluxes(Values, Nan) real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN taux_p (:) = Values !wind stress: E-W [kg/m/s2] diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 index ca17147eb1..e0c961ef9e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 @@ -51,7 +51,7 @@ SUBROUTINE allocate_2D_Forcing (grid) type(grid_type), intent(in) :: grid - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid, forc_xy_pco2m ) ! CO2 concentration in atmos. (pascals) CALL allocate_block_data (grid, forc_xy_po2m ) ! O2 concentration in atmos. (pascals) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 index 7496c1ec85..92efbe9460 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 @@ -55,7 +55,7 @@ SUBROUTINE allocate_PFTimeInvariants USE MOD_Precision IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN allocate (pftclass (numpft)) allocate (pftfrac (numpft)) @@ -128,7 +128,7 @@ SUBROUTINE deallocate_PFTimeInvariants USE MOD_SPMD_Task USE MOD_LandPFT - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN deallocate (pftclass) deallocate (pftfrac ) @@ -314,7 +314,7 @@ SUBROUTINE allocate_TimeInvariants () USE MOD_LandPatch, only: numpatch IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -506,7 +506,7 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] #endif #ifdef DataAssimilation - IF (numpatch > 0 .and. p_is_worker) wf_silt = 1.0_r8 - wf_gravels - wf_sand - wf_clay - wf_om + IF (numpatch > 0 .and. p_is_compute) wf_silt = 1.0_r8 - wf_gravels - wf_sand - wf_clay - wf_om #endif CALL ncio_read_vector (file_restart, 'soiltext', landpatch, soiltext, defval = 0 ) @@ -613,7 +613,7 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Loading Time Invariants done.' ENDIF @@ -647,7 +647,7 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) write(cyear,'(i4.4)') lc_year - IF (p_is_master) THEN + IF (p_is_root) THEN CALL system('mkdir -p ' // trim(dir_restart)//'/const') ENDIF #ifdef USEMPI @@ -781,7 +781,7 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) then + if (p_is_root) then #if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) CALL ncio_create_file (file_restart) @@ -840,7 +840,7 @@ SUBROUTINE deallocate_TimeInvariants () ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -971,7 +971,7 @@ SUBROUTINE check_TimeInvariants () real(r8), allocatable :: tmpcheck(:,:) - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(/,A29)') 'Checking Time Invariants ...' ENDIF @@ -1084,7 +1084,7 @@ SUBROUTINE check_TimeInvariants () CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(/,A)') 'Checking Constants ...' write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 index 6ebc93b313..e95f9084c5 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 @@ -100,7 +100,7 @@ SUBROUTINE allocate_PFTimeVariables () USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN allocate (tleaf_p (numpft)) ; tleaf_p (:) = spval !leaf temperature [K] allocate (ldew_p (numpft)) ; ldew_p (:) = spval !depth of water on foliage [mm] @@ -298,7 +298,7 @@ SUBROUTINE deallocate_PFTimeVariables USE MOD_SPMD_Task USE MOD_LandPFT - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpft > 0) THEN deallocate (tleaf_p ) ! leaf temperature [K] deallocate (ldew_p ) ! depth of water on foliage [mm] @@ -635,7 +635,7 @@ SUBROUTINE allocate_TimeVariables IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -843,7 +843,7 @@ SUBROUTINE deallocate_TimeVariables () ! Deallocates memory for CoLM 1d [numpatch] variables !-------------------------------------------------------------------- - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN @@ -1107,7 +1107,7 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) write(cyear,'(i4.4)') lc_year write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) ENDIF #ifdef COLM_PARALLEL @@ -1324,7 +1324,7 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Loading Time Variables ...' ENDIF @@ -1492,7 +1492,7 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) CALL check_TimeVariables #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Loading Time Variables done.' ENDIF @@ -1513,7 +1513,7 @@ SUBROUTINE check_TimeVariables () #ifdef COLM_PARALLEL CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(/,A27)') 'Checking Time Variables ...' ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 index c892e935c2..ea31551991 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 @@ -74,14 +74,14 @@ SUBROUTINE vicpara_readin () CALL grid_Ds%define_by_center (lat, lon) CALL grid_DsM%define_by_center (lat, lon) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_b_infilt, f_xy_b_infilt) CALL allocate_block_data (grid_Ws, f_xy_Ws) CALL allocate_block_data (grid_Ds, f_xy_Ds) CALL allocate_block_data (grid_DsM, f_xy_DsM) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL ncio_read_block (file_vic_para,'b', grid_b_infilt, f_xy_b_infilt) CALL ncio_read_block (file_vic_para,'Ws', grid_Ws, f_xy_Ws) CALL ncio_read_block (file_vic_para,'Ds', grid_Ds, f_xy_Ds) @@ -98,7 +98,7 @@ SUBROUTINE vicpara_readin () IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) allocate (b_infilt_tmp (numpatch)) IF (numpatch > 0) allocate (Ws_tmp (numpatch)) IF (numpatch > 0) allocate (Ds_tmp (numpatch)) @@ -110,7 +110,7 @@ SUBROUTINE vicpara_readin () CALL mg2patch_Ds%grid2pset (f_xy_Ds, Ds_tmp(:)) CALL mg2patch_DsM%grid2pset (f_xy_DsM, DsM_tmp(:)) - IF (p_is_worker) THEN + IF (p_is_compute) THEN vic_b_infilt(:) = -9999 vic_Dsmax(:) = -9999 vic_Ds(:) = -9999 @@ -118,7 +118,7 @@ SUBROUTINE vicpara_readin () vic_c = 2 ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipft = 1, numpatch !WRITE(*,*) 'Values of vic_b_infilt: ', DsM_tmp(ipft) vic_b_infilt(ipft) = b_infilt_tmp(ipft) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 index 7a5abebb4a..a1d8c4b3d4 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 @@ -33,7 +33,7 @@ SUBROUTINE Opt_Baseflow_init () file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' CALL ncio_read_vector (file_restart, 'scale_baseflow', landpatch, scale_baseflow, defval = 1.) - IF (p_is_master) THEN + IF (p_is_root) THEN CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt') ENDIF #ifdef USEMPI @@ -42,7 +42,7 @@ SUBROUTINE Opt_Baseflow_init () IF (DEF_Optimize_Baseflow) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (zwt_init (numpatch)); zwt_init (:) = zwt allocate (rchg_year (numpatch)); rchg_year (:) = spval @@ -80,7 +80,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) IF (DEF_Optimize_Baseflow .and. is_spinup) THEN - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (recharge(numpatch)); recharge(:) = spval @@ -102,7 +102,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) iter_bf_opt = iter_bf_opt + 1 write(strcyc,'(A1,I4.4)') 'c', iter_bf_opt - IF (p_is_master) THEN + IF (p_is_root) THEN CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt/'//strcyc) ENDIF #ifdef USEMPI @@ -117,7 +117,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) CALL ncio_write_vector (file_restart, 'total_recharge', 'patch', landpatch, rchg_year, 1) CALL ncio_write_vector (file_restart, 'total_subsurface_runoff', 'patch', landpatch, rsub_year, 1) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ipatch = 1, numpatch IF (patchtype(ipatch) <= 1) THEN @@ -148,7 +148,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') CALL ncio_write_vector (file_restart, 'scale_baseflow', 'patch', landpatch, scale_baseflow, 1) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN rchg_year(:) = spval rsub_year(:) = spval diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 index 11ca8b7c42..3b1de1a0b7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 @@ -66,7 +66,7 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) CALL ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) #endif ! loop for urban patch to assign fraction of green leaf - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO u = 1, numurban npatch = urban2patch(u) tlai(npatch) = urb_lai(u) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 index 1774342d98..3e20a7c3c4 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 @@ -60,7 +60,7 @@ SUBROUTINE allocate_1D_UrbanFluxes USE MOD_Vars_Global, only: spval IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN !allocate (sabroof (numurban)) !allocate (sabwsun (numurban)) @@ -90,7 +90,7 @@ SUBROUTINE deallocate_1D_UrbanFluxes USE MOD_SPMD_Task USE MOD_LandUrban - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN !deallocate (sabroof ) @@ -127,7 +127,7 @@ SUBROUTINE set_1D_UrbanFluxes(Values, Nan) real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN !sabroof (:) = Values !sabwsun (:) = Values diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 index f63ba79577..bded9f3f79 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 @@ -93,7 +93,7 @@ SUBROUTINE allocate_UrbanTimeInvariants () USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN allocate (fveg_urb (numurban)) allocate (htop_urb (numurban)) @@ -288,7 +288,7 @@ SUBROUTINE deallocate_UrbanTimeInvariants ! deallocate (urbclass ) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN deallocate (fveg_urb ) deallocate (htop_urb ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 index 2297a5e5b7..31234bb8c5 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 @@ -128,7 +128,7 @@ SUBROUTINE allocate_UrbanTimeVariables () USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN allocate (fwsun (numurban)) allocate (dfwsun (numurban)) @@ -415,7 +415,7 @@ SUBROUTINE deallocate_UrbanTimeVariables USE MOD_SPMD_Task USE MOD_LandUrban - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numurban > 0) THEN deallocate (fwsun ) deallocate (dfwsun ) diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 index 311a976d5a..51f99e2fc1 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 @@ -21,7 +21,7 @@ MODULE MOD_AggregationRequestData #ifdef USEMPI PUBLIC :: aggregation_data_daemon - PUBLIC :: aggregation_worker_done + PUBLIC :: aggregation_compute_done #endif ! ---- subroutines ---- @@ -70,14 +70,14 @@ SUBROUTINE aggregation_data_daemon (grid_in, & real(r8), allocatable :: sbuf_r8_1d(:), sbuf_r8_2d(:,:) integer , allocatable :: sbuf_i4_1d(:) - logical, allocatable :: worker_done (:) + logical, allocatable :: compute_done (:) - IF (p_is_io) THEN + IF (p_is_active) THEN - allocate (worker_done (0:p_np_worker-1)) + allocate (compute_done (0:p_np_compute-1)) - worker_done(:) = .false. - DO WHILE (any(.not. worker_done)) + compute_done(:) = .false. + DO WHILE (any(.not. compute_done)) CALL mpi_recv (rmesg, 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -258,12 +258,12 @@ SUBROUTINE aggregation_data_daemon (grid_in, & deallocate (xlist) ELSE - worker_done(p_itis_worker(isrc)) = .true. + compute_done(p_itis_compute(isrc)) = .true. ENDIF ENDDO - deallocate (worker_done) + deallocate (compute_done) ENDIF @@ -484,14 +484,14 @@ SUBROUTINE aggregation_request_data ( & ipt(ireq) = gblock%pio(xblk,yblk) ENDDO - DO iproc = 0, p_np_io-1 - msk = (ipt == p_address_io(iproc)) + DO iproc = 0, p_np_active-1 + msk = (ipt == p_address_active(iproc)) nreq = count(msk) IF (nreq > 0) THEN smesg = (/p_iam_glb, nreq/) - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) allocate (ibuf (nreq)) @@ -641,7 +641,7 @@ END SUBROUTINE aggregation_request_data #ifdef USEMPI - SUBROUTINE aggregation_worker_done () + SUBROUTINE aggregation_compute_done () USE MOD_SPMD_Task @@ -649,15 +649,15 @@ SUBROUTINE aggregation_worker_done () integer :: smesg(2), iproc, idest - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 smesg = (/p_iam_glb, -1/) - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) ENDDO ENDIF - END SUBROUTINE aggregation_worker_done + END SUBROUTINE aggregation_compute_done #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 index 00a96729c4..ba7030b2b5 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 @@ -52,30 +52,30 @@ SUBROUTINE elm_vector_init integer*8, allocatable :: indexelm (:) integer, allocatable :: order (:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN CALL elm_patch%build (landelm, landpatch, use_frac = .true.) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef USEMPI IF (numelm > 0) THEN allocate (indexelm (numelm)) indexelm = landelm%eindex ENDIF - IF (p_iam_worker == p_root) allocate (numelm_worker (0:p_np_worker-1)) + IF (p_iam_compute == p_root) allocate (numelm_worker (0:p_np_compute-1)) CALL mpi_gather (numelm, 1, MPI_INTEGER, & - numelm_worker, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + numelm_worker, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN - CALL mpi_send (numelm_worker, p_np_worker, MPI_INTEGER, & - p_address_master, mpi_tag_size, p_comm_glb, p_err) + IF (p_iam_compute == p_root) THEN + CALL mpi_send (numelm_worker, p_np_compute, MPI_INTEGER, & + p_address_root, mpi_tag_size, p_comm_glb, p_err) ENDIF mesg = (/p_iam_glb, numelm/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numelm > 0) THEN - CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #else IF (numelm > 0) THEN @@ -85,15 +85,15 @@ SUBROUTINE elm_vector_init #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - allocate (numelm_worker (0:p_np_worker-1)) - CALL mpi_recv (numelm_worker, p_np_worker, MPI_INTEGER, p_address_worker(p_root), & + allocate (numelm_worker (0:p_np_compute-1)) + CALL mpi_recv (numelm_worker, p_np_compute, MPI_INTEGER, p_address_compute(p_root), & mpi_tag_size, p_comm_glb, p_stat, p_err) - allocate (vec_worker_dsp (0:p_np_worker-1)) + allocate (vec_worker_dsp (0:p_np_compute-1)) vec_worker_dsp(0) = 0 - DO iwork = 1, p_np_worker-1 + DO iwork = 1, p_np_compute-1 vec_worker_dsp(iwork) = vec_worker_dsp(iwork-1) + numelm_worker(iwork-1) ENDDO @@ -101,21 +101,21 @@ SUBROUTINE elm_vector_init allocate (eindex_glb (totalnumelm)) - allocate (elm_data_address(0:p_np_worker-1)) - DO iwork = 0, p_np_worker-1 + allocate (elm_data_address(0:p_np_compute-1)) + DO iwork = 0, p_np_compute-1 IF (numelm_worker(iwork) > 0) THEN allocate (elm_data_address(iwork)%val (numelm_worker(iwork))) ENDIF ENDDO - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = mesg(1) ndata = mesg(2) IF (ndata > 0) THEN - idsp = vec_worker_dsp(p_itis_worker(isrc)) + idsp = vec_worker_dsp(p_itis_compute(isrc)) CALL mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -128,10 +128,10 @@ SUBROUTINE elm_vector_init ENDIF #ifdef USEMPI - CALL mpi_bcast (totalnumelm, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (totalnumelm, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (order (totalnumelm)) order = (/(i, i=1,totalnumelm)/) diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 index cb71887b90..ebb675e94a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 @@ -55,7 +55,7 @@ SUBROUTINE hru_vector_init integer :: nhru, nelm, hru_dsp_loc - IF (p_is_worker) THEN + IF (p_is_compute) THEN CALL elm_hru%build (landelm, landhru, use_frac = .true.) @@ -68,21 +68,21 @@ SUBROUTINE hru_vector_init #ifdef USEMPI mesg = (/p_iam_glb, numelm/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numelm > 0) THEN - CALL mpi_send (nhru_bsn, numelm, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (nhru_bsn, numelm, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN - allocate (hru_data_address (0:p_np_worker-1)) + allocate (hru_data_address (0:p_np_compute-1)) allocate (nhru_bsn_glb (totalnumelm)) #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -94,10 +94,10 @@ SUBROUTINE hru_vector_init CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) - nhru_bsn_glb(elm_data_address(p_itis_worker(isrc))%val) = rbuff + nhru_bsn_glb(elm_data_address(p_itis_compute(isrc))%val) = rbuff IF (sum(rbuff) > 0) THEN - allocate(hru_data_address(p_itis_worker(isrc))%val (sum(rbuff))) + allocate(hru_data_address(p_itis_compute(isrc))%val (sum(rbuff))) ENDIF deallocate(rbuff) @@ -115,7 +115,7 @@ SUBROUTINE hru_vector_init CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN totalnumhru = sum(nhru_bsn_glb) @@ -125,7 +125,7 @@ SUBROUTINE hru_vector_init hru_dsp_glb(ielm) = hru_dsp_glb(ielm-1) + nhru_bsn_glb(ielm-1) ENDDO - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 IF (allocated(elm_data_address(iwork)%val)) THEN nelm = size(elm_data_address(iwork)%val) hru_dsp_loc = 0 @@ -142,20 +142,20 @@ SUBROUTINE hru_vector_init ENDDO ENDIF #ifdef USEMPI - CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #endif #ifdef USEMPI - IF (p_is_worker) THEN + IF (p_is_compute) THEN mesg = (/p_iam_glb, numhru/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_master, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numhru > 0) THEN - CALL mpi_send (landhru%settyp, numhru, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (landhru%settyp, numhru, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF ENDIF #endif - IF (p_is_master) THEN + IF (p_is_root) THEN allocate (eindx_hru (totalnumhru)) @@ -167,7 +167,7 @@ SUBROUTINE hru_vector_init allocate (htype_hru (totalnumhru)) #ifdef USEMPI - DO iwork = 0, p_np_worker-1 + DO iwork = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -178,7 +178,7 @@ SUBROUTINE hru_vector_init CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) - htype_hru(hru_data_address(p_itis_worker(isrc))%val) = rbuff + htype_hru(hru_data_address(p_itis_compute(isrc))%val) = rbuff deallocate(rbuff) ENDIF @@ -195,7 +195,7 @@ SUBROUTINE hru_vector_init ENDIF #ifdef USEMPI - CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #endif END SUBROUTINE hru_vector_init diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 index 6a181d8195..e646025a2b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 @@ -58,7 +58,7 @@ SUBROUTINE land2mwmo_build (lc_year) integer :: numwmo write(cyear,'(i4.4)') lc_year - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making land 2 m wmo patches:' ENDIF @@ -66,7 +66,7 @@ SUBROUTINE land2mwmo_build (lc_year) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN numset = numelm @@ -208,9 +208,9 @@ SUBROUTINE land2mwmo_build (lc_year) IF (allocated (locpth )) deallocate (locpth ) #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 index 9e743711d1..85ed62521c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 @@ -55,7 +55,7 @@ SUBROUTINE landcrop_build (lc_year) integer , allocatable :: classshared(:) write(cyear,'(i4.4)') lc_year - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making patches (crop shared):' ENDIF @@ -63,7 +63,7 @@ SUBROUTINE landcrop_build (lc_year) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_io) THEN + IF (p_is_active) THEN dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' suffix = 'MOD'//trim(cyear) @@ -90,13 +90,13 @@ SUBROUTINE landcrop_build (lc_year) pctshared, classshared) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (landpatch%nset > 0) THEN WHERE (classshared == 2) landpatch%settyp = CROPLAND ENDIF ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN file_patch = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc' CALL allocate_block_data (grid_crop, cropdata, N_CFT) CALL ncio_read_block (file_patch, 'PCT_CFT', grid_crop, N_CFT, cropdata) @@ -110,7 +110,7 @@ SUBROUTINE landcrop_build (lc_year) numpatch = landpatch%nset landpatch%has_shared = .true. - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN IF (allocated(landpatch%pctshared)) THEN deallocate(landpatch%pctshared) @@ -125,9 +125,9 @@ SUBROUTINE landcrop_build (lc_year) IF (allocated(classshared)) deallocate(classshared) #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches (with crop).' ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 index 290039b763..69d75a4878 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 @@ -39,11 +39,11 @@ SUBROUTINE landelm_build ! Local Variables integer :: ielm, nelm_glb - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making land elements:' ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (landelm%eindex (numelm)) allocate (landelm%ipxstt (numelm)) @@ -67,9 +67,9 @@ SUBROUTINE landelm_build #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_worker) THEN - CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements.' ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 index 01c3832a21..a63fed01a7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 @@ -66,36 +66,36 @@ SUBROUTINE landhru_build () CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making land hydro units:' ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial (DEF_CatchmentMesh_data, 'basin_numhru', numhru_all_g) CALL ncio_read_serial (DEF_CatchmentMesh_data, 'lake_id', lakeid) ENDIF #ifdef USEMPI - IF (p_is_master) THEN - DO iwork = 0, p_np_worker-1 + IF (p_is_root) THEN + DO iwork = 0, p_np_compute-1 - CALL mpi_recv (ncat, 1, MPI_INTEGER, p_address_worker(iwork), mpi_tag_size, & + CALL mpi_recv (ncat, 1, MPI_INTEGER, p_address_compute(iwork), mpi_tag_size, & p_comm_glb, p_stat, p_err) IF (ncat > 0) THEN allocate (catnum(ncat)) allocate (ibuff (ncat)) - CALL mpi_recv (catnum, ncat, MPI_INTEGER8, p_address_worker(iwork), mpi_tag_data, & + CALL mpi_recv (catnum, ncat, MPI_INTEGER8, p_address_compute(iwork), mpi_tag_data, & p_comm_glb, p_stat, p_err) nhru = sum(numhru_all_g(catnum)) CALL mpi_send (nhru, 1, MPI_INTEGER, & - p_address_worker(iwork), mpi_tag_size, p_comm_glb, p_err) + p_address_compute(iwork), mpi_tag_size, p_comm_glb, p_err) ibuff = lakeid(catnum) CALL mpi_send (ibuff, ncat, MPI_INTEGER, & - p_address_worker(iwork), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(iwork), mpi_tag_data, p_comm_glb, p_err) deallocate(catnum) deallocate(ibuff ) @@ -103,13 +103,13 @@ SUBROUTINE landhru_build () ENDDO ENDIF - IF (p_is_worker) THEN - CALL mpi_send (numelm, 1, MPI_INTEGER, p_address_master, mpi_tag_size, p_comm_glb, p_err) + IF (p_is_compute) THEN + CALL mpi_send (numelm, 1, MPI_INTEGER, p_address_root, mpi_tag_size, p_comm_glb, p_err) IF (numelm > 0) THEN allocate (lakeid (numelm)) - CALL mpi_send (landelm%eindex, numelm, MPI_INTEGER8, p_address_master, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_recv (numhru, 1, MPI_INTEGER, p_address_master, mpi_tag_size, p_comm_glb, p_stat, p_err) - CALL mpi_recv (lakeid, numelm, MPI_INTEGER, p_address_master, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_send (landelm%eindex, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_recv (numhru, 1, MPI_INTEGER, p_address_root, mpi_tag_size, p_comm_glb, p_stat, p_err) + CALL mpi_recv (lakeid, numelm, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ELSE numhru = 0 ENDIF @@ -118,20 +118,20 @@ SUBROUTINE landhru_build () numhru = sum(numhru_all_g) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN IF (allocated(numhru_all_g)) deallocate(numhru_all_g) ENDIF - IF (p_is_io) CALL allocate_block_data (grid_hru, hrudata) + IF (p_is_active) CALL allocate_block_data (grid_hru, hrudata) CALL catchment_data_read (DEF_CatchmentMesh_data, 'ihydrounit2d', grid_hru, hrudata) #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN CALL aggregation_data_daemon (grid_hru, data_i4_2d_in1 = hrudata) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numhru > 0) THEN allocate (landhru%eindex (numhru)) @@ -194,7 +194,7 @@ SUBROUTINE landhru_build () ENDDO #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_compute_done () #endif ENDIF @@ -202,9 +202,9 @@ SUBROUTINE landhru_build () CALL landhru%set_vecgs #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numhru, nhru_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numhru, nhru_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', nhru_glb, ' hydro units.' ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 index cfebf1dc34..4c8d17e875 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 @@ -72,7 +72,7 @@ SUBROUTINE landpft_build (lc_year) integer :: wmo_src, ipft_grass real(r8) :: sumarea, maxgrass - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making land plant function type tiles:' ENDIF @@ -82,7 +82,7 @@ SUBROUTINE landpft_build (lc_year) landpft%has_shared = .true. - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_patch, pctpft, N_PFT_modis, lb1 = 0) CALL flush_block_data (pctpft, 1.0) @@ -99,7 +99,7 @@ SUBROUTINE landpft_build (lc_year) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN allocate (pctpft_patch (0:N_PFT-1,numpatch)) @@ -149,7 +149,7 @@ SUBROUTINE landpft_build (lc_year) ENDDO #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_compute_done () #endif IF (numpatch > 0) THEN @@ -241,9 +241,9 @@ SUBROUTINE landpft_build (lc_year) CALL landpft%set_vecgs #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numpft, npft_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numpft, npft_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', npft_glb, ' plant function type tiles.' ENDIF ENDIF @@ -270,7 +270,7 @@ SUBROUTINE map_patch_to_pft integer :: ipatch, ipft - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((numpatch <= 0) .or. (numpft <= 0)) RETURN diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 index d3bf9f1387..04c76fe18b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 @@ -80,7 +80,7 @@ SUBROUTINE landpatch_build (lc_year) integer, allocatable :: npxl_types (:) write(cyear,'(i4.4)') lc_year - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making land patches:' ENDIF @@ -88,7 +88,7 @@ SUBROUTINE landpatch_build (lc_year) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (grid_patch, patchdata) @@ -106,7 +106,7 @@ SUBROUTINE landpatch_build (lc_year) #endif ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN #ifdef CATCHMENT numset = numhru @@ -252,7 +252,7 @@ SUBROUTINE landpatch_build (lc_year) ENDIF #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_compute_done () #endif ENDIF @@ -264,9 +264,9 @@ SUBROUTINE landpatch_build (lc_year) #if (!defined(URBAN_MODEL) && !defined(CROP)) #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 index 3a57e5acfc..76fd7e77fe 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 @@ -90,7 +90,7 @@ SUBROUTINE landurban_build (lc_year) character(len=256) :: suffix, cyear - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making urban type tiles:' ENDIF @@ -99,7 +99,7 @@ SUBROUTINE landurban_build (lc_year) #endif ! allocate and read the grided LCZ/NCAR urban type - IF (p_is_io) THEN + IF (p_is_active) THEN dir_urban = trim(DEF_dir_rawdata) // '/urban_type' @@ -119,7 +119,7 @@ SUBROUTINE landurban_build (lc_year) #endif ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (numpatch > 0) THEN ! a temporary numpatch with max urban patch number @@ -259,7 +259,7 @@ SUBROUTINE landurban_build (lc_year) ENDDO #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_compute_done () #endif numpatch = jpatch @@ -323,9 +323,9 @@ SUBROUTINE landurban_build (lc_year) CALL map_patch_to_urban #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numurban, nurb_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numurban, nurb_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', nurb_glb, ' urban tiles.' ENDIF ENDIF @@ -337,9 +337,9 @@ SUBROUTINE landurban_build (lc_year) #ifndef CROP #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' ENDIF ENDIF @@ -382,7 +382,7 @@ SUBROUTINE map_patch_to_urban integer :: ipatch, iurban - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((numpatch <= 0) .or. (numurban <= 0)) RETURN diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 index 6ba1cc228b..d4796ff885 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 @@ -26,7 +26,7 @@ logical FUNCTION inquire_mesh_filter () IMPLICIT NONE logical :: fexists - IF (p_is_master) THEN + IF (p_is_root) THEN inquire (file=trim(DEF_file_mesh_filter), exist=fexists) @@ -38,7 +38,7 @@ logical FUNCTION inquire_mesh_filter () ENDIF #ifdef USEMPI - CALL mpi_bcast (fexists, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (fexists, 1, MPI_LOGICAL, p_address_root, p_comm_glb, p_err) #endif inquire_mesh_filter = fexists @@ -73,11 +73,11 @@ SUBROUTINE mesh_filter (gridf, ffilter, fvname) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(/, A)') 'Filtering pixels ...' ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (gridf, datafilter) CALL ncio_read_block (trim(ffilter), trim(fvname), gridf, datafilter) @@ -86,7 +86,7 @@ SUBROUTINE mesh_filter (gridf, ffilter, fvname) #endif ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN jelm = 0 DO ielm = 1, numelm @@ -134,11 +134,11 @@ SUBROUTINE mesh_filter (gridf, ffilter, fvname) numelm = jelm #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_compute_done () #endif ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (allocated(landelm%eindex)) deallocate (landelm%eindex) IF (allocated(landelm%ipxstt)) deallocate (landelm%ipxstt) IF (allocated(landelm%ipxend)) deallocate (landelm%ipxend) @@ -149,9 +149,9 @@ SUBROUTINE mesh_filter (gridf, ffilter, fvname) CALL landelm_build () #ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN + IF (p_is_compute) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) + IF (p_iam_compute == 0) THEN write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements after mesh filtering.' ENDIF ENDIF @@ -161,7 +161,7 @@ SUBROUTINE mesh_filter (gridf, ffilter, fvname) ! Update nelm_blk nelm_blk(:,:) = 0 - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO ielm = 1, numelm nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) = & nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) + 1 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 index b6de6c5bac..61f5ab7bdf 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 @@ -63,12 +63,12 @@ SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typf #endif #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN CALL aggregation_data_daemon (gshared, data_r8_3d_in1 = datashared, n1_r8_3d_in1 = nmaxshared) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN nsetshared = 0 @@ -115,11 +115,11 @@ SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typf ENDDO #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_compute_done () #endif ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (pixelset%nset > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 index e9b2fa9aa3..c5f20253fd 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 @@ -49,7 +49,7 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Saving land elements ...' CALL system('mkdir -p ' // trim(dir_landdata) // '/mesh/' // trim(cyear)) ENDIF @@ -63,8 +63,8 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) DO iblk = 1, gblock%nxblk #ifdef USEMPI - IF (p_is_worker) THEN - IF (gblock%pio(iblk,jblk) == p_address_io(p_my_group)) THEN + IF (p_is_compute) THEN + IF (gblock%pio(iblk,jblk) == p_address_active(p_my_group)) THEN #endif nelm = 0 totlen = 0 @@ -123,7 +123,7 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) #endif #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN allocate (nelm_worker (0:p_np_group-1)) @@ -172,7 +172,7 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) ENDIF #endif - IF (p_is_io) THEN + IF (p_is_active) THEN IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN IF (nelm > 0) THEN CALL get_filename_block (filename, iblk, jblk, fileblock) @@ -203,7 +203,7 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) ENDDO ENDDO - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_create_file (filename) @@ -247,7 +247,7 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) write(*,*) 'SAVE land elements done.' + IF (p_is_root) write(*,*) 'SAVE land elements done.' END SUBROUTINE mesh_save_to_file @@ -339,7 +339,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Loading land elements ...' ENDIF @@ -350,7 +350,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) use_subset = present(subset_eindex) IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) - IF (p_is_io) THEN + IF (p_is_active) THEN numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) @@ -443,7 +443,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDIF #ifdef CoLMDEBUG - IF (p_is_io) write(*,'(I10,A,I4)') numelm, ' elements on group ', p_iam_io + IF (p_is_active) write(*,'(I10,A,I4)') numelm, ' elements on group ', p_iam_active #endif #ifdef USEMPI @@ -451,7 +451,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Loading land elements done.' ENDIF @@ -479,7 +479,7 @@ SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Saving Pixel Sets ' // trim(psetname) // ' ...' CALL system('mkdir -p ' // trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear)) ENDIF @@ -505,7 +505,7 @@ SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) write(*,*) 'SAVE Pixel Sets ' // trim(psetname) // ' done.' + IF (p_is_root) write(*,*) 'SAVE Pixel Sets ' // trim(psetname) // ' done.' END SUBROUTINE pixelset_save_to_file @@ -548,13 +548,13 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc use_subset = present(subset_eindex) IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Loading Pixel Sets ' // trim(psetname) // ' ...' ENDIF filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc' - IF (p_is_io) THEN + IF (p_is_active) THEN pixelset%nset = 0 @@ -599,7 +599,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc #endif #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. fexists_any) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' @@ -695,7 +695,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc #ifdef USEMPI - IF (p_is_io) THEN + IF (p_is_active) THEN IF (pixelset%nset > 0) THEN allocate (iworker (pixelset%nset)) allocate (msk (pixelset%nset)) @@ -746,7 +746,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_stat, p_err) @@ -766,7 +766,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc CALL ncio_read_vector (filename, 'ipxend', pixelset, pixelset%ipxend) CALL ncio_read_vector (filename, 'settyp', pixelset, pixelset%settyp) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (pixelset%nset > 0) THEN allocate (pixelset%ielm (pixelset%nset)) @@ -786,7 +786,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc numset = pixelset%nset pixelset%has_shared = .false. - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iset = 1, pixelset%nset-1 IF ((pixelset%ielm(iset) == pixelset%ielm(iset+1)) & .and. (pixelset%ipxstt(iset) == pixelset%ipxstt(iset+1))) THEN @@ -806,7 +806,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF #ifdef CoLMDEBUG - IF (p_is_io) write(*,*) numset, trim(psetname), ' on group', p_iam_io + IF (p_is_active) write(*,*) numset, trim(psetname), ' on group', p_iam_active #endif IF (allocated(subset_sorted)) deallocate(subset_sorted) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 index 4cc54435c0..4a120a37e1 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 @@ -148,7 +148,7 @@ SUBROUTINE read_5x5_data_int32 (dir_5x5, sfx, grid, dataname, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -233,7 +233,7 @@ SUBROUTINE read_5x5_data_real8 (dir_5x5, sfx, grid, dataname, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -319,7 +319,7 @@ SUBROUTINE read_5x5_data_pft (dir_5x5, sfx, grid, dataname, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -408,7 +408,7 @@ SUBROUTINE read_5x5_data_time (dir_5x5, sfx, grid, dataname, time, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -496,7 +496,7 @@ SUBROUTINE read_5x5_data_pft_time (dir_5x5, sfx, grid, dataname, time, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 index a3724e2e13..d8506a51f7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 @@ -144,7 +144,7 @@ SUBROUTINE block_set (this) ENDIF IF ((mod(360,this%nxblk) /= 0) .or. (mod(180,this%nyblk) /= 0)) THEN - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) 'Number of blocks in longitude should be a factor of 360 ' write(*,*) ' and Number of blocks in latitude should be a factor of 180.' CALL CoLM_stop () @@ -173,7 +173,7 @@ SUBROUTINE block_set (this) ENDIF #ifndef SinglePoint - IF (p_is_master) THEN + IF (p_is_root) THEN write (*,*) write (*,'(A)') '----- Block information -----' write (*,'(I4,A,I4,A)') this%nxblk, ' blocks in longitude,', & @@ -204,7 +204,7 @@ SUBROUTINE block_save_to_file (this, dir_landdata) ! Local variables character(len=256) :: filename - IF (p_is_master) THEN + IF (p_is_root) THEN filename = trim(dir_landdata) // '/block.nc' @@ -245,7 +245,7 @@ SUBROUTINE block_load_from_file (this, dir_landdata) this%nyblk = size(this%lat_s) this%nxblk = size(this%lon_w) - IF (p_is_master) THEN + IF (p_is_root) THEN write (*,*) 'Block information:' write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', & this%nyblk, ' blocks in latitude.' @@ -331,12 +331,12 @@ SUBROUTINE block_init_pio (this) integer :: numblocks, ngrp integer :: iblkme - IF (p_is_master) THEN + IF (p_is_root) THEN CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east, numblocks) ENDIF #ifdef USEMPI - CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN ngrp = p_np_glb / DEF_PIO_groupsize @@ -351,7 +351,7 @@ SUBROUTINE block_init_pio (this) allocate (this%pio (this%nxblk,this%nyblk)) this%pio(:,:) = -1 - IF (p_is_master) THEN + IF (p_is_root) THEN iproc = -1 DO jblk = iblk_south, iblk_north @@ -359,8 +359,8 @@ SUBROUTINE block_init_pio (this) iblk = iblk_west DO WHILE (.true.) #ifdef USEMPI - iproc = mod(iproc+1, p_np_io) - this%pio(iblk,jblk) = p_address_io(iproc) + iproc = mod(iproc+1, p_np_active) + this%pio(iblk,jblk) = p_address_active(iproc) #else this%pio(iblk,jblk) = p_root #endif @@ -377,11 +377,11 @@ SUBROUTINE block_init_pio (this) #ifdef USEMPI CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, & - p_address_master, p_comm_glb, p_err) + p_address_root, p_comm_glb, p_err) #endif this%nblkme = 0 - IF (p_is_io) THEN + IF (p_is_active) THEN this%nblkme = count(this%pio == p_iam_glb) IF (this%nblkme > 0) THEN iblkme = 0 @@ -419,7 +419,7 @@ SUBROUTINE block_read_pio (this, dir_landdata) integer :: numblocks, ngrp, iblk, jblk, iproc, jproc integer :: iblkme - IF (p_is_master) THEN + IF (p_is_root) THEN ! Whether it varies by year??? write(cyear,'(i4.4)') DEF_LC_YEAR filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' @@ -431,7 +431,7 @@ SUBROUTINE block_read_pio (this, dir_landdata) ENDIF #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN ngrp = p_np_glb / DEF_PIO_groupsize @@ -481,18 +481,18 @@ SUBROUTINE block_read_pio (this, dir_landdata) ENDIF - CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - CALL mpi_bcast (ngrp, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (ngrp, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) CALL divide_processes_into_groups (ngrp) #endif allocate (this%pio (this%nxblk,this%nyblk)) this%pio(:,:) = -1 - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - allocate (nelm_io (0:p_np_io-1)) + allocate (nelm_io (0:p_np_active-1)) nelm_io(:) = 0 jproc = -1 #endif @@ -503,11 +503,11 @@ SUBROUTINE block_read_pio (this, dir_landdata) #ifdef USEMPI IF (nelmblk(iblk,jblk) > 0) THEN iproc = minloc(nelm_io, dim=1) - 1 - this%pio(iblk,jblk) = p_address_io(iproc) + this%pio(iblk,jblk) = p_address_active(iproc) nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk) ELSEIF (nelmblk(iblk,jblk) == 0) THEN - jproc = mod(jproc+1, p_np_io) - this%pio(iblk,jblk) = p_address_io(jproc) + jproc = mod(jproc+1, p_np_active) + this%pio(iblk,jblk) = p_address_active(jproc) ENDIF #else this%pio(iblk,jblk) = p_root @@ -528,11 +528,11 @@ SUBROUTINE block_read_pio (this, dir_landdata) #ifdef USEMPI CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, & - p_address_master, p_comm_glb, p_err) + p_address_root, p_comm_glb, p_err) #endif this%nblkme = 0 - IF (p_is_io) THEN + IF (p_is_active) THEN this%nblkme = count(this%pio == p_iam_glb) IF (this%nblkme > 0) THEN iblkme = 0 diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 index 22474e9f12..dcb444bc80 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 @@ -118,19 +118,19 @@ SUBROUTINE catchment_data_read_general (file_meshdata_in, dataname, grid, & real(r8), allocatable :: latitude(:), longitude(:) logical :: fexists - IF (p_is_io) THEN + IF (p_is_active) THEN - IF (p_iam_io == p_root) THEN + IF (p_iam_active == p_root) THEN IF (grid%yinc == 1) THEN write(*,*) 'Warning: latitude in catchment data should be from north to south.' ENDIF ENDIF - IF (p_iam_io == p_root) THEN + IF (p_iam_active == p_root) THEN in_one_file = ncio_var_exist (file_meshdata_in, dataname) ENDIF #ifdef USEMPI - CALL mpi_bcast (in_one_file, 1, mpi_logical, p_root, p_comm_io, p_err) + CALL mpi_bcast (in_one_file, 1, mpi_logical, p_root, p_comm_active, p_err) #endif IF (in_one_file) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 similarity index 82% rename from src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 index 5fa6725e4d..9c75e89a25 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_WorkerPushData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 @@ -1,6 +1,6 @@ #include -MODULE MOD_WorkerPushData +MODULE MOD_ComputePushData !-------------------------------------------------------------------------------- ! DESCRIPTION: !-------------------------------------------------------------------------------- @@ -12,7 +12,7 @@ MODULE MOD_WorkerPushData IMPLICIT NONE ! -- Data Type : push data between workers -- - type :: worker_pushdata_type + type :: compute_pushdata_type integer :: num_req_uniq @@ -34,12 +34,12 @@ MODULE MOD_WorkerPushData type(pointer_int32_1d), allocatable :: other_to (:) #endif CONTAINS - final :: worker_pushdata_free_mem - END type worker_pushdata_type + final :: compute_pushdata_free_mem + END type compute_pushdata_type ! -- Data Type : remap data on workers -- - type :: worker_remapdata_type + type :: compute_remapdata_type integer :: num_grid integer, allocatable :: ilon_me (:) @@ -53,43 +53,43 @@ MODULE MOD_WorkerPushData type(pointer_real8_1d), allocatable :: areapart (:) ! intersection area CONTAINS - final :: worker_remapdata_free_mem - END type worker_remapdata_type + final :: compute_remapdata_free_mem + END type compute_remapdata_type ! -- public subroutines -- - INTERFACE build_worker_pushdata - MODULE procedure build_worker_pushdata_single - MODULE procedure build_worker_pushdata_multi - END INTERFACE build_worker_pushdata + INTERFACE build_compute_pushdata + MODULE procedure build_compute_pushdata_single + MODULE procedure build_compute_pushdata_multi + END INTERFACE build_compute_pushdata - PUBLIC :: build_worker_pushdata_subset + PUBLIC :: build_compute_pushdata_subset - PUBLIC :: build_worker_remapdata + PUBLIC :: build_compute_remapdata - INTERFACE worker_push_data - MODULE procedure worker_push_data_single_real8 - MODULE procedure worker_push_data_single_int32 - MODULE procedure worker_push_data_multi_real8 - END INTERFACE worker_push_data + INTERFACE compute_push_data + MODULE procedure compute_push_data_single_real8 + MODULE procedure compute_push_data_single_int32 + MODULE procedure compute_push_data_multi_real8 + END INTERFACE compute_push_data - INTERFACE worker_remap_data_pset2grid - MODULE procedure worker_remap_data_pset2grid_real8 - END INTERFACE worker_remap_data_pset2grid + INTERFACE compute_remap_data_pset2grid + MODULE procedure compute_remap_data_pset2grid_real8 + END INTERFACE compute_remap_data_pset2grid - INTERFACE worker_remap_data_grid2pset - MODULE procedure worker_remap_data_grid2pset_real8 - END INTERFACE worker_remap_data_grid2pset + INTERFACE compute_remap_data_grid2pset + MODULE procedure compute_remap_data_grid2pset_real8 + END INTERFACE compute_remap_data_grid2pset CONTAINS ! ---------- - SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, pushdata) + SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, pushdata) IMPLICIT NONE integer, intent(in) :: num_me, ids_me (:) integer, intent(in) :: n_req_uniq, ids_req_uniq (:) - type(worker_pushdata_type), intent(inout) :: pushdata + type(compute_pushdata_type), intent(inout) :: pushdata ! Local Variables integer, allocatable :: ids_me_sorted(:), order_ids(:), self_from(:) @@ -100,7 +100,7 @@ SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, integer :: i, iloc, iworker, jworker, n_req_other - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (ids_me_sorted (num_me)) allocate (order_ids (num_me)) @@ -133,39 +133,39 @@ SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, ENDIF #ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_worker, p_err) + CALL mpi_barrier (p_comm_compute, p_err) - allocate (pushdata%n_to_other (0:p_np_worker-1)) - allocate (pushdata%to_other (0:p_np_worker-1)) + allocate (pushdata%n_to_other (0:p_np_compute-1)) + allocate (pushdata%to_other (0:p_np_compute-1)) - allocate (pushdata%n_from_other (0:p_np_worker-1)) - allocate (pushdata%other_to (0:p_np_worker-1)) + allocate (pushdata%n_from_other (0:p_np_compute-1)) + allocate (pushdata%other_to (0:p_np_compute-1)) pushdata%n_to_other (:) = 0 pushdata%n_from_other(:) = 0 IF (n_req_uniq > 0) allocate (loc_from_other (n_req_uniq)) - iworker = modulo(p_iam_worker+1, p_np_worker) - jworker = modulo(p_iam_worker-1, p_np_worker) - DO WHILE (iworker /= p_iam_worker) + iworker = modulo(p_iam_compute+1, p_np_compute) + jworker = modulo(p_iam_compute-1, p_np_compute) + DO WHILE (iworker /= p_iam_compute) CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jworker, 10, & - p_comm_worker, request(1), p_err) + p_comm_compute, request(1), p_err) IF (n_req_uniq > 0) THEN CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jworker, 11, & - p_comm_worker, request(2), p_err) + p_comm_compute, request(2), p_err) ENDIF CALL mpi_recv (n_req_other, 1, MPI_INTEGER, iworker, 10, & - p_comm_worker, p_stat, p_err) + p_comm_compute, p_stat, p_err) IF (n_req_other > 0) THEN allocate (ids (n_req_other)) CALL mpi_recv (ids, n_req_other, MPI_INTEGER, iworker, 11, & - p_comm_worker, p_stat, p_err) + p_comm_compute, p_stat, p_err) allocate (loc_from_me (n_req_other)) loc_from_me(:) = -1 @@ -186,14 +186,14 @@ SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, ENDIF CALL mpi_isend (loc_from_me, n_req_other, MPI_INTEGER, iworker, 12, & - p_comm_worker, request(3), p_err) + p_comm_compute, request(3), p_err) ENDIF IF (n_req_uniq > 0) THEN CALL mpi_recv (loc_from_other, n_req_uniq, MPI_INTEGER, & - jworker, 12, p_comm_worker, p_stat, p_err) + jworker, 12, p_comm_compute, p_stat, p_err) pushdata%n_from_other(jworker) = count(loc_from_other > 0) IF (pushdata%n_from_other(jworker) > 0) THEN @@ -210,13 +210,13 @@ SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, IF (allocated(ids )) deallocate(ids ) IF (allocated(loc_from_me)) deallocate(loc_from_me) - iworker = modulo(iworker+1, p_np_worker) - jworker = modulo(jworker-1, p_np_worker) + iworker = modulo(iworker+1, p_np_compute) + jworker = modulo(jworker-1, p_np_compute) ENDDO IF (allocated (loc_from_other)) deallocate (loc_from_other) - CALL mpi_barrier (p_comm_worker, p_err) + CALL mpi_barrier (p_comm_compute, p_err) #endif IF (allocated(ids_me_sorted)) deallocate(ids_me_sorted) @@ -225,22 +225,22 @@ SUBROUTINE build_worker_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, ENDIF - END SUBROUTINE build_worker_pushdata_uniq + END SUBROUTINE build_compute_pushdata_uniq ! ---------- - SUBROUTINE build_worker_pushdata_single (num_me, ids_me, num_req, ids_req, pushdata) + SUBROUTINE build_compute_pushdata_single (num_me, ids_me, num_req, ids_req, pushdata) IMPLICIT NONE integer, intent(in) :: num_me, ids_me (:) integer, intent(in) :: num_req, ids_req (:) - type(worker_pushdata_type), intent(inout) :: pushdata + type(compute_pushdata_type), intent(inout) :: pushdata ! Local Variables integer :: n_req_uniq, iloc, i integer, allocatable :: ids_req_uniq (:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN n_req_uniq = 0 @@ -259,17 +259,17 @@ SUBROUTINE build_worker_pushdata_single (num_me, ids_me, num_req, ids_req, pushd pushdata%num_req_uniq = n_req_uniq - CALL build_worker_pushdata_uniq ( & + CALL build_compute_pushdata_uniq ( & num_me, ids_me, n_req_uniq, ids_req_uniq(1:n_req_uniq), pushdata) IF (allocated (ids_req_uniq)) deallocate(ids_req_uniq) ENDIF - END SUBROUTINE build_worker_pushdata_single + END SUBROUTINE build_compute_pushdata_single ! ---------- - SUBROUTINE build_worker_pushdata_multi ( & + SUBROUTINE build_compute_pushdata_multi ( & num_me, ids_me, num_req, ids_req, area_req, pushdata) IMPLICIT NONE @@ -277,14 +277,14 @@ SUBROUTINE build_worker_pushdata_multi ( & integer, intent(in) :: num_me, ids_me (:) integer, intent(in) :: num_req, ids_req (:,:) real(r8), intent(in) :: area_req(:,:) - type(worker_pushdata_type), intent(inout) :: pushdata + type(compute_pushdata_type), intent(inout) :: pushdata ! Local Variables integer :: ndim1, n_req_uniq, iloc, i, j, iworker integer, allocatable :: ids_req_uniq (:) logical, allocatable :: id_found (:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN n_req_uniq = 0 @@ -311,7 +311,7 @@ SUBROUTINE build_worker_pushdata_multi ( & pushdata%num_req_uniq = n_req_uniq - CALL build_worker_pushdata_uniq ( & + CALL build_compute_pushdata_uniq ( & num_me, ids_me, n_req_uniq, ids_req_uniq(1:n_req_uniq), pushdata) IF (num_req > 0) THEN @@ -329,7 +329,7 @@ SUBROUTINE build_worker_pushdata_multi ( & IF (pushdata%nself > 0) id_found(pushdata%self_to) = .true. #ifdef COLM_PARALLEL - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (pushdata%n_from_other(iworker) > 0) THEN id_found(pushdata%other_to(iworker)%val) = .true. ENDIF @@ -353,10 +353,10 @@ SUBROUTINE build_worker_pushdata_multi ( & ENDIF - END SUBROUTINE build_worker_pushdata_multi + END SUBROUTINE build_compute_pushdata_multi ! ---------- - SUBROUTINE build_worker_pushdata_subset ( & + SUBROUTINE build_compute_pushdata_subset ( & num_me, num_req, pushdata_in, subset_in, pushdata_out, subset_out, numsubset) USE MOD_Pixelset @@ -365,10 +365,10 @@ SUBROUTINE build_worker_pushdata_subset ( & integer, intent(in) :: num_me integer, intent(in) :: num_req - type(worker_pushdata_type), intent(in) :: pushdata_in + type(compute_pushdata_type), intent(in) :: pushdata_in type(subset_type), intent(in) :: subset_in - type(worker_pushdata_type), intent(inout) :: pushdata_out + type(compute_pushdata_type), intent(inout) :: pushdata_out type(subset_type), optional, intent(inout) :: subset_out integer, optional, intent(inout) :: numsubset @@ -377,7 +377,7 @@ SUBROUTINE build_worker_pushdata_subset ( & integer, allocatable :: nsub_me (:), nsub_req(:), nsub_req_uniq(:) integer, allocatable :: subdsp_me(:), subdsp_req_uniq(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (num_me > 0) THEN allocate (nsub_me (num_me)) @@ -388,7 +388,7 @@ SUBROUTINE build_worker_pushdata_subset ( & allocate (nsub_req (num_req)) ENDIF - CALL worker_push_data (pushdata_in, nsub_me, nsub_req, 0) + CALL compute_push_data (pushdata_in, nsub_me, nsub_req, 0) IF (present(subset_out) .and. present(numsubset)) THEN IF (num_req > 0) THEN @@ -484,10 +484,10 @@ SUBROUTINE build_worker_pushdata_subset ( & ENDIF #ifdef COLM_PARALLEL - allocate (pushdata_out%n_to_other (0:p_np_worker-1)) - allocate (pushdata_out%to_other (0:p_np_worker-1)) + allocate (pushdata_out%n_to_other (0:p_np_compute-1)) + allocate (pushdata_out%to_other (0:p_np_compute-1)) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 pushdata_out%n_to_other(iworker) = 0 DO i = 1, pushdata_in%n_to_other(iworker) @@ -510,10 +510,10 @@ SUBROUTINE build_worker_pushdata_subset ( & ENDDO - allocate (pushdata_out%n_from_other (0:p_np_worker-1)) - allocate (pushdata_out%other_to (0:p_np_worker-1)) + allocate (pushdata_out%n_from_other (0:p_np_compute-1)) + allocate (pushdata_out%other_to (0:p_np_compute-1)) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 pushdata_out%n_from_other(iworker) = 0 DO i = 1, pushdata_in%n_from_other(iworker) pushdata_out%n_from_other(iworker) = pushdata_out%n_from_other(iworker) & @@ -543,10 +543,10 @@ SUBROUTINE build_worker_pushdata_subset ( & ENDIF - END SUBROUTINE build_worker_pushdata_subset + END SUBROUTINE build_compute_pushdata_subset ! ---------- - SUBROUTINE build_worker_remapdata (pixelset, grid, remapdata) + SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) USE MOD_Grid USE MOD_Pixelset @@ -556,7 +556,7 @@ SUBROUTINE build_worker_remapdata (pixelset, grid, remapdata) type(pixelset_type), intent(in) :: pixelset type(grid_type), intent(in) :: grid - type(worker_remapdata_type), intent(inout) :: remapdata + type(compute_remapdata_type), intent(inout) :: remapdata ! Local Variables type(spatial_mapping_type) :: mapping @@ -566,10 +566,10 @@ SUBROUTINE build_worker_remapdata (pixelset, grid, remapdata) CALL mapping%build_arealweighted (grid, pixelset) - IF (p_is_worker) THEN + IF (p_is_compute) THEN ngrid = 0 - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 ngrid = ngrid + mapping%glist(iproc)%ng ENDDO @@ -579,7 +579,7 @@ SUBROUTINE build_worker_remapdata (pixelset, grid, remapdata) ENDIF ngrid = 0 - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 DO ig = 1, mapping%glist(iproc)%ng CALL insert_into_sorted_list2 ( & mapping%glist(iproc)%ilon(ig), mapping%glist(iproc)%ilat(ig), & @@ -635,15 +635,15 @@ SUBROUTINE build_worker_remapdata (pixelset, grid, remapdata) ENDIF - END SUBROUTINE build_worker_remapdata + END SUBROUTINE build_compute_remapdata ! ---------- - SUBROUTINE worker_push_data_uniq_real8 ( & + SUBROUTINE compute_push_data_uniq_real8 ( & pushdata, vec_send, vec_recv, fillvalue) IMPLICIT NONE - type(worker_pushdata_type), intent(in) :: pushdata + type(compute_pushdata_type), intent(in) :: pushdata real(r8), intent(in) , optional :: vec_send (:) real(r8), intent(inout), optional :: vec_recv (:) @@ -661,7 +661,7 @@ SUBROUTINE worker_push_data_uniq_real8 ( & integer :: iworker, iproc, idsp, istt, iend, i, i_to - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (pushdata%num_req_uniq > 0) THEN vec_recv = fillvalue @@ -680,7 +680,7 @@ SUBROUTINE worker_push_data_uniq_real8 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (pushdata%n_to_other(iworker) > 0) THEN iproc = iproc + 1 istt = idsp + 1 @@ -688,7 +688,7 @@ SUBROUTINE worker_push_data_uniq_real8 ( & sendcache(istt:iend) = vec_send(pushdata%to_other(iworker)%val) CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(iworker), MPI_REAL8, & - iworker, 101, p_comm_worker, req_send(iproc), p_err) + iworker, 101, p_comm_compute, req_send(iproc), p_err) idsp = iend ENDIF @@ -703,14 +703,14 @@ SUBROUTINE worker_push_data_uniq_real8 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (pushdata%n_from_other(iworker) > 0) THEN iproc = iproc + 1 istt = idsp + 1 iend = idsp + pushdata%n_from_other(iworker) CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(iworker), MPI_REAL8, & - iworker, 101, p_comm_worker, req_recv(iproc), p_err) + iworker, 101, p_comm_compute, req_recv(iproc), p_err) idsp = iend ENDIF @@ -722,7 +722,7 @@ SUBROUTINE worker_push_data_uniq_real8 ( & CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) idsp = 0 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 DO i = 1, pushdata%n_from_other(iworker) IF (recvcache(idsp+i) /= fillvalue) THEN @@ -752,15 +752,15 @@ SUBROUTINE worker_push_data_uniq_real8 ( & ENDIF - END SUBROUTINE worker_push_data_uniq_real8 + END SUBROUTINE compute_push_data_uniq_real8 ! ---------- - SUBROUTINE worker_push_data_uniq_int32 ( & + SUBROUTINE compute_push_data_uniq_int32 ( & pushdata, vec_send, vec_recv, fillvalue) IMPLICIT NONE - type(worker_pushdata_type), intent(in) :: pushdata + type(compute_pushdata_type), intent(in) :: pushdata integer, intent(in) , optional :: vec_send (:) integer, intent(inout), optional :: vec_recv (:) @@ -778,7 +778,7 @@ SUBROUTINE worker_push_data_uniq_int32 ( & integer :: iworker, iproc, idsp, istt, iend, i, i_to - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (pushdata%num_req_uniq > 0) THEN vec_recv = fillvalue @@ -797,7 +797,7 @@ SUBROUTINE worker_push_data_uniq_int32 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (pushdata%n_to_other(iworker) > 0) THEN iproc = iproc + 1 istt = idsp + 1 @@ -805,7 +805,7 @@ SUBROUTINE worker_push_data_uniq_int32 ( & sendcache(istt:iend) = vec_send(pushdata%to_other(iworker)%val) CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(iworker), MPI_INTEGER, & - iworker, 101, p_comm_worker, req_send(iproc), p_err) + iworker, 101, p_comm_compute, req_send(iproc), p_err) idsp = iend ENDIF @@ -820,14 +820,14 @@ SUBROUTINE worker_push_data_uniq_int32 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (pushdata%n_from_other(iworker) > 0) THEN iproc = iproc + 1 istt = idsp + 1 iend = idsp + pushdata%n_from_other(iworker) CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(iworker), MPI_INTEGER, & - iworker, 101, p_comm_worker, req_recv(iproc), p_err) + iworker, 101, p_comm_compute, req_recv(iproc), p_err) idsp = iend ENDIF @@ -839,7 +839,7 @@ SUBROUTINE worker_push_data_uniq_int32 ( & CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) idsp = 0 - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 DO i = 1, pushdata%n_from_other(iworker) IF (recvcache(idsp+i) /= fillvalue) THEN @@ -869,14 +869,14 @@ SUBROUTINE worker_push_data_uniq_int32 ( & ENDIF - END SUBROUTINE worker_push_data_uniq_int32 + END SUBROUTINE compute_push_data_uniq_int32 ! ---------- - SUBROUTINE worker_push_data_single_real8 (pushdata, vec_send, vec_recv, fillvalue) + SUBROUTINE compute_push_data_single_real8 (pushdata, vec_send, vec_recv, fillvalue) IMPLICIT NONE - type(worker_pushdata_type) :: pushdata + type(compute_pushdata_type) :: pushdata real(r8), intent(in) :: vec_send (:) real(r8), intent(inout) :: vec_recv (:) @@ -885,16 +885,16 @@ SUBROUTINE worker_push_data_single_real8 (pushdata, vec_send, vec_recv, fillvalu ! Local Variables real(r8), allocatable :: vec_recv_uniq (:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! Always allocate (zero-length if no requests) to avoid passing - ! unallocated array to worker_push_data_uniq_real8. + ! unallocated array to compute_push_data_uniq_real8. allocate (vec_recv_uniq (pushdata%num_req_uniq)) IF (pushdata%num_req_uniq > 0) THEN vec_recv_uniq(:) = fillvalue ENDIF - CALL worker_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) + CALL compute_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) IF (pushdata%num_req_uniq > 0) THEN vec_recv = vec_recv_uniq(pushdata%addr_single) @@ -903,14 +903,14 @@ SUBROUTINE worker_push_data_single_real8 (pushdata, vec_send, vec_recv, fillvalu ENDIF - END SUBROUTINE worker_push_data_single_real8 + END SUBROUTINE compute_push_data_single_real8 ! ---------- - SUBROUTINE worker_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalue, mode) + SUBROUTINE compute_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalue, mode) IMPLICIT NONE - type(worker_pushdata_type) :: pushdata + type(compute_pushdata_type) :: pushdata real(r8), intent(in) :: vec_send (:) real(r8), intent(inout) :: vec_recv (:) @@ -923,16 +923,16 @@ SUBROUTINE worker_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalue integer :: i, j real(r8) :: val, sumarea - IF (p_is_worker) THEN + IF (p_is_compute) THEN ! Always allocate (zero-length if no requests) to avoid passing - ! unallocated array to worker_push_data_uniq_real8. + ! unallocated array to compute_push_data_uniq_real8. allocate (vec_recv_uniq (pushdata%num_req_uniq)) IF (pushdata%num_req_uniq > 0) THEN vec_recv_uniq(:) = fillvalue ENDIF - CALL worker_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) + CALL compute_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) IF (pushdata%num_req_uniq > 0) THEN @@ -966,14 +966,14 @@ SUBROUTINE worker_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalue ENDIF - END SUBROUTINE worker_push_data_multi_real8 + END SUBROUTINE compute_push_data_multi_real8 ! ---------- - SUBROUTINE worker_push_data_single_int32 (pushdata, vec_send, vec_recv, fillvalue) + SUBROUTINE compute_push_data_single_int32 (pushdata, vec_send, vec_recv, fillvalue) IMPLICIT NONE - type(worker_pushdata_type) :: pushdata + type(compute_pushdata_type) :: pushdata integer, intent(in) :: vec_send (:) integer, intent(inout) :: vec_recv (:) @@ -982,14 +982,14 @@ SUBROUTINE worker_push_data_single_int32 (pushdata, vec_send, vec_recv, fillvalu ! Local Variables integer, allocatable :: vec_recv_uniq (:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (vec_recv_uniq (pushdata%num_req_uniq)) IF (pushdata%num_req_uniq > 0) THEN vec_recv_uniq(:) = fillvalue ENDIF - CALL worker_push_data_uniq_int32 (pushdata, vec_send, vec_recv_uniq, fillvalue) + CALL compute_push_data_uniq_int32 (pushdata, vec_send, vec_recv_uniq, fillvalue) IF (pushdata%num_req_uniq > 0) THEN vec_recv = vec_recv_uniq(pushdata%addr_single) @@ -998,14 +998,14 @@ SUBROUTINE worker_push_data_single_int32 (pushdata, vec_send, vec_recv, fillvalu ENDIF - END SUBROUTINE worker_push_data_single_int32 + END SUBROUTINE compute_push_data_single_int32 ! --------- - SUBROUTINE worker_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillvalue, filter) + SUBROUTINE compute_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillvalue, filter) IMPLICIT NONE - type(worker_remapdata_type), intent(in) :: remapdata + type(compute_remapdata_type), intent(in) :: remapdata real(r8), intent(in) :: vec_in (:) real(r8), intent(inout) :: vec_out(:) @@ -1017,7 +1017,7 @@ SUBROUTINE worker_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillva real(r8) :: area - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (remapdata%num_grid > 0) THEN vec_out(:) = fillvalue @@ -1042,14 +1042,14 @@ SUBROUTINE worker_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillva ENDIF ENDIF - END SUBROUTINE worker_remap_data_pset2grid_real8 + END SUBROUTINE compute_remap_data_pset2grid_real8 ! --------- - SUBROUTINE worker_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillvalue, mode) + SUBROUTINE compute_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillvalue, mode) IMPLICIT NONE - type(worker_remapdata_type), intent(in) :: remapdata + type(compute_remapdata_type), intent(in) :: remapdata real(r8), intent(in) :: vec_in (:) real(r8), intent(inout) :: vec_out(:) @@ -1061,7 +1061,7 @@ SUBROUTINE worker_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillva integer :: iset, ipart, iloc real(r8) :: area, sumarea - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (remapdata%npset > 0) THEN vec_out(:) = fillvalue @@ -1094,13 +1094,13 @@ SUBROUTINE worker_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillva ENDIF ENDIF - END SUBROUTINE worker_remap_data_grid2pset_real8 + END SUBROUTINE compute_remap_data_grid2pset_real8 ! --------- - SUBROUTINE worker_pushdata_free_mem (this) + SUBROUTINE compute_pushdata_free_mem (this) IMPLICIT NONE - type(worker_pushdata_type) :: this + type(compute_pushdata_type) :: this IF (allocated(this%addr_single )) deallocate(this%addr_single ) IF (allocated(this%addr_multi )) deallocate(this%addr_multi ) @@ -1115,13 +1115,13 @@ SUBROUTINE worker_pushdata_free_mem (this) IF (allocated(this%other_to )) deallocate(this%other_to ) #endif - END SUBROUTINE worker_pushdata_free_mem + END SUBROUTINE compute_pushdata_free_mem ! --------- - SUBROUTINE worker_remapdata_free_mem (this) + SUBROUTINE compute_remapdata_free_mem (this) IMPLICIT NONE - type(worker_remapdata_type) :: this + type(compute_remapdata_type) :: this IF (allocated(this%ilon_me )) deallocate(this%ilon_me ) IF (allocated(this%ilat_me )) deallocate(this%ilat_me ) @@ -1131,6 +1131,6 @@ SUBROUTINE worker_remapdata_free_mem (this) IF (allocated(this%part_to )) deallocate(this%part_to ) IF (allocated(this%areapart)) deallocate(this%areapart) - END SUBROUTINE worker_remapdata_free_mem + END SUBROUTINE compute_remapdata_free_mem -END MODULE MOD_WorkerPushData +END MODULE MOD_ComputePushData diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 index 4a907ac1a1..54d355350e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 @@ -672,7 +672,7 @@ SUBROUTINE block_data_division (gdata, sumdata, spv) ! Local variables integer :: iblkme, iblk, jblk - IF (p_is_io) THEN + IF (p_is_active) THEN IF (.not. present(spv)) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 index 6b8ad66908..1b61638bfb 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 @@ -967,7 +967,7 @@ SUBROUTINE get_region_by_this_IO ( grid, & ! Local Variables integer :: iblk, jblk - IF (p_is_io) THEN + IF (p_is_active) THEN IF (gblock%nblkme /= 1) THEN write(*,*) 'Warning: more than one block is on IO processor: ', p_iam_glb diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 index 02bd497abf..25c82d9604 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -70,11 +70,11 @@ SUBROUTINE init_gridbased_mesh_grid () USE MOD_Namelist IMPLICIT NONE - IF (p_is_master) THEN + IF (p_is_root) THEN inquire (file=trim(DEF_file_mesh), exist=read_mesh_from_file) ENDIF #ifdef USEMPI - CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, p_address_root, p_comm_glb, p_err) #endif IF (read_mesh_from_file) THEN CALL gridmesh%define_from_file (DEF_file_mesh) @@ -153,7 +153,7 @@ SUBROUTINE mesh_build () type(irregular_elm_type), allocatable :: meshtmp (:) - IF (p_is_io) THEN + IF (p_is_active) THEN CALL allocate_block_data (gridmesh, datamesh) ENDIF @@ -174,15 +174,15 @@ SUBROUTINE mesh_build () #endif ! Step 1: How many elms in each block? - IF (p_is_io) THEN + IF (p_is_active) THEN nelm = 0 - allocate (nelm_worker (0:p_np_worker-1)) + allocate (nelm_worker (0:p_np_compute-1)) nelm_worker(:) = 0 - allocate (elist_worker (0:p_np_worker-1)) - DO iworker = 0, p_np_worker-1 + allocate (elist_worker (0:p_np_compute-1)) + DO iworker = 0, p_np_compute-1 allocate (elist_worker(iworker)%val (1000)) ENDDO @@ -214,7 +214,7 @@ SUBROUTINE mesh_build () IF (elmid > 0) THEN - iworker = mod(elmid, p_np_worker) + iworker = mod(elmid, p_np_compute) CALL insert_into_sorted_list1 ( & elmid, nelm_worker(iworker), elist_worker(iworker)%val, iloc) @@ -228,9 +228,9 @@ SUBROUTINE mesh_build () ENDDO #ifdef USEMPI - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 IF (nelm_worker(iworker) > 0) THEN - idest = p_address_worker(iworker) + idest = p_address_compute(iworker) smesg(1:2) = (/p_iam_glb, nelm_worker(iworker)/) ! send(01) CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & @@ -244,8 +244,8 @@ SUBROUTINE mesh_build () ENDDO #ifdef USEMPI - DO iworker = 0, p_np_worker-1 - idest = p_address_worker(iworker) + DO iworker = 0, p_np_compute-1 + idest = p_address_compute(iworker) ! send(02) smesg(1:2) = (/p_iam_glb, 0/) CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & @@ -254,7 +254,7 @@ SUBROUTINE mesh_build () #endif deallocate (nelm_worker) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 deallocate (elist_worker(iworker)%val) ENDDO deallocate (elist_worker) @@ -262,9 +262,9 @@ SUBROUTINE mesh_build () ENDIF #ifdef USEMPI - IF (p_is_worker) THEN + IF (p_is_compute) THEN nelm = 0 - allocate(work_done(0:p_np_io-1)) + allocate(work_done(0:p_np_active-1)) work_done(:) = .false. DO WHILE (.not. all(work_done)) ! recv(01,02) @@ -277,7 +277,7 @@ SUBROUTINE mesh_build () IF (nrecv > 0) THEN nelm = nelm + nrecv ELSE - work_done(p_itis_io(isrc)) = .true. + work_done(p_itis_active(isrc)) = .true. ENDIF ENDDO @@ -288,7 +288,7 @@ SUBROUTINE mesh_build () #endif ! Step 2: Build pixel list for each elm. - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (nelm > 0) THEN allocate (meshtmp (nelm)) allocate (elist (nelm)) @@ -297,7 +297,7 @@ SUBROUTINE mesh_build () nelm = 0 ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -395,13 +395,13 @@ SUBROUTINE mesh_build () allocate (sbuf64 (nxp*nyp)) blktag = iblkme - ipt2 = mod(elist2, p_np_worker) - DO iproc = 0, p_np_worker-1 + ipt2 = mod(elist2, p_np_compute) + DO iproc = 0, p_np_compute-1 msk2 = (ipt2 == iproc) .and. (elist2 > 0) nsend = count(msk2) IF (nsend > 0) THEN - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) smesg(1:3) = (/p_iam_glb, nsend, blktag/) ! send(03) @@ -480,8 +480,8 @@ SUBROUTINE mesh_build () ENDDO #ifdef USEMPI - DO iworker = 0, p_np_worker-1 - idest = p_address_worker(iworker) + DO iworker = 0, p_np_compute-1 + idest = p_address_compute(iworker) ! send(07) smesg(1:3) = (/p_iam_glb, 0, 0/) CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & @@ -492,9 +492,9 @@ SUBROUTINE mesh_build () ENDIF #ifdef USEMPI - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate(work_done(0:p_np_io-1)) + allocate(work_done(0:p_np_active-1)) work_done(:) = .false. DO WHILE (.not. all(work_done)) ! recv(03,07) @@ -566,7 +566,7 @@ SUBROUTINE mesh_build () deallocate (xlist_recv) deallocate (ylist_recv) ELSE - work_done(p_itis_io(isrc)) = .true. + work_done(p_itis_active(isrc)) = .true. ENDIF ENDDO @@ -579,7 +579,7 @@ SUBROUTINE mesh_build () IF (allocated(iaddr)) deallocate (iaddr) ! Step 3: Which block each elm locates at. - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (npxl_blk (gblock%nxblk,gblock%nyblk)) allocate (nelm_blk (gblock%nxblk,gblock%nyblk)) @@ -616,7 +616,7 @@ SUBROUTINE mesh_build () ENDIF #ifdef USEMPI - IF (.not. p_is_worker) THEN + IF (.not. p_is_compute) THEN allocate (nelm_blk (gblock%nxblk,gblock%nyblk)) nelm_blk(:,:) = 0 ENDIF @@ -627,7 +627,7 @@ SUBROUTINE mesh_build () ! Step 4: IF MPI is used, sending elms from worker to their IO processes. - IF (p_is_io) THEN + IF (p_is_active) THEN allocate (blkdsp (gblock%nxblk, gblock%nyblk)) blkdsp(1,1) = 0 @@ -654,7 +654,7 @@ SUBROUTINE mesh_build () ENDIF #ifdef USEMPI - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblk = 1, gblock%nxblk DO jblk = 1, gblock%nyblk @@ -717,7 +717,7 @@ SUBROUTINE mesh_build () ENDDO ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) @@ -810,7 +810,7 @@ SUBROUTINE mesh_build () #endif ! Step 4-2: sort elms. - IF (p_is_io) THEN + IF (p_is_active) THEN IF (allocated (meshtmp)) THEN DO ie = 1, size(meshtmp) IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon) @@ -870,23 +870,23 @@ SUBROUTINE mesh_build () CALL scatter_mesh_from_io_to_worker () #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') 'Making mesh elements:' ENDIF #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_io) THEN + IF (p_is_active) THEN - CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_io, p_err) - IF (p_iam_io == p_root) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_active, p_err) + IF (p_iam_active == p_root) THEN write(*,'(A,I12,A)') 'Total : ', nelm_glb, ' elements.' ENDIF nelm_max_blk = maxval(nelm_blk, mask = gblock%pio == p_iam_glb) - CALL mpi_allreduce (MPI_IN_PLACE, nelm_max_blk, 1, MPI_INTEGER, MPI_MAX, p_comm_io, p_err) - IF (p_iam_io == p_root) THEN + CALL mpi_allreduce (MPI_IN_PLACE, nelm_max_blk, 1, MPI_INTEGER, MPI_MAX, p_comm_active, p_err) + IF (p_iam_active == p_root) THEN write(*,'(A,I12,A)') 'Maximum : ', nelm_max_blk, & ' elements in one block (More than 3600 is recommended).' write(*,'(/,A)') ' -----------------------------------------------------------------' @@ -927,7 +927,7 @@ SUBROUTINE scatter_mesh_from_io_to_worker CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_io) THEN + IF (p_is_active) THEN allocate (nelm_worker (1:p_np_group-1)) nelm_worker(:) = 0 @@ -986,7 +986,7 @@ SUBROUTINE scatter_mesh_from_io_to_worker ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN CALL mpi_recv (numelm, 1, MPI_INTEGER, & p_root, mpi_tag_size, p_comm_group, p_stat, p_err) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 index caf415f838..9597e3c662 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 @@ -1254,7 +1254,7 @@ SUBROUTINE read_namelist (nlfile) namelist /nl_colm_history/ DEF_hist_vars ! ----- open the namelist file ----- - IF (p_is_master) THEN + IF (p_is_root) THEN open(10, status='OLD', file=nlfile, form="FORMATTED") read(10, nml=nl_colm, iostat=ierr, iomsg=iomesg) @@ -1618,283 +1618,283 @@ SUBROUTINE read_namelist (nlfile) #ifdef USEMPI - CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_PIO_groupsize ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_nIO_eq_nBlock ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_PIO_groupsize ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_nIO_eq_nBlock ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) #if (defined GRIDBASED || defined UNSTRUCTURED) - CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) #endif #ifdef CATCHMENT - CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) #endif - CALL mpi_bcast (DEF_file_mesh_filter ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_mesh_filter ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (USE_zip_for_aggregation ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Srfdata_CompressLevel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (USE_zip_for_aggregation ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Srfdata_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) ! 07/2023, added by yuan: subgrid setting related - CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) ! 05/2023, added by Xingjie lu - CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) ! LULC related - CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) ! 05/2023, added by yuan - CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) ! 06/2023, added by weinan - CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) ! 06/2023, added by hua yuan - CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) ! 07/2023, added by zhuo liu - CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) ! 02/2024, added by Shupeng Zhang - CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) ! 08/2023, added by hua yuan - CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + + CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) DO ivar = 1, 8 - CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) ENDDO - CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,p_address_master ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) #endif CALL sync_hist_vars (set_defaults = .true.) - IF (p_is_master) THEN + IF (p_is_root) THEN inquire (file=trim(DEF_HIST_vars_namelist), exist=fexists) IF (.not. fexists) THEN @@ -2493,14 +2493,14 @@ SUBROUTINE sync_hist_vars_one (onoff, set_defaults) logical, intent(inout) :: onoff logical, intent(in) :: set_defaults - IF (p_is_master) THEN + IF (p_is_root) THEN IF (set_defaults) THEN onoff = DEF_HIST_vars_out_default ENDIF ENDIF #ifdef USEMPI - CALL mpi_bcast (onoff, 1, mpi_logical, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (onoff, 1, mpi_logical, p_address_root, p_comm_glb, p_err) #endif END SUBROUTINE sync_hist_vars_one diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 index faff0b500a..a2e62143dc 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 @@ -62,7 +62,7 @@ SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) integer :: ncid, varid integer :: iblkme - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -122,7 +122,7 @@ SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) integer :: ncid, varid integer :: iblkme - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -183,7 +183,7 @@ SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) integer :: iblk, jblk, ndims(3), start3(3), count3(3), start_mem integer :: iblkme - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -245,7 +245,7 @@ SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata integer :: ncid, varid integer :: iblkme - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -307,7 +307,7 @@ SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata integer :: ncid, varid integer :: iblkme - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -368,7 +368,7 @@ SUBROUTINE ncio_read_block_real8_3d_time (filename, dataname, grid, ndim1, itime integer :: ncid, varid integer :: iblkme - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -431,7 +431,7 @@ SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) integer, SAVE :: ncid, time_dim logical, SAVE :: fid = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN CALL check_ncfile_exist (filename) IF ((.not. fid) .or. (trim(fileopen) /= trim(filename))) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 index 367f650562..63213746ff 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 @@ -836,10 +836,10 @@ SUBROUTINE ncio_read_bcast_serial_int32_0d (filename, dataname, rdata) integer, intent(out) :: rdata #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_int32_0d (filename, dataname, rdata) ENDIF - CALL mpi_bcast (rdata, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (rdata, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_int32_0d (filename, dataname, rdata) #endif @@ -858,10 +858,10 @@ SUBROUTINE ncio_read_bcast_serial_real8_0d (filename, dataname, rdata) real(r8), intent(out) :: rdata #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_real8_0d (filename, dataname, rdata) ENDIF - CALL mpi_bcast (rdata, 1, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (rdata, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_real8_0d (filename, dataname, rdata) #endif @@ -880,13 +880,13 @@ SUBROUTINE ncio_read_bcast_serial_int32_1d (filename, dataname, rdata) integer :: vlen #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_int32_1d(filename, dataname, rdata) vlen = size(rdata) ENDIF - CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vlen)) - CALL mpi_bcast (rdata, vlen, MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_INTEGER, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_int32_1d(filename, dataname, rdata) #endif @@ -905,13 +905,13 @@ SUBROUTINE ncio_read_bcast_serial_int32_2d (filename, dataname, rdata) integer :: vsize(2) #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_int32_2d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vsize(1), vsize(2))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vsize(1), vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_int32_2d(filename, dataname, rdata) #endif @@ -932,13 +932,13 @@ SUBROUTINE ncio_read_bcast_serial_real8_1d (filename, dataname, rdata) integer :: vlen #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_real8_1d(filename, dataname, rdata) vlen = size(rdata) ENDIF - CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vlen)) - CALL mpi_bcast (rdata, vlen, MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_REAL8, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_real8_1d(filename, dataname, rdata) #endif @@ -959,13 +959,13 @@ SUBROUTINE ncio_read_bcast_serial_real8_2d (filename, dataname, rdata) integer :: vsize(2) #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_real8_2d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_real8_2d(filename, dataname, rdata) #endif @@ -986,13 +986,13 @@ SUBROUTINE ncio_read_bcast_serial_real8_3d (filename, dataname, rdata) integer :: vsize(3) #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_real8_3d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 3, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2),vsize(3))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 3, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_real8_3d(filename, dataname, rdata) #endif @@ -1013,13 +1013,13 @@ SUBROUTINE ncio_read_bcast_serial_real8_4d (filename, dataname, rdata) integer :: vsize(4) #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_real8_4d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 4, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4), MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 4, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4), MPI_REAL8, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_real8_4d(filename, dataname, rdata) #endif @@ -1040,13 +1040,13 @@ SUBROUTINE ncio_read_bcast_serial_real8_5d (filename, dataname, rdata) integer :: vsize(5) #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_real8_5d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 5, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4),vsize(5))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4)*vsize(5), MPI_REAL8, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 5, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4),vsize(5))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4)*vsize(5), MPI_REAL8, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_real8_5d(filename, dataname, rdata) #endif @@ -1066,7 +1066,7 @@ SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) integer(1), allocatable :: rdata_byte(:) #ifdef USEMPI - IF (p_is_master) THEN + IF (p_is_root) THEN CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) vlen = size(rdata_byte) @@ -1075,9 +1075,9 @@ SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) deallocate (rdata_byte) ENDIF - CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err) - IF (.not. p_is_master) allocate (rdata (vlen)) - CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, p_address_master, p_comm_glb, p_err) + CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. p_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, p_address_root, p_comm_glb, p_err) #else CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) vlen = size(rdata_byte) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 index 32653d4d2f..9db5a20a5a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -134,7 +134,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & integer, allocatable :: sbuff(:), rbuff(:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -142,7 +142,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -184,7 +184,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -201,7 +201,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -256,7 +256,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & integer*8, allocatable :: sbuff(:), rbuff(:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -264,7 +264,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -306,7 +306,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -323,7 +323,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -378,7 +378,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & integer(1), allocatable :: sbuff(:), rbuff(:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -386,7 +386,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -432,7 +432,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -449,7 +449,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -505,7 +505,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & real(r8), allocatable :: sbuff(:), rbuff(:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -513,7 +513,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -555,7 +555,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -572,7 +572,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -629,7 +629,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & real(r8), allocatable :: sbuff(:,:), rbuff(:,:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1, pixelset%nset)) ENDIF @@ -637,7 +637,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -679,7 +679,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -696,7 +696,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -753,7 +753,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & real(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1,ndim2, pixelset%nset)) ENDIF @@ -761,7 +761,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -803,7 +803,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -820,7 +820,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -877,7 +877,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & real(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1,ndim2,ndim3, pixelset%nset)) ENDIF @@ -885,7 +885,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -927,7 +927,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -944,7 +944,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1002,7 +1002,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & real(r8), allocatable :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:) logical :: any_data_exists, block_has_data, use_srcpos - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1,ndim2,ndim3,ndim4, pixelset%nset)) ENDIF @@ -1010,7 +1010,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & any_data_exists = .false. - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1052,7 +1052,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & ENDDO #ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif IF (.not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN @@ -1069,7 +1069,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1118,7 +1118,7 @@ SUBROUTINE ncio_create_file_vector (filename, pixelset) integer :: iblkgrp, iblk, jblk character(len=256) :: fileblock - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) @@ -1150,7 +1150,7 @@ SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) character(len=256) :: fileblock logical :: fexists - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) @@ -1196,7 +1196,7 @@ SUBROUTINE ncio_write_vector_int32_1d ( & character(len=256) :: fileblock integer, allocatable :: sbuff(:), rbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1230,7 +1230,7 @@ SUBROUTINE ncio_write_vector_int32_1d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1282,7 +1282,7 @@ SUBROUTINE ncio_write_vector_logical_1d ( & character(len=256) :: fileblock integer(1), allocatable :: sbuff(:), rbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1322,7 +1322,7 @@ SUBROUTINE ncio_write_vector_logical_1d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1382,7 +1382,7 @@ SUBROUTINE ncio_write_vector_int32_3d ( & character(len=256) :: fileblock integer, allocatable :: sbuff(:,:,:), rbuff(:,:,:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1417,7 +1417,7 @@ SUBROUTINE ncio_write_vector_int32_3d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1469,7 +1469,7 @@ SUBROUTINE ncio_write_vector_int64_1d ( & character(len=256) :: fileblock integer*8, allocatable :: sbuff(:), rbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1503,7 +1503,7 @@ SUBROUTINE ncio_write_vector_int64_1d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1556,7 +1556,7 @@ SUBROUTINE ncio_write_vector_real8_1d ( & character(len=256) :: fileblock real(r8), allocatable :: sbuff(:), rbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1589,7 +1589,7 @@ SUBROUTINE ncio_write_vector_real8_1d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1644,7 +1644,7 @@ SUBROUTINE ncio_write_vector_real8_2d ( & character(len=256) :: fileblock real(r8), allocatable :: sbuff(:,:), rbuff(:,:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1679,7 +1679,7 @@ SUBROUTINE ncio_write_vector_real8_2d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1734,7 +1734,7 @@ SUBROUTINE ncio_write_vector_real8_3d ( & character(len=256) :: fileblock real(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1768,7 +1768,7 @@ SUBROUTINE ncio_write_vector_real8_3d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1823,7 +1823,7 @@ SUBROUTINE ncio_write_vector_real8_4d ( & character(len=256) :: fileblock real(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1857,7 +1857,7 @@ SUBROUTINE ncio_write_vector_real8_4d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1913,7 +1913,7 @@ SUBROUTINE ncio_write_vector_real8_5d ( & character(len=256) :: fileblock real(r8), allocatable :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1947,7 +1947,7 @@ SUBROUTINE ncio_write_vector_real8_5d ( & ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) @@ -1979,15 +1979,15 @@ END SUBROUTINE ncio_write_vector_real8_5d LOGICAL FUNCTION ncio_vector_report_missing(mandatory) - USE MOD_SPMD_Task, only: p_iam_io, p_root + USE MOD_SPMD_Task, only: p_iam_active, p_root IMPLICIT NONE logical, intent(in) :: mandatory #ifdef MPAS_EMBEDDED_COLM - ncio_vector_report_missing = mandatory .or. (p_iam_io == p_root) + ncio_vector_report_missing = mandatory .or. (p_iam_active == p_root) #else - ncio_vector_report_missing = (p_iam_io == p_root) + ncio_vector_report_missing = (p_iam_active == p_root) #endif END FUNCTION ncio_vector_report_missing diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 index cf18c44ce0..69f6d2bf3c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 @@ -95,7 +95,7 @@ SUBROUTINE pixel_set_edges (this, & this%lon_w(1) = this%edgew this%lon_e(1) = this%edgee - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,'(A)') '----- Region information -----' write(*,'(A,F10.4,A,F10.4,A,F10.4,A,F10.4,A)') ' (south,north,west,east) = (', & this%edges, ',', this%edgen, ',', this%edgew, ',', this%edgee, ')' @@ -350,7 +350,7 @@ SUBROUTINE pixel_save_to_file (this, dir_landdata) ! Local variables character(len=256) :: filename - IF (p_is_master) THEN + IF (p_is_root) THEN filename = trim(dir_landdata) // '/pixel.nc' diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 index 29b7ccfa32..aa22b27d0d 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -347,7 +347,7 @@ SUBROUTINE vec_gather_scatter_set (this) this%vecgs%vlen(:,:) = 0 ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (.not. allocated (this%vecgs%vstt)) THEN allocate (this%vecgs%vstt (gblock%nxblk, gblock%nyblk)) @@ -379,7 +379,7 @@ SUBROUTINE vec_gather_scatter_set (this) #ifdef COLM_VECTOR_MPI_IO DO jblk = 1, gblock%nyblk DO iblk = 1, gblock%nxblk - IF (gblock%pio(iblk,jblk) == p_address_io(p_my_group)) THEN + IF (gblock%pio(iblk,jblk) == p_address_active(p_my_group)) THEN scnt = this%vecgs%vlen(iblk,jblk) CALL mpi_gather (scnt, 1, MPI_INTEGER, & @@ -392,7 +392,7 @@ SUBROUTINE vec_gather_scatter_set (this) ENDIF #ifdef COLM_VECTOR_MPI_IO - IF (p_is_io) THEN + IF (p_is_active) THEN IF (.not. allocated(this%vecgs%vcnt)) THEN allocate (this%vecgs%vcnt (0:p_np_group-1,gblock%nxblk,gblock%nyblk)) @@ -423,7 +423,7 @@ SUBROUTINE vec_gather_scatter_set (this) ENDIF #endif - IF (p_is_io .or. p_is_worker) THEN + IF (p_is_active .or. p_is_compute) THEN allocate (nonzero (gblock%nxblk,gblock%nyblk)) nonzero = this%vecgs%vlen > 0 @@ -473,7 +473,7 @@ SUBROUTINE pixelset_pack (this, mask, nset_packed) real(r8), allocatable :: pctshared_(:) integer :: s, e - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (this%nset > 0) THEN IF (count(mask) < this%nset) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 index f98194e8e4..d25f51486b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 @@ -56,7 +56,7 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) logical :: has_nan character(len=256) :: wfmt, exception, str_print - IF (p_is_io) THEN + IF (p_is_active) THEN IF (present(spv_in)) THEN spv = spv_in @@ -102,19 +102,19 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) ENDDO #ifdef USEMPI - IF (p_iam_io == p_root) THEN - allocate (gmin_all (0:p_np_io-1)) - allocate (gmax_all (0:p_np_io-1)) - CALL mpi_gather (gmin, 1, MPI_REAL8, gmin_all, 1, MPI_REAL8, p_root, p_comm_io, p_err) - CALL mpi_gather (gmax, 1, MPI_REAL8, gmax_all, 1, MPI_REAL8, p_root, p_comm_io, p_err) + IF (p_iam_active == p_root) THEN + allocate (gmin_all (0:p_np_active-1)) + allocate (gmax_all (0:p_np_active-1)) + CALL mpi_gather (gmin, 1, MPI_REAL8, gmin_all, 1, MPI_REAL8, p_root, p_comm_active, p_err) + CALL mpi_gather (gmax, 1, MPI_REAL8, gmax_all, 1, MPI_REAL8, p_root, p_comm_active, p_err) ELSE - CALL mpi_gather (gmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_io, p_err) - CALL mpi_gather (gmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_io, p_err) + CALL mpi_gather (gmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_active, p_err) + CALL mpi_gather (gmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_active, p_err) ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) - IF (p_iam_io == p_root) THEN + IF (p_iam_active == p_root) THEN IF (any(gmin_all /= spv)) THEN gmin = minval(gmin_all, mask = (gmin_all /= spv)) ELSE @@ -131,7 +131,7 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) deallocate (gmax_all) ENDIF #endif - IF (p_iam_io == p_root) THEN + IF (p_iam_active == p_root) THEN exception = '' @@ -149,19 +149,19 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) write(str_print,wfmt) varname, gmin, gmax, trim(exception) #ifdef USEMPI - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_io(p_root), & + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_active(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_io(p_root), & + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_active(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif @@ -198,7 +198,7 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) logical :: has_nan character(len=256) :: wfmt, exception, str_print - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (present(spv_in)) THEN spv = spv_in @@ -225,19 +225,19 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) ENDIF #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (vmin_all (0:p_np_worker-1)) - allocate (vmax_all (0:p_np_worker-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + IF (p_iam_compute == p_root) THEN + allocate (vmin_all (0:p_np_compute-1)) + allocate (vmax_all (0:p_np_compute-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN IF (any(vmin_all /= spv)) THEN vmin = minval(vmin_all, mask = (vmin_all /= spv)) ELSE @@ -255,7 +255,7 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) ENDIF #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN exception = '' @@ -273,19 +273,19 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) write(str_print,wfmt) varname, vmin, vmax, trim(exception) #ifdef USEMPI - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif @@ -321,7 +321,7 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) logical :: has_nan character(len=256) :: wfmt, exception, str_print - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (present(spv_in)) THEN spv = spv_in @@ -350,19 +350,19 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) ENDIF #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (vmin_all (0:p_np_worker-1)) - allocate (vmax_all (0:p_np_worker-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + IF (p_iam_compute == p_root) THEN + allocate (vmin_all (0:p_np_compute-1)) + allocate (vmax_all (0:p_np_compute-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN IF (any(vmin_all /= spv)) THEN vmin = minval(vmin_all, mask = (vmin_all /= spv)) ELSE @@ -380,7 +380,7 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) ENDIF #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN exception = '' @@ -398,19 +398,19 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) write(str_print,wfmt) varname, vmin, vmax, trim(exception) #ifdef USEMPI - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif @@ -446,7 +446,7 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) logical :: has_nan character(len=256) :: wfmt, exception, str_print - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (present(spv_in)) THEN spv = spv_in @@ -477,20 +477,20 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) ENDIF #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (vmin_all (0:p_np_worker-1)) - allocate (vmax_all (0:p_np_worker-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + IF (p_iam_compute == p_root) THEN + allocate (vmin_all (0:p_np_compute-1)) + allocate (vmax_all (0:p_np_compute-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN IF (any(vmin_all /= spv)) THEN vmin = minval(vmin_all, mask = (vmin_all /= spv)) ELSE @@ -508,7 +508,7 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) ENDIF #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN exception = '' @@ -526,19 +526,19 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) write(str_print,wfmt) varname, vmin, vmax, trim(exception) #ifdef USEMPI - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif @@ -574,7 +574,7 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) logical :: has_nan character(len=256) :: wfmt, exception, str_print - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (present(spv_in)) THEN spv = spv_in @@ -607,20 +607,20 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) ENDIF #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (vmin_all (0:p_np_worker-1)) - allocate (vmax_all (0:p_np_worker-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + IF (p_iam_compute == p_root) THEN + allocate (vmin_all (0:p_np_compute-1)) + allocate (vmax_all (0:p_np_compute-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN IF (any(vmin_all /= spv)) THEN vmin = minval(vmin_all, mask = (vmin_all /= spv)) ELSE @@ -638,7 +638,7 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) ENDIF #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN exception = '' @@ -656,19 +656,19 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) write(str_print,wfmt) varname, vmin, vmax, trim(exception) #ifdef USEMPI - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif @@ -704,7 +704,7 @@ SUBROUTINE check_vector_data_real8_5d (varname, vdata, spv_in, limits) logical :: has_nan character(len=256) :: wfmt, ss, info - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (present(spv_in)) THEN spv = spv_in @@ -734,20 +734,20 @@ SUBROUTINE check_vector_data_real8_5d (varname, vdata, spv_in, limits) ENDDO #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (vmin_all (0:p_np_worker-1)) - allocate (vmax_all (0:p_np_worker-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + IF (p_iam_compute == p_root) THEN + allocate (vmin_all (0:p_np_compute-1)) + allocate (vmax_all (0:p_np_compute-1)) + CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_worker, p_err) + CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN IF (any(vmin_all /= spv)) THEN vmin = minval(vmin_all, mask = (vmin_all /= spv)) ELSE @@ -765,7 +765,7 @@ SUBROUTINE check_vector_data_real8_5d (varname, vdata, spv_in, limits) ENDIF #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN info = '' @@ -814,7 +814,7 @@ SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) integer, allocatable :: vmin_all(:), vmax_all(:) character(len=256) :: wfmt, str_print - IF (p_is_worker) THEN + IF (p_is_compute) THEN isnull = .not. allocated(vdata) @@ -834,20 +834,20 @@ SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) ENDIF #ifdef USEMPI - IF (p_iam_worker == p_root) THEN - allocate (null_all (0:p_np_worker-1)) - allocate (vmin_all (0:p_np_worker-1)) - allocate (vmax_all (0:p_np_worker-1)) - CALL mpi_gather (isnull, 1, MPI_LOGICAL, null_all, 1, MPI_LOGICAL, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmin, 1, MPI_INTEGER, vmin_all, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_INTEGER, vmax_all, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + IF (p_iam_compute == p_root) THEN + allocate (null_all (0:p_np_compute-1)) + allocate (vmin_all (0:p_np_compute-1)) + allocate (vmax_all (0:p_np_compute-1)) + CALL mpi_gather (isnull, 1, MPI_LOGICAL, null_all, 1, MPI_LOGICAL, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmin, 1, MPI_INTEGER, vmin_all, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_INTEGER, vmax_all, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) ELSE - CALL mpi_gather (isnull, 1, MPI_LOGICAL, MPI_LNULL_P, 1, MPI_LOGICAL, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmin, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) - CALL mpi_gather (vmax, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_worker, p_err) + CALL mpi_gather (isnull, 1, MPI_LOGICAL, MPI_LNULL_P, 1, MPI_LOGICAL, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmin, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) + CALL mpi_gather (vmax, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) ENDIF - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN IF (present(spv_in)) THEN null_all = null_all .and. (vmin_all == spv_in) ENDIF @@ -861,19 +861,19 @@ SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) ENDIF #endif - IF (p_iam_worker == p_root) THEN + IF (p_iam_compute == p_root) THEN wfmt = "('Check vector data:', A25, ' is in (', I20, ',', I20, ')')" write(str_print,wfmt) varname, vmin, vmax #ifdef USEMPI - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_master, & + CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif ENDIF ENDIF - IF (p_is_master) THEN + IF (p_is_root) THEN #ifdef USEMPI - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_worker(p_root), & + CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif write(*,'(A)') trim(str_print) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 index bf85591aec..02e29abe97 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 @@ -7,11 +7,8 @@ MODULE MOD_SPMD_Task ! ! SPMD refers to "Single PROGRAM/Multiple Data" parallelization. ! -! In MPAS-embedded CoLM the standalone CoLM MPI master/IO/worker split is not -! used. MPAS owns MPI initialization and decomposition; every MPAS rank stays -! active as a CoLM compute rank, with rank 0 used only for legacy logging/error -! compatibility. The io/worker communicator names below are compatibility -! aliases for older CoLM helper APIs, not separate process pools. +! MPAS owns MPI initialization and decomposition. Every MPAS rank stays active +! as a CoLM compute rank, with rank 0 used only for logging/error aggregation. ! ! CoLM element ownership is supplied by MPAS cell ownership. Patch/PFT state ! remains internal to CoLM and is mapped back to the owning element/cell by CoLM. @@ -26,10 +23,10 @@ MODULE MOD_SPMD_Task integer, parameter :: p_root = 0 - logical :: p_is_master = .false. - logical :: p_is_io = .false. - logical :: p_is_worker = .false. - logical :: p_is_writeback = .false. + logical :: p_is_root = .false. + logical :: p_is_active = .false. + logical :: p_is_compute = .false. + logical :: p_is_history_task = .false. integer :: p_comm_glb_plus = MPI_COMM_NULL integer :: p_iam_glb_plus = -1 @@ -44,23 +41,23 @@ MODULE MOD_SPMD_Task integer :: p_np_group = 0 integer :: p_my_group = 0 - integer :: p_address_master = p_root + integer :: p_address_root = p_root - integer :: p_comm_io = MPI_COMM_NULL - integer :: p_iam_io = -1 - integer :: p_np_io = 0 + integer :: p_comm_active = MPI_COMM_NULL + integer :: p_iam_active = -1 + integer :: p_np_active = 0 - integer, allocatable :: p_itis_io (:) - integer, allocatable :: p_address_io (:) + integer, allocatable :: p_itis_active (:) + integer, allocatable :: p_address_active (:) - integer :: p_comm_worker = MPI_COMM_NULL - integer :: p_iam_worker = -1 - integer :: p_np_worker = 0 + integer :: p_comm_compute = MPI_COMM_NULL + integer :: p_iam_compute = -1 + integer :: p_np_compute = 0 - integer, allocatable :: p_itis_worker (:) - integer, allocatable :: p_address_worker (:) + integer, allocatable :: p_itis_compute (:) + integer, allocatable :: p_address_compute (:) - integer :: p_address_writeback = -1 + integer :: p_address_history_task = -1 integer :: p_stat (MPI_STATUS_SIZE) integer :: p_err = 0 @@ -78,7 +75,7 @@ MODULE MOD_SPMD_Task PUBLIC :: spmd_init PUBLIC :: spmd_exit PUBLIC :: divide_processes_into_groups - PUBLIC :: spmd_assign_writeback + PUBLIC :: spmd_assign_history_task CONTAINS @@ -105,44 +102,44 @@ SUBROUTINE spmd_init (MyComm_r) CALL mpi_comm_rank (p_comm_glb, p_iam_glb, p_err) CALL mpi_comm_size (p_comm_glb, p_np_glb, p_err) - p_address_master = p_root - p_is_master = (p_iam_glb == p_address_master) - p_is_io = .true. - p_is_worker = .true. - p_is_writeback = .false. + p_address_root = p_root + p_is_root = (p_iam_glb == p_address_root) + p_is_active = .true. + p_is_compute = .true. + p_is_history_task = .false. p_comm_group = p_comm_glb p_iam_group = p_iam_glb p_np_group = p_np_glb p_my_group = 0 - p_comm_io = p_comm_glb - p_iam_io = p_iam_glb - p_np_io = p_np_glb + p_comm_active = p_comm_glb + p_iam_active = p_iam_glb + p_np_active = p_np_glb - p_comm_worker = p_comm_glb - p_iam_worker = p_iam_glb - p_np_worker = p_np_glb + p_comm_compute = p_comm_glb + p_iam_compute = p_iam_glb + p_np_compute = p_np_glb p_comm_glb_plus = MPI_COMM_NULL p_iam_glb_plus = -1 - p_address_writeback = -1 + p_address_history_task = -1 - IF (allocated(p_itis_io )) deallocate (p_itis_io ) - IF (allocated(p_address_io )) deallocate (p_address_io ) - IF (allocated(p_itis_worker )) deallocate (p_itis_worker ) - IF (allocated(p_address_worker)) deallocate (p_address_worker) + IF (allocated(p_itis_active )) deallocate (p_itis_active ) + IF (allocated(p_address_active )) deallocate (p_address_active ) + IF (allocated(p_itis_compute )) deallocate (p_itis_compute ) + IF (allocated(p_address_compute)) deallocate (p_address_compute) - allocate (p_itis_io (0:p_np_glb-1)) - allocate (p_address_io (0:p_np_glb-1)) - allocate (p_itis_worker (0:p_np_glb-1)) - allocate (p_address_worker (0:p_np_glb-1)) + allocate (p_itis_active (0:p_np_glb-1)) + allocate (p_address_active (0:p_np_glb-1)) + allocate (p_itis_compute (0:p_np_glb-1)) + allocate (p_address_compute (0:p_np_glb-1)) DO iproc = 0, p_np_glb-1 - p_itis_io(iproc) = iproc - p_address_io(iproc) = iproc - p_itis_worker(iproc) = iproc - p_address_worker(iproc) = iproc + p_itis_active(iproc) = iproc + p_address_active(iproc) = iproc + p_itis_compute(iproc) = iproc + p_address_compute(iproc) = iproc ENDDO END SUBROUTINE spmd_init @@ -168,10 +165,10 @@ END SUBROUTINE divide_processes_into_groups !----------------------------------------- SUBROUTINE spmd_exit - IF (allocated(p_itis_io )) deallocate (p_itis_io ) - IF (allocated(p_address_io )) deallocate (p_address_io ) - IF (allocated(p_itis_worker )) deallocate (p_itis_worker ) - IF (allocated(p_address_worker)) deallocate (p_address_worker) + IF (allocated(p_itis_active )) deallocate (p_itis_active ) + IF (allocated(p_address_active )) deallocate (p_address_active ) + IF (allocated(p_itis_compute )) deallocate (p_itis_compute ) + IF (allocated(p_address_compute)) deallocate (p_address_compute) IF (p_comm_glb /= MPI_COMM_NULL) THEN CALL mpi_barrier (p_comm_glb, p_err) @@ -180,19 +177,19 @@ SUBROUTINE spmd_exit p_comm_glb = MPI_COMM_NULL p_comm_group = MPI_COMM_NULL - p_comm_io = MPI_COMM_NULL - p_comm_worker = MPI_COMM_NULL + p_comm_active = MPI_COMM_NULL + p_comm_compute = MPI_COMM_NULL END SUBROUTINE spmd_exit ! ----- ----- - SUBROUTINE spmd_assign_writeback () + SUBROUTINE spmd_assign_history_task () IMPLICIT NONE - CALL CoLM_stop('MPAS embedded CoLM does not support a standalone writeback MPI task.') + CALL CoLM_stop('MPAS embedded CoLM does not support a standalone history MPI task.') - END SUBROUTINE spmd_assign_writeback + END SUBROUTINE spmd_assign_history_task ! -- STOP all processes -- SUBROUTINE CoLM_stop (mesg) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 index f10bbd8181..730feb831e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 @@ -124,7 +124,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,"(A, I0, A, I0, A)") & 'Making areal weighted mapping between pixel set and grid: ', & @@ -196,7 +196,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN this%npset = pixelset%nset @@ -367,10 +367,10 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDDO #endif - allocate (this%glist (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 + allocate (this%glist (0:p_np_active-1)) + DO iproc = 0, p_np_active-1 #ifdef USEMPI - msk = (ipt == p_address_io(iproc)) + msk = (ipt == p_address_active(iproc)) ng = count(msk) #else ng = ng_all @@ -424,7 +424,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) yblk = fgrid%yblk(ilat) #ifdef USEMPI - iproc = p_itis_io(gblock%pio(xblk,yblk)) + iproc = p_itis_active(gblock%pio(xblk,yblk)) #else iproc = 0 #endif @@ -450,10 +450,10 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDIF #ifdef USEMPI - IF (p_is_worker) THEN + IF (p_is_compute) THEN - DO iproc = 0, p_np_io-1 - idest = p_address_io(iproc) + DO iproc = 0, p_np_active-1 + idest = p_address_active(iproc) smesg = (/p_iam_glb, this%glist(iproc)%ng/) CALL mpi_send (smesg, 2, MPI_INTEGER, & @@ -469,18 +469,18 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN - allocate (this%glist (0:p_np_worker-1)) + allocate (this%glist (0:p_np_compute-1)) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 CALL mpi_recv (rmesg, 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = rmesg(1) nrecv = rmesg(2) - iproc = p_itis_worker(isrc) + iproc = p_itis_compute(isrc) this%glist(iproc)%ng = nrecv @@ -498,7 +498,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDIF #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (this%npset > 0) THEN allocate (this%areapset (this%npset)) this%areapset(:) = 0. @@ -510,8 +510,8 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDDO ENDIF - IF (p_is_io) CALL allocate_block_data (fgrid, this%areagrid) - IF (p_is_worker) THEN + IF (p_is_active) CALL allocate_block_data (fgrid, this%areagrid) + IF (p_is_compute) THEN IF (this%npset > 0) THEN allocate (msk (this%npset)) msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 @@ -572,7 +572,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN + IF (p_is_root) THEN write(*,*) write(*,"(A, I0, A, I0, A)") & @@ -609,7 +609,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (this%grid%lat_s(this%grid%nlat)); this%grid%lat_s = fgrid%lat_s allocate (this%grid%lat_n(this%grid%nlat)); this%grid%lat_n = fgrid%lat_n @@ -749,10 +749,10 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDDO #endif - allocate (this%glist (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 + allocate (this%glist (0:p_np_active-1)) + DO iproc = 0, p_np_active-1 #ifdef USEMPI - msk = (ipt == p_address_io(iproc)) + msk = (ipt == p_address_active(iproc)) ng = count(msk) #else ng = nglist @@ -785,9 +785,9 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDIF #ifdef USEMPI - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 - idest = p_address_io(iproc) + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 + idest = p_address_active(iproc) smesg = (/p_iam_glb, this%glist(iproc)%ng/) CALL mpi_send (smesg, 2, MPI_INTEGER, & @@ -802,18 +802,18 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDDO ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN - allocate (this%glist (0:p_np_worker-1)) + allocate (this%glist (0:p_np_compute-1)) - DO iworker = 0, p_np_worker-1 + DO iworker = 0, p_np_compute-1 CALL mpi_recv (rmesg, 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) isrc = rmesg(1) nrecv = rmesg(2) - iproc = p_itis_worker(isrc) + iproc = p_itis_compute(isrc) this%glist(iproc)%ng = nrecv @@ -834,7 +834,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_worker) THEN + IF (p_is_compute) THEN allocate (this%address (this%npset)) allocate (this%npart (this%npset)) @@ -875,7 +875,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) #ifdef USEMPI xblk = this%grid%xblk(ix) yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) + iproc = p_itis_active(gblock%pio(xblk,yblk)) #else iproc = 0 #endif @@ -890,7 +890,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) #ifdef USEMPI xblk = this%grid%xblk(ix) yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) + iproc = p_itis_active(gblock%pio(xblk,yblk)) #else iproc = 0 #endif @@ -905,7 +905,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) #ifdef USEMPI xblk = this%grid%xblk(ix) yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) + iproc = p_itis_active(gblock%pio(xblk,yblk)) #else iproc = 0 #endif @@ -920,7 +920,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) #ifdef USEMPI xblk = this%grid%xblk(ix) yblk = this%grid%yblk(iy) - iproc = p_itis_io(gblock%pio(xblk,yblk)) + iproc = p_itis_active(gblock%pio(xblk,yblk)) #else iproc = 0 #endif @@ -934,7 +934,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (this%npset > 0) THEN allocate (this%areapset (this%npset)) ENDIF @@ -943,8 +943,8 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDDO ENDIF - IF (p_is_io) CALL allocate_block_data (fgrid, this%areagrid) - IF (p_is_worker) THEN + IF (p_is_active) CALL allocate_block_data (fgrid, this%areagrid) + IF (p_is_compute) THEN IF (this%npset > 0) THEN allocate (msk (this%npset)) msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 @@ -1008,9 +1008,9 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) this%has_missing_value = .true. this%missing_value = missing_value - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -1028,7 +1028,7 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) ENDDO #ifdef USEMPI - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -1048,17 +1048,17 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_io(iproc) + isrc = p_address_active(iproc) CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -1090,7 +1090,7 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) ENDDO - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1129,14 +1129,14 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod character(len=256) :: inmode real(r8) :: sumwt - IF (p_is_worker) THEN + IF (p_is_compute) THEN inmode = 'average' IF (present(input_mode)) inmode = trim(input_mode) - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) @@ -1184,9 +1184,9 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1195,7 +1195,7 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN IF (present(spv)) THEN CALL flush_block_data (gdata, spv) @@ -1203,13 +1203,13 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod CALL flush_block_data (gdata, 0.0_r8) ENDIF - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -1252,8 +1252,8 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod ENDIF - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1291,14 +1291,14 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) type(pointer_real8_2d), allocatable :: pbuff(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) lb1 = lbound(pdata,1) ub1 = ubound(pdata,1) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (lb1:ub1, this%glist(iproc)%ng)) @@ -1339,9 +1339,9 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, & (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -1352,7 +1352,7 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN lb1 = gdata%lb1 ub1 = gdata%ub1 @@ -1363,13 +1363,13 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) CALL flush_block_data (gdata, 0.0_r8) ENDIF - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (lb1:ub1, this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, & (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) @@ -1409,8 +1409,8 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1446,9 +1446,9 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) real(r8), allocatable :: gbuff(:,:,:) type(pointer_real8_3d), allocatable :: pbuff(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) lb1 = lbound(pdata,1) ub1 = ubound(pdata,1) @@ -1458,7 +1458,7 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ub2 = ubound(pdata,2) ndim2 = ub2 - lb2 + 1 - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) @@ -1501,9 +1501,9 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1512,7 +1512,7 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN lb1 = gdata%lb1 ub1 = gdata%ub1 @@ -1528,13 +1528,13 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) CALL flush_block_data (gdata, 0.0_r8) ENDIF - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -1573,8 +1573,8 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ENDDO ENDIF - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1609,11 +1609,11 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) pbuff(iproc)%val(:) = spval @@ -1643,9 +1643,9 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1654,17 +1654,17 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL flush_block_data (gdata, spval) - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -1695,8 +1695,8 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1732,16 +1732,16 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff (:) - IF (p_is_worker) THEN - allocate (pbuff (0:p_np_io-1)) - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + allocate (pbuff (0:p_np_active-1)) + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) ENDIF ENDDO ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL flush_block_data (gdata, spv) ENDIF @@ -1749,9 +1749,9 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, DO ityp = 1, ntyps - IF (p_is_worker) THEN + IF (p_is_compute) THEN - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN pbuff(iproc)%val(:) = spv ENDIF @@ -1775,9 +1775,9 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1786,15 +1786,15 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -1831,8 +1831,8 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, #endif ENDDO - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1863,11 +1863,11 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) pbuff(iproc)%val(:) = 0.0 @@ -1888,9 +1888,9 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1899,17 +1899,17 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL flush_block_data (sumarea, 0.0_r8) - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -1934,8 +1934,8 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) ENDIF - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1968,9 +1968,9 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -1988,7 +1988,7 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) ENDDO #ifdef USEMPI - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -1999,17 +1999,17 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_io(iproc) + isrc = p_address_active(iproc) CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -2043,7 +2043,7 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) ENDDO - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2079,9 +2079,9 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) type(pointer_real8_2d), allocatable :: pbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (ndim1, this%glist(iproc)%ng)) @@ -2098,7 +2098,7 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) ENDDO #ifdef USEMPI - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) CALL mpi_send (gbuff, ndim1 * this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -2109,17 +2109,17 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_io(iproc) + isrc = p_address_active(iproc) CALL mpi_recv (pbuff(iproc)%val, ndim1 * this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -2154,7 +2154,7 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) ENDDO - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2188,9 +2188,9 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) integer, allocatable :: gbuff(:) type(pointer_int32_1d), allocatable :: pbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2208,7 +2208,7 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) ENDDO #ifdef USEMPI - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -2219,17 +2219,17 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_io(iproc) + isrc = p_address_active(iproc) CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -2250,7 +2250,7 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) ENDIF ENDDO - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2286,9 +2286,9 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) type(pointer_real8_1d), allocatable :: pbuff(:) real(r8), allocatable :: pdata_tem(:) - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2306,7 +2306,7 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) ENDDO #ifdef USEMPI - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -2317,18 +2317,18 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) allocate (pdata_tem (size(pdata))) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_io(iproc) + isrc = p_address_active(iproc) CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -2362,7 +2362,7 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) pdata = pdata_tem - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2397,9 +2397,9 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_io) THEN + IF (p_is_active) THEN - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2417,7 +2417,7 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) ENDDO #ifdef USEMPI - idest = p_address_worker(iproc) + idest = p_address_compute(iproc) CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -2428,17 +2428,17 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_io(iproc) + isrc = p_address_active(iproc) CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -2457,7 +2457,7 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) ENDDO ENDDO - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2491,11 +2491,11 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_worker) THEN + IF (p_is_compute) THEN - allocate (pbuff (0:p_np_io-1)) + allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) pbuff(iproc)%val(:) = 0.0 @@ -2513,9 +2513,9 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) ENDDO #ifdef USEMPI - DO iproc = 0, p_np_io-1 + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_io(iproc) + idest = p_address_active(iproc) CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & idest, mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -2524,17 +2524,17 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) ENDIF - IF (p_is_io) THEN + IF (p_is_active) THEN CALL flush_block_data (gdata, 0.0_r8) - DO iproc = 0, p_np_worker-1 + DO iproc = 0, p_np_compute-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) #ifdef USEMPI - isrc = p_address_worker(iproc) + isrc = p_address_compute(iproc) CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) #else @@ -2571,8 +2571,8 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) ENDIF - IF (p_is_worker) THEN - DO iproc = 0, p_np_io-1 + IF (p_is_compute) THEN + DO iproc = 0, p_np_active-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2606,12 +2606,12 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) type(pointer_real8_1d), allocatable :: scaldata(:) - IF (p_is_io) CALL allocate_block_data (this%grid, sumdata) - IF (p_is_worker) CALL this%allocate_part (scaldata) + IF (p_is_active) CALL allocate_block_data (this%grid, sumdata) + IF (p_is_compute) CALL this%allocate_part (scaldata) CALL this%part2grid (sdata, sumdata) - IF (p_is_io) THEN + IF (p_is_active) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) @@ -2626,7 +2626,7 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) CALL this%grid2part (sumdata, scaldata) - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iset = 1, this%npset DO ipart = 1, this%npart(iset) @@ -2640,7 +2640,7 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) ENDIF - IF (p_is_worker) deallocate(scaldata) + IF (p_is_compute) deallocate(scaldata) END SUBROUTINE spatial_mapping_normalize @@ -2662,7 +2662,7 @@ SUBROUTINE spatial_mapping_part2pset (this, sdata, pdata) ! Local variables integer :: iset - IF (p_is_worker) THEN + IF (p_is_compute) THEN pdata(:) = spval @@ -2690,7 +2690,7 @@ SUBROUTINE spatial_mapping_allocate_part (this, datapart) ! Local variables integer :: iset - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (this%npset > 0) THEN allocate (datapart (this%npset)) @@ -2720,7 +2720,7 @@ SUBROUTINE spatial_mapping_deallocate_part (this, datapart) ! Local variables integer :: iset - IF (p_is_worker) THEN + IF (p_is_compute) THEN DO iset = 1, this%npset IF (this%npart(iset) > 0) THEN @@ -2765,7 +2765,7 @@ SUBROUTINE spatial_mapping_free_mem (this) deallocate (this%glist) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (allocated(this%npart)) deallocate(this%npart) @@ -2823,7 +2823,7 @@ SUBROUTINE forc_free_mem_spatial_mapping(this) deallocate (this%glist) ENDIF - IF (p_is_worker) THEN + IF (p_is_compute) THEN IF (allocated(this%npart)) deallocate(this%npart) From 567125ca7553d83f939c4cf30546006274487d4a Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 21:47:30 +0800 Subject: [PATCH 04/17] Keep embedded CoLM landdata loading on MPAS-owned ranks Constraint: MPAS embedded CoLM runs every MPAS rank as both active and compute, so legacy IO/worker scatter paths deadlock or reallocate local state. Rejected: Reintroducing standalone CoLM process pools | it conflicts with MPAS-owned decomposition and the cell==element integration target. Confidence: high Scope-risk: moderate Directive: Keep landdata reads on original block files; use rank-suffixed vector files only for MPAS-owned writes. Tested: cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; NETCDF=/opt/homebrew/Cellar/netcdf/4.10.0 NETCDFF=/opt/homebrew/Cellar/netcdf-fortran/4.6.2 PNETCDF=/opt/homebrew/Cellar/pnetcdf/1.14.1 make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true -j 8 Not-tested: Runtime MPAS+CoLM case with real landdata/restart inputs. --- .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 2 +- .../mksrfdata/MOD_SrfdataRestart.F90 | 4 ++- .../physics_colm2024/share/MOD_Block.F90 | 7 ++++ .../share/MOD_NetCDFVector.F90 | 33 +++++++++++-------- 4 files changed, 30 insertions(+), 16 deletions(-) diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index 356f48cf58..973d30891a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -472,7 +472,7 @@ SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cel old_to_new(i) = packed_count ENDIF ENDDO - IF (packed_count < 1) RETURN + IF (packed_count /= n_mpas_cells) RETURN CALL colm_mpas_pack_mesh(keep_elm, old_to_new) CALL landelm%pset_pack(keep_elm, packed_count) diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 index c5f20253fd..3fd25d0cbe 100644 --- a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 @@ -447,7 +447,9 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) #endif #ifdef USEMPI +#ifndef MPAS_EMBEDDED_COLM CALL scatter_mesh_from_io_to_worker +#endif CALL mpi_barrier (p_comm_glb, p_err) #endif @@ -694,7 +696,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) IF (p_is_active) THEN IF (pixelset%nset > 0) THEN allocate (iworker (pixelset%nset)) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 index d8506a51f7..e46580e731 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 @@ -252,7 +252,14 @@ SUBROUTINE block_load_from_file (this, dir_landdata) write (*,*) ENDIF +#ifdef MPAS_EMBEDDED_COLM + IF (allocated(this%pio)) deallocate(this%pio) + allocate (this%pio (this%nxblk,this%nyblk)) + this%pio(:,:) = -1 + this%nblkme = 0 +#else CALL this%read_pio (dir_landdata) +#endif END SUBROUTINE block_load_from_file diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 index 9db5a20a5a..7cdbca56e5 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -87,26 +87,31 @@ SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write character(len=256) :: fileblock_rank character(len=32) :: rank_suffix integer :: idot + logical :: rank_local_file #endif CALL get_filename_block (filename, iblk, jblk, fileblock) #ifdef MPAS_EMBEDDED_COLM - write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb - idot = len_trim(fileblock) - DO WHILE (idot > 0) - IF (fileblock(idot:idot) == '.') EXIT - idot = idot - 1 - ENDDO - - IF (idot > 0) THEN - fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) - ELSE - fileblock_rank = trim(fileblock) // trim(rank_suffix) - ENDIF + rank_local_file = .false. + IF (present(for_write)) rank_local_file = for_write + IF (rank_local_file) THEN + write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb + idot = len_trim(fileblock) + DO WHILE (idot > 0) + IF (fileblock(idot:idot) == '.') EXIT + idot = idot - 1 + ENDDO - fileblock = fileblock_rank - IF (present(use_srcpos)) use_srcpos = .false. + IF (idot > 0) THEN + fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) + ELSE + fileblock_rank = trim(fileblock) // trim(rank_suffix) + ENDIF + + fileblock = fileblock_rank + IF (present(use_srcpos)) use_srcpos = .false. + ENDIF #endif END SUBROUTINE get_filename_vector_block From f1be06c0a2f22457b5945de8359640e9b7cf1d51 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 21:55:56 +0800 Subject: [PATCH 05/17] Remove standalone CoLM run materials from embedded tree Constraint: CoLM2024 is now built and run only as the MPAS sf_colm2024 land-surface scheme in this repository. Rejected: Deleting CoLM core driver or mksrfdata modules | they remain in the MPAS adapter and build dependency chain. Confidence: high Scope-risk: narrow Directive: Keep future CoLM examples and forcing namelists outside the embedded MPAS source tree unless MPAS itself consumes them. Tested: rg found no remaining references to deleted run/evaluation files; rg found no standalone PROGRAM in physics_colm2024; git diff --cached --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; NETCDF=/opt/homebrew/Cellar/netcdf/4.10.0 NETCDFF=/opt/homebrew/Cellar/netcdf-fortran/4.6.2 PNETCDF=/opt/homebrew/Cellar/pnetcdf/1.14.1 make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true -j 8 Not-tested: Runtime MPAS+CoLM case with real landdata/restart inputs. --- .../physics/physics_colm2024/.gitignore | 2 +- .../physics/physics_colm2024/Makefile | 2 +- .../physics/physics_colm2024/README.md | 13 +- .../physics/physics_colm2024/ReadMeEvaluation | 1 - .../physics_colm2024/run/NmlNameFormatReadme | 127 ------- .../run/examples/CRA40_Grid_30km_IGBP_VG.nml | 71 ---- .../run/examples/China_Grid_50km_IGBP_VG.nml | 68 ---- .../examples/Global_Grid_2x2_PFT_VG_BGC.nml | 69 ---- .../Global_Grid_50km_IGBP_CB_URBAN.nml | 126 ------- .../examples/GreaterBay_Grid_10km_IGBP_VG.nml | 73 ---- .../PearlRiver_Catch_100km_IGBP_VG.nml | 53 --- .../examples/PoyangLake_Grid_5km_IGBP_VG.nml | 65 ---- .../RegChina_Grid_50km_IGBP_CB_LULCC.nml | 110 ------ .../run/examples/SiteSYSUAtmos_IGBP_VG.nml | 64 ---- .../run/examples/full_history_variables.nml | 353 ------------------ .../physics_colm2024/run/forcing/CLDAS.nml | 50 --- .../physics_colm2024/run/forcing/CMFD.nml | 51 --- .../physics_colm2024/run/forcing/CMFDv2.nml | 51 --- .../physics_colm2024/run/forcing/CRA40.nml | 50 --- .../physics_colm2024/run/forcing/CRUJRA.nml | 48 --- .../run/forcing/CRUNCEPV4.nml | 45 --- .../run/forcing/CRUNCEPV7.nml | 45 --- .../physics_colm2024/run/forcing/ERA5.nml | 53 --- .../physics_colm2024/run/forcing/ERA5LAND.nml | 50 --- .../run/forcing/ERA5_LEddy.nml | 50 --- .../physics_colm2024/run/forcing/GDAS.nml | 51 --- .../physics_colm2024/run/forcing/GSWP3.nml | 44 --- .../physics_colm2024/run/forcing/IsoGSM.nml | 68 ---- .../physics_colm2024/run/forcing/JRA3Q.nml | 47 --- .../physics_colm2024/run/forcing/JRA55.nml | 46 --- .../run/forcing/MPI-ESM1-2-HR_ssp585.nml | 45 --- .../physics_colm2024/run/forcing/MSWX.nml | 45 --- .../physics_colm2024/run/forcing/POINT.nml | 31 -- .../run/forcing/PRINCETON.nml | 45 --- .../physics_colm2024/run/forcing/QIAN.nml | 45 --- .../physics_colm2024/run/forcing/TPMFD.nml | 50 --- .../physics_colm2024/run/forcing/WFDE5.nml | 48 --- .../physics_colm2024/run/forcing/WFDEI.nml | 49 --- .../physics/physics_colm2024/run/mapdata.txt | 5 - .../physics_colm2024/run/test_vic_para.nml | 111 ------ 40 files changed, 13 insertions(+), 2407 deletions(-) delete mode 100644 src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt delete mode 100644 src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml diff --git a/src/core_atmosphere/physics/physics_colm2024/.gitignore b/src/core_atmosphere/physics/physics_colm2024/.gitignore index c0d791f49b..62b6d29223 100644 --- a/src/core_atmosphere/physics/physics_colm2024/.gitignore +++ b/src/core_atmosphere/physics/physics_colm2024/.gitignore @@ -1,12 +1,12 @@ .DS_Store -run/log_CaMa.txt *.pyc __pycache__ *.o *.mod .vscode .bld +.mpas lib *.a *.x diff --git a/src/core_atmosphere/physics/physics_colm2024/Makefile b/src/core_atmosphere/physics/physics_colm2024/Makefile index e3015c7d70..c96a71cb93 100644 --- a/src/core_atmosphere/physics/physics_colm2024/Makefile +++ b/src/core_atmosphere/physics/physics_colm2024/Makefile @@ -1,4 +1,4 @@ -# Makefile for CoLM program +# Object list and staging rules for MPAS-embedded CoLM2024. include include/Makeoptions HEADER = include/define.h diff --git a/src/core_atmosphere/physics/physics_colm2024/README.md b/src/core_atmosphere/physics/physics_colm2024/README.md index 3f17afd572..d08b93f20e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/README.md +++ b/src/core_atmosphere/physics/physics_colm2024/README.md @@ -1,3 +1,12 @@ -# The Common Land Model Version 202X (CoLM202X) +# MPAS-Embedded CoLM2024 -[![Build_CoLM202X_gnu](https://github.com/CoLM-SYSU/CoLM202X/actions/workflows/build_CoLM_gnu.yml/badge.svg)](https://github.com/CoLM-SYSU/CoLM202X/actions/workflows/build_CoLM_gnu.yml) +This directory contains the CoLM2024 land-surface physics used by +MPAS-Atmosphere when `config_lsm_scheme = 'sf_colm2024'`. + +Build CoLM2024 through MPAS: + +- CMake: configure with `-DMPAS_COLM2024=ON`. +- Make: build atmosphere with `COLM2024=true`. + +Standalone CoLM run cases, forcing namelist examples, and evaluation scripts +are intentionally not kept in this embedded source tree. diff --git a/src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation b/src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation deleted file mode 100644 index a95c4d07d1..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/ReadMeEvaluation +++ /dev/null @@ -1 +0,0 @@ -Evaluation script for CoLM can be down load from github: https://github.com/CoLM-SYSU/CoLM-Evaluation.git diff --git a/src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme b/src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme deleted file mode 100644 index 856f508a89..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/NmlNameFormatReadme +++ /dev/null @@ -1,127 +0,0 @@ -########################################################################################### - Rules to Name your nml file - - Your nml file should be named in following format: - - REGION{_STRUCTURE}{_RES}_LANDTYPE_SOILMODEL[_BGC][_URBAN][_LULCC].nml - - eg. Global_Grid_2x2_PFT_VG_BGC.nml - SiteCNDin_IGBP_CB.nml - - Please leave your name at begining of the namelist file, - eg. Author: Xingjie Lu -########################################################################################### - - Detailed description of each tag in the namelist format: - - Region (mandatory): - The abbrevation of the model simulation region. - Existing definitions of the model simulation regions includes: - - -------------------------------------------------------------------------------------- - Abbreviation Description Edges - -------------------------------------------------------------------------------------- - Global Global region: edges = -90.0; edgen = 90.0; - edgew = -180.0; edgee = 180.0 - RegChina China region: edges = 18.0; edgen = 54.0; - edgew = 73.0; edgee = 135.0 - RegPearl Pearl catchment region: edges = 21.0; edgen = 27.0; - edgew = 100.0; edgee = 115.0 - RegTibet Tibet Plateau region: edges = 25.0; edgen = 40.0; - edgew = 75.0; edgee = 105.0 - ... - SiteCNDin Dinghushan site: latitude = 23.17329979; - longitude = 112.5361023 - ... - -------------------------------------------------------------------------------------- - - STRUCTURE (conditional, only applicable for global and regional simulation, not for site) - The abbreviation of the model spatial structure. - Existing definitions of the model spatail structure includes: - - -------------------------------------------------------------------------------------- - Abbreviation Description - -------------------------------------------------------------------------------------- - Grid Latitude-longitude grid: grid cells are partitioned by latitudes - and longitudes with a constant interval. - Unstr Unstructure grid: grid cells are formed by polygons according to the - heteorogeneity of soil properties, vegetation types and ... - Catch Catchment grid: grid cells represent catchment units, - which is generated from the DEM data. - -------------------------------------------------------------------------------------- - - RES (conditional: only applicable when "STRUCTURE=Grid"): - The abbreviation of the grid resolution. - Existing definitions of grid resolution includes: - - --------------------------------------------------------------------------------------- - Abbreviation Description (longitude resolution x latitude resolution (in degree)) - --------------------------------------------------------------------------------------- - 2x2 2.5x1.875 - 1x1 1x1 - 50km 0.5x0.5 - 25km 0.25x0.25 - 10km 0.1x0.1 - --------------------------------------------------------------------------------------- - - LANDTYPE (mandatory): - The abbreviation of the land cover type classification, including the subgrid structure. - Existing definition of the land cover type classification includes: - - --------------------------------------------------------------------------------------- - Abbreviation Description Patch subgrid - --------------------------------------------------------------------------------------- - USGS USGS land cover patch No patch subgrid - IGBP IGBP land cover patch No patch subgrid - PFT IGBP land cover patch All soil patches within a grid cell has been - with plant functional aggregated and divided into multiple PFT - type subgrid subgrids - PC IGBP land cover patch Each IGBP patch has been divided into - with plant community multiple PFT subgrids - subgrid. - --------------------------------------------------------------------------------------- - - SOILMODEL (mandatory): - The abbreviation of soil hydraulics models. - Existing definition of the soil hydraulics models include: - - --------------------------------------------------------------------------------------- - Abbreviation Long name - --------------------------------------------------------------------------------------- - CB Campbell model - VG vanGenuchten Mualem model - --------------------------------------------------------------------------------------- - - BGC (optional, if not present, the namelist must indicate a bgc off simulation): - The abbreviation of biogeochemical model switches. - Existing definition of the biogeochemical model switches include: - - --------------------------------------------------------------------------------------- - Abbreviation Description - --------------------------------------------------------------------------------------- - (not present) BGC is turned off - BGC BGC is defined, but CROP is undef in define.h - BGCCROP Both BGC and CROP are defined in define.h - --------------------------------------------------------------------------------------- - - URBAN (optional, if not present, the namelist must correspond to a no urban simulation): - The abbreviation of urban model switches. - Existing definition of the urban model switches include: - - --------------------------------------------------------------------------------------- - Abbreviation Description - --------------------------------------------------------------------------------------- - (not present) The urban model is turned off - URBAN URBAN is defined, and the urban model is on - --------------------------------------------------------------------------------------- - - LULCC (optional, if not present, the namelist must correspond to a no land use change simulation): - The abbreviation of land use change model switches. - Existing definition of the land use change model switches include: - - --------------------------------------------------------------------------------------- - Abbreviation Description - --------------------------------------------------------------------------------------- - (not present) The land use change model is turned off - LULCC LULCC is defined, and the land use change model is on - --------------------------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml deleted file mode 100644 index cdb1482240..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/CRA40_Grid_30km_IGBP_VG.nml +++ /dev/null @@ -1,71 +0,0 @@ -&nl_colm - -! Author: Zhongwang Wei -! Description : include soil state init from data. - - DEF_CASE_NAME = 'CRA40' - - - DEF_domain%edges = 20.0 - DEF_domain%edgen = 25.0 - DEF_domain%edgew = 109.0 - DEF_domain%edgee = 118.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1980 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 21600 - DEF_simulation_time%end_year = 2015 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 0 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/share/home/dq013/zhwei/colm/data/CoLMrawdata/' - DEF_dir_runtime = '/share/home/dq013/zhwei/colm/data/CoLMruntime/' - DEF_dir_output = '/share/home/dq013/zhwei/colm/cases/' - - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 0.5 - DEF_GRIDBASED_lat_res = 0.5 - - - ! soil state init - DEF_USE_SoilInit = .true. - DEF_file_SoilInit = '/share/home/dq013/zhwei/colm/data/soilstate/soilstate.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - DEF_USE_PLANTHYDRAULICS = .false. - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '/share/home/dq013/zhwei/colm/CoLM202X-CRA40/CoLM202X/run/forcing/CRA40.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .true. - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_CompressLevel = 1 - DEF_HIST_CompressLevel = 1 - - DEF_HIST_WriteBack = .true. - - DEF_hist_vars_out_default = .true. - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml deleted file mode 100644 index f96a47da06..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/China_Grid_50km_IGBP_VG.nml +++ /dev/null @@ -1,68 +0,0 @@ -&nl_colm - -! Author: Shupeng Zhang -! Description : include soil state init from data. - - DEF_CASE_NAME = 'China_Grid_10km_IGBP_VG' - - DEF_domain%edges = 0.0 - DEF_domain%edgen = 55.0 - DEF_domain%edgew = 70.0 - DEF_domain%edgee = 140.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2010 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2015 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 0 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 0.5 - DEF_GRIDBASED_lat_res = 0.5 - - ! soil state init - DEF_USE_SoilInit = .true. - DEF_file_SoilInit = '/tera05/zhangsp/data/soilstate/soilstate.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - DEF_USE_PLANTHYDRAULICS = .false. - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '/tera04/zhangsp/git/CoLM202X/run/forcing/ERA5LAND.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .true. - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_CompressLevel = 1 - DEF_HIST_CompressLevel = 1 - - DEF_HIST_WriteBack = .true. - - DEF_hist_vars_out_default = .true. - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml deleted file mode 100644 index 2a1595c3b7..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_2x2_PFT_VG_BGC.nml +++ /dev/null @@ -1,69 +0,0 @@ -&nl_colm - -!Author: Xingjie Lu - - DEF_CASE_NAME = 'GlobalBGCPFTnoCROPHist1851-2014-newPHS' - - DEF_domain%edges = -90.0 - DEF_domain%edgen = 90.0 - DEF_domain%edgew = -180.0 - DEF_domain%edgee = 180.0 - - DEF_nx_blocks = 18 - DEF_ny_blocks = 9 - DEF_PIO_groupsize = 12 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1849 - DEF_simulation_time%start_month = 12 - DEF_simulation_time%start_day = 31 - DEF_simulation_time%start_sec = 86400 - DEF_simulation_time%end_year = 2014 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 0 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CLMrawdata_updating//' - DEF_dir_runtime = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime//' - DEF_dir_output = '/share/home/dq010/CoLM/CoLM202X-CROP/cases/' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 2.5 - DEF_GRIDBASED_lat_res = 1.875 - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC -! DEF_USE_IRRIGATION = .true. - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP//run/forcing/GSWP3-boat.nml' - - ! ----- history ----- - DEF_hist_lon_res = 2.5 - DEF_hist_lat_res = 1.875 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_CompressLevel = 1 - DEF_HIST_CompressLevel = 1 - - DEF_hist_vars_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP/cases/GlobalBGCPFTnoCROPHist1851-2014-newPHS/history.nml' - DEF_hist_vars_out_default = .true. - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml deleted file mode 100644 index cfd4823a80..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/Global_Grid_50km_IGBP_CB_URBAN.nml +++ /dev/null @@ -1,126 +0,0 @@ -&nl_colm - -!Author: Wenzong Dong - - DEF_CASE_NAME = 'GlobalURBANIGBPHist2000-2016' - - DEF_domain%edges = -90.0 - DEF_domain%edgen = 90.0 - DEF_domain%edgew = -180.0 - DEF_domain%edgee = 180.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1995 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2016 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 1 - DEF_simulation_time%end_sec = 0 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 0 - DEF_simulation_time%spinup_repeat= 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/stu01/dongwz/data/CoLMrawdata/' - DEF_dir_runtime = '/stu01/dongwz/data/CoLMruntime/' - DEF_dir_output = '/stu01/dongwz/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 0.5 - DEF_GRIDBASED_lat_res = 0.5 - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - ! LandCover setting - DEF_LC_YEAR = 2005 - - ! ----Soil Surface Resistance options---- - ! 0: NONE soil surface resistance - ! 1: SL14, Swenson and Lawrence (2014) - ! 2: SZ09, Sakaguchi and Zeng (2009) - ! 3: TR13, Tang and Riley (2013) - ! 4: LP92, Lee and Pielke (1992) - ! 5: S92, Sellers et al (1992) - DEF_RSS_SCHEME = 1 - - !---- Urban options ---- - ! urban type options - ! Options : - ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density - ! 2: LCZ Classification, 10 urban type with LCZ 1-10 - DEF_URBAN_type_scheme = 1 - - ! urban module options - DEF_URBAN_ONLY = .false. - DEF_URBAN_TREE = .true. - DEF_URBAN_WATER= .true. - DEF_URBAN_BEM = .true. - DEF_URBAN_LUCY = .true. - ! ----------------------- - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ---- Hydrology module ---- - DEF_USE_SUPERCOOL_WATER = .false. - DEF_USE_VariablySaturatedFlow = .false. - DEF_USE_PLANTHYDRAULICS = .false. - ! -------------------------- - - ! ---- SNICAR ---- - DEF_USE_SNICAR = .false. - DEF_Aerosol_Readin = .true. - DEF_Aerosol_Clim = .false. - ! ---------------- - - ! ---- Ozone MODULE ---- - DEF_USE_OZONESTRESS = .false. - DEF_USE_OZONEDATA = .false. - ! ---------------------- - - ! ---- Bedrock ---- - DEF_USE_BEDROCK = .false. - ! ----------------- - - ! ---- Split Soil Snow ---- - DEF_SPLIT_SOILSNOW = .false. - ! ------------------------- - - ! ---- Forcing Downscalling ---- - DEF_USE_Forcing_Downscaling = .false. - DEF_DS_precipitation_adjust_scheme = 'II' - DEF_DS_longwave_adjust_scheme = 'II' - ! ------------------------------ - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '../forcing/CRUNCEPV7.nml' - - ! ----- history ----- - DEF_hist_lon_res = 0.5 - DEF_hist_lat_res = 0.5 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_CompressLevel = 1 - DEF_HIST_CompressLevel = 1 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_out_default = .true. - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml deleted file mode 100644 index bd6d2ff194..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/GreaterBay_Grid_10km_IGBP_VG.nml +++ /dev/null @@ -1,73 +0,0 @@ -&nl_colm - -! Author: Shupeng Zhang -! Description : include soil state init from data. - - DEF_CASE_NAME = 'GreaterBay_Grid_10km_IGBP_VG' - - DEF_domain%edges = 20.0 - DEF_domain%edgen = 25.0 - DEF_domain%edgew = 109.0 - DEF_domain%edgee = 118.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2010 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2010 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 0 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - DEF_dir_output = '/tera13/zhangsp/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 0.05 - DEF_GRIDBASED_lat_res = 0.05 - DEF_file_mesh_filter = '/tera13/zhangsp/landdata/filter/greaterbay_1km_filter.nc' - - ! soil state init - DEF_USE_SoilInit = .true. - DEF_file_SoilInit = '/tera13/zhangsp/landdata/soilstate/soilstate.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - DEF_USE_BEDROCK = .true. - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '/tera13/zhangsp/work/CoLM2024/run/forcing/ERA5LAND.nml' - - DEF_Forcing_Interp_Method = 'arealweight' ! 'arealweight' (default) or 'bilinear' - - ! ----- history ----- - DEF_HIST_lon_res = 0.05 - DEF_HIST_lat_res = 0.05 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_CompressLevel = 1 - DEF_HIST_CompressLevel = 1 - - DEF_HIST_WriteBack = .false. - - DEF_hist_vars_out_default = .false. - DEF_hist_vars_namelist = '/tera13/zhangsp/work/CoLM2024/run/history.nml' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml deleted file mode 100644 index 4c418a4f3d..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/PearlRiver_Catch_100km_IGBP_VG.nml +++ /dev/null @@ -1,53 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'PearlRiver_100km' - - DEF_domain%edges = 20.0 - DEF_domain%edgen = 30.0 - DEF_domain%edgew = 100.0 - DEF_domain%edgee = 115.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 0 - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/tera07/CLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - DEF_dir_output = '/tera05/zhangsp/cases/' - - DEF_CatchmentMesh_data = '/tera04/zhangsp/hillslope/output/pearl_100km2.nc' - DEF_ElementNeighbour_file = '/tera04/zhangsp/hillslope/output/pearl_100km2.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/git/CoLM202X/run/forcing/CRUJRA.nml' - - ! ----- history ----- - DEF_HISTORY_IN_VECTOR = .false. - DEF_hist_grid_as_forcing = .true. - - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_CompressLevel = 1 - DEF_HIST_CompressLevel = 1 - - DEF_hist_vars_out_default = .false. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM2024/run/history.nml' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml deleted file mode 100644 index 234118c956..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/PoyangLake_Grid_5km_IGBP_VG.nml +++ /dev/null @@ -1,65 +0,0 @@ -&nl_colm - -! Author: Shupeng Zhang -! Description : an example to use dynamic lake. - - DEF_CASE_NAME = 'PoyangLake_Grid_5km_IGBP_VG' - - DEF_domain%edges = 28.0 - DEF_domain%edgen = 30.0 - DEF_domain%edgew = 115.0 - DEF_domain%edgee = 117.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2010 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2020 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 0 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/shr03/CoLMrawdata/' - DEF_dir_runtime = '/shr03/CoLMruntime/' - DEF_dir_output = '/tera13/zhangsp/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 0.05 - DEF_GRIDBASED_lat_res = 0.05 - - ! soil state init - DEF_USE_SoilInit = .true. - DEF_file_SoilInit = '/shr03/CoLMruntime/soilstate.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - DEF_USE_Dynamic_Lake = .true. - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '/tera13/zhangsp/work/CoLM2024/run/forcing/CRUJRA.nml' - - ! ----- history ----- - DEF_HIST_lon_res = 0.05 - DEF_HIST_lat_res = 0.05 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - - DEF_hist_vars_out_default = .false. - DEF_HIST_vars_namelist = 'run/hist_dynamic_lake.nml' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml deleted file mode 100644 index c9fa04d00c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/RegChina_Grid_50km_IGBP_CB_LULCC.nml +++ /dev/null @@ -1,110 +0,0 @@ -&nl_colm - -!Author: Wanyi Lin - - DEF_CASE_NAME = 'RegChina_Grid_50km_IGBP_CB_LULCC.nml' - - DEF_domain%edges = 18.0 - DEF_domain%edgen = 54.0 - DEF_domain%edgew = 73.0 - DEF_domain%edgee = 135.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2002 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 0 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - DEF_dir_output = '/home/linwy20/stu01/colm202x-master/case' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = 'NONE' - DEF_GRIDBASED_lon_res = 0.5 - DEF_GRIDBASED_lat_res = 0.5 - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .true. - - ! LandCover setting - DEF_LC_YEAR = 2002 - - ! Land use change scheme selection - DEF_LULCC_SCHEME = 2 - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ---------- Hydrology module --------- - DEF_USE_SUPERCOOL_WATER = .false. - DEF_USE_VariablySaturatedFlow = .false. - DEF_USE_PLANTHYDRAULICS = .false. - ! ------------------------------------- - - ! --------- SNICAR --------- - DEF_USE_SNICAR = .false. - DEF_Aerosol_Readin = .true. - DEF_Aerosol_Clim = .false. - ! -------------------------- - - ! ------ Ozone MODULE ------ - DEF_USE_OZONESTRESS = .false. - DEF_USE_OZONEDATA = .false. - ! -------------------------- - - ! ------- Bedrock ------- - DEF_USE_BEDROCK = .false. - ! ----------------------- - - ! ---- Split Soil Snow ---- - DEF_SPLIT_SOILSNOW = .false. - ! ------------------------- - - ! ---------- Forcing Downscalling ---------- - DEF_USE_Forcing_Downscaling = .false. - DEF_DS_precipitation_adjust_scheme = 'II' - DEF_DS_longwave_adjust_scheme = 'II' - ! ------------------------------------------ - - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - ! CLDAS - DEF_forcing_namelist = './forcing/GSWP3.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - DEF_hist_lon_res = 0.5 - DEF_hist_lat_res = 0.5 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_out_default = .true. - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml deleted file mode 100644 index feaa1e83ec..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/SiteSYSUAtmos_IGBP_VG.nml +++ /dev/null @@ -1,64 +0,0 @@ -&nl_colm - -! Author: Shupeng Zhang -! Description : an example for SinglePoint with all surface data from database instead of observations. - - DEF_CASE_NAME = 'SiteSYSUAtmos_IGBP_VG' - - SITE_lon_location = 113.5897 - SITE_lat_location = 22.3507 - - USE_SITE_landtype = .false. - USE_SITE_htop = .false. - USE_SITE_LAI = .false. - USE_SITE_lakedepth = .false. - USE_SITE_soilreflectance = .false. - USE_SITE_soilparameters = .false. - USE_SITE_dbedrock = .false. - USE_SITE_topography = .false. - USE_SITE_topostd = .false. - USE_SITE_BVIC = .false. - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1951 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 1951 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 11 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 0 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/shr03/CoLMrawdata/' - DEF_dir_runtime = '/shr03/CoLMruntime/' - DEF_dir_output = '/tera09/training/CoLM202X-Tutorial/cases/' - - ! soil state init - DEF_USE_SoilInit = .true. - DEF_file_SoilInit = '/tera13/zhangsp/landdata/soilstate/soilstate.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT | JRA3Q - DEF_forcing_namelist = '/tera13/zhangsp/work/CoLM2024/run/forcing/ERA5LAND.nml' - - ! ----- history ----- - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - - DEF_hist_vars_out_default = .true. - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml b/src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml deleted file mode 100644 index 9ed55af006..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/examples/full_history_variables.nml +++ /dev/null @@ -1,353 +0,0 @@ -&nl_colm_history - - ! ----------- history ------------ - ! A full list of output variables. - - DEF_hist_vars%xy_us = .true. - DEF_hist_vars%xy_vs = .true. - DEF_hist_vars%xy_t = .true. - DEF_hist_vars%xy_q = .true. - DEF_hist_vars%xy_prc = .true. - DEF_hist_vars%xy_prl = .true. - DEF_hist_vars%xy_pbot = .true. - DEF_hist_vars%xy_frl = .true. - DEF_hist_vars%xy_solarin = .true. - DEF_hist_vars%xy_rain = .true. - DEF_hist_vars%xy_snow = .true. - DEF_hist_vars%xy_ozone = .true. - DEF_hist_vars%xy_hpbl = .true. - - DEF_hist_vars%taux = .true. - DEF_hist_vars%tauy = .true. - DEF_hist_vars%fsena = .true. - DEF_hist_vars%lfevpa = .true. - DEF_hist_vars%fevpa = .true. - DEF_hist_vars%fsenl = .true. - DEF_hist_vars%fevpl = .true. - DEF_hist_vars%etr = .true. - DEF_hist_vars%fseng = .true. - DEF_hist_vars%fevpg = .true. - DEF_hist_vars%fgrnd = .true. - DEF_hist_vars%sabvsun = .true. - DEF_hist_vars%sabvsha = .true. - DEF_hist_vars%sabg = .true. - DEF_hist_vars%olrg = .true. - DEF_hist_vars%rnet = .true. - DEF_hist_vars%xerr = .true. - DEF_hist_vars%zerr = .true. - DEF_hist_vars%rsur = .true. - DEF_hist_vars%rsur_se = .true. - DEF_hist_vars%rsur_ie = .true. - DEF_hist_vars%rsub = .true. - DEF_hist_vars%rnof = .true. - DEF_hist_vars%xwsur = .true. - DEF_hist_vars%xwsub = .true. - DEF_hist_vars%qintr = .true. - DEF_hist_vars%qinfl = .true. - DEF_hist_vars%qdrip = .true. - DEF_hist_vars%wat = .true. - DEF_hist_vars%wat_inst = .true. - DEF_hist_vars%wetwat = .true. - DEF_hist_vars%wetwat_inst = .true. - DEF_hist_vars%assim = .true. - DEF_hist_vars%respc = .true. - DEF_hist_vars%qcharge = .true. - DEF_hist_vars%t_grnd = .true. - DEF_hist_vars%tleaf = .true. - DEF_hist_vars%ldew = .true. - DEF_hist_vars%scv = .true. - DEF_hist_vars%snowdp = .true. - DEF_hist_vars%fsno = .true. - DEF_hist_vars%sigf = .true. - DEF_hist_vars%green = .true. - DEF_hist_vars%lai = .true. - DEF_hist_vars%laisun = .true. - DEF_hist_vars%laisha = .true. - DEF_hist_vars%sai = .true. - DEF_hist_vars%alb = .true. - DEF_hist_vars%emis = .true. - DEF_hist_vars%z0m = .true. - DEF_hist_vars%trad = .true. - DEF_hist_vars%rss = .true. - DEF_hist_vars%tref = .true. - DEF_hist_vars%qref = .true. - - DEF_hist_vars%fsen_roof = .true. - DEF_hist_vars%fsen_wsun = .true. - DEF_hist_vars%fsen_wsha = .true. - DEF_hist_vars%fsen_gimp = .true. - DEF_hist_vars%fsen_gper = .true. - DEF_hist_vars%fsen_urbl = .true. - DEF_hist_vars%lfevp_roof = .true. - DEF_hist_vars%lfevp_gimp = .true. - DEF_hist_vars%lfevp_gper = .true. - DEF_hist_vars%lfevp_urbl = .true. - DEF_hist_vars%fhac = .true. - DEF_hist_vars%fwst = .true. - DEF_hist_vars%fach = .true. - DEF_hist_vars%fhah = .true. - DEF_hist_vars%meta = .true. - DEF_hist_vars%vehc = .true. - DEF_hist_vars%t_room = .true. - DEF_hist_vars%tafu = .true. - DEF_hist_vars%t_roof = .true. - DEF_hist_vars%t_wall = .true. - - DEF_hist_vars%assimsun = .true. - DEF_hist_vars%assimsha = .true. - DEF_hist_vars%etrsun = .true. - DEF_hist_vars%etrsha = .true. - - DEF_hist_vars%leafc = .true. - DEF_hist_vars%leafc_storage = .true. - DEF_hist_vars%leafc_xfer = .true. - DEF_hist_vars%frootc = .true. - DEF_hist_vars%frootc_storage = .true. - DEF_hist_vars%frootc_xfer = .true. - DEF_hist_vars%livestemc = .true. - DEF_hist_vars%livestemc_storage = .true. - DEF_hist_vars%livestemc_xfer = .true. - DEF_hist_vars%deadstemc = .true. - DEF_hist_vars%deadstemc_storage = .true. - DEF_hist_vars%deadstemc_xfer = .true. - DEF_hist_vars%livecrootc = .true. - DEF_hist_vars%livecrootc_storage = .true. - DEF_hist_vars%livecrootc_xfer = .true. - DEF_hist_vars%deadcrootc = .true. - DEF_hist_vars%deadcrootc_storage = .true. - DEF_hist_vars%deadcrootc_xfer = .true. - DEF_hist_vars%grainc = .true. - DEF_hist_vars%grainc_storage = .true. - DEF_hist_vars%grainc_xfer = .true. - DEF_hist_vars%leafn = .true. - DEF_hist_vars%leafn_storage = .true. - DEF_hist_vars%leafn_xfer = .true. - DEF_hist_vars%frootn = .true. - DEF_hist_vars%frootn_storage = .true. - DEF_hist_vars%frootn_xfer = .true. - DEF_hist_vars%livestemn = .true. - DEF_hist_vars%livestemn_storage = .true. - DEF_hist_vars%livestemn_xfer = .true. - DEF_hist_vars%deadstemn = .true. - DEF_hist_vars%deadstemn_storage = .true. - DEF_hist_vars%deadstemn_xfer = .true. - DEF_hist_vars%livecrootn = .true. - DEF_hist_vars%livecrootn_storage = .true. - DEF_hist_vars%livecrootn_xfer = .true. - DEF_hist_vars%deadcrootn = .true. - DEF_hist_vars%deadcrootn_storage = .true. - DEF_hist_vars%deadcrootn_xfer = .true. - DEF_hist_vars%grainn = .true. - DEF_hist_vars%grainn_storage = .true. - DEF_hist_vars%grainn_xfer = .true. - DEF_hist_vars%retrasn = .true. - DEF_hist_vars%gpp = .true. - DEF_hist_vars%downreg = .true. - DEF_hist_vars%ar = .true. - DEF_hist_vars%cwdprod = .true. - DEF_hist_vars%cwddecomp = .true. - DEF_hist_vars%hr = .true. - DEF_hist_vars%fpg = .true. - DEF_hist_vars%fpi = .true. - DEF_hist_vars%gpp_enftemp = .false. !1 - DEF_hist_vars%gpp_enfboreal = .false. !2 - DEF_hist_vars%gpp_dnfboreal = .false. !3 - DEF_hist_vars%gpp_ebftrop = .false. !4 - DEF_hist_vars%gpp_ebftemp = .false. !5 - DEF_hist_vars%gpp_dbftrop = .false. !6 - DEF_hist_vars%gpp_dbftemp = .false. !7 - DEF_hist_vars%gpp_dbfboreal = .false. !8 - DEF_hist_vars%gpp_ebstemp = .false. !9 - DEF_hist_vars%gpp_dbstemp = .false. !10 - DEF_hist_vars%gpp_dbsboreal = .false. !11 - DEF_hist_vars%gpp_c3arcgrass = .false. !12 - DEF_hist_vars%gpp_c3grass = .false. !13 - DEF_hist_vars%gpp_c4grass = .false. !14 - DEF_hist_vars%leafc_enftemp = .false. !1 - DEF_hist_vars%leafc_enfboreal = .false. !2 - DEF_hist_vars%leafc_dnfboreal = .false. !3 - DEF_hist_vars%leafc_ebftrop = .false. !4 - DEF_hist_vars%leafc_ebftemp = .false. !5 - DEF_hist_vars%leafc_dbftrop = .false. !6 - DEF_hist_vars%leafc_dbftemp = .false. !7 - DEF_hist_vars%leafc_dbfboreal = .false. !8 - DEF_hist_vars%leafc_ebstemp = .false. !9 - DEF_hist_vars%leafc_dbstemp = .false. !10 - DEF_hist_vars%leafc_dbsboreal = .false. !11 - DEF_hist_vars%leafc_c3arcgrass = .false. !12 - DEF_hist_vars%leafc_c3grass = .false. !13 - DEF_hist_vars%leafc_c4grass = .false. !14 - - DEF_hist_vars%cphase = .true. - DEF_hist_vars%gddmaturity = .true. - DEF_hist_vars%gddplant = .true. - DEF_hist_vars%vf = .true. - DEF_hist_vars%hui = .true. - DEF_hist_vars%cropprod1c = .true. - DEF_hist_vars%cropprod1c_loss = .true. - DEF_hist_vars%cropseedc_deficit = .true. - DEF_hist_vars%grainc_to_cropprodc = .true. - DEF_hist_vars%plantdate_rainfed_temp_corn = .true. - DEF_hist_vars%plantdate_irrigated_temp_corn = .true. - DEF_hist_vars%plantdate_rainfed_spwheat = .true. - DEF_hist_vars%plantdate_irrigated_spwheat = .true. - DEF_hist_vars%plantdate_rainfed_wtwheat = .true. - DEF_hist_vars%plantdate_irrigated_wtwheat = .true. - DEF_hist_vars%plantdate_rainfed_temp_soybean = .true. - DEF_hist_vars%plantdate_irrigated_temp_soybean = .true. - DEF_hist_vars%plantdate_rainfed_cotton = .true. - DEF_hist_vars%plantdate_irrigated_cotton = .true. - DEF_hist_vars%plantdate_rainfed_rice = .true. - DEF_hist_vars%plantdate_irrigated_rice = .true. - DEF_hist_vars%plantdate_rainfed_sugarcane = .true. - DEF_hist_vars%plantdate_irrigated_sugarcane = .true. - DEF_hist_vars%plantdate_rainfed_trop_corn = .true. - DEF_hist_vars%plantdate_irrigated_trop_corn = .true. - DEF_hist_vars%plantdate_rainfed_trop_soybean = .true. - DEF_hist_vars%plantdate_irrigated_trop_soybean = .true. - DEF_hist_vars%plantdate_unmanagedcrop = .true. - DEF_hist_vars%cropprodc_rainfed_temp_corn = .true. - DEF_hist_vars%cropprodc_irrigated_temp_corn = .true. - DEF_hist_vars%cropprodc_rainfed_spwheat = .true. - DEF_hist_vars%cropprodc_irrigated_spwheat = .true. - DEF_hist_vars%cropprodc_rainfed_wtwheat = .true. - DEF_hist_vars%cropprodc_irrigated_wtwheat = .true. - DEF_hist_vars%cropprodc_rainfed_temp_soybean = .true. - DEF_hist_vars%cropprodc_irrigated_temp_soybean = .true. - DEF_hist_vars%cropprodc_rainfed_cotton = .true. - DEF_hist_vars%cropprodc_irrigated_cotton = .true. - DEF_hist_vars%cropprodc_rainfed_rice = .true. - DEF_hist_vars%cropprodc_irrigated_rice = .true. - DEF_hist_vars%cropprodc_rainfed_sugarcane = .true. - DEF_hist_vars%cropprodc_irrigated_sugarcane = .true. - DEF_hist_vars%cropprodc_rainfed_trop_corn = .true. - DEF_hist_vars%cropprodc_irrigated_trop_corn = .true. - DEF_hist_vars%cropprodc_rainfed_trop_soybean = .true. - DEF_hist_vars%cropprodc_irrigated_trop_soybean = .true. - DEF_hist_vars%cropprodc_unmanagedcrop = .true. - - DEF_hist_vars%grainc_to_seed = .true. - DEF_hist_vars%fert_to_sminn = .true. - - DEF_hist_vars%huiswheat = .true. - DEF_hist_vars%pdcorn = .true. - DEF_hist_vars%pdswheat = .true. - DEF_hist_vars%pdwwheat = .true. - DEF_hist_vars%pdsoybean = .true. - DEF_hist_vars%pdcotton = .true. - DEF_hist_vars%pdrice1 = .true. - DEF_hist_vars%pdrice2 = .true. - DEF_hist_vars%pdsugarcane = .true. - DEF_hist_vars%manunitro = .true. - DEF_hist_vars%fertnitro_corn = .true. - DEF_hist_vars%fertnitro_swheat = .true. - DEF_hist_vars%fertnitro_wwheat = .true. - DEF_hist_vars%fertnitro_soybean = .true. - DEF_hist_vars%fertnitro_cotton = .true. - DEF_hist_vars%fertnitro_rice1 = .true. - DEF_hist_vars%fertnitro_rice2 = .true. - DEF_hist_vars%fertnitro_sugarcane = .true. - DEF_hist_vars%irrig_method_corn = .true. - DEF_hist_vars%irrig_method_swheat = .true. - DEF_hist_vars%irrig_method_wwheat = .true. - DEF_hist_vars%irrig_method_soybean = .true. - DEF_hist_vars%irrig_method_cotton = .true. - DEF_hist_vars%irrig_method_rice1 = .true. - DEF_hist_vars%irrig_method_rice2 = .true. - DEF_hist_vars%irrig_method_sugarcane = .true. - - DEF_hist_vars%irrig_rate = .true. - DEF_hist_vars%deficit_irrig = .true. - DEF_hist_vars%sum_irrig = .true. - DEF_hist_vars%sum_irrig_count = .true. - - DEF_hist_vars%ndep_to_sminn = .true. - DEF_hist_vars%CONC_O2_UNSAT = .true. - DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT = .true. - DEF_hist_vars%abm = .true. - DEF_hist_vars%gdp = .true. - DEF_hist_vars%peatf = .true. - DEF_hist_vars%hdm = .true. - DEF_hist_vars%lnfm = .true. - - DEF_hist_vars%t_soisno = .true. - DEF_hist_vars%wliq_soisno = .true. - DEF_hist_vars%wice_soisno = .true. - - DEF_hist_vars%h2osoi = .true. - DEF_hist_vars%rstfacsun = .true. - DEF_hist_vars%rstfacsha = .true. - DEF_hist_vars%gssun = .true. - DEF_hist_vars%gssha = .true. - DEF_hist_vars%rootr = .true. - DEF_hist_vars%vegwp = .true. - DEF_hist_vars%BD_all = .true. - DEF_hist_vars%wfc = .true. - DEF_hist_vars%OM_density = .true. - DEF_hist_vars%wdsrf = .true. - DEF_hist_vars%wdsrf_inst = .true. - DEF_hist_vars%zwt = .true. - DEF_hist_vars%wa = .true. - DEF_hist_vars%wa_inst = .true. - - DEF_hist_vars%dz_lake = .true. - DEF_hist_vars%t_lake = .true. - DEF_hist_vars%lake_icefrac = .true. - - DEF_hist_vars%litr1c_vr = .true. - DEF_hist_vars%litr2c_vr = .true. - DEF_hist_vars%litr3c_vr = .true. - DEF_hist_vars%soil1c_vr = .true. - DEF_hist_vars%soil2c_vr = .true. - DEF_hist_vars%soil3c_vr = .true. - DEF_hist_vars%cwdc_vr = .true. - DEF_hist_vars%litr1n_vr = .true. - DEF_hist_vars%litr2n_vr = .true. - DEF_hist_vars%litr3n_vr = .true. - DEF_hist_vars%soil1n_vr = .true. - DEF_hist_vars%soil2n_vr = .true. - DEF_hist_vars%soil3n_vr = .true. - DEF_hist_vars%cwdn_vr = .true. - DEF_hist_vars%sminn_vr = .true. - - DEF_hist_vars%ustar = .true. - DEF_hist_vars%ustar2 = .true. - DEF_hist_vars%tstar = .true. - DEF_hist_vars%qstar = .true. - DEF_hist_vars%zol = .true. - DEF_hist_vars%rib = .true. - DEF_hist_vars%fm = .true. - DEF_hist_vars%fh = .true. - DEF_hist_vars%fq = .true. - DEF_hist_vars%us10m = .true. - DEF_hist_vars%vs10m = .true. - DEF_hist_vars%fm10m = .true. - DEF_hist_vars%sr = .true. - DEF_hist_vars%solvd = .true. - DEF_hist_vars%solvi = .true. - DEF_hist_vars%solnd = .true. - DEF_hist_vars%solni = .true. - DEF_hist_vars%srvd = .true. - DEF_hist_vars%srvi = .true. - DEF_hist_vars%srnd = .true. - DEF_hist_vars%srni = .true. - - DEF_hist_vars%solvdln = .true. - DEF_hist_vars%solviln = .true. - DEF_hist_vars%solndln = .true. - DEF_hist_vars%solniln = .true. - DEF_hist_vars%srvdln = .true. - DEF_hist_vars%srviln = .true. - DEF_hist_vars%srndln = .true. - DEF_hist_vars%srniln = .true. - - DEF_hist_vars%xsubs_bsn = .true. - DEF_hist_vars%xsubs_hru = .true. - DEF_hist_vars%riv_height = .true. - DEF_hist_vars%riv_veloct = .true. - DEF_hist_vars%discharge = .true. - DEF_hist_vars%wdsrf_hru = .true. - DEF_hist_vars%veloc_hru = .true. - - DEF_hist_vars%sensors = .true. -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml deleted file mode 100644 index 2646cee645..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CLDAS.nml +++ /dev/null @@ -1,50 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/CLDAS/' - - DEF_forcing%dataset = 'CLDAS' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%regional = .true. - DEF_forcing%regbnd = 0.0 65.0 60.0 160.0 - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = 'missing_value' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 2008 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2020 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 0 0 0 0 0 0 0 0 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'LAT' ! dimension name of latitude - DEF_forcing%lonname = 'LON' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'TMP/CLDAS_NRT_ASI_0P0625_HOR-TMP-' - DEF_forcing%fprefix(2) = 'SHU/CLDAS_NRT_ASI_0P0625_HOR-SHU-' - DEF_forcing%fprefix(3) = 'PRS/CLDAS_NRT_ASI_0P0625_HOR-PRS-' - DEF_forcing%fprefix(4) = 'PRE/CLDAS_NRT_ASI_0P0625_HOR-PRE-' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'WIN/CLDAS_NRT_ASI_0P0625_HOR-WIN-' - DEF_forcing%fprefix(7) = 'SSRA/CLDAS_NRT_ASI_0P0625_HOR-SSRA-' - DEF_forcing%fprefix(8) = 'tstr/CLDAS_NRT_ASI_0P0625_HOR-tstr-' - - - DEF_forcing%vname = 'TAIR' 'QAIR' 'PAIR' 'PRCP' 'NULL' 'WIND' 'SWDN' 'tstr' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml deleted file mode 100644 index 8963774c67..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFD.nml +++ /dev/null @@ -1,51 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/CMFD/' - - DEF_forcing%dataset = 'CMFD' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40.0 - DEF_forcing%HEIGHT_Q = 40.0 - - DEF_forcing%regional = .true. - DEF_forcing%regbnd = 15.0 55.0 70.0 140.0 - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = 'missing_value' - - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2018 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 - DEF_forcing%offset = 5400 5400 5400 5400 0 5400 0 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'temp/temp_CMFD_V0106_B-01_03hr_010deg_' - DEF_forcing%fprefix(2) = 'shum/shum_CMFD_V0106_B-01_03hr_010deg_' - DEF_forcing%fprefix(3) = 'pres/pres_CMFD_V0106_B-01_03hr_010deg_' - DEF_forcing%fprefix(4) = 'prec/prec_CMFD_V0106_B-01_03hr_010deg_' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'wind/wind_CMFD_V0106_B-01_03hr_010deg_' - DEF_forcing%fprefix(7) = 'srad/srad_CMFD_V0106_B-01_03hr_010deg_' - DEF_forcing%fprefix(8) = 'lrad/lrad_CMFD_V0106_B-01_03hr_010deg_' - - - DEF_forcing%vname = 'temp' 'shum' 'pres' 'prec' 'NULL' 'wind' 'srad' 'lrad' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml deleted file mode 100644 index 7d2a9c8bf0..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CMFDv2.nml +++ /dev/null @@ -1,51 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/share/home/dq013/zhwei/colm/data/CoLM_Forcing/CMFDv2/Data_forcing_03hr_010deg' - - DEF_forcing%dataset = 'CMFDv2' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40.0 - DEF_forcing%HEIGHT_Q = 40.0 - - DEF_forcing%regional = .true. - DEF_forcing%regbnd = 15.0 55.0 70.0 140.0 - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = 'missing_value' - - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1951 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2020 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 - DEF_forcing%offset = 0 0 0 0 0 0 5400 0 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'Temp/temp_CMFD_V0200_B-01_03hr_010deg_' - DEF_forcing%fprefix(2) = 'SHum/shum_CMFD_V0200_B-01_03hr_010deg_' - DEF_forcing%fprefix(3) = 'Pres/pres_CMFD_V0200_B-01_03hr_010deg_' - DEF_forcing%fprefix(4) = 'Prec/prec_CMFD_V0200_B-01_03hr_010deg_' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'Wind/wind_CMFD_V0200_B-01_03hr_010deg_' - DEF_forcing%fprefix(7) = 'SRad/srad_CMFD_V0200_B-01_03hr_010deg_' - DEF_forcing%fprefix(8) = 'LRad/lrad_CMFD_V0200_B-01_03hr_010deg_' - - - DEF_forcing%vname = 'temp' 'shum' 'pres' 'prec' 'NULL' 'wind' 'srad' 'lrad' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'backward' 'instant' 'instant' 'backward' 'instant' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'uniform' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml deleted file mode 100644 index 7d058b33ad..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRA40.nml +++ /dev/null @@ -1,50 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/CRA40/' - - DEF_forcing%dataset = 'CRA40' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - !DEF_forcing%has_missing_value = .true. - !DEF_forcing%missing_value_name = 'missing_value' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1950 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2021 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 21600 21600 21600 21600 21600 21600 21600 21600 - DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'g0_lat_0' ! dimension name of latitude - DEF_forcing%lonname = 'g0_lon_1' ! dimension name of longitude - - DEF_forcing%groupby = 'year' ! file grouped by year/month - - - - DEF_forcing%fprefix(1) = 'CRA40_sp_t_u_v' - DEF_forcing%fprefix(2) = 'CRA40_sp_t_u_v' - DEF_forcing%fprefix(3) = 'CRA40_pres_remap' - DEF_forcing%fprefix(4) = 'CRA40_Radiation_precip_remap' - DEF_forcing%fprefix(5) = 'CRA40_sp_t_u_v' - DEF_forcing%fprefix(6) = 'CRA40_sp_t_u_v' - DEF_forcing%fprefix(7) = 'CRA40_Radiation_precip_remap' - DEF_forcing%fprefix(8) = 'CRA40_Radiation_precip_remap' - - - DEF_forcing%vname = 'TMP_GDS0_HTGL' 'SPF_H_GDS0_HTGL' 'PRES_P0_L1_GLL0' 'PRATE_P8_L1_GLL0_avg' 'U_GRD_GDS0_HTGL' 'V_GRD_GDS0_HTGL' 'DSWRF_P8_L1_GLL0_avg' 'DLWRF_P8_L1_GLL0_avg' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml deleted file mode 100644 index 90ed744a6c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUJRA.nml +++ /dev/null @@ -1,48 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/crujra_v2.5/' - - DEF_forcing%dataset = 'CRUJRA' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = 'missing_value' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1901 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2022 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 21600 21600 21600 21600 21600 21600 21600 21600 - DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .false. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'year' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'tmp/crujra.v2.5.5d.tmp.' - DEF_forcing%fprefix(2) = 'spfh/crujra.v2.5.5d.spfh.' - DEF_forcing%fprefix(3) = 'pres/crujra.v2.5.5d.pres.' - DEF_forcing%fprefix(4) = 'pre/crujra.v2.5.5d.pre.' - DEF_forcing%fprefix(5) = 'ugrd/crujra.v2.5.5d.ugrd.' - DEF_forcing%fprefix(6) = 'vgrd/crujra.v2.5.5d.vgrd.' - DEF_forcing%fprefix(7) = 'dswrf/crujra.v2.5.5d.dswrf.' - DEF_forcing%fprefix(8) = 'dlwrf/crujra.v2.5.5d.dlwrf.' - - - DEF_forcing%vname = 'tmp' 'spfh' 'pres' 'pre' 'ugrd' 'vgrd' 'dswrf' 'dlwrf' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml deleted file mode 100644 index 7cddcd5a4b..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV4.nml +++ /dev/null @@ -1,45 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/cruncep_v4/cruncep/' - - DEF_forcing%dataset = 'CRUNCEPV4' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1950 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2016 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 21600 21600 21600 21600 0 21600 21600 21600 - DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .false. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'LATIXY' ! dimension name of latitude - DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' - DEF_forcing%fprefix(2) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' - DEF_forcing%fprefix(3) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' - DEF_forcing%fprefix(4) = 'Precip6Hrly/clmforc.cruncep.V4.c2011.0.5d.Prec.' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' - DEF_forcing%fprefix(7) = 'Solar6Hrly/clmforc.cruncep.V4.c2011.0.5d.Solr.' - DEF_forcing%fprefix(8) = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' - - - DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml deleted file mode 100644 index c669c1f489..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/CRUNCEPV7.nml +++ /dev/null @@ -1,45 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing ='/shr03/CoLM_Forcing/cruncep_v7/' - - DEF_forcing%dataset = 'CRUNCEPV7' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1950 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2016 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 21600 21600 21600 21600 0 21600 21600 21600 - DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .false. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'LATIXY' ! dimension name of latitude - DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' - DEF_forcing%fprefix(2) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' - DEF_forcing%fprefix(3) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' - DEF_forcing%fprefix(4) = 'Precip6Hrly/clmforc.cruncep.V7.c2016.0.5d.Prec.' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' - DEF_forcing%fprefix(7) = 'Solar6Hrly/clmforc.cruncep.V7.c2016.0.5d.Solr.' - DEF_forcing%fprefix(8) = 'TPHWL6Hrly/clmforc.cruncep.V7.c2016.0.5d.TPQWL.' - - - DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml deleted file mode 100644 index 15ae5fac2d..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5.nml +++ /dev/null @@ -1,53 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5/' - - DEF_forcing%dataset = 'ERA5' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_mode = 'absolute' ! 'absolute' height to ground surface or - ! 'relative' height to tree/building top - ! if not speficied, default is absolute - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40.0 - DEF_forcing%HEIGHT_Q = 40.0 - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2024 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 1800 1800 1800 1800 1800 1800 0 1800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'latitude' ! dimension name of latitude - DEF_forcing%lonname = 'longitude' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = '2m_temperature/ERA5' - DEF_forcing%fprefix(2) = 'Specific_Humdity/ERA5' - DEF_forcing%fprefix(3) = 'surface_pressure/ERA5' - DEF_forcing%fprefix(4) = 'mean_total_precipitation_rate/ERA5' - DEF_forcing%fprefix(5) = '10m_u_component_of_wind/ERA5' - DEF_forcing%fprefix(6) = '10m_v_component_of_wind/ERA5' - DEF_forcing%fprefix(7) = 'mean_surface_downward_short_wave_radiation_flux/ERA5' - DEF_forcing%fprefix(8) = 'mean_surface_downward_long_wave_radiation_flux/ERA5' - - - DEF_forcing%vname = 't2m' 'q' 'sp' 'mtpr' 'u10' 'v10' 'msdwswrf' 'msdwlwrf' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'backward' 'instant' 'instant' 'backward' 'backward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - - DEF_forcing%CBL_fprefix = 'boundary_layer_height/ERA5' - DEF_forcing%CBL_vname = 'blh' - DEF_forcing%CBL_tintalgo = 'linear' - DEF_forcing%CBL_dtime = 3600 - DEF_forcing%CBL_offset = 3600 -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml deleted file mode 100644 index d4d8221da2..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5LAND.nml +++ /dev/null @@ -1,50 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5LAND/' - - DEF_forcing%dataset = 'ERA5LAND' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_mode = 'relative' ! 'absolute' height to ground surface or - ! 'relative' height to tree/building top - ! if not speficied, default is absolute - DEF_forcing%HEIGHT_V = 10.0 - DEF_forcing%HEIGHT_T = 10.0 - DEF_forcing%HEIGHT_Q = 10.0 - - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = 'missing_value' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1950 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2024 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 1800 1800 1800 1800 1800 1800 0 1800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'latitude' ! dimension name of latitude - DEF_forcing%lonname = 'longitude' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = '2m_temperature/ERA5LAND' - DEF_forcing%fprefix(2) = 'specific_humidity/ERA5LAND' - DEF_forcing%fprefix(3) = 'surface_pressure/ERA5LAND' - DEF_forcing%fprefix(4) = 'Precipitation_m_hr/ERA5LAND' - DEF_forcing%fprefix(5) = '10m_u_component_of_wind/ERA5LAND' - DEF_forcing%fprefix(6) = '10m_v_component_of_wind/ERA5LAND' - DEF_forcing%fprefix(7) = 'surface_solar_radiation_downwards_w_m2/ERA5LAND' - DEF_forcing%fprefix(8) = 'surface_thermal_radiation_downwards_w_m2/ERA5LAND' - - DEF_forcing%vname = 't2m' 'Q' 'sp' 'tp' 'u10' 'v10' 'ssrd' 'strd' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml deleted file mode 100644 index 78007a1020..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/ERA5_LEddy.nml +++ /dev/null @@ -1,50 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/ERA5/' - - DEF_forcing%dataset = 'ERA5' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40.0 - DEF_forcing%HEIGHT_Q = 40.0 - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2021 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 1800 1800 1800 1800 1800 1800 0 1800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'latitude' ! dimension name of latitude - DEF_forcing%lonname = 'longitude' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = '2m_temperature/ERA5' - DEF_forcing%fprefix(2) = 'Specific_Humdity/ERA5' - DEF_forcing%fprefix(3) = 'surface_pressure/ERA5' - DEF_forcing%fprefix(4) = 'mean_total_precipitation_rate/ERA5' - DEF_forcing%fprefix(5) = '10m_u_component_of_wind/ERA5' - DEF_forcing%fprefix(6) = '10m_v_component_of_wind/ERA5' - DEF_forcing%fprefix(7) = 'mean_surface_downward_short_wave_radiation_flux/ERA5' - DEF_forcing%fprefix(8) = 'mean_surface_downward_long_wave_radiation_flux/ERA5' - - - DEF_forcing%vname = 't2m' 'q' 'sp' 'mtpr' 'u10' 'v10' 'msdwswrf' 'msdwlwrf' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - - DEF_forcing%CBL_fprefix = 'boundary_layer_height/ERA5' - DEF_forcing%CBL_vname = 'blh' - DEF_forcing%CBL_tintalgo = 'linear' - DEF_forcing%CBL_dtime = 3600 - DEF_forcing%CBL_offset = 3600 -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml deleted file mode 100644 index 6c40df842f..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/GDAS.nml +++ /dev/null @@ -1,51 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/GDAS_GPCP/' - - DEF_forcing%dataset = 'GDAS' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%regional = .true. - DEF_forcing%regbnd = -60.0 90.0 -180.0 180.0 - - DEF_forcing%has_missing_value = .true. - missing_value_name = 'missing_value' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 2002 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2021 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 - DEF_forcing%offset = 5400 5400 5400 5400 0 5400 0 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'GLDAS_GDAS_3H_Tair.' - DEF_forcing%fprefix(2) = 'GLDAS_GDAS_3H_Qair.' - DEF_forcing%fprefix(3) = 'GLDAS_GDAS_3H_Psurf.' - DEF_forcing%fprefix(4) = 'GLDAS_GDAS_3H_tot_prcip.' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'GLDAS_GDAS_3H_Wind.' - DEF_forcing%fprefix(7) = 'GLDAS_GDAS_3H_SWdown.' - DEF_forcing%fprefix(8) = 'GLDAS_GDAS_3H_LWdown.' - - - DEF_forcing%vname = 'Tair_f_inst' 'Qair_f_inst' 'Psurf_f_inst' 'Rainf_f_tavg' 'NULL' 'Wind_f_inst' 'SWdown_f_tavg' 'LWdown_f_tavg' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml deleted file mode 100644 index b53345f62f..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/GSWP3.nml +++ /dev/null @@ -1,44 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/GSWP3/' - - DEF_forcing%dataset = 'GSWP3' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1950 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2014 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 - DEF_forcing%offset = 5400 5400 5400 5400 0 5400 0 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .false. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'LATIXY' ! dimension name of latitude - DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(2) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(3) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(4) = 'Precip/clmforc.GSWP3.c2011.0.5x0.5.Prec.' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(7) = 'Solar/clmforc.GSWP3.c2011.0.5x0.5.Solr.' - DEF_forcing%fprefix(8) = 'TPHWL/clmforc.GSWP3.c2011.0.5x0.5.TPQWL.' - - DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml deleted file mode 100644 index b9e914030c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/IsoGSM.nml +++ /dev/null @@ -1,68 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/IsoGSM/' - - DEF_forcing%dataset = 'IsoGSM' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1980 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2024 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 21600 21600 21600 21600 21600 21600 21600 21600 - DEF_forcing%offset = 10800 10800 10800 10800 10800 10800 0 10800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'year' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'IsoGSM_temperature' - DEF_forcing%fprefix(2) = 'IsoGSM_Q' - DEF_forcing%fprefix(3) = 'IsoGSM_Pressure' - DEF_forcing%fprefix(4) = 'IsoGSM_prate' - DEF_forcing%fprefix(5) = 'IsoGSM_Wind' - DEF_forcing%fprefix(6) = 'IsoGSM_Wind' - DEF_forcing%fprefix(7) = 'IsoGSM_Radiation' - DEF_forcing%fprefix(8) = 'IsoGSM_Radiation' - - - DEF_forcing%vname = 'tmp2m' 'spfh2m' 'pressfc' 'pratesfc' 'ugrd10m' 'vgrd10m' 'dswrfsfc' 'dlwrfsfc' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - - DEF_forcing%precipitation_O18_fprefix = 'IsoGSM_prate' - DEF_forcing%precipitation_O18_vname = 'prate1sfc' - DEF_forcing%precipitation_O18_tintalgo = 'linear' - DEF_forcing%precipitation_O18_dtime = 21600 - DEF_forcing%precipitation_O18_offset = 10800 - - DEF_forcing%precipitation_H2_fprefix = 'IsoGSM_prate' - DEF_forcing%precipitation_H2_vname = 'prate2sfc' - DEF_forcing%precipitation_H2_tintalgo = 'linear' - DEF_forcing%precipitation_H2_dtime = 21600 - DEF_forcing%precipitation_H2_offset = 10800 - - DEF_forcing%water_vapor_O18_fprefix = 'IsoGSM_Q' - DEF_forcing%water_vapor_O18_vname = 'spfh12m' - DEF_forcing%water_vapor_O18_tintalgo = 'linear' - DEF_forcing%water_vapor_O18_dtime = 21600 - DEF_forcing%water_vapor_O18_offset = 10800 - - DEF_forcing%water_vapor_H2_fprefix = 'IsoGSM_Q' - DEF_forcing%water_vapor_H2_vname = 'spfh22m' - DEF_forcing%water_vapor_H2_tintalgo = 'linear' - DEF_forcing%water_vapor_H2_dtime = 21600 - DEF_forcing%water_vapor_H2_offset = 10800 -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml deleted file mode 100644 index e698a04a05..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA3Q.nml +++ /dev/null @@ -1,47 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/JRA3Q/' - - DEF_forcing%dataset = 'JRA3Q' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 2003 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2024 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 0 0 0 1800 0 0 0 1800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'tmp2m/tmp2m' - DEF_forcing%fprefix(2) = 'spfh2m/spfh2m' - DEF_forcing%fprefix(3) = 'pres/pres' - DEF_forcing%fprefix(4) = 'tprate/tprate' - DEF_forcing%fprefix(5) = 'u/u' - DEF_forcing%fprefix(6) = 'v/v' - DEF_forcing%fprefix(7) = 'dswrf/dswrf' - DEF_forcing%fprefix(8) = 'dlwrf/dlwrf' - - - - DEF_forcing%vname = 'tmp2m-hgt-fc-gauss' 'spfh2m-hgt-fc-gauss' 'pres-sfc-fc-gauss' 'tprate1have-sfc-fc-gauss' 'ugrd10m-hgt-fc-gauss' 'vgrd10m-hgt-fc-gauss' 'dswrf1have-sfc-fc-gauss' 'dlwrf1have-sfc-fc-gauss' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'linear' 'linear' 'linear' 'coszen' 'linear' - - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml deleted file mode 100644 index 884142b554..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/JRA55.nml +++ /dev/null @@ -1,46 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/JRA55-Final' - - DEF_forcing%dataset = 'JRA55' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1958 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2023 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 - DEF_forcing%offset = 0 0 0 5400 0 0 5400 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'tmp/tmp_' - DEF_forcing%fprefix(2) = 'spfh/spfh_' - DEF_forcing%fprefix(3) = 'pres/pres_' - DEF_forcing%fprefix(4) = 'tprat/tprat_' - DEF_forcing%fprefix(5) = 'ugrd/ugrd_' - DEF_forcing%fprefix(6) = 'vgrd/vgrd_' - DEF_forcing%fprefix(7) = 'dswrf/dswrf_' - DEF_forcing%fprefix(8) = 'dlwrf/dlwrf_' - - - DEF_forcing%vname = 'var11' 'var51' 'var1' 'var61' 'var33' 'var34' 'var204' 'var205' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml deleted file mode 100644 index c99da16be1..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/MPI-ESM1-2-HR_ssp585.nml +++ /dev/null @@ -1,45 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/share/home/dq013/zhwei/colm/data/CoLM_Forcing/MPI-ESM1-2-HR/ssp585/' - - DEF_forcing%dataset = 'CMIP6' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40.0 - DEF_forcing%HEIGHT_Q = 40.0 - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 2016 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2100 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 - DEF_forcing%offset = 0 0 0 5400 0 0 0 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'year' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'tas/tas_1d' - DEF_forcing%fprefix(2) = 'huss/huss_1d' - DEF_forcing%fprefix(3) = 'ps/ps_1d' - DEF_forcing%fprefix(4) = 'pr/pr_1d' - DEF_forcing%fprefix(5) = 'uas/uas_1d' - DEF_forcing%fprefix(6) = 'vas/vas_1d' - DEF_forcing%fprefix(7) = 'rsds/rsds_1d' - DEF_forcing%fprefix(8) = 'rlds/rlds_1d' - - - DEF_forcing%vname = 'tas' 'huss' 'ps' 'pr' 'uas' 'vas' 'rsds' 'rlds' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'linear' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml deleted file mode 100644 index e6635dcf91..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/MSWX.nml +++ /dev/null @@ -1,45 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/MSWX_V100/' - - DEF_forcing%dataset = 'MSWX' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2021 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 - DEF_forcing%offset = 5400 5400 5400 5400 5400 5400 0 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'Temp' - DEF_forcing%fprefix(2) = 'SpecHum' - DEF_forcing%fprefix(3) = 'Pres' - DEF_forcing%fprefix(4) = 'P' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'Wind' - DEF_forcing%fprefix(7) = 'SWd' - DEF_forcing%fprefix(8) = 'LWd' - - - DEF_forcing%vname = 'air_temperature' 'specific_humidity' 'surface_pressure' 'precipitation' 'NULL' 'wind_speed' 'downward_shortwave_radiation' 'downward_longwave_radiation' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml deleted file mode 100644 index 4e4a773502..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/POINT.nml +++ /dev/null @@ -1,31 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/PLUMBER2/Forcing/' - - DEF_forcing%dataset = 'POINT' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 100.0 - DEF_forcing%HEIGHT_T = 50. - DEF_forcing%HEIGHT_Q = 50. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 2013 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2020 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - - DEF_forcing%fprefix(1) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(2) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(3) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(4) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(5) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(6) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(7) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - DEF_forcing%fprefix(8) = 'CN-Dan_2004-2005_FLUXNET2015_Met.nc' - - DEF_forcing%vname = 'Tair' 'Qair' 'Psurf' 'Precip' 'NULL' 'Wind' 'SWdown' 'LWdown' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml deleted file mode 100644 index 8c965f6a64..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/PRINCETON.nml +++ /dev/null @@ -1,45 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/princeton-r/' - - DEF_forcing%dataset = 'PRINCETON' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1948 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2006 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 10800 10800 10800 10800 - DEF_forcing%offset = 0 0 0 0 0 0 0 0 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'latitude' ! dimension name of latitude - DEF_forcing%lonname = 'longitude' ! dimension name of longitude - - DEF_forcing%groupby = 'year' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'tas/tas_3hourly_' - DEF_forcing%fprefix(2) = 'shum/shum_3hourly_' - DEF_forcing%fprefix(3) = 'pres/pres_3hourly_' - DEF_forcing%fprefix(4) = 'prcp/prcp_3hourly_' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'wind/wind_3hourly_' - DEF_forcing%fprefix(7) = 'dswrf/dswrf_3hourly_' - DEF_forcing%fprefix(8) = 'dlwrf/dlwrf_3hourly_' - - - DEF_forcing%vname = 'tas' 'shum' 'pres' 'prcp' 'NULL' 'wind' 'dswrf' 'dlwrf' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml deleted file mode 100644 index ab97240b7d..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/QIAN.nml +++ /dev/null @@ -1,45 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/qian/' - - DEF_forcing%dataset = 'QIAN' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1972 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2004 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 21600 0 10800 21600 0 - DEF_forcing%offset = 5400 5400 5400 10800 0 5400 0 0 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .false. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'LATIXY' ! dimension name of latitude - DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' - DEF_forcing%fprefix(2) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' - DEF_forcing%fprefix(3) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' - DEF_forcing%fprefix(4) = 'Precip6Hrly/clmforc.Qian.c2006.T62.Prec.' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'TmpPrsHumWnd3Hrly/clmforc.Qian.c2006.T62.TPQW.' - DEF_forcing%fprefix(7) = 'Solar6Hrly/clmforc.Qian.c2006.T62.Solr.' - DEF_forcing%fprefix(8) = 'NULL' - - - DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'NULL' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'NULL' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml deleted file mode 100644 index 0ff75008bc..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/TPMFD.nml +++ /dev/null @@ -1,50 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/TPMFD/' - - DEF_forcing%dataset = 'TPMFD' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40.0 - DEF_forcing%HEIGHT_Q = 40.0 - - DEF_forcing%regional = .true. - DEF_forcing%regbnd = 25.4166 41.3818 61.0 105.678 - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = 'missing_value' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2021 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 0 0 0 0 0 0 0 0 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'latitude' ! dimension name of latitude - DEF_forcing%lonname = 'longitude' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'temp/temp_' - DEF_forcing%fprefix(2) = 'shum/shum_' - DEF_forcing%fprefix(3) = 'pres/pres_' - DEF_forcing%fprefix(4) = 'prcp/prcp_' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'wind/wind_' - DEF_forcing%fprefix(7) = 'srad/srad_' - DEF_forcing%fprefix(8) = 'lrad/lrad_' - - - DEF_forcing%vname = 'temp' 'shum' 'pres' 'prcp' 'NULL' 'wind' 'srad' 'lrad' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml deleted file mode 100644 index c94765eed4..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDE5.nml +++ /dev/null @@ -1,48 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/WFDE5/' - - DEF_forcing%dataset = 'WFDE5' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = '_FillValue' - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2019 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 3600 3600 3600 3600 3600 3600 3600 3600 - DEF_forcing%offset = 0 0 0 1800 0 0 0 1800 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .true. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .false. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'lat' ! dimension name of latitude - DEF_forcing%lonname = 'lon' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'near_surface_air_temperature/Tair_WFDE5_CRU_' - DEF_forcing%fprefix(2) = 'near_surface_specific_humidity/Qair_WFDE5_CRU_' - DEF_forcing%fprefix(3) = 'surface_air_pressure/PSurf_WFDE5_CRU_' - DEF_forcing%fprefix(4) = 'rainfall_plus_snowfall_flux_CRU_GPCP/precipitation_CRU_GPCP_' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'near_surface_wind_speed/Wind_WFDE5_CRU_' - DEF_forcing%fprefix(7) = 'surface_downwelling_shortwave_radiation/SWdown_WFDE5_CRU_' - DEF_forcing%fprefix(8) = 'surface_downwelling_longwave_radiation/LWdown_WFDE5_CRU_' - - - DEF_forcing%vname = 'Tair' 'Qair' 'PSurf' 'precipitation' 'NULL' 'Wind' 'SWdown' 'LWdown' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml b/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml deleted file mode 100644 index 7c44a9cb49..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/forcing/WFDEI.nml +++ /dev/null @@ -1,49 +0,0 @@ -&nl_colm_forcing - - ! ----- forcing ----- - DEF_dir_forcing = '/shr03/CoLM_Forcing/WFDEI/' - - DEF_forcing%dataset = 'WFDEI' - DEF_forcing%solarin_all_band = .true. - DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 40. - DEF_forcing%HEIGHT_Q = 40. - - DEF_forcing%has_missing_value = .true. - DEF_forcing%missing_value_name = '_FillValue' - - - DEF_forcing%NVAR = 8 ! variable number of forcing data - DEF_forcing%startyr = 1979 ! start year of forcing data - DEF_forcing%startmo = 1 ! start month of forcing data - DEF_forcing%endyr = 2016 ! end year of forcing data - DEF_forcing%endmo = 12 ! end month of forcing data - DEF_forcing%dtime = 10800 10800 10800 10800 0 10800 10800 10800 - DEF_forcing%offset = 0 0 0 5400 0 0 0 5400 - DEF_forcing%nlands = 1 ! land grid number in 1d - - DEF_forcing%leapyear = .false. ! leapyear calendar - DEF_forcing%data2d = .true. ! data in 2 dimension (lon, lat) - DEF_forcing%hightdim = .false. ! have "z" dimension - DEF_forcing%dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) - - DEF_forcing%latname = 'LATIXY' ! dimension name of latitude - DEF_forcing%lonname = 'LONGXY' ! dimension name of longitude - - DEF_forcing%groupby = 'month' ! file grouped by year/month - - DEF_forcing%fprefix(1) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(2) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(3) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(4) = 'clmforc.WFDEI.c2017.0.5x0.5.Prec.' - DEF_forcing%fprefix(5) = 'NULL' - DEF_forcing%fprefix(6) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' - DEF_forcing%fprefix(7) = 'clmforc.WFDEI.c2017.0.5x0.5.Solr.' - DEF_forcing%fprefix(8) = 'clmforc.WFDEI.c2017.0.5x0.5.TPQWL.' - - - DEF_forcing%vname = 'TBOT' 'QBOT' 'PSRF' 'PRECTmms' 'NULL' 'WIND' 'FSDS' 'FLDS' - DEF_forcing%timelog = 'instant' 'instant' 'instant' 'forward' 'instant' 'instant' 'forward' 'forward' - DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' - -/ diff --git a/src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt b/src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt deleted file mode 100644 index 0b04883dcc..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/mapdata.txt +++ /dev/null @@ -1,5 +0,0 @@ - NX 360 - NY 200 - NLFP 10 - REGIONALL 1 - NSEQMAX 41455 diff --git a/src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml b/src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml deleted file mode 100644 index c082d9ffea..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/run/test_vic_para.nml +++ /dev/null @@ -1,111 +0,0 @@ -&nl_colm - -! Author: Shupeng Zhang -! Description : include soil state init from data. - - DEF_CASE_NAME = 'test_vic_para_global' - !DEF_file_mesh='/stu01/guoqj23/data/landtype/mask_zhujiang_0.5deg/mask_landtype9.nc' - !DEF_file_mesh='/stu01/guoqj23/data/landtype_mask/china_mask.nc' - - DEF_domain%edges = -90 - DEF_domain%edgen = 90 - DEF_domain%edgew = -180 - DEF_domain%edgee = 180 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2010 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 1 - DEF_simulation_time%end_sec = 0 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 0 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/shr03/CoLMrawdata/' - DEF_dir_runtime = '/shr03/CoLMruntime/' - DEF_dir_output = '/stu01/guoqj23/CoLM202X/cases/' - - !---- Run off setting ---- - DEF_file_VIC_para = './vic_para.txt' - DEF_VIC_OPT = .true. - DEF_file_VIC_OPT = '/stu01/guoqj23/CoLM202X/CoLM202X-20250829/vic_para.nc' - DEF_Runoff_SCHEME = 1 - - !---- LAI setting ---- - DEF_LC_YEAR = 2005 - - !---- Urban options ---- - ! urban type options - ! Options : - ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density - ! 2: LCZ Classification, 10 urban type with LCZ 1-10 - DEF_URBAN_type_scheme = 1 - - DEF_LAI_CHANGE_YEARLY=.false. - DEF_RSS_SCHEME = 1 - ! urban module options - DEF_URBAN_ONLY = .false. - DEF_URBAN_TREE = .true. - DEF_URBAN_WATER= .true. - DEF_URBAN_BEM = .true. - DEF_URBAN_LUCY = .true. - ! ----------------------- - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ---- Hydrology module ---- - DEF_USE_SUPERCOOL_WATER = .false. - DEF_USE_VariablySaturatedFlow = .false. - DEF_USE_PLANTHYDRAULICS = .false. - ! -------------------------- - - ! ---- SNICAR ---- - DEF_USE_SNICAR = .false. - DEF_Aerosol_Readin = .true. - DEF_Aerosol_Clim = .false. - ! ---------------- - - ! ---- Ozone MODULE ---- - DEF_USE_OZONESTRESS = .false. - DEF_USE_OZONEDATA = .false. - ! ---------------------- - - ! ---- Bedrock ---- - DEF_USE_BEDROCK = .false. - ! ----------------- - - ! ---- Forcing Downscalling ---- - DEF_USE_Forcing_Downscaling = .false. - DEF_DS_precipitation_adjust_scheme = 'II' - DEF_DS_longwave_adjust_scheme = 'II' - - ! ----- forcing ----- - DEF_forcing_namelist = '/stu01/guoqj23/CoLM202X/CoLM202X-20250830/run/forcing/GSWP3.nml' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_GRIDBASED_lon_res = 0.5 - DEF_GRIDBASED_lat_res = 0.5 - - ! ----- history ----- - DEF_hist_lon_res = 0.5 - DEF_hist_lat_res = 0.5 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'YEAR' ! history in one file: DAY/MONTH/YEAR - DEF_REST_CompressLevel = 0 - DEF_HIST_CompressLevel = 0 - - !DEF_hist_vars_namelist = '/stu01/guoqj23/CoLM202X/CoLM202X-0314vicsingle/run/history.nml' - !DEF_hist_vars_out_default = .false. - -/ From f285bb182c758971b4c9fe4381be0c43208c0454 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 22:05:44 +0800 Subject: [PATCH 06/17] Merge CoLM surface-data modules into shared embedded source Constraint: MPAS embedded CoLM still needs these surface/restart and land-unit modules, but no standalone mksrfdata directory should remain. Rejected: Deleting the modules outright | MPAS initialization and CoLM object lists still depend on them. Confidence: high Scope-risk: narrow Directive: Keep future embedded CoLM runtime/shared modules under share unless they are true MPAS driver code or main physics kernels. Tested: cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; make -C src/core_atmosphere/physics/physics_colm2024 clean && NETCDF=/opt/homebrew/Cellar/netcdf/4.10.0 NETCDFF=/opt/homebrew/Cellar/netcdf-fortran/4.6.2 PNETCDF=/opt/homebrew/Cellar/pnetcdf/1.14.1 make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true -j 8; git diff --check; git diff --cached --check; rg found no mksrfdata path references. Not-tested: Runtime MPAS+CoLM case with real landdata/restart inputs. --- src/core_atmosphere/CMakeLists.txt | 1 - src/core_atmosphere/physics/physics_colm2024/Makefile | 2 +- .../{mksrfdata => share}/MOD_AggregationRequestData.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_ElmVector.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_HRUVector.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_Land2mWMO.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_LandCrop.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_LandElm.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_LandHRU.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_LandPFT.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_LandPatch.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_LandUrban.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_MeshFilter.F90 | 0 .../{mksrfdata => share}/MOD_PixelsetShared.F90 | 0 .../physics_colm2024/{mksrfdata => share}/MOD_SingleSrfdata.F90 | 0 .../{mksrfdata => share}/MOD_SrfdataRestart.F90 | 0 16 files changed, 1 insertion(+), 2 deletions(-) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_AggregationRequestData.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_ElmVector.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_HRUVector.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_Land2mWMO.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_LandCrop.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_LandElm.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_LandHRU.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_LandPFT.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_LandPatch.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_LandUrban.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_MeshFilter.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_PixelsetShared.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_SingleSrfdata.F90 (100%) rename src/core_atmosphere/physics/physics_colm2024/{mksrfdata => share}/MOD_SrfdataRestart.F90 (100%) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 500de79be7..97b1370f8f 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -320,7 +320,6 @@ if(MPAS_COLM2024) set(COLM2024_SOURCE_SEARCH_DIRS include share - mksrfdata main main/HYDRO main/BGC diff --git a/src/core_atmosphere/physics/physics_colm2024/Makefile b/src/core_atmosphere/physics/physics_colm2024/Makefile index c96a71cb93..988f1339e7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/Makefile +++ b/src/core_atmosphere/physics/physics_colm2024/Makefile @@ -10,7 +10,7 @@ endif ifneq ($(strip $(PNETCDF_INC)),) INCLUDE_DIR += -I$(PNETCDF_INC) endif -VPATH = include : share : mksrfdata \ +VPATH = include : share \ : main : main/HYDRO : main/BGC : main/URBAN : main/DA \ : main/ParaOpt : drivers/mpas : .bld diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_AggregationRequestData.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_ElmVector.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_HRUVector.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_Land2mWMO.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandCrop.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandElm.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandHRU.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPFT.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandPatch.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_LandUrban.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_MeshFilter.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_PixelsetShared.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SingleSrfdata.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SingleSrfdata.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 diff --git a/src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 similarity index 100% rename from src/core_atmosphere/physics/physics_colm2024/mksrfdata/MOD_SrfdataRestart.F90 rename to src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 From 20a9cfd3e2283827fe9836c8f455af44ddc06094 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 22:30:03 +0800 Subject: [PATCH 07/17] Keep embedded CoLM MPI helpers on MPAS-owned ranks Constraint: MPAS embedded CoLM runs root and compute roles on the same MPAS ranks, so old standalone IO/worker point-to-point paths must not self-send or leave vector address tables unallocated. Rejected: Reintroducing a separate CoLM worker/IO process pool | MPAS must own the communicator and CoLM must stay rank-local to MPAS cells. Confidence: high Scope-risk: moderate Directive: Embedded CoLM helper paths should use local data access or self-skip collectives; do not add standalone master/worker handshakes under MPAS_EMBEDDED_COLM. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; NETCDF=/opt/homebrew/Cellar/netcdf/4.10.0 NETCDFF=/opt/homebrew/Cellar/netcdf-fortran/4.6.2 PNETCDF=/opt/homebrew/Cellar/pnetcdf/1.14.1 make gfortran CORE=atmosphere COLM2024=true AUTOCLEAN=true -j 8 Not-tested: Runtime MPAS+CoLM case with real landdata/restart/riverlake/reservoir inputs. --- .../main/HYDRO/MOD_Grid_Reservoir.F90 | 10 ++---- .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 1 + .../share/MOD_AggregationRequestData.F90 | 10 +++++- .../physics_colm2024/share/MOD_ElmVector.F90 | 26 ++++++++++++-- .../physics_colm2024/share/MOD_LandHRU.F90 | 36 +++++++++++++++++-- .../physics_colm2024/share/MOD_RangeCheck.F90 | 24 ++++++------- 6 files changed, 80 insertions(+), 27 deletions(-) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 index 9857bf3acf..a2a018375a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -139,15 +139,10 @@ SUBROUTINE reservoir_init ( ) ENDIF -#ifdef MPAS_EMBEDDED_COLM - ! MPAS embedded mode writes reservoir restart state from each owning rank - ! with resv_global_index, so no master-side global address table is needed. -#else #ifdef COLM_PARALLEL - IF (p_is_root) THEN - - allocate (resv_data_address (0:p_np_compute-1)) + IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:p_np_compute-1)) + IF (p_is_root) THEN DO iworker = 0, p_np_compute-1 IF (p_address_compute(iworker) == p_iam_glb) THEN @@ -186,7 +181,6 @@ SUBROUTINE reservoir_init ( ) allocate (resv_data_address(0)%val (numresv)) resv_data_address(0)%val = resv_global_index(1:numresv) ENDIF -#endif #endif IF (p_is_compute) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index 11f396c173..10a0fd907e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -1275,6 +1275,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () ENDIF CALL build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) + CALL gather_mpas_embedded_ucat_addresses() CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) inpn = varsize(1) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 index 51f99e2fc1..684f4d7e2e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 @@ -72,6 +72,10 @@ SUBROUTINE aggregation_data_daemon (grid_in, & logical, allocatable :: compute_done (:) +#ifdef MPAS_EMBEDDED_COLM + RETURN +#endif + IF (p_is_active) THEN allocate (compute_done (0:p_np_compute-1)) @@ -471,7 +475,7 @@ SUBROUTINE aggregation_request_data ( & ENDIF ENDIF -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) allocate (ipt (totalreq)) allocate (msk (totalreq)) @@ -649,6 +653,10 @@ SUBROUTINE aggregation_compute_done () integer :: smesg(2), iproc, idest +#ifdef MPAS_EMBEDDED_COLM + RETURN +#endif + IF (p_is_compute) THEN DO iproc = 0, p_np_active-1 smesg = (/p_iam_glb, -1/) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 index ba7030b2b5..8479808cac 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 @@ -68,15 +68,23 @@ SUBROUTINE elm_vector_init numelm_worker, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) IF (p_iam_compute == p_root) THEN +#ifndef MPAS_EMBEDDED_COLM CALL mpi_send (numelm_worker, p_np_compute, MPI_INTEGER, & p_address_root, mpi_tag_size, p_comm_glb, p_err) +#endif ENDIF mesg = (/p_iam_glb, numelm/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numelm > 0) THEN - CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err) +#ifdef MPAS_EMBEDDED_COLM + IF (.not. (p_is_root .and. p_iam_compute == p_root)) THEN +#endif + CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + IF (numelm > 0) THEN + CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err) + ENDIF +#ifdef MPAS_EMBEDDED_COLM ENDIF +#endif #else IF (numelm > 0) THEN allocate (eindex_glb (numelm)) @@ -87,9 +95,11 @@ SUBROUTINE elm_vector_init IF (p_is_root) THEN #ifdef USEMPI +#ifndef MPAS_EMBEDDED_COLM allocate (numelm_worker (0:p_np_compute-1)) CALL mpi_recv (numelm_worker, p_np_compute, MPI_INTEGER, p_address_compute(p_root), & mpi_tag_size, p_comm_glb, p_stat, p_err) +#endif allocate (vec_worker_dsp (0:p_np_compute-1)) vec_worker_dsp(0) = 0 @@ -109,6 +119,16 @@ SUBROUTINE elm_vector_init ENDDO DO iwork = 0, p_np_compute-1 +#ifdef MPAS_EMBEDDED_COLM + IF (iwork == p_root) THEN + ndata = numelm_worker(iwork) + IF (ndata > 0) THEN + idsp = vec_worker_dsp(iwork) + eindex_glb(idsp+1:idsp+ndata) = indexelm(1:ndata) + ENDIF + CYCLE + ENDIF +#endif CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 index a63fed01a7..7e490ebf47 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 @@ -76,6 +76,37 @@ SUBROUTINE landhru_build () ENDIF #ifdef USEMPI +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_root) THEN + ncat = size(numhru_all_g) + ELSE + ncat = 0 + ENDIF + CALL mpi_bcast (ncat, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) + IF (.not. p_is_root) THEN + allocate (numhru_all_g(ncat)) + allocate (lakeid(ncat)) + ENDIF + CALL mpi_bcast (numhru_all_g, ncat, MPI_INTEGER, p_root, p_comm_glb, p_err) + CALL mpi_bcast (lakeid, ncat, MPI_INTEGER, p_root, p_comm_glb, p_err) + + IF (p_is_compute) THEN + IF (numelm > 0) THEN + allocate (catnum(numelm)) + allocate (ibuff(numelm)) + catnum = landelm%eindex + numhru = sum(numhru_all_g(catnum)) + ibuff = lakeid(catnum) + deallocate (lakeid) + allocate (lakeid(numelm)) + lakeid = ibuff + deallocate (catnum) + deallocate (ibuff) + ELSE + numhru = 0 + ENDIF + ENDIF +#else IF (p_is_root) THEN DO iwork = 0, p_np_compute-1 @@ -114,13 +145,12 @@ SUBROUTINE landhru_build () numhru = 0 ENDIF ENDIF +#endif #else numhru = sum(numhru_all_g) #endif - IF (p_is_root) THEN - IF (allocated(numhru_all_g)) deallocate(numhru_all_g) - ENDIF + IF (allocated(numhru_all_g)) deallocate(numhru_all_g) IF (p_is_active) CALL allocate_block_data (grid_hru, hrudata) CALL catchment_data_read (DEF_CatchmentMesh_data, 'ihydrounit2d', grid_hru, hrudata) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 index d25f51486b..c7de99cc96 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 @@ -148,7 +148,7 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) wfmt = "('Check block data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" write(str_print,wfmt) varname, gmin, gmax, trim(exception) -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & @@ -158,7 +158,7 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) ENDIF IF (p_is_root) THEN -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_active(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_active(p_root), & @@ -272,7 +272,7 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" write(str_print,wfmt) varname, vmin, vmax, trim(exception) -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & @@ -282,7 +282,7 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) ENDIF IF (p_is_root) THEN -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & @@ -397,7 +397,7 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" write(str_print,wfmt) varname, vmin, vmax, trim(exception) -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & @@ -407,7 +407,7 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) ENDIF IF (p_is_root) THEN -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & @@ -525,7 +525,7 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" write(str_print,wfmt) varname, vmin, vmax, trim(exception) -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & @@ -535,7 +535,7 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) ENDIF IF (p_is_root) THEN -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & @@ -655,7 +655,7 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" write(str_print,wfmt) varname, vmin, vmax, trim(exception) -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & @@ -665,7 +665,7 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) ENDIF IF (p_is_root) THEN -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & @@ -864,7 +864,7 @@ SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) IF (p_iam_compute == p_root) THEN wfmt = "('Check vector data:', A25, ' is in (', I20, ',', I20, ')')" write(str_print,wfmt) varname, vmin, vmax -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & mpi_tag_mesg, p_comm_glb, p_err) #endif @@ -872,7 +872,7 @@ SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) ENDIF IF (p_is_root) THEN -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif From 25583c25841e0dc7c0ed2f5837f05084f8a09c6e Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 23:08:39 +0800 Subject: [PATCH 08/17] Tighten embedded CoLM cell ownership Constraint: MPAS embedded CoLM must use MPAS-owned cell decomposition while retaining CoLM patch/PFT state internally. Rejected: Coordinate fallback mapping | It can silently map multiple MPAS cells to one CoLM element and breaks the MPAS cell == CoLM element contract. Rejected: Embedded root-gather river/reservoir address tables | They recreate legacy process-pool assumptions and are not needed by MPAS-owned routing/restart paths. Confidence: high Scope-risk: moderate Directive: Keep CoLM MPI enabled through MPAS communicators; do not revive standalone process pools or global river-network replication. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8 Not-tested: End-to-end multi-rank MPAS run with real landdata/restart files. --- .../mpas_atmphys_driver_lsm_colm2024.F | 117 +++++-- .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 305 ++++++++++-------- .../physics/physics_colm2024/include/define.h | 6 +- .../main/HYDRO/MOD_Grid_Reservoir.F90 | 2 + .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 46 ++- .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 77 +---- .../main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 | 4 +- .../physics_colm2024/share/MOD_SPMD_Task.F90 | 2 +- 8 files changed, 282 insertions(+), 277 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index f475759bcd..c20ba4c311 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -17,11 +17,12 @@ module mpas_atmphys_driver_lsm_colm2024 use mpas_atmphys_vars, only: dt_pbl, xice_threshold #ifdef MPAS_COLM2024 - use MOD_Precision, only: colm_r8 => r8 - use MOD_CoLM_MPAS_Interface, only: colm_mpas_initialize_from_namelist, colm_mpas_ready, & - colm_mpas_set_element_forcing, & - colm_mpas_step, colm_mpas_get_element_surface, & - colm_mpas_finalize + use MOD_Precision, only: colm_r8 => r8 + use MOD_CoLM_MPAS_Interface, only: colm_mpas_initialize_from_namelist, colm_mpas_ready, & + colm_mpas_set_element_forcing, & + colm_mpas_step, colm_mpas_get_element_surface, & + colm_mpas_get_element_state, & + colm_mpas_finalize #endif implicit none @@ -280,14 +281,19 @@ subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) real(kind=colm_r8),intent(in):: dt integer,intent(in):: its,ite - integer:: i + integer:: i, ns, nlev, nvalid_soil integer:: ierr real(kind=colm_r8):: sensible, latent, evaporation, ground_heat, runoff real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm real(kind=colm_r8):: emissivity, roughness, albedo + real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index + real(kind=colm_r8):: soil_moisture_sum + real(kind=colm_r8),parameter:: colm_state_bad_value = 1.e30_colm_r8 + real(kind=colm_r8),dimension(:),allocatable:: soil_liquid, soil_moisture, soil_temperature real(kind=RKIND),dimension(:),pointer:: hfx, lh, qfx, grdflx, sfcrunoff, udrunoff real(kind=RKIND),dimension(:),pointer:: sfc_albedo, sfc_emiss, z0, znt, qsfc, t2m, q2 - real(kind=RKIND),dimension(:),pointer:: skintemp + real(kind=RKIND),dimension(:),pointer:: skintemp, canwat, smstav, smstot, snow, snowc, snowh, lai + real(kind=RKIND),dimension(:,:),pointer:: sh2o, smois, tslb call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) call mpas_pool_get_array(diag_physics,'lh' ,lh ) @@ -302,36 +308,81 @@ subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) + call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) call mpas_pool_get_array(sfc_input,'skintemp',skintemp) - - do i = its,ite - if(colm_element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") - - call colm_mpas_get_element_surface(colm_element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & - surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & - emissivity, roughness, albedo, ierr) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + nlev = size(tslb, 1) + allocate(soil_liquid(nlev), soil_moisture(nlev), soil_temperature(nlev)) + + do i = its,ite + if(colm_element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + + call colm_mpas_get_element_surface(colm_element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & + emissivity, roughness, albedo, ierr) if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.") - - hfx(i) = real(sensible, RKIND) - lh(i) = real(latent, RKIND) - qfx(i) = real(evaporation, RKIND) - grdflx(i) = real(ground_heat, RKIND) - sfcrunoff(i) = real(surface_runoff * dt, RKIND) - udrunoff(i) = real(subsurface_runoff * dt, RKIND) - skintemp(i) = real(skin_temp, RKIND) - t2m(i) = real(t2m_colm, RKIND) - qsfc(i) = real(q2m_colm, RKIND) - if(q2m_colm > 0._colm_r8 .and. q2m_colm < 1._colm_r8) then - q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) - else - q2(i) = real(q2m_colm, RKIND) - endif - sfc_emiss(i) = real(emissivity, RKIND) - z0(i) = real(roughness, RKIND) - znt(i) = real(roughness, RKIND) - if(albedo > 0._colm_r8 .and. albedo < 1._colm_r8) sfc_albedo(i) = real(albedo, RKIND) + call colm_mpas_get_element_state(colm_element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, & + leaf_area_index, soil_liquid, soil_moisture, soil_temperature, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface state.") + + hfx(i) = real(sensible, RKIND) + lh(i) = real(latent, RKIND) + qfx(i) = real(evaporation, RKIND) + grdflx(i) = real(ground_heat, RKIND) + sfcrunoff(i) = real(surface_runoff * dt, RKIND) + udrunoff(i) = real(subsurface_runoff * dt, RKIND) + skintemp(i) = real(skin_temp, RKIND) + t2m(i) = real(t2m_colm, RKIND) + qsfc(i) = real(q2m_colm, RKIND) + if(q2m_colm > 0._colm_r8 .and. q2m_colm < 1._colm_r8) then + q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) + else + q2(i) = real(q2m_colm, RKIND) + endif + sfc_emiss(i) = real(emissivity, RKIND) + z0(i) = real(roughness, RKIND) + znt(i) = real(roughness, RKIND) + if(albedo > 0._colm_r8 .and. albedo < 1._colm_r8) sfc_albedo(i) = real(albedo, RKIND) + canwat(i) = real(canopy_water, RKIND) + snow(i) = real(snow_water, RKIND) + snowh(i) = real(snow_depth, RKIND) + snowc(i) = real(max(0._colm_r8, min(1._colm_r8, snow_cover)), RKIND) + lai(i) = real(max(0._colm_r8, leaf_area_index), RKIND) + + soil_moisture_sum = 0._colm_r8 + nvalid_soil = 0 + do ns = 1,nlev + if(abs(soil_liquid(ns)) < colm_state_bad_value .and. & + abs(soil_moisture(ns)) < colm_state_bad_value .and. & + abs(soil_temperature(ns)) < colm_state_bad_value) then + sh2o(ns,i) = real(soil_liquid(ns), RKIND) + smois(ns,i) = real(soil_moisture(ns), RKIND) + tslb(ns,i) = real(soil_temperature(ns), RKIND) + soil_moisture_sum = soil_moisture_sum + soil_moisture(ns) + nvalid_soil = nvalid_soil + 1 + endif + enddo + if(nvalid_soil > 0) then + smstot(i) = real(soil_moisture_sum / real(nvalid_soil, colm_r8), RKIND) + if(abs(soil_moisture(1)) < colm_state_bad_value) then + smstav(i) = real(soil_moisture(1), RKIND) + else + smstav(i) = smstot(i) + endif + endif enddo + deallocate(soil_liquid, soil_moisture, soil_temperature) + end subroutine colm2024_pull_mpas_surface #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index 973d30891a..cf610817ed 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -4,7 +4,7 @@ MODULE MOD_CoLM_MPAS_Interface USE MOD_Precision USE MOD_LandPatch, only: numpatch, landpatch, elm_patch - USE MOD_Vars_Global, only: spval + USE MOD_Vars_Global, only: spval, nl_soil, dz_soi USE MOD_Vars_1DForcing, only: forc_pco2m, forc_po2m, forc_us, forc_vs, forc_t, forc_q, & forc_prc, forc_prl, forc_rain, forc_snow, forc_psrf, forc_pbot, forc_sols, forc_soll, & forc_solsd, forc_solld, forc_frl, forc_swrad, forc_hgt_u, forc_hgt_t, forc_hgt_q, & @@ -13,27 +13,24 @@ MODULE MOD_CoLM_MPAS_Interface USE MOD_Vars_1DForcing, only: forc_solarin #endif USE MOD_Vars_1DFluxes, only: oroflag, fsena, lfevpa, fevpa, fgrnd, rnof, rsur, rsub - USE MOD_Vars_TimeInvariants, only: patchlatr, patchlonr, patchmask - USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, emis, z0m, alb + USE MOD_Vars_TimeInvariants, only: patchmask + USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, emis, z0m, alb, & + ldew, scv, snowdp, fsno, lai, t_soisno, wliq_soisno, wice_soisno USE MOD_TimeManager, only: timestamp IMPLICIT NONE PRIVATE - PUBLIC :: colm_mpas_initialize_from_namelist - PUBLIC :: colm_mpas_finalize - PUBLIC :: colm_mpas_ready - PUBLIC :: colm_mpas_find_patch - PUBLIC :: colm_mpas_find_element - PUBLIC :: colm_mpas_set_forcing + PUBLIC :: colm_mpas_initialize_from_namelist + PUBLIC :: colm_mpas_finalize + PUBLIC :: colm_mpas_ready PUBLIC :: colm_mpas_set_element_forcing PUBLIC :: colm_mpas_step PUBLIC :: colm_mpas_get_surface PUBLIC :: colm_mpas_get_element_surface + PUBLIC :: colm_mpas_get_element_state logical, save :: colm_mpas_initialized = .false. - real(r8), allocatable, save :: colm_mpas_elm_lonr(:) - real(r8), allocatable, save :: colm_mpas_elm_latr(:) character(len=256), save :: colm_mpas_casename = '' character(len=256), save :: colm_mpas_dir_restart = '' integer, save :: colm_mpas_lc_year = -1 @@ -212,30 +209,21 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_lon_ #endif IF (n_mpas > 0) THEN - CALL colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cell_id, & - n_mpas, cell_to_element, ierr) + CALL colm_mpas_restrict_to_mpas_cells(mpas_cell_id, n_mpas, cell_to_element, ierr) IF (ierr /= 0) RETURN ENDIF - CALL elm_patch%build(landelm, landpatch, use_frac = .true.) + CALL elm_patch%build(landelm, landpatch, use_frac = .true.) #ifdef GridRiverLakeFlow #ifdef MPAS_EMBEDDED_COLM - CALL colm_mpas_check_embedded_riverlake(ierr) - IF (ierr /= 0) RETURN + CALL colm_mpas_check_embedded_riverlake(ierr) + IF (ierr /= 0) RETURN #endif - CALL build_riverlake_network() - IF (DEF_Reservoir_Method > 0) CALL reservoir_init() + CALL build_riverlake_network() + IF (DEF_Reservoir_Method > 0) CALL reservoir_init() #endif - IF (allocated(colm_mpas_elm_lonr)) deallocate(colm_mpas_elm_lonr) - IF (allocated(colm_mpas_elm_latr)) deallocate(colm_mpas_elm_latr) - IF (numelm > 0) THEN - allocate(colm_mpas_elm_lonr(numelm)) - allocate(colm_mpas_elm_latr(numelm)) - CALL landelm%get_lonlat_radian(colm_mpas_elm_lonr, colm_mpas_elm_latr) - ENDIF - #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL map_patch_to_pft #endif @@ -289,7 +277,7 @@ SUBROUTINE colm_mpas_check_embedded_riverlake(ierr) ENDIF IF (p_np_glb > 1 .and. p_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded GridRiverLakeFlow uses MPAS communicator ranks for distributed routing.' - write(*,'(A)') 'CoLM standalone MPI process pools and replicated full-river-network fallback are disabled.' + write(*,'(A)') 'Legacy CoLM MPI process pools and replicated full-river-network fallback are disabled.' ENDIF END SUBROUTINE colm_mpas_check_embedded_riverlake #endif @@ -401,23 +389,18 @@ SUBROUTINE colm_mpas_finalize(ierr) CALL grid_riverlake_flow_final() #endif - IF (allocated(colm_mpas_elm_lonr)) deallocate(colm_mpas_elm_lonr) - IF (allocated(colm_mpas_elm_latr)) deallocate(colm_mpas_elm_latr) CALL spmd_exit() colm_mpas_initialized = .false. colm_mpas_restart_ready = .false. END SUBROUTINE colm_mpas_finalize - SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cell_id, & - n_mpas_cells, cell_to_element, ierr) + SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_cell_id, n_mpas_cells, cell_to_element, ierr) USE MOD_LandElm, only: landelm USE MOD_LandPatch, only: landpatch, numpatch USE MOD_Mesh, only: numelm #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT, only: landpft, numpft #endif - real(r8), intent(in) :: mpas_lon_rad(:) - real(r8), intent(in) :: mpas_lat_rad(:) integer, intent(in) :: mpas_cell_id(:) integer, intent(in) :: n_mpas_cells integer, intent(out) :: cell_to_element(:) @@ -428,13 +411,9 @@ SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cel logical, allocatable :: keep_pft(:) integer, allocatable :: old_to_new(:) integer, allocatable :: old_element_for_cell(:) - real(r8), allocatable :: all_lon(:) - real(r8), allocatable :: all_lat(:) integer :: i integer :: old_element integer :: packed_count - real(r8) :: match_dist2 - real(r8), parameter :: max_coord_match_dist2 = 1.e-10_r8 ierr = 1 IF (n_mpas_cells < 1) RETURN @@ -444,21 +423,12 @@ SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_lon_rad, mpas_lat_rad, mpas_cel allocate(keep_elm(numelm)) allocate(old_to_new(numelm)) allocate(old_element_for_cell(n_mpas_cells)) - allocate(all_lon(numelm)) - allocate(all_lat(numelm)) keep_elm = .false. old_to_new = 0 - CALL landelm%get_lonlat_radian(all_lon, all_lat) DO i = 1, n_mpas_cells CALL colm_mpas_find_element_by_eindex(mpas_cell_id(i), old_element) - IF (old_element <= 0) THEN - match_dist2 = huge(match_dist2) - CALL colm_mpas_find_element_in_arrays(mpas_lon_rad(i), mpas_lat_rad(i), & - all_lon, all_lat, old_element, match_dist2) - IF (match_dist2 > max_coord_match_dist2) old_element = 0 - ENDIF IF (old_element <= 0 .or. old_element > numelm) RETURN old_element_for_cell(i) = old_element @@ -563,55 +533,27 @@ SUBROUTINE colm_mpas_find_element_by_eindex(cell_id, element) integer, intent(out) :: element integer :: i + integer :: hits integer*8 :: cell_id_i8 element = 0 + hits = 0 cell_id_i8 = cell_id DO i = 1, landelm%nset IF (landelm%eindex(i) == cell_id_i8) THEN + hits = hits + 1 element = i - RETURN ENDIF ENDDO + IF (hits /= 1) element = 0 END SUBROUTINE colm_mpas_find_element_by_eindex - SUBROUTINE colm_mpas_find_element_in_arrays(lon_rad, lat_rad, lon_array, lat_array, element, best_dist2_out) - real(r8), intent(in) :: lon_rad - real(r8), intent(in) :: lat_rad - real(r8), intent(in) :: lon_array(:) - real(r8), intent(in) :: lat_array(:) - integer, intent(out) :: element - real(r8), intent(out), optional :: best_dist2_out - - integer :: i - real(r8) :: dlon - real(r8) :: dist2 - real(r8) :: best_dist2 - real(r8), parameter :: two_pi = 6.283185307179586476925286766559_r8 - - element = 0 - IF (size(lon_array) /= size(lat_array)) RETURN - - best_dist2 = huge(best_dist2) - DO i = 1, size(lat_array) - dlon = abs(lon_array(i) - lon_rad) - dlon = min(dlon, two_pi - dlon) - dist2 = dlon * dlon + (lat_array(i) - lat_rad) * (lat_array(i) - lat_rad) - IF (dist2 < best_dist2) THEN - best_dist2 = dist2 - element = i - ENDIF - ENDDO - IF (present(best_dist2_out)) best_dist2_out = best_dist2 - END SUBROUTINE colm_mpas_find_element_in_arrays - SUBROUTINE colm_mpas_ready(ready, patch_count) logical, intent(out) :: ready integer, intent(out), optional :: patch_count ready = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) & - .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subfrc) & - .and. allocated(colm_mpas_elm_lonr) .and. allocated(colm_mpas_elm_latr) + .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subfrc) IF (present(patch_count)) THEN IF (allocated(oroflag)) THEN patch_count = size(oroflag) @@ -621,69 +563,6 @@ SUBROUTINE colm_mpas_ready(ready, patch_count) ENDIF END SUBROUTINE colm_mpas_ready - SUBROUTINE colm_mpas_find_patch(lon_rad, lat_rad, patch, ierr) - real(r8), intent(in) :: lon_rad - real(r8), intent(in) :: lat_rad - integer, intent(out) :: patch - integer, intent(out) :: ierr - - integer :: i - real(r8) :: dlon - real(r8) :: dist2 - real(r8) :: best_dist2 - real(r8), parameter :: two_pi = 6.283185307179586476925286766559_r8 - - patch = 0 - ierr = 1 - IF (.not. allocated(patchlatr)) RETURN - - best_dist2 = huge(best_dist2) - DO i = 1, size(patchlatr) - IF (allocated(patchmask)) THEN - IF (.not. patchmask(i)) CYCLE - ENDIF - dlon = abs(patchlonr(i) - lon_rad) - dlon = min(dlon, two_pi - dlon) - dist2 = dlon * dlon + (patchlatr(i) - lat_rad) * (patchlatr(i) - lat_rad) - IF (dist2 < best_dist2) THEN - best_dist2 = dist2 - patch = i - ENDIF - ENDDO - - IF (patch > 0) ierr = 0 - END SUBROUTINE colm_mpas_find_patch - - SUBROUTINE colm_mpas_find_element(lon_rad, lat_rad, element, ierr) - real(r8), intent(in) :: lon_rad - real(r8), intent(in) :: lat_rad - integer, intent(out) :: element - integer, intent(out) :: ierr - - integer :: i - real(r8) :: dlon - real(r8) :: dist2 - real(r8) :: best_dist2 - real(r8), parameter :: two_pi = 6.283185307179586476925286766559_r8 - - element = 0 - ierr = 1 - IF (.not. allocated(colm_mpas_elm_latr)) RETURN - - best_dist2 = huge(best_dist2) - DO i = 1, size(colm_mpas_elm_latr) - dlon = abs(colm_mpas_elm_lonr(i) - lon_rad) - dlon = min(dlon, two_pi - dlon) - dist2 = dlon * dlon + (colm_mpas_elm_latr(i) - lat_rad) * (colm_mpas_elm_latr(i) - lat_rad) - IF (dist2 < best_dist2) THEN - best_dist2 = dist2 - element = i - ENDIF - ENDDO - - IF (element > 0) ierr = 0 - END SUBROUTINE colm_mpas_find_element - SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, oro, ozone, ierr) @@ -1054,4 +933,144 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ierr = 0 END SUBROUTINE colm_mpas_get_element_surface -END MODULE MOD_CoLM_MPAS_Interface + SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_depth, snow_cover, & + leaf_area_index, soil_liquid, soil_moisture, soil_temperature, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index + real(r8), intent(out) :: soil_liquid(:), soil_moisture(:), soil_temperature(:) + integer, intent(out) :: ierr + + integer :: patch + integer :: istt + integer :: iend + integer :: n + integer :: nlev + real(r8) :: wt + real(r8) :: sumwt + real(r8) :: bad_value + real(r8) :: patch_canopy_water + real(r8) :: patch_snow_water + real(r8) :: patch_snow_depth + real(r8) :: patch_snow_cover + real(r8) :: patch_lai + real(r8) :: patch_liquid + real(r8) :: patch_moisture + real(r8) :: soil_wt(size(soil_liquid)) + + ierr = 1 + canopy_water = spval + snow_water = spval + snow_depth = spval + snow_cover = spval + leaf_area_index = spval + soil_liquid(:) = spval + soil_moisture(:) = spval + soil_temperature(:) = spval + + nlev = min(size(soil_liquid), size(soil_moisture), size(soil_temperature), nl_soil) + IF (nlev < 1) RETURN + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (.not. allocated(ldew)) RETURN + IF (.not. allocated(scv)) RETURN + IF (.not. allocated(snowdp)) RETURN + IF (.not. allocated(fsno)) RETURN + IF (.not. allocated(lai)) RETURN + IF (.not. allocated(t_soisno)) RETURN + IF (.not. allocated(wliq_soisno)) RETURN + IF (.not. allocated(wice_soisno)) RETURN + IF (element < 1 .or. element > size(elm_patch%substt)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt) RETURN + + bad_value = 0.5_r8 * abs(spval) + canopy_water = 0._r8 + snow_water = 0._r8 + snow_depth = 0._r8 + snow_cover = 0._r8 + leaf_area_index = 0._r8 + soil_liquid(:) = 0._r8 + soil_moisture(:) = 0._r8 + soil_temperature(:) = 0._r8 + soil_wt(:) = 0._r8 + sumwt = 0._r8 + + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) CYCLE + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (wt <= 0._r8) CYCLE + + patch_canopy_water = ldew(patch) + IF (abs(patch_canopy_water) >= bad_value) patch_canopy_water = 0._r8 + patch_snow_water = scv(patch) + IF (abs(patch_snow_water) >= bad_value) patch_snow_water = 0._r8 + patch_snow_depth = snowdp(patch) + IF (abs(patch_snow_depth) >= bad_value) patch_snow_depth = 0._r8 + patch_snow_cover = fsno(patch) + IF (abs(patch_snow_cover) >= bad_value) patch_snow_cover = 0._r8 + patch_lai = lai(patch) + IF (abs(patch_lai) >= bad_value) patch_lai = 0._r8 + + sumwt = sumwt + wt + canopy_water = canopy_water + wt * max(0._r8, patch_canopy_water) + snow_water = snow_water + wt * max(0._r8, patch_snow_water) + snow_depth = snow_depth + wt * max(0._r8, patch_snow_depth) + snow_cover = snow_cover + wt * max(0._r8, min(1._r8, patch_snow_cover)) + leaf_area_index = leaf_area_index + wt * max(0._r8, patch_lai) + + DO n = 1, nlev + IF (n < lbound(t_soisno, 1) .or. n > ubound(t_soisno, 1)) CYCLE + IF (dz_soi(n) <= 0._r8) CYCLE + IF (abs(t_soisno(n, patch)) >= bad_value) CYCLE + IF (abs(wliq_soisno(n, patch)) >= bad_value) CYCLE + IF (abs(wice_soisno(n, patch)) >= bad_value) CYCLE + + patch_liquid = max(0._r8, wliq_soisno(n, patch) / (1000._r8 * dz_soi(n))) + patch_moisture = max(0._r8, (wliq_soisno(n, patch) + wice_soisno(n, patch)) / (1000._r8 * dz_soi(n))) + soil_liquid(n) = soil_liquid(n) + wt * min(1._r8, patch_liquid) + soil_moisture(n) = soil_moisture(n) + wt * min(1._r8, patch_moisture) + soil_temperature(n) = soil_temperature(n) + wt * t_soisno(n, patch) + soil_wt(n) = soil_wt(n) + wt + ENDDO + ENDDO + + IF (sumwt <= 0._r8) THEN + canopy_water = spval + snow_water = spval + snow_depth = spval + snow_cover = spval + leaf_area_index = spval + soil_liquid(:) = spval + soil_moisture(:) = spval + soil_temperature(:) = spval + RETURN + ENDIF + + canopy_water = canopy_water / sumwt + snow_water = snow_water / sumwt + snow_depth = snow_depth / sumwt + snow_cover = snow_cover / sumwt + leaf_area_index = leaf_area_index / sumwt + + DO n = 1, nlev + IF (soil_wt(n) > 0._r8) THEN + soil_liquid(n) = soil_liquid(n) / soil_wt(n) + soil_moisture(n) = soil_moisture(n) / soil_wt(n) + soil_temperature(n) = soil_temperature(n) / soil_wt(n) + ELSE + soil_liquid(n) = spval + soil_moisture(n) = spval + soil_temperature(n) = spval + ENDIF + ENDDO + + ierr = 0 + END SUBROUTINE colm_mpas_get_element_state + + END MODULE MOD_CoLM_MPAS_Interface diff --git a/src/core_atmosphere/physics/physics_colm2024/include/define.h b/src/core_atmosphere/physics/physics_colm2024/include/define.h index 3572bc0b95..cb65a5066c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/include/define.h +++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h @@ -30,8 +30,8 @@ ! 3.1 If defined, surface data in vector is mapped to gridded data for checking. #undef SrfdataDiag -! 4. CoLM uses MPI collectives through MPAS-owned communicators. The standalone -! CoLM master/IO/worker process decomposition is disabled in MOD_SPMD_Task. +! 4. CoLM uses MPI collectives through MPAS-owned communicators. The legacy +! CoLM process-pool decomposition is disabled in MOD_SPMD_Task. #define USEMPI ! 5. Hydrological process options. @@ -103,7 +103,7 @@ #define HYPERSPECTRAL ! MPAS embeds CoLM as a local land-surface physics package on each MPAS rank. -! Reusing the CoLM standalone MPI master/IO/worker split inside MPAS leaves some +! Reusing the legacy CoLM process split inside MPAS leaves some ! ranks without patch forcing/flux arrays, so the embedded library keeps CoLM ! land state on MPAS-owned cells. MPAS also supplies broadband shortwave forcing. #define MPAS_EMBEDDED_COLM diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 index a2a018375a..ab24e3686b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -139,6 +139,7 @@ SUBROUTINE reservoir_init ( ) ENDIF +#ifndef MPAS_EMBEDDED_COLM #ifdef COLM_PARALLEL IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:p_np_compute-1)) @@ -181,6 +182,7 @@ SUBROUTINE reservoir_init ( ) allocate (resv_data_address(0)%val (numresv)) resv_data_address(0)%val = resv_global_index(1:numresv) ENDIF +#endif #endif IF (p_is_compute) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index a0b26850bf..02d3108532 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -222,33 +222,29 @@ SUBROUTINE grid_riverlake_flow (year, deltime) IF (p_is_compute) THEN - IF (numucat > 0) THEN - - allocate (is_built_resv (numucat)) - allocate (wdsrf_next (numucat)) - allocate (veloc_next (numucat)) - allocate (hflux_fc (numucat)) - allocate (mflux_fc (numucat)) - allocate (zgrad_dn (numucat)) - allocate (sum_hflux_riv (numucat)) - allocate (sum_mflux_riv (numucat)) - allocate (sum_zgrad_riv (numucat)) - allocate (ucatfilter (numucat)) - - allocate (hflux_sumups (numucat)) - allocate (mflux_sumups (numucat)) - allocate (zgrad_sumups (numucat)) - - IF (DEF_Reservoir_Method > 0) THEN - allocate (hflux_resv (numucat)) - allocate (mflux_resv (numucat)) - ENDIF - - allocate (dt_res (numrivsys)) - allocate (dt_all (numrivsys)) - + allocate (is_built_resv (numucat)) + allocate (wdsrf_next (numucat)) + allocate (veloc_next (numucat)) + allocate (hflux_fc (numucat)) + allocate (mflux_fc (numucat)) + allocate (zgrad_dn (numucat)) + allocate (sum_hflux_riv (numucat)) + allocate (sum_mflux_riv (numucat)) + allocate (sum_zgrad_riv (numucat)) + allocate (ucatfilter (numucat)) + + allocate (hflux_sumups (numucat)) + allocate (mflux_sumups (numucat)) + allocate (zgrad_sumups (numucat)) + + IF (DEF_Reservoir_Method > 0) THEN + allocate (hflux_resv (numucat)) + allocate (mflux_resv (numucat)) ENDIF + allocate (dt_res (max(1,numrivsys))) + allocate (dt_all (max(1,numrivsys))) + #ifdef CoLMDEBUG totalrnof = sum(acc_rnof_uc) totalvol_bef = 0. diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index 10a0fd907e..c2e647661a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -1275,7 +1275,6 @@ SUBROUTINE build_riverlake_network_mpas_embedded () ENDIF CALL build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) - CALL gather_mpas_embedded_ucat_addresses() CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) inpn = varsize(1) @@ -1325,27 +1324,18 @@ SUBROUTINE build_riverlake_network_mpas_embedded () #ifdef COLM_PARALLEL IF (p_is_compute) THEN - IF (numucat > 0) THEN - p_comm_rivsys = p_comm_compute - CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) - rivsys_by_multiple_procs = p_np_rivsys > 1 - ELSE - p_comm_rivsys = MPI_COMM_NULL - rivsys_by_multiple_procs = .false. - ENDIF + p_comm_rivsys = p_comm_compute + CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) + rivsys_by_multiple_procs = p_np_rivsys > 1 ENDIF #else rivsys_by_multiple_procs = .false. #endif IF (p_is_compute) THEN - IF (numucat > 0) THEN - allocate (irivsys (numucat)) - numrivsys = 1 - irivsys(:) = 1 - ELSE - numrivsys = 0 - ENDIF + allocate (irivsys (numucat)) + numrivsys = 1 + IF (numucat > 0) irivsys(:) = 1 ENDIF CALL readin_riverlake_parameter (parafile, 'topo_rivelv', rdata1d = topo_rivelv ) @@ -1517,60 +1507,6 @@ SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_g END SUBROUTINE build_mpas_embedded_local_ucats - ! --------- - SUBROUTINE gather_mpas_embedded_ucat_addresses() - - USE MOD_SPMD_Task - IMPLICIT NONE - - integer :: iworker, nrecv - - allocate (numucat_wrk (0:p_np_compute-1)) - allocate (ucat_data_address (0:p_np_compute-1)) - numucat_wrk(:) = 0 - -#ifdef COLM_PARALLEL - IF (p_is_compute .and. (.not. p_is_root)) THEN - CALL mpi_send (numucat, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numucat > 0) THEN - CALL mpi_send (ucat_ucid, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDIF - - IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 - IF (p_is_compute .and. p_address_compute(iworker) == p_iam_glb) THEN - nrecv = numucat - ELSE - CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_address_compute(iworker), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - ENDIF - - numucat_wrk(iworker) = nrecv - allocate (ucat_data_address(iworker)%val (nrecv)) - - IF (nrecv > 0) THEN - IF (p_is_compute .and. p_address_compute(iworker) == p_iam_glb) THEN - ucat_data_address(iworker)%val = ucat_ucid - ELSE - CALL mpi_recv (ucat_data_address(iworker)%val, nrecv, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF - ENDDO - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - numucat_wrk(0) = numucat - allocate (ucat_data_address(0)%val (numucat)) - IF (numucat > 0) ucat_data_address(0)%val = ucat_ucid -#endif - - END SUBROUTINE gather_mpas_embedded_ucat_addresses - - ! --------- SUBROUTINE build_mpas_embedded_local_topology (parafile) USE MOD_SPMD_Task @@ -1736,6 +1672,7 @@ SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_g #else nucpart = nucpart_local #endif + nucpart = max(1, nucpart) allocate (idmap_uc2gd (nucpart,numinpm)) allocate (area_uc2gd (nucpart,numinpm)) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 index fc05ceb3c9..69c329d91f 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 @@ -219,7 +219,7 @@ END SUBROUTINE write_gridriver_restart_mpas_embedded SUBROUTINE pnetcdf_write_real8_points(ncid, varid, index, data, ndata, varname, filename) USE mpi, only: MPI_OFFSET_KIND - USE pnetcdf, only: nfmpi_put_var1_double + USE pnetcdf, only: nf90mpi_put_var USE MOD_SPMD_Task, only: CoLM_stop IMPLICIT NONE @@ -247,7 +247,7 @@ SUBROUTINE pnetcdf_write_real8_points(ncid, varid, index, data, ndata, varname, start(1) = int(index(i), MPI_OFFSET_KIND) value = data(i) - ierr = nfmpi_put_var1_double(ncid, varid, start, value) + ierr = nf90mpi_put_var(ncid, varid, value, start=start) CALL pnetcdf_check(ierr, 'write '//trim(varname), filename) ENDDO diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 index 02e29abe97..f14cd1c143 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 @@ -187,7 +187,7 @@ SUBROUTINE spmd_assign_history_task () IMPLICIT NONE - CALL CoLM_stop('MPAS embedded CoLM does not support a standalone history MPI task.') + CALL CoLM_stop('MPAS embedded CoLM does not support a dedicated history MPI task.') END SUBROUTINE spmd_assign_history_task From 70b6dffdf15d7b7a87c73308d4919a3379bd7a75 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Thu, 2 Jul 2026 23:51:05 +0800 Subject: [PATCH 09/17] Keep embedded CoLM restart reads rank-local Embedded CoLM writes vector restart shards per MPAS rank to avoid block-file races. Reads must prefer the same rank-local shards while keeping original landdata fallback, and MPAS q2 must stay specific humidity. Constraint: MPAS cell-owned CoLM runs have no separate IO/worker pool and retain CoLM patch/PFT state internally. Rejected: Writing shared vector restart block files from all ranks | races/clobbers block files under MPAS-owned decomposition. Confidence: high Scope-risk: narrow Directive: Preserve original block-file fallback for initial landdata; rank-suffixed files are only an embedded restart path. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8 Not-tested: multi-rank runtime restart with real CoLM landdata/restart files --- .../mpas_atmphys_driver_lsm_colm2024.F | 6 +-- .../share/MOD_NetCDFVector.F90 | 45 ++++++++++--------- 2 files changed, 25 insertions(+), 26 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index c20ba4c311..bb6af112ad 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -343,11 +343,7 @@ subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) skintemp(i) = real(skin_temp, RKIND) t2m(i) = real(t2m_colm, RKIND) qsfc(i) = real(q2m_colm, RKIND) - if(q2m_colm > 0._colm_r8 .and. q2m_colm < 1._colm_r8) then - q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) - else - q2(i) = real(q2m_colm, RKIND) - endif + q2(i) = real(q2m_colm, RKIND) sfc_emiss(i) = real(emissivity, RKIND) z0(i) = real(roughness, RKIND) znt(i) = real(roughness, RKIND) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 index 7cdbca56e5..909247e61a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -93,22 +93,25 @@ SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write CALL get_filename_block (filename, iblk, jblk, fileblock) #ifdef MPAS_EMBEDDED_COLM + write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb + idot = len_trim(fileblock) + DO WHILE (idot > 0) + IF (fileblock(idot:idot) == '.') EXIT + idot = idot - 1 + ENDDO + + IF (idot > 0) THEN + fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) + ELSE + fileblock_rank = trim(fileblock) // trim(rank_suffix) + ENDIF + rank_local_file = .false. IF (present(for_write)) rank_local_file = for_write + IF ((.not. rank_local_file) .and. present(use_srcpos)) THEN + inquire(file=trim(fileblock_rank), exist=rank_local_file) + ENDIF IF (rank_local_file) THEN - write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb - idot = len_trim(fileblock) - DO WHILE (idot > 0) - IF (fileblock(idot:idot) == '.') EXIT - idot = idot - 1 - ENDDO - - IF (idot > 0) THEN - fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) - ELSE - fileblock_rank = trim(fileblock) // trim(rank_suffix) - ENDIF - fileblock = fileblock_rank IF (present(use_srcpos)) use_srcpos = .false. ENDIF @@ -191,7 +194,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -313,7 +316,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -439,7 +442,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -562,7 +565,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -686,7 +689,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -810,7 +813,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -934,7 +937,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & @@ -1059,7 +1062,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & #ifdef COLM_VECTOR_MPI_IO CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) #endif - IF (.not. any_data_exists) THEN + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN write(*,*) 'Warning : restart data '//trim(dataname) & From 2aeae566b7c84e1dc968aeac08a25dcd86086d7e Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Fri, 3 Jul 2026 00:20:27 +0800 Subject: [PATCH 10/17] Preserve MPAS explicit snow in CoLM forcing Map MPAS microphysics precipitation into CoLM without truncating snow/graupel to the rainncv amount. CoLM still receives explicit rain/snow phase through forc_rain/forc_snow while forc_prc/forc_prl retain the water-balance total used by CoLM checks. Constraint: MPAS rainncv, snowncv, and graupelncv are separate diagnostics, matching the Noah-MP MPAS driver treatment. Rejected: deriving snow solely as a fraction of rainncv | drops explicit snowncv/graupelncv water when rainncv does not include frozen precipitation. Confidence: high Scope-risk: narrow Directive: Keep MPAS precipitation amount and phase fields separate when adapting future CoLM forcing changes. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8 Not-tested: runtime integration case with real MPAS/CoLM landdata and restart files --- .../mpas_atmphys_driver_lsm_colm2024.F | 34 ++++++++++--------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index bb6af112ad..c470653c0d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -171,7 +171,7 @@ subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_phys integer:: i, k integer:: ierr real(kind=colm_r8):: aerdep(14) - real(kind=colm_r8):: dt, grid_snow, hgt, oro, pbot, psrf, prc, prl, qair, rain, rhoair, snow, & + real(kind=colm_r8):: dt, micro_rain, micro_snow, hgt, oro, pbot, psrf, prc, prl, qair, rain, rhoair, snow, & solld, soll, solsd, sols, spectral_sw, swdir, swdif, tair, uair, vair real(kind=RKIND):: qv_cell real(kind=RKIND),dimension(:),pointer:: glw, swddir, swddif, swvisdir, swvisdif, swnirdir, swnirdif @@ -228,21 +228,23 @@ subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_phys prc = 0._colm_r8 prl = 0._colm_r8 rain = 0._colm_r8 - snow = 0._colm_r8 - - if(config_convection_scheme .ne. 'off') then - prc = max(0._colm_r8, real(raincv(i), colm_r8) / dt) - rain = rain + prc - endif - if(config_microp_scheme .ne. 'off') then - prl = max(0._colm_r8, real(rainncv(i), colm_r8) / dt) - grid_snow = max(0._colm_r8, real(snowncv(i) + graupelncv(i), colm_r8) / dt) - if(grid_snow <= 0._colm_r8 .and. sr(i) > 0._RKIND) then - grid_snow = prl * min(1._colm_r8, real(sr(i), colm_r8)) - endif - snow = min(prl, grid_snow) - rain = rain + max(0._colm_r8, prl - snow) - endif + snow = 0._colm_r8 + + if(config_convection_scheme .ne. 'off') then + prc = max(0._colm_r8, real(raincv(i), colm_r8) / dt) + rain = rain + prc + endif + if(config_microp_scheme .ne. 'off') then + micro_rain = max(0._colm_r8, real(rainncv(i), colm_r8) / dt) + micro_snow = max(0._colm_r8, real(snowncv(i) + graupelncv(i), colm_r8) / dt) + if(micro_snow <= 0._colm_r8 .and. sr(i) > 0._RKIND) then + micro_snow = micro_rain * min(1._colm_r8, real(sr(i), colm_r8)) + micro_rain = max(0._colm_r8, micro_rain - micro_snow) + endif + prl = micro_rain + micro_snow + rain = rain + micro_rain + snow = snow + micro_snow + endif swdir = max(0._colm_r8, real(swddir(i), colm_r8)) swdif = max(0._colm_r8, real(swddif(i), colm_r8)) From 2a8d24cc8e7a0d32a39cef0891444dd75b433d91 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Fri, 3 Jul 2026 10:01:03 +0800 Subject: [PATCH 11/17] Embed CoLM on MPAS-owned cell subsets CoLM now follows the MPAS block/cell decomposition while keeping patch and PFT state internal to CoLM, with cell-level flux/state exchange through the MPAS physics driver. Constraint: MPAS cell == CoLM element, and CoLM master/io/worker process pools are not valid inside MPAS. Rejected: standalone global CoLM landdata loading | it can deadlock or replicate global state under MPAS ranks. Confidence: high Scope-risk: broad Directive: Do not reintroduce standalone CoLM preprocess/make-surface paths or rank-specific IO-worker process ownership in MPAS embedded mode. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8 Not-tested: runtime smoke test with real CoLM landdata/restart/river inputs; restart portability across changed MPI decompositions. --- src/core_atmosphere/mpas_atm_core.F | 2 +- .../physics/mpas_atmphys_driver.F | 229 ++++++++++++- .../mpas_atmphys_driver_lsm_colm2024.F | 273 ++++++++++++---- .../physics/mpas_atmphys_init.F | 6 +- .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 305 ++++++++++++------ .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 81 ++++- .../physics_colm2024/main/MOD_Thermal.F90 | 26 +- .../main/MOD_Vars_TimeVariables.F90 | 36 ++- .../physics_colm2024/share/MOD_Mesh.F90 | 4 + .../share/MOD_NetCDFVector.F90 | 150 +++++---- .../share/MOD_SrfdataRestart.F90 | 15 + 11 files changed, 853 insertions(+), 274 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index eef1951e36..792d9f561d 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -591,7 +591,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call physics_run_init(block % configs, mesh, state, clock, stream_manager) !initialization of all physics: - call physics_init(dminfo, stream_manager, clock, block % configs, mesh, diag, tend, tend_physics, state, 1, & + call physics_init(dminfo, stream_manager, clock, block, block % configs, mesh, diag, tend, tend_physics, state, 1, & diag_physics, diag_physics_noahmp, ngw_input, atm_input, sfc_input, output_noahmp) endif #endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index faf2b9c1bc..1538930736 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -15,7 +15,7 @@ module mpas_atmphys_driver use mpas_atmphys_driver_gwdo use mpas_atmphys_driver_lsm use mpas_atmphys_driver_lsm_noahmp - use mpas_atmphys_driver_lsm_colm2024,only: driver_lsm_colm2024 + use mpas_atmphys_driver_lsm_colm2024,only: push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024 use mpas_atmphys_driver_pbl use mpas_atmphys_driver_radiation_lw use mpas_atmphys_driver_radiation_sw @@ -173,15 +173,213 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_config(domain%configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(domain%configs,'config_oml1d' ,config_oml1d ) - if(config_convection_scheme .ne. 'off' .or. & - config_lsm_scheme .ne. 'off' .or. & - config_pbl_scheme .ne. 'off' .or. & - config_radt_lw_scheme .ne. 'off' .or. & - config_radt_sw_scheme .ne. 'off' .or. & - config_sfclayer_scheme .ne. 'off') then - - block => domain % blocklist - do while(associated(block)) + if(config_convection_scheme .ne. 'off' .or. & + config_lsm_scheme .ne. 'off' .or. & + config_pbl_scheme .ne. 'off' .or. & + config_radt_lw_scheme .ne. 'off' .or. & + config_radt_sw_scheme .ne. 'off' .or. & + config_sfclayer_scheme .ne. 'off') then + + if(config_lsm_scheme == 'sf_colm2024') then + + block => domain % blocklist + do while(associated(block)) + + call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) + call mpas_pool_get_subpool(block%structs,'state' ,state ) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) + call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) + call mpas_pool_get_subpool(block%structs,'output_noahmp' ,output_noahmp ) + call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) + call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'ngw_input' ,ngw_input ) + call mpas_pool_get_subpool(block%structs,'tend_physics' ,tend_physics ) + + call mpas_pool_get_dimension(block%dimensions,'nThreads',nThreads) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadStart',cellSolveThreadStart) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadEnd',cellSolveThreadEnd) + + call allocate_forall_physics(block%configs) + time_lev = 1 + + !$OMP PARALLEL DO + do thread=1,nThreads + call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + + if(l_radtlw .or. l_radtsw) then + call allocate_cloudiness + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_cloudiness(block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + endif + + if(l_radtsw) then + time_lev = 1 + call allocate_radiation_sw(block%configs,xtime_s) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_radiation_sw(itimestep,block%configs,mesh,state,time_lev,diag_physics, & + atm_input,sfc_input,tend_physics,xtime_s, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + endif + + if(l_radtlw) then + time_lev = 1 + call allocate_radiation_lw(block%configs,xtime_s) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_radiation_lw(xtime_s,block%configs,mesh,state,time_lev,diag_physics, & + atm_input,sfc_input,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + endif + + if(config_bucket_update /= 'none' .and. config_bucket_radt .gt. 0._RKIND) then + !$OMP PARALLEL DO + do thread=1,nThreads + call update_radiation_diagnostics(block%configs,mesh,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + endif + + if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') & + call deallocate_cloudiness + if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw(block%configs) + if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw(block%configs) + + if(config_sfclayer_scheme .ne. 'off') then + call allocate_sfclayer(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_sfclayer(block%configs) + endif + + if(config_oml1d) call driver_oml1d(block%configs,mesh,diag,diag_physics,sfc_input) + + call push_lsm_colm2024(block,block%configs,mesh,state,time_lev,diag,diag_physics, & + sfc_input,itimestep,cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) + + call deallocate_forall_physics(block%configs) + block => block % next + end do + + call step_lsm_colm2024() + + block => domain % blocklist + do while(associated(block)) + + call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) + call mpas_pool_get_subpool(block%structs,'state' ,state ) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) + call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) + call mpas_pool_get_subpool(block%structs,'output_noahmp' ,output_noahmp ) + call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'ngw_input' ,ngw_input ) + call mpas_pool_get_subpool(block%structs,'tend_physics' ,tend_physics ) + + call mpas_pool_get_dimension(block%dimensions,'nThreads',nThreads) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadStart',cellSolveThreadStart) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadEnd',cellSolveThreadEnd) + + call allocate_forall_physics(block%configs) + time_lev = 1 + + !$OMP PARALLEL DO + do thread=1,nThreads + call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + + call pull_lsm_colm2024(block,diag_physics,sfc_input,cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) + + call allocate_seaice(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_seaice(block%configs,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo + !$OMP END PARALLEL DO + call deallocate_seaice(block%configs) + + !$OMP PARALLEL DO + do thread=1,nThreads + call atmphys_sfc_diagnostics(block%configs,mesh,diag,diag_physics,sfc_input,output_noahmp, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo + !$OMP END PARALLEL DO + + if(config_pbl_scheme .ne. 'off' .and. config_sfclayer_scheme .ne. 'off') then + call allocate_pbl(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_pbl(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_pbl(block%configs) + endif + + if(config_gwdo_scheme .ne. 'off') then + call allocate_gwdo(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_gwdo(itimestep,block%configs,mesh,sfc_input,ngw_input,diag_physics, & + tend_physics,cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_gwdo(block%configs) + endif + + !$OMP PARALLEL DO + do thread=1,nThreads + call update_convection_step1(block%configs,diag_physics,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + if(l_conv) then + call allocate_convection(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_convection(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_convection(block%configs) + endif + if(config_convection_scheme .ne. 'off') then + !$OMP PARALLEL DO + do thread=1,nThreads + call update_convection_step2(block%configs,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + end if + + call deallocate_forall_physics(block%configs) + block => block % next + end do + + else + + block => domain % blocklist + do while(associated(block)) call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) call mpas_pool_get_subpool(block%structs,'state' ,state ) @@ -298,11 +496,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) diag_physics_noahmp,output_noahmp,sfc_input,itimestep, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) enddo - elseif(config_lsm_scheme == 'sf_colm2024') then - call driver_lsm_colm2024(block%configs,mesh,state,time_lev,diag,diag_physics, & - sfc_input,itimestep,cellSolveThreadStart(1), & - cellSolveThreadEnd(nThreads)) - endif + endif call allocate_seaice(block%configs) !$OMP PARALLEL DO @@ -377,9 +571,10 @@ subroutine physics_driver(domain,itimestep,xtime_s) call deallocate_forall_physics(block%configs) block => block % next - end do + end do + endif - endif + endif call mpas_timer_stop('physics driver') diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index c470653c0d..9ab42b31d2 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -8,7 +8,7 @@ !================================================================================================================= module mpas_atmphys_driver_lsm_colm2024 use mpas_kind_types - use mpas_derived_types, only: dm_info + use mpas_derived_types, only: block_type, dm_info use mpas_pool_routines use mpas_atmphys_constants, only: R_d, R_v @@ -27,48 +27,88 @@ module mpas_atmphys_driver_lsm_colm2024 implicit none private - public :: init_lsm_colm2024, driver_lsm_colm2024, finalize_lsm_colm2024 + public :: init_lsm_colm2024, push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024, finalize_lsm_colm2024 logical, save :: colm_first_step = .true. #ifdef MPAS_COLM2024 - integer, allocatable, save :: colm_element_for_cell(:) + type colm_block_map_type + integer :: local_block_id = -1 + integer, allocatable :: element_for_cell(:) + type(colm_block_map_type), pointer :: next => null() + end type colm_block_map_type + + type(colm_block_map_type), pointer, save :: colm_block_maps => null() + logical, save :: colm_initialized = .false. #endif contains !================================================================================================================= - subroutine init_lsm_colm2024(dminfo,configs,mesh,diag_physics,sfc_input) + subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) !================================================================================================================= type(dm_info),intent(in):: dminfo type(mpas_pool_type),intent(in):: configs - type(mpas_pool_type),intent(in):: mesh + type(block_type),intent(in):: block type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: sfc_input #ifdef MPAS_COLM2024 logical :: colm_ready integer :: colm_ierr integer :: colm_mpas_comm - integer :: colm_patch_count + integer :: colm_patch_count + integer :: block_cells + integer :: n_mpas_cells + integer :: offset character(len=StrKIND),pointer:: config_colm2024_namelist integer,pointer:: nCellsSolve integer,dimension(:),pointer:: indexToCellID - real(kind=RKIND),dimension(:),pointer:: latCell, lonCell + integer,allocatable:: cell_to_element(:), mpas_cell_id(:) + type(block_type),pointer:: block_cursor + type(colm_block_map_type),pointer:: block_map + type(mpas_pool_type),pointer:: block_mesh #endif #ifdef MPAS_COLM2024 call mpas_pool_get_config(configs,'config_colm2024_namelist',config_colm2024_namelist) - if(trim(config_colm2024_namelist) == 'none' .or. trim(config_colm2024_namelist) == '') then - call physics_error_fatal("config_lsm_scheme='sf_colm2024' requires config_colm2024_namelist.") - endif + if(trim(config_colm2024_namelist) == 'none' .or. trim(config_colm2024_namelist) == '') then + call physics_error_fatal("config_lsm_scheme='sf_colm2024' requires config_colm2024_namelist.") + endif + + if(colm_initialized) return + if(associated(block % next)) return + if(.not. associated(block % domain)) call physics_error_fatal("CoLM2024 MPAS block is missing its owning domain.") + + call colm2024_free_block_maps() + + n_mpas_cells = 0 + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + n_mpas_cells = n_mpas_cells + nCellsSolve + block_cursor => block_cursor % next + enddo + if(n_mpas_cells < 1) call physics_error_fatal("CoLM2024 MPAS embedded mode requires at least one solve cell " // & + "on every MPAS rank; reduce MPI ranks or repartition.") + + allocate(mpas_cell_id(n_mpas_cells), cell_to_element(n_mpas_cells)) - call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) - call mpas_pool_get_array(mesh,'latCell',latCell) - call mpas_pool_get_array(mesh,'lonCell',lonCell) - call mpas_pool_get_array(mesh,'indexToCellID',indexToCellID) - if(allocated(colm_element_for_cell)) deallocate(colm_element_for_cell) - allocate(colm_element_for_cell(size(latCell))) - colm_element_for_cell(:) = 0 + offset = 0 + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_array(block_mesh,'indexToCellID',indexToCellID) + + block_cells = nCellsSolve + if(block_cells > 0) then + mpas_cell_id(offset+1:offset+block_cells) = indexToCellID(1:block_cells) + endif + call colm2024_add_block_map(block_cursor % localBlockID, size(indexToCellID)) + offset = offset + block_cells + block_cursor => block_cursor % next + enddo #ifdef MPAS_USE_MPI_F08 colm_mpas_comm = dminfo % comm % mpi_val @@ -78,27 +118,41 @@ subroutine init_lsm_colm2024(dminfo,configs,mesh,diag_physics,sfc_input) call colm_mpas_initialize_from_namelist(trim(config_colm2024_namelist), colm_ierr, & mpas_comm=colm_mpas_comm, & - mpas_lon_rad=real(lonCell(1:nCellsSolve), colm_r8), & - mpas_lat_rad=real(latCell(1:nCellsSolve), colm_r8), & - mpas_cell_id=indexToCellID(1:nCellsSolve), & - n_mpas_cells=nCellsSolve, & - cell_to_element=colm_element_for_cell(1:nCellsSolve)) + mpas_cell_id=mpas_cell_id, & + n_mpas_cells=n_mpas_cells, & + cell_to_element=cell_to_element) if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 initialization from config_colm2024_namelist failed.") + offset = 0 + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + call colm2024_find_block_map(block_cursor % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS block map was not created.") + block_map % element_for_cell(:) = 0 + block_cells = nCellsSolve + if(block_cells > 0) block_map % element_for_cell(1:block_cells) = cell_to_element(offset+1:offset+block_cells) + offset = offset + block_cells + block_cursor => block_cursor % next + enddo + call colm_mpas_ready(colm_ready, colm_patch_count) if(.not. colm_ready) call colm2024_adapter_not_ready - colm_first_step = .true. + colm_first_step = .true. + colm_initialized = .true. #else - call colm2024_adapter_not_built + call colm2024_adapter_not_built #endif end subroutine init_lsm_colm2024 !================================================================================================================= - subroutine driver_lsm_colm2024(configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) + subroutine push_lsm_colm2024(block,configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) !================================================================================================================= + type(block_type),intent(in):: block type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state @@ -110,52 +164,159 @@ subroutine driver_lsm_colm2024(configs,mesh,state,time_lev,diag,diag_physics,sfc integer,intent(in):: its,ite #ifdef MPAS_COLM2024 logical :: colm_ready - integer :: colm_ierr integer :: colm_patch_count - integer :: colm_idate(3) + type(colm_block_map_type),pointer:: block_map #endif #ifdef MPAS_COLM2024 call colm_mpas_ready(colm_ready, colm_patch_count) if(.not. colm_ready) call colm2024_adapter_not_ready - if(.not. allocated(colm_element_for_cell)) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is not initialized.") - if(size(colm_element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & - "than the MPAS cell range.") + call colm2024_find_block_map(block % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is not initialized.") + if(size(block_map % element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & + "than the MPAS cell range.") - call colm2024_push_mpas_forcing(configs, mesh, state, time_lev, diag, diag_physics, sfc_input, itimestep, its, ite) + call colm2024_push_mpas_forcing(block_map % element_for_cell, configs, mesh, state, time_lev, diag, diag_physics, & + sfc_input, itimestep, its, ite) +#else + call colm2024_adapter_not_built +#endif + end subroutine push_lsm_colm2024 + +!================================================================================================================= + subroutine step_lsm_colm2024() +!================================================================================================================= + +#ifdef MPAS_COLM2024 + logical :: colm_ready + integer :: colm_ierr + integer :: colm_patch_count + integer :: colm_idate(3) + + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready colm_idate(1) = year colm_idate(2) = int(curr_julday) + 1 colm_idate(3) = nint((curr_julday - real(int(curr_julday), RKIND)) * 86400._RKIND) call colm_mpas_step(colm_idate, real(dt_pbl, colm_r8), colm_first_step, .true., .false., colm_ierr) if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 driver returned before completing a land-surface step.") - - call colm2024_pull_mpas_surface(diag_physics, sfc_input, real(dt_pbl, colm_r8), its, ite) colm_first_step = .false. #else call colm2024_adapter_not_built #endif - end subroutine driver_lsm_colm2024 + end subroutine step_lsm_colm2024 + +!================================================================================================================= + subroutine pull_lsm_colm2024(block,diag_physics,sfc_input,its,ite) +!================================================================================================================= + + type(block_type),intent(in):: block + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + integer,intent(in):: its,ite +#ifdef MPAS_COLM2024 + logical :: colm_ready + integer :: colm_patch_count + type(colm_block_map_type),pointer:: block_map + + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + call colm2024_find_block_map(block % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is not initialized.") + if(size(block_map % element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & + "than the MPAS cell range.") + + call colm2024_pull_mpas_surface(block_map % element_for_cell, diag_physics, sfc_input, real(dt_pbl, colm_r8), its, ite) +#else + call colm2024_adapter_not_built +#endif + + end subroutine pull_lsm_colm2024 !================================================================================================================= subroutine finalize_lsm_colm2024() !================================================================================================================= #ifdef MPAS_COLM2024 - integer :: colm_ierr - - call colm_mpas_finalize(colm_ierr) - if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.") + integer :: colm_ierr + + if(.not. colm_initialized) return + call colm_mpas_finalize(colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.") + call colm2024_free_block_maps() + colm_first_step = .true. + colm_initialized = .false. #endif end subroutine finalize_lsm_colm2024 #ifdef MPAS_COLM2024 !================================================================================================================= - subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) + subroutine colm2024_add_block_map(local_block_id, nCells) +!================================================================================================================= + + integer,intent(in):: local_block_id + integer,intent(in):: nCells + type(colm_block_map_type),pointer:: block_map, cursor + + allocate(block_map) + block_map % local_block_id = local_block_id + allocate(block_map % element_for_cell(nCells)) + block_map % element_for_cell(:) = 0 + nullify(block_map % next) + + if(.not. associated(colm_block_maps)) then + colm_block_maps => block_map + else + cursor => colm_block_maps + do while(associated(cursor % next)) + cursor => cursor % next + enddo + cursor % next => block_map + endif + + end subroutine colm2024_add_block_map + +!================================================================================================================= + subroutine colm2024_find_block_map(local_block_id, block_map) +!================================================================================================================= + + integer,intent(in):: local_block_id + type(colm_block_map_type),pointer:: block_map + + block_map => colm_block_maps + do while(associated(block_map)) + if(block_map % local_block_id == local_block_id) return + block_map => block_map % next + enddo + nullify(block_map) + + end subroutine colm2024_find_block_map + +!================================================================================================================= + subroutine colm2024_free_block_maps() +!================================================================================================================= + + type(colm_block_map_type),pointer:: block_map, next_map + + block_map => colm_block_maps + do while(associated(block_map)) + next_map => block_map % next + if(allocated(block_map % element_for_cell)) deallocate(block_map % element_for_cell) + deallocate(block_map) + block_map => next_map + enddo + nullify(colm_block_maps) + + end subroutine colm2024_free_block_maps + +!================================================================================================================= + subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) !================================================================================================================= + integer,dimension(:),intent(in):: element_for_cell type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state @@ -213,7 +374,7 @@ subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_phys k = lbound(theta_m, 1) do i = its,ite - if(colm_element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + if(element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") psrf = real(surface_pressure(i), colm_r8) pbot = real(pressure_b(k,i) + pressure_p(k,i), colm_r8) @@ -263,7 +424,7 @@ subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_phys if(xland(i) >= 1.5_RKIND) oro = 0._colm_r8 if(xice(i) >= xice_threshold) oro = 2._colm_r8 - call colm_mpas_set_element_forcing(colm_element_for_cell(i), psrf * 420.e-6_colm_r8, & + call colm_mpas_set_element_forcing(element_for_cell(i), psrf * 420.e-6_colm_r8, & psrf * 0.209_colm_r8, uair, vair, tair, qair, & prc, prl, rain, snow, psrf, pbot, & sols, soll, solsd, solld, & @@ -275,9 +436,10 @@ subroutine colm2024_push_mpas_forcing(configs,mesh,state,time_lev,diag,diag_phys end subroutine colm2024_push_mpas_forcing !================================================================================================================= - subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) + subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt,its,ite) !================================================================================================================= + integer,dimension(:),intent(in):: element_for_cell type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: sfc_input real(kind=colm_r8),intent(in):: dt @@ -286,7 +448,7 @@ subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) integer:: i, ns, nlev, nvalid_soil integer:: ierr real(kind=colm_r8):: sensible, latent, evaporation, ground_heat, runoff - real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm + real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, qsfc_colm real(kind=colm_r8):: emissivity, roughness, albedo real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index real(kind=colm_r8):: soil_moisture_sum @@ -326,26 +488,27 @@ subroutine colm2024_pull_mpas_surface(diag_physics,sfc_input,dt,its,ite) allocate(soil_liquid(nlev), soil_moisture(nlev), soil_temperature(nlev)) do i = its,ite - if(colm_element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + if(element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") - call colm_mpas_get_element_surface(colm_element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & - surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & - emissivity, roughness, albedo, ierr) + call colm_mpas_get_element_surface(element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & + qsfc_colm, emissivity, roughness, albedo, ierr) if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.") - call colm_mpas_get_element_state(colm_element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, & + call colm_mpas_get_element_state(element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, & leaf_area_index, soil_liquid, soil_moisture, soil_temperature, ierr) if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface state.") - hfx(i) = real(sensible, RKIND) - lh(i) = real(latent, RKIND) - qfx(i) = real(evaporation, RKIND) - grdflx(i) = real(ground_heat, RKIND) - sfcrunoff(i) = real(surface_runoff * dt, RKIND) + hfx(i) = real(sensible, RKIND) + lh(i) = real(latent, RKIND) + qfx(i) = real(evaporation, RKIND) + ! CoLM fgrnd and MPAS/Noah-MP grdflx are positive into soil/snow. + grdflx(i) = real(ground_heat, RKIND) + sfcrunoff(i) = real(surface_runoff * dt, RKIND) udrunoff(i) = real(subsurface_runoff * dt, RKIND) skintemp(i) = real(skin_temp, RKIND) t2m(i) = real(t2m_colm, RKIND) - qsfc(i) = real(q2m_colm, RKIND) - q2(i) = real(q2m_colm, RKIND) + qsfc(i) = real(qsfc_colm, RKIND) + q2(i) = real(q2m_colm, RKIND) sfc_emiss(i) = real(emissivity, RKIND) z0(i) = real(roughness, RKIND) znt(i) = real(roughness, RKIND) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 4d4109b7c5..431442c19b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -81,15 +81,17 @@ module mpas_atmphys_init !================================================================================================================= - subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_physics,state,time_lev,diag_physics, & + subroutine physics_init(dminfo,stream_manager,clock,block,configs,mesh,diag,tend,tend_physics,state,time_lev,diag_physics, & diag_physics_noahmp,ngw_input,atm_input,sfc_input,output_noahmp) !================================================================================================================= use mpas_stream_manager +use mpas_derived_types, only: block_type !input arguments: type(dm_info),intent(in):: dminfo type(MPAS_streamManager_type),intent(inout):: stream_manager + type(block_type),intent(in):: block type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: configs type(MPAS_Clock_type),intent(in):: clock @@ -422,7 +424,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ elseif(config_lsm_scheme .eq. 'sf_noahmp') then call init_lsm_noahmp(configs,mesh,clock,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) elseif(config_lsm_scheme .eq. 'sf_colm2024') then - call init_lsm_colm2024(dminfo,configs,mesh,diag_physics,sfc_input) + call init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) endif endif diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index cf610817ed..20d22eded1 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -14,8 +14,8 @@ MODULE MOD_CoLM_MPAS_Interface #endif USE MOD_Vars_1DFluxes, only: oroflag, fsena, lfevpa, fevpa, fgrnd, rnof, rsur, rsub USE MOD_Vars_TimeInvariants, only: patchmask - USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, emis, z0m, alb, & - ldew, scv, snowdp, fsno, lai, t_soisno, wliq_soisno, wice_soisno + USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, qsfc, emis, z0m, alb, & + ldew, scv, snowdp, fsno, lai, t_soisno, wliq_soisno, wice_soisno USE MOD_TimeManager, only: timestamp IMPLICIT NONE @@ -53,14 +53,14 @@ END SUBROUTINE CoLMDRIVER CONTAINS - SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_lon_rad, mpas_lat_rad, & - mpas_cell_id, n_mpas_cells, cell_to_element) + SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell_id, & + n_mpas_cells, cell_to_element) USE MOD_Namelist, only: read_namelist, DEF_CASE_NAME, DEF_dir_landdata, & DEF_dir_restart, DEF_LC_YEAR, DEF_simulation_time, DEF_USE_SNICAR, & DEF_file_snowoptics, DEF_file_snowaging, DEF_forcing, DEF_Reservoir_Method, & DEF_WRST_FREQ, DEF_HIST_FREQ, DEF_HIST_WriteBack USE MOD_Vars_Global, only: Init_GlobalVars - USE MOD_SPMD_Task, only: spmd_init + USE MOD_SPMD_Task, only: spmd_init, p_is_root USE MOD_Const_LC, only: Init_LC_Const USE MOD_Const_PFT, only: Init_PFT_Const, rho_p, tau_p USE MOD_TimeManager, only: initimetype, monthday2julian, adj2begin, adj2end @@ -91,8 +91,6 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_lon_ character(len=*), intent(in) :: nlfile integer, intent(out) :: ierr integer, intent(in), optional :: mpas_comm - real(r8), intent(in), optional :: mpas_lon_rad(:) - real(r8), intent(in), optional :: mpas_lat_rad(:) integer, intent(in), optional :: mpas_cell_id(:) integer, intent(in), optional :: n_mpas_cells integer, intent(out), optional :: cell_to_element(:) @@ -162,16 +160,18 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_lon_ CALL Init_PFT_Const n_mpas = 0 +#ifdef MPAS_EMBEDDED_COLM + IF (.not. present(n_mpas_cells)) THEN + IF (p_is_root) write(*,'(A)') 'CoLM2024 MPAS embedded initialization requires MPAS-owned cell ids.' + RETURN + ENDIF +#endif IF (present(n_mpas_cells)) THEN - IF (.not. present(mpas_lon_rad)) RETURN - IF (.not. present(mpas_lat_rad)) RETURN IF (.not. present(mpas_cell_id)) RETURN IF (.not. present(cell_to_element)) RETURN n_mpas = n_mpas_cells IF (n_mpas < 1) RETURN - IF (size(mpas_lon_rad) < n_mpas) RETURN - IF (size(mpas_lat_rad) < n_mpas) RETURN IF (size(mpas_cell_id) < n_mpas) RETURN IF (size(cell_to_element) < n_mpas) RETURN @@ -185,7 +185,7 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_lon_ CALL gblock%load_from_file(dir_landdata) IF (n_mpas > 0) THEN - CALL colm_mpas_claim_owned_blocks(mpas_lon_rad, mpas_lat_rad, n_mpas, ierr) + CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, n_mpas, ierr) IF (ierr /= 0) RETURN CALL mesh_load_from_file(dir_landdata, lc_year, subset_eindex=mpas_cell_id_i8) @@ -300,46 +300,96 @@ SUBROUTINE colm_mpas_check_embedded_io(ierr) ENDIF END SUBROUTINE colm_mpas_check_embedded_io - SUBROUTINE colm_mpas_claim_owned_blocks(mpas_lon_rad, mpas_lat_rad, n_mpas_cells, ierr) - USE MOD_Block, only: gblock + SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_mpas_cells, ierr) + USE MOD_Block, only: gblock, get_filename_block USE MOD_SPMD_Task, only: p_iam_glb - USE MOD_Utils, only: normalize_longitude, find_nearest_south, find_nearest_west - real(r8), intent(in) :: mpas_lon_rad(:) - real(r8), intent(in) :: mpas_lat_rad(:) + USE MOD_NetCDFSerial, only: ncio_read_serial + USE MOD_Utils, only: quicksort, find_in_sorted_list1 + character(len=*), intent(in) :: dir_landdata + integer, intent(in) :: lc_year + integer*8, intent(in) :: mpas_cell_id(:) integer, intent(in) :: n_mpas_cells integer, intent(out) :: ierr logical, allocatable :: keep_block(:,:) + logical, allocatable :: found_element(:) + logical :: fexists integer :: i + integer :: ie integer :: iblk integer :: jblk integer :: iblkme - real(r8) :: lon_deg - real(r8) :: lat_deg - real(r8), parameter :: rad_to_deg = 57.295779513082320876798154814105_r8 + integer :: match + character(len=256) :: filename + character(len=256) :: fileblock + character(len=256) :: cyear + integer, allocatable :: order(:) + integer*8, allocatable :: elmindx(:) + integer*8, allocatable :: sorted_cell_id(:) ierr = 1 IF (n_mpas_cells < 1) RETURN IF (.not. allocated(gblock%pio)) RETURN IF (.not. allocated(gblock%lon_w)) RETURN IF (.not. allocated(gblock%lat_s)) RETURN + IF (size(mpas_cell_id) < n_mpas_cells) RETURN allocate(keep_block(gblock%nxblk, gblock%nyblk)) + allocate(found_element(n_mpas_cells)) + allocate(sorted_cell_id(n_mpas_cells)) keep_block = .false. + found_element = .false. + sorted_cell_id = mpas_cell_id(1:n_mpas_cells) + + IF (n_mpas_cells > 1) THEN + allocate(order(n_mpas_cells)) + order = (/ (i, i = 1, n_mpas_cells) /) + CALL quicksort(n_mpas_cells, sorted_cell_id, order) + deallocate(order) + + DO i = 2, n_mpas_cells + IF (sorted_cell_id(i) == sorted_cell_id(i-1)) THEN + write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded duplicate cell/eindex on rank ', & + p_iam_glb, ': ', sorted_cell_id(i) + deallocate(keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + ENDDO + ENDIF - DO i = 1, n_mpas_cells - lon_deg = mpas_lon_rad(i) * rad_to_deg - lat_deg = mpas_lat_rad(i) * rad_to_deg - CALL normalize_longitude(lon_deg) - lat_deg = max(-90._r8, min(90._r8, lat_deg)) - - iblk = find_nearest_west(lon_deg, gblock%nxblk, gblock%lon_w) - jblk = find_nearest_south(lat_deg, gblock%nyblk, gblock%lat_s) - IF (iblk >= 1 .and. iblk <= gblock%nxblk .and. jblk >= 1 .and. jblk <= gblock%nyblk) THEN - keep_block(iblk,jblk) = .true. - ENDIF + write(cyear,'(i4.4)') lc_year + filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' + + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + CALL get_filename_block(filename, iblk, jblk, fileblock) + inquire(file=trim(fileblock), exist=fexists) + IF (.not. fexists) CYCLE + + CALL ncio_read_serial(fileblock, 'elmindex', elmindx) + DO ie = 1, size(elmindx) + match = find_in_sorted_list1(elmindx(ie), n_mpas_cells, sorted_cell_id) + IF (match > 0) THEN + keep_block(iblk,jblk) = .true. + found_element(match) = .true. + ENDIF + ENDDO + IF (allocated(elmindx)) deallocate(elmindx) + ENDDO ENDDO + IF (count(found_element) /= n_mpas_cells) THEN + DO i = 1, n_mpas_cells + IF (.not. found_element(i)) THEN + write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded mesh is missing cell/eindex on rank ', & + p_iam_glb, ': ', sorted_cell_id(i) + EXIT + ENDIF + ENDDO + deallocate(keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + gblock%pio(:,:) = -1 WHERE (keep_block) gblock%pio = p_iam_glb @@ -349,7 +399,8 @@ SUBROUTINE colm_mpas_claim_owned_blocks(mpas_lon_rad, mpas_lat_rad, n_mpas_cells IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) gblock%nblkme = count(keep_block) IF (gblock%nblkme < 1) THEN - deallocate(keep_block) + write(*,'(A,I0)') 'CoLM2024 MPAS embedded found no local mesh blocks for rank ', p_iam_glb + deallocate(keep_block, found_element, sorted_cell_id) RETURN ENDIF @@ -366,7 +417,7 @@ SUBROUTINE colm_mpas_claim_owned_blocks(mpas_lon_rad, mpas_lat_rad, n_mpas_cells ENDDO ENDDO - deallocate(keep_block) + deallocate(keep_block, found_element, sorted_cell_id) ierr = 0 END SUBROUTINE colm_mpas_claim_owned_blocks @@ -553,7 +604,7 @@ SUBROUTINE colm_mpas_ready(ready, patch_count) integer, intent(out), optional :: patch_count ready = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) & - .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subfrc) + .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) IF (present(patch_count)) THEN IF (allocated(oroflag)) THEN patch_count = size(oroflag) @@ -635,6 +686,7 @@ SUBROUTINE colm_mpas_set_element_forcing(element, pco2m, po2m, us, vs, tair, qai ierr = 1 IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN IF (.not. allocated(elm_patch%subfrc)) RETURN IF (element < 1 .or. element > size(elm_patch%substt)) RETURN @@ -762,14 +814,15 @@ LOGICAL FUNCTION colm_mpas_timestamp_reached(tstamp, target) ENDIF END FUNCTION colm_mpas_timestamp_reached - SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_heat, runoff, & - surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & - emissivity, roughness, albedo, ierr) - integer, intent(in) :: patch - real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff - real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m - real(r8), intent(out) :: emissivity, roughness, albedo - integer, intent(out) :: ierr + SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & + surface_humidity, emissivity, roughness, albedo, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff + real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: surface_humidity + real(r8), intent(out) :: emissivity, roughness, albedo + integer, intent(out) :: ierr ierr = 1 sensible = spval @@ -779,15 +832,39 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he runoff = spval surface_runoff = spval subsurface_runoff = spval - skin_temp = spval - t2m = spval - q2m = spval - emissivity = spval - roughness = spval + skin_temp = spval + t2m = spval + q2m = spval + surface_humidity = spval + emissivity = spval + roughness = spval albedo = spval IF (.not. allocated(fsena)) RETURN - IF (patch < 1 .or. patch > size(fsena)) RETURN + IF (.not. allocated(lfevpa)) RETURN + IF (.not. allocated(fevpa)) RETURN + IF (.not. allocated(fgrnd)) RETURN + IF (.not. allocated(rnof)) RETURN + IF (.not. allocated(rsur)) RETURN + IF (.not. allocated(rsub)) RETURN + IF (.not. allocated(t_grnd)) RETURN + IF (.not. allocated(tref)) RETURN + IF (.not. allocated(qref)) RETURN + IF (.not. allocated(emis)) RETURN + IF (.not. allocated(z0m)) RETURN + IF (patch < 1) RETURN + IF (patch > size(fsena)) RETURN + IF (patch > size(lfevpa)) RETURN + IF (patch > size(fevpa)) RETURN + IF (patch > size(fgrnd)) RETURN + IF (patch > size(rnof)) RETURN + IF (patch > size(rsur)) RETURN + IF (patch > size(rsub)) RETURN + IF (patch > size(t_grnd)) RETURN + IF (patch > size(tref)) RETURN + IF (patch > size(qref)) RETURN + IF (patch > size(emis)) RETURN + IF (patch > size(z0m)) RETURN sensible = fsena(patch) latent = lfevpa(patch) @@ -796,25 +873,32 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he runoff = rnof(patch) surface_runoff = rsur(patch) subsurface_runoff = rsub(patch) - skin_temp = t_grnd(patch) - t2m = tref(patch) - q2m = qref(patch) - emissivity = emis(patch) + skin_temp = t_grnd(patch) + t2m = tref(patch) + q2m = qref(patch) + surface_humidity = qref(patch) + IF (allocated(qsfc)) THEN + IF (patch <= size(qsfc)) THEN + IF (qsfc(patch) > 0._r8 .and. qsfc(patch) < 1._r8) surface_humidity = qsfc(patch) + ENDIF + ENDIF + emissivity = emis(patch) roughness = z0m(patch) IF (allocated(alb)) THEN ! ponytail: bulk albedo average; replace with band/beam mapping when MPAS consumes CoLM spectral albedo. - albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) + IF (patch <= size(alb,3)) albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) ENDIF ierr = 0 END SUBROUTINE colm_mpas_get_surface - SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ground_heat, runoff, & - surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & - emissivity, roughness, albedo, ierr) - integer, intent(in) :: element - real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff - real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m - real(r8), intent(out) :: emissivity, roughness, albedo + SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & + surface_humidity, emissivity, roughness, albedo, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff + real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: surface_humidity + real(r8), intent(out) :: emissivity, roughness, albedo integer, intent(out) :: ierr integer :: patch @@ -827,8 +911,8 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, real(r8) :: albedo_wt real(r8) :: patch_sensible, patch_latent, patch_evaporation, patch_ground_heat real(r8) :: patch_runoff, patch_surface_runoff, patch_subsurface_runoff - real(r8) :: patch_skin_temp, patch_t2m, patch_q2m - real(r8) :: patch_emissivity, patch_roughness, patch_albedo + real(r8) :: patch_skin_temp, patch_t2m, patch_q2m, patch_surface_humidity + real(r8) :: patch_emissivity, patch_roughness, patch_albedo ierr = 1 sensible = spval @@ -838,14 +922,16 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, runoff = spval surface_runoff = spval subsurface_runoff = spval - skin_temp = spval - t2m = spval - q2m = spval - emissivity = spval + skin_temp = spval + t2m = spval + q2m = spval + surface_humidity = spval + emissivity = spval roughness = spval albedo = spval IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN IF (.not. allocated(elm_patch%subfrc)) RETURN IF (element < 1 .or. element > size(elm_patch%substt)) RETURN @@ -860,40 +946,48 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, runoff = 0._r8 surface_runoff = 0._r8 subsurface_runoff = 0._r8 - skin_temp = 0._r8 - t2m = 0._r8 - q2m = 0._r8 - emissivity = 0._r8 + skin_temp = 0._r8 + t2m = 0._r8 + q2m = 0._r8 + surface_humidity = 0._r8 + emissivity = 0._r8 roughness = 0._r8 albedo_sum = 0._r8 albedo_wt = 0._r8 sumwt = 0._r8 - DO patch = istt, iend - IF (patch < 1 .or. patch > numpatch) CYCLE - IF (allocated(patchmask)) THEN - IF (.not. patchmask(patch)) CYCLE - ENDIF - wt = elm_patch%subfrc(patch) - IF (wt <= 0._r8) CYCLE - CALL colm_mpas_get_surface(patch, patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & - patch_runoff, patch_surface_runoff, patch_subsurface_runoff, & - patch_skin_temp, patch_t2m, patch_q2m, patch_emissivity, & - patch_roughness, patch_albedo, patch_ierr) - IF (patch_ierr /= 0) CYCLE + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) THEN + WRITE(*,*) 'Error: CoLM2024 element surface references invalid patch:', element, patch, numpatch + RETURN + ENDIF + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (wt <= 0._r8) CYCLE + CALL colm_mpas_get_surface(patch, patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & + patch_runoff, patch_surface_runoff, patch_subsurface_runoff, & + patch_skin_temp, patch_t2m, patch_q2m, patch_surface_humidity, & + patch_emissivity, patch_roughness, patch_albedo, patch_ierr) + IF (patch_ierr /= 0) THEN + WRITE(*,*) 'Error: failed to retrieve CoLM2024 patch surface:', element, patch, patch_ierr + RETURN + ENDIF - sumwt = sumwt + wt - sensible = sensible + wt * patch_sensible - latent = latent + wt * patch_latent - evaporation = evaporation + wt * patch_evaporation + sumwt = sumwt + wt + sensible = sensible + wt * patch_sensible + latent = latent + wt * patch_latent + evaporation = evaporation + wt * patch_evaporation ground_heat = ground_heat + wt * patch_ground_heat runoff = runoff + wt * patch_runoff surface_runoff = surface_runoff + wt * patch_surface_runoff subsurface_runoff = subsurface_runoff + wt * patch_subsurface_runoff - skin_temp = skin_temp + wt * patch_skin_temp - t2m = t2m + wt * patch_t2m - q2m = q2m + wt * patch_q2m - emissivity = emissivity + wt * patch_emissivity + skin_temp = skin_temp + wt * patch_skin_temp + t2m = t2m + wt * patch_t2m + q2m = q2m + wt * patch_q2m + surface_humidity = surface_humidity + wt * patch_surface_humidity + emissivity = emissivity + wt * patch_emissivity roughness = roughness + wt * patch_roughness IF (patch_albedo > 0._r8 .and. patch_albedo < 1._r8) THEN albedo_sum = albedo_sum + wt * patch_albedo @@ -909,10 +1003,11 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, runoff = spval surface_runoff = spval subsurface_runoff = spval - skin_temp = spval - t2m = spval - q2m = spval - emissivity = spval + skin_temp = spval + t2m = spval + q2m = spval + surface_humidity = spval + emissivity = spval roughness = spval RETURN ENDIF @@ -924,10 +1019,11 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, runoff = runoff / sumwt surface_runoff = surface_runoff / sumwt subsurface_runoff = subsurface_runoff / sumwt - skin_temp = skin_temp / sumwt - t2m = t2m / sumwt - q2m = q2m / sumwt - emissivity = emissivity / sumwt + skin_temp = skin_temp / sumwt + t2m = t2m / sumwt + q2m = q2m / sumwt + surface_humidity = surface_humidity / sumwt + emissivity = emissivity / sumwt roughness = roughness / sumwt IF (albedo_wt > 0._r8) albedo = albedo_sum / albedo_wt ierr = 0 @@ -998,11 +1094,14 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d soil_wt(:) = 0._r8 sumwt = 0._r8 - DO patch = istt, iend - IF (patch < 1 .or. patch > numpatch) CYCLE - IF (allocated(patchmask)) THEN - IF (.not. patchmask(patch)) CYCLE - ENDIF + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) THEN + WRITE(*,*) 'Error: CoLM2024 element state references invalid patch:', element, patch, numpatch + RETURN + ENDIF + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF wt = elm_patch%subfrc(patch) IF (wt <= 0._r8) CYCLE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index c2e647661a..356fea3045 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -1314,13 +1314,14 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL build_mpas_embedded_local_topology (parafile) - IF (p_is_compute) THEN - allocate (wts_ups (upnmax,numucat)) - IF (numucat > 0) wts_ups(:,:) = 1._r8 + IF (p_is_compute) THEN + allocate (wts_ups (upnmax,numucat)) + IF (numucat > 0) wts_ups(:,:) = 1._r8 - CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) - CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) - ENDIF + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) + CALL check_mpas_embedded_downstream_ownership () + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + ENDIF #ifdef COLM_PARALLEL IF (p_is_compute) THEN @@ -1598,10 +1599,72 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) deallocate (ucat_order) ENDIF - END SUBROUTINE build_mpas_embedded_local_topology + END SUBROUTINE build_mpas_embedded_local_topology - ! --------- - SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & + ! --------- + SUBROUTINE check_mpas_embedded_downstream_ownership () + + USE MOD_SPMD_Task + IMPLICIT NONE + + logical, allocatable :: id_found(:) + integer :: i, iworker, ireq + integer :: local_missing, global_missing + integer :: first_missing, global_first_missing + + IF (.not. p_is_compute) RETURN + + local_missing = 0 + first_missing = huge(1) + + IF (numucat > 0 .and. push_next2ucat%num_req_uniq > 0) THEN + allocate (id_found (push_next2ucat%num_req_uniq)) + id_found(:) = .false. + + IF (push_next2ucat%nself > 0) id_found(push_next2ucat%self_to) = .true. + +#ifdef COLM_PARALLEL + DO iworker = 0, p_np_compute-1 + IF (push_next2ucat%n_from_other(iworker) > 0) THEN + id_found(push_next2ucat%other_to(iworker)%val) = .true. + ENDIF + ENDDO +#endif + + DO i = 1, numucat + IF (ucat_next(i) > 0) THEN + ireq = push_next2ucat%addr_single(i) + IF (ireq <= 0 .or. .not. id_found(ireq)) THEN + local_missing = local_missing + 1 + first_missing = min(first_missing, ucat_next(i)) + ENDIF + ENDIF + ENDDO + + deallocate (id_found) + ENDIF + +#ifdef COLM_PARALLEL + CALL mpi_allreduce (local_missing, global_missing, 1, MPI_INTEGER, MPI_SUM, p_comm_compute, p_err) + CALL mpi_allreduce (first_missing, global_first_missing, 1, MPI_INTEGER, MPI_MIN, p_comm_compute, p_err) +#else + global_missing = local_missing + global_first_missing = first_missing +#endif + + IF (global_missing > 0) THEN + IF (p_is_root) THEN + write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM GridRiverLakeFlow is missing ', & + global_missing, ' downstream unit-catchment owner(s); first missing seq_next = ', & + global_first_missing + ENDIF + CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network ownership is incomplete.') + ENDIF + + END SUBROUTINE check_mpas_embedded_downstream_ownership + + ! --------- + SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & nucpart, idmap_uc2gd, area_uc2gd) USE MOD_SPMD_Task diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 index c727e85c9e..bc5571c3d1 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 @@ -108,14 +108,15 @@ SUBROUTINE THERMAL (ipatch ,patchtype,is_dry_lake,lb ,deltim , USE MOD_Const_PFT USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& stefnc,denice,tfrz,vonkar,grav,cpliq,cpice - USE MOD_FrictionVelocity - USE MOD_Eroot - USE MOD_GroundFluxes - USE MOD_LeafTemperature - USE MOD_LeafTemperaturePC - USE MOD_GroundTemperature - USE MOD_Qsadv - USE MOD_SoilSurfaceResistance + USE MOD_FrictionVelocity + USE MOD_Eroot + USE MOD_GroundFluxes + USE MOD_LeafTemperature + USE MOD_LeafTemperaturePC + USE MOD_GroundTemperature + USE MOD_Qsadv + USE MOD_SoilSurfaceResistance + USE MOD_Vars_TimeVariables, only: qsfc #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT, only: patch_pft_s, patch_pft_e USE MOD_Vars_TimeInvariants, only: patchclass @@ -594,11 +595,12 @@ SUBROUTINE THERMAL (ipatch ,patchtype,is_dry_lake,lb ,deltim , q_snow = qsatg dqgdT = dqgdT + fsno*qsatgdT - ! weighted average qg - qg = (1.-fsno)*q_soil + fsno*q_snow -ENDIF + ! weighted average qg + qg = (1.-fsno)*q_soil + fsno*q_snow + ENDIF + IF (allocated(qsfc)) qsfc(ipatch) = qg - ! calculate soil surface resistance (rss) + ! calculate soil surface resistance (rss) ! ------------------------------------------------ !NOTE: (1) DEF_RSS_SCHEME=0 means no rss considered ! (2) Do NOT calculate rss for the first timestep diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 index e95f9084c5..2a1ca48d80 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 @@ -554,10 +554,11 @@ MODULE MOD_Vars_TimeVariables real(r8), allocatable :: ssno_lyr(:,:,:,:) ! snow layer absorption [-] real(r8), allocatable :: trad (:) ! radiative temperature of surface [K] - real(r8), allocatable :: tref (:) ! 2 m height air temperature [kelvin] - real(r8), allocatable :: t2m_wmo (:) ! 2 m WMO air temperature [kelvin] - real(r8), allocatable :: qref (:) ! 2 m height air specific humidity - real(r8), allocatable :: rst (:) ! canopy stomatal resistance (s/m) + real(r8), allocatable :: tref (:) ! 2 m height air temperature [kelvin] + real(r8), allocatable :: t2m_wmo (:) ! 2 m WMO air temperature [kelvin] + real(r8), allocatable :: qref (:) ! 2 m height air specific humidity + real(r8), allocatable :: qsfc (:) ! bulk surface/ground specific humidity [kg/kg] + real(r8), allocatable :: rst (:) ! canopy stomatal resistance (s/m) real(r8), allocatable :: emis (:) ! averaged bulk surface emissivity real(r8), allocatable :: z0m (:) ! effective roughness [m] real(r8), allocatable :: displa (:) ! zero displacement height [m] @@ -746,10 +747,11 @@ SUBROUTINE allocate_TimeVariables allocate (ssno_lyr (2,2,maxsnl+1:1,numpatch)); ssno_lyr(:,:,:,:) = spval allocate (trad (numpatch)); trad (:) = spval - allocate (tref (numpatch)); tref (:) = spval - allocate (t2m_wmo (numpatch)); t2m_wmo (:) = spval - allocate (qref (numpatch)); qref (:) = spval - allocate (rst (numpatch)); rst (:) = spval + allocate (tref (numpatch)); tref (:) = spval + allocate (t2m_wmo (numpatch)); t2m_wmo (:) = spval + allocate (qref (numpatch)); qref (:) = spval + allocate (qsfc (numpatch)); qsfc (:) = spval + allocate (rst (numpatch)); rst (:) = spval allocate (emis (numpatch)); emis (:) = spval allocate (z0m (numpatch)); z0m (:) = spval allocate (displa (numpatch)); displa (:) = spval @@ -947,10 +949,11 @@ SUBROUTINE deallocate_TimeVariables () deallocate (ssno_lyr ) deallocate (trad ) - deallocate (tref ) - deallocate (t2m_wmo ) - deallocate (qref ) - deallocate (rst ) + deallocate (tref ) + deallocate (t2m_wmo ) + deallocate (qref ) + deallocate (qsfc ) + deallocate (rst ) deallocate (emis ) deallocate (z0m ) deallocate (displa ) @@ -1558,10 +1561,11 @@ SUBROUTINE check_TimeVariables () CALL check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] CALL check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] - CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] - CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] - CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] -IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] + CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] + CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] + CALL check_vector_data ('qsfc [kg/kg]', qsfc ) ! bulk surface/ground specific humidity + IF(DEF_USE_PLANTHYDRAULICS)THEN CALL check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] CALL check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance CALL check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shaded stomata conductance diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 index 25c82d9604..f2c13dca93 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -867,7 +867,9 @@ SUBROUTINE mesh_build () ! Step 5: IF MPI is used, scatter elms from IO to workers. #ifdef USEMPI +#ifndef MPAS_EMBEDDED_COLM CALL scatter_mesh_from_io_to_worker () +#endif #endif IF (p_is_root) THEN @@ -911,6 +913,7 @@ END SUBROUTINE mesh_build #ifdef USEMPI +#ifndef MPAS_EMBEDDED_COLM ! -------------------------------- SUBROUTINE scatter_mesh_from_io_to_worker @@ -1021,6 +1024,7 @@ SUBROUTINE scatter_mesh_from_io_to_worker END SUBROUTINE scatter_mesh_from_io_to_worker +#endif #endif ! -------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 index 909247e61a..76694f6926 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -117,10 +117,26 @@ SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write ENDIF #endif - END SUBROUTINE get_filename_vector_block + END SUBROUTINE get_filename_vector_block - !--------------------------------------------------------- - SUBROUTINE ncio_read_vector_int32_1d ( & + !--------------------------------------------------------- + SUBROUTINE ncio_vector_stop_missing_block (filename, dataname, fileblock) + + USE MOD_SPMD_Task, only: CoLM_stop + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: fileblock + + write(*,*) 'Error : required vector data '//trim(dataname) & + //' in '//trim(filename)//' is missing from block file '//trim(fileblock)//'.' + CALL CoLM_stop () + + END SUBROUTINE ncio_vector_stop_missing_block + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int32_1d ( & filename, dataname, pixelset, rdata, defval) USE MOD_NetCDFSerial @@ -161,13 +177,15 @@ SUBROUTINE ncio_read_vector_int32_1d ( & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -283,13 +301,15 @@ SUBROUTINE ncio_read_vector_int64_1d ( & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -409,13 +429,15 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & CALL ncio_read_serial (fileblock, dataname, sbuff) any_data_exists = .true. block_has_data = .true. - ELSEIF (present(defval)) THEN - IF (defval) THEN - sbuff(:) = 1 - ELSE - sbuff(:) = 0 - ENDIF - ENDIF + ELSEIF (present(defval)) THEN + IF (defval) THEN + sbuff(:) = 1 + ELSE + sbuff(:) = 0 + ENDIF + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -532,13 +554,15 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -656,13 +680,15 @@ SUBROUTINE ncio_read_vector_real8_2d ( & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -780,13 +806,15 @@ SUBROUTINE ncio_read_vector_real8_3d ( & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:,:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -904,13 +932,15 @@ SUBROUTINE ncio_read_vector_real8_4d ( & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:,:,:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & @@ -1029,13 +1059,15 @@ SUBROUTINE ncio_read_vector_real8_5d ( & CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:,:,:,:) = defval - ENDIF + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + any_data_exists = .true. + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF #ifdef COLM_VECTOR_MPI_IO CALL mpi_scatterv ( & diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 index 3fd25d0cbe..5f3d9b9e32 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -44,6 +44,10 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) integer :: nsend, nrecv, ndone, ndsp +#ifdef MPAS_EMBEDDED_COLM + CALL CoLM_stop('MPAS embedded CoLM does not support standalone mesh_save_to_file.') +#endif + ! add parameter input for time year write(cyear,'(i4.4)') lc_year #ifdef USEMPI @@ -379,6 +383,8 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDDO IF (count(keep_elm) < 1) THEN deallocate(keep_elm) + IF (allocated(elmindx)) deallocate(elmindx) + IF (allocated(npxl)) deallocate(npxl) CYCLE ENDIF ENDIF @@ -419,6 +425,11 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDDO IF (allocated(keep_elm)) deallocate(keep_elm) + IF (allocated(elmindx)) deallocate(elmindx) + IF (allocated(npxl)) deallocate(npxl) + IF (allocated(datasize)) deallocate(datasize) + IF (allocated(pixels)) deallocate(pixels) + IF (allocated(pixels2d)) deallocate(pixels2d) ENDIF ENDDO @@ -477,6 +488,10 @@ SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year) ! Local variables character(len=256) :: filename, cyear +#ifdef MPAS_EMBEDDED_COLM + CALL CoLM_stop('MPAS embedded CoLM does not support standalone pixelset_save_to_file.') +#endif + write(cyear,'(i4.4)') lc_year #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) From d2a487c2c63391dddc00f1eb62cc27787c0b2868 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Fri, 3 Jul 2026 10:53:59 +0800 Subject: [PATCH 12/17] Align CoLM embedded ownership with MPAS Constraint: CoLM2024 must stay MPAS-embedded while preserving patch/PFT internals. Rejected: Reopening standalone CoLM IO/worker paths | would reintroduce split ownership and deadlock risk. Confidence: high Scope-risk: moderate Directive: Keep runoff diagnostics cumulative in MPAS units; do not restore standalone role names in embedded paths. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; cmake --build build-cmake-colm-debug --target install -j 8; rg old CoLM role names under physics_colm2024 Not-tested: Real multi-rank MPAS+CoLM runtime case; river-system communicator refactor; zero-solve-cell rank support. --- .../mpas_atmphys_driver_lsm_colm2024.F | 5 +- .../physics/physics_colm2024/include/define.h | 2 +- .../physics_colm2024/main/DA/MOD_DA_SM.F90 | 158 +++++----- .../main/HYDRO/MOD_Catch_BasinNetwork.F90 | 72 ++--- .../main/HYDRO/MOD_Catch_HillslopeNetwork.F90 | 4 +- .../main/HYDRO/MOD_Catch_Reservoir.F90 | 16 +- .../main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 | 6 +- .../main/HYDRO/MOD_Grid_Reservoir.F90 | 18 +- .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 6 +- .../main/HYDRO/MOD_Grid_RiverLakeHist.F90 | 2 +- .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 278 +++++++++--------- .../main/HYDRO/MOD_Vector_ReadWrite.F90 | 8 +- .../share/MOD_AggregationRequestData.F90 | 8 +- .../share/MOD_ComputePushData.F90 | 166 +++++------ .../physics_colm2024/share/MOD_ElmVector.F90 | 44 +-- .../physics_colm2024/share/MOD_HRUVector.F90 | 4 +- .../physics_colm2024/share/MOD_Mesh.F90 | 82 +++--- .../physics_colm2024/share/MOD_Namelist.F90 | 6 +- .../share/MOD_NetCDFBlock.F90 | 3 +- .../share/MOD_NetCDFSerial.F90 | 3 +- .../share/MOD_NetCDFVector.F90 | 37 ++- .../physics_colm2024/share/MOD_Pixelset.F90 | 11 +- .../physics_colm2024/share/MOD_RangeCheck.F90 | 2 +- .../share/MOD_SpatialMapping.F90 | 8 +- .../share/MOD_SrfdataRestart.F90 | 56 ++-- 25 files changed, 501 insertions(+), 504 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index 9ab42b31d2..3e54655241 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -503,8 +503,9 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt qfx(i) = real(evaporation, RKIND) ! CoLM fgrnd and MPAS/Noah-MP grdflx are positive into soil/snow. grdflx(i) = real(ground_heat, RKIND) - sfcrunoff(i) = real(surface_runoff * dt, RKIND) - udrunoff(i) = real(subsurface_runoff * dt, RKIND) + ! MPAS runoff diagnostics are accumulated depths, matching Noah/Noah-MP. + sfcrunoff(i) = sfcrunoff(i) + real(surface_runoff * dt, RKIND) + udrunoff(i) = udrunoff(i) + real(subsurface_runoff * dt, RKIND) skintemp(i) = real(skin_temp, RKIND) t2m(i) = real(t2m_colm, RKIND) qsfc(i) = real(qsfc_colm, RKIND) diff --git a/src/core_atmosphere/physics/physics_colm2024/include/define.h b/src/core_atmosphere/physics/physics_colm2024/include/define.h index cb65a5066c..b5ea11ffc0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/include/define.h +++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h @@ -113,7 +113,7 @@ #endif #undef HYPERSPECTRAL #undef CoLMDEBUG -! CoLM range diagnostics still assume standalone IO/worker roles. +! CoLM range diagnostics still assume the standalone role split. #undef RangeCheck #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 index 9aa4ef5a8d..8854feb488 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 @@ -227,15 +227,15 @@ MODULE MOD_DA_SM !############################################################################# ! For SYNOP 2m temperature and humidity observations !############################################################################# - ! derived types of pixel index in each worker + ! derived types of pixel index in each rank ! firstly sorted by pixel latitude index (nlat) and record ! corresponding longitude index and patch id for each pixel type :: idx_type integer, allocatable :: ilon (:) integer, allocatable :: ipatch (:) END type idx_type - type(idx_type), allocatable :: idx (:) ! derived types of pixel index at each worker - integer, allocatable :: counter (:) ! counter of pixel longitude index of each latitude index at each worker + type(idx_type), allocatable :: idx (:) ! derived types of pixel index at each rank + integer, allocatable :: counter (:) ! counter of pixel longitude index of each latitude index at each rank ! file path character(len=256) :: file_synop ! SYNOP file path @@ -246,8 +246,8 @@ MODULE MOD_DA_SM real(r8), allocatable :: synop_lon_all(:) ! latitude and longitude of all SYNOP sites integer :: nsite ! number of all SYNOP sites integer, allocatable :: iloc_synop (:,:) ! global lat/lon index of pixel cover each site in all SYNOP sites - integer :: counter_worker_nsite ! number of all SYNOP sites located at each worker - integer, allocatable :: ip_worker (:,:) ! patch id of all SYNOP sites located at each worker + integer :: counter_rank_nsite ! number of all SYNOP sites located at each rank + integer, allocatable :: ip_rank (:,:) ! patch id of all SYNOP sites located at each rank integer, allocatable :: idx_lat(:), idx_lon(:), pos(:) ! temporary array save global lat/lon index of each site integer, allocatable :: synop_lut (:,:) ! look-up-table of all SYNOP sites @@ -261,10 +261,10 @@ MODULE MOD_DA_SM logical :: has_synop_obs ! whether has SYNOP obs at current step ! info of SYNOP sites at each step - integer, allocatable :: synop_idx (:,:) ! index of SYNOP sites (worker/patch id) at each step - integer, allocatable :: site_id_worker (:) ! site id of SYNOP sites at each step at each worker - real(r8), allocatable :: tref_ens_worker (:,:) ! predicted 2m temperature of SYNOP sites at each step at each worker - real(r8), allocatable :: qref_ens_worker (:,:) ! predicted 2m humidity of SYNOP sites at each step at each worker + integer, allocatable :: synop_idx (:,:) ! index of SYNOP sites (rank/patch id) at each step + integer, allocatable :: site_id_rank (:) ! site id of SYNOP sites at each step at each rank + real(r8), allocatable :: tref_ens_rank (:,:) ! predicted 2m temperature of SYNOP sites at each step at each rank + real(r8), allocatable :: qref_ens_rank (:,:) ! predicted 2m humidity of SYNOP sites at each step at each rank real(r8), allocatable :: qref_ens_o (:,:) ! predicted 2m temperature of SYNOP sites at each step real(r8), allocatable :: tref_ens_o (:,:) ! predicted 2m humidity of SYNOP sites at each step @@ -313,7 +313,7 @@ SUBROUTINE init_DA_SM() IMPLICIT NONE integer :: np, ie, ipxstt, ipxend, ipxl, i, ilat, isite, ilon, iwork, mesg(2), isrc, ndata, numpxl_lat, numpxl_lon, numpxl - integer, allocatable :: temp (:,:) ! temporary array for receiving data from workers + integer, allocatable :: temp (:,:) ! temporary array for receiving data from ranks !----------------------------------------------------------------------------- @@ -339,7 +339,7 @@ SUBROUTINE init_DA_SM() IF (DEF_DA_SM_SYNOP) THEN !############################################################################# -! Makeup derived types of pixel index for fast access at each worker +! Makeup derived types of pixel index for fast access at each rank !############################################################################# IF (p_is_compute) THEN allocate (counter (pixel%nlat)) @@ -400,7 +400,7 @@ SUBROUTINE init_DA_SM() ENDIF nsite = size(synop_lat_all) - ! find the located pixel of each site & broadcast workers + ! find the located pixel of each site & broadcast ranks allocate (iloc_synop (2, nsite)) iloc_synop(:,:) = -1 IF (p_is_root) THEN @@ -432,26 +432,26 @@ SUBROUTINE init_DA_SM() #endif !############################################################################# -! Assess the patch id of pixel that cover each observation at each worker +! Assess the patch id of pixel that cover each observation at each rank !############################################################################# IF (p_is_compute) THEN - ! count the number of site that located in pixels of each worker - counter_worker_nsite = 0 + ! count the number of site that located in pixels of each rank + counter_rank_nsite = 0 DO i = 1, nsite IF (iloc_synop(1, i) > 0) THEN IF (counter(iloc_synop(1, i)) > 0) THEN IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN - counter_worker_nsite = counter_worker_nsite + 1 + counter_rank_nsite = counter_rank_nsite + 1 ENDIF ENDIF ENDIF ENDDO - ! assess patch/site id of sites located at each worker - IF (counter_worker_nsite > 0) THEN - allocate (ip_worker (2, counter_worker_nsite)) - counter_worker_nsite = 0 - ip_worker(:,:) = -1 + ! assess patch/site id of sites located at each rank + IF (counter_rank_nsite > 0) THEN + allocate (ip_rank (2, counter_rank_nsite)) + counter_rank_nsite = 0 + ip_rank(:,:) = -1 DO i = 1, nsite IF (iloc_synop(1, i) > 0) THEN @@ -462,22 +462,22 @@ SUBROUTINE init_DA_SM() allocate (pos(numpxl)) pos = pack([(ilon, ilon=1, counter(iloc_synop(1, i)))], (idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) - counter_worker_nsite = counter_worker_nsite + 1 - ip_worker(1, counter_worker_nsite) = i - ip_worker(2, counter_worker_nsite) = idx(iloc_synop(1, i))%ipatch(pos(1)) + counter_rank_nsite = counter_rank_nsite + 1 + ip_rank(1, counter_rank_nsite) = i + ip_rank(2, counter_rank_nsite) = idx(iloc_synop(1, i))%ipatch(pos(1)) ENDIF ENDIF ENDIF ENDDO ENDIF - ! send the number of site and their patch id to master + ! send the number of site and their patch id to root #ifdef USEMPI - mesg = (/p_iam_glb, counter_worker_nsite/) + mesg = (/p_iam_glb, counter_rank_nsite/) CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (counter_worker_nsite > 0) THEN - CALL mpi_send(ip_worker, 2*counter_worker_nsite, MPI_INTEGER, & + IF (counter_rank_nsite > 0) THEN + CALL mpi_send(ip_rank, 2*counter_rank_nsite, MPI_INTEGER, & p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif @@ -490,11 +490,11 @@ SUBROUTINE init_DA_SM() ENDDO IF (allocated (idx)) deallocate (idx) IF (allocated (iloc_synop)) deallocate (iloc_synop) - IF (allocated (ip_worker)) deallocate (ip_worker) + IF (allocated (ip_rank)) deallocate (ip_rank) ENDIF !############################################################################# -! Generate look-up-table (contains the worker/patch id of each site) at master +! Generate look-up-table (contains the rank/patch id of each site) at root !############################################################################# IF (p_is_root) THEN allocate (synop_lut (2, nsite)) @@ -969,7 +969,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF ENDDO - ! send data from io to masters + ! send data from io to roots #ifdef USEMPI smesg = (/p_iam_glb, ndata/) CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) @@ -989,7 +989,7 @@ SUBROUTINE run_DA_SM(idate, deltim) deallocate (pred_smap_tb_h_wgrid_ens%blk, pred_smap_tb_v_wgrid_ens%blk) ENDIF - ! broadcast from master to all workers + ! broadcast from root to all ranks #ifdef USEMPI IF (p_is_root) THEN pred_smap_tb_h_ogrid_ens = -9999.0 @@ -1074,7 +1074,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF ENDDO - ! send data from io to masters + ! send data from io to roots #ifdef USEMPI smesg = (/p_iam_glb, ndata/) CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) @@ -1094,7 +1094,7 @@ SUBROUTINE run_DA_SM(idate, deltim) deallocate (pred_fy3d_tb_h_wgrid_ens%blk, pred_fy3d_tb_v_wgrid_ens%blk) ENDIF - ! broadcast from master to all workers + ! broadcast from root to all ranks #ifdef USEMPI IF (p_is_root) THEN pred_fy3d_tb_h_ogrid_ens = -9999.0 @@ -1126,7 +1126,7 @@ SUBROUTINE run_DA_SM(idate, deltim) ENDIF IF (DEF_DA_SM_SYNOP) THEN - ! crop corresponding index (worker id and patch id) of each observation + ! crop corresponding index (rank id and patch id) of each observation IF (has_synop_obs) THEN synop_idx(:,:) = -1 IF (p_is_root) THEN @@ -1135,64 +1135,64 @@ SUBROUTINE run_DA_SM(idate, deltim) CALL mpi_bcast(synop_idx, 2*num_synop_obs, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ENDIF - ! recount the number of observations at each worker + ! recount the number of observations at each rank IF (has_synop_obs) THEN IF (p_is_compute) THEN - counter_worker_nsite = 0 + counter_rank_nsite = 0 DO i = 1, num_synop_obs IF (synop_idx(1, i) == p_iam_glb) THEN - counter_worker_nsite = counter_worker_nsite + 1 + counter_rank_nsite = counter_rank_nsite + 1 ENDIF ENDDO ENDIF ENDIF - ! allocate memory for worker + ! allocate memory for rank IF (has_synop_obs) THEN IF (p_is_compute) THEN - IF (counter_worker_nsite > 0) THEN - IF (allocated(tref_ens_worker)) deallocate (tref_ens_worker) - IF (allocated(qref_ens_worker)) deallocate (qref_ens_worker) - IF (allocated(site_id_worker)) deallocate (site_id_worker) - allocate (tref_ens_worker (counter_worker_nsite, DEF_DA_ENS_NUM)) - allocate (qref_ens_worker (counter_worker_nsite, DEF_DA_ENS_NUM)) - allocate (site_id_worker (counter_worker_nsite)) + IF (counter_rank_nsite > 0) THEN + IF (allocated(tref_ens_rank)) deallocate (tref_ens_rank) + IF (allocated(qref_ens_rank)) deallocate (qref_ens_rank) + IF (allocated(site_id_rank)) deallocate (site_id_rank) + allocate (tref_ens_rank (counter_rank_nsite, DEF_DA_ENS_NUM)) + allocate (qref_ens_rank (counter_rank_nsite, DEF_DA_ENS_NUM)) + allocate (site_id_rank (counter_rank_nsite)) ENDIF ENDIF ENDIF - ! crop observations at each worker according index & send to master + ! crop observations at each rank according index & send to root IF (has_synop_obs) THEN IF (p_is_compute) THEN - counter_worker_nsite = 0 + counter_rank_nsite = 0 DO i = 1, num_synop_obs IF (synop_idx(1, i) == p_iam_glb) THEN - counter_worker_nsite = counter_worker_nsite + 1 - tref_ens_worker(counter_worker_nsite,:) = tref_ens(:, synop_idx(2, i)) - qref_ens_worker(counter_worker_nsite,:) = rhref_ens(:, synop_idx(2, i)) - site_id_worker (counter_worker_nsite) = i + counter_rank_nsite = counter_rank_nsite + 1 + tref_ens_rank(counter_rank_nsite,:) = tref_ens(:, synop_idx(2, i)) + qref_ens_rank(counter_rank_nsite,:) = rhref_ens(:, synop_idx(2, i)) + site_id_rank (counter_rank_nsite) = i ENDIF ENDDO #ifdef USEMPI - ! send the number of site and their patch id to master - mesg = (/p_iam_glb, counter_worker_nsite/) + ! send the number of site and their patch id to root + mesg = (/p_iam_glb, counter_rank_nsite/) CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (counter_worker_nsite > 0) THEN - CALL mpi_send(tref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send(qref_ens_worker, DEF_DA_ENS_NUM*counter_worker_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send(site_id_worker, counter_worker_nsite, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) + IF (counter_rank_nsite > 0) THEN + CALL mpi_send(tref_ens_rank, DEF_DA_ENS_NUM*counter_rank_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(qref_ens_rank, DEF_DA_ENS_NUM*counter_rank_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send(site_id_rank, counter_rank_nsite, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #endif - IF (allocated(tref_ens_worker)) deallocate (tref_ens_worker) - IF (allocated(qref_ens_worker)) deallocate (qref_ens_worker) - IF (allocated(site_id_worker)) deallocate (site_id_worker) + IF (allocated(tref_ens_rank)) deallocate (tref_ens_rank) + IF (allocated(qref_ens_rank)) deallocate (qref_ens_rank) + IF (allocated(site_id_rank)) deallocate (site_id_rank) ENDIF ENDIF - ! concatenate all predicted observations at master & broadcast to all workers + ! concatenate all predicted observations at root & broadcast to all ranks IF (has_synop_obs) THEN qref_ens_o = spval tref_ens_o = spval @@ -1204,21 +1204,21 @@ SUBROUTINE run_DA_SM(idate, deltim) ndata = mesg(2) IF (ndata > 0) THEN - allocate(tref_ens_worker(ndata, DEF_DA_ENS_NUM)) - allocate(qref_ens_worker(ndata, DEF_DA_ENS_NUM)) - allocate(site_id_worker (ndata)) + allocate(tref_ens_rank(ndata, DEF_DA_ENS_NUM)) + allocate(qref_ens_rank(ndata, DEF_DA_ENS_NUM)) + allocate(site_id_rank (ndata)) - CALL mpi_recv(tref_ens_worker, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv(qref_ens_worker, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv(site_id_worker, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(tref_ens_rank, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(qref_ens_rank, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv(site_id_rank, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - qref_ens_o(site_id_worker,:) = qref_ens_worker - tref_ens_o(site_id_worker,:) = tref_ens_worker + qref_ens_o(site_id_rank,:) = qref_ens_rank + tref_ens_o(site_id_rank,:) = tref_ens_rank ENDIF - IF (allocated(tref_ens_worker)) deallocate(tref_ens_worker) - IF (allocated(qref_ens_worker)) deallocate(qref_ens_worker) - IF (allocated(site_id_worker)) deallocate(site_id_worker) + IF (allocated(tref_ens_rank)) deallocate(tref_ens_rank) + IF (allocated(qref_ens_rank)) deallocate(qref_ens_rank) + IF (allocated(site_id_rank)) deallocate(site_id_rank) ENDDO #endif ENDIF @@ -1702,9 +1702,9 @@ SUBROUTINE run_DA_SM(idate, deltim) IF (allocated (qref_ens_o)) deallocate (qref_ens_o) IF (allocated (synop_idx)) deallocate (synop_idx) - IF (allocated (site_id_worker)) deallocate (site_id_worker) - IF (allocated (tref_ens_worker)) deallocate (tref_ens_worker) - IF (allocated (qref_ens_worker)) deallocate (qref_ens_worker) + IF (allocated (site_id_rank)) deallocate (site_id_rank) + IF (allocated (tref_ens_rank)) deallocate (tref_ens_rank) + IF (allocated (qref_ens_rank)) deallocate (qref_ens_rank) IF (allocated (qref_ens_o)) deallocate (qref_ens_o) IF (allocated (tref_ens_o)) deallocate (tref_ens_o) @@ -1773,9 +1773,9 @@ SUBROUTINE end_DA_SM() IF (allocated (qref_ens_o)) deallocate (qref_ens_o) IF (allocated (synop_idx)) deallocate (synop_idx) - IF (allocated (site_id_worker)) deallocate (site_id_worker) - IF (allocated (tref_ens_worker)) deallocate (tref_ens_worker) - IF (allocated (qref_ens_worker)) deallocate (qref_ens_worker) + IF (allocated (site_id_rank)) deallocate (site_id_rank) + IF (allocated (tref_ens_rank)) deallocate (tref_ens_rank) + IF (allocated (qref_ens_rank)) deallocate (qref_ens_rank) IF (allocated (qref_ens_o)) deallocate (qref_ens_o) IF (allocated (tref_ens_o)) deallocate (tref_ens_o) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 index 95a5ec9b43..5a864c2a8b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 @@ -56,11 +56,11 @@ SUBROUTINE build_basin_network () integer, allocatable :: nups_nst(:), iups_nst(:), nups_all(:), b_up2down(:), orderbsn(:) - integer , allocatable :: nb_rs(:), iwrk_rs(:), nwrk_rs(:), nave_rs(:), nb_wrk(:) - real(r8), allocatable :: wtbsn(:), wt_rs (:), wt_wrk (:) + integer , allocatable :: nb_rs(:), irank_rs(:), nrank_rs(:), nave_rs(:), nb_rank(:) + real(r8), allocatable :: wtbsn(:), wt_rs (:), wt_rank (:) integer :: totalnumbasin, ibasin, nbasin, iriv - integer :: iworker, iwrkdsp, mesg(2), isrc, nrecv + integer :: irank, irankdsp, mesg(2), isrc, nrecv integer :: iloc, i, j, ithis real(r8) :: sumwt @@ -87,7 +87,7 @@ SUBROUTINE build_basin_network () ENDIF #ifdef USEMPI - ! divide basins into groups and assign to workers + ! divide basins into groups and assign to ranks IF (p_is_root) THEN IF (ncio_var_exist(basin_file, 'weightbasin')) THEN @@ -159,22 +159,22 @@ SUBROUTINE build_basin_network () sumwt = sum(wt_rs) - allocate (iwrk_rs (numrivmth)) - allocate (nwrk_rs (numrivmth)) + allocate (irank_rs (numrivmth)) + allocate (nrank_rs (numrivmth)) allocate (nave_rs (numrivmth)) - iwrkdsp = -1 + irankdsp = -1 DO i = 1, numrivmth - nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) - IF (nwrk_rs(i) > 1) THEN + nrank_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) + IF (nrank_rs(i) > 1) THEN - nave_rs(i) = nb_rs(i) / nwrk_rs(i) - IF (mod(nb_rs(i), nwrk_rs(i)) /= 0) THEN + nave_rs(i) = nb_rs(i) / nrank_rs(i) + IF (mod(nb_rs(i), nrank_rs(i)) /= 0) THEN nave_rs(i) = nave_rs(i) + 1 ENDIF - iwrk_rs(i) = iwrkdsp + 1 - iwrkdsp = iwrkdsp + nwrk_rs(i) + irank_rs(i) = irankdsp + 1 + irankdsp = irankdsp + nrank_rs(i) ENDIF ENDDO @@ -189,8 +189,8 @@ SUBROUTINE build_basin_network () allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 - allocate (wt_wrk (0:p_np_compute-1)); wt_wrk(:) = 0 - allocate (nb_wrk (0:p_np_compute-1)); nb_wrk(:) = 0 + allocate (wt_rank (0:p_np_compute-1)); wt_rank(:) = 0 + allocate (nb_rank (0:p_np_compute-1)); nb_rank(:) = 0 allocate (orderbsn(totalnumbasin)) orderbsn(b_up2down) = (/(i, i = 1, totalnumbasin)/) @@ -215,15 +215,15 @@ SUBROUTINE build_basin_network () ENDIF iriv = rivermouth(i) - IF (nwrk_rs(iriv) > 1) THEN - iworker = iwrk_rs(iriv) - IF (nups_all(i) <= nave_rs(iriv)-nb_wrk(iworker)) THEN + IF (nrank_rs(iriv) > 1) THEN + irank = irank_rs(iriv) + IF (nups_all(i) <= nave_rs(iriv)-nb_rank(irank)) THEN - addrbasin(i) = p_address_compute(iworker) + addrbasin(i) = p_address_compute(irank) - nb_wrk(iworker) = nb_wrk(iworker) + nups_all(i) - IF (nb_wrk(iworker) == nave_rs(iriv)) THEN - iwrk_rs(iriv) = iwrk_rs(iriv) + 1 + nb_rank(irank) = nb_rank(irank) + nups_all(i) + IF (nb_rank(irank) == nave_rs(iriv)) THEN + irank_rs(iriv) = irank_rs(iriv) + 1 ENDIF j = basindown(i) @@ -240,11 +240,11 @@ SUBROUTINE build_basin_network () ithis = ithis - 1 ENDIF ELSE - iworker = minloc(wt_wrk(iwrkdsp+1:p_np_compute-1), dim=1) + iwrkdsp + irank = minloc(wt_rank(irankdsp+1:p_np_compute-1), dim=1) + irankdsp - addrbasin(i) = p_address_compute(iworker) + addrbasin(i) = p_address_compute(irank) - wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv) + wt_rank(irank) = wt_rank(irank) + wt_rs(iriv) ithis = ithis - 1 ENDIF @@ -257,31 +257,31 @@ SUBROUTINE build_basin_network () deallocate (orderbsn ) deallocate (nb_rs ) deallocate (wt_rs ) - deallocate (iwrk_rs ) - deallocate (nwrk_rs ) + deallocate (irank_rs ) + deallocate (nrank_rs ) deallocate (nave_rs ) - deallocate (wt_wrk ) - deallocate (nb_wrk ) + deallocate (wt_rank ) + deallocate (nb_rank ) ENDIF - ! send basin index to workers + ! send basin index to ranks IF (p_is_root) THEN allocate(basinindex (totalnumbasin)) basinindex = (/(i, i = 1, totalnumbasin)/) - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 - nbasin = count(addrbasin == p_address_compute(iworker)) - CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_compute(iworker), mpi_tag_mesg, p_comm_glb, p_err) + nbasin = count(addrbasin == p_address_compute(irank)) + CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_err) IF (nbasin > 0) THEN allocate (bindex (nbasin)) - bindex = pack(basinindex, mask = (addrbasin == p_address_compute(iworker))) - CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_compute(iworker), & + bindex = pack(basinindex, mask = (addrbasin == p_address_compute(irank))) + CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) deallocate (bindex) @@ -400,7 +400,7 @@ SUBROUTINE build_basin_network () ENDIF IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & mpi_tag_mesg, p_comm_glb, p_stat, p_err) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 index 63f3802660..92ab560435 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 @@ -51,7 +51,7 @@ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) character(len=256) :: hillslope_network_file integer :: maxnumhru, ie, nhru, hs, i, j - integer :: iworker, mesg(2), nrecv, irecv, isrc, idest + integer :: irank, mesg(2), nrecv, irecv, isrc, idest integer , allocatable :: eid (:) @@ -98,7 +98,7 @@ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) IF (p_is_root) THEN #ifdef USEMPI - DO iworker = 1, p_np_compute + DO irank = 1, p_np_compute CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) nrecv = mesg(2) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 index b5e2328aca..b36a691f70 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 @@ -63,7 +63,7 @@ SUBROUTINE reservoir_init ( ) ! Local variables character(len=256) :: basin_info_file, resv_info_file - integer :: maxlakeid, mesg(2), isrc, idest, iworker + integer :: maxlakeid, mesg(2), isrc, idest, irank integer, allocatable :: lake_id_basin (:), ilat_outlet_basin(:), ilon_outlet_basin(:) integer, allocatable :: lake_id_resv (:), ilat_outlet_resv (:), ilon_outlet_resv (:) @@ -183,7 +183,7 @@ SUBROUTINE reservoir_init ( ) #ifdef USEMPI IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -403,7 +403,7 @@ SUBROUTINE reservoir_gather_var (varin, varout) real(r8), intent(out) :: varout (:) ! local variables - integer :: irsv, iworker + integer :: irsv, irank real(r8), allocatable :: varall (:,:) IF (numresv_uniq == 0) RETURN @@ -430,13 +430,13 @@ SUBROUTINE reservoir_gather_var (varin, varout) IF (p_iam_compute == p_root) THEN DO irsv = 1, numresv_uniq - DO iworker = 0, p_np_compute-1 - IF (iworker /= p_root) THEN - IF (varall(irsv,iworker) /= spval) THEN + DO irank = 0, p_np_compute-1 + IF (irank /= p_root) THEN + IF (varall(irsv,irank) /= spval) THEN IF (varout(irsv) /= spval) THEN - varout(irsv) = varout(irsv) + varall(irsv,iworker) + varout(irsv) = varout(irsv) + varall(irsv,irank) ELSE - varout(irsv) = varall(irsv,iworker) + varout(irsv) = varall(irsv,irank) ENDIF ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 index 4b84d4347a..7ed4ee95a7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 @@ -118,7 +118,7 @@ SUBROUTINE river_lake_network_init (patcharea) logical :: use_calc_rivdpt integer :: totalnumbasin, ibasin, jbasin, inb, iloc, ielm, i, j, ilink - integer :: iworker, mesg(2), isrc, idest, nrecv + integer :: irank, mesg(2), isrc, idest, nrecv #ifdef USEMPI integer :: nblink_all @@ -191,7 +191,7 @@ SUBROUTINE river_lake_network_init (patcharea) #ifdef USEMPI IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -295,7 +295,7 @@ SUBROUTINE river_lake_network_init (patcharea) allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 index ab24e3686b..208dd12b8e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -63,7 +63,7 @@ SUBROUTINE reservoir_init ( ) integer, allocatable :: icache (:) integer, parameter :: dam_seq_chunk_size = 1048576 - integer :: i, iloc, irsv, nresv, iworker + integer :: i, iloc, irsv, nresv, irank integer :: istart, iend, local_index @@ -144,22 +144,22 @@ SUBROUTINE reservoir_init ( ) IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:p_np_compute-1)) IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 - IF (p_address_compute(iworker) == p_iam_glb) THEN + IF (p_address_compute(irank) == p_iam_glb) THEN nresv = numresv ELSE CALL mpi_recv (nresv, 1, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_stat, p_err) ENDIF IF (nresv > 0) THEN - allocate (resv_data_address(iworker)%val (nresv)) - IF (p_address_compute(iworker) == p_iam_glb) THEN - resv_data_address(iworker)%val = resv_global_index(1:nresv) + allocate (resv_data_address(irank)%val (nresv)) + IF (p_address_compute(irank) == p_iam_glb) THEN + resv_data_address(irank)%val = resv_global_index(1:nresv) ELSE - CALL mpi_recv (resv_data_address(iworker)%val, nresv, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + CALL mpi_recv (resv_data_address(irank)%val, nresv, MPI_INTEGER, & + p_address_compute(irank), mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDIF ENDDO diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index 02d3108532..e2768a3c8c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -45,7 +45,7 @@ SUBROUTINE grid_riverlake_flow_init () acctime_rnof = 0. IF (p_is_compute) THEN - ! Allocate on all workers (zero-length if numucat/numpatch=0) + ! Allocate on all ranks (zero-length if numucat/numpatch=0) ! to avoid passing unallocated arrays to assumed-shape MPI wrappers. allocate (acc_rnof_uc (numucat)) acc_rnof_uc = 0. @@ -163,7 +163,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #ifdef GridRiverLakeSediment IF (DEF_USE_SEDIMENT) THEN - ! Allocate zero-length arrays on empty workers to avoid passing unallocated + ! Allocate zero-length arrays on empty ranks to avoid passing unallocated ! arrays to assumed-shape dummy arguments in MPI communication routines. IF (numpatch > 0) THEN allocate (prcp_pch (numpatch)) @@ -703,7 +703,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #ifdef GridRiverLakeSediment IF (DEF_USE_SEDIMENT .and. p_is_compute) THEN - ! All workers must participate (MPI point-to-point inside push_data). + ! All ranks must participate (MPI point-to-point inside push_data). ! fldfrc is now computed inside grid_sediment_calc from per-routing-period ! accumulators (sed_acc_floodarea), not from history-period averages. CALL grid_sediment_calc(acctime_rnof) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 index 67d569eb9c..033dec6575 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 @@ -633,7 +633,7 @@ SUBROUTINE write_sediment_history (file_hist_ucat, itime_in_file_ucat) IF (.not. DEF_USE_SEDIMENT) RETURN - ! Allocate on ALL processes (zero-size on non-workers) to avoid + ! Allocate on ALL processes (zero-size on non-ranks) to avoid ! passing unallocated arrays to vector_gather_map2grid_and_write IF (p_is_compute .and. numucat > 0) THEN allocate (a_sedcon_avg (nsed, numucat)) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index 356fea3045..d853844134 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -21,7 +21,7 @@ MODULE MOD_Grid_RiverLakeNetwork integer, allocatable :: y_ucat (:) ! integer, allocatable :: ucat_gdid (:) ! - integer, allocatable :: numucat_wrk (:) + integer, allocatable :: numucat_rank (:) type(pointer_int32_1d), allocatable :: ucat_data_address (:) ! ----- Part 1: between runoff input elements and unit catchments ----- @@ -128,8 +128,8 @@ SUBROUTINE build_riverlake_network () integer, allocatable :: uc_up2down(:), order_ucat(:) integer, allocatable :: addr_ucat (:) - integer , allocatable :: nuc_rs(:), iwrk_rs(:), nwrk_rs(:), nave_rs(:) - real(r8), allocatable :: wt_uc (:), wt_rs (:), wt_wrk (:), nuc_wrk(:) + integer , allocatable :: nuc_rs(:), irank_rs(:), nrank_rs(:), nave_rs(:) + real(r8), allocatable :: wt_uc (:), wt_rs (:), wt_rank (:), nuc_rank(:) integer, allocatable :: grdindex(:) @@ -147,7 +147,7 @@ SUBROUTINE build_riverlake_network () integer :: nlat_ucat, nlon_ucat integer :: nucat, iriv, ngrdall, igrd, ngrd integer :: p_np_rivsys, color - integer :: iworker, iwrkdsp, self_worker + integer :: irank, irankdsp, self_rank integer :: iloc, i, j, ithis real(r8) :: sumwt logical :: is_new @@ -233,7 +233,7 @@ SUBROUTINE build_riverlake_network () ENDIF #ifdef COLM_PARALLEL - ! divide unit catchments into groups and assign to workers + ! divide unit catchments into groups and assign to ranks IF (p_is_root) THEN allocate (wt_uc (totalnumucat)); wt_uc(:) = 1. @@ -259,22 +259,22 @@ SUBROUTINE build_riverlake_network () sumwt = sum(wt_rs) - allocate (iwrk_rs (numrivmth)) - allocate (nwrk_rs (numrivmth)) + allocate (irank_rs (numrivmth)) + allocate (nrank_rs (numrivmth)) allocate (nave_rs (numrivmth)) - iwrkdsp = -1 + irankdsp = -1 DO i = 1, numrivmth - nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) - IF (nwrk_rs(i) > 1) THEN + nrank_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) + IF (nrank_rs(i) > 1) THEN - nave_rs(i) = nuc_rs(i) / nwrk_rs(i) - IF (mod(nuc_rs(i), nwrk_rs(i)) /= 0) THEN + nave_rs(i) = nuc_rs(i) / nrank_rs(i) + IF (mod(nuc_rs(i), nrank_rs(i)) /= 0) THEN nave_rs(i) = nave_rs(i) + 1 ENDIF - iwrk_rs(i) = iwrkdsp + 1 - iwrkdsp = iwrkdsp + nwrk_rs(i) + irank_rs(i) = irankdsp + 1 + irankdsp = irankdsp + nrank_rs(i) ENDIF ENDDO @@ -289,8 +289,8 @@ SUBROUTINE build_riverlake_network () allocate (addr_ucat (totalnumucat)); addr_ucat(:) = -1 - allocate (wt_wrk (0:p_np_compute-1)); wt_wrk (:) = 0 - allocate (nuc_wrk(0:p_np_compute-1)); nuc_wrk(:) = 0 + allocate (wt_rank (0:p_np_compute-1)); wt_rank (:) = 0 + allocate (nuc_rank(0:p_np_compute-1)); nuc_rank(:) = 0 allocate (order_ucat (totalnumucat)) order_ucat(uc_up2down) = (/(i, i = 1, totalnumucat)/) @@ -315,15 +315,15 @@ SUBROUTINE build_riverlake_network () ENDIF iriv = rivermouth(i) - IF (nwrk_rs(iriv) > 1) THEN - iworker = iwrk_rs(iriv) - IF (nups_all(i) <= nave_rs(iriv)-nuc_wrk(iworker)) THEN + IF (nrank_rs(iriv) > 1) THEN + irank = irank_rs(iriv) + IF (nups_all(i) <= nave_rs(iriv)-nuc_rank(irank)) THEN - addr_ucat(i) = p_address_compute(iworker) + addr_ucat(i) = p_address_compute(irank) - nuc_wrk(iworker) = nuc_wrk(iworker) + nups_all(i) - IF (nuc_wrk(iworker) == nave_rs(iriv)) THEN - iwrk_rs(iriv) = iwrk_rs(iriv) + 1 + nuc_rank(irank) = nuc_rank(irank) + nups_all(i) + IF (nuc_rank(irank) == nave_rs(iriv)) THEN + irank_rs(iriv) = irank_rs(iriv) + 1 ENDIF j = ucat_next(i) @@ -340,11 +340,11 @@ SUBROUTINE build_riverlake_network () ithis = ithis - 1 ENDIF ELSE - iworker = minloc(wt_wrk(iwrkdsp+1:p_np_compute-1), dim=1) + iwrkdsp + irank = minloc(wt_rank(irankdsp+1:p_np_compute-1), dim=1) + irankdsp - addr_ucat(i) = p_address_compute(iworker) + addr_ucat(i) = p_address_compute(irank) - wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv) + wt_rank(irank) = wt_rank(irank) + wt_rs(iriv) ithis = ithis - 1 ENDIF @@ -353,13 +353,13 @@ SUBROUTINE build_riverlake_network () deallocate (order_ucat) deallocate (nups_all ) deallocate (nuc_rs ) - deallocate (iwrk_rs ) - deallocate (nwrk_rs ) + deallocate (irank_rs ) + deallocate (nrank_rs ) deallocate (nave_rs ) deallocate (wt_uc ) deallocate (wt_rs ) - deallocate (wt_wrk ) - deallocate (nuc_wrk ) + deallocate (wt_rank ) + deallocate (nuc_rank ) ENDIF @@ -368,16 +368,16 @@ SUBROUTINE build_riverlake_network () allocate(ucat_ucid (totalnumucat)) ucat_ucid = (/(i, i = 1, totalnumucat)/) - allocate (numucat_wrk (0:p_np_compute-1)) + allocate (numucat_rank (0:p_np_compute-1)) allocate (ucat_data_address (0:p_np_compute-1)) - DO iworker = 0, p_np_compute-1 - nucat = count(addr_ucat == p_address_compute(iworker)) - numucat_wrk(iworker) = nucat + DO irank = 0, p_np_compute-1 + nucat = count(addr_ucat == p_address_compute(irank)) + numucat_rank(irank) = nucat IF (nucat > 0) THEN - allocate (ucat_data_address(iworker)%val (nucat)) - ucat_data_address(iworker)%val = & - pack(ucat_ucid, mask = (addr_ucat == p_address_compute(iworker))) + allocate (ucat_data_address(irank)%val (nucat)) + ucat_data_address(irank)%val = & + pack(ucat_ucid, mask = (addr_ucat == p_address_compute(irank))) ENDIF ENDDO @@ -385,49 +385,49 @@ SUBROUTINE build_riverlake_network () CALL mpi_bcast (totalnumucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - ! send unit catchment index to workers + ! send unit catchment index to ranks IF (p_is_root) THEN - self_worker = -1 + self_rank = -1 - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 - nucat = numucat_wrk(iworker) - IF (p_address_compute(iworker) == p_iam_glb) THEN + nucat = numucat_rank(irank) + IF (p_address_compute(irank) == p_iam_glb) THEN numucat = nucat - self_worker = iworker + self_rank = irank CYCLE ENDIF - CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_compute(iworker), & + CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_compute(irank), & mpi_tag_mesg, p_comm_glb, p_err) IF (nucat > 0) THEN - CALL mpi_send (ucat_data_address(iworker)%val, nucat, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (ucat_data_address(irank)%val, nucat, MPI_INTEGER, & + p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err) #ifndef MPAS_EMBEDDED_COLM allocate (idata1d (nucat)) - idata1d = x_ucat (ucat_data_address(iworker)%val) + idata1d = x_ucat (ucat_data_address(irank)%val) CALL mpi_send (idata1d, nucat, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err) - idata1d = y_ucat (ucat_data_address(iworker)%val) + idata1d = y_ucat (ucat_data_address(irank)%val) CALL mpi_send (idata1d, nucat, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_err) + p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err) deallocate (idata1d) #endif ENDIF ENDDO - IF (self_worker >= 0) THEN - nucat = numucat_wrk(self_worker) + IF (self_rank >= 0) THEN + nucat = numucat_rank(self_rank) IF (allocated(idata1d)) deallocate(idata1d) allocate (idata1d (nucat)) - IF (nucat > 0) idata1d = ucat_data_address(self_worker)%val + IF (nucat > 0) idata1d = ucat_data_address(self_rank)%val IF (allocated(ucat_ucid)) deallocate(ucat_ucid) allocate (ucat_ucid (nucat)) @@ -483,8 +483,8 @@ SUBROUTINE build_riverlake_network () allocate(ucat_ucid (totalnumucat)) ucat_ucid = (/(i, i = 1, totalnumucat)/) - allocate (numucat_wrk (0:0)) - numucat_wrk(0) = numucat + allocate (numucat_rank (0:0)) + numucat_rank(0) = numucat allocate (ucat_data_address (0:0)) allocate (ucat_data_address(0)%val (numucat)) @@ -621,30 +621,30 @@ SUBROUTINE build_riverlake_network () IF (p_is_root) THEN - self_worker = -1 - DO iworker = 0, p_np_compute-1 + self_rank = -1 + DO irank = 0, p_np_compute-1 - nucat = numucat_wrk(iworker) + nucat = numucat_rank(irank) IF (nucat > 0) THEN - IF (p_address_compute(iworker) == p_iam_glb) THEN - self_worker = iworker + IF (p_address_compute(irank) == p_iam_glb) THEN + self_rank = irank CYCLE ENDIF allocate (idata2d (inpn, nucat)) DO i = 1, nucat - idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(iworker)%val(i)) + idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(irank)%val(i)) ENDDO allocate (rdata2d (inpn, nucat)) DO i = 1, nucat - rdata2d(:,i) = area_gd2uc(:,ucat_data_address(iworker)%val(i)) + rdata2d(:,i) = area_gd2uc(:,ucat_data_address(irank)%val(i)) ENDDO - CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_compute(iworker), & + CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_compute(iworker), & + CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) deallocate (idata2d) @@ -652,17 +652,17 @@ SUBROUTINE build_riverlake_network () ENDIF ENDDO - IF (self_worker >= 0) THEN - nucat = numucat_wrk(self_worker) + IF (self_rank >= 0) THEN + nucat = numucat_rank(self_rank) IF (nucat > 0) THEN allocate (idata2d (inpn, nucat)) DO i = 1, nucat - idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(self_worker)%val(i)) + idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(self_rank)%val(i)) ENDDO allocate (rdata2d (inpn, nucat)) DO i = 1, nucat - rdata2d(:,i) = area_gd2uc(:,ucat_data_address(self_worker)%val(i)) + rdata2d(:,i) = area_gd2uc(:,ucat_data_address(self_rank)%val(i)) ENDDO IF (allocated(idmap_gd2uc)) deallocate(idmap_gd2uc) @@ -708,13 +708,13 @@ SUBROUTINE build_riverlake_network () IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 - IF (p_address_compute(iworker) == p_iam_glb) THEN + IF (p_address_compute(irank) == p_iam_glb) THEN ngrd = numinpm ELSE CALL mpi_recv (ngrd, 1, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_stat, p_err) ENDIF IF (ngrd > 0) THEN @@ -723,11 +723,11 @@ SUBROUTINE build_riverlake_network () allocate (idata2d (nucpart, ngrd)); idata2d(:,:) = 0 allocate (rdata2d (nucpart, ngrd)); rdata2d(:,:) = 0. - IF (p_address_compute(iworker) == p_iam_glb) THEN + IF (p_address_compute(irank) == p_iam_glb) THEN grdindex = inpm_gdid ELSE CALL mpi_recv (grdindex, ngrd, MPI_INTEGER, & - p_address_compute(iworker), mpi_tag_data, p_comm_glb, p_stat, p_err) + p_address_compute(irank), mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF DO i = 1, ngrd @@ -738,7 +738,7 @@ SUBROUTINE build_riverlake_network () ENDIF ENDDO - IF (p_address_compute(iworker) == p_iam_glb) THEN + IF (p_address_compute(irank) == p_iam_glb) THEN IF (allocated(idmap_uc2gd)) deallocate(idmap_uc2gd) IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) allocate (idmap_uc2gd (nucpart, ngrd)) @@ -746,9 +746,9 @@ SUBROUTINE build_riverlake_network () idmap_uc2gd = idata2d area_uc2gd = rdata2d ELSE - CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_compute(iworker), & + CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_compute(iworker), & + CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -856,28 +856,28 @@ SUBROUTINE build_riverlake_network () IF (p_is_root) THEN - self_worker = -1 - DO iworker = 0, p_np_compute-1 + self_rank = -1 + DO irank = 0, p_np_compute-1 - nucat = numucat_wrk(iworker) + nucat = numucat_rank(irank) IF (nucat > 0) THEN - IF (p_address_compute(iworker) == p_iam_glb) THEN - self_worker = iworker + IF (p_address_compute(irank) == p_iam_glb) THEN + self_rank = irank CYCLE ENDIF allocate (idata1d (nucat)) - idata1d = ucat_next(ucat_data_address(iworker)%val) + idata1d = ucat_next(ucat_data_address(irank)%val) allocate (idata2d (upnmax,nucat)) DO i = 1, nucat - idata2d(:,i) = ucat_ups(:,ucat_data_address(iworker)%val(i)) + idata2d(:,i) = ucat_ups(:,ucat_data_address(irank)%val(i)) ENDDO - CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(iworker), & + CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_compute(iworker), & + CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) deallocate (idata1d) @@ -885,15 +885,15 @@ SUBROUTINE build_riverlake_network () ENDIF ENDDO - IF (self_worker >= 0) THEN - nucat = numucat_wrk(self_worker) + IF (self_rank >= 0) THEN + nucat = numucat_rank(self_rank) IF (nucat > 0) THEN allocate (idata1d (nucat)) - idata1d = ucat_next(ucat_data_address(self_worker)%val) + idata1d = ucat_next(ucat_data_address(self_rank)%val) allocate (idata2d (upnmax,nucat)) DO i = 1, nucat - idata2d(:,i) = ucat_ups(:,ucat_data_address(self_worker)%val(i)) + idata2d(:,i) = ucat_ups(:,ucat_data_address(self_rank)%val(i)) ENDDO IF (allocated(ucat_next)) deallocate(ucat_next) @@ -950,8 +950,8 @@ SUBROUTINE build_riverlake_network () #ifdef CoLMDEBUG ! IF (p_is_compute) THEN - ! write(*,'(A,I0,A,I0,A,I0,A)') 'worker ', p_iam_compute, ' has ', numucat, & - ! ' unit catchment with ', sum(push_next2ucat%n_from_other), ' downstream to other workers' + ! write(*,'(A,I0,A,I0,A,I0,A)') 'rank ', p_iam_compute, ' has ', numucat, & + ! ' unit catchment with ', sum(push_next2ucat%n_from_other), ' downstream to other ranks' ! ENDIF #endif @@ -959,27 +959,27 @@ SUBROUTINE build_riverlake_network () #ifdef COLM_PARALLEL IF (p_is_root) THEN - self_worker = -1 - DO iworker = 0, p_np_compute-1 - nucat = numucat_wrk(iworker) + self_rank = -1 + DO irank = 0, p_np_compute-1 + nucat = numucat_rank(irank) IF (nucat > 0) THEN - IF (p_address_compute(iworker) == p_iam_glb) THEN - self_worker = iworker + IF (p_address_compute(irank) == p_iam_glb) THEN + self_rank = irank CYCLE ENDIF allocate (idata1d (nucat)) - idata1d = rivermouth(ucat_data_address(iworker)%val) - CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(iworker), & + idata1d = rivermouth(ucat_data_address(irank)%val) + CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) deallocate (idata1d) ENDIF ENDDO - IF (self_worker >= 0) THEN - nucat = numucat_wrk(self_worker) + IF (self_rank >= 0) THEN + nucat = numucat_rank(self_rank) allocate (idata1d (nucat)) - IF (nucat > 0) idata1d = rivermouth(ucat_data_address(self_worker)%val) + IF (nucat > 0) idata1d = rivermouth(ucat_data_address(self_rank)%val) IF (allocated(rivermouth)) deallocate(rivermouth) allocate (rivermouth (nucat)) IF (nucat > 0) rivermouth = idata1d @@ -1138,18 +1138,18 @@ SUBROUTINE build_riverlake_network () IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 - IF (numucat_wrk(iworker) > 0) THEN + DO irank = 0, p_np_compute-1 + IF (numucat_rank(irank) > 0) THEN - allocate (rdata1d (numucat_wrk(iworker))) - IF (p_address_compute(iworker) == p_iam_glb) THEN + allocate (rdata1d (numucat_rank(irank))) + IF (p_address_compute(irank) == p_iam_glb) THEN rdata1d = push_inpm2ucat%sum_area ELSE - CALL mpi_recv (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_compute(iworker), & + CALL mpi_recv (rdata1d, numucat_rank(irank), MPI_REAL8, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF - ucat_area_all(ucat_data_address(iworker)%val) = rdata1d + ucat_area_all(ucat_data_address(irank)%val) = rdata1d deallocate (rdata1d) ENDIF @@ -1184,31 +1184,31 @@ SUBROUTINE build_riverlake_network () #ifdef COLM_PARALLEL IF (p_is_root) THEN - self_worker = -1 - DO iworker = 0, p_np_compute-1 - IF (numucat_wrk(iworker) > 0) THEN - IF (p_address_compute(iworker) == p_iam_glb) THEN - self_worker = iworker + self_rank = -1 + DO irank = 0, p_np_compute-1 + IF (numucat_rank(irank) > 0) THEN + IF (p_address_compute(irank) == p_iam_glb) THEN + self_rank = irank CYCLE ENDIF - allocate (rdata1d (numucat_wrk(iworker))) - rdata1d = allups_mask_ucat(ucat_data_address(iworker)%val) + allocate (rdata1d (numucat_rank(irank))) + rdata1d = allups_mask_ucat(ucat_data_address(irank)%val) - CALL mpi_send (rdata1d, numucat_wrk(iworker), MPI_REAL8, p_address_compute(iworker), & + CALL mpi_send (rdata1d, numucat_rank(irank), MPI_REAL8, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) deallocate (rdata1d) ENDIF ENDDO - IF (self_worker >= 0) THEN - allocate (rdata1d (numucat_wrk(self_worker))) - IF (numucat_wrk(self_worker) > 0) & - rdata1d = allups_mask_ucat(ucat_data_address(self_worker)%val) + IF (self_rank >= 0) THEN + allocate (rdata1d (numucat_rank(self_rank))) + IF (numucat_rank(self_rank) > 0) & + rdata1d = allups_mask_ucat(ucat_data_address(self_rank)%val) IF (allocated(allups_mask_ucat)) deallocate(allups_mask_ucat) - allocate (allups_mask_ucat (numucat_wrk(self_worker))) - IF (numucat_wrk(self_worker) > 0) allups_mask_ucat = rdata1d + allocate (allups_mask_ucat (numucat_rank(self_rank))) + IF (numucat_rank(self_rank) > 0) allups_mask_ucat = rdata1d deallocate (rdata1d) ENDIF ENDIF @@ -1608,7 +1608,7 @@ SUBROUTINE check_mpas_embedded_downstream_ownership () IMPLICIT NONE logical, allocatable :: id_found(:) - integer :: i, iworker, ireq + integer :: i, irank, ireq integer :: local_missing, global_missing integer :: first_missing, global_first_missing @@ -1624,9 +1624,9 @@ SUBROUTINE check_mpas_embedded_downstream_ownership () IF (push_next2ucat%nself > 0) id_found(push_next2ucat%self_to) = .true. #ifdef COLM_PARALLEL - DO iworker = 0, p_np_compute-1 - IF (push_next2ucat%n_from_other(iworker) > 0) THEN - id_found(push_next2ucat%other_to(iworker)%val) = .true. + DO irank = 0, p_np_compute-1 + IF (push_next2ucat%n_from_other(irank) > 0) THEN + id_found(push_next2ucat%other_to(irank)%val) = .true. ENDIF ENDDO #endif @@ -1797,7 +1797,7 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat integer, allocatable, intent(inout), optional :: idata1d (:) ! Local Variables - integer :: iworker, nucat, ndim1, i + integer :: irank, nucat, ndim1, i real(r8), allocatable :: rsend1d (:) real(r8), allocatable :: rsend2d (:,:) integer, allocatable :: isend1d (:) @@ -1828,24 +1828,24 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat CALL mpi_bcast (ndim1, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) ENDIF - ! send unit catchment index to workers + ! send unit catchment index to ranks IF (p_is_root) THEN - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 - nucat = numucat_wrk(iworker) + nucat = numucat_rank(irank) IF (nucat > 0) THEN IF (present(rdata1d)) THEN allocate (rsend1d (nucat)) - rsend1d = rdata1d(ucat_data_address(iworker)%val) - IF (p_address_compute(iworker) == p_iam_glb) THEN + rsend1d = rdata1d(ucat_data_address(irank)%val) + IF (p_address_compute(irank) == p_iam_glb) THEN IF (allocated(rdata1d)) deallocate(rdata1d) allocate (rdata1d (nucat)) rdata1d = rsend1d ELSE - CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_compute(iworker), & + CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1856,14 +1856,14 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat allocate (rsend2d (ndim1,nucat)) DO i = 1, nucat - rsend2d(:,i) = rdata2d(:,ucat_data_address(iworker)%val(i)) + rsend2d(:,i) = rdata2d(:,ucat_data_address(irank)%val(i)) ENDDO - IF (p_address_compute(iworker) == p_iam_glb) THEN + IF (p_address_compute(irank) == p_iam_glb) THEN IF (allocated(rdata2d)) deallocate(rdata2d) allocate (rdata2d (ndim1,nucat)) rdata2d = rsend2d ELSE - CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_compute(iworker), & + CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -1873,13 +1873,13 @@ SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idat IF (present(idata1d)) THEN allocate (isend1d (nucat)) - isend1d = idata1d(ucat_data_address(iworker)%val) - IF (p_address_compute(iworker) == p_iam_glb) THEN + isend1d = idata1d(ucat_data_address(irank)%val) + IF (p_address_compute(irank) == p_iam_glb) THEN IF (allocated(idata1d)) deallocate(idata1d) allocate (idata1d (nucat)) idata1d = isend1d ELSE - CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_compute(iworker), & + CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_compute(irank), & mpi_tag_data, p_comm_glb, p_err) ENDIF @@ -2072,7 +2072,7 @@ SUBROUTINE riverlake_network_final () IF (allocated(ucat_ucid )) deallocate(ucat_ucid ) IF (allocated(ucat_gdid )) deallocate(ucat_gdid ) - IF (allocated(numucat_wrk )) deallocate(numucat_wrk ) + IF (allocated(numucat_rank )) deallocate(numucat_rank ) IF (allocated(ucat_data_address)) deallocate(ucat_data_address) IF (allocated(inpm_gdid )) deallocate(inpm_gdid ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 index 308e06f20b..35d7de3e75 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 @@ -16,7 +16,7 @@ MODULE MOD_Vector_ReadWrite CONTAINS ! ------- - SUBROUTINE vector_gather_to_master ( & + SUBROUTINE vector_gather_to_root ( & vector, vlen, totalvlen, data_address, wdata) USE MOD_Precision @@ -85,7 +85,7 @@ SUBROUTINE vector_gather_to_master ( & wdata(data_address(0)%val) = vector #endif - END SUBROUTINE vector_gather_to_master + END SUBROUTINE vector_gather_to_root ! ------- SUBROUTINE vector_gather_and_write ( vector, vlen, totalvlen, data_address, & @@ -118,7 +118,7 @@ SUBROUTINE vector_gather_and_write ( vector, vlen, totalvlen, data_address, & logical :: write_attr - CALL vector_gather_to_master (vector, vlen, totalvlen, data_address, wdata) + CALL vector_gather_to_root (vector, vlen, totalvlen, data_address, wdata) IF (p_is_root) THEN @@ -182,7 +182,7 @@ SUBROUTINE vector_gather_map2grid_and_write ( & real(r8), allocatable :: wdata(:), wdata2d(:,:) logical :: write_attr - CALL vector_gather_to_master (vector, vlen, totalvlen, data_address, wdata) + CALL vector_gather_to_root (vector, vlen, totalvlen, data_address, wdata) IF (p_is_root) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 index 684f4d7e2e..c4517c21cc 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 @@ -7,10 +7,10 @@ MODULE MOD_AggregationRequestData ! ! Aggregation Utilities. ! -! On IO processes, a data daemon is running to provide data -! at fine resolutions for worker processes. -! On worker processes, request is sent to IO processes and -! data is returned from IO processes. +! On IO ranks, a data daemon is running to provide data +! at fine resolutions for rank processes. +! On rank processes, request is sent to IO ranks and +! data is returned from IO ranks. ! ! Created by Shupeng Zhang, May 2023 !----------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 index 9c75e89a25..d810f957f0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 @@ -11,7 +11,7 @@ MODULE MOD_ComputePushData USE MOD_Utils IMPLICIT NONE - ! -- Data Type : push data between workers -- + ! -- Data Type : push data between ranks -- type :: compute_pushdata_type integer :: num_req_uniq @@ -38,7 +38,7 @@ MODULE MOD_ComputePushData END type compute_pushdata_type - ! -- Data Type : remap data on workers -- + ! -- Data Type : remap data on ranks -- type :: compute_remapdata_type integer :: num_grid @@ -97,7 +97,7 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq integer, allocatable :: ids(:), loc_from_me(:), loc_from_other(:) integer :: request(3) #endif - integer :: i, iloc, iworker, jworker, n_req_other + integer :: i, iloc, irank, jrank, n_req_other IF (p_is_compute) THEN @@ -146,25 +146,25 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq IF (n_req_uniq > 0) allocate (loc_from_other (n_req_uniq)) - iworker = modulo(p_iam_compute+1, p_np_compute) - jworker = modulo(p_iam_compute-1, p_np_compute) - DO WHILE (iworker /= p_iam_compute) + irank = modulo(p_iam_compute+1, p_np_compute) + jrank = modulo(p_iam_compute-1, p_np_compute) + DO WHILE (irank /= p_iam_compute) - CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jworker, 10, & + CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jrank, 10, & p_comm_compute, request(1), p_err) IF (n_req_uniq > 0) THEN - CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jworker, 11, & + CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jrank, 11, & p_comm_compute, request(2), p_err) ENDIF - CALL mpi_recv (n_req_other, 1, MPI_INTEGER, iworker, 10, & + CALL mpi_recv (n_req_other, 1, MPI_INTEGER, irank, 10, & p_comm_compute, p_stat, p_err) IF (n_req_other > 0) THEN allocate (ids (n_req_other)) - CALL mpi_recv (ids, n_req_other, MPI_INTEGER, iworker, 11, & + CALL mpi_recv (ids, n_req_other, MPI_INTEGER, irank, 11, & p_comm_compute, p_stat, p_err) allocate (loc_from_me (n_req_other)) @@ -179,13 +179,13 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq ENDDO ENDIF - pushdata%n_to_other(iworker) = count(loc_from_me > 0) - IF (pushdata%n_to_other(iworker) > 0) THEN - allocate (pushdata%to_other(iworker)%val (pushdata%n_to_other(iworker))) - pushdata%to_other(iworker)%val = pack(loc_from_me, loc_from_me > 0) + pushdata%n_to_other(irank) = count(loc_from_me > 0) + IF (pushdata%n_to_other(irank) > 0) THEN + allocate (pushdata%to_other(irank)%val (pushdata%n_to_other(irank))) + pushdata%to_other(irank)%val = pack(loc_from_me, loc_from_me > 0) ENDIF - CALL mpi_isend (loc_from_me, n_req_other, MPI_INTEGER, iworker, 12, & + CALL mpi_isend (loc_from_me, n_req_other, MPI_INTEGER, irank, 12, & p_comm_compute, request(3), p_err) ENDIF @@ -193,12 +193,12 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq IF (n_req_uniq > 0) THEN CALL mpi_recv (loc_from_other, n_req_uniq, MPI_INTEGER, & - jworker, 12, p_comm_compute, p_stat, p_err) + jrank, 12, p_comm_compute, p_stat, p_err) - pushdata%n_from_other(jworker) = count(loc_from_other > 0) - IF (pushdata%n_from_other(jworker) > 0) THEN - allocate (pushdata%other_to(jworker)%val (pushdata%n_from_other(jworker))) - pushdata%other_to(jworker)%val = pack((/(i,i=1,n_req_uniq)/), loc_from_other > 0) + pushdata%n_from_other(jrank) = count(loc_from_other > 0) + IF (pushdata%n_from_other(jrank) > 0) THEN + allocate (pushdata%other_to(jrank)%val (pushdata%n_from_other(jrank))) + pushdata%other_to(jrank)%val = pack((/(i,i=1,n_req_uniq)/), loc_from_other > 0) ENDIF ENDIF @@ -210,8 +210,8 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq IF (allocated(ids )) deallocate(ids ) IF (allocated(loc_from_me)) deallocate(loc_from_me) - iworker = modulo(iworker+1, p_np_compute) - jworker = modulo(jworker-1, p_np_compute) + irank = modulo(irank+1, p_np_compute) + jrank = modulo(jrank-1, p_np_compute) ENDDO IF (allocated (loc_from_other)) deallocate (loc_from_other) @@ -280,7 +280,7 @@ SUBROUTINE build_compute_pushdata_multi ( & type(compute_pushdata_type), intent(inout) :: pushdata ! Local Variables - integer :: ndim1, n_req_uniq, iloc, i, j, iworker + integer :: ndim1, n_req_uniq, iloc, i, j, irank integer, allocatable :: ids_req_uniq (:) logical, allocatable :: id_found (:) @@ -329,9 +329,9 @@ SUBROUTINE build_compute_pushdata_multi ( & IF (pushdata%nself > 0) id_found(pushdata%self_to) = .true. #ifdef COLM_PARALLEL - DO iworker = 0, p_np_compute-1 - IF (pushdata%n_from_other(iworker) > 0) THEN - id_found(pushdata%other_to(iworker)%val) = .true. + DO irank = 0, p_np_compute-1 + IF (pushdata%n_from_other(irank) > 0) THEN + id_found(pushdata%other_to(irank)%val) = .true. ENDIF ENDDO #endif @@ -373,7 +373,7 @@ SUBROUTINE build_compute_pushdata_subset ( & integer, optional, intent(inout) :: numsubset ! Local Variables - integer :: i, j, ii, jj, idsp, jdsp, kdsp, nsub, iworker + integer :: i, j, ii, jj, idsp, jdsp, kdsp, nsub, irank integer, allocatable :: nsub_me (:), nsub_req(:), nsub_req_uniq(:) integer, allocatable :: subdsp_me(:), subdsp_req_uniq(:) @@ -487,22 +487,22 @@ SUBROUTINE build_compute_pushdata_subset ( & allocate (pushdata_out%n_to_other (0:p_np_compute-1)) allocate (pushdata_out%to_other (0:p_np_compute-1)) - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 - pushdata_out%n_to_other(iworker) = 0 - DO i = 1, pushdata_in%n_to_other(iworker) - pushdata_out%n_to_other(iworker) = pushdata_out%n_to_other(iworker) & - + nsub_me(pushdata_in%to_other(iworker)%val(i)) + pushdata_out%n_to_other(irank) = 0 + DO i = 1, pushdata_in%n_to_other(irank) + pushdata_out%n_to_other(irank) = pushdata_out%n_to_other(irank) & + + nsub_me(pushdata_in%to_other(irank)%val(i)) ENDDO - IF (pushdata_out%n_to_other(iworker) > 0) THEN - allocate (pushdata_out%to_other(iworker)%val (pushdata_out%n_to_other(iworker))) + IF (pushdata_out%n_to_other(irank) > 0) THEN + allocate (pushdata_out%to_other(irank)%val (pushdata_out%n_to_other(irank))) kdsp = 0 - DO i = 1, pushdata_in%n_to_other(iworker) - IF (nsub_me(pushdata_in%to_other(iworker)%val(i)) > 0) THEN - nsub = nsub_me (pushdata_in%to_other(iworker)%val(i)) - idsp = subdsp_me(pushdata_in%to_other(iworker)%val(i)) - pushdata_out%to_other(iworker)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) + DO i = 1, pushdata_in%n_to_other(irank) + IF (nsub_me(pushdata_in%to_other(irank)%val(i)) > 0) THEN + nsub = nsub_me (pushdata_in%to_other(irank)%val(i)) + idsp = subdsp_me(pushdata_in%to_other(irank)%val(i)) + pushdata_out%to_other(irank)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) kdsp = kdsp + nsub ENDIF ENDDO @@ -513,21 +513,21 @@ SUBROUTINE build_compute_pushdata_subset ( & allocate (pushdata_out%n_from_other (0:p_np_compute-1)) allocate (pushdata_out%other_to (0:p_np_compute-1)) - DO iworker = 0, p_np_compute-1 - pushdata_out%n_from_other(iworker) = 0 - DO i = 1, pushdata_in%n_from_other(iworker) - pushdata_out%n_from_other(iworker) = pushdata_out%n_from_other(iworker) & - + nsub_req_uniq(pushdata_in%other_to(iworker)%val(i)) + DO irank = 0, p_np_compute-1 + pushdata_out%n_from_other(irank) = 0 + DO i = 1, pushdata_in%n_from_other(irank) + pushdata_out%n_from_other(irank) = pushdata_out%n_from_other(irank) & + + nsub_req_uniq(pushdata_in%other_to(irank)%val(i)) ENDDO - IF (pushdata_out%n_from_other(iworker) > 0) THEN - allocate (pushdata_out%other_to(iworker)%val (pushdata_out%n_from_other(iworker))) + IF (pushdata_out%n_from_other(irank) > 0) THEN + allocate (pushdata_out%other_to(irank)%val (pushdata_out%n_from_other(irank))) kdsp = 0 - DO i = 1, pushdata_in%n_from_other(iworker) - IF (nsub_req_uniq(pushdata_in%other_to(iworker)%val(i)) > 0) THEN - nsub = nsub_req_uniq (pushdata_in%other_to(iworker)%val(i)) - idsp = subdsp_req_uniq(pushdata_in%other_to(iworker)%val(i)) - pushdata_out%other_to(iworker)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) + DO i = 1, pushdata_in%n_from_other(irank) + IF (nsub_req_uniq(pushdata_in%other_to(irank)%val(i)) > 0) THEN + nsub = nsub_req_uniq (pushdata_in%other_to(irank)%val(i)) + idsp = subdsp_req_uniq(pushdata_in%other_to(irank)%val(i)) + pushdata_out%other_to(irank)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) kdsp = kdsp + nsub ENDIF ENDDO @@ -658,7 +658,7 @@ SUBROUTINE compute_push_data_uniq_real8 ( & integer, allocatable :: req_recv (:) real(r8), allocatable :: recvcache (:) - integer :: iworker, iproc, idsp, istt, iend, i, i_to + integer :: irank, iproc, idsp, istt, iend, i, i_to IF (p_is_compute) THEN @@ -680,15 +680,15 @@ SUBROUTINE compute_push_data_uniq_real8 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_compute-1 - IF (pushdata%n_to_other(iworker) > 0) THEN + DO irank = 0, p_np_compute-1 + IF (pushdata%n_to_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 - iend = idsp + pushdata%n_to_other(iworker) + iend = idsp + pushdata%n_to_other(irank) - sendcache(istt:iend) = vec_send(pushdata%to_other(iworker)%val) - CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(iworker), MPI_REAL8, & - iworker, 101, p_comm_compute, req_send(iproc), p_err) + sendcache(istt:iend) = vec_send(pushdata%to_other(irank)%val) + CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(irank), MPI_REAL8, & + irank, 101, p_comm_compute, req_send(iproc), p_err) idsp = iend ENDIF @@ -703,14 +703,14 @@ SUBROUTINE compute_push_data_uniq_real8 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_compute-1 - IF (pushdata%n_from_other(iworker) > 0) THEN + DO irank = 0, p_np_compute-1 + IF (pushdata%n_from_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 - iend = idsp + pushdata%n_from_other(iworker) + iend = idsp + pushdata%n_from_other(irank) - CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(iworker), MPI_REAL8, & - iworker, 101, p_comm_compute, req_recv(iproc), p_err) + CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(irank), MPI_REAL8, & + irank, 101, p_comm_compute, req_recv(iproc), p_err) idsp = iend ENDIF @@ -722,11 +722,11 @@ SUBROUTINE compute_push_data_uniq_real8 ( & CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) idsp = 0 - DO iworker = 0, p_np_compute-1 - DO i = 1, pushdata%n_from_other(iworker) + DO irank = 0, p_np_compute-1 + DO i = 1, pushdata%n_from_other(irank) IF (recvcache(idsp+i) /= fillvalue) THEN - i_to = pushdata%other_to(iworker)%val(i) + i_to = pushdata%other_to(irank)%val(i) IF (vec_recv(i_to) == fillvalue) THEN vec_recv(i_to) = recvcache(idsp+i) ELSE @@ -735,7 +735,7 @@ SUBROUTINE compute_push_data_uniq_real8 ( & ENDIF ENDDO - idsp = idsp + pushdata%n_from_other(iworker) + idsp = idsp + pushdata%n_from_other(irank) ENDDO ENDIF @@ -775,7 +775,7 @@ SUBROUTINE compute_push_data_uniq_int32 ( & integer, allocatable :: req_recv (:) integer, allocatable :: recvcache (:) - integer :: iworker, iproc, idsp, istt, iend, i, i_to + integer :: irank, iproc, idsp, istt, iend, i, i_to IF (p_is_compute) THEN @@ -797,15 +797,15 @@ SUBROUTINE compute_push_data_uniq_int32 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_compute-1 - IF (pushdata%n_to_other(iworker) > 0) THEN + DO irank = 0, p_np_compute-1 + IF (pushdata%n_to_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 - iend = idsp + pushdata%n_to_other(iworker) + iend = idsp + pushdata%n_to_other(irank) - sendcache(istt:iend) = vec_send(pushdata%to_other(iworker)%val) - CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(iworker), MPI_INTEGER, & - iworker, 101, p_comm_compute, req_send(iproc), p_err) + sendcache(istt:iend) = vec_send(pushdata%to_other(irank)%val) + CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(irank), MPI_INTEGER, & + irank, 101, p_comm_compute, req_send(iproc), p_err) idsp = iend ENDIF @@ -820,14 +820,14 @@ SUBROUTINE compute_push_data_uniq_int32 ( & iproc = 0 idsp = 0 - DO iworker = 0, p_np_compute-1 - IF (pushdata%n_from_other(iworker) > 0) THEN + DO irank = 0, p_np_compute-1 + IF (pushdata%n_from_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 - iend = idsp + pushdata%n_from_other(iworker) + iend = idsp + pushdata%n_from_other(irank) - CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(iworker), MPI_INTEGER, & - iworker, 101, p_comm_compute, req_recv(iproc), p_err) + CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(irank), MPI_INTEGER, & + irank, 101, p_comm_compute, req_recv(iproc), p_err) idsp = iend ENDIF @@ -839,11 +839,11 @@ SUBROUTINE compute_push_data_uniq_int32 ( & CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) idsp = 0 - DO iworker = 0, p_np_compute-1 - DO i = 1, pushdata%n_from_other(iworker) + DO irank = 0, p_np_compute-1 + DO i = 1, pushdata%n_from_other(irank) IF (recvcache(idsp+i) /= fillvalue) THEN - i_to = pushdata%other_to(iworker)%val(i) + i_to = pushdata%other_to(irank)%val(i) IF (vec_recv(i_to) == fillvalue) THEN vec_recv(i_to) = recvcache(idsp+i) ELSE @@ -852,7 +852,7 @@ SUBROUTINE compute_push_data_uniq_int32 ( & ENDIF ENDDO - idsp = idsp + pushdata%n_from_other(iworker) + idsp = idsp + pushdata%n_from_other(irank) ENDDO ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 index 8479808cac..4f14eaf2af 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 @@ -8,8 +8,8 @@ MODULE MOD_ElmVector ! ! Address of Data associated with land element. ! -! To output a vector, Data is gathered from worker processes directly to -! master. "elm_data_address" stores information on how to reorganize data +! To output a vector, Data is gathered from compute ranks directly to +! root rank. "elm_data_address" stores information on how to reorganize data ! gathered. The output data in vector is sorted by global element index. ! ! Created by Shupeng Zhang, May 2023 @@ -44,10 +44,10 @@ SUBROUTINE elm_vector_init ! Local Variables integer :: mesg(2), iwork, isrc, ndata - integer, allocatable :: numelm_worker (:) + integer, allocatable :: numelm_rank (:) integer :: i, idsp - integer, allocatable :: vec_worker_dsp (:) + integer, allocatable :: vec_rank_dsp (:) integer*8, allocatable :: indexelm (:) integer, allocatable :: order (:) @@ -63,13 +63,13 @@ SUBROUTINE elm_vector_init indexelm = landelm%eindex ENDIF - IF (p_iam_compute == p_root) allocate (numelm_worker (0:p_np_compute-1)) + IF (p_iam_compute == p_root) allocate (numelm_rank (0:p_np_compute-1)) CALL mpi_gather (numelm, 1, MPI_INTEGER, & - numelm_worker, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) + numelm_rank, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) IF (p_iam_compute == p_root) THEN #ifndef MPAS_EMBEDDED_COLM - CALL mpi_send (numelm_worker, p_np_compute, MPI_INTEGER, & + CALL mpi_send (numelm_rank, p_np_compute, MPI_INTEGER, & p_address_root, mpi_tag_size, p_comm_glb, p_err) #endif ENDIF @@ -96,34 +96,34 @@ SUBROUTINE elm_vector_init IF (p_is_root) THEN #ifdef USEMPI #ifndef MPAS_EMBEDDED_COLM - allocate (numelm_worker (0:p_np_compute-1)) - CALL mpi_recv (numelm_worker, p_np_compute, MPI_INTEGER, p_address_compute(p_root), & + allocate (numelm_rank (0:p_np_compute-1)) + CALL mpi_recv (numelm_rank, p_np_compute, MPI_INTEGER, p_address_compute(p_root), & mpi_tag_size, p_comm_glb, p_stat, p_err) #endif - allocate (vec_worker_dsp (0:p_np_compute-1)) - vec_worker_dsp(0) = 0 + allocate (vec_rank_dsp (0:p_np_compute-1)) + vec_rank_dsp(0) = 0 DO iwork = 1, p_np_compute-1 - vec_worker_dsp(iwork) = vec_worker_dsp(iwork-1) + numelm_worker(iwork-1) + vec_rank_dsp(iwork) = vec_rank_dsp(iwork-1) + numelm_rank(iwork-1) ENDDO - totalnumelm = sum(numelm_worker) + totalnumelm = sum(numelm_rank) allocate (eindex_glb (totalnumelm)) allocate (elm_data_address(0:p_np_compute-1)) DO iwork = 0, p_np_compute-1 - IF (numelm_worker(iwork) > 0) THEN - allocate (elm_data_address(iwork)%val (numelm_worker(iwork))) + IF (numelm_rank(iwork) > 0) THEN + allocate (elm_data_address(iwork)%val (numelm_rank(iwork))) ENDIF ENDDO DO iwork = 0, p_np_compute-1 #ifdef MPAS_EMBEDDED_COLM IF (iwork == p_root) THEN - ndata = numelm_worker(iwork) + ndata = numelm_rank(iwork) IF (ndata > 0) THEN - idsp = vec_worker_dsp(iwork) + idsp = vec_rank_dsp(iwork) eindex_glb(idsp+1:idsp+ndata) = indexelm(1:ndata) ENDIF CYCLE @@ -135,7 +135,7 @@ SUBROUTINE elm_vector_init isrc = mesg(1) ndata = mesg(2) IF (ndata > 0) THEN - idsp = vec_worker_dsp(p_itis_compute(isrc)) + idsp = vec_rank_dsp(p_itis_compute(isrc)) CALL mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -159,16 +159,16 @@ SUBROUTINE elm_vector_init #ifdef USEMPI DO i = 1, totalnumelm - iwork = findloc_ud(order(i) > vec_worker_dsp, back=.true.) - 1 - elm_data_address(iwork)%val(order(i)-vec_worker_dsp(iwork)) = i + iwork = findloc_ud(order(i) > vec_rank_dsp, back=.true.) - 1 + elm_data_address(iwork)%val(order(i)-vec_rank_dsp(iwork)) = i ENDDO #else elm_data_address(0)%val (order) = (/(i, i=1,totalnumelm)/) #endif ENDIF - IF (allocated(numelm_worker)) deallocate(numelm_worker) - IF (allocated(vec_worker_dsp)) deallocate(vec_worker_dsp) + IF (allocated(numelm_rank)) deallocate(numelm_rank) + IF (allocated(vec_rank_dsp)) deallocate(vec_rank_dsp) IF (allocated(indexelm)) deallocate(indexelm) IF (allocated(order)) deallocate(order) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 index ebb675e94a..8115d9cab3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 @@ -8,8 +8,8 @@ MODULE MOD_HRUVector ! ! Address of Data associated with HRU. ! -! To output a vector, Data is gathered from worker processes directly to -! master. "hru_data_address" stores information on how to reorganize data +! To output a vector, Data is gathered from compute ranks directly to +! root rank. "hru_data_address" stores information on how to reorganize data ! gathered. The output data in vector is sorted by global element index ! (i.e. catchment index) ! diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 index f2c13dca93..907bbe3b67 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -129,7 +129,7 @@ SUBROUTINE mesh_build () integer :: nelm, ie, je, dsp integer :: iblkme, iblk, jblk, xloc, yloc, xg, yg, ixloc, iyloc integer :: xp, yp, xblk, yblk, npxl, ipxl, ix, iy - integer :: iworker, iproc, idest, isrc, iloc, iloc_max(2) + integer :: irank, iproc, idest, isrc, iloc, iloc_max(2) integer :: ylg, yug, ysp, ynp, nyp integer :: xlg, xug, xwp, xep, nxp real(r8) :: dlatp, dlonp @@ -137,8 +137,8 @@ SUBROUTINE mesh_build () integer :: smesg(6), rmesg(6), blktag, nsend, nrecv, irecv integer :: iblk_p, jblk_p, nelm_max_blk, nelm_glb - integer, allocatable :: nelm_worker(:) - type(pointer_int64_1d), allocatable :: elist_worker(:) + integer, allocatable :: nelm_rank(:) + type(pointer_int64_1d), allocatable :: elist_rank(:) integer*8 :: elmid integer*8, allocatable :: elist(:), elist2(:,:), sbuf64(:), elist_recv(:) @@ -178,12 +178,12 @@ SUBROUTINE mesh_build () nelm = 0 - allocate (nelm_worker (0:p_np_compute-1)) - nelm_worker(:) = 0 + allocate (nelm_rank (0:p_np_compute-1)) + nelm_rank(:) = 0 - allocate (elist_worker (0:p_np_compute-1)) - DO iworker = 0, p_np_compute-1 - allocate (elist_worker(iworker)%val (1000)) + allocate (elist_rank (0:p_np_compute-1)) + DO irank = 0, p_np_compute-1 + allocate (elist_rank(irank)%val (1000)) ENDDO DO iblkme = 1, gblock%nblkme @@ -214,12 +214,12 @@ SUBROUTINE mesh_build () IF (elmid > 0) THEN - iworker = mod(elmid, p_np_compute) + irank = mod(elmid, p_np_compute) CALL insert_into_sorted_list1 ( & - elmid, nelm_worker(iworker), elist_worker(iworker)%val, iloc) + elmid, nelm_rank(irank), elist_rank(irank)%val, iloc) - IF (nelm_worker(iworker) == size(elist_worker(iworker)%val)) THEN - CALL expand_list (elist_worker(iworker)%val, 0.2_r8) + IF (nelm_rank(irank) == size(elist_rank(irank)%val)) THEN + CALL expand_list (elist_rank(irank)%val, 0.2_r8) ENDIF ENDIF @@ -228,10 +228,10 @@ SUBROUTINE mesh_build () ENDDO #ifdef USEMPI - DO iworker = 0, p_np_compute-1 - IF (nelm_worker(iworker) > 0) THEN - idest = p_address_compute(iworker) - smesg(1:2) = (/p_iam_glb, nelm_worker(iworker)/) + DO irank = 0, p_np_compute-1 + IF (nelm_rank(irank) > 0) THEN + idest = p_address_compute(irank) + smesg(1:2) = (/p_iam_glb, nelm_rank(irank)/) ! send(01) CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & idest, mpi_tag_size, p_comm_glb, p_err) @@ -239,13 +239,13 @@ SUBROUTINE mesh_build () ENDDO #endif - nelm = nelm + sum(nelm_worker) - nelm_worker(:) = 0 + nelm = nelm + sum(nelm_rank) + nelm_rank(:) = 0 ENDDO #ifdef USEMPI - DO iworker = 0, p_np_compute-1 - idest = p_address_compute(iworker) + DO irank = 0, p_np_compute-1 + idest = p_address_compute(irank) ! send(02) smesg(1:2) = (/p_iam_glb, 0/) CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & @@ -253,11 +253,11 @@ SUBROUTINE mesh_build () ENDDO #endif - deallocate (nelm_worker) - DO iworker = 0, p_np_compute-1 - deallocate (elist_worker(iworker)%val) + deallocate (nelm_rank) + DO irank = 0, p_np_compute-1 + deallocate (elist_rank(irank)%val) ENDDO - deallocate (elist_worker) + deallocate (elist_rank) ENDIF @@ -480,8 +480,8 @@ SUBROUTINE mesh_build () ENDDO #ifdef USEMPI - DO iworker = 0, p_np_compute-1 - idest = p_address_compute(iworker) + DO irank = 0, p_np_compute-1 + idest = p_address_compute(irank) ! send(07) smesg(1:3) = (/p_iam_glb, 0, 0/) CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & @@ -625,7 +625,7 @@ SUBROUTINE mesh_build () MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) #endif - ! Step 4: IF MPI is used, sending elms from worker to their IO processes. + ! Step 4: IF MPI is used, sending elms from rank to their IO processes. IF (p_is_active) THEN @@ -865,10 +865,10 @@ SUBROUTINE mesh_build () deallocate (meshtmp ) ENDIF - ! Step 5: IF MPI is used, scatter elms from IO to workers. + ! Step 5: IF MPI is used, scatter elms from IO to ranks. #ifdef USEMPI #ifndef MPAS_EMBEDDED_COLM - CALL scatter_mesh_from_io_to_worker () + CALL scatter_mesh_legacy_roles () #endif #endif @@ -915,7 +915,7 @@ END SUBROUTINE mesh_build #ifdef USEMPI #ifndef MPAS_EMBEDDED_COLM ! -------------------------------- - SUBROUTINE scatter_mesh_from_io_to_worker + SUBROUTINE scatter_mesh_legacy_roles USE MOD_SPMD_Task USE MOD_Block @@ -924,7 +924,7 @@ SUBROUTINE scatter_mesh_from_io_to_worker ! Local variables integer :: iblk, jblk, nave, nres, iproc, ndsp, nsend, idest, ie integer :: smesg(4), rmesg(4) - integer, allocatable :: nelm_worker(:) + integer, allocatable :: nelm_rank(:) integer :: iblkme character(len=20) :: wfmt @@ -932,8 +932,8 @@ SUBROUTINE scatter_mesh_from_io_to_worker IF (p_is_active) THEN - allocate (nelm_worker (1:p_np_group-1)) - nelm_worker(:) = 0 + allocate (nelm_rank (1:p_np_group-1)) + nelm_rank(:) = 0 DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -942,23 +942,23 @@ SUBROUTINE scatter_mesh_from_io_to_worker nave = nelm_blk(iblk,jblk) / (p_np_group-1) nres = mod(nelm_blk(iblk,jblk), p_np_group-1) DO iproc = 1, p_np_group-1 - nelm_worker(iproc) = nelm_worker(iproc) + nave - IF (iproc <= nres) nelm_worker(iproc) = nelm_worker(iproc) + 1 + nelm_rank(iproc) = nelm_rank(iproc) + nave + IF (iproc <= nres) nelm_rank(iproc) = nelm_rank(iproc) + 1 ENDDO ENDDO - IF (any(nelm_worker == 0)) THEN - write(*,'(A,/,A)') 'Warning: there are idle workers, please use less processors ' // & + IF (any(nelm_rank == 0)) THEN + write(*,'(A,/,A)') 'Warning: there are idle ranks, please use less processors ' // & 'OR larger working group ', ' (set by DEF_PIO_groupsize in CoLM namelist).' write(wfmt,'(A,I0,A)') '(A,I6,A,', p_np_group-1, '(X,I0))' - write(*,wfmt) 'Numbers of elements by workers in group ', p_iam_glb, ' are ', nelm_worker + write(*,wfmt) 'Numbers of elements by ranks in group ', p_iam_glb, ' are ', nelm_rank ENDIF DO iproc = 1, p_np_group-1 - CALL mpi_send (nelm_worker(iproc), 1, MPI_INTEGER, & + CALL mpi_send (nelm_rank(iproc), 1, MPI_INTEGER, & iproc, mpi_tag_size, p_comm_group, p_err) ENDDO - deallocate (nelm_worker) + deallocate (nelm_rank) ndsp = 0 DO iblkme = 1, gblock%nblkme @@ -1022,7 +1022,7 @@ SUBROUTINE scatter_mesh_from_io_to_worker CALL mpi_barrier (p_comm_glb, p_err) - END SUBROUTINE scatter_mesh_from_io_to_worker + END SUBROUTINE scatter_mesh_legacy_roles #endif #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 index 9597e3c662..4e0c56a636 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 @@ -48,8 +48,8 @@ MODULE MOD_Namelist integer :: DEF_nx_blocks = 72 integer :: DEF_ny_blocks = 36 - ! A group includes one "IO" process and several "worker" processes. - ! Its size determines number of IOs in a job. + ! Standalone CoLM used this to size its role-split groups. + ! MPAS-embedded CoLM maps all active ranks to MPAS compute ranks. integer :: DEF_PIO_groupsize = 12 logical :: DEF_nIO_eq_nBlock = .false. @@ -165,7 +165,7 @@ MODULE MOD_Namelist ! 2: Read a global soil color map from CLM integer :: DEF_SOIL_REFL_SCHEME = 2 - ! ----- merge data in aggregation when send data from IO to worker ----- + ! ----- merge data in aggregation when send data from IO to compute rank ----- logical :: USE_zip_for_aggregation = .true. ! ----- compress level in writing aggregated surface data ----- diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 index a2e62143dc..68f36f0231 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 @@ -9,8 +9,7 @@ MODULE MOD_NetCDFBlock ! ! CoLM read and write netCDF files mainly in three ways: ! 1. Serial: read and write data by a single process; -! 2. Vector: 1) read vector data by IO and scatter from IO to workers -! 2) gather from workers to IO and write vectors by IO +! 2. Vector: read/write data associated with CoLM pixelsets ! Notice: each file contains vector data in one block. ! 3. Block : read blocked data by IO ! Notice: input file is a single file. diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 index 63213746ff..f025d752d3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 @@ -9,8 +9,7 @@ MODULE MOD_NetCDFSerial ! ! CoLM read and write netCDF files mainly in three ways: ! 1. Serial: read and write data by a single process; -! 2. Vector: 1) read vector data by IO and scatter from IO to workers -! 2) gather from workers to IO and write vectors by IO +! 2. Vector: read/write data associated with CoLM pixelsets ! Notice: each file CONTAINS vector data in one block. ! 3. Block : read blocked data by IO ! Notice: input file is a single file. diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 index 76694f6926..f803c3d468 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -11,8 +11,7 @@ ! ! CoLM read and write netCDF files mainly in three ways: ! 1. Serial: read and write data by a single process; -! 2. Vector: 1) read vector data by IO and scatter from IO to workers -! 2) gather from workers to IO and write vectors by IO +! 2. Vector: read/write data associated with CoLM pixelsets ! 3. Block : read blocked data by IO ! Notice: input file is a single file. ! @@ -240,7 +239,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & ENDIF CALL mpi_scatterv ( & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & p_root, p_comm_group, p_err) @@ -364,7 +363,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & ENDIF CALL mpi_scatterv ( & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & p_root, p_comm_group, p_err) @@ -492,7 +491,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & ENDIF CALL mpi_scatterv ( & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! unused on non-root ranks rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & p_root, p_comm_group, p_err) @@ -617,7 +616,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & ENDIF CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & p_root, p_comm_group, p_err) @@ -743,7 +742,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & ENDIF CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks rbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & p_root, p_comm_group, p_err) @@ -869,7 +868,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & ENDIF CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks rbuff, ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & p_root, p_comm_group, p_err) @@ -995,7 +994,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & ENDIF CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & p_root, p_comm_group, p_err) @@ -1122,7 +1121,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & ENDIF CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & p_root, p_comm_group, p_err) @@ -1287,7 +1286,7 @@ SUBROUTINE ncio_write_vector_int32_1d ( & CALL mpi_gatherv ( & sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1385,7 +1384,7 @@ SUBROUTINE ncio_write_vector_logical_1d ( & CALL mpi_gatherv ( & sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1474,7 +1473,7 @@ SUBROUTINE ncio_write_vector_int32_3d ( & CALL mpi_gatherv ( & sbuff, ndim1*ndim2*pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1560,7 +1559,7 @@ SUBROUTINE ncio_write_vector_int64_1d ( & CALL mpi_gatherv ( & sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1646,7 +1645,7 @@ SUBROUTINE ncio_write_vector_real8_1d ( & CALL mpi_gatherv ( & sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1736,7 +1735,7 @@ SUBROUTINE ncio_write_vector_real8_2d ( & CALL mpi_gatherv ( & sbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1825,7 +1824,7 @@ SUBROUTINE ncio_write_vector_real8_3d ( & CALL mpi_gatherv ( sbuff, & ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -1914,7 +1913,7 @@ SUBROUTINE ncio_write_vector_real8_4d ( & CALL mpi_gatherv ( sbuff, & ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) @@ -2004,7 +2003,7 @@ SUBROUTINE ncio_write_vector_real8_5d ( & CALL mpi_gatherv ( sbuff, & ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks p_root, p_comm_group, p_err) IF (allocated(sbuff)) deallocate (sbuff) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 index aa22b27d0d..785b27b7de 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -38,9 +38,8 @@ MODULE MOD_Pixelset ! "Vector" is a collection of data when each pixelset in a given level is associated ! with a value, representing its averaged physical, chemical or biological state. ! -! "Vector" is usually defined on worker process, while its IO is through IO process. -! To read, vector is first loaded from files by IO and then scattered from IO to worker. -! To write, vector is first gathered from worker to IO and then saved to files by IO. +! In standalone CoLM, vector data may be redistributed between ranks for IO. +! MPAS-embedded CoLM keeps land vectors on MPAS-owned cell subsets. ! ! Created by Shupeng Zhang, May 2023 !------------------------------------------------------------------------------------ @@ -52,14 +51,14 @@ MODULE MOD_Pixelset ! ---- data types ---- type :: vec_gather_scatter_type - ! for worker and io + ! rank-local vector layout integer, allocatable :: vlen(:,:) - ! for worker + ! local vector offsets integer, allocatable :: vstt(:,:) integer, allocatable :: vend(:,:) - ! for io + ! gathered vector counts/displacements integer, allocatable :: vcnt(:,:,:) integer, allocatable :: vdsp(:,:,:) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 index c7de99cc96..e66c2dc779 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 @@ -9,7 +9,7 @@ MODULE MOD_RangeCheck ! ! Notice that: ! 1. "check_block_data" can only be called by IO processes. -! 2. "check_vector_data" can only be called by worker processes. +! 2. "check_vector_data" can only be called by compute ranks. ! ! Created by Shupeng Zhang, May 2023 !----------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 index 730feb831e..1cd796c060 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 @@ -112,7 +112,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) integer :: ie, iset, iblkme integer :: ng, ig, ng_all, iloc integer :: npxl, ipxl, ilat, ilon - integer :: iworker, iproc, idest, isrc, nrecv + integer :: irank, iproc, idest, isrc, nrecv integer :: rmesg(2), smesg(2) integer :: iy, ix, xblk, yblk, xloc, yloc integer :: ipxstt, ipxend @@ -473,7 +473,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) allocate (this%glist (0:p_np_compute-1)) - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 CALL mpi_recv (rmesg, 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) @@ -560,7 +560,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) integer :: iset, ilat, ilon, iwest, ieast, ie, ipxl integer :: nglist, iloc, ng, ig - integer :: iworker, iproc, iio, idest, isrc, nrecv + integer :: irank, iproc, iio, idest, isrc, nrecv integer :: rmesg(2), smesg(2) integer :: iy, ix, xblk, yblk, xloc, yloc integer :: ipxstt, ipxend @@ -806,7 +806,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) allocate (this%glist (0:p_np_compute-1)) - DO iworker = 0, p_np_compute-1 + DO irank = 0, p_np_compute-1 CALL mpi_recv (rmesg, 2, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 index 5f3d9b9e32..f5b30ce741 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -35,8 +35,8 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) ! Local variables character(len=256) :: filename, fileblock, cyear - integer :: ie, je, nelm, totlen, tothis, iblk, jblk, iworker, i - integer, allocatable :: nelm_worker(:), ndsp_worker(:) + integer :: ie, je, nelm, totlen, tothis, iblk, jblk, owner_rank, i + integer, allocatable :: nelm_rank(:), ndsp_rank(:) integer*8, allocatable :: elmindx(:) integer, allocatable :: npxlall(:) integer, allocatable :: elmpixels(:,:) @@ -106,11 +106,11 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err) CALL mpi_gatherv (elmindx, nelm, MPI_INTEGER8, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks p_root, p_comm_group, p_err) CALL mpi_gatherv (npxlall, nelm, MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks p_root, p_comm_group, p_err) ndone = 0 @@ -130,44 +130,44 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) IF (p_is_active) THEN IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - allocate (nelm_worker (0:p_np_group-1)) - nelm_worker(0) = 0 + allocate (nelm_rank (0:p_np_group-1)) + nelm_rank(0) = 0 CALL mpi_gather (MPI_IN_PLACE, 0, MPI_INTEGER, & - nelm_worker, 1, MPI_INTEGER, p_root, p_comm_group, p_err) + nelm_rank, 1, MPI_INTEGER, p_root, p_comm_group, p_err) - nelm = sum(nelm_worker) + nelm = sum(nelm_rank) - allocate (ndsp_worker(0:p_np_group-1)) - ndsp_worker(0) = 0 - DO iworker = 1, p_np_group-1 - ndsp_worker(iworker) = ndsp_worker(iworker-1) + nelm_worker(iworker-1) + allocate (ndsp_rank(0:p_np_group-1)) + ndsp_rank(0) = 0 + DO owner_rank = 1, p_np_group-1 + ndsp_rank(owner_rank) = ndsp_rank(owner_rank-1) + nelm_rank(owner_rank-1) ENDDO allocate (elmindx (nelm)) CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & - elmindx, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER8, & + elmindx, nelm_rank(0:), ndsp_rank(0:), MPI_INTEGER8, & p_root, p_comm_group, p_err) allocate (npxlall (nelm)) CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & - npxlall, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER, & + npxlall, nelm_rank(0:), ndsp_rank(0:), MPI_INTEGER, & p_root, p_comm_group, p_err) totlen = sum(npxlall) allocate (elmpixels (2, totlen)) ndone = 0 - DO iworker = 1, p_np_group-1 + DO owner_rank = 1, p_np_group-1 - ndsp = ndsp_worker(iworker) - tothis = ndone + sum(npxlall(ndsp+1:ndsp+nelm_worker(iworker))) + ndsp = ndsp_rank(owner_rank) + tothis = ndone + sum(npxlall(ndsp+1:ndsp+nelm_rank(owner_rank))) DO WHILE (ndone < tothis) CALL mpi_recv (nrecv, 1, & - MPI_INTEGER, iworker, mpi_tag_size, p_comm_group, p_stat, p_err) + MPI_INTEGER, owner_rank, mpi_tag_size, p_comm_group, p_stat, p_err) CALL mpi_recv (elmpixels(:,ndone+1:ndone+nrecv), 2*nrecv, & - MPI_INTEGER, iworker, mpi_tag_data, p_comm_group, p_stat, p_err) + MPI_INTEGER, owner_rank, mpi_tag_data, p_comm_group, p_stat, p_err) ndone = ndone + nrecv ENDDO @@ -198,8 +198,8 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) IF (allocated (npxlall)) deallocate(npxlall) IF (allocated (elmpixels)) deallocate(elmpixels) - IF (allocated (nelm_worker)) deallocate(nelm_worker) - IF (allocated (ndsp_worker)) deallocate(ndsp_worker) + IF (allocated (nelm_rank)) deallocate(nelm_rank) + IF (allocated (ndsp_rank)) deallocate(ndsp_rank) #ifdef USEMPI CALL mpi_barrier (p_comm_group, p_err) @@ -459,7 +459,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) #ifdef USEMPI #ifndef MPAS_EMBEDDED_COLM - CALL scatter_mesh_from_io_to_worker + CALL scatter_mesh_legacy_roles #endif CALL mpi_barrier (p_comm_glb, p_err) #endif @@ -551,7 +551,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc integer :: nsend, nrecv integer*8, allocatable :: rbuff(:), sbuff(:) integer*8, allocatable :: subset_sorted(:) - integer, allocatable :: iworker(:) + integer, allocatable :: owner_rank(:) logical, allocatable :: msk(:) logical, allocatable :: keep_set(:) logical :: fexists, fexists_any @@ -714,7 +714,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc #if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) IF (p_is_active) THEN IF (pixelset%nset > 0) THEN - allocate (iworker (pixelset%nset)) + allocate (owner_rank (pixelset%nset)) allocate (msk (pixelset%nset)) ie = 1 @@ -736,14 +736,14 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc nres = mod(nelm_blk(iblk,jblk), p_np_group-1) left = (nave+1) * nres IF (je <= left) THEN - iworker(iset) = (je-1) / (nave+1) + 1 + owner_rank(iset) = (je-1) / (nave+1) + 1 ELSE - iworker(iset) = (je-left-1) / nave + 1 + nres + owner_rank(iset) = (je-left-1) / nave + 1 + nres ENDIF ENDDO DO iproc = 1, p_np_group-1 - msk = (iworker == iproc) + msk = (owner_rank == iproc) nsend = count(msk) CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err) @@ -796,7 +796,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDDO ELSE - write(*,*) 'Warning: 0 ',trim(psetname), ' on worker :', p_iam_glb + write(*,*) 'Warning: 0 ',trim(psetname), ' on rank :', p_iam_glb ENDIF ENDIF From d427fe077b5a3fa0ab528d8ca9e3c53a373bd6e5 Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Fri, 3 Jul 2026 11:51:08 +0800 Subject: [PATCH 13/17] Keep embedded river systems independent Constraint: MPAS ranks can own multiple CoLM river systems while CoLM still routes through the MPAS compute communicator. Rejected: Collapsing embedded GridRiverLakeFlow to one river system | couples unrelated rivers and forces a global routing timestep. Confidence: medium Scope-risk: moderate Directive: Preserve river-mouth keyed irivsys mapping in embedded mode; do not restore irivsys(:)=1 there. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; cmake --build build-cmake-colm-debug --target install -j 8 Not-tested: Real multi-rank MPAS+CoLM river-routing case with split river systems. --- .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 35 ++++- .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 146 ++++++++++++++++-- 2 files changed, 159 insertions(+), 22 deletions(-) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index e2768a3c8c..e14b03e58c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -132,6 +132,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) real(r8) :: volwater, friction, floodarea real(r8), allocatable :: dt_res(:), dt_all(:) logical, allocatable :: ucatfilter(:) + real(r8) :: global_dt_remaining(1) #ifdef CoLMDEBUG real(r8) :: totalvol_bef, totalvol_aft, totalrnof, totaldis #endif @@ -300,9 +301,19 @@ SUBROUTINE grid_riverlake_flow (year, deltime) totaldis = 0. #endif - dt_res(:) = acctime_rnof + dt_res(:) = 0._r8 + DO i = 1, numucat + dt_res(irivsys(i)) = acctime_rnof + ENDDO - DO WHILE (any(dt_res > 0)) + global_dt_remaining(1) = maxval(dt_res) +#ifdef COLM_PARALLEL + IF (rivsys_by_multiple_procs) THEN + CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, p_comm_rivsys, p_err) + ENDIF +#endif + + DO WHILE (global_dt_remaining(1) > 0._r8) ntimestep = ntimestep + 1 @@ -310,11 +321,14 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ! velocity in ocean or inland depression is assumed to be 0. CALL compute_push_data (push_next2ucat, veloc_riv, veloc_next, fillvalue = 0.) - dt_all(:) = min(dt_res(:), 60.) + dt_all(:) = huge(1._r8) + WHERE (dt_res > 0._r8) + dt_all = min(dt_res, 60._r8) + END WHERE DO i = 1, numucat - ucatfilter(i) = dt_all(irivsys(i)) > 0 + ucatfilter(i) = dt_res(irivsys(i)) > 0._r8 IF (.not. ucatfilter(i)) CYCLE @@ -551,7 +565,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #ifdef COLM_PARALLEL IF (rivsys_by_multiple_procs) THEN - CALL mpi_allreduce (MPI_IN_PLACE, dt_all, 1, MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, dt_all, size(dt_all), MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err) ENDIF #endif @@ -639,7 +653,16 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDIF ENDDO - dt_res = dt_res - dt_all + WHERE (dt_res > 0._r8) + dt_res = max(0._r8, dt_res - dt_all) + END WHERE + + global_dt_remaining(1) = maxval(dt_res) +#ifdef COLM_PARALLEL + IF (rivsys_by_multiple_procs) THEN + CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, p_comm_rivsys, p_err) + ENDIF +#endif #ifdef GridRiverLakeSediment IF (DEF_USE_SEDIMENT) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index d853844134..b3d21e2243 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -1252,7 +1252,6 @@ SUBROUTINE build_riverlake_network_mpas_embedded () integer, allocatable :: idmap_x(:,:), idmap_y(:,:) integer :: nlat_ucat, nlon_ucat integer :: inpn - integer :: p_np_rivsys integer :: i, j parafile = DEF_UnitCatchment_file @@ -1323,21 +1322,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) ENDIF -#ifdef COLM_PARALLEL - IF (p_is_compute) THEN - p_comm_rivsys = p_comm_compute - CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) - rivsys_by_multiple_procs = p_np_rivsys > 1 - ENDIF -#else - rivsys_by_multiple_procs = .false. -#endif - - IF (p_is_compute) THEN - allocate (irivsys (numucat)) - numrivsys = 1 - IF (numucat > 0) irivsys(:) = 1 - ENDIF + CALL build_mpas_embedded_river_systems (parafile) CALL readin_riverlake_parameter (parafile, 'topo_rivelv', rdata1d = topo_rivelv ) CALL readin_riverlake_parameter (parafile, 'topo_rivhgt', rdata1d = topo_rivhgt ) @@ -1419,6 +1404,135 @@ SUBROUTINE build_riverlake_network_mpas_embedded () END SUBROUTINE build_riverlake_network_mpas_embedded + ! --------- + SUBROUTINE build_mpas_embedded_river_systems (parafile) + + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + + integer, allocatable :: mouth_id(:), next_id(:) + integer, allocatable :: request(:), request_order(:), request_next(:) + integer, allocatable :: local_mouths(:), all_mouths(:), global_mouths(:) +#ifdef COLM_PARALLEL + integer, allocatable :: counts(:), displs(:) +#endif + integer :: i, iloc, nactive, niter, nlocal_mouths, total_mouths + logical :: is_new + + IF (.not. p_is_compute) RETURN + + allocate (irivsys (numucat)) + allocate (mouth_id (numucat)) + allocate (local_mouths (max(1,numucat))) + mouth_id(:) = 0 + + IF (numucat > 0) THEN + allocate (next_id (numucat)) + next_id = ucat_next + + DO i = 1, numucat + IF (next_id(i) <= 0) THEN + mouth_id(i) = ucat_ucid(i) + ENDIF + ENDDO + + nactive = count(next_id > 0) + niter = 0 + DO WHILE (nactive > 0) + niter = niter + 1 + IF (niter > totalnumucat) THEN + CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network has a downstream cycle.') + ENDIF + + allocate (request (nactive)) + allocate (request_order (nactive)) + iloc = 0 + DO i = 1, numucat + IF (next_id(i) > 0) THEN + iloc = iloc + 1 + request(iloc) = next_id(i) + request_order(iloc) = i + ENDIF + ENDDO + + CALL quicksort (nactive, request, request_order) + CALL ncio_read_indexed_serial (parafile, 'seq_next', request, request_next) + + nactive = 0 + DO iloc = 1, size(request) + i = request_order(iloc) + IF (request_next(iloc) > 0) THEN + next_id(i) = request_next(iloc) + nactive = nactive + 1 + ELSE + mouth_id(i) = request(iloc) + next_id(i) = 0 + ENDIF + ENDDO + + deallocate (request) + deallocate (request_order) + deallocate (request_next) + ENDDO + + deallocate (next_id) + ENDIF + + nlocal_mouths = 0 + DO i = 1, numucat + CALL insert_into_sorted_list1 (mouth_id(i), nlocal_mouths, local_mouths, iloc, is_new) + ENDDO + +#ifdef COLM_PARALLEL + allocate (counts (0:p_np_compute-1)) + allocate (displs (0:p_np_compute-1)) + CALL mpi_allgather (nlocal_mouths, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, p_comm_compute, p_err) + + displs(0) = 0 + DO i = 1, p_np_compute-1 + displs(i) = displs(i-1) + counts(i-1) + ENDDO + total_mouths = sum(counts) + + allocate (all_mouths (max(1,total_mouths))) + CALL mpi_allgatherv (local_mouths, nlocal_mouths, MPI_INTEGER, all_mouths, counts, displs, & + MPI_INTEGER, p_comm_compute, p_err) + + allocate (global_mouths (max(1,total_mouths))) + numrivsys = 0 + DO i = 1, total_mouths + CALL insert_into_sorted_list1 (all_mouths(i), numrivsys, global_mouths, iloc, is_new) + ENDDO + + p_comm_rivsys = p_comm_compute + rivsys_by_multiple_procs = p_np_compute > 1 + + deallocate (counts) + deallocate (displs) + deallocate (all_mouths) +#else + total_mouths = nlocal_mouths + allocate (global_mouths (max(1,total_mouths))) + numrivsys = nlocal_mouths + IF (numrivsys > 0) global_mouths(1:numrivsys) = local_mouths(1:numrivsys) + rivsys_by_multiple_procs = .false. +#endif + + DO i = 1, numucat + irivsys(i) = find_in_sorted_list1 (mouth_id(i), numrivsys, global_mouths(1:numrivsys)) + IF (irivsys(i) <= 0) CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river-system map is incomplete.') + ENDDO + + deallocate (mouth_id) + deallocate (local_mouths) + deallocate (global_mouths) + + END SUBROUTINE build_mpas_embedded_river_systems + ! --------- SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) From 00b93d3631f4bff8f316b4d7cf983e98ad05d03d Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Fri, 3 Jul 2026 12:02:44 +0800 Subject: [PATCH 14/17] Allow empty MPAS-owned CoLM subsets MPAS decomposition can leave some ranks with zero local land solve cells. Treat those ranks as valid empty CoLM owners while preserving MPAS communicator participation for river/restart collectives. Constraint: MPAS cell ownership defines CoLM element ownership; no rank may fall back to global landdata or standalone CoLM process pools. Rejected: Requiring at least one CoLM cell per MPAS rank | breaks normal MPAS partitioning and wastes MPI resources. Confidence: high Scope-risk: moderate Directive: Keep MPAS_EMBEDDED_COLM on subset-based landdata reads; do not reintroduce global mesh/pixelset fallback for empty ranks. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; cmake --build build-cmake-colm-debug --target install -j 8 Not-tested: end-to-end MPAS runtime with a real decomposition containing zero-land-cell ranks. --- .../mpas_atmphys_driver_lsm_colm2024.F | 3 - .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 68 +++++++++++++++++-- .../physics_colm2024/share/MOD_Pixelset.F90 | 15 ++-- .../share/MOD_SrfdataRestart.F90 | 2 +- 4 files changed, 69 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index 3e54655241..4b2e2368a1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -89,9 +89,6 @@ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) n_mpas_cells = n_mpas_cells + nCellsSolve block_cursor => block_cursor % next enddo - if(n_mpas_cells < 1) call physics_error_fatal("CoLM2024 MPAS embedded mode requires at least one solve cell " // & - "on every MPAS rank; reduce MPI ranks or repartition.") - allocate(mpas_cell_id(n_mpas_cells), cell_to_element(n_mpas_cells)) offset = 0 diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index 20d22eded1..342e603e09 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -171,7 +171,7 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell IF (.not. present(cell_to_element)) RETURN n_mpas = n_mpas_cells - IF (n_mpas < 1) RETURN + IF (n_mpas < 0) RETURN IF (size(mpas_cell_id) < n_mpas) RETURN IF (size(cell_to_element) < n_mpas) RETURN @@ -184,6 +184,16 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell CALL pixel%load_from_file(dir_landdata) CALL gblock%load_from_file(dir_landdata) +#ifdef MPAS_EMBEDDED_COLM + CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, n_mpas, ierr) + IF (ierr /= 0) RETURN + + CALL mesh_load_from_file(dir_landdata, lc_year, subset_eindex=mpas_cell_id_i8) + CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year, & + subset_eindex=mpas_cell_id_i8) + CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year, & + subset_eindex=mpas_cell_id_i8) +#else IF (n_mpas > 0) THEN CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, n_mpas, ierr) IF (ierr /= 0) RETURN @@ -198,14 +208,20 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year) CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year) ENDIF +#endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef MPAS_EMBEDDED_COLM + CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, & + subset_eindex=mpas_cell_id_i8) +#else IF (n_mpas > 0) THEN CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, & subset_eindex=mpas_cell_id_i8) ELSE CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year) ENDIF +#endif #endif IF (n_mpas > 0) THEN @@ -328,16 +344,27 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m integer*8, allocatable :: sorted_cell_id(:) ierr = 1 - IF (n_mpas_cells < 1) RETURN + IF (n_mpas_cells < 0) RETURN IF (.not. allocated(gblock%pio)) RETURN IF (.not. allocated(gblock%lon_w)) RETURN IF (.not. allocated(gblock%lat_s)) RETURN IF (size(mpas_cell_id) < n_mpas_cells) RETURN allocate(keep_block(gblock%nxblk, gblock%nyblk)) + keep_block = .false. + + IF (n_mpas_cells == 0) THEN + gblock%pio(:,:) = -1 + IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) + IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) + gblock%nblkme = 0 + deallocate(keep_block) + ierr = 0 + RETURN + ENDIF + allocate(found_element(n_mpas_cells)) allocate(sorted_cell_id(n_mpas_cells)) - keep_block = .false. found_element = .false. sorted_cell_id = mpas_cell_id(1:n_mpas_cells) @@ -603,8 +630,13 @@ SUBROUTINE colm_mpas_ready(ready, patch_count) logical, intent(out) :: ready integer, intent(out), optional :: patch_count - ready = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) & - .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) + IF (numpatch == 0) THEN + ready = colm_mpas_initialized .and. allocated(elm_patch%substt) .and. & + allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) + ELSE + ready = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) & + .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) + ENDIF IF (present(patch_count)) THEN IF (allocated(oroflag)) THEN patch_count = size(oroflag) @@ -739,7 +771,7 @@ SUBROUTINE colm_mpas_step(idate, deltim, dolai, doalb, dosst, ierr) ierr = 1 IF (.not. ready) RETURN - CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag) + IF (numpatch > 0) CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag) #ifdef GridRiverLakeFlow CALL grid_riverlake_flow(idate(1), deltim) #endif @@ -751,8 +783,12 @@ END SUBROUTINE colm_mpas_step SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) USE MOD_Namelist, only: DEF_WRST_FREQ + USE MOD_SPMD_Task, only: p_is_root USE MOD_TimeManager, only: adj2begin USE MOD_Vars_TimeVariables, only: save_to_restart, WRITE_TimeVariables +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeTimeVars, only: WRITE_GridRiverLakeTimeVars +#endif integer, intent(in) :: idate(3) real(r8), intent(in) :: deltim logical, intent(in) :: force @@ -763,6 +799,11 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) integer :: write_lc_year logical :: should_write character(len=256) :: wrst_freq +#ifdef GridRiverLakeFlow + character(len=14) :: cdate + character(len=256) :: cyear + character(len=256) :: file_restart +#endif ierr = 0 IF (.not. colm_mpas_restart_ready) RETURN @@ -796,7 +837,20 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) write_lc_year = colm_mpas_lc_year #endif - CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) +#ifdef GridRiverLakeFlow + IF (numpatch == 0) THEN + write(cyear,'(i4.4)') write_lc_year + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') write_idate(1), write_idate(2), write_idate(3) + IF (p_is_root) CALL system('mkdir -p ' // trim(colm_mpas_dir_restart)//'/'//trim(cdate)) + file_restart = trim(colm_mpas_dir_restart)// '/'//trim(cdate)//'/' // & + trim(colm_mpas_casename) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_GridRiverLakeTimeVars(file_restart) + ELSE + CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) + ENDIF +#else + IF (numpatch > 0) CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) +#endif colm_mpas_last_restart_idate(:) = write_idate(:) END SUBROUTINE colm_mpas_write_restart_if_due diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 index 785b27b7de..a268bc8681 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -602,8 +602,6 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) ! Local Variables integer :: isuperset, isubset, ielm, ipxl, istt, iend - IF (superset%nset <= 0) RETURN - IF (superset%has_shared) THEN write(*,*) 'Warning: superset has shared area.' ENDIF @@ -617,6 +615,13 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) this%substt = 0 this%subend = -1 + IF (use_frac) THEN + IF (allocated(this%subfrc)) deallocate(this%subfrc) + allocate (this%subfrc (subset%nset)) + ENDIF + + IF (superset%nset <= 0 .or. subset%nset <= 0) RETURN + isuperset = 1 isubset = 1 DO WHILE (isubset <= subset%nset) @@ -640,12 +645,6 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) IF (use_frac) THEN - IF (allocated(this%subfrc)) deallocate(this%subfrc) - - IF (subset%nset <= 0) RETURN - - allocate (this%subfrc (subset%nset)) - DO isubset = 1, subset%nset ielm = subset%ielm(isubset) this%subfrc(isubset) = 0 diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 index f5b30ce741..a4d52c86fe 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -612,7 +612,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDDO #if (defined VectorInOneFileS || defined VectorInOneFileP) - fexists_any = pixelset%nset > 0 + inquire(file=trim(filename), exist=fexists_any) #endif #ifdef USEMPI From d2a7ee13f3cfbdb1c927711dcfe4fb49ed9c9bbb Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Fri, 3 Jul 2026 17:47:46 +0800 Subject: [PATCH 15/17] Embed CoLM2024 under MPAS-owned decomposition Constraint: CoLM must run as an MPAS land-surface option without standalone build, preprocess, run scripts, or dedicated CoLM rank pools. Rejected: Linking an external libcolm or keeping CoLM master/io/worker MPI roles | those paths fight MPAS decomposition and leave rank-local land state inconsistent. Confidence: high Scope-risk: broad Directive: Keep MPAS cell ownership as the source of truth; do not reintroduce CoLM standalone process pools or generated surface builders. Tested: git diff --check; cmake --build build-cmake-colm-debug --target mpas_atmosphere -j 8; cmake --build build-cmake-colm-debug --target install -j 8; embedded CoLM Make dry-run; 201-object source table check; residual standalone/CaMa/master-worker scans. Not-tested: Real multi-rank MPAS+CoLM landdata/restart runtime smoke; full traditional Make compile. --- src/core_atmosphere/CMakeLists.txt | 45 +-- src/core_atmosphere/physics/Makefile | 273 +++++++++++++++++- .../mpas_atmphys_driver_lsm_colm2024.F | 18 +- .../physics/physics_colm2024/Makefile | 264 ----------------- .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 86 +++++- .../physics_colm2024/include/Makeoptions | 9 - .../physics/physics_colm2024/include/define.h | 10 +- .../physics_colm2024/main/CoLMDRIVER.F90 | 16 - .../physics_colm2024/main/CoLMMAIN.F90 | 87 ------ .../main/HYDRO/MOD_Catch_Reservoir.F90 | 2 +- .../main/HYDRO/MOD_Grid_Reservoir.F90 | 2 +- .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 8 +- .../physics_colm2024/main/MOD_Hist.F90 | 24 -- .../physics_colm2024/main/MOD_HistGridded.F90 | 5 + .../physics_colm2024/main/MOD_Irrigation.F90 | 31 -- .../main/MOD_LeafInterception.F90 | 2 +- .../main/MOD_SoilSnowHydrology.F90 | 131 --------- .../main/MOD_Vars_TimeInvariants.F90 | 53 +++- .../main/MOD_Vars_TimeVariables.F90 | 65 +++-- .../main/URBAN/CoLMMAIN_Urban.F90 | 17 -- .../main/URBAN/MOD_Urban_Hydrology.F90 | 12 - .../physics_colm2024/share/MOD_Mesh.F90 | 8 +- .../physics_colm2024/share/MOD_Namelist.F90 | 2 +- .../share/MOD_NetCDFSerial.F90 | 19 -- .../physics_colm2024/share/MOD_Pixelset.F90 | 14 +- .../share/MOD_SingleSrfdata.F90 | 66 ++--- .../share/MOD_SpatialMapping.F90 | 35 ++- .../share/MOD_SrfdataRestart.F90 | 4 + 28 files changed, 562 insertions(+), 746 deletions(-) delete mode 100644 src/core_atmosphere/physics/physics_colm2024/Makefile delete mode 100644 src/core_atmosphere/physics/physics_colm2024/include/Makeoptions diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 97b1370f8f..9780e83714 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -301,24 +301,7 @@ list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES PREPEND physics/physics if(MPAS_COLM2024) set(COLM2024_SOURCE_ROOT ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_colm2024) - file(STRINGS ${COLM2024_SOURCE_ROOT}/Makefile COLM2024_MAKEFILE_LINES) - set(_colm2024_collect_sources FALSE) - foreach(_colm2024_line IN LISTS COLM2024_MAKEFILE_LINES) - if(_colm2024_line MATCHES "^OBJS_SHARED[ \t]*=" OR - _colm2024_line MATCHES "^OBJS_BASIC[ \t]*=" OR - _colm2024_line MATCHES "^OBJS_MAIN[ \t]*=") - set(_colm2024_collect_sources TRUE) - endif() - if(_colm2024_collect_sources) - string(REGEX MATCHALL "[A-Za-z0-9_]+\\.o" _colm2024_objects "${_colm2024_line}") - list(APPEND COLM2024_OBJECT_LIST ${_colm2024_objects}) - if(NOT _colm2024_line MATCHES "\\\\[ \t]*$") - set(_colm2024_collect_sources FALSE) - endif() - endif() - endforeach() set(COLM2024_SOURCE_SEARCH_DIRS - include share main main/HYDRO @@ -328,18 +311,14 @@ if(MPAS_COLM2024) main/ParaOpt drivers/mpas ) - foreach(_colm2024_obj IN LISTS COLM2024_OBJECT_LIST) - string(REGEX REPLACE "\\.o$" ".F90" _colm2024_src_name ${_colm2024_obj}) - unset(_colm2024_src) - foreach(_colm2024_dir IN LISTS COLM2024_SOURCE_SEARCH_DIRS) - if(EXISTS ${COLM2024_SOURCE_ROOT}/${_colm2024_dir}/${_colm2024_src_name}) - set(_colm2024_src ${COLM2024_SOURCE_ROOT}/${_colm2024_dir}/${_colm2024_src_name}) - break() - endif() - endforeach() - if(NOT _colm2024_src) - message(FATAL_ERROR "Could not resolve CoLM2024 object ${_colm2024_obj} to a source file") - endif() + foreach(_colm2024_dir IN LISTS COLM2024_SOURCE_SEARCH_DIRS) + file(GLOB _colm2024_dir_sources CONFIGURE_DEPENDS + ${COLM2024_SOURCE_ROOT}/${_colm2024_dir}/*.F90) + list(APPEND COLM2024_SOURCE_CANDIDATES ${_colm2024_dir_sources}) + endforeach() + list(REMOVE_DUPLICATES COLM2024_SOURCE_CANDIDATES) + list(SORT COLM2024_SOURCE_CANDIDATES) + foreach(_colm2024_src IN LISTS COLM2024_SOURCE_CANDIDATES) file(RELATIVE_PATH _colm2024_src_rel ${CMAKE_CURRENT_SOURCE_DIR} ${_colm2024_src}) execute_process( COMMAND ${CPP_EXECUTABLE} -traditional-cpp -P -I${COLM2024_SOURCE_ROOT}/include ${_colm2024_src} @@ -386,14 +365,6 @@ if(MPAS_COLM2024) endif() endfunction() - set(_colm2024_previous_source) - foreach(_colm2024_source IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) - if(_colm2024_previous_source) - _colm2024_source_depends(${_colm2024_source} ${_colm2024_previous_source}) - endif() - set(_colm2024_previous_source ${_colm2024_source}) - endforeach() - _colm2024_source_depends( physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 05a125b409..0422dc4da0 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -6,9 +6,34 @@ endif ifneq (,$(findstring -DMPAS_COLM2024,$(CPPFLAGS))) COLM2024_ENABLED = true -COLM2024_CORE = core_physics_colm2024 -COLM2024_INCLUDES = -I./physics_colm2024/include -I./physics_colm2024/.bld +COLM2024_CORE = core_physics_colm2024_embedded +COLM2024_BUILD_DIR = physics_colm2024/.mpas_bld +COLM2024_HEADER = physics_colm2024/include/define.h +COLM2024_STAMP = $(COLM2024_BUILD_DIR)/.built +COLM2024_MOD_CMD ?= -J +NF_CONFIG ?= nf-config +COLM2024_NETCDF_INC ?= $(shell $(NF_CONFIG) --includedir 2>/dev/null || nc-config --includedir 2>/dev/null) +COLM2024_INCLUDES = -I./physics_colm2024/include -I./$(COLM2024_BUILD_DIR) +ifneq ($(strip $(COLM2024_NETCDF_INC)),) +COLM2024_INCLUDES += -I$(COLM2024_NETCDF_INC) +endif +ifneq ($(strip $(PNETCDF)),) +COLM2024_INCLUDES += -I$(PNETCDF)/include +endif +ifneq ($(strip $(PNETCDF_INC)),) +COLM2024_INCLUDES += -I$(PNETCDF_INC) +endif COLM2024_FOPTS ?= $(CPPFLAGS) $(COREDEF) $(FFLAGS) -fdefault-real-8 -ffree-form -cpp -ffree-line-length-0 -fallow-argument-mismatch +COLM2024_SOURCE_DIRS = \ + physics_colm2024/share \ + physics_colm2024/main \ + physics_colm2024/main/HYDRO \ + physics_colm2024/main/BGC \ + physics_colm2024/main/URBAN \ + physics_colm2024/main/DA \ + physics_colm2024/main/ParaOpt \ + physics_colm2024/drivers/mpas +COLM2024_SOURCES = $(foreach dir,$(COLM2024_SOURCE_DIRS),$(wildcard $(dir)/*.F90)) endif all: @@ -80,8 +105,241 @@ core_physics_noahmp: (cd physics_noahmp/src; $(MAKE) all COREDEF="$(COREDEF)") (cd physics_noahmp/drivers/mpas; $(MAKE) all COREDEF="$(COREDEF)") -core_physics_colm2024: - (cd physics_colm2024; $(MAKE) mpas_objects FF="$(FC)" FOPTS="$(COLM2024_FOPTS)") +ifeq "$(COLM2024_ENABLED)" "true" +COLM2024_OBJS_SHARED_NAMES = \ + MOD_Precision.o \ + MOD_SPMD_Task.o \ + MOD_Namelist.o \ + MOD_Vars_Global.o \ + MOD_Const_Physical.o \ + MOD_Const_LC.o \ + MOD_Utils.o \ + MOD_IncompleteGamma.o \ + MOD_UserDefFun.o \ + MOD_TimeManager.o \ + MOD_Const_PFT.o \ + MOD_NetCDFSerial.o \ + MOD_Block.o \ + MOD_Grid.o \ + MOD_Pixel.o \ + MOD_DataType.o \ + MOD_NetCDFPoint.o \ + MOD_NetCDFBlock.o \ + MOD_CatchmentDataReadin.o \ + MOD_5x5DataReadin.o \ + MOD_Mesh.o \ + MOD_Pixelset.o \ + MOD_NetCDFVector.o \ + MOD_RangeCheck.o \ + MOD_SpatialMapping.o \ + MOD_ComputePushData.o \ + MOD_AggregationRequestData.o \ + MOD_PixelsetShared.o \ + MOD_LandElm.o \ + MOD_LandHRU.o \ + MOD_LandPatch.o \ + MOD_Land2mWMO.o \ + MOD_LandCrop.o \ + MOD_LandPFT.o \ + MOD_LandUrban.o \ + MOD_Urban_Const_LCZ.o \ + MOD_SingleSrfdata.o \ + MOD_SrfdataRestart.o \ + MOD_ElmVector.o \ + MOD_HRUVector.o \ + MOD_MeshFilter.o + +COLM2024_OBJS_BASIC_NAMES = \ + MOD_Vector_ReadWrite.o \ + MOD_dataSpec_PDB.o \ + MOD_tav_abs.o \ + MOD_prospect_DB.o \ + MOD_Catch_BasinNetwork.o \ + MOD_Catch_Vars_TimeVariables.o \ + MOD_Catch_Vars_1DFluxes.o \ + MOD_Grid_RiverLakeNetwork.o \ + MOD_Grid_Reservoir.o \ + MOD_Grid_RiverLakeTimeVars.o \ + MOD_BGC_Vars_1DFluxes.o \ + MOD_BGC_Vars_1DPFTFluxes.o \ + MOD_BGC_Vars_PFTimeVariables.o \ + MOD_BGC_Vars_TimeInvariants.o \ + MOD_BGC_Vars_TimeVariables.o \ + MOD_Urban_Vars_1DFluxes.o \ + MOD_Urban_Vars_TimeVariables.o \ + MOD_Urban_Vars_TimeInvariants.o \ + MOD_DA_Vars_1DFluxes.o \ + MOD_Vars_TimeInvariants.o \ + MOD_DA_Vars_TimeVariables.o \ + MOD_Vars_TimeVariables.o \ + MOD_Vars_1DPFTFluxes.o \ + MOD_Vars_1DFluxes.o \ + MOD_Vars_1DForcing.o \ + MOD_Hydro_SoilFunction.o \ + MOD_Hydro_SoilWater.o \ + MOD_Eroot.o \ + MOD_Qsadv.o \ + MOD_LAIEmpirical.o \ + MOD_LAIReadin.o \ + MOD_CropReadin.o \ + MOD_NitrifData.o \ + MOD_NdepData.o \ + MOD_FireData.o \ + MOD_OrbCoszen.o \ + MOD_OrbCosazi.o \ + MOD_HighRes_Parameters.o \ + MOD_3DCanopyRadiation.o \ + MOD_Aerosol.o \ + MOD_SnowSnicar.o \ + MOD_Albedo.o \ + MOD_SnowSnicar_HiRes.o \ + MOD_Albedo_HiRes.o \ + MOD_SnowFraction.o \ + MOD_Urban_LAIReadin.o \ + MOD_Urban_Shortwave.o \ + MOD_Urban_Albedo.o \ + MOD_MonthlyinSituCO2MaunaLoa.o \ + MOD_BGC_CNSummary.o \ + MOD_ElementNeighbour.o \ + MOD_Catch_HillslopeNetwork.o \ + MOD_Catch_RiverLakeNetwork.o \ + MOD_Catch_Reservoir.o \ + MOD_VicParaReadin.o + +COLM2024_OBJS_MAIN_NAMES = \ + MOD_Catch_HillslopeFlow.o \ + MOD_Catch_SubsurfaceFlow.o \ + MOD_Catch_RiverLakeFlow.o \ + MOD_Catch_Hist.o \ + MOD_Catch_WriteParameters.o \ + MOD_BGC_CNCStateUpdate1.o \ + MOD_BGC_CNCStateUpdate2.o \ + MOD_BGC_CNCStateUpdate3.o \ + MOD_BGC_CNNStateUpdate1.o \ + MOD_BGC_CNNStateUpdate2.o \ + MOD_BGC_CNNStateUpdate3.o \ + MOD_BGC_Soil_BiogeochemNStateUpdate1.o \ + MOD_BGC_Soil_BiogeochemNitrifDenitrif.o \ + MOD_BGC_Soil_BiogeochemCompetition.o \ + MOD_BGC_Soil_BiogeochemDecompCascadeBGC.o \ + MOD_BGC_Soil_BiogeochemDecomp.o \ + MOD_BGC_Soil_BiogeochemLittVertTransp.o \ + MOD_BGC_Soil_BiogeochemNLeaching.o \ + MOD_BGC_Soil_BiogeochemPotential.o \ + MOD_BGC_Soil_BiogeochemVerticalProfile.o \ + MOD_BGC_Veg_CNGapMortality.o \ + MOD_BGC_Veg_CNGResp.o \ + MOD_BGC_Veg_CNMResp.o \ + MOD_BGC_Daylength.o \ + MOD_BGC_Veg_CNPhenology.o \ + MOD_BGC_Veg_NutrientCompetition.o \ + MOD_BGC_Veg_CNVegStructUpdate.o \ + MOD_BGC_CNAnnualUpdate.o \ + MOD_BGC_CNZeroFluxes.o \ + MOD_BGC_CNBalanceCheck.o \ + MOD_BGC_CNSASU.o \ + MOD_BGC_Veg_CNNDynamics.o \ + MOD_BGC_Veg_CNFireBase.o \ + MOD_BGC_Veg_CNFireLi2016.o \ + MOD_Vars_2DForcing.o \ + MOD_UserSpecifiedForcing.o \ + MOD_ForcingDownscaling.o \ + MOD_Forcing.o \ + MOD_DA_TWS.o \ + MOD_DA_Const.o \ + MOD_DA_RTM.o \ + MOD_DA_EnKF.o \ + MOD_DA_SM.o \ + MOD_DA_Ensemble.o \ + MOD_DA_Main.o \ + MOD_Opt_Baseflow.o \ + MOD_ParameterOptimization.o \ + MOD_AssimStomataConductance.o \ + MOD_PlantHydraulic.o \ + MOD_FrictionVelocity.o \ + MOD_TurbulenceLEddy.o \ + MOD_Ozone.o \ + MOD_CanopyLayerProfile.o \ + MOD_LeafTemperature.o \ + MOD_LeafTemperaturePC.o \ + MOD_SoilThermalParameters.o \ + MOD_Hydro_VIC_Variables.o \ + MOD_Hydro_VIC.o \ + MOD_Runoff.o \ + MOD_SoilSnowHydrology.o \ + MOD_SnowLayersCombineDivide.o \ + MOD_PhaseChange.o \ + MOD_Glacier.o \ + MOD_Lake.o \ + MOD_SimpleOcean.o \ + MOD_GroundFluxes.o \ + MOD_GroundTemperature.o \ + MOD_LeafInterception.o \ + MOD_NetSolar.o \ + MOD_NetSolar_Hyper.o \ + MOD_WetBulb.o \ + MOD_RainSnowTemp.o \ + MOD_SoilSurfaceResistance.o \ + MOD_NewSnow.o \ + MOD_Thermal.o \ + MOD_Vars_1DAccFluxes.o \ + MOD_Irrigation.o \ + MOD_BGC_driver.o \ + MOD_HistWriteBack.o \ + MOD_HistGridded.o \ + MOD_HistVector.o \ + MOD_HistSingle.o \ + MOD_Grid_RiverLakeHist.o \ + MOD_Hist.o \ + MOD_CheckEquilibrium.o \ + MOD_LightningData.o \ + MOD_Catch_LateralFlow.o \ + MOD_Grid_RiverLakeFlow.o \ + MOD_Urban_Longwave.o \ + MOD_Urban_NetSolar.o \ + MOD_Urban_Flux.o \ + MOD_Urban_GroundFlux.o \ + MOD_Urban_RoofFlux.o \ + MOD_Urban_RoofTemperature.o \ + MOD_Urban_WallTemperature.o \ + MOD_Urban_PerviousTemperature.o \ + MOD_Urban_ImperviousTemperature.o \ + MOD_Urban_Hydrology.o \ + MOD_Urban_BEM.o \ + MOD_Urban_LUCY.o \ + MOD_Urban_Thermal.o \ + CoLMMAIN_Urban.o \ + CoLMDRIVER.o \ + MOD_CoLM_MPAS_Interface.o \ + CoLMMAIN.o + +COLM2024_OBJ_NAMES = $(COLM2024_OBJS_SHARED_NAMES) $(COLM2024_OBJS_BASIC_NAMES) $(COLM2024_OBJS_MAIN_NAMES) +COLM2024_OBJS = $(addprefix $(COLM2024_BUILD_DIR)/,$(COLM2024_OBJ_NAMES)) + +.PHONY: core_physics_colm2024_embedded +core_physics_colm2024_embedded: $(COLM2024_STAMP) + +$(COLM2024_BUILD_DIR): + mkdir -p $(COLM2024_BUILD_DIR) + +$(COLM2024_STAMP): $(COLM2024_HEADER) $(COLM2024_SOURCES) | $(COLM2024_BUILD_DIR) + @echo 'compiling embedded CoLM2024 physics >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>' + @set -e; \ + for obj in $(COLM2024_OBJ_NAMES); do \ + src=""; \ + stem="$${obj%.o}"; \ + for dir in $(COLM2024_SOURCE_DIRS); do \ + if [ -f "$$dir/$$stem.F90" ]; then src="$$dir/$$stem.F90"; break; fi; \ + done; \ + if [ -z "$$src" ]; then \ + echo "CoLM2024 source not found for $$obj"; \ + exit 1; \ + fi; \ + echo " $$src"; \ + $(FC) -c $(COLM2024_FOPTS) $(COLM2024_INCLUDES) -o "$(COLM2024_BUILD_DIR)/$$obj" "$$src" $(COLM2024_MOD_CMD)$(COLM2024_BUILD_DIR); \ + done; \ + touch $@ +endif core_physics_init: $(OBJS_init) @@ -94,7 +352,7 @@ core_physics: core_physics_wrf core_physics_noahmp $(COLM2024_CORE) ($(MAKE) -C ./physics_noahmp/src src_lib) ($(MAKE) -C ./physics_noahmp/utility utility_lib) ifeq "$(COLM2024_ENABLED)" "true" - (cd physics_colm2024/.mpas; ar -ru ../../libphys.a *.o) + ar -ru libphys.a $(COLM2024_OBJS) endif phys_interface: $(OBJS) @@ -227,8 +485,7 @@ mpas_atmphys_lsm_noahmpinit.o: \ mpas_atmphys_lsm_noahmpfinalize.o : \ mpas_atmphys_vars.o -mpas_atmphys_driver_lsm_colm2024.o : \ - mpas_atmphys_utilities.o +mpas_atmphys_driver_lsm_colm2024.o : mpas_atmphys_utilities.o $(COLM2024_STAMP) mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ @@ -274,7 +531,7 @@ clean: ( cd physics_noahmp/drivers/mpas; $(MAKE) clean ) ( cd physics_noahmp/src; $(MAKE) clean ) ( cd physics_noahmp/utility; $(MAKE) clean ) - ( if [ -d physics_colm2024 ]; then cd physics_colm2024; $(MAKE) clean; fi ) + $(RM) -r physics_colm2024/.mpas_bld ( if [ -d physics_noaa/UGWP ]; then cd physics_noaa/UGWP; $(MAKE) clean; fi ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index 4b2e2368a1..aeca5641a5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -23,6 +23,7 @@ module mpas_atmphys_driver_lsm_colm2024 colm_mpas_step, colm_mpas_get_element_surface, & colm_mpas_get_element_state, & colm_mpas_finalize + use MOD_Vars_Global, only: colm_dz_soi => dz_soi #endif implicit none @@ -449,6 +450,7 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt real(kind=colm_r8):: emissivity, roughness, albedo real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index real(kind=colm_r8):: soil_moisture_sum + real(kind=colm_r8):: soil_depth_sum real(kind=colm_r8),parameter:: colm_state_bad_value = 1.e30_colm_r8 real(kind=colm_r8),dimension(:),allocatable:: soil_liquid, soil_moisture, soil_temperature real(kind=RKIND),dimension(:),pointer:: hfx, lh, qfx, grdflx, sfcrunoff, udrunoff @@ -506,7 +508,10 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt skintemp(i) = real(skin_temp, RKIND) t2m(i) = real(t2m_colm, RKIND) qsfc(i) = real(qsfc_colm, RKIND) - q2(i) = real(q2m_colm, RKIND) + ! MPAS/WRF q2 is a 2 m mixing ratio; CoLM qref is specific humidity. + if(abs(q2m_colm) < colm_state_bad_value .and. q2m_colm >= 0._colm_r8 .and. q2m_colm < 1._colm_r8) then + q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) + endif sfc_emiss(i) = real(emissivity, RKIND) z0(i) = real(roughness, RKIND) znt(i) = real(roughness, RKIND) @@ -518,6 +523,7 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt lai(i) = real(max(0._colm_r8, leaf_area_index), RKIND) soil_moisture_sum = 0._colm_r8 + soil_depth_sum = 0._colm_r8 nvalid_soil = 0 do ns = 1,nlev if(abs(soil_liquid(ns)) < colm_state_bad_value .and. & @@ -526,17 +532,21 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt sh2o(ns,i) = real(soil_liquid(ns), RKIND) smois(ns,i) = real(soil_moisture(ns), RKIND) tslb(ns,i) = real(soil_temperature(ns), RKIND) - soil_moisture_sum = soil_moisture_sum + soil_moisture(ns) + if(ns <= size(colm_dz_soi) .and. colm_dz_soi(ns) > 0._colm_r8) then + soil_moisture_sum = soil_moisture_sum + soil_moisture(ns) * colm_dz_soi(ns) + soil_depth_sum = soil_depth_sum + colm_dz_soi(ns) + endif nvalid_soil = nvalid_soil + 1 endif enddo - if(nvalid_soil > 0) then - smstot(i) = real(soil_moisture_sum / real(nvalid_soil, colm_r8), RKIND) + if(nvalid_soil > 0 .and. soil_depth_sum > 0._colm_r8) then + smstot(i) = real(soil_moisture_sum / soil_depth_sum, RKIND) if(abs(soil_moisture(1)) < colm_state_bad_value) then smstav(i) = real(soil_moisture(1), RKIND) else smstav(i) = smstot(i) endif + smstav(i) = max(0._RKIND, min(1._RKIND, smstav(i))) endif enddo diff --git a/src/core_atmosphere/physics/physics_colm2024/Makefile b/src/core_atmosphere/physics/physics_colm2024/Makefile deleted file mode 100644 index 988f1339e7..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/Makefile +++ /dev/null @@ -1,264 +0,0 @@ -# Object list and staging rules for MPAS-embedded CoLM2024. - -include include/Makeoptions -HEADER = include/define.h - -INCLUDE_DIR = -Iinclude -I.bld/ -I${NETCDF_INC} -ifneq ($(strip $(PNETCDF)),) -INCLUDE_DIR += -I$(PNETCDF)/include -endif -ifneq ($(strip $(PNETCDF_INC)),) -INCLUDE_DIR += -I$(PNETCDF_INC) -endif -VPATH = include : share \ - : main : main/HYDRO : main/BGC : main/URBAN : main/DA \ - : main/ParaOpt : drivers/mpas : .bld - -.PHONY: all -all : mpas_objects - -.NOTPARALLEL: - -.PHONY: mkdir_build -mkdir_build : - mkdir -p .bld - -OBJS_SHARED = \ - MOD_Precision.o \ - MOD_SPMD_Task.o \ - MOD_Namelist.o \ - MOD_Vars_Global.o \ - MOD_Const_Physical.o \ - MOD_Const_LC.o \ - MOD_Utils.o \ - MOD_IncompleteGamma.o \ - MOD_UserDefFun.o \ - MOD_TimeManager.o \ - MOD_Const_PFT.o \ - MOD_NetCDFSerial.o \ - MOD_Block.o \ - MOD_Grid.o \ - MOD_Pixel.o \ - MOD_DataType.o \ - MOD_NetCDFPoint.o \ - MOD_NetCDFBlock.o \ - MOD_CatchmentDataReadin.o \ - MOD_5x5DataReadin.o \ - MOD_Mesh.o \ - MOD_Pixelset.o \ - MOD_NetCDFVector.o \ - MOD_RangeCheck.o \ - MOD_SpatialMapping.o \ - MOD_ComputePushData.o \ - MOD_AggregationRequestData.o \ - MOD_PixelsetShared.o \ - MOD_LandElm.o \ - MOD_LandHRU.o \ - MOD_LandPatch.o \ - MOD_Land2mWMO.o \ - MOD_LandCrop.o \ - MOD_LandPFT.o \ - MOD_LandUrban.o \ - MOD_Urban_Const_LCZ.o \ - MOD_SingleSrfdata.o \ - MOD_SrfdataRestart.o \ - MOD_ElmVector.o \ - MOD_HRUVector.o \ - MOD_MeshFilter.o - -${OBJS_SHARED} : %.o : %.F90 ${HEADER} - ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld - -OBJS_SHARED_T = $(addprefix .bld/,${OBJS_SHARED}) - -OBJS_BASIC = \ - MOD_Vector_ReadWrite.o \ - MOD_dataSpec_PDB.o \ - MOD_tav_abs.o \ - MOD_prospect_DB.o \ - MOD_Catch_BasinNetwork.o \ - MOD_Catch_Vars_TimeVariables.o \ - MOD_Catch_Vars_1DFluxes.o \ - MOD_Grid_RiverLakeNetwork.o \ - MOD_Grid_Reservoir.o \ - MOD_Grid_RiverLakeTimeVars.o \ - MOD_BGC_Vars_1DFluxes.o \ - MOD_BGC_Vars_1DPFTFluxes.o \ - MOD_BGC_Vars_PFTimeVariables.o \ - MOD_BGC_Vars_TimeInvariants.o \ - MOD_BGC_Vars_TimeVariables.o \ - MOD_Urban_Vars_1DFluxes.o \ - MOD_Urban_Vars_TimeVariables.o \ - MOD_Urban_Vars_TimeInvariants.o\ - MOD_DA_Vars_1DFluxes.o \ - MOD_Vars_TimeInvariants.o \ - MOD_DA_Vars_TimeVariables.o \ - MOD_Vars_TimeVariables.o \ - MOD_Vars_1DPFTFluxes.o \ - MOD_Vars_1DFluxes.o \ - MOD_Vars_1DForcing.o \ - MOD_Hydro_SoilFunction.o \ - MOD_Hydro_SoilWater.o \ - MOD_Eroot.o \ - MOD_Qsadv.o \ - MOD_LAIEmpirical.o \ - MOD_LAIReadin.o \ - MOD_CropReadin.o \ - MOD_NitrifData.o \ - MOD_NdepData.o \ - MOD_FireData.o \ - MOD_OrbCoszen.o \ - MOD_OrbCosazi.o \ - MOD_HighRes_Parameters.o \ - MOD_3DCanopyRadiation.o \ - MOD_Aerosol.o \ - MOD_SnowSnicar.o \ - MOD_Albedo.o \ - MOD_SnowSnicar_HiRes.o \ - MOD_Albedo_HiRes.o \ - MOD_SnowFraction.o \ - MOD_Urban_LAIReadin.o \ - MOD_Urban_Shortwave.o \ - MOD_Urban_Albedo.o \ - MOD_MonthlyinSituCO2MaunaLoa.o \ - MOD_BGC_CNSummary.o \ - MOD_ElementNeighbour.o \ - MOD_Catch_HillslopeNetwork.o \ - MOD_Catch_RiverLakeNetwork.o \ - MOD_Catch_Reservoir.o \ - MOD_VicParaReadin.o - - -$(OBJS_BASIC) : %.o : %.F90 ${HEADER} ${OBJS_SHARED} - ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld - -OBJS_BASIC_T = $(addprefix .bld/,${OBJS_BASIC}) - -OBJS_MAIN = \ - MOD_Catch_HillslopeFlow.o \ - MOD_Catch_SubsurfaceFlow.o \ - MOD_Catch_RiverLakeFlow.o \ - MOD_Catch_Hist.o \ - MOD_Catch_WriteParameters.o \ - MOD_BGC_CNCStateUpdate1.o \ - MOD_BGC_CNCStateUpdate2.o \ - MOD_BGC_CNCStateUpdate3.o \ - MOD_BGC_CNNStateUpdate1.o \ - MOD_BGC_CNNStateUpdate2.o \ - MOD_BGC_CNNStateUpdate3.o \ - MOD_BGC_Soil_BiogeochemNStateUpdate1.o \ - MOD_BGC_Soil_BiogeochemNitrifDenitrif.o \ - MOD_BGC_Soil_BiogeochemCompetition.o \ - MOD_BGC_Soil_BiogeochemDecompCascadeBGC.o \ - MOD_BGC_Soil_BiogeochemDecomp.o \ - MOD_BGC_Soil_BiogeochemLittVertTransp.o \ - MOD_BGC_Soil_BiogeochemNLeaching.o \ - MOD_BGC_Soil_BiogeochemPotential.o \ - MOD_BGC_Soil_BiogeochemVerticalProfile.o \ - MOD_BGC_Veg_CNGapMortality.o \ - MOD_BGC_Veg_CNGResp.o \ - MOD_BGC_Veg_CNMResp.o \ - MOD_BGC_Daylength.o \ - MOD_BGC_Veg_CNPhenology.o \ - MOD_BGC_Veg_NutrientCompetition.o \ - MOD_BGC_Veg_CNVegStructUpdate.o \ - MOD_BGC_CNAnnualUpdate.o \ - MOD_BGC_CNZeroFluxes.o \ - MOD_BGC_CNBalanceCheck.o \ - MOD_BGC_CNSASU.o \ - MOD_BGC_Veg_CNNDynamics.o \ - MOD_BGC_Veg_CNFireBase.o \ - MOD_BGC_Veg_CNFireLi2016.o \ - MOD_Vars_2DForcing.o \ - MOD_UserSpecifiedForcing.o \ - MOD_ForcingDownscaling.o \ - MOD_Forcing.o \ - MOD_DA_TWS.o \ - MOD_DA_Const.o \ - MOD_DA_RTM.o \ - MOD_DA_EnKF.o \ - MOD_DA_SM.o \ - MOD_DA_Ensemble.o \ - MOD_DA_Main.o \ - MOD_Opt_Baseflow.o \ - MOD_ParameterOptimization.o \ - MOD_AssimStomataConductance.o \ - MOD_PlantHydraulic.o \ - MOD_FrictionVelocity.o \ - MOD_TurbulenceLEddy.o \ - MOD_Ozone.o \ - MOD_CanopyLayerProfile.o \ - MOD_LeafTemperature.o \ - MOD_LeafTemperaturePC.o \ - MOD_SoilThermalParameters.o \ - MOD_Hydro_VIC_Variables.o \ - MOD_Hydro_VIC.o \ - MOD_Runoff.o \ - MOD_SoilSnowHydrology.o \ - MOD_SnowLayersCombineDivide.o \ - MOD_PhaseChange.o \ - MOD_Glacier.o \ - MOD_Lake.o \ - MOD_SimpleOcean.o \ - MOD_GroundFluxes.o \ - MOD_GroundTemperature.o \ - MOD_LeafInterception.o \ - MOD_NetSolar.o \ - MOD_NetSolar_Hyper.o \ - MOD_WetBulb.o \ - MOD_RainSnowTemp.o \ - MOD_SoilSurfaceResistance.o \ - MOD_NewSnow.o \ - MOD_Thermal.o \ - MOD_Vars_1DAccFluxes.o \ - MOD_Irrigation.o \ - MOD_BGC_driver.o \ - MOD_HistWriteBack.o \ - MOD_HistGridded.o \ - MOD_HistVector.o \ - MOD_HistSingle.o \ - MOD_Grid_RiverLakeHist.o \ - MOD_Hist.o \ - MOD_CheckEquilibrium.o \ - MOD_LightningData.o \ - MOD_Catch_LateralFlow.o \ - MOD_Grid_RiverLakeFlow.o \ - MOD_Urban_Longwave.o \ - MOD_Urban_NetSolar.o \ - MOD_Urban_Flux.o \ - MOD_Urban_GroundFlux.o \ - MOD_Urban_RoofFlux.o \ - MOD_Urban_RoofTemperature.o \ - MOD_Urban_WallTemperature.o \ - MOD_Urban_PerviousTemperature.o \ - MOD_Urban_ImperviousTemperature.o \ - MOD_Urban_Hydrology.o \ - MOD_Urban_BEM.o \ - MOD_Urban_LUCY.o \ - MOD_Urban_Thermal.o \ - CoLMMAIN_Urban.o \ - CoLMDRIVER.o \ - MOD_CoLM_MPAS_Interface.o \ - CoLMMAIN.o - -$(OBJS_MAIN) : %.o : %.F90 ${HEADER} ${OBJS_SHARED} ${OBJS_BASIC} - ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld - -MOD_Urban_Thermal.o: MOD_Urban_Flux.o -MOD_Grid_RiverLakeTimeVars.o: MOD_Grid_RiverLakeNetwork.o MOD_Grid_Reservoir.o -MOD_Grid_RiverLakeFlow.o: MOD_Grid_RiverLakeHist.o - -OBJS_MPAS_T = $(addprefix .bld/,${OBJS_SHARED} ${OBJS_BASIC} ${OBJS_MAIN}) - -.PHONY: mpas_objects -mpas_objects : mkdir_build ${HEADER} ${OBJS_SHARED} ${OBJS_BASIC} ${OBJS_MAIN} - @echo '' - @echo 'staging CoLM objects for MPAS physics library >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>' - rm -rf .mpas - mkdir -p .mpas - cd .mpas && for obj in ${OBJS_MPAS_T}; do ln -sf ../$$obj ./; done - -.PHONY: clean -clean : - rm -rf .bld - rm -rf .mpas diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index 342e603e09..eb500330d0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -230,6 +230,10 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell ENDIF CALL elm_patch%build(landelm, landpatch, use_frac = .true.) +#ifdef MPAS_EMBEDDED_COLM + CALL colm_mpas_validate_element_patch_map(.false., ierr) + IF (ierr /= 0) RETURN +#endif #ifdef GridRiverLakeFlow #ifdef MPAS_EMBEDDED_COLM @@ -250,6 +254,10 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell CALL allocate_TimeInvariants() CALL READ_TimeInvariants(lc_year, casename, dir_restart) +#ifdef MPAS_EMBEDDED_COLM + CALL colm_mpas_validate_element_patch_map(.true., ierr) + IF (ierr /= 0) RETURN +#endif CALL allocate_TimeVariables() CALL READ_TimeVariables(jdate, lc_year, casename, dir_restart) @@ -626,6 +634,74 @@ SUBROUTINE colm_mpas_find_element_by_eindex(cell_id, element) IF (hits /= 1) element = 0 END SUBROUTINE colm_mpas_find_element_by_eindex + SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr) + USE MOD_LandElm, only: landelm + USE MOD_SPMD_Task, only: p_iam_glb + logical, intent(in) :: require_active_patch + integer, intent(out) :: ierr + + integer :: element + integer :: patch + integer :: istt + integer :: iend + integer :: local_missing + integer :: first_missing + logical :: has_patch + + ierr = 1 + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (size(elm_patch%substt) < landelm%nset) RETURN + IF (size(elm_patch%subend) < landelm%nset) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (require_active_patch .and. numpatch > 0 .and. .not. allocated(patchmask)) RETURN + IF (require_active_patch .and. numpatch > 0) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + + local_missing = 0 + first_missing = -1 + + DO element = 1, landelm%nset + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + has_patch = .false. + + IF (istt >= 1 .and. iend >= istt .and. iend <= numpatch) THEN + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) CYCLE + IF (require_active_patch .and. allocated(patchmask)) THEN + IF (patchmask(patch)) has_patch = .true. + ELSE + has_patch = .true. + ENDIF + ENDDO + ENDIF + + IF (.not. has_patch) THEN + local_missing = local_missing + 1 + IF (first_missing < 0) first_missing = element + ENDIF + ENDDO + + IF (local_missing > 0) THEN + IF (first_missing > 0 .and. first_missing <= landelm%nset) THEN + write(*,'(A,I0,A,I0,A,I0,A,I0)') & + 'CoLM2024 MPAS embedded landdata is missing usable patch coverage on rank ', & + p_iam_glb, ': ', local_missing, ' element(s); first local element ', & + first_missing, ', eindex ', landelm%eindex(first_missing) + ELSE + write(*,'(A,I0,A,I0)') & + 'CoLM2024 MPAS embedded landdata is missing usable patch coverage on rank ', & + p_iam_glb, ': ', local_missing + ENDIF + RETURN + ENDIF + + ierr = 0 + END SUBROUTINE colm_mpas_validate_element_patch_map + SUBROUTINE colm_mpas_ready(ready, patch_count) logical, intent(out) :: ready integer, intent(out), optional :: patch_count @@ -799,7 +875,7 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) integer :: write_lc_year logical :: should_write character(len=256) :: wrst_freq -#ifdef GridRiverLakeFlow +#if defined(GridRiverLakeFlow) && !defined(MPAS_EMBEDDED_COLM) character(len=14) :: cdate character(len=256) :: cyear character(len=256) :: file_restart @@ -838,6 +914,9 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) #endif #ifdef GridRiverLakeFlow +#ifdef MPAS_EMBEDDED_COLM + CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) +#else IF (numpatch == 0) THEN write(cyear,'(i4.4)') write_lc_year write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') write_idate(1), write_idate(2), write_idate(3) @@ -848,8 +927,13 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) ELSE CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) ENDIF +#endif +#else +#ifdef MPAS_EMBEDDED_COLM + CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) #else IF (numpatch > 0) CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) +#endif #endif colm_mpas_last_restart_idate(:) = write_idate(:) END SUBROUTINE colm_mpas_write_restart_if_due diff --git a/src/core_atmosphere/physics/physics_colm2024/include/Makeoptions b/src/core_atmosphere/physics/physics_colm2024/include/Makeoptions deleted file mode 100644 index aed82b243e..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/include/Makeoptions +++ /dev/null @@ -1,9 +0,0 @@ -# MPAS-embedded CoLM2024 defaults. -# The parent MPAS build passes FF/FOPTS into this submake, just as it does for -# Noah-MP. These values only keep a direct `make mpas_objects` usable. - -FF ?= mpif90 -FOPTS ?= -ffree-form -cpp -ffree-line-length-0 -fallow-argument-mismatch -NF_CONFIG ?= nf-config -NETCDF_INC ?= $(shell $(NF_CONFIG) --includedir 2>/dev/null || nc-config --includedir) -MOD_CMD ?= -J diff --git a/src/core_atmosphere/physics/physics_colm2024/include/define.h b/src/core_atmosphere/physics/physics_colm2024/include/define.h index b5ea11ffc0..d3f5da4b34 100644 --- a/src/core_atmosphere/physics/physics_colm2024/include/define.h +++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h @@ -45,15 +45,7 @@ #undef CatchLateralFlow #endif -! 6. CaMa-Flood is not built in the MPAS-embedded CoLM package. -#undef CaMa_Flood -#if (defined SinglePoint) -#undef CaMa_Flood -#endif -#ifndef USEMPI -#undef CaMa_Flood -#endif - +! 6. Embedded grid river-lake routing. #define GridRiverLakeFlow ! Conflicts : #if (defined CATCHMENT || defined SinglePoint) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 index e4f9b1063c..8cb4a8bba1 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 @@ -29,12 +29,6 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) #ifdef HYPERSPECTRAL USE MOD_HighRes_Parameters #endif -#ifdef CaMa_Flood - ! get flood variables: inundation depth[mm], inundation fraction [0-1], - ! inundation evaporation [mm/s], inundation re-infiltration[mm/s] - USE MOD_CaMa_Vars, only: flddepth_cama,fldfrc_cama,fevpg_fld,finfg_fld -#endif - IMPLICIT NONE integer, intent(in) :: idate(3) ! model calendar for next time step (year, julian day, seconds) @@ -104,11 +98,6 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) dksatf(1:,i), dkdry(1:,i), BA_alpha(1:,i), BA_beta(1:,i), & rootfr(1:,m), lakedepth(i), dz_lake(1:,i), elvstd(i), & BVIC(i), & -#if (defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i), fevpg_fld(i), finfg_fld(i), & -#endif - ! VEGETATION INFORMATION htop(i), hbot(i), sqrtdi(m), & effcon(m), vmax25(m), c3c4(m), & @@ -321,11 +310,6 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& -#if (defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i) ,fevpg_fld(i) ,finfg_fld(i) ,& -#endif - ! additional diagnostic variables for output laisun(i) ,laisha(i) ,rss(i) ,& rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 index 8f53a8a6f2..2b2ca31314 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 @@ -20,11 +20,6 @@ SUBROUTINE CoLMMAIN ( & hksati, csol, k_solids, dksatu, & dksatf, dkdry, BA_alpha, BA_beta, & rootfr, lakedepth, dz_lake, elvstd, BVIC,& -#if (defined CaMa_Flood) - ! add flood depth, flood fraction, flood evaporation and - ! flood re-infiltration - flddepth, fldfrc, fevpg_fld, qinfl_fld, & -#endif ! vegetation information htop, hbot, sqrtdi, & @@ -196,11 +191,6 @@ SUBROUTINE CoLMMAIN ( & USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VariablySaturatedFlow, & DEF_USE_PLANTHYDRAULICS, DEF_USE_IRRIGATION USE MOD_LeafInterception -#if (defined CaMa_Flood) - ! get flood depth [mm], flood fraction[0-1], flood evaporation [mm/s], flood inflow [mm/s] - USE MOD_CaMa_colmCaMa, only: get_fldevp - USE YOS_CMF_INPUT, only: LWINFILT,LWEVAP -#endif #ifdef CROP USE MOD_Irrigation, only: CalIrrigationApplicationFluxes #endif @@ -375,14 +365,6 @@ SUBROUTINE CoLMMAIN ( & forc_hpbl ,&! atmospheric boundary layer height [m] forc_aerdep(14)!atmospheric aerosol deposition data [kg/m/s] -#if (defined CaMa_Flood) - real(r8), intent(in) :: fldfrc !inundation fraction - ! --> allow re-evaporation and infiltration![0-1] - real(r8), intent(inout) :: flddepth !inundation depth - ! --> allow re-evaporation and infiltration![mm] - real(r8), intent(out) :: fevpg_fld !effective evaporation from inundation [mm/s] - real(r8), intent(out) :: qinfl_fld !effective re-infiltration from inundation [mm/s] -#endif ! Variables required for restart run !----------------------------------------------------------------------- integer, intent(in) :: & @@ -648,27 +630,6 @@ SUBROUTINE CoLMMAIN ( & real(r8) :: wextra, t_rain, t_snow integer ps, pe, pc -#if (defined CaMa_Flood) - !add variables for flood evaporation [mm/s] and re-infiltration [mm/s] calculation. - real(r8) :: kk - real(r8) :: taux_fld ! wind stress: E-W [kg/m/s**2] - real(r8) :: tauy_fld ! wind stress: N-S [kg/m/s**2] - real(r8) :: fsena_fld ! sensible heat from agcm reference height to atmosphere [W/m2] - real(r8) :: fevpa_fld ! evaporation from agcm reference height to atmosphere [mm/s] - real(r8) :: fseng_fld ! sensible heat flux from ground [W/m2] - real(r8) :: tref_fld ! 2 m height air temperature [kelvin] - real(r8) :: qref_fld ! 2 m height air humidity - real(r8) :: z0m_fld ! effective roughness [m] - real(r8) :: zol_fld ! dimensionless height (z/L) used in Monin-Obukhov theory - real(r8) :: rib_fld ! bulk Richardson number in surface layer - real(r8) :: ustar_fld ! friction velocity [m/s] - real(r8) :: tstar_fld ! temperature scaling parameter - real(r8) :: qstar_fld ! moisture scaling parameter - real(r8) :: fm_fld ! integral of profile function for momentum - real(r8) :: fh_fld ! integral of profile function for heat - real(r8) :: fq_fld ! integral of profile function for moisture -#endif - !----------------------------------------------------------------------- z_soisno (maxsnl+1:0) = z_sno (maxsnl+1:0) @@ -910,11 +871,6 @@ SUBROUTINE CoLMMAIN ( & ssi ,wimp ,smpmin ,zwt ,& wdsrf ,wa ,qcharge ,& -#if (defined CaMa_Flood) - !add variables for flood depth [mm], flood fraction [0-1] - !and re-infiltration [mm/s] calculation. - flddepth ,fldfrc ,qinfl_fld ,& -#endif ! SNICAR model variables forc_aer ,& mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& @@ -944,11 +900,6 @@ SUBROUTINE CoLMMAIN ( & qinfl ,& qlayer ,ssi ,pondmx ,wimp ,& zwt ,wdsrf ,wa ,wetwat ,& -#if (defined CaMa_Flood) - !add variables for flood depth [mm], flood fraction [0-1] - !and re-infiltration [mm/s] calculation. - flddepth ,fldfrc ,qinfl_fld ,& -#endif ! SNICAR model variables forc_aer ,& mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& @@ -1047,14 +998,6 @@ SUBROUTINE CoLMMAIN ( & endwb = endwb + wetwat ENDIF ENDIF -#if (defined CaMa_Flood) - IF (LWINFILT) THEN - IF (patchtype == 0) THEN - endwb=endwb - qinfl_fld*deltim - ENDIF - ENDIF -#endif - #ifndef CatchLateralFlow errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa-rnof)*deltim #else @@ -1507,36 +1450,6 @@ SUBROUTINE CoLMMAIN ( & !====================================================================== ENDIF -#if (defined CaMa_Flood) - IF (LWEVAP) THEN - IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05).and.patchtype == 0)THEN - CALL get_fldevp (forc_hgt_u,forc_hgt_t,forc_hgt_q,& - forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf,t_grnd,& - forc_hpbl, & - taux_fld,tauy_fld,fseng_fld,fevpg_fld,tref_fld,qref_fld,& - z0m_fld,zol_fld,rib_fld,ustar_fld,qstar_fld,tstar_fld,fm_fld,fh_fld,fq_fld) - - IF (fevpg_fld<0.0) fevpg_fld=0.0d0 - - IF ((flddepth-deltim*fevpg_fld .gt. 0.0) .and. (fevpg_fld.gt.0.0)) THEN - flddepth=flddepth-deltim*fevpg_fld - fseng= fseng_fld*fldfrc+(1.0-fldfrc)*fseng - fevpg= fevpg_fld*fldfrc+(1.0-fldfrc)*fevpg - fevpg_fld=fevpg_fld*fldfrc - ELSE - fevpg_fld=0.0d0 - ENDIF - - ELSE - fevpg_fld=0.0d0 - ENDIF - - ELSE - fevpg_fld=0.0d0 - ENDIF -#endif - - !====================================================================== ! Preparation for the next time step ! 1) time-varying parameters for vegetation diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 index b36a691f70..62e2a12557 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 @@ -368,7 +368,7 @@ SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) IF (method == 1) THEN ! *** Reference *** ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. - ! Development of an Improved Reservoir Operation Scheme for Global Flood Modeling (CaMa-Flood v4.20). + ! Development of an improved reservoir operation scheme for global flood modeling. ! ESS Open Archive . October 24, 2024. IF (vol > volresv_emerg(irsv)) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 index 208dd12b8e..d41418d8ce 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -283,7 +283,7 @@ SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) IF (method == 1) THEN ! *** Reference *** ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. - ! Development of an Improved Reservoir Operation Scheme for Global Flood Modeling (CaMa-Flood v4.20). + ! Development of an improved reservoir operation scheme for global flood modeling. ! ESS Open Archive . October 24, 2024. IF (vol > volresv_emerg(irsv)) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index e14b03e58c..790931e487 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -143,8 +143,12 @@ SUBROUTINE grid_riverlake_flow (year, deltime) allocate (rnof_gd (numinpm)) allocate (rnof_uc (numucat)) - CALL compute_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & - fillvalue = 0., filter = filter_rnof) + IF (numpatch > 0) THEN + CALL compute_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & + fillvalue = 0., filter = filter_rnof) + ELSE + rnof_gd = 0._r8 + ENDIF IF (numinpm > 0) THEN WHERE (push_ucat2inpm%sum_area > 0) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 index 96cbcf9b47..e60eeee954 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 @@ -136,9 +136,6 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeInvariants, only: pftclass USE MOD_LandPFT, only: patch_pft_s -#endif -#if (defined CaMa_Flood) - USE MOD_CaMa_Vars !definition of CaMa variables #endif USE MOD_Forcing, only: forcmask_pch #ifdef DataAssimilation @@ -163,10 +160,6 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & logical :: lwrite character(len=256) :: file_hist integer :: itime_in_file -#if (defined CaMa_Flood) - character(len=256) :: file_hist_cama - integer :: itime_in_file_cama -#endif integer :: month, day integer :: days_month(1:12) character(len=10) :: cdate @@ -268,14 +261,6 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & write(*,*) 'Warning : Please USE one of DAY/MONTH/YEAR for history group.' ENDIF -#if (defined CaMa_Flood) - ! add variables to write cama-flood output. - ! file name of cama-flood output - file_hist_cama = trim(dir_hist) // '/' // trim(casename) //'_hist_cama_'//trim(cdate)//'.nc' - ! write CaMa-Flood output - CALL hist_write_cama_time (file_hist_cama, 'time', idate, itime_in_file_cama) -#endif - file_hist = trim(dir_hist) // '/' // trim(casename) //'_hist_'//trim(cdate)//'.nc' CALL hist_write_time (file_hist, file_last, 'time', idate, itime_in_file) @@ -4714,15 +4699,6 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_sensors, file_hist, 'f_sensors', itime_in_file, 'sensor', 1, nsensor, & sumarea, filter, 'variable sensors','user defined') -#if (defined CaMa_Flood) -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) THEN - CALL hist_out_cama (file_hist_cama, itime_in_file_cama) - ENDIF -#endif - #ifdef CatchLateralFlow CALL hist_basin_out (file_hist, idate) #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 index f2e366dfd8..051f429903 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 @@ -388,6 +388,7 @@ SUBROUTINE hist_gridded_write_time ( & integer :: iblkme, iblk, jblk logical :: fexists + itime = 0 IF (trim(DEF_HIST_mode) == 'one') THEN IF (p_is_root) THEN #ifdef USEMPI @@ -459,7 +460,11 @@ SUBROUTINE hist_gridded_write_time ( & ENDIF #ifdef USEMPI +#ifdef MPAS_EMBEDDED_COLM + CALL mpi_allreduce (MPI_IN_PLACE, itime, 1, MPI_INTEGER, MPI_MAX, p_comm_group, p_err) +#else IF (.not. p_is_root) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) +#endif #endif ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 index 8c11982acd..69deecce49 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 @@ -30,9 +30,6 @@ MODULE MOD_Irrigation USE MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs USE MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi -#ifdef CaMa_Flood - USE MOD_CaMa_Vars, only: withdrawal_cama, withdrawal_dam_cama, withdrawal_riv_cama, withdrawal_rof_cama -#endif USE MOD_SPMD_Task IMPLICIT NONE @@ -84,24 +81,6 @@ SUBROUTINE CalIrrigationNeeded(i,idate,nl_soil,nbedrock,z_soi,zi_soi,dz_soi,delt zwt_stand(i) = min(80., zwt_stand(i)) end if -#ifdef CaMa_Flood - ! irrigation withdraw from reservoir and river - reservoirriver_supply(i) = withdrawal_cama(i) - reservoir_supply(i) = withdrawal_dam_cama(i) - river_supply(i) = withdrawal_riv_cama(i) - runoff_supply(i) = withdrawal_rof_cama(i) - waterstorage(i) = waterstorage(i) + max(0._r8, reservoirriver_supply(i)) - withdrawal_cama(i) = 0._r8 - withdrawal_dam_cama(i) = 0._r8 - withdrawal_riv_cama(i) = 0._r8 - withdrawal_rof_cama(i) = 0._r8 - - ! IF (reservoirriver_supply(i) > 0) THEN - ! WRITE(*,*) "LHB debug line98 runoff error: p_iam_glb, ipatch, reservoirriver_supply ---> ", & - ! p_iam_glb, i, reservoirriver_supply(i) - ! ENDIF -#endif - ! ! calculate last day potential evapotranspiration ! CALL CalPotentialEvapotranspiration(i,idate,dlon,deltim) @@ -394,11 +373,6 @@ SUBROUTINE CalIrrigationLimitedSupply(i,nl_soil,deltim,dz_soi,zi_soi) waterstorage_supply = min(waterstorage(i), deficit_irrig(i)) waterstorage_supply = max(waterstorage_supply, 0._r8) actual_irrig(i) = actual_irrig(i) + waterstorage_supply -#ifdef CaMa_Flood - IF (deficit_irrig(i) > actual_irrig(i)) THEN - reservoirriver_demand(i) = max(deficit_irrig(i) - actual_irrig(i), 0._r8) - ENDIF -#endif ! irrigation withdraw from ground water (unconfined and confined) IF (deficit_irrig(i) > actual_irrig(i)) THEN groundwater_demand(i) = max(deficit_irrig(i) - actual_irrig(i), 0._r8) @@ -410,11 +384,6 @@ SUBROUTINE CalIrrigationLimitedSupply(i,nl_soil,deltim,dz_soi,zi_soi) waterstorage_supply = min(waterstorage(i), deficit_irrig(i)) waterstorage_supply = max(waterstorage_supply, 0._r8) actual_irrig(i) = actual_irrig(i) + waterstorage_supply -#ifdef CaMa_Flood - IF (deficit_irrig(i) > actual_irrig(i)) THEN - reservoirriver_demand(i) = max((deficit_irrig(i) - actual_irrig(i))*(1.-irrig_gw_alloc(i)), 0._r8) - ENDIF -#endif ! irrigation withdraw from ground water (unconfined and confined) IF (deficit_irrig(i) > actual_irrig(i)) THEN groundwater_demand(i) = max((deficit_irrig(i) - actual_irrig(i))*irrig_gw_alloc(i), 0._r8) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 index 94e0ebc91c..2628092057 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 @@ -4,7 +4,7 @@ MODULE MOD_LeafInterception ! !DESCRIPTION: ! For calculating vegetation canopy precipitation interception. ! -! This MODULE is the coupler for the colm and CaMa-Flood model. +! This module computes canopy interception and evaporation fluxes. !ANCILLARY FUNCTIONS AND SUBROUTINES !------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 index 74137a12db..372873169a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 @@ -9,9 +9,6 @@ MODULE MOD_SoilSnowHydrology DEF_SPLIT_SOILSNOW, DEF_Runoff_SCHEME, & DEF_DA_TWS_GRACE, DEF_Optimize_Baseflow, & DEF_USE_Dynamic_Wetland -#if (defined CaMa_Flood) - USE YOS_CMF_INPUT, only: LWINFILT -#endif USE MOD_LandPatch, only: landpatch USE MOD_Runoff USE MOD_Hydro_VIC @@ -50,9 +47,6 @@ SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& rsur ,rnof ,qinfl ,pondmx ,ssi ,& wimp ,smpmin ,zwt ,wdsrf ,wa ,& qcharge ,& -#if (defined CaMa_Flood) - flddepth ,fldfrc ,qinfl_fld ,& -#endif ! SNICAR model variables forc_aer ,& mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& @@ -138,11 +132,6 @@ SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& qfros_snow ,&! surface dew added to snow pack (mm h2o /s) [+] fsno ! snow fractional cover -#if (defined CaMa_Flood) - real(r8), intent(inout) :: flddepth ! inundation water depth [mm] - real(r8), intent(in) :: fldfrc ! inundation water depth [0-1] - real(r8), intent(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) -#endif real(r8), intent(inout) :: & wice_soisno(lb:nl_soil) ,&! ice lens (kg/m2) wliq_soisno(lb:nl_soil) ! liquid water (kg/m2) @@ -201,10 +190,6 @@ SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& zimm(0:nl_soil) ! interface level below a "z" level (mm) real(r8) :: err_solver, w_sum -#if (defined CaMa_Flood) - real(r8) ::gfld ,rsur_fld, qinfl_fld_subgrid ! inundation water input from top (mm/s) -#endif - real(r8) :: gwat_prev integer :: ps, pe, m @@ -343,51 +328,6 @@ SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& ! infiltration into surface soil layer qinfl = gwat - rsur - wdsrf/deltim -#if (defined CaMa_Flood) - IF (LWINFILT) THEN - ! re-infiltration [mm/s] calculation. - ! IF surface runoff is occurred (rsur != 0.), flood depth <1.e-6 and flood fraction <0.05, - ! the re-infiltration will not be calculated. - IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05) .and. (patchtype == 0) ) THEN - gfld=flddepth/deltim ! [mm/s] - ! surface runoff from inundation, this should not be added to the surface runoff from soil - ! otherwise, the surface runoff will be double counted. - ! only the re-infiltration is added to water balance calculation. - IF (DEF_Runoff_SCHEME == 0) THEN - - CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,1.0,fsatdcf,& - z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& - eff_porosity,icefrac,zwt,gfld,rsur_fld) - - ELSEIF (DEF_Runoff_SCHEME == 1) THEN - wliq_soisno_tmp(:) = 0 - CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & - wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gfld, & - vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& - rsur_fld, rsubst, wliq_soisno_tmp(1:nl_soil)) - ELSEIF (DEF_Runoff_SCHEME == 2) THEN - CALL Runoff_XinAnJiang (& - nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & - elvstd, gfld, deltim, rsur_fld, rsubst) - ELSEIF (DEF_Runoff_SCHEME == 3) THEN - CALL Runoff_SimpleVIC (& - nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & - BVIC, gfld, deltim, rsur_fld, rsubst) - ENDIF - ! infiltration into surface soil layer - qinfl_fld_subgrid = gfld - rsur_fld !assume the re-infiltration is occurred in whole patch area. - ELSE - qinfl_fld_subgrid=0.0d0 - gfld=0.0d0 - rsur_fld=0.0d0 - - ENDIF - qinfl_fld=qinfl_fld_subgrid*fldfrc ! [mm/s] re-infiltration in grid. - qinfl=qinfl_fld+qinfl ! [mm/s] total infiltration in grid. - flddepth=flddepth-deltim*qinfl_fld_subgrid ! renew flood depth [mm], the flood depth is reduced by re-infiltration but only in inundation area. - ENDIF -#endif - !======================================================================= ! [3] determine the change of soil water !======================================================================= @@ -446,13 +386,6 @@ SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim ENDIF -#if (defined CaMa_Flood) - IF (LWINFILT) THEN - err_solver = err_solver-(gfld-rsur_fld)*fldfrc*deltim - ENDIF -#endif - - #if (defined CoLMDEBUG) IF(abs(err_solver) > 1.e-3)THEN write(6,*) 'Warning: water balance violation after all soilwater calculation', err_solver @@ -515,9 +448,6 @@ SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& rsubst ,rnof ,qinfl ,qlayer ,ssi ,& pondmx ,wimp ,zwt ,wdsrf ,wa ,& wetwat ,& -#if (defined CaMa_Flood) - flddepth ,fldfrc ,qinfl_fld ,& -#endif ! SNICAR model variables forc_aer ,& mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& @@ -617,12 +547,6 @@ SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& qsubl_snow , &! sublimation rate from snow pack (mm h2o /s) [+] qfros_snow , &! surface dew added to snow pack (mm h2o /s) [+] fsno ! snow fractional cover -#if (defined CaMa_Flood) - real(r8), intent(inout) :: flddepth ! inundation water input from top (mm/s) - real(r8), intent(in) :: fldfrc ! inundation water input from top (mm/s) - real(r8), intent(out) :: qinfl_fld ! inundation water input from top (mm/s) -#endif - real(r8), intent(inout) :: & wice_soisno(lb:nl_soil) , &! ice lens (kg/m2) wliq_soisno(lb:nl_soil) ! liquid water (kg/m2) @@ -702,10 +626,6 @@ SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& integer, parameter :: nprms = 5 #endif real(r8) :: prms(nprms, 1:nl_soil) -#if (defined CaMa_Flood) - real(r8) :: gfld,qinfl_all,rsur_fld, qinfl_fld_subgrid! inundation water input from top (mm/s) -#endif - type(soil_con_struct ) :: soil_con type(cell_data_struct) :: cell real(r8) :: wliq_soisno_tmp(1:nl_soil) @@ -900,51 +820,6 @@ SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& ! infiltration into surface soil layer qgtop = gwat - rsur -#if (defined CaMa_Flood) - IF (LWINFILT) THEN - ! re-infiltration [mm/s] calculation. - ! IF surface runoff is occurred (rsur != 0.), flood depth <1.e-6 and flood fraction <0.05, - ! the re-infiltration will not be calculated. - IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05) .and. (patchtype == 0) ) THEN - gfld=flddepth/deltim ! [mm/s] - ! surface runoff from inundation, this should not be added to the surface runoff from soil - ! otherwise, the surface runoff will be double counted. - ! only the re-infiltration is added to water balance calculation. - IF (DEF_Runoff_SCHEME == 0) THEN - - CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,1.0,fsatdcf,& - z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& - eff_porosity,icefrac,zwt,gfld,rsur_fld) - - ELSEIF (DEF_Runoff_SCHEME == 1) THEN - wliq_soisno_tmp(:) = 0 - CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & - wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gfld, & - vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& - rsur_fld, rsubst, wliq_soisno_tmp(1:nl_soil)) - ELSEIF (DEF_Runoff_SCHEME == 2) THEN - CALL Runoff_XinAnJiang (& - nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & - elvstd, gfld, deltim, rsur_fld, rsubst) - ELSEIF (DEF_Runoff_SCHEME == 3) THEN - CALL Runoff_SimpleVIC (& - nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & - BVIC, gfld, deltim, rsur_fld, rsubst) - ENDIF - ! infiltration into surface soil layer - qinfl_fld_subgrid = gfld - rsur_fld !assume the re-infiltration is occurred in whole patch area. - ELSE - qinfl_fld_subgrid=0.0d0 - gfld=0.0d0 - rsur_fld=0.0d0 - - ENDIF - qinfl_fld=qinfl_fld_subgrid*fldfrc ! [mm/s] re-infiltration in grid. - !qinfl=qinfl_fld+qinfl ! [mm/s] total infiltration in grid. - qgtop=qinfl_fld+qgtop ! [mm/s] total infiltration in grid. - flddepth=flddepth-deltim*qinfl_fld_subgrid ! renew flood depth [mm], the flood depth is reduced by re-infiltration but only in inundation area. - ENDIF -#endif !======================================================================= ! [3] determine the change of soil water !======================================================================= @@ -1147,12 +1022,6 @@ SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim ENDIF -#if (defined CaMa_Flood) - IF (LWINFILT) THEN - err_solver = err_solver-(gfld-rsur_fld)*fldfrc*deltim - ENDIF -#endif - #if (defined CoLMDEBUG) IF(abs(err_solver) > 1.e-3)THEN write(6,'(A,E20.5,A,I0)') 'Warning (WATER_VSF): water balance violation', err_solver, & diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 index 92efbe9460..d7d7224079 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 @@ -81,12 +81,14 @@ SUBROUTINE READ_PFTimeInvariants (file_restart) character(len=*), intent(in) :: file_restart - CALL ncio_read_vector (file_restart, 'pftclass', landpft, pftclass) ! - CALL ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! - CALL ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! - CALL ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! + IF (numpft > 0) THEN + CALL ncio_read_vector (file_restart, 'pftclass', landpft, pftclass) ! + CALL ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! + CALL ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! + CALL ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! + ENDIF #ifdef CROP - CALL ncio_read_vector (file_restart, 'cropfrac ', landpatch, cropfrac) ! + IF (numpatch > 0) CALL ncio_read_vector (file_restart, 'cropfrac ', landpatch, cropfrac) ! #endif END SUBROUTINE READ_PFTimeInvariants @@ -106,17 +108,22 @@ SUBROUTINE WRITE_PFTimeInvariants (file_restart) compress = DEF_REST_CompressLevel - CALL ncio_create_file_vector (file_restart, landpft) - CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + IF (numpft > 0) THEN + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') - CALL ncio_write_vector (file_restart, 'pftclass', 'pft', landpft, pftclass, compress) ! - CALL ncio_write_vector (file_restart, 'pftfrac ', 'pft', landpft, pftfrac , compress) ! - CALL ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! - CALL ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! + CALL ncio_write_vector (file_restart, 'pftclass', 'pft', landpft, pftclass, compress) ! + CALL ncio_write_vector (file_restart, 'pftfrac ', 'pft', landpft, pftfrac , compress) ! + CALL ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! + CALL ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! + ENDIF #ifdef CROP - CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') - CALL ncio_write_vector (file_restart, 'cropfrac', 'patch', landpatch, cropfrac, compress) ! + IF (numpatch > 0) THEN + IF (numpft <= 0) CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'cropfrac', 'patch', landpatch, cropfrac, compress) ! + ENDIF #endif END SUBROUTINE WRITE_PFTimeInvariants @@ -134,10 +141,10 @@ SUBROUTINE deallocate_PFTimeInvariants deallocate (pftfrac ) deallocate (htop_p ) deallocate (hbot_p ) + ENDIF #ifdef CROP - deallocate (cropfrac) + IF (numpatch > 0) deallocate (cropfrac) #endif - ENDIF ENDIF END SUBROUTINE deallocate_PFTimeInvariants @@ -463,6 +470,10 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) write(cyear,'(i4.4)') lc_year file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + CALL ncio_read_vector (file_restart, 'patchclass', landpatch, patchclass) ! CALL ncio_read_vector (file_restart, 'patchtype' , landpatch, patchtype ) ! CALL ncio_read_vector (file_restart, 'patchmask' , landpatch, patchmask ) ! @@ -546,6 +557,10 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL ncio_read_vector (file_restart, 'elvstd ', landpatch, elvstd ) ! CALL ncio_read_vector (file_restart, 'slpratio', landpatch, slpratio) ! +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + CALL ncio_read_bcast_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] CALL ncio_read_bcast_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] CALL ncio_read_bcast_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] @@ -564,6 +579,10 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL ncio_read_bcast_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow CALL ncio_read_bcast_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + IF (DEF_USE_Forcing_Downscaling) THEN CALL ncio_read_vector (file_restart, 'slp_type_patches' , num_slope_type, landpatch, slp_type_patches) CALL ncio_read_vector (file_restart, 'svf_patches' , landpatch, svf_patches ) @@ -583,6 +602,10 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL ncio_read_vector (file_restart, 'cur_patches' , landpatch, cur_patches ) ENDIF +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) #ifdef SinglePoint IF (patchtypes(SITE_landtype) == 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 index 2a1ca48d80..0b6d23dc00 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 @@ -167,6 +167,10 @@ SUBROUTINE READ_PFTimeVariables (file_restart) character(len=*), intent(in) :: file_restart +#ifdef MPAS_EMBEDDED_COLM + IF (numpft <= 0) RETURN +#endif + CALL ncio_read_vector (file_restart, 'tleaf_p ', landpft, tleaf_p ) CALL ncio_read_vector (file_restart, 'ldew_p ', landpft, ldew_p ) CALL ncio_read_vector (file_restart, 'ldew_rain_p',landpft, ldew_rain_p ) @@ -229,10 +233,14 @@ SUBROUTINE WRITE_PFTimeVariables (file_restart) ! Local variables integer :: compress - compress = DEF_REST_CompressLevel + compress = DEF_REST_CompressLevel - CALL ncio_create_file_vector (file_restart, landpft) - CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') +#ifdef MPAS_EMBEDDED_COLM + IF (numpft <= 0) RETURN +#endif + + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') CALL ncio_define_dimension_vector (file_restart, landpft, 'band', 2) CALL ncio_define_dimension_vector (file_restart, landpft, 'rtyp', 2) @@ -1117,11 +1125,14 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) CALL mpi_barrier (p_comm_glb, p_err) #endif - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif - CALL ncio_create_file_vector (file_restart, landpatch) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) @@ -1270,18 +1281,13 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) #endif #if (defined CatchLateralFlow) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_CatchTimeVariables (file_restart) -#endif - -#ifdef GridRiverLakeFlow - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_GridRiverLakeTimeVars (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_CatchTimeVariables (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_UrbanTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_UrbanTimeVariables (file_restart) #endif #ifdef EXTERNAL_LAKE @@ -1289,10 +1295,19 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) #endif #ifdef DataAssimilation - CALL WRITE_DATimeVariables (idate, lc_year, site, dir_restart) + CALL WRITE_DATimeVariables (idate, lc_year, site, dir_restart) +#endif + +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + +#ifdef GridRiverLakeFlow + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_GridRiverLakeTimeVars (file_restart) #endif - END SUBROUTINE WRITE_TimeVariables + END SUBROUTINE WRITE_TimeVariables SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) @@ -1337,6 +1352,10 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + ! Time-varying state variables which required by restart run CALL ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] CALL ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] @@ -1473,11 +1492,19 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) CALL READ_CatchTimeVariables (file_restart) #endif +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + #ifdef GridRiverLakeFlow file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL READ_GridRiverLakeTimeVars (file_restart) #endif +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + #if (defined URBAN_MODEL) file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL READ_UrbanTimeVariables (file_restart) @@ -1495,6 +1522,10 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) CALL check_TimeVariables #endif +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + IF (p_is_root) THEN write(*,*) 'Loading Time Variables done.' ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 index 1949de5906..b3aad898d2 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 @@ -138,11 +138,6 @@ SUBROUTINE CoLMMAIN_Urban ( & mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& -#if (defined CaMa_Flood) - ! flood depth [mm], flood fraction[0-1], - ! flood evaporation [mm/s], flood re-infiltration [mm/s] - flddepth ,fldfrc ,fevpg_fld ,qinfl_fld ,& -#endif ! additional diagnostic variables for output laisun ,laisha ,rss ,& rstfac ,h2osoi ,wat ,& @@ -348,15 +343,6 @@ SUBROUTINE CoLMMAIN_Urban ( & forc_hgt_q ,&! observational height of humidity [m] forc_rhoair ! density air [kg/m3] -#if (defined CaMa_Flood) - real(r8), intent(in) :: fldfrc !inundation fraction - !--> allow re-evaporation and infiltration![0-1] - real(r8), intent(inout) :: flddepth !inundation depth - !--> allow re-evaporation and infiltration![mm] - real(r8), intent(out) :: fevpg_fld !effective evaporation from inundation [mm/s] - real(r8), intent(out) :: qinfl_fld !effective re-infiltration from inundation [mm/s] -#endif - ! Variables required for restart run ! ---------------------------------------------------------------------- real(r8), intent(inout) :: & @@ -1098,9 +1084,6 @@ SUBROUTINE CoLMMAIN_Urban ( & sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& lake_icefrac ,scv_lake ,snowdp_lake ,imeltl ,& fioldl ,w_old ,& -#if (defined CaMa_Flood) - flddepth ,fldfrc ,qinfl_fld ,& -#endif forc_us ,forc_vs ,& ! SNICAR model variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 index 63df6cac35..29b0d5ce6b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 @@ -62,9 +62,6 @@ SUBROUTINE UrbanHydrology ( & sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& lake_icefrac ,scv_lake ,snowdp_lake ,imelt_lake ,& fioldl ,w_old ,& -#if (defined CaMa_Flood) - flddepth ,fldfrc ,qinfl_fld ,& -#endif forc_us ,forc_vs ,& ! SNICAR model variables forc_aer ,& @@ -158,12 +155,6 @@ SUBROUTINE UrbanHydrology ( & real(r8), intent(inout) :: rootflux(1:nl_soil) -#if (defined CaMa_Flood) - real(r8), intent(inout) :: flddepth ! inundation water depth [mm] - real(r8), intent(in) :: fldfrc ! inundation water depth [0-1] - real(r8), intent(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) -#endif - real(r8), intent(in) :: forc_us real(r8), intent(in) :: forc_vs @@ -283,9 +274,6 @@ SUBROUTINE UrbanHydrology ( & 0. ,& ! fsno, not active rsur_gper ,rnof_gper ,qinfl ,pondmx ,ssi ,& wimp ,smpmin ,zwt ,wdsrf ,wa ,qcharge ,& -#if (defined CaMa_Flood) - flddepth ,fldfrc ,qinfl_fld ,& -#endif ! SNICAR model variables forc_aer ,& mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 index 907bbe3b67..24bfc019c8 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -1036,14 +1036,16 @@ SUBROUTINE mesh_free_mem () integer :: ie IF (allocated(mesh)) THEN - DO ie = 1, numelm - deallocate (mesh(ie)%ilon) - deallocate (mesh(ie)%ilat) + DO ie = 1, size(mesh) + IF (allocated(mesh(ie)%ilon)) deallocate (mesh(ie)%ilon) + IF (allocated(mesh(ie)%ilat)) deallocate (mesh(ie)%ilat) ENDDO deallocate (mesh) ENDIF + numelm = 0 + END SUBROUTINE mesh_free_mem END MODULE MOD_Mesh diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 index 4e0c56a636..d22cdf17ed 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 @@ -119,7 +119,7 @@ MODULE MOD_Namelist character(len=256) :: DEF_dir_history = 'path/to/history' ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! ----- Part 6: make surface data ----- +! ----- Part 6: landdata and surface inputs ----- ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=256) :: DEF_file_mesh = 'path/to/mesh/file' diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 index f025d752d3..89c0b68b60 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 @@ -1406,15 +1406,6 @@ SUBROUTINE ncio_define_dimension_int32 (filename, dimname, dimlen) CALL nccheck( nf90_def_var(ncid, 'lat', nf90_float, (/dimid/), varid) ) CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) - ELSEIF (trim(dimname) .eq.'lat_cama') THEN - !print *, 'lat-def' - CALL nccheck( nf90_def_var(ncid, 'lat_cama', nf90_float, (/dimid/), varid) ) - CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) - CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) - ELSEIF (trim(dimname) .eq.'lon_cama') THEN - CALL nccheck( nf90_def_var(ncid, 'lon_cama', nf90_float, (/dimid/), varid) ) - CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) - CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) ENDIF CALL nccheck (nf90_enddef(ncid)) ENDIF @@ -1458,16 +1449,6 @@ SUBROUTINE ncio_define_dimension_int64 (filename, dimname, dimlen) CALL nccheck( nf90_def_var(ncid, 'lat', nf90_float, (/dimid/), varid) ) CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) - ELSEIF (trim(dimname) .eq.'lat_cama') THEN - !print *, 'lat-def' - CALL nccheck( nf90_def_var(ncid, 'lat_cama', nf90_float, (/dimid/), varid) ) - CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) - CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) - ELSEIF (trim(dimname) .eq.'lon_cama') THEN - CALL nccheck( nf90_def_var(ncid, 'lon_cama', nf90_float, (/dimid/), varid) ) - CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) - CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) - ENDIF CALL nccheck (nf90_enddef(ncid)) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 index a268bc8681..a5276283a4 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -38,7 +38,7 @@ MODULE MOD_Pixelset ! "Vector" is a collection of data when each pixelset in a given level is associated ! with a value, representing its averaged physical, chemical or biological state. ! -! In standalone CoLM, vector data may be redistributed between ranks for IO. +! Legacy vector MPI I/O may redistribute vector data between ranks for IO. ! MPAS-embedded CoLM keeps land vectors on MPAS-owned cell subsets. ! ! Created by Shupeng Zhang, May 2023 @@ -268,8 +268,14 @@ SUBROUTINE pixelset_free_mem (this) IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + CALL vec_gather_scatter_free_mem(this%vecgs) + IF (allocated(this%pctshared)) deallocate(this%pctshared) + this%nset = 0 + this%nblkgrp = 0 + this%has_shared = .false. + END SUBROUTINE pixelset_free_mem ! -------------------------------- @@ -290,8 +296,14 @@ SUBROUTINE pixelset_forc_free_mem (this) IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + CALL vec_gather_scatter_free_mem(this%vecgs) + IF (allocated(this%pctshared)) deallocate(this%pctshared) + this%nset = 0 + this%nblkgrp = 0 + this%has_shared = .false. + END SUBROUTINE pixelset_forc_free_mem ! -------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 index 5318e75a93..80de18fdf7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 @@ -180,7 +180,7 @@ MODULE MOD_SingleSrfdata !----------------------------------------------------------------------- - SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) + SUBROUTINE read_surface_data_single (fsrfdata, for_surface_build) USE MOD_TimeManager USE MOD_Grid @@ -202,7 +202,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) IMPLICIT NONE character(len=*), intent(in) :: fsrfdata - logical, intent(in) :: mksrfdata + logical, intent(in) :: for_surface_build ! Local Variables real(r8) :: lat_in, lon_in @@ -226,7 +226,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) CALL Init_GlobalVars CALL Init_LC_Const - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,*) write(*,*) ' ---------------- Make Single Point Surface Data ---------------- ' ENDIF @@ -255,7 +255,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) LocalLongitude = SITE_lon_location ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location ENDIF @@ -278,7 +278,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) numpatch = 1 #ifdef LULC_USGS - u_site_landtype = (.not. mksrfdata) .or. (SITE_landtype >= 0) & + u_site_landtype = (.not. for_surface_build) .or. (SITE_landtype >= 0) & .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'USGS_classification')) IF (u_site_landtype) THEN @@ -292,7 +292,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) SITE_lon_location, SITE_lat_location, SITE_landtype) ENDIF #else - u_site_landtype = (.not. mksrfdata) .or. (SITE_landtype >= 0) & + u_site_landtype = (.not. for_surface_build) .or. (SITE_landtype >= 0) & .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'IGBP_classification')) IF (u_site_landtype) THEN @@ -320,7 +320,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ENDIF #endif - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), & ' (from ',trim(datasource(u_site_landtype)),')' ENDIF @@ -329,7 +329,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) #ifdef CROP IF (SITE_landtype == CROPLAND) THEN - readflag = ((.not. mksrfdata) .or. USE_SITE_pctcrop) + readflag = ((.not. for_surface_build) .or. USE_SITE_pctcrop) u_site_crop = readflag & .and. ncio_var_exist(fsrfdata,'croptyp',readflag) .and. ncio_var_exist(fsrfdata,'pctcrop',readflag) @@ -359,7 +359,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) SITE_croptyp = pack(croptyp, pctcrop > 0.) SITE_pctcrop = pack(pctcrop, pctcrop > 0.) / sum(pctcrop) - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(c,'(I0)') numpatch write(*,'(A,'//trim(c)//'I5,3A)') 'crop type : ', SITE_croptyp, ' (from ',trim(datasource(u_site_crop)),')' write(*,'(A,'//trim(c)//'F5.2,3A)') 'crop frac : ', SITE_pctcrop, ' (from ',trim(datasource(u_site_crop)),')' @@ -376,7 +376,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) #else IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN #endif - readflag = ((.not. mksrfdata) .or. USE_SITE_pctpfts) + readflag = ((.not. for_surface_build) .or. USE_SITE_pctpfts) u_site_pfts = readflag & .and. ncio_var_exist(fsrfdata,'pfttyp',readflag) .and. ncio_var_exist(fsrfdata,'pctpfts',readflag) @@ -421,7 +421,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) CALL CoLM_stop() ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN IF (numpft > 0) THEN write(*,'(4A)') 'PFT type and fraction : ', ' (from ',trim(datasource(u_site_pfts)),')' DO i = 1, numpft @@ -434,7 +434,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ! (4) forest height - readflag = (.not. mksrfdata) .or. USE_SITE_htop + readflag = (.not. for_surface_build) .or. USE_SITE_htop #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (patchtypes(SITE_landtype) == 0) THEN u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height_pfts',readflag) @@ -479,7 +479,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) #endif ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (patchtypes(SITE_landtype) == 0) THEN arraysize = size(SITE_htop_pfts) @@ -495,7 +495,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ! (5) LAI - readflag = ((.not. mksrfdata) .or. USE_SITE_LAI) + readflag = ((.not. for_surface_build) .or. USE_SITE_LAI) readflag = readflag .and. ncio_var_exist(fsrfdata,'LAI_year',readflag) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (patchtypes(SITE_landtype) == 0) THEN @@ -652,7 +652,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ENDDO ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN DO iyear = start_year, end_year write(c,'(i2)') ntime #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) @@ -687,7 +687,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ! (6) lake depth - readflag = ((.not. mksrfdata) .or. USE_SITE_lakedepth) + readflag = ((.not. for_surface_build) .or. USE_SITE_lakedepth) u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag) IF (u_site_lakedepth) THEN @@ -700,13 +700,13 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) SITE_lakedepth = lakedepth * 0.1 ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',trim(datasource(u_site_lakedepth)),')' ENDIF ! (7) soil brightness parameters - readflag = ((.not. mksrfdata) .or. USE_SITE_soilreflectance) + readflag = ((.not. for_surface_build) .or. USE_SITE_soilreflectance) u_site_soil_bright = readflag & .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) & .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) & @@ -743,7 +743,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ENDIF ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' @@ -755,7 +755,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) CALL gridsoil%define_by_name ('colm_500m') - readflag = ((.not. mksrfdata) .or. USE_SITE_soilparameters) + readflag = ((.not. for_surface_build) .or. USE_SITE_soilparameters) u_site_vf_quartz_mineral = readflag & .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag) IF (u_site_vf_quartz_mineral) THEN @@ -1124,7 +1124,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ENDIF ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')' write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')' write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')' @@ -1162,7 +1162,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ! (9) depth to bedrock IF (DEF_USE_BEDROCK) THEN - readflag = ((.not. mksrfdata) .or. USE_SITE_dbedrock) + readflag = ((.not. for_surface_build) .or. USE_SITE_dbedrock) u_site_dbedrock = readflag & .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag) IF (u_site_dbedrock) THEN @@ -1174,14 +1174,14 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) SITE_lon_location, SITE_lat_location, SITE_dbedrock) ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',trim(datasource(u_site_dbedrock)),')' ENDIF ENDIF ! (10) topography - readflag = ((.not. mksrfdata) .or. USE_SITE_topography) + readflag = ((.not. for_surface_build) .or. USE_SITE_topography) u_site_elevation = readflag & .and. ncio_var_exist (fsrfdata, 'elevation',readflag) @@ -1326,7 +1326,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ENDIF ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation , ' (from ',trim(datasource(u_site_elevation)),')' write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd , ' (from ',trim(datasource(u_site_elvstd)),')' write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio, ' (from ',trim(datasource(u_site_sloperatio)),')' @@ -1346,7 +1346,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ENDIF - IF (.not. mksrfdata) THEN + IF (.not. for_surface_build) THEN landpatch%nset = numpatch @@ -1414,7 +1414,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) END SUBROUTINE read_surface_data_single !----------------------------------------------------------------------- - SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) + SUBROUTINE read_urban_surface_data_single (fsrfdata, for_surface_build, mkrun) USE MOD_TimeManager USE MOD_Grid @@ -1433,7 +1433,7 @@ SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) IMPLICIT NONE character(len=*), intent(in) :: fsrfdata - logical, intent(in) :: mksrfdata + logical, intent(in) :: for_surface_build logical, intent(in), optional :: mkrun ! Local Variables @@ -1473,7 +1473,7 @@ SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) u_site_tbmax = .false.; u_site_tbmin = .false.; u_site_thickr = .false.; u_site_thickw = .false.; u_site_pop = .false.; u_site_lucy = .false.; - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,*) write(*,*) ' ---------------- Make Single Point Surface Data ---------------- ' ENDIF @@ -1502,7 +1502,7 @@ SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) LocalLongitude = SITE_lon_location ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location ENDIF @@ -1530,12 +1530,12 @@ SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) numpatch = 1 numurban = 1 u_site_landtype = (SITE_landtype >= 0) - IF (mksrfdata) THEN + IF (for_surface_build) THEN write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), & ' (from ',trim(datasource(u_site_landtype)),')' ENDIF - IF (mksrfdata) THEN + IF (for_surface_build) THEN ! (2) build/read "urban type" by using land cover type data IF (DEF_URBAN_type_scheme == 1) THEN u_site_utype = ncio_var_exist(fsrfdata,'URBAN_DENSITY_CLASS') @@ -2725,7 +2725,7 @@ SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) ENDIF ENDIF - IF (.not. mksrfdata) THEN + IF (.not. for_surface_build) THEN landpatch%nset = numpatch diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 index 1cd796c060..a47fa6e21c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 @@ -449,7 +449,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDIF -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) IF (p_is_compute) THEN DO iproc = 0, p_np_active-1 @@ -784,7 +784,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) #endif ENDIF -#ifdef USEMPI +#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) IF (p_is_compute) THEN DO iproc = 0, p_np_active-1 idest = p_address_active(iproc) @@ -1863,6 +1863,37 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) +#ifdef MPAS_EMBEDDED_COLM + IF (p_is_active) CALL flush_block_data (sumarea, 0.0_r8) + + IF (p_is_compute) THEN + DO iset = 1, this%npset + + IF (present(filter)) THEN + IF (.not. filter(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + IF (p_address_active(iproc) /= p_iam_glb) CYCLE + + iloc = this%address(iset)%val(2,ipart) + ilon = this%glist(iproc)%ilon(iloc) + ilat = this%glist(iproc)%ilat(iloc) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + sumarea%blk(xblk,yblk)%val(xloc,yloc) = & + sumarea%blk(xblk,yblk)%val(xloc,yloc) + this%areapart(iset)%val(ipart) + ENDDO + ENDDO + ENDIF + + RETURN +#endif + IF (p_is_compute) THEN allocate (pbuff (0:p_np_active-1)) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 index a4d52c86fe..f56f51a1f0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -356,6 +356,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) IF (p_is_active) THEN + CALL mesh_free_mem() numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) IF (numelm > 0) THEN @@ -434,6 +435,7 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDDO numelm = ndsp + IF (numelm == 0) CALL mesh_free_mem() ENDIF IF (use_subset .and. allocated(nelm_blk)) THEN @@ -571,6 +573,8 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc' + CALL pixelset%forc_free_mem() + IF (p_is_active) THEN pixelset%nset = 0 From 9bc967857780622d563377d759c8ddc8915f084f Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Sun, 12 Jul 2026 22:50:28 +0800 Subject: [PATCH 16/17] Integrate CoLM2024 under MPAS-owned land and MPI domains Constraint: Preserve CoLM native 10-layer soil and patch/PFT state while mapping one MPAS cell to one CoLM element. Rejected: Separate CoLM process pool or replicated global river state | violates MPAS rank ownership and memory scaling. Rejected: Remove all CoLM MPI calls | distributed river routing and restart require sparse cross-rank communication absent from mpas_dmpar. Confidence: high Scope-risk: broad Directive: Keep MPAS as the sole MPI/context/decomposition owner and preserve CoLM native 10-layer and patch/PFT state. Tested: CMake Debug; OpenMP Release; CMake install; CoLM-off baseline; GNU Make mpi_f08 full link; bounds-check MPI exchange, river, and repartitioned restart tests. Not-tested: Full production MPAS-CoLM forecast with real landdata and atmospheric forcing. --- CMakeLists.txt | 12 +- cmake/Functions/MPAS_Functions.cmake | 8 +- src/core_atmosphere/CMakeLists.txt | 132 +- src/core_atmosphere/Registry.xml | 19 +- src/core_atmosphere/mpas_atm_core.F | 10 +- src/core_atmosphere/physics/Makefile | 153 +- .../physics/Registry_colm2024.xml | 47 + .../physics/mpas_atmphys_control.F | 39 +- .../physics/mpas_atmphys_driver.F | 27 +- .../mpas_atmphys_driver_lsm_colm2024.F | 756 ++- .../physics/mpas_atmphys_finalize.F | 16 +- .../physics/mpas_atmphys_init.F | 2 +- .../physics/mpas_atmphys_packages.F | 3 + .../physics/mpas_atmphys_vars.F | 4 +- .../physics/physics_colm2024/README.md | 10 + .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 1722 ++++-- .../physics/physics_colm2024/include/define.h | 37 +- .../main/BGC/MOD_BGC_CNBalanceCheck.F90 | 18 +- .../main/BGC/MOD_BGC_CNSASU.F90 | 3 +- .../main/BGC/MOD_BGC_CNSummary.F90 | 10 +- .../MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 | 2 +- ...MOD_BGC_Soil_BiogeochemVerticalProfile.F90 | 5 +- .../main/BGC/MOD_BGC_Vars_1DFluxes.F90 | 12 +- .../main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 | 12 +- .../main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 | 10 +- .../main/BGC/MOD_BGC_Vars_TimeInvariants.F90 | 24 +- .../main/BGC/MOD_BGC_Vars_TimeVariables.F90 | 12 +- .../main/BGC/MOD_BGC_Veg_CNPhenology.F90 | 2 +- .../physics_colm2024/main/CoLMDRIVER.F90 | 15 +- .../physics_colm2024/main/CoLMMAIN.F90 | 2 +- .../physics_colm2024/main/DA/MOD_DA_Const.F90 | 143 - .../physics_colm2024/main/DA/MOD_DA_EnKF.F90 | 137 - .../main/DA/MOD_DA_Ensemble.F90 | 267 - .../physics_colm2024/main/DA/MOD_DA_Main.F90 | 396 -- .../physics_colm2024/main/DA/MOD_DA_RTM.F90 | 1431 ----- .../physics_colm2024/main/DA/MOD_DA_SM.F90 | 1787 ------ .../physics_colm2024/main/DA/MOD_DA_TWS.F90 | 440 -- .../main/DA/MOD_DA_Vars_1DFluxes.F90 | 92 - .../main/DA/MOD_DA_Vars_TimeVariables.F90 | 716 --- .../main/HYDRO/MOD_Catch_BasinNetwork.F90 | 494 -- .../main/HYDRO/MOD_Catch_HillslopeFlow.F90 | 310 - .../main/HYDRO/MOD_Catch_HillslopeNetwork.F90 | 381 -- .../main/HYDRO/MOD_Catch_Hist.F90 | 490 -- .../main/HYDRO/MOD_Catch_LateralFlow.F90 | 496 -- .../main/HYDRO/MOD_Catch_Reservoir.F90 | 497 -- .../main/HYDRO/MOD_Catch_RiverLakeFlow.F90 | 596 -- .../main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 | 1145 ---- .../main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 | 823 --- .../main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 | 115 - .../HYDRO/MOD_Catch_Vars_TimeVariables.F90 | 178 - .../main/HYDRO/MOD_Catch_WriteParameters.F90 | 230 - .../main/HYDRO/MOD_ElementNeighbour.F90 | 711 --- .../main/HYDRO/MOD_Grid_Reservoir.F90 | 127 +- .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 226 +- .../main/HYDRO/MOD_Grid_RiverLakeHist.F90 | 756 --- .../main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 | 2105 ++----- .../main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 | 353 +- .../main/HYDRO/MOD_Hydro_SoilWater.F90 | 55 +- .../main/HYDRO/MOD_Vector_ReadWrite.F90 | 291 - .../main/MOD_CheckEquilibrium.F90 | 685 --- .../physics_colm2024/main/MOD_CropReadin.F90 | 377 -- .../physics_colm2024/main/MOD_FireData.F90 | 14 +- .../physics_colm2024/main/MOD_Forcing.F90 | 1810 ------ .../main/MOD_ForcingDownscaling.F90 | 1049 ---- .../physics_colm2024/main/MOD_Glacier.F90 | 3 +- .../main/MOD_GroundTemperature.F90 | 2 +- .../physics_colm2024/main/MOD_Hist.F90 | 5033 ----------------- .../physics_colm2024/main/MOD_HistGridded.F90 | 1079 ---- .../physics_colm2024/main/MOD_HistSingle.F90 | 370 -- .../physics_colm2024/main/MOD_HistVector.F90 | 623 -- .../main/MOD_HistWriteBack.F90 | 743 --- .../physics_colm2024/main/MOD_Irrigation.F90 | 2 +- .../physics_colm2024/main/MOD_LAIReadin.F90 | 6 +- .../main/MOD_LeafInterception.F90 | 29 +- .../main/MOD_LeafTemperature.F90 | 12 +- .../main/MOD_LeafTemperaturePC.F90 | 13 +- .../main/MOD_LightningData.F90 | 2 +- .../physics_colm2024/main/MOD_NdepData.F90 | 12 +- .../physics_colm2024/main/MOD_NitrifData.F90 | 16 +- .../physics_colm2024/main/MOD_Ozone.F90 | 6 +- .../physics_colm2024/main/MOD_PhaseChange.F90 | 6 +- .../main/MOD_PlantHydraulic.F90 | 2 +- .../physics_colm2024/main/MOD_Runoff.F90 | 2 +- .../physics_colm2024/main/MOD_SnowSnicar.F90 | 70 +- .../main/MOD_SnowSnicar_HiRes.F90 | 70 +- .../physics_colm2024/main/MOD_Thermal.F90 | 2 +- .../main/MOD_UserSpecifiedForcing.F90 | 969 ---- .../main/MOD_Vars_1DAccFluxes.F90 | 2970 ---------- .../main/MOD_Vars_1DFluxes.F90 | 8 +- .../main/MOD_Vars_1DForcing.F90 | 47 +- .../main/MOD_Vars_1DPFTFluxes.F90 | 12 +- .../main/MOD_Vars_2DForcing.F90 | 81 - .../main/MOD_Vars_TimeInvariants.F90 | 67 +- .../main/MOD_Vars_TimeVariables.F90 | 115 +- .../main/MOD_VicParaReadin.F90 | 12 +- .../main/ParaOpt/MOD_Opt_Baseflow.F90 | 40 +- .../main/URBAN/MOD_Urban_Flux.F90 | 14 +- .../main/URBAN/MOD_Urban_LAIReadin.F90 | 4 +- .../main/URBAN/MOD_Urban_Shortwave.F90 | 2 +- .../main/URBAN/MOD_Urban_Thermal.F90 | 2 +- .../main/URBAN/MOD_Urban_Vars_1DFluxes.F90 | 12 +- .../URBAN/MOD_Urban_Vars_TimeInvariants.F90 | 8 +- .../URBAN/MOD_Urban_Vars_TimeVariables.F90 | 8 +- .../share/MOD_5x5DataReadin.F90 | 20 +- .../share/MOD_AggregationRequestData.F90 | 709 --- .../physics_colm2024/share/MOD_Block.F90 | 495 +- .../share/MOD_CatchmentDataReadin.F90 | 375 -- .../share/MOD_ComputePushData.F90 | 578 +- .../physics_colm2024/share/MOD_DataType.F90 | 26 +- .../physics_colm2024/share/MOD_ElmVector.F90 | 188 - .../physics_colm2024/share/MOD_Grid.F90 | 64 +- .../physics_colm2024/share/MOD_HRUVector.F90 | 215 - .../physics_colm2024/share/MOD_Land2mWMO.F90 | 249 - .../physics_colm2024/share/MOD_LandCrop.F90 | 152 - .../physics_colm2024/share/MOD_LandElm.F90 | 21 +- .../physics_colm2024/share/MOD_LandHRU.F90 | 252 - .../physics_colm2024/share/MOD_LandPFT.F90 | 244 +- .../physics_colm2024/share/MOD_LandPatch.F90 | 273 - .../physics_colm2024/share/MOD_LandUrban.F90 | 340 +- .../physics_colm2024/share/MOD_MPAS_MPI.F90 | 115 + .../physics_colm2024/share/MOD_Mesh.F90 | 928 +-- .../physics_colm2024/share/MOD_MeshFilter.F90 | 181 - .../physics_colm2024/share/MOD_Namelist.F90 | 552 +- .../share/MOD_NetCDFBlock.F90 | 28 +- .../share/MOD_NetCDFSerial.F90 | 146 +- .../share/MOD_NetCDFVector.F90 | 2257 +++++--- .../physics_colm2024/share/MOD_Pixel.F90 | 61 +- .../physics_colm2024/share/MOD_Pixelset.F90 | 126 +- .../share/MOD_PixelsetShared.F90 | 213 - .../physics_colm2024/share/MOD_RangeCheck.F90 | 886 --- .../physics_colm2024/share/MOD_SPMD_Task.F90 | 212 - .../share/MOD_SingleSrfdata.F90 | 3472 ------------ .../share/MOD_SpatialMapping.F90 | 727 +-- .../share/MOD_SrfdataRestart.F90 | 535 +- .../share/MOD_TimeManager.F90 | 10 +- .../physics_colm2024/share/MOD_Utils.F90 | 35 + 136 files changed, 6536 insertions(+), 43470 deletions(-) create mode 100644 src/core_atmosphere/physics/Registry_colm2024.xml delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 create mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 delete mode 100644 src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index c934cde3e9..8c5d7a6079 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -24,6 +24,10 @@ option(BUILD_SHARED_LIBS "Build shared libraries" ON) option(MPAS_USE_PIO "Build with PIO I/O library" OFF) option(MPAS_COLM2024 "Build atmosphere core with embedded CoLM2024 land-surface physics" OFF) +if(MPAS_COLM2024 AND NOT DO_PHYSICS) + message(FATAL_ERROR "MPAS_COLM2024 requires DO_PHYSICS=ON because CoLM2024 is built into the atmosphere physics driver.") +endif() + message(STATUS "[OPTION] MPAS_CORES: ${MPAS_CORES}") message(STATUS "[OPTION] MPAS_DOUBLE_PRECISION: ${MPAS_DOUBLE_PRECISION}") message(STATUS "[OPTION] MPAS_PROFILE: ${MPAS_PROFILE}") @@ -45,8 +49,11 @@ if(NOT CMAKE_BUILD_TYPE) endif() # Detect MPAS git version +if(DEFINED GIT_EXECUTABLE AND NOT EXISTS "${GIT_EXECUTABLE}") + unset(GIT_EXECUTABLE CACHE) +endif() +find_package(Git QUIET) if(NOT MPAS_GIT_VERSION) - find_package(Git QUIET) if(GIT_FOUND) execute_process(COMMAND ${GIT_EXECUTABLE} describe --dirty WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}" @@ -73,9 +80,6 @@ find_package(PnetCDF REQUIRED COMPONENTS Fortran) if(MPAS_USE_PIO OR MPAS_COLM2024) find_package(NetCDF REQUIRED COMPONENTS Fortran C) endif() -if(MPAS_COLM2024) - find_package(LAPACK REQUIRED) -endif() if(MPAS_USE_PIO) find_package(PIO REQUIRED COMPONENTS Fortran C) endif() diff --git a/cmake/Functions/MPAS_Functions.cmake b/cmake/Functions/MPAS_Functions.cmake index 1a349d13fc..db2240f4bd 100644 --- a/cmake/Functions/MPAS_Functions.cmake +++ b/cmake/Functions/MPAS_Functions.cmake @@ -148,7 +148,8 @@ function(mpas_fortran_target target) endfunction() -# mpas_core_target(CORE TARGET INCLUDE ) +# mpas_core_target(CORE TARGET +# INCLUDES REGISTRY_DEPENDS ) # # Common configuration and properties for `MPAS::core::` targets. # * Calls mpas_fortran_target() for common Fortran target configuration. @@ -164,9 +165,10 @@ endfunction() # CORE - Name of core # TARGET - Name of core_target (without namespace) # INCLUDES - List of generated include files +# REGISTRY_DEPENDS - Files included by the core Registry.xml preprocessor input # function(mpas_core_target) - cmake_parse_arguments(ARG "" "CORE;TARGET" "INCLUDES" ${ARGN}) + cmake_parse_arguments(ARG "" "CORE;TARGET" "INCLUDES;REGISTRY_DEPENDS" ${ARGN}) mpas_fortran_target(${ARG_TARGET}) @@ -219,7 +221,7 @@ function(mpas_core_target) add_custom_command(OUTPUT ${REGISTRY_PROCESSED_XML} COMMAND ${CPP_EXECUTABLE} -E -P ${CPP_EXTRA_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml > ${REGISTRY_PROCESSED_XML} COMMENT "CORE ${ARG_CORE}: Pre-Process Registry" - DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml) + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml ${ARG_REGISTRY_DEPENDS}) add_custom_command(OUTPUT ${ARG_INCLUDES} COMMAND mpas_parse_${ARG_CORE} ${REGISTRY_PROCESSED_XML} ${CPP_EXTRA_FLAGS} COMMENT "CORE ${ARG_CORE}: Parse Registry" diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 9780e83714..b71a0295e2 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -301,6 +301,8 @@ list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES PREPEND physics/physics if(MPAS_COLM2024) set(COLM2024_SOURCE_ROOT ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_colm2024) + set_property(DIRECTORY APPEND PROPERTY CMAKE_CONFIGURE_DEPENDS + ${COLM2024_SOURCE_ROOT}/include/define.h) set(COLM2024_SOURCE_SEARCH_DIRS share main @@ -334,14 +336,67 @@ if(MPAS_COLM2024) list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES ${_colm2024_src_rel}) continue() endif() - list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES ${_colm2024_src_rel}) + list(APPEND COLM2024_AVAILABLE_SOURCES ${_colm2024_src_rel}) + string(REGEX MATCHALL "(^|\n)[ \t]*MODULE[ \t]+[A-Z][A-Z0-9_]*" _colm2024_module_lines + "${_colm2024_preprocessed_src_upper}") + foreach(_colm2024_module_line IN LISTS _colm2024_module_lines) + if(_colm2024_module_line MATCHES "MODULE[ \t]+PROCEDURE") + continue() + endif() + string(REGEX REPLACE ".*MODULE[ \t]+([A-Z][A-Z0-9_]*).*" "\\1" _colm2024_module_name + "${_colm2024_module_line}") + set(COLM2024_MODULE_SOURCE_${_colm2024_module_name} ${_colm2024_src_rel}) + endforeach() + string(REGEX MATCHALL "(^|\n)[ \t]*USE[^\n]*" _colm2024_use_lines + "${_colm2024_preprocessed_src_upper}") + set(_colm2024_source_uses) + foreach(_colm2024_use_line IN LISTS _colm2024_use_lines) + if(_colm2024_use_line MATCHES "INTRINSIC") + continue() + endif() + if(_colm2024_use_line MATCHES "USE[ \t]*(,[^:]*)?(::)?[ \t]*([A-Z][A-Z0-9_]*)") + list(APPEND _colm2024_source_uses ${CMAKE_MATCH_3}) + endif() + endforeach() + if(_colm2024_source_uses) + list(REMOVE_DUPLICATES _colm2024_source_uses) + endif() + string(MAKE_C_IDENTIFIER "${_colm2024_src_rel}" _colm2024_src_key) + set(COLM2024_SOURCE_USES_${_colm2024_src_key} ${_colm2024_source_uses}) + endforeach() + set(ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES + physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 + physics/physics_colm2024/main/CoLMDRIVER.F90 + physics/physics_colm2024/main/CoLMMAIN.F90 + physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 + ) + foreach(_colm2024_root IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + if(NOT "${_colm2024_root}" IN_LIST COLM2024_AVAILABLE_SOURCES) + message(FATAL_ERROR "Required embedded CoLM2024 source is unavailable: ${_colm2024_root}") + endif() endforeach() + + set(_colm2024_previous_source_count -1) list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES _colm2024_source_count) - if(_colm2024_source_count EQUAL 0) - message(FATAL_ERROR "CoLM2024 CMake source list is empty") - endif() + while(NOT _colm2024_previous_source_count EQUAL _colm2024_source_count) + set(_colm2024_previous_source_count ${_colm2024_source_count}) + foreach(_colm2024_src IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + string(MAKE_C_IDENTIFIER "${_colm2024_src}" _colm2024_src_key) + foreach(_colm2024_use IN LISTS COLM2024_SOURCE_USES_${_colm2024_src_key}) + if(DEFINED COLM2024_MODULE_SOURCE_${_colm2024_use}) + list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES + ${COLM2024_MODULE_SOURCE_${_colm2024_use}}) + endif() + endforeach() + endforeach() + list(REMOVE_DUPLICATES ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES _colm2024_source_count) + endwhile() + list(SORT ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES _colm2024_skipped_empty_count) - message(STATUS "CoLM2024 embedded CMake sources: ${_colm2024_source_count}") + list(LENGTH COLM2024_AVAILABLE_SOURCES _colm2024_available_source_count) + message(STATUS "CoLM2024 embedded CMake sources: ${_colm2024_source_count} of ${_colm2024_available_source_count}") message(STATUS "CoLM2024 embedded CMake skipped empty sources: ${_colm2024_skipped_empty_count}") function(_colm2024_object_path out source) @@ -365,40 +420,23 @@ if(MPAS_COLM2024) endif() endfunction() - _colm2024_source_depends( - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90) - _colm2024_source_depends( - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 - physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90) - _colm2024_source_depends( - physics/physics_colm2024/main/MOD_HistGridded.F90 - physics/physics_colm2024/main/MOD_HistWriteBack.F90) - _colm2024_source_depends( - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90) - _colm2024_source_depends( - physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90) - _colm2024_source_depends( - physics/physics_colm2024/main/MOD_Hist.F90 - physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90) - _colm2024_source_depends( - physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 - physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 - physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90) - _colm2024_source_depends( - physics/mpas_atmphys_driver_lsm_colm2024.F - physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90) + foreach(_colm2024_src IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + string(MAKE_C_IDENTIFIER "${_colm2024_src}" _colm2024_src_key) + set(_colm2024_dep_sources) + set(_colm2024_source_uses ${COLM2024_SOURCE_USES_${_colm2024_src_key}}) + foreach(_colm2024_use IN LISTS _colm2024_source_uses) + if(DEFINED COLM2024_MODULE_SOURCE_${_colm2024_use}) + set(_colm2024_dep_source ${COLM2024_MODULE_SOURCE_${_colm2024_use}}) + if(NOT _colm2024_dep_source STREQUAL _colm2024_src) + list(APPEND _colm2024_dep_sources ${_colm2024_dep_source}) + endif() + endif() + endforeach() + if(_colm2024_dep_sources) + list(REMOVE_DUPLICATES _colm2024_dep_sources) + _colm2024_source_depends(${_colm2024_src} ${_colm2024_dep_sources}) + endif() + endforeach() endif() # diagnostics/ @@ -476,18 +514,10 @@ target_compile_definitions(core_atmosphere PRIVATE ${CORE_ATMOSPHERE_COMPILE_DEF if (MPAS_COLM2024) target_include_directories(core_atmosphere PRIVATE ${COLM2024_SOURCE_ROOT}/include) target_link_libraries(core_atmosphere PUBLIC NetCDF::NetCDF_Fortran NetCDF::NetCDF_C) - if(TARGET LAPACK::LAPACK) - target_link_libraries(core_atmosphere PUBLIC LAPACK::LAPACK) - else() - target_link_libraries(core_atmosphere PUBLIC ${LAPACK_LIBRARIES}) - endif() set_property(SOURCE ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} PROPERTY Fortran_PREPROCESS ON) if(CMAKE_Fortran_COMPILER_ID MATCHES GNU) set(_colm2024_compile_options -fdefault-real-8 -ffree-line-length-none) - if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) - list(APPEND _colm2024_compile_options -fallow-argument-mismatch) - endif() elseif(CMAKE_Fortran_COMPILER_ID MATCHES Intel) set(_colm2024_compile_options -real-size 64) elseif(CMAKE_Fortran_COMPILER_ID MATCHES NVHPC) @@ -499,7 +529,13 @@ if (MPAS_COLM2024) endif() endif () set_MPAS_DEBUG_flag(core_atmosphere) -mpas_core_target(CORE atmosphere TARGET core_atmosphere INCLUDES ${ATMOSPHERE_CORE_INCLUDES}) +set(ATMOSPHERE_REGISTRY_DEPENDS + ${CMAKE_CURRENT_SOURCE_DIR}/diagnostics/Registry_diagnostics.xml + ${CMAKE_CURRENT_SOURCE_DIR}/physics/Registry_noahmp.xml + ${CMAKE_CURRENT_SOURCE_DIR}/physics/Registry_colm2024.xml) +mpas_core_target(CORE atmosphere TARGET core_atmosphere + INCLUDES ${ATMOSPHERE_CORE_INCLUDES} + REGISTRY_DEPENDS ${ATMOSPHERE_REGISTRY_DEPENDS}) #Get physics_wrf tables from MPAS-Data include(FetchContent) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 8b0ff5241e..2200b7ed12 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1027,13 +1027,19 @@ + + + + + + #endif @@ -2235,8 +2241,8 @@ + description="number of soil layers in the selected land surface scheme" + possible_values="For Noah and Noah-MP use 4; for CoLM2024 use its 10 native soil layers."/> - - + @@ -4045,5 +4051,6 @@ #ifdef DO_PHYSICS #include "physics/Registry_noahmp.xml" +#include "physics/Registry_colm2024.xml" #endif diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 792d9f561d..c7b80f0fe0 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -626,6 +626,9 @@ function atm_core_run(domain) result(ierr) use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atm_boundaries, only : mpas_atm_update_bdy_tend use mpas_atm_diagnostics_manager, only : mpas_atm_diag_update, mpas_atm_diag_compute, mpas_atm_diag_reset +#ifdef DO_PHYSICS + use mpas_atmphys_finalize, only : atmphys_write_restart +#endif implicit none @@ -859,6 +862,12 @@ function atm_core_run(domain) result(ierr) call mpas_timer_start('stream_output') call mpas_dmpar_get_time(output_start_time) +#ifdef DO_PHYSICS + if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='restart', & + direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then + call atmphys_write_restart(domain % blocklist % configs) + end if +#endif call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_dmpar_get_time(output_stop_time) call mpas_timer_stop('stream_output') @@ -1850,4 +1859,3 @@ subroutine atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_ end subroutine atm_initialize_deformation_weights end module atm_core - diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 0422dc4da0..c0143db0e0 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -10,7 +10,6 @@ COLM2024_CORE = core_physics_colm2024_embedded COLM2024_BUILD_DIR = physics_colm2024/.mpas_bld COLM2024_HEADER = physics_colm2024/include/define.h COLM2024_STAMP = $(COLM2024_BUILD_DIR)/.built -COLM2024_MOD_CMD ?= -J NF_CONFIG ?= nf-config COLM2024_NETCDF_INC ?= $(shell $(NF_CONFIG) --includedir 2>/dev/null || nc-config --includedir 2>/dev/null) COLM2024_INCLUDES = -I./physics_colm2024/include -I./$(COLM2024_BUILD_DIR) @@ -23,14 +22,27 @@ endif ifneq ($(strip $(PNETCDF_INC)),) COLM2024_INCLUDES += -I$(PNETCDF_INC) endif -COLM2024_FOPTS ?= $(CPPFLAGS) $(COREDEF) $(FFLAGS) -fdefault-real-8 -ffree-form -cpp -ffree-line-length-0 -fallow-argument-mismatch +COLM2024_FC_NAME := $(notdir $(firstword $(FC))) +COLM2024_FC_VERSION := $(shell $(FC) --version 2>/dev/null | sed -n '1p') +COLM2024_FC_ID_TEXT = $(COLM2024_FC_NAME) $(COLM2024_FC_VERSION) +COLM2024_FOPTS_BASE = $(CPPFLAGS) $(COREDEF) $(FFLAGS) +ifneq (,$(strip $(findstring gfortran,$(COLM2024_FC_ID_TEXT)) $(findstring GNU Fortran,$(COLM2024_FC_ID_TEXT)))) +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) -std=legacy -fno-implicit-none -fdefault-real-8 -fdefault-double-8 -ffree-form -cpp -ffree-line-length-0 +COLM2024_MOD_FLAGS ?= -J$(COLM2024_BUILD_DIR) +else ifneq (,$(strip $(filter ifort ifx mpiifort mpiifx,$(COLM2024_FC_NAME)) $(findstring Intel,$(COLM2024_FC_ID_TEXT)))) +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) -real-size 64 -free -fpp +COLM2024_MOD_FLAGS ?= -module $(COLM2024_BUILD_DIR) +else ifneq (,$(strip $(filter nvfortran pgfortran pgf90,$(COLM2024_FC_NAME)) $(findstring nvfortran,$(COLM2024_FC_ID_TEXT)) $(findstring NVIDIA,$(COLM2024_FC_ID_TEXT)))) +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) -r8 -Mfree -Mpreprocess +COLM2024_MOD_FLAGS ?= -module $(COLM2024_BUILD_DIR) +else +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) +COLM2024_MOD_FLAGS ?= -J$(COLM2024_BUILD_DIR) +endif COLM2024_SOURCE_DIRS = \ physics_colm2024/share \ physics_colm2024/main \ physics_colm2024/main/HYDRO \ - physics_colm2024/main/BGC \ - physics_colm2024/main/URBAN \ - physics_colm2024/main/DA \ physics_colm2024/main/ParaOpt \ physics_colm2024/drivers/mpas COLM2024_SOURCES = $(foreach dir,$(COLM2024_SOURCE_DIRS),$(wildcard $(dir)/*.F90)) @@ -108,12 +120,12 @@ core_physics_noahmp: ifeq "$(COLM2024_ENABLED)" "true" COLM2024_OBJS_SHARED_NAMES = \ MOD_Precision.o \ - MOD_SPMD_Task.o \ + MOD_MPAS_MPI.o \ + MOD_Utils.o \ MOD_Namelist.o \ MOD_Vars_Global.o \ MOD_Const_Physical.o \ MOD_Const_LC.o \ - MOD_Utils.o \ MOD_IncompleteGamma.o \ MOD_UserDefFun.o \ MOD_TimeManager.o \ @@ -123,54 +135,23 @@ COLM2024_OBJS_SHARED_NAMES = \ MOD_Grid.o \ MOD_Pixel.o \ MOD_DataType.o \ - MOD_NetCDFPoint.o \ MOD_NetCDFBlock.o \ - MOD_CatchmentDataReadin.o \ - MOD_5x5DataReadin.o \ MOD_Mesh.o \ MOD_Pixelset.o \ MOD_NetCDFVector.o \ - MOD_RangeCheck.o \ MOD_SpatialMapping.o \ MOD_ComputePushData.o \ - MOD_AggregationRequestData.o \ - MOD_PixelsetShared.o \ MOD_LandElm.o \ - MOD_LandHRU.o \ MOD_LandPatch.o \ - MOD_Land2mWMO.o \ - MOD_LandCrop.o \ MOD_LandPFT.o \ MOD_LandUrban.o \ - MOD_Urban_Const_LCZ.o \ - MOD_SingleSrfdata.o \ - MOD_SrfdataRestart.o \ - MOD_ElmVector.o \ - MOD_HRUVector.o \ - MOD_MeshFilter.o + MOD_SrfdataRestart.o COLM2024_OBJS_BASIC_NAMES = \ - MOD_Vector_ReadWrite.o \ - MOD_dataSpec_PDB.o \ - MOD_tav_abs.o \ - MOD_prospect_DB.o \ - MOD_Catch_BasinNetwork.o \ - MOD_Catch_Vars_TimeVariables.o \ - MOD_Catch_Vars_1DFluxes.o \ MOD_Grid_RiverLakeNetwork.o \ MOD_Grid_Reservoir.o \ MOD_Grid_RiverLakeTimeVars.o \ - MOD_BGC_Vars_1DFluxes.o \ - MOD_BGC_Vars_1DPFTFluxes.o \ - MOD_BGC_Vars_PFTimeVariables.o \ - MOD_BGC_Vars_TimeInvariants.o \ - MOD_BGC_Vars_TimeVariables.o \ - MOD_Urban_Vars_1DFluxes.o \ - MOD_Urban_Vars_TimeVariables.o \ - MOD_Urban_Vars_TimeInvariants.o \ - MOD_DA_Vars_1DFluxes.o \ MOD_Vars_TimeInvariants.o \ - MOD_DA_Vars_TimeVariables.o \ MOD_Vars_TimeVariables.o \ MOD_Vars_1DPFTFluxes.o \ MOD_Vars_1DFluxes.o \ @@ -181,79 +162,16 @@ COLM2024_OBJS_BASIC_NAMES = \ MOD_Qsadv.o \ MOD_LAIEmpirical.o \ MOD_LAIReadin.o \ - MOD_CropReadin.o \ - MOD_NitrifData.o \ - MOD_NdepData.o \ - MOD_FireData.o \ MOD_OrbCoszen.o \ - MOD_OrbCosazi.o \ - MOD_HighRes_Parameters.o \ MOD_3DCanopyRadiation.o \ MOD_Aerosol.o \ MOD_SnowSnicar.o \ MOD_Albedo.o \ - MOD_SnowSnicar_HiRes.o \ - MOD_Albedo_HiRes.o \ MOD_SnowFraction.o \ - MOD_Urban_LAIReadin.o \ - MOD_Urban_Shortwave.o \ - MOD_Urban_Albedo.o \ - MOD_MonthlyinSituCO2MaunaLoa.o \ - MOD_BGC_CNSummary.o \ - MOD_ElementNeighbour.o \ - MOD_Catch_HillslopeNetwork.o \ - MOD_Catch_RiverLakeNetwork.o \ - MOD_Catch_Reservoir.o \ - MOD_VicParaReadin.o + MOD_MonthlyinSituCO2MaunaLoa.o COLM2024_OBJS_MAIN_NAMES = \ - MOD_Catch_HillslopeFlow.o \ - MOD_Catch_SubsurfaceFlow.o \ - MOD_Catch_RiverLakeFlow.o \ - MOD_Catch_Hist.o \ - MOD_Catch_WriteParameters.o \ - MOD_BGC_CNCStateUpdate1.o \ - MOD_BGC_CNCStateUpdate2.o \ - MOD_BGC_CNCStateUpdate3.o \ - MOD_BGC_CNNStateUpdate1.o \ - MOD_BGC_CNNStateUpdate2.o \ - MOD_BGC_CNNStateUpdate3.o \ - MOD_BGC_Soil_BiogeochemNStateUpdate1.o \ - MOD_BGC_Soil_BiogeochemNitrifDenitrif.o \ - MOD_BGC_Soil_BiogeochemCompetition.o \ - MOD_BGC_Soil_BiogeochemDecompCascadeBGC.o \ - MOD_BGC_Soil_BiogeochemDecomp.o \ - MOD_BGC_Soil_BiogeochemLittVertTransp.o \ - MOD_BGC_Soil_BiogeochemNLeaching.o \ - MOD_BGC_Soil_BiogeochemPotential.o \ - MOD_BGC_Soil_BiogeochemVerticalProfile.o \ - MOD_BGC_Veg_CNGapMortality.o \ - MOD_BGC_Veg_CNGResp.o \ - MOD_BGC_Veg_CNMResp.o \ - MOD_BGC_Daylength.o \ - MOD_BGC_Veg_CNPhenology.o \ - MOD_BGC_Veg_NutrientCompetition.o \ - MOD_BGC_Veg_CNVegStructUpdate.o \ - MOD_BGC_CNAnnualUpdate.o \ - MOD_BGC_CNZeroFluxes.o \ - MOD_BGC_CNBalanceCheck.o \ - MOD_BGC_CNSASU.o \ - MOD_BGC_Veg_CNNDynamics.o \ - MOD_BGC_Veg_CNFireBase.o \ - MOD_BGC_Veg_CNFireLi2016.o \ - MOD_Vars_2DForcing.o \ - MOD_UserSpecifiedForcing.o \ - MOD_ForcingDownscaling.o \ - MOD_Forcing.o \ - MOD_DA_TWS.o \ - MOD_DA_Const.o \ - MOD_DA_RTM.o \ - MOD_DA_EnKF.o \ - MOD_DA_SM.o \ - MOD_DA_Ensemble.o \ - MOD_DA_Main.o \ MOD_Opt_Baseflow.o \ - MOD_ParameterOptimization.o \ MOD_AssimStomataConductance.o \ MOD_PlantHydraulic.o \ MOD_FrictionVelocity.o \ @@ -276,39 +194,12 @@ COLM2024_OBJS_MAIN_NAMES = \ MOD_GroundTemperature.o \ MOD_LeafInterception.o \ MOD_NetSolar.o \ - MOD_NetSolar_Hyper.o \ MOD_WetBulb.o \ MOD_RainSnowTemp.o \ MOD_SoilSurfaceResistance.o \ MOD_NewSnow.o \ MOD_Thermal.o \ - MOD_Vars_1DAccFluxes.o \ - MOD_Irrigation.o \ - MOD_BGC_driver.o \ - MOD_HistWriteBack.o \ - MOD_HistGridded.o \ - MOD_HistVector.o \ - MOD_HistSingle.o \ - MOD_Grid_RiverLakeHist.o \ - MOD_Hist.o \ - MOD_CheckEquilibrium.o \ - MOD_LightningData.o \ - MOD_Catch_LateralFlow.o \ MOD_Grid_RiverLakeFlow.o \ - MOD_Urban_Longwave.o \ - MOD_Urban_NetSolar.o \ - MOD_Urban_Flux.o \ - MOD_Urban_GroundFlux.o \ - MOD_Urban_RoofFlux.o \ - MOD_Urban_RoofTemperature.o \ - MOD_Urban_WallTemperature.o \ - MOD_Urban_PerviousTemperature.o \ - MOD_Urban_ImperviousTemperature.o \ - MOD_Urban_Hydrology.o \ - MOD_Urban_BEM.o \ - MOD_Urban_LUCY.o \ - MOD_Urban_Thermal.o \ - CoLMMAIN_Urban.o \ CoLMDRIVER.o \ MOD_CoLM_MPAS_Interface.o \ CoLMMAIN.o @@ -336,7 +227,7 @@ $(COLM2024_STAMP): $(COLM2024_HEADER) $(COLM2024_SOURCES) | $(COLM2024_BUILD_DIR exit 1; \ fi; \ echo " $$src"; \ - $(FC) -c $(COLM2024_FOPTS) $(COLM2024_INCLUDES) -o "$(COLM2024_BUILD_DIR)/$$obj" "$$src" $(COLM2024_MOD_CMD)$(COLM2024_BUILD_DIR); \ + $(FC) -c $(COLM2024_FOPTS) $(COLM2024_INCLUDES) -o "$(COLM2024_BUILD_DIR)/$$obj" "$$src" $(COLM2024_MOD_FLAGS); \ done; \ touch $@ endif diff --git a/src/core_atmosphere/physics/Registry_colm2024.xml b/src/core_atmosphere/physics/Registry_colm2024.xml new file mode 100644 index 0000000000..77bbe168b4 --- /dev/null +++ b/src/core_atmosphere/physics/Registry_colm2024.xml @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index c83013c5ee..ee18c0c52b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -352,7 +352,9 @@ subroutine physics_registry_init(mesh,configs,sfc_input) real(kind=RKIND),dimension(:,:),pointer:: dzs !local variables: - integer:: iCell + integer,parameter:: colm_soil_levels = 10 + integer:: iCell,iSoil + real(kind=RKIND):: colm_z(colm_soil_levels),colm_dz(colm_soil_levels) !----------------------------------------------------------------------------------------------------------------- @@ -364,20 +366,39 @@ subroutine physics_registry_init(mesh,configs,sfc_input) call mpas_pool_get_array(sfc_input,'landmask',landmask) call mpas_pool_get_array(sfc_input,'dzs' , dzs ) + if(trim(config_lsm_scheme) == "sf_colm2024" .and. size(dzs,1) /= colm_soil_levels) then + call physics_error_fatal("CoLM2024 requires num_soil_layers=10 so MPAS retains the complete native soil column.") + endif + !initialization of input variables, if needed: if(.not. config_do_restart) then lsm_select: select case(trim(config_lsm_scheme)) - case("sf_noah","sf_noahmp") - !initialize the thickness of the soil layers for the Noah scheme: - do iCell = 1, nCells - dzs(1,iCell) = 0.10_RKIND - dzs(2,iCell) = 0.30_RKIND - dzs(3,iCell) = 0.60_RKIND - dzs(4,iCell) = 1.00_RKIND - enddo + case("sf_noah","sf_noahmp") + if(size(dzs,1) < 4) then + call physics_error_fatal("Noah/Noah-MP requires at least four MPAS soil layers.") + endif + do iCell = 1, nCells + dzs(1,iCell) = 0.10_RKIND + dzs(2,iCell) = 0.30_RKIND + dzs(3,iCell) = 0.60_RKIND + dzs(4,iCell) = 1.00_RKIND + enddo + + case("sf_colm2024") + do iSoil = 1, colm_soil_levels + colm_z(iSoil) = 0.025_RKIND * (exp(0.5_RKIND * (real(iSoil,RKIND)-0.5_RKIND)) - 1._RKIND) + enddo + colm_dz(1) = 0.5_RKIND * (colm_z(1) + colm_z(2)) + do iSoil = 2, colm_soil_levels-1 + colm_dz(iSoil) = 0.5_RKIND * (colm_z(iSoil+1) - colm_z(iSoil-1)) + enddo + colm_dz(colm_soil_levels) = colm_z(colm_soil_levels) - colm_z(colm_soil_levels-1) + do iCell = 1, nCells + dzs(:,iCell) = colm_dz + enddo case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 1538930736..8020480685 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -123,9 +123,10 @@ subroutine physics_driver(domain,itimestep,xtime_s) type(mpas_pool_type),pointer:: configs, & mesh, & state, & - diag, & - diag_physics, & - diag_physics_noahmp, & + diag, & + diag_physics, & + diag_physics_colm2024, & + diag_physics_noahmp, & output_noahmp, & tend_physics, & atm_input, & @@ -187,9 +188,9 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) call mpas_pool_get_subpool(block%structs,'state' ,state ) - call mpas_pool_get_subpool(block%structs,'diag' ,diag ) - call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) - call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) + call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) call mpas_pool_get_subpool(block%structs,'output_noahmp' ,output_noahmp ) call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) @@ -271,8 +272,8 @@ subroutine physics_driver(domain,itimestep,xtime_s) if(config_oml1d) call driver_oml1d(block%configs,mesh,diag,diag_physics,sfc_input) - call push_lsm_colm2024(block,block%configs,mesh,state,time_lev,diag,diag_physics, & - sfc_input,itimestep,cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) + call push_lsm_colm2024(block,block%configs,mesh,state,time_lev,diag,diag_physics,atm_input, & + sfc_input,cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) call deallocate_forall_physics(block%configs) block => block % next @@ -285,9 +286,10 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) call mpas_pool_get_subpool(block%structs,'state' ,state ) - call mpas_pool_get_subpool(block%structs,'diag' ,diag ) - call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) - call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) + call mpas_pool_get_subpool(block%structs,'diag_physics_colm2024',diag_physics_colm2024) + call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) call mpas_pool_get_subpool(block%structs,'output_noahmp' ,output_noahmp ) call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) call mpas_pool_get_subpool(block%structs,'ngw_input' ,ngw_input ) @@ -307,7 +309,8 @@ subroutine physics_driver(domain,itimestep,xtime_s) end do !$OMP END PARALLEL DO - call pull_lsm_colm2024(block,diag_physics,sfc_input,cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) + call pull_lsm_colm2024(block,diag_physics,diag_physics_colm2024,sfc_input, & + cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) call allocate_seaice(block%configs) !$OMP PARALLEL DO diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index aeca5641a5..c4d2e85d93 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -10,27 +10,42 @@ module mpas_atmphys_driver_lsm_colm2024 use mpas_kind_types use mpas_derived_types, only: block_type, dm_info use mpas_pool_routines + use mpas_timekeeping, only: MPAS_Clock_type, MPAS_Time_type, MPAS_START_TIME, MPAS_STOP_TIME, & + mpas_get_clock_time, mpas_get_time + use, intrinsic :: ieee_arithmetic, only: ieee_is_finite - use mpas_atmphys_constants, only: R_d, R_v - use mpas_atmphys_manager, only: year, curr_julday + use mpas_atmphys_constants, only: R_d, R_v, cp use mpas_atmphys_utilities, only: physics_error_fatal use mpas_atmphys_vars, only: dt_pbl, xice_threshold #ifdef MPAS_COLM2024 - use MOD_Precision, only: colm_r8 => r8 + use mpi, only: MPI_COMM_NULL, MPI_SUCCESS, MPI_Comm_dup, MPI_Comm_free + use MOD_Precision, only: colm_r8 => r8 use MOD_CoLM_MPAS_Interface, only: colm_mpas_initialize_from_namelist, colm_mpas_ready, & colm_mpas_set_element_forcing, & - colm_mpas_step, colm_mpas_get_element_surface, & - colm_mpas_get_element_state, & + colm_mpas_step, colm_mpas_get_element_surface, & + colm_mpas_get_element_boundary_state, & + colm_mpas_get_element_state, & + colm_mpas_get_element_river_state, & + colm_mpas_force_restart, & colm_mpas_finalize - use MOD_Vars_Global, only: colm_dz_soi => dz_soi + use MOD_Vars_Global, only: colm_nl_soil => nl_soil, colm_dz_soi => dz_soi, colm_z_soi => z_soi + use MOD_Const_Physical, only: colm_denh2o => denh2o, colm_denice => denice + use MOD_TimeManager, only: colm_ticktime => ticktime, colm_adj2begin => adj2begin, & + colm_adj2end => adj2end, & + colm_julian2monthday => julian2monthday + use MOD_MonthlyinSituCO2MaunaLoa, only: colm_init_monthly_co2_mlo => init_monthly_co2_mlo, & + colm_get_monthly_co2_mlo => get_monthly_co2_mlo + use MOD_Namelist, only: colm_use_ozone_data => DEF_USE_OZONEDATA, & + colm_use_cbl_height => DEF_USE_CBL_HEIGHT #endif implicit none private - public :: init_lsm_colm2024, push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024, finalize_lsm_colm2024 + public :: init_lsm_colm2024, push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024 + public :: checkpoint_lsm_colm2024, finalize_lsm_colm2024 - logical, save :: colm_first_step = .true. + logical, save :: colm_update_lai_next_step = .true. #ifdef MPAS_COLM2024 type colm_block_map_type integer :: local_block_id = -1 @@ -38,48 +53,116 @@ module mpas_atmphys_driver_lsm_colm2024 type(colm_block_map_type), pointer :: next => null() end type colm_block_map_type - type(colm_block_map_type), pointer, save :: colm_block_maps => null() - logical, save :: colm_initialized = .false. + type(colm_block_map_type), pointer, save :: colm_block_maps => null() + logical, save :: colm_initialized = .false. + integer, save :: colm_mpas_comm = MPI_COMM_NULL + integer, save :: colm_step_idate(3) = -1 #endif contains !================================================================================================================= - subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) + subroutine init_lsm_colm2024(dminfo,configs,clock,block) !================================================================================================================= type(dm_info),intent(in):: dminfo type(mpas_pool_type),intent(in):: configs + type(MPAS_Clock_type),intent(in):: clock type(block_type),intent(in):: block - type(mpas_pool_type),intent(inout):: diag_physics - type(mpas_pool_type),intent(inout):: sfc_input #ifdef MPAS_COLM2024 logical :: colm_ready + logical,pointer:: config_do_restart integer :: colm_ierr - integer :: colm_mpas_comm + integer :: mpas_domain_comm + integer :: mpi_ierr integer :: colm_patch_count integer :: block_cells integer :: n_mpas_cells integer :: offset + integer :: start_year, start_month, start_day, start_doy + integer :: start_hour, start_minute, start_second, start_second_num, start_second_den + integer :: stop_year, stop_doy + integer :: stop_hour, stop_minute, stop_second, stop_second_num, stop_second_den + integer :: mpas_start_idate(3), mpas_stop_idate(3) character(len=StrKIND),pointer:: config_colm2024_namelist + character(len=StrKIND),pointer:: config_calendar_type + character(len=StrKIND),pointer:: config_pbl_scheme + character(len=StrKIND),pointer:: config_radt_lw_scheme + character(len=StrKIND),pointer:: config_radt_sw_scheme + character(len=StrKIND),pointer:: config_sfclayer_scheme integer,pointer:: nCellsSolve integer,dimension(:),pointer:: indexToCellID integer,allocatable:: cell_to_element(:), mpas_cell_id(:) + real(kind=RKIND),dimension(:),pointer:: latCell, lonCell + real(kind=colm_r8),allocatable:: mpas_cell_lat(:), mpas_cell_lon(:) + real(kind=colm_r8) :: mpas_colm_timestep + type(MPAS_Time_type):: start_time, stop_time type(block_type),pointer:: block_cursor type(colm_block_map_type),pointer:: block_map - type(mpas_pool_type),pointer:: block_mesh + type(mpas_pool_type),pointer:: block_mesh, block_diag_physics, block_diag_physics_colm2024, block_sfc_input #endif #ifdef MPAS_COLM2024 - call mpas_pool_get_config(configs,'config_colm2024_namelist',config_colm2024_namelist) + call mpas_pool_get_config(configs,'config_colm2024_namelist',config_colm2024_namelist) + call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) if(trim(config_colm2024_namelist) == 'none' .or. trim(config_colm2024_namelist) == '') then call physics_error_fatal("config_lsm_scheme='sf_colm2024' requires config_colm2024_namelist.") endif + call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',config_sfclayer_scheme) + if(trim(config_radt_lw_scheme) == 'off') then + call physics_error_fatal("CoLM2024 requires an active MPAS longwave-radiation scheme.") + endif + if(trim(config_radt_sw_scheme) /= 'rrtmg_sw') then + call physics_error_fatal("CoLM2024 requires config_radt_sw_scheme='rrtmg_sw' for VIS/NIR direct/diffuse fluxes.") + endif + if(trim(config_sfclayer_scheme) == 'off') then + call physics_error_fatal("CoLM2024 requires an active MPAS surface-layer scheme for PBL coupling.") + endif + if(colm_initialized) return if(associated(block % next)) return if(.not. associated(block % domain)) call physics_error_fatal("CoLM2024 MPAS block is missing its owning domain.") + call mpas_pool_get_config(configs,'config_calendar_type',config_calendar_type) + if(trim(config_calendar_type) /= 'gregorian') then + call physics_error_fatal("CoLM2024 embedded time management requires config_calendar_type='gregorian'.") + endif + + start_time = mpas_get_clock_time(clock, MPAS_START_TIME, colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to obtain the MPAS start time for CoLM2024.") + call mpas_get_time(start_time, YYYY=start_year, MM=start_month, DD=start_day, DoY=start_doy, & + H=start_hour, M=start_minute, S=start_second, S_n=start_second_num, & + S_d=start_second_den, ierr=colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to decode the MPAS start time for CoLM2024.") + if(start_second_num /= 0) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second MPAS start time.") + endif + mpas_start_idate = (/start_year, start_doy, start_hour * 3600 + start_minute * 60 + start_second/) + + stop_time = mpas_get_clock_time(clock, MPAS_STOP_TIME, colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to obtain the MPAS stop time for CoLM2024.") + call mpas_get_time(stop_time, YYYY=stop_year, DoY=stop_doy, H=stop_hour, M=stop_minute, & + S=stop_second, S_n=stop_second_num, S_d=stop_second_den, ierr=colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to decode the MPAS stop time for CoLM2024.") + if(stop_second_num /= 0) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second MPAS stop time.") + endif + mpas_stop_idate = (/stop_year, stop_doy, stop_hour * 3600 + stop_minute * 60 + stop_second/) + call colm_adj2end(mpas_stop_idate) + + mpas_colm_timestep = real(dt_pbl, colm_r8) + if(.not. ieee_is_finite(mpas_colm_timestep) .or. mpas_colm_timestep <= 0._colm_r8 .or. & + mpas_colm_timestep > 3600._colm_r8) then + call physics_error_fatal("CoLM2024 requires an MPAS land-surface timestep in (0, 3600] seconds.") + endif + if(abs(mpas_colm_timestep - real(nint(mpas_colm_timestep), colm_r8)) > 1.e-6_colm_r8) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second MPAS timestep.") + endif + call colm2024_free_block_maps() n_mpas_cells = 0 @@ -90,7 +173,8 @@ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) n_mpas_cells = n_mpas_cells + nCellsSolve block_cursor => block_cursor % next enddo - allocate(mpas_cell_id(n_mpas_cells), cell_to_element(n_mpas_cells)) + allocate(mpas_cell_id(n_mpas_cells), mpas_cell_lat(n_mpas_cells), mpas_cell_lon(n_mpas_cells), & + cell_to_element(n_mpas_cells)) offset = 0 block_cursor => block % domain % blocklist @@ -98,10 +182,14 @@ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) call mpas_pool_get_array(block_mesh,'indexToCellID',indexToCellID) + call mpas_pool_get_array(block_mesh,'latCell',latCell) + call mpas_pool_get_array(block_mesh,'lonCell',lonCell) block_cells = nCellsSolve if(block_cells > 0) then mpas_cell_id(offset+1:offset+block_cells) = indexToCellID(1:block_cells) + mpas_cell_lat(offset+1:offset+block_cells) = real(latCell(1:block_cells), colm_r8) + mpas_cell_lon(offset+1:offset+block_cells) = real(lonCell(1:block_cells), colm_r8) endif call colm2024_add_block_map(block_cursor % localBlockID, size(indexToCellID)) offset = offset + block_cells @@ -109,17 +197,34 @@ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) enddo #ifdef MPAS_USE_MPI_F08 - colm_mpas_comm = dminfo % comm % mpi_val + mpas_domain_comm = dminfo % comm % mpi_val #else - colm_mpas_comm = dminfo % comm + mpas_domain_comm = dminfo % comm #endif + if(colm_mpas_comm /= MPI_COMM_NULL) then + call physics_error_fatal("CoLM2024 MPAS communication context was initialized more than once.") + endif + call MPI_Comm_dup(mpas_domain_comm, colm_mpas_comm, mpi_ierr) + if(mpi_ierr /= MPI_SUCCESS) then + call physics_error_fatal("MPAS could not create the CoLM2024 communication context.") + endif - call colm_mpas_initialize_from_namelist(trim(config_colm2024_namelist), colm_ierr, & + call colm_mpas_initialize_from_namelist(trim(config_colm2024_namelist), colm_ierr, & mpas_comm=colm_mpas_comm, & mpas_cell_id=mpas_cell_id, & + mpas_cell_lat=mpas_cell_lat, & + mpas_cell_lon=mpas_cell_lon, & n_mpas_cells=n_mpas_cells, & - cell_to_element=cell_to_element) + cell_to_element=cell_to_element, & + mpas_start_idate=mpas_start_idate, & + mpas_stop_idate=mpas_stop_idate, & + mpas_timestep=mpas_colm_timestep, & + mpas_is_restart=config_do_restart) if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 initialization from config_colm2024_namelist failed.") + if(colm_use_cbl_height .and. trim(config_pbl_scheme) == 'off') then + call physics_error_fatal("CoLM2024 DEF_USE_CBL_HEIGHT requires an active MPAS PBL scheme.") + endif + call colm_init_monthly_co2_mlo() offset = 0 block_cursor => block % domain % blocklist @@ -138,8 +243,27 @@ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) call colm_mpas_ready(colm_ready, colm_patch_count) if(.not. colm_ready) call colm2024_adapter_not_ready - colm_first_step = .true. + colm_update_lai_next_step = .true. + colm_step_idate(:) = mpas_start_idate(:) + call colm_adj2end(colm_step_idate) colm_initialized = .true. + + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh' ,block_mesh ) + call mpas_pool_get_subpool(block_cursor % structs,'diag_physics' ,block_diag_physics ) + call mpas_pool_get_subpool(block_cursor % structs,'diag_physics_colm2024' ,block_diag_physics_colm2024 ) + call mpas_pool_get_subpool(block_cursor % structs,'sfc_input' ,block_sfc_input ) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + call colm2024_find_block_map(block_cursor % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS block map was not created.") + if(nCellsSolve > 0) then + call colm2024_pull_mpas_surface(block_map % element_for_cell, block_diag_physics, & + block_diag_physics_colm2024, block_sfc_input, & + mpas_colm_timestep, 1, nCellsSolve, state_only=.true.) + endif + block_cursor => block_cursor % next + enddo #else call colm2024_adapter_not_built #endif @@ -147,7 +271,7 @@ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) end subroutine init_lsm_colm2024 !================================================================================================================= - subroutine push_lsm_colm2024(block,configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) + subroutine push_lsm_colm2024(block,configs,mesh,state,time_lev,diag,diag_physics,atm_input,sfc_input,its,ite) !================================================================================================================= type(block_type),intent(in):: block @@ -156,9 +280,9 @@ subroutine push_lsm_colm2024(block,configs,mesh,state,time_lev,diag,diag_physics type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: diag type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(in):: atm_input type(mpas_pool_type),intent(inout):: sfc_input integer,intent(in):: time_lev - integer,intent(in):: itimestep integer,intent(in):: its,ite #ifdef MPAS_COLM2024 logical :: colm_ready @@ -175,7 +299,7 @@ subroutine push_lsm_colm2024(block,configs,mesh,state,time_lev,diag,diag_physics "than the MPAS cell range.") call colm2024_push_mpas_forcing(block_map % element_for_cell, configs, mesh, state, time_lev, diag, diag_physics, & - sfc_input, itimestep, its, ite) + atm_input, sfc_input, its, ite) #else call colm2024_adapter_not_built #endif @@ -188,18 +312,29 @@ subroutine step_lsm_colm2024() #ifdef MPAS_COLM2024 logical :: colm_ready + logical :: colm_update_daily_lai integer :: colm_ierr integer :: colm_patch_count - integer :: colm_idate(3) + integer :: colm_previous_date(3) + integer :: colm_current_date(3) + real(kind=colm_r8) :: colm_dt call colm_mpas_ready(colm_ready, colm_patch_count) if(.not. colm_ready) call colm2024_adapter_not_ready - colm_idate(1) = year - colm_idate(2) = int(curr_julday) + 1 - colm_idate(3) = nint((curr_julday - real(int(curr_julday), RKIND)) * 86400._RKIND) - call colm_mpas_step(colm_idate, real(dt_pbl, colm_r8), colm_first_step, .true., .false., colm_ierr) + colm_dt = real(dt_pbl, colm_r8) + if(colm_dt <= 0._colm_r8) call physics_error_fatal("CoLM2024 requires a positive land-surface timestep.") + if(abs(colm_dt - real(nint(colm_dt), colm_r8)) > 1.e-6_colm_r8) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second land-surface timestep.") + endif + colm_previous_date(:) = colm_step_idate(:) + call colm_adj2begin(colm_previous_date) + call colm_ticktime(colm_dt, colm_step_idate) + colm_current_date(:) = colm_step_idate(:) + call colm_adj2begin(colm_current_date) + colm_update_daily_lai = colm_update_lai_next_step + call colm_mpas_step(colm_step_idate, colm_dt, colm_update_daily_lai, .true., .false., colm_ierr) if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 driver returned before completing a land-surface step.") - colm_first_step = .false. + colm_update_lai_next_step = any(colm_current_date(1:2) /= colm_previous_date(1:2)) #else call colm2024_adapter_not_built #endif @@ -207,11 +342,12 @@ subroutine step_lsm_colm2024() end subroutine step_lsm_colm2024 !================================================================================================================= - subroutine pull_lsm_colm2024(block,diag_physics,sfc_input,its,ite) + subroutine pull_lsm_colm2024(block,diag_physics,diag_physics_colm2024,sfc_input,its,ite) !================================================================================================================= type(block_type),intent(in):: block type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_colm2024 type(mpas_pool_type),intent(inout):: sfc_input integer,intent(in):: its,ite #ifdef MPAS_COLM2024 @@ -226,25 +362,49 @@ subroutine pull_lsm_colm2024(block,diag_physics,sfc_input,its,ite) if(size(block_map % element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & "than the MPAS cell range.") - call colm2024_pull_mpas_surface(block_map % element_for_cell, diag_physics, sfc_input, real(dt_pbl, colm_r8), its, ite) + call colm2024_pull_mpas_surface(block_map % element_for_cell, diag_physics, diag_physics_colm2024, & + sfc_input, real(dt_pbl, colm_r8), its, ite) #else call colm2024_adapter_not_built #endif end subroutine pull_lsm_colm2024 +!================================================================================================================= + subroutine checkpoint_lsm_colm2024() +!================================================================================================================= + +#ifdef MPAS_COLM2024 + integer :: colm_ierr + + if(.not. colm_initialized) return + call colm_mpas_force_restart(colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 failed to write a checkpoint with the MPAS restart stream.") +#endif + + end subroutine checkpoint_lsm_colm2024 + !================================================================================================================= subroutine finalize_lsm_colm2024() !================================================================================================================= #ifdef MPAS_COLM2024 - integer :: colm_ierr + integer :: colm_ierr, mpi_ierr if(.not. colm_initialized) return - call colm_mpas_finalize(colm_ierr) - if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.") - call colm2024_free_block_maps() - colm_first_step = .true. + call colm_mpas_finalize(colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.") + if(colm_mpas_comm == MPI_COMM_NULL) then + call physics_error_fatal("CoLM2024 MPAS communication context is missing during finalization.") + endif + call MPI_Comm_free(colm_mpas_comm, mpi_ierr) + if(mpi_ierr /= MPI_SUCCESS) then + call physics_error_fatal("MPAS could not release the CoLM2024 communication context.") + endif + colm_mpas_comm = MPI_COMM_NULL + call colm2024_free_block_maps() + colm_update_lai_next_step = .true. + colm_step_idate(:) = -1 colm_initialized = .false. #endif @@ -311,7 +471,8 @@ subroutine colm2024_free_block_maps() end subroutine colm2024_free_block_maps !================================================================================================================= - subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_lev,diag,diag_physics,sfc_input,itimestep,its,ite) + subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_lev,diag,diag_physics,atm_input, & + sfc_input,its,ite) !================================================================================================================= integer,dimension(:),intent(in):: element_for_cell @@ -320,27 +481,39 @@ subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_l type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: diag type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: atm_input type(mpas_pool_type),intent(in):: sfc_input integer,intent(in):: time_lev - integer,intent(in):: itimestep integer,intent(in):: its,ite + logical,pointer:: config_o3climatology + logical:: micro_has_solid character(len=StrKIND),pointer:: config_convection_scheme, config_microp_scheme integer,pointer:: index_qv integer:: i, k - integer:: ierr + integer:: ierr, ozone_ierr + integer:: forcing_idate(3), forcing_month, forcing_mday real(kind=colm_r8):: aerdep(14) - real(kind=colm_r8):: dt, micro_rain, micro_snow, hgt, oro, pbot, psrf, prc, prl, qair, rain, rhoair, snow, & - solld, soll, solsd, sols, spectral_sw, swdir, swdif, tair, uair, vair + real(kind=colm_r8):: co2_mole_fraction, dt, micro_rain, micro_snow, micro_total, precip_tolerance, & + hgt, hpbl_forcing, oro, ozone_ppbv, & + pbot, psrf, prc, prl, qair, & + rain, rhoair, snow, frl_down, & + solld, soll, solsd, sols, spectral_sw, spectral_swdir, spectral_swdif, & + sw_consistency_tolerance, swdir, swdif, solar_cosine, tair, uair, vair real(kind=RKIND):: qv_cell - real(kind=RKIND),dimension(:),pointer:: glw, swddir, swddif, swvisdir, swvisdif, swnirdir, swnirdif - real(kind=RKIND),dimension(:),pointer:: surface_pressure, sr, xice, xland + real(kind=RKIND),dimension(:),pointer:: coszr, glw, hpbl, swddir, swddif, swvisdir, swvisdif, swnirdir, swnirdif + real(kind=RKIND),dimension(:),pointer:: surface_pressure, xice, xland + real(kind=RKIND),dimension(:),pointer:: pin real(kind=RKIND),dimension(:),pointer:: raincv, rainncv, snowncv, graupelncv - real(kind=RKIND),dimension(:,:),pointer:: exner, pressure_b, pressure_p, theta_m, u, v, zgrid + real(kind=RKIND),dimension(:,:),pointer:: exner, o3clim, pressure_b, pressure_p, theta_m, u, v, zgrid real(kind=RKIND),dimension(:,:,:),pointer:: scalars call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology ) + if(colm_use_ozone_data .and. .not. config_o3climatology) then + call physics_error_fatal("CoLM2024 DEF_USE_OZONEDATA requires MPAS config_o3climatology=true.") + endif call mpas_pool_get_dimension(state,'index_qv',index_qv) call mpas_pool_get_array(mesh,'zgrid',zgrid) @@ -352,30 +525,83 @@ subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_l call mpas_pool_get_array(diag,'uReconstructZonal' ,u ) call mpas_pool_get_array(diag,'uReconstructMeridional',v ) call mpas_pool_get_array(diag,'surface_pressure',surface_pressure) + if(colm_use_ozone_data) then + call mpas_pool_get_array(atm_input,'pin',pin) + call mpas_pool_get_array(diag_physics,'o3clim',o3clim) + endif call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) call mpas_pool_get_array(diag_physics,'swddir',swddir) call mpas_pool_get_array(diag_physics,'swddif',swddif) call mpas_pool_get_array(diag_physics,'swvisdir',swvisdir) call mpas_pool_get_array(diag_physics,'swvisdif',swvisdif) call mpas_pool_get_array(diag_physics,'swnirdir',swnirdir) call mpas_pool_get_array(diag_physics,'swnirdif',swnirdif) - call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) - call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) - call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) - call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) - call mpas_pool_get_array(diag_physics,'sr' ,sr ) + if(config_convection_scheme .ne. 'off') call mpas_pool_get_array(diag_physics,'raincv',raincv) + micro_has_solid = .false. + select case(trim(config_microp_scheme)) + case('off') + case('mp_kessler') + call mpas_pool_get_array(diag_physics,'rainncv',rainncv) + case('mp_thompson','mp_thompson_aerosols','mp_wsm6') + micro_has_solid = .true. + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) + case default + call physics_error_fatal("CoLM2024 encountered an unsupported MPAS microphysics scheme.") + end select call mpas_pool_get_array(sfc_input,'xland',xland) call mpas_pool_get_array(sfc_input,'xice' ,xice ) - dt = max(real(dt_pbl, colm_r8), 1._colm_r8) + dt = real(dt_pbl, colm_r8) + if(.not. ieee_is_finite(dt) .or. dt <= 0._colm_r8) then + call physics_error_fatal("CoLM2024 precipitation forcing requires a positive finite timestep.") + endif + forcing_idate(:) = colm_step_idate(:) + call colm_adj2begin(forcing_idate) + call colm_julian2monthday(forcing_idate(1), forcing_idate(2), forcing_month, forcing_mday) + co2_mole_fraction = 1.e-6_colm_r8 * colm_get_monthly_co2_mlo(forcing_idate(1), forcing_month) + if(.not. ieee_is_finite(co2_mole_fraction) .or. co2_mole_fraction <= 0._colm_r8) then + call physics_error_fatal("CoLM2024 produced an invalid atmospheric CO2 mole fraction.") + endif aerdep(:) = 0._colm_r8 k = lbound(theta_m, 1) do i = its,ite if(element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + if(.not. ieee_is_finite(xland(i)) .or. .not. ieee_is_finite(xice(i))) then + call physics_error_fatal("MPAS supplied a non-finite land-ocean or sea-ice mask to CoLM2024.") + endif + if(xland(i) < 1._RKIND .or. xland(i) > 2._RKIND .or. xice(i) < 0._RKIND .or. xice(i) > 1._RKIND) then + call physics_error_fatal("MPAS supplied an out-of-range land-ocean or sea-ice mask to CoLM2024.") + endif + if(config_convection_scheme .ne. 'off') then + if(.not. ieee_is_finite(raincv(i))) then + call physics_error_fatal("MPAS supplied non-finite convective precipitation to CoLM2024.") + endif + if(raincv(i) < 0._RKIND) call physics_error_fatal("MPAS supplied negative convective precipitation to CoLM2024.") + endif + if(config_microp_scheme .ne. 'off') then + if(.not. ieee_is_finite(rainncv(i)) .or. rainncv(i) < 0._RKIND) & + call physics_error_fatal("MPAS supplied invalid total microphysics precipitation to CoLM2024.") + if(micro_has_solid) then + if(.not. all(ieee_is_finite((/snowncv(i), graupelncv(i)/))) .or. & + snowncv(i) < 0._RKIND .or. graupelncv(i) < 0._RKIND) & + call physics_error_fatal("MPAS supplied invalid solid microphysics precipitation to CoLM2024.") + endif + endif + psrf = real(surface_pressure(i), colm_r8) pbot = real(pressure_b(k,i) + pressure_p(k,i), colm_r8) + if(.not. ieee_is_finite(scalars(index_qv,k,i))) then + call physics_error_fatal("MPAS supplied non-finite lowest-level water vapor to CoLM2024.") + endif + if(scalars(index_qv,k,i) < -1.e-10_RKIND) then + call physics_error_fatal("MPAS supplied negative lowest-level water vapor to CoLM2024.") + endif qv_cell = max(0._RKIND, scalars(index_qv,k,i)) tair = real((theta_m(k,i) / (1._RKIND + R_v / R_d * qv_cell)) * exner(k,i), colm_r8) qair = real(qv_cell / (1._RKIND + qv_cell), colm_r8) @@ -383,7 +609,10 @@ subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_l vair = real(v(k,i), colm_r8) hgt = 2._colm_r8 if(ubound(zgrid, 1) >= k + 1) hgt = max(2._colm_r8, real(0.5_RKIND * (zgrid(k+1,i) - zgrid(k,i)), colm_r8)) - rhoair = max(0.1_colm_r8, pbot / (R_d * tair * (1._colm_r8 + 0.61_colm_r8 * qair))) + rhoair = pbot / (real(R_d, colm_r8) * tair * (1._colm_r8 + 0.61_colm_r8 * qair)) + if(.not. ieee_is_finite(rhoair) .or. rhoair <= 0._colm_r8) then + call physics_error_fatal("MPAS atmospheric state produced invalid air density for CoLM2024.") + endif prc = 0._colm_r8 prl = 0._colm_r8 rain = 0._colm_r8 @@ -394,69 +623,184 @@ subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_l rain = rain + prc endif if(config_microp_scheme .ne. 'off') then - micro_rain = max(0._colm_r8, real(rainncv(i), colm_r8) / dt) - micro_snow = max(0._colm_r8, real(snowncv(i) + graupelncv(i), colm_r8) / dt) - if(micro_snow <= 0._colm_r8 .and. sr(i) > 0._RKIND) then - micro_snow = micro_rain * min(1._colm_r8, real(sr(i), colm_r8)) - micro_rain = max(0._colm_r8, micro_rain - micro_snow) + micro_total = real(rainncv(i), colm_r8) + micro_snow = 0._colm_r8 + if(micro_has_solid) micro_snow = real(snowncv(i) + graupelncv(i), colm_r8) + precip_tolerance = max(1.e-10_colm_r8, 1.e-6_colm_r8 * max(1._colm_r8, micro_total)) + if(micro_snow > micro_total + precip_tolerance) then + call physics_error_fatal("MPAS solid grid-scale precipitation exceeds total precipitation for CoLM2024.") endif - prl = micro_rain + micro_snow + micro_snow = min(micro_total, micro_snow) / dt + micro_rain = max(0._colm_r8, micro_total / dt - micro_snow) + prl = micro_total / dt rain = rain + micro_rain snow = snow + micro_snow endif + if(.not. all(ieee_is_finite((/real(swddir(i), colm_r8), real(swddif(i), colm_r8), & + real(swvisdir(i), colm_r8), real(swvisdif(i), colm_r8), & + real(swnirdir(i), colm_r8), real(swnirdif(i), colm_r8)/)))) then + call physics_error_fatal("MPAS supplied non-finite shortwave forcing to CoLM2024.") + endif + if(any((/real(swddir(i), colm_r8), real(swddif(i), colm_r8), & + real(swvisdir(i), colm_r8), real(swvisdif(i), colm_r8), & + real(swnirdir(i), colm_r8), real(swnirdif(i), colm_r8)/) < -1.e-6_colm_r8)) then + call physics_error_fatal("MPAS supplied negative shortwave forcing to CoLM2024.") + endif swdir = max(0._colm_r8, real(swddir(i), colm_r8)) swdif = max(0._colm_r8, real(swddif(i), colm_r8)) sols = max(0._colm_r8, real(swvisdir(i), colm_r8)) solsd = max(0._colm_r8, real(swvisdif(i), colm_r8)) soll = max(0._colm_r8, real(swnirdir(i), colm_r8)) solld = max(0._colm_r8, real(swnirdif(i), colm_r8)) - spectral_sw = sols + solsd + soll + solld + spectral_swdir = sols + soll + spectral_swdif = solsd + solld + spectral_sw = spectral_swdir + spectral_swdif + solar_cosine = real(coszr(i), colm_r8) + if(.not. ieee_is_finite(solar_cosine) .or. solar_cosine < -1._colm_r8 .or. & + solar_cosine > 1._colm_r8) then + call physics_error_fatal("MPAS supplied an invalid solar-zenith cosine to CoLM2024.") + endif if(spectral_sw <= 0._colm_r8 .and. swdir + swdif > 0._colm_r8) then - sols = 0.5_colm_r8 * swdir - soll = 0.5_colm_r8 * swdir - solsd = 0.5_colm_r8 * swdif - solld = 0.5_colm_r8 * swdif + call physics_error_fatal("MPAS shortwave forcing lacks the VIS/NIR direct/diffuse components required by CoLM2024.") + endif + sw_consistency_tolerance = max(1._colm_r8, 1.e-3_colm_r8 * max(swdir, spectral_swdir)) + if(abs(swdir - spectral_swdir) > sw_consistency_tolerance) then + call physics_error_fatal("MPAS broadband and VIS/NIR direct shortwave forcing are inconsistent for CoLM2024.") + endif + sw_consistency_tolerance = max(1._colm_r8, 1.e-3_colm_r8 * max(swdif, spectral_swdif)) + if(abs(swdif - spectral_swdif) > sw_consistency_tolerance) then + call physics_error_fatal("MPAS broadband and VIS/NIR diffuse shortwave forcing are inconsistent for CoLM2024.") endif oro = 1._colm_r8 if(xland(i) >= 1.5_RKIND) oro = 0._colm_r8 if(xice(i) >= xice_threshold) oro = 2._colm_r8 + hpbl_forcing = real(hpbl(i), colm_r8) + if(.not. ieee_is_finite(hpbl_forcing) .or. hpbl_forcing < 0._colm_r8) then + call physics_error_fatal("MPAS supplied an invalid boundary-layer height to CoLM2024.") + endif + + frl_down = real(glw(i), colm_r8) + if(.not. all(ieee_is_finite((/psrf, pbot, tair, qair, uair, vair, prc, prl, rain, snow, & + sols, soll, solsd, solld, frl_down, hgt, rhoair/)))) then + call physics_error_fatal("MPAS supplied non-finite atmospheric forcing to CoLM2024.") + endif + if(frl_down < -1.e-6_colm_r8) then + call physics_error_fatal("MPAS supplied negative downward longwave forcing to CoLM2024.") + endif + frl_down = max(0._colm_r8, frl_down) + if(psrf <= 0._colm_r8 .or. pbot <= 0._colm_r8 .or. tair <= 0._colm_r8 .or. & + qair < 0._colm_r8 .or. qair >= 1._colm_r8) then + call physics_error_fatal("MPAS supplied out-of-range pressure, temperature, or humidity to CoLM2024.") + endif + ozone_ppbv = 100._colm_r8 + if(colm_use_ozone_data) then + call colm2024_interpolate_ozone(pbot, pin, o3clim(:,i), ozone_ppbv, ozone_ierr) + if(ozone_ierr /= 0) call physics_error_fatal("Failed to interpolate MPAS ozone forcing for CoLM2024.") + endif - call colm_mpas_set_element_forcing(element_for_cell(i), psrf * 420.e-6_colm_r8, & - psrf * 0.209_colm_r8, uair, vair, tair, qair, & - prc, prl, rain, snow, psrf, pbot, & + call colm_mpas_set_element_forcing(element_for_cell(i), pbot * co2_mole_fraction, & + pbot * 0.209_colm_r8, uair, vair, tair, qair, & + prc, prl, rain, snow, solar_cosine, psrf, pbot, & sols, soll, solsd, solld, & - real(glw(i), colm_r8), hgt, hgt, hgt, rhoair, 1000._colm_r8, & - aerdep, oro=oro, ierr=ierr) + frl_down, hgt, hgt, hgt, rhoair, hpbl_forcing, & + aerdep, oro=oro, ozone=ozone_ppbv, ierr=ierr) if(ierr /= 0) call physics_error_fatal("Failed to pass MPAS forcing into CoLM2024.") enddo end subroutine colm2024_push_mpas_forcing !================================================================================================================= - subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt,its,ite) + subroutine colm2024_interpolate_ozone(target_pressure,pressure_levels,ozone_profile,ozone_ppbv,ierr) +!================================================================================================================= + + real(kind=colm_r8),intent(in):: target_pressure + real(kind=RKIND),dimension(:),intent(in):: pressure_levels, ozone_profile + real(kind=colm_r8),intent(out):: ozone_ppbv + integer,intent(out):: ierr + + integer:: i, lower_index, upper_index + real(kind=colm_r8):: lower_pressure, upper_pressure, weight + + ierr = 1 + ozone_ppbv = -1._colm_r8 + if(size(pressure_levels) /= size(ozone_profile) .or. size(pressure_levels) < 1) return + if(.not. ieee_is_finite(target_pressure) .or. target_pressure <= 0._colm_r8) return + + lower_index = 0 + upper_index = 0 + lower_pressure = -huge(1._colm_r8) + upper_pressure = huge(1._colm_r8) + do i = 1,size(pressure_levels) + if(.not. ieee_is_finite(pressure_levels(i)) .or. pressure_levels(i) <= 0._RKIND) cycle + if(.not. ieee_is_finite(ozone_profile(i)) .or. ozone_profile(i) < 0._RKIND) cycle + if(real(pressure_levels(i),colm_r8) <= target_pressure .and. & + real(pressure_levels(i),colm_r8) > lower_pressure) then + lower_pressure = real(pressure_levels(i),colm_r8) + lower_index = i + endif + if(real(pressure_levels(i),colm_r8) >= target_pressure .and. & + real(pressure_levels(i),colm_r8) < upper_pressure) then + upper_pressure = real(pressure_levels(i),colm_r8) + upper_index = i + endif + enddo + + if(lower_index == 0 .and. upper_index == 0) return + if(lower_index == 0) lower_index = upper_index + if(upper_index == 0) upper_index = lower_index + if(lower_index == upper_index) then + ozone_ppbv = 1.e9_colm_r8 * real(ozone_profile(lower_index),colm_r8) + else + weight = (log(target_pressure) - log(lower_pressure)) / (log(upper_pressure) - log(lower_pressure)) + ozone_ppbv = 1.e9_colm_r8 * ((1._colm_r8 - weight) * real(ozone_profile(lower_index),colm_r8) + & + weight * real(ozone_profile(upper_index),colm_r8)) + endif + if(.not. ieee_is_finite(ozone_ppbv) .or. ozone_ppbv < 0._colm_r8) return + ierr = 0 + + end subroutine colm2024_interpolate_ozone + +!================================================================================================================= +subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,diag_physics_colm2024,sfc_input,dt,its,ite,state_only) !================================================================================================================= integer,dimension(:),intent(in):: element_for_cell type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_colm2024 type(mpas_pool_type),intent(inout):: sfc_input real(kind=colm_r8),intent(in):: dt integer,intent(in):: its,ite + logical,intent(in),optional:: state_only integer:: i, ns, nlev, nvalid_soil integer:: ierr + logical:: pull_fluxes real(kind=colm_r8):: sensible, latent, evaporation, ground_heat, runoff - real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, qsfc_colm + real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, u10m_colm, v10m_colm, qsfc_colm real(kind=colm_r8):: emissivity, roughness, albedo - real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index + real(kind=colm_r8):: friction_velocity, stability_zeta, bulk_richardson, momentum_profile, heat_profile + real(kind=colm_r8):: moisture_profile, air_density, heat_exchange_velocity, moisture_exchange_velocity + real(kind=colm_r8):: momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov + real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index, ground_temperature + real(kind=colm_r8):: vegetation_fraction, soil_availability + real(kind=colm_r8):: river_water_depth, river_velocity, river_discharge real(kind=colm_r8):: soil_moisture_sum - real(kind=colm_r8):: soil_depth_sum real(kind=colm_r8),parameter:: colm_state_bad_value = 1.e30_colm_r8 - real(kind=colm_r8),dimension(:),allocatable:: soil_liquid, soil_moisture, soil_temperature + real(kind=colm_r8),dimension(:),allocatable:: soil_liquid, soil_ice, soil_moisture, soil_temperature + real(kind=colm_r8),dimension(:),allocatable:: soil_water_equivalent + real(kind=RKIND),dimension(:),pointer:: hfx, lh, qfx, grdflx, sfcrunoff, udrunoff - real(kind=RKIND),dimension(:),pointer:: sfc_albedo, sfc_emiss, z0, znt, qsfc, t2m, q2 - real(kind=RKIND),dimension(:),pointer:: skintemp, canwat, smstav, smstot, snow, snowc, snowh, lai - real(kind=RKIND),dimension(:,:),pointer:: sh2o, smois, tslb + real(kind=RKIND),dimension(:),pointer:: sfc_albedo, sfc_emiss, z0, znt, qsfc, t2m, q2, u10, v10 + real(kind=RKIND),dimension(:),pointer:: ust, ustm, zol, br, fm, fh, rmol, ch, chs, cda, cka, flhc, flqc + real(kind=RKIND),dimension(:),pointer:: skintemp, canwat, smstav, smstot, snow, snowc, snowh, lai, vegfra, xland + real(kind=RKIND),dimension(:,:),pointer:: dzs, sh2o, smois, tslb + real(kind=RKIND),dimension(:,:),pointer:: colm_soil_liquid, colm_soil_ice, colm_soil_moisture + real(kind=RKIND),dimension(:,:),pointer:: colm_soil_temperature, colm_soil_layer_thickness, colm_soil_layer_depth + real(kind=RKIND),dimension(:),pointer:: colm_river_water_depth, colm_river_velocity, colm_river_discharge + + pull_fluxes = .true. + if(present(state_only)) pull_fluxes = .not. state_only call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) call mpas_pool_get_array(diag_physics,'lh' ,lh ) @@ -470,7 +814,22 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt call mpas_pool_get_array(diag_physics,'znt' ,znt ) call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) - call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + call mpas_pool_get_array(diag_physics,'u10' ,u10 ) + call mpas_pool_get_array(diag_physics,'v10' ,v10 ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'ustm' ,ustm ) + call mpas_pool_get_array(diag_physics,'zol' ,zol ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'fm' ,fm ) + call mpas_pool_get_array(diag_physics,'fh' ,fh ) + call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) + call mpas_pool_get_array(diag_physics,'ch' ,ch ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'cda' ,cda ) + call mpas_pool_get_array(diag_physics,'cka' ,cka ) + call mpas_pool_get_array(diag_physics,'flhc' ,flhc ) + call mpas_pool_get_array(diag_physics,'flqc' ,flqc ) call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) @@ -479,23 +838,118 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt call mpas_pool_get_array(sfc_input,'snow' ,snow ) call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + call mpas_pool_get_array(sfc_input,'dzs' ,dzs ) call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) call mpas_pool_get_array(sfc_input,'smois' ,smois ) call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_liquid' ,colm_soil_liquid ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_ice' ,colm_soil_ice ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_moisture' ,colm_soil_moisture ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_temperature' ,colm_soil_temperature ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_layer_thickness',colm_soil_layer_thickness) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_layer_depth' ,colm_soil_layer_depth ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_river_water_depth' ,colm_river_water_depth ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_river_velocity' ,colm_river_velocity ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_river_discharge' ,colm_river_discharge ) nlev = size(tslb, 1) - allocate(soil_liquid(nlev), soil_moisture(nlev), soil_temperature(nlev)) + if(size(sh2o,1) /= nlev .or. size(smois,1) /= nlev .or. size(dzs,1) /= nlev) then + call physics_error_fatal("MPAS generic soil arrays have inconsistent vertical dimensions.") + endif + if(nlev /= colm_nl_soil) then + call physics_error_fatal("CoLM2024 requires all MPAS soil arrays to retain its 10 native layers.") + endif + if(size(colm_soil_liquid,1) /= colm_nl_soil .or. size(colm_soil_ice,1) /= colm_nl_soil .or. & + size(colm_soil_moisture,1) /= colm_nl_soil .or. size(colm_soil_temperature,1) /= colm_nl_soil .or. & + size(colm_soil_layer_thickness,1) /= colm_nl_soil .or. size(colm_soil_layer_depth,1) /= colm_nl_soil) then + call physics_error_fatal("MPAS CoLM2024 registry fields must retain all 10 native soil layers.") + endif + allocate(soil_liquid(colm_nl_soil), soil_ice(colm_nl_soil), soil_moisture(colm_nl_soil), & + soil_temperature(colm_nl_soil), soil_water_equivalent(colm_nl_soil)) do i = its,ite if(element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + if(.not. ieee_is_finite(xland(i))) call physics_error_fatal("MPAS supplied a non-finite land-ocean mask to CoLM2024.") + if(xland(i) >= 1.5_RKIND) then + colm_soil_liquid(:,i) = -9999._RKIND + colm_soil_ice(:,i) = -9999._RKIND + colm_soil_moisture(:,i) = -9999._RKIND + colm_soil_temperature(:,i) = -9999._RKIND + colm_soil_layer_thickness(:,i) = -9999._RKIND + colm_soil_layer_depth(:,i) = -9999._RKIND + colm_river_water_depth(i) = -9999._RKIND + colm_river_velocity(i) = -9999._RKIND + colm_river_discharge(i) = -9999._RKIND + cycle + endif - call colm_mpas_get_element_surface(element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & - surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & - qsfc_colm, emissivity, roughness, albedo, ierr) - if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.") - call colm_mpas_get_element_state(element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, & - leaf_area_index, soil_liquid, soil_moisture, soil_temperature, ierr) - if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface state.") + if(pull_fluxes) then + call colm_mpas_get_element_surface(element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & + u10m_colm, v10m_colm, qsfc_colm, emissivity, roughness, albedo, & + friction_velocity, & + stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.") + else + call colm_mpas_get_element_boundary_state(element_for_cell(i), skin_temp, qsfc_colm, emissivity, & + roughness, albedo, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve the initial CoLM2024 surface boundary state.") + endif + call colm_mpas_get_element_state(element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, & + leaf_area_index, vegetation_fraction, soil_availability, ground_temperature, & + soil_liquid, soil_ice, soil_moisture, soil_temperature, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface state.") + call colm_mpas_get_element_river_state(element_for_cell(i), river_water_depth, river_velocity, & + river_discharge, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 river-routing diagnostics.") + colm_river_water_depth(i) = -9999._RKIND + colm_river_velocity(i) = -9999._RKIND + colm_river_discharge(i) = -9999._RKIND + if(ieee_is_finite(river_water_depth) .and. abs(river_water_depth) < colm_state_bad_value) & + colm_river_water_depth(i) = real(river_water_depth, RKIND) + if(ieee_is_finite(river_velocity) .and. abs(river_velocity) < colm_state_bad_value) & + colm_river_velocity(i) = real(river_velocity, RKIND) + if(ieee_is_finite(river_discharge) .and. abs(river_discharge) < colm_state_bad_value) & + colm_river_discharge(i) = real(river_discharge, RKIND) + if(.not. all(ieee_is_finite((/canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index, & + ground_temperature/))) .or. & + any(abs((/canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index, & + ground_temperature/)) >= colm_state_bad_value)) then + call physics_error_fatal("CoLM2024 returned a non-finite or missing required surface state.") + endif + if(pull_fluxes) then + if(.not. all(ieee_is_finite((/sensible, latent, evaporation, ground_heat, runoff, surface_runoff, & + subsurface_runoff, skin_temp, t2m_colm, q2m_colm, u10m_colm, v10m_colm, & + qsfc_colm, emissivity, & + roughness, albedo/))) .or. & + any(abs((/sensible, latent, evaporation, ground_heat, runoff, surface_runoff, subsurface_runoff, & + skin_temp, t2m_colm, q2m_colm, u10m_colm, v10m_colm, qsfc_colm, emissivity, roughness, & + albedo/)) >= colm_state_bad_value)) then + call physics_error_fatal("CoLM2024 returned a non-finite or missing required surface field.") + endif + if(.not. all(ieee_is_finite((/friction_velocity, stability_zeta, bulk_richardson, momentum_profile, & + heat_profile, moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov/))) .or. & + any(abs((/friction_velocity, stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, moisture_exchange_velocity, & + momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov/)) >= colm_state_bad_value)) then + call physics_error_fatal("CoLM2024 returned a non-finite or missing surface-exchange field.") + endif + if(q2m_colm < 0._colm_r8 .or. q2m_colm >= 1._colm_r8 .or. qsfc_colm < 0._colm_r8 .or. & + qsfc_colm >= 1._colm_r8 .or. emissivity < 0._colm_r8 .or. emissivity > 1._colm_r8 .or. & + albedo < 0._colm_r8 .or. albedo > 1._colm_r8 .or. & + roughness < 0._colm_r8 .or. friction_velocity < 0._colm_r8 .or. air_density <= 0._colm_r8 .or. & + momentum_profile <= 0._colm_r8 .or. heat_profile <= 0._colm_r8 .or. moisture_profile <= 0._colm_r8 .or. & + heat_exchange_velocity < 0._colm_r8 .or. moisture_exchange_velocity < 0._colm_r8 .or. & + momentum_coefficient < 0._colm_r8 .or. enthalpy_coefficient < 0._colm_r8) then + call physics_error_fatal("CoLM2024 returned an out-of-range surface state or exchange field.") + endif hfx(i) = real(sensible, RKIND) lh(i) = real(latent, RKIND) @@ -505,54 +959,104 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt ! MPAS runoff diagnostics are accumulated depths, matching Noah/Noah-MP. sfcrunoff(i) = sfcrunoff(i) + real(surface_runoff * dt, RKIND) udrunoff(i) = udrunoff(i) + real(subsurface_runoff * dt, RKIND) - skintemp(i) = real(skin_temp, RKIND) - t2m(i) = real(t2m_colm, RKIND) + skintemp(i) = real(skin_temp, RKIND) + t2m(i) = real(t2m_colm, RKIND) + u10(i) = real(u10m_colm, RKIND) + v10(i) = real(v10m_colm, RKIND) + ! Noah-MP and the MPAS Registry keep qsfc as specific humidity, while q2 uses the WRF mixing-ratio convention. qsfc(i) = real(qsfc_colm, RKIND) - ! MPAS/WRF q2 is a 2 m mixing ratio; CoLM qref is specific humidity. if(abs(q2m_colm) < colm_state_bad_value .and. q2m_colm >= 0._colm_r8 .and. q2m_colm < 1._colm_r8) then q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) endif - sfc_emiss(i) = real(emissivity, RKIND) - z0(i) = real(roughness, RKIND) - znt(i) = real(roughness, RKIND) - if(albedo > 0._colm_r8 .and. albedo < 1._colm_r8) sfc_albedo(i) = real(albedo, RKIND) - canwat(i) = real(canopy_water, RKIND) + sfc_emiss(i) = real(emissivity, RKIND) + z0(i) = real(roughness, RKIND) + znt(i) = real(roughness, RKIND) + sfc_albedo(i) = real(albedo, RKIND) + ust(i) = real(friction_velocity, RKIND) + ustm(i) = real(friction_velocity, RKIND) + zol(i) = real(stability_zeta, RKIND) + br(i) = real(bulk_richardson, RKIND) + fm(i) = real(momentum_profile, RKIND) + fh(i) = real(heat_profile, RKIND) + rmol(i) = real(inverse_monin_obukhov, RKIND) + ch(i) = real(heat_exchange_velocity, RKIND) + chs(i) = real(heat_exchange_velocity, RKIND) + flhc(i) = real(air_density * real(cp,colm_r8) * heat_exchange_velocity, RKIND) + flqc(i) = real(air_density * moisture_exchange_velocity, RKIND) + cda(i) = real(momentum_coefficient, RKIND) + cka(i) = real(enthalpy_coefficient, RKIND) + else + if(.not. all(ieee_is_finite((/skin_temp, qsfc_colm, emissivity, roughness, albedo/))) .or. & + any(abs((/skin_temp, qsfc_colm, emissivity, roughness, albedo/)) >= colm_state_bad_value) .or. & + skin_temp <= 0._colm_r8 .or. qsfc_colm < 0._colm_r8 .or. qsfc_colm >= 1._colm_r8 .or. & + emissivity <= 0._colm_r8 .or. emissivity > 1._colm_r8 .or. roughness < 0._colm_r8 .or. & + albedo < 0._colm_r8 .or. albedo > 1._colm_r8) then + call physics_error_fatal("CoLM2024 returned an invalid initial surface boundary state.") + endif + skintemp(i) = real(skin_temp, RKIND) + qsfc(i) = real(qsfc_colm, RKIND) + sfc_emiss(i) = real(emissivity, RKIND) + z0(i) = real(roughness, RKIND) + znt(i) = real(roughness, RKIND) + sfc_albedo(i) = real(albedo, RKIND) + endif + canwat(i) = real(canopy_water, RKIND) snow(i) = real(snow_water, RKIND) snowh(i) = real(snow_depth, RKIND) - snowc(i) = real(max(0._colm_r8, min(1._colm_r8, snow_cover)), RKIND) - lai(i) = real(max(0._colm_r8, leaf_area_index), RKIND) - - soil_moisture_sum = 0._colm_r8 - soil_depth_sum = 0._colm_r8 - nvalid_soil = 0 - do ns = 1,nlev - if(abs(soil_liquid(ns)) < colm_state_bad_value .and. & - abs(soil_moisture(ns)) < colm_state_bad_value .and. & - abs(soil_temperature(ns)) < colm_state_bad_value) then - sh2o(ns,i) = real(soil_liquid(ns), RKIND) - smois(ns,i) = real(soil_moisture(ns), RKIND) - tslb(ns,i) = real(soil_temperature(ns), RKIND) - if(ns <= size(colm_dz_soi) .and. colm_dz_soi(ns) > 0._colm_r8) then - soil_moisture_sum = soil_moisture_sum + soil_moisture(ns) * colm_dz_soi(ns) - soil_depth_sum = soil_depth_sum + colm_dz_soi(ns) - endif - nvalid_soil = nvalid_soil + 1 - endif - enddo - if(nvalid_soil > 0 .and. soil_depth_sum > 0._colm_r8) then - smstot(i) = real(soil_moisture_sum / soil_depth_sum, RKIND) - if(abs(soil_moisture(1)) < colm_state_bad_value) then - smstav(i) = real(soil_moisture(1), RKIND) - else - smstav(i) = smstot(i) - endif - smstav(i) = max(0._RKIND, min(1._RKIND, smstav(i))) - endif - enddo + snowc(i) = real(max(0._colm_r8, min(1._colm_r8, snow_cover)), RKIND) + lai(i) = real(max(0._colm_r8, leaf_area_index), RKIND) + if(ieee_is_finite(vegetation_fraction) .and. abs(vegetation_fraction) < colm_state_bad_value) & + vegfra(i) = real(100._colm_r8 * max(0._colm_r8, min(1._colm_r8, vegetation_fraction)), RKIND) + if(ieee_is_finite(soil_availability) .and. abs(soil_availability) < colm_state_bad_value) & + smstav(i) = real(max(0._colm_r8, min(1._colm_r8, soil_availability)), RKIND) + + soil_moisture_sum = 0._colm_r8 + nvalid_soil = 0 + smstot(i) = -9999._RKIND + sh2o(:,i) = -9999._RKIND + smois(:,i) = -9999._RKIND + tslb(:,i) = -9999._RKIND + colm_soil_liquid(:,i) = -9999._RKIND + colm_soil_ice(:,i) = -9999._RKIND + colm_soil_moisture(:,i) = -9999._RKIND + colm_soil_temperature(:,i) = -9999._RKIND + soil_water_equivalent(:) = -1._colm_r8 + do ns = 1,colm_nl_soil + colm_soil_layer_thickness(ns,i) = real(colm_dz_soi(ns), RKIND) + colm_soil_layer_depth(ns,i) = real(colm_z_soi(ns), RKIND) + if(ieee_is_finite(soil_liquid(ns)) .and. ieee_is_finite(soil_ice(ns)) .and. & + ieee_is_finite(soil_moisture(ns)) .and. ieee_is_finite(soil_temperature(ns)) .and. & + soil_liquid(ns) >= 0._colm_r8 .and. soil_ice(ns) >= 0._colm_r8 .and. & + soil_moisture(ns) >= 0._colm_r8 .and. soil_temperature(ns) > 0._colm_r8 .and. & + abs(soil_liquid(ns)) < colm_state_bad_value .and. & + abs(soil_ice(ns)) < colm_state_bad_value .and. & + abs(soil_moisture(ns)) < colm_state_bad_value .and. & + abs(soil_temperature(ns)) < colm_state_bad_value) then + colm_soil_liquid(ns,i) = real(soil_liquid(ns), RKIND) + colm_soil_ice(ns,i) = real(soil_ice(ns), RKIND) + colm_soil_moisture(ns,i) = real(soil_moisture(ns), RKIND) + colm_soil_temperature(ns,i) = real(soil_temperature(ns), RKIND) + soil_water_equivalent(ns) = soil_liquid(ns) + soil_ice(ns) * colm_denice / colm_denh2o + soil_moisture_sum = soil_moisture_sum + soil_water_equivalent(ns) * colm_dz_soi(ns) + nvalid_soil = nvalid_soil + 1 + endif + enddo + if(nvalid_soil == colm_nl_soil) then + smstot(i) = real(1000._colm_r8 * soil_moisture_sum, RKIND) + sh2o(:,i) = real(soil_liquid(:), RKIND) + smois(:,i) = real(soil_water_equivalent(:), RKIND) + tslb(:,i) = real(soil_temperature(:), RKIND) + else + colm_soil_liquid(:,i) = -9999._RKIND + colm_soil_ice(:,i) = -9999._RKIND + colm_soil_moisture(:,i) = -9999._RKIND + colm_soil_temperature(:,i) = -9999._RKIND + endif + enddo - deallocate(soil_liquid, soil_moisture, soil_temperature) + deallocate(soil_liquid, soil_ice, soil_moisture, soil_temperature, soil_water_equivalent) - end subroutine colm2024_pull_mpas_surface + end subroutine colm2024_pull_mpas_surface #endif !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index b3d7a7b12b..55b8d7bdaa 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -10,13 +10,13 @@ module mpas_atmphys_finalize use mpas_pool_routines use mpas_atmphys_lsm_noahmpfinalize,only: sf_noahmp_deallocate - use mpas_atmphys_driver_lsm_colm2024,only: finalize_lsm_colm2024 + use mpas_atmphys_driver_lsm_colm2024,only: checkpoint_lsm_colm2024, finalize_lsm_colm2024 use module_mp_thompson use cires_ugwpv1_module implicit none private - public:: atmphys_finalize + public:: atmphys_write_restart, atmphys_finalize !mpas_atmphys_finalize contains subroutines that deallocate arrays used in physics parameterizations, i.e. arrays !that need to remain allocated as long as MPAS runs and are not properly deallocated in the sourcecode itself. @@ -33,6 +33,18 @@ module mpas_atmphys_finalize contains +!================================================================================================================= + subroutine atmphys_write_restart(configs) +!================================================================================================================= + + type(mpas_pool_type),intent(in):: configs + character(len=StrKIND),pointer:: config_lsm_scheme + + call mpas_pool_get_config(configs,'config_lsm_scheme',config_lsm_scheme) + if(trim(config_lsm_scheme) == 'sf_colm2024') call checkpoint_lsm_colm2024 + + end subroutine atmphys_write_restart + !================================================================================================================= subroutine atmphys_finalize(configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 431442c19b..b8a2dbc14a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -424,7 +424,7 @@ subroutine physics_init(dminfo,stream_manager,clock,block,configs,mesh,diag,tend elseif(config_lsm_scheme .eq. 'sf_noahmp') then call init_lsm_noahmp(configs,mesh,clock,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) elseif(config_lsm_scheme .eq. 'sf_colm2024') then - call init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input) + call init_lsm_colm2024(dminfo,configs,clock,block) endif endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_packages.F b/src/core_atmosphere/physics/mpas_atmphys_packages.F index 228bb86243..e24907b8c5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_packages.F +++ b/src/core_atmosphere/physics/mpas_atmphys_packages.F @@ -191,6 +191,9 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) return endif + sf_noahmp_in = .false. + sf_colm2024_in = .false. + if(config_lsm_scheme=='sf_noahmp') then sf_noahmp_in = .true. endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 134009f537..a64e18b2aa 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -579,7 +579,7 @@ module mpas_atmphys_vars qgh_p, &! qsfc_p, &!specific humidity at lower boundary [kg/kg] regime_p, &!flag indicating PBL regime (stable_p,unstable_p,etc...) [-] - rmol_p, &!1 / Monin Ob length [-] + rmol_p, &!1 / Monin Ob length [m-1] t2m_p, &!temperature at 2m [K] th2m_p, &!potential temperature at 2m [K] u10_p, &!u at 10 m [m/s] @@ -867,7 +867,7 @@ module mpas_atmphys_vars shdmin_p, &!minimum areal fractional coverage of annual green vegetation [-] shdmax_p, &!maximum areal fractional coverage of annual green vegetation [-] smstav_p, &!moisture availability [-] - smstot_p, &!total moisture [m3 m-3] + smstot_p, &!total frozen and unfrozen soil-column water [mm] snopcx_p, &!snow phase change heat flux [W m-2] snotime_p, &! snowc_p, &!snow water equivalent [kg m-2] diff --git a/src/core_atmosphere/physics/physics_colm2024/README.md b/src/core_atmosphere/physics/physics_colm2024/README.md index d08b93f20e..f3df9c9d74 100644 --- a/src/core_atmosphere/physics/physics_colm2024/README.md +++ b/src/core_atmosphere/physics/physics_colm2024/README.md @@ -8,5 +8,15 @@ Build CoLM2024 through MPAS: - CMake: configure with `-DMPAS_COLM2024=ON`. - Make: build atmosphere with `COLM2024=true`. +Run with `config_num_soil_layers = 10`. CoLM keeps its native 10-layer soil +column and its patch/PFT state; MPAS cells map one-to-one to CoLM elements. + +MPAS initializes MPI and passes its domain communicator to CoLM. CoLM does not +start a separate process pool or require extra ranks. The MPAS LSM driver owns a +duplicated communicator context that isolates CoLM river-routing, remapping, and +restart messages while using the same MPAS processes. Distributed CoLM code still +issues the collectives and point-to-point exchanges required by those algorithms, +but only on this borrowed MPAS-owned context; it never owns an MPI runtime. + Standalone CoLM run cases, forcing namelist examples, and evaluation scripts are intentionally not kept in this embedded source tree. diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index eb500330d0..df1d542fc3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -3,8 +3,9 @@ MODULE MOD_CoLM_MPAS_Interface USE MOD_Precision + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite USE MOD_LandPatch, only: numpatch, landpatch, elm_patch - USE MOD_Vars_Global, only: spval, nl_soil, dz_soi + USE MOD_Vars_Global, only: spval, nl_soil, dz_soi, pi USE MOD_Vars_1DForcing, only: forc_pco2m, forc_po2m, forc_us, forc_vs, forc_t, forc_q, & forc_prc, forc_prl, forc_rain, forc_snow, forc_psrf, forc_pbot, forc_sols, forc_soll, & forc_solsd, forc_solld, forc_frl, forc_swrad, forc_hgt_u, forc_hgt_t, forc_hgt_q, & @@ -13,9 +14,18 @@ MODULE MOD_CoLM_MPAS_Interface USE MOD_Vars_1DForcing, only: forc_solarin #endif USE MOD_Vars_1DFluxes, only: oroflag, fsena, lfevpa, fevpa, fgrnd, rnof, rsur, rsub - USE MOD_Vars_TimeInvariants, only: patchmask - USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, qsfc, emis, z0m, alb, & - ldew, scv, snowdp, fsno, lai, t_soisno, wliq_soisno, wice_soisno + USE MOD_Vars_TimeInvariants, only: patchmask, patchtype, htop +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants, only: htop_p, pftfrac + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e +#endif + USE MOD_Vars_TimeVariables, only: t_grnd, trad, tref, qref, qsfc, emis, z0m, displa, alb, & + ldew, scv, snowdp, fsno, lai, fveg, rstfacsun_out, rstfacsha_out, & + t_soisno, wliq_soisno, wice_soisno, coszen, zol, rib, ustar, fm, fh, fq + USE MOD_Const_Physical, only: vonkar, denh2o, denice + USE MOD_FrictionVelocity, only: moninobuk + USE MOD_TurbulenceLEddy, only: moninobuk_leddy + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT USE MOD_TimeManager, only: timestamp IMPLICIT NONE @@ -26,14 +36,20 @@ MODULE MOD_CoLM_MPAS_Interface PUBLIC :: colm_mpas_ready PUBLIC :: colm_mpas_set_element_forcing PUBLIC :: colm_mpas_step + PUBLIC :: colm_mpas_force_restart PUBLIC :: colm_mpas_get_surface PUBLIC :: colm_mpas_get_element_surface + PUBLIC :: colm_mpas_get_element_boundary_state PUBLIC :: colm_mpas_get_element_state + PUBLIC :: colm_mpas_get_element_river_state logical, save :: colm_mpas_initialized = .false. character(len=256), save :: colm_mpas_casename = '' + character(len=256), save :: colm_mpas_dir_landdata = '' character(len=256), save :: colm_mpas_dir_restart = '' integer, save :: colm_mpas_lc_year = -1 + integer, save :: colm_mpas_last_lai_year = -1 + integer, save :: colm_mpas_last_lai_period = -1 integer, save :: colm_mpas_last_idate(3) = -1 integer, save :: colm_mpas_last_restart_idate(3) = -1 type(timestamp), save :: colm_mpas_ptstamp @@ -54,16 +70,23 @@ END SUBROUTINE CoLMDRIVER CONTAINS SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell_id, & - n_mpas_cells, cell_to_element) + mpas_cell_lat, mpas_cell_lon, & + n_mpas_cells, cell_to_element, mpas_start_idate, & + mpas_stop_idate, mpas_timestep, mpas_is_restart) USE MOD_Namelist, only: read_namelist, DEF_CASE_NAME, DEF_dir_landdata, & DEF_dir_restart, DEF_LC_YEAR, DEF_simulation_time, DEF_USE_SNICAR, & - DEF_file_snowoptics, DEF_file_snowaging, DEF_forcing, DEF_Reservoir_Method, & - DEF_WRST_FREQ, DEF_HIST_FREQ, DEF_HIST_WriteBack + DEF_file_snowoptics, DEF_file_snowaging, DEF_Reservoir_Method, & + DEF_WRST_FREQ, DEF_HIST_FREQ, DEF_HIST_WriteBack, DEF_LAI_MONTHLY, & + DEF_LAI_CHANGE_YEARLY USE MOD_Vars_Global, only: Init_GlobalVars - USE MOD_SPMD_Task, only: spmd_init, p_is_root + USE MOD_MPAS_MPI, only: mpas_mpi_attach, mpas_is_root USE MOD_Const_LC, only: Init_LC_Const +#ifdef HYPERSPECTRAL USE MOD_Const_PFT, only: Init_PFT_Const, rho_p, tau_p - USE MOD_TimeManager, only: initimetype, monthday2julian, adj2begin, adj2end +#else + USE MOD_Const_PFT, only: Init_PFT_Const +#endif + USE MOD_TimeManager, only: initimetype, monthday2julian, julian2monthday, adj2begin, adj2end USE MOD_Block, only: gblock USE MOD_Pixel, only: pixel USE MOD_Mesh, only: numelm @@ -74,6 +97,7 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell USE MOD_SrfdataRestart, only: mesh_load_from_file, pixelset_load_from_file USE MOD_Vars_TimeInvariants, only: allocate_TimeInvariants, READ_TimeInvariants USE MOD_Vars_TimeVariables, only: allocate_TimeVariables, READ_TimeVariables + USE MOD_Opt_Baseflow, only: Opt_Baseflow_init USE MOD_Vars_1DForcing, only: allocate_1D_Forcing USE MOD_Vars_1DFluxes, only: allocate_1D_Fluxes #ifdef GridRiverLakeFlow @@ -90,10 +114,16 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell #endif character(len=*), intent(in) :: nlfile integer, intent(out) :: ierr - integer, intent(in), optional :: mpas_comm - integer, intent(in), optional :: mpas_cell_id(:) - integer, intent(in), optional :: n_mpas_cells - integer, intent(out), optional :: cell_to_element(:) + integer, intent(in) :: mpas_comm + integer, intent(in) :: mpas_cell_id(:) + real(r8), intent(in) :: mpas_cell_lat(:) + real(r8), intent(in) :: mpas_cell_lon(:) + integer, intent(in) :: n_mpas_cells + integer, intent(out) :: cell_to_element(:) + integer, intent(in) :: mpas_start_idate(3) + integer, intent(in) :: mpas_stop_idate(3) + real(r8), intent(in) :: mpas_timestep + logical, intent(in) :: mpas_is_restart character(len=256) :: casename character(len=256) :: dir_landdata @@ -103,9 +133,10 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell integer :: jdate(3) integer :: s_julian integer :: p_julian - integer :: e_julian integer :: n_mpas integer :: i + integer :: lai_month + integer :: lai_mday integer*8, allocatable :: mpas_cell_id_i8(:) ierr = 1 @@ -114,17 +145,17 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell RETURN ENDIF - IF (present(mpas_comm)) THEN - CALL spmd_init(mpas_comm) - ELSE - CALL spmd_init() - ENDIF + CALL mpas_mpi_attach(mpas_comm) CALL read_namelist(trim(nlfile)) -#ifdef MPAS_EMBEDDED_COLM + IF (.not. ieee_is_finite(mpas_timestep) .or. mpas_timestep <= 0._r8 .or. mpas_timestep > 3600._r8) THEN + IF (mpas_is_root) write(*,'(A)') 'CoLM2024 MPAS timestep must be finite and in (0, 3600] seconds.' + RETURN + ENDIF + DEF_simulation_time%timestep = mpas_timestep + DEF_WRST_FREQ = 'none' CALL colm_mpas_check_embedded_io(ierr) IF (ierr /= 0) RETURN -#endif casename = DEF_CASE_NAME dir_landdata = DEF_dir_landdata @@ -136,56 +167,69 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell DEF_simulation_time%start_day, s_julian) CALL monthday2julian(DEF_simulation_time%spinup_year, DEF_simulation_time%spinup_month, & DEF_simulation_time%spinup_day, p_julian) - CALL monthday2julian(DEF_simulation_time%end_year, DEF_simulation_time%end_month, & - DEF_simulation_time%end_day, e_julian) sdate(1) = DEF_simulation_time%start_year sdate(2) = s_julian sdate(3) = DEF_simulation_time%start_sec + IF (mpas_is_restart) THEN + sdate(:) = mpas_start_idate(:) + ELSEIF (any(sdate /= mpas_start_idate)) THEN + IF (mpas_is_root) THEN + write(*,'(A,3(I0,1X))') 'CoLM2024 namelist start timestamp (year, day-of-year, second): ', sdate + write(*,'(A,3(I0,1X))') 'MPAS start timestamp (year, day-of-year, second): ', mpas_start_idate + write(*,'(A)') 'Set DEF_simulation_time start values to the MPAS cold-start time.' + ENDIF + RETURN + ENDIF + IF (DEF_simulation_time%spinup_repeat /= 1 .or. & + DEF_simulation_time%spinup_year > sdate(1) .or. & + (DEF_simulation_time%spinup_year == sdate(1) .and. p_julian > sdate(2)) .or. & + (DEF_simulation_time%spinup_year == sdate(1) .and. p_julian == sdate(2) .and. & + DEF_simulation_time%spinup_sec > sdate(3))) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 standalone spinup cycles cannot be embedded inside the MPAS atmosphere clock.' + write(*,'(A)') 'Use spinup_repeat = 1 and a spinup endpoint no later than the MPAS start timestamp.' + ENDIF + RETURN + ENDIF + colm_mpas_casename = casename + colm_mpas_dir_landdata = dir_landdata colm_mpas_dir_restart = dir_restart colm_mpas_lc_year = lc_year + colm_mpas_last_lai_year = -1 + colm_mpas_last_lai_period = -1 colm_mpas_ptstamp%year = DEF_simulation_time%spinup_year colm_mpas_ptstamp%day = p_julian colm_mpas_ptstamp%sec = DEF_simulation_time%spinup_sec - colm_mpas_etstamp%year = DEF_simulation_time%end_year - colm_mpas_etstamp%day = e_julian - colm_mpas_etstamp%sec = DEF_simulation_time%end_sec + colm_mpas_etstamp%year = mpas_stop_idate(1) + colm_mpas_etstamp%day = mpas_stop_idate(2) + colm_mpas_etstamp%sec = mpas_stop_idate(3) colm_mpas_last_idate(:) = -1 colm_mpas_last_restart_idate(:) = -1 - colm_mpas_restart_ready = .true. CALL Init_GlobalVars CALL Init_LC_Const CALL Init_PFT_Const n_mpas = 0 -#ifdef MPAS_EMBEDDED_COLM - IF (.not. present(n_mpas_cells)) THEN - IF (p_is_root) write(*,'(A)') 'CoLM2024 MPAS embedded initialization requires MPAS-owned cell ids.' - RETURN - ENDIF -#endif - IF (present(n_mpas_cells)) THEN - IF (.not. present(mpas_cell_id)) RETURN - IF (.not. present(cell_to_element)) RETURN - - n_mpas = n_mpas_cells - IF (n_mpas < 0) RETURN - IF (size(mpas_cell_id) < n_mpas) RETURN - IF (size(cell_to_element) < n_mpas) RETURN - - allocate(mpas_cell_id_i8(n_mpas)) - DO i = 1, n_mpas - mpas_cell_id_i8(i) = int(mpas_cell_id(i), 8) - ENDDO - ENDIF + n_mpas = n_mpas_cells + IF (n_mpas < 0) RETURN + IF (size(mpas_cell_id) < n_mpas) RETURN + IF (size(mpas_cell_lat) < n_mpas) RETURN + IF (size(mpas_cell_lon) < n_mpas) RETURN + IF (size(cell_to_element) < n_mpas) RETURN + + allocate(mpas_cell_id_i8(n_mpas)) + DO i = 1, n_mpas + mpas_cell_id_i8(i) = int(mpas_cell_id(i), 8) + ENDDO CALL pixel%load_from_file(dir_landdata) CALL gblock%load_from_file(dir_landdata) -#ifdef MPAS_EMBEDDED_COLM - CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, n_mpas, ierr) + CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, mpas_cell_lat, & + mpas_cell_lon, n_mpas, ierr) IF (ierr /= 0) RETURN CALL mesh_load_from_file(dir_landdata, lc_year, subset_eindex=mpas_cell_id_i8) @@ -193,53 +237,27 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell subset_eindex=mpas_cell_id_i8) CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year, & subset_eindex=mpas_cell_id_i8) -#else - IF (n_mpas > 0) THEN - CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, n_mpas, ierr) - IF (ierr /= 0) RETURN - - CALL mesh_load_from_file(dir_landdata, lc_year, subset_eindex=mpas_cell_id_i8) - CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year, & - subset_eindex=mpas_cell_id_i8) - CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year, & - subset_eindex=mpas_cell_id_i8) - ELSE - CALL mesh_load_from_file(dir_landdata, lc_year) - CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year) - CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year) - ENDIF -#endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) -#ifdef MPAS_EMBEDDED_COLM CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, & subset_eindex=mpas_cell_id_i8) -#else - IF (n_mpas > 0) THEN - CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, & - subset_eindex=mpas_cell_id_i8) - ELSE - CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year) - ENDIF -#endif #endif IF (n_mpas > 0) THEN CALL colm_mpas_restrict_to_mpas_cells(mpas_cell_id, n_mpas, cell_to_element, ierr) IF (ierr /= 0) RETURN + CALL colm_mpas_validate_cell_geometry(mpas_cell_id, mpas_cell_lat, mpas_cell_lon, & + n_mpas, cell_to_element, ierr) + IF (ierr /= 0) RETURN ENDIF CALL elm_patch%build(landelm, landpatch, use_frac = .true.) -#ifdef MPAS_EMBEDDED_COLM CALL colm_mpas_validate_element_patch_map(.false., ierr) IF (ierr /= 0) RETURN -#endif #ifdef GridRiverLakeFlow -#ifdef MPAS_EMBEDDED_COLM CALL colm_mpas_check_embedded_riverlake(ierr) IF (ierr /= 0) RETURN -#endif CALL build_riverlake_network() IF (DEF_Reservoir_Method > 0) CALL reservoir_init() #endif @@ -254,12 +272,29 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell CALL allocate_TimeInvariants() CALL READ_TimeInvariants(lc_year, casename, dir_restart) -#ifdef MPAS_EMBEDDED_COLM - CALL colm_mpas_validate_element_patch_map(.true., ierr) - IF (ierr /= 0) RETURN + CALL colm_mpas_validate_element_patch_map(.true., ierr) + IF (ierr /= 0) RETURN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL colm_mpas_validate_pft_fractions(ierr) + IF (ierr /= 0) RETURN #endif - CALL allocate_TimeVariables() - CALL READ_TimeVariables(jdate, lc_year, casename, dir_restart) + CALL allocate_TimeVariables() + CALL READ_TimeVariables(jdate, lc_year, casename, dir_restart, mpas_is_restart) + ! Soil hydrology always applies this factor. The embedded path reads a + ! calibrated vector when present and otherwise initializes every patch to 1. + CALL Opt_Baseflow_init() + + IF (DEF_LAI_CHANGE_YEARLY) THEN + colm_mpas_last_lai_year = jdate(1) + ELSE + colm_mpas_last_lai_year = lc_year + ENDIF + IF (DEF_LAI_MONTHLY) THEN + CALL julian2monthday(jdate(1), jdate(2), lai_month, lai_mday) + colm_mpas_last_lai_period = lai_month + ELSE + colm_mpas_last_lai_period = 1 + (jdate(2) - 1) / 8 + ENDIF IF (DEF_USE_SNICAR) THEN CALL SnowOptics_init(DEF_file_snowoptics) @@ -274,67 +309,123 @@ SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell CALL allocate_1D_Forcing() CALL allocate_1D_Fluxes() - DEF_forcing%has_missing_value = .false. #ifdef GridRiverLakeFlow CALL grid_riverlake_flow_init() #endif + colm_mpas_last_idate(:) = sdate(:) + colm_mpas_restart_ready = .true. colm_mpas_initialized = .true. ierr = 0 END SUBROUTINE colm_mpas_initialize_from_namelist -#if defined(GridRiverLakeFlow) && defined(MPAS_EMBEDDED_COLM) +#ifdef GridRiverLakeFlow SUBROUTINE colm_mpas_check_embedded_riverlake(ierr) - USE MOD_Namelist, only: DEF_USE_SEDIMENT - USE MOD_SPMD_Task, only: p_np_glb, p_is_root + USE MOD_Namelist, only: DEF_USE_SEDIMENT, DEF_Reservoir_Method + USE MOD_MPAS_MPI, only: mpas_size, mpas_is_root integer, intent(out) :: ierr ierr = 0 IF (DEF_USE_SEDIMENT) THEN - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded mode does not support GridRiverLakeSediment yet.' write(*,'(A)') 'Set DEF_USE_SEDIMENT = .false. until sediment routing is migrated to MPAS-owned rank decomposition.' ENDIF ierr = 1 RETURN ENDIF - IF (p_np_glb > 1 .and. p_is_root) THEN + IF (DEF_Reservoir_Method < 0 .or. DEF_Reservoir_Method > 1) THEN + IF (mpas_is_root) THEN + write(*,'(A,I0)') 'Unsupported CoLM2024 embedded reservoir method: ', DEF_Reservoir_Method + write(*,'(A)') 'Use DEF_Reservoir_Method = 0 (off) or 1.' + ENDIF + ierr = 1 + RETURN + ENDIF + IF (mpas_size > 1 .and. mpas_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded GridRiverLakeFlow uses MPAS communicator ranks for distributed routing.' - write(*,'(A)') 'Legacy CoLM MPI process pools and replicated full-river-network fallback are disabled.' + write(*,'(A)') 'No replicated full-river-network fallback is used.' ENDIF END SUBROUTINE colm_mpas_check_embedded_riverlake #endif SUBROUTINE colm_mpas_check_embedded_io(ierr) - USE MOD_Namelist, only: DEF_HIST_FREQ, DEF_HIST_WriteBack, USE_SITE_HistWriteBack - USE MOD_SPMD_Task, only: p_is_root + USE MOD_Namelist, only: DEF_HIST_FREQ, DEF_HIST_WriteBack, USE_SITE_HistWriteBack, & + DEF_USE_SNICAR, DEF_Aerosol_Readin, DEF_USE_Forcing_Downscaling, & + DEF_USE_Forcing_Downscaling_Simple, DEF_USE_ClimForcing_for_Spinup, & + DEF_Optimize_Baseflow, DEF_CheckEquilibrium, DEF_DA_TWS, DEF_DA_SM, & + DEF_DA_ENS_SM, DEF_DA_TWS_GRACE, DEF_DA_SM_SMAP, DEF_DA_SM_FY, & + DEF_DA_SM_SYNOP + USE MOD_MPAS_MPI, only: mpas_is_root integer, intent(out) :: ierr ierr = 0 USE_SITE_HistWriteBack = .false. IF ((trim(adjustl(DEF_HIST_FREQ)) /= 'none' .and. trim(adjustl(DEF_HIST_FREQ)) /= 'NONE') .or. & DEF_HIST_WriteBack) THEN - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(A)') 'CoLM2024 MPAS embedded mode currently writes fluxes through MPAS streams.' write(*,'(A)') 'Disable CoLM DEF_HIST_FREQ/DEF_HIST_WriteBack; CoLM restart files remain supported for patch/PFT state.' write(*,'(A)') 'CoLM USE_SITE_HistWriteBack is forced off in MPAS embedded mode.' ENDIF ierr = 1 ENDIF + IF (DEF_USE_SNICAR .and. DEF_Aerosol_Readin) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode does not yet receive the 14-component aerosol deposition forcing.' + write(*,'(A)') 'Set DEF_Aerosol_Readin = .false., or add an MPAS aerosol-deposition source before enabling it.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_USE_Forcing_Downscaling .or. DEF_USE_Forcing_Downscaling_Simple .or. & + DEF_USE_ClimForcing_for_Spinup) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode receives forcing directly from MPAS.' + write(*,'(A)') 'Disable CoLM forcing downscaling and climatological-forcing spinup options.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_Optimize_Baseflow) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode does not run the standalone annual baseflow optimizer.' + write(*,'(A)') 'Set DEF_Optimize_Baseflow = .false.; an existing scale_baseflow vector is still honored.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_CheckEquilibrium) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 standalone spinup-equilibrium checking is unavailable under the MPAS clock.' + write(*,'(A)') 'Set DEF_CheckEquilibrium = .false. for MPAS embedded runs.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_DA_TWS .or. DEF_DA_SM .or. DEF_DA_ENS_SM .or. DEF_DA_TWS_GRACE .or. & + DEF_DA_SM_SMAP .or. DEF_DA_SM_FY .or. DEF_DA_SM_SYNOP) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 standalone data-assimilation drivers are not part of the MPAS embedded coupling.' + write(*,'(A)') 'Disable all DEF_DA_* switches and perform atmospheric/land analysis through MPAS.' + ENDIF + ierr = 1 + ENDIF END SUBROUTINE colm_mpas_check_embedded_io - SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_mpas_cells, ierr) + SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, mpas_cell_lat, & + mpas_cell_lon, n_mpas_cells, ierr) USE MOD_Block, only: gblock, get_filename_block - USE MOD_SPMD_Task, only: p_iam_glb + USE MOD_MPAS_MPI, only: mpas_rank USE MOD_NetCDFSerial, only: ncio_read_serial - USE MOD_Utils, only: quicksort, find_in_sorted_list1 + USE MOD_Utils, only: quicksort, find_in_sorted_list1, find_nearest_south, & + find_nearest_west, normalize_longitude character(len=*), intent(in) :: dir_landdata integer, intent(in) :: lc_year integer*8, intent(in) :: mpas_cell_id(:) + real(r8), intent(in) :: mpas_cell_lat(:) + real(r8), intent(in) :: mpas_cell_lon(:) integer, intent(in) :: n_mpas_cells integer, intent(out) :: ierr + logical, allocatable :: candidate_block(:,:) logical, allocatable :: keep_block(:,:) logical, allocatable :: found_element(:) logical :: fexists @@ -344,6 +435,9 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m integer :: jblk integer :: iblkme integer :: match + integer :: scan_pass + real(r8) :: lat_deg + real(r8) :: lon_deg character(len=256) :: filename character(len=256) :: fileblock character(len=256) :: cyear @@ -353,20 +447,24 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m ierr = 1 IF (n_mpas_cells < 0) RETURN - IF (.not. allocated(gblock%pio)) RETURN + IF (.not. allocated(gblock%owner_rank)) RETURN IF (.not. allocated(gblock%lon_w)) RETURN IF (.not. allocated(gblock%lat_s)) RETURN IF (size(mpas_cell_id) < n_mpas_cells) RETURN + IF (size(mpas_cell_lat) < n_mpas_cells) RETURN + IF (size(mpas_cell_lon) < n_mpas_cells) RETURN + allocate(candidate_block(gblock%nxblk, gblock%nyblk)) allocate(keep_block(gblock%nxblk, gblock%nyblk)) + candidate_block = .false. keep_block = .false. IF (n_mpas_cells == 0) THEN - gblock%pio(:,:) = -1 + gblock%owner_rank(:,:) = -1 IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) gblock%nblkme = 0 - deallocate(keep_block) + deallocate(candidate_block, keep_block) ierr = 0 RETURN ENDIF @@ -375,6 +473,23 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m allocate(sorted_cell_id(n_mpas_cells)) found_element = .false. sorted_cell_id = mpas_cell_id(1:n_mpas_cells) + DO i = 1, n_mpas_cells + IF (.not. ieee_is_finite(mpas_cell_lat(i)) .or. .not. ieee_is_finite(mpas_cell_lon(i))) THEN + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + IF (abs(mpas_cell_lat(i)) > 0.5_r8 * pi + 1.e-12_r8 .or. & + abs(mpas_cell_lon(i)) > 4._r8 * pi) THEN + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + lat_deg = mpas_cell_lat(i) * 180._r8 / pi + lon_deg = mpas_cell_lon(i) * 180._r8 / pi + CALL normalize_longitude(lon_deg) + iblk = find_nearest_west(lon_deg, gblock%nxblk, gblock%lon_w) + jblk = find_nearest_south(lat_deg, gblock%nyblk, gblock%lat_s) + candidate_block(iblk,jblk) = .true. + ENDDO IF (n_mpas_cells > 1) THEN allocate(order(n_mpas_cells)) @@ -385,8 +500,8 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m DO i = 2, n_mpas_cells IF (sorted_cell_id(i) == sorted_cell_id(i-1)) THEN write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded duplicate cell/eindex on rank ', & - p_iam_glb, ': ', sorted_cell_id(i) - deallocate(keep_block, found_element, sorted_cell_id) + mpas_rank, ': ', sorted_cell_id(i) + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) RETURN ENDIF ENDDO @@ -395,8 +510,16 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m write(cyear,'(i4.4)') lc_year filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' - DO jblk = 1, gblock%nyblk - DO iblk = 1, gblock%nxblk + ! CoLM writes an element to the block containing most of its pixels, which + ! is usually the block containing the MPAS cell center but is not guaranteed + ! to be. Probe center blocks first, verify by exact eindex, then scan only + ! the remaining blocks when an irregular or boundary cell was not found. + DO scan_pass = 1, 2 + IF (scan_pass == 2 .and. all(found_element)) EXIT + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (scan_pass == 1 .and. .not. candidate_block(iblk,jblk)) CYCLE + IF (scan_pass == 2 .and. candidate_block(iblk,jblk)) CYCLE CALL get_filename_block(filename, iblk, jblk, fileblock) inquire(file=trim(fileblock), exist=fexists) IF (.not. fexists) CYCLE @@ -405,11 +528,18 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m DO ie = 1, size(elmindx) match = find_in_sorted_list1(elmindx(ie), n_mpas_cells, sorted_cell_id) IF (match > 0) THEN + IF (found_element(match)) THEN + write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded mesh contains duplicate eindex on rank ', & + mpas_rank, ': ', sorted_cell_id(match) + deallocate(elmindx, candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF keep_block(iblk,jblk) = .true. found_element(match) = .true. ENDIF ENDDO IF (allocated(elmindx)) deallocate(elmindx) + ENDDO ENDDO ENDDO @@ -417,25 +547,25 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m DO i = 1, n_mpas_cells IF (.not. found_element(i)) THEN write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded mesh is missing cell/eindex on rank ', & - p_iam_glb, ': ', sorted_cell_id(i) + mpas_rank, ': ', sorted_cell_id(i) EXIT ENDIF ENDDO - deallocate(keep_block, found_element, sorted_cell_id) + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) RETURN ENDIF - gblock%pio(:,:) = -1 + gblock%owner_rank(:,:) = -1 WHERE (keep_block) - gblock%pio = p_iam_glb + gblock%owner_rank = mpas_rank END WHERE IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) gblock%nblkme = count(keep_block) IF (gblock%nblkme < 1) THEN - write(*,'(A,I0)') 'CoLM2024 MPAS embedded found no local mesh blocks for rank ', p_iam_glb - deallocate(keep_block, found_element, sorted_cell_id) + write(*,'(A,I0)') 'CoLM2024 MPAS embedded found no local mesh blocks for rank ', mpas_rank + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) RETURN ENDIF @@ -452,7 +582,7 @@ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_m ENDDO ENDDO - deallocate(keep_block, found_element, sorted_cell_id) + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) ierr = 0 END SUBROUTINE colm_mpas_claim_owned_blocks @@ -460,7 +590,22 @@ SUBROUTINE colm_mpas_finalize(ierr) #ifdef GridRiverLakeFlow USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow_final #endif - USE MOD_SPMD_Task, only: spmd_exit + USE MOD_Vars_1DForcing, only: deallocate_1D_Forcing + USE MOD_Vars_1DFluxes, only: deallocate_1D_Fluxes + USE MOD_Vars_TimeVariables, only: deallocate_TimeVariables + USE MOD_Vars_TimeInvariants, only: deallocate_TimeInvariants + USE MOD_Opt_Baseflow, only: Opt_Baseflow_final + USE MOD_NetCDFVector, only: ncio_reset_distributed_validation + USE MOD_MPAS_MPI, only: mpas_mpi_detach + USE MOD_LandElm, only: landelm + USE MOD_LandPatch, only: patch2elm, grid_patch + USE MOD_Mesh, only: mesh_free_mem + USE MOD_Grid, only: grid_free_mem + USE MOD_Pixel, only: pixel + USE MOD_Block, only: gblock +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: landpft, numpft, pft2patch +#endif integer, intent(out) :: ierr ierr = 0 @@ -474,169 +619,245 @@ SUBROUTINE colm_mpas_finalize(ierr) #ifdef GridRiverLakeFlow CALL grid_riverlake_flow_final() #endif + CALL Opt_Baseflow_final() + CALL deallocate_1D_Fluxes() + CALL deallocate_1D_Forcing() + CALL deallocate_TimeVariables() + CALL deallocate_TimeInvariants() - CALL spmd_exit() +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL landpft%forc_free_mem() + IF (allocated(patch_pft_s)) deallocate(patch_pft_s) + IF (allocated(patch_pft_e)) deallocate(patch_pft_e) + IF (allocated(pft2patch)) deallocate(pft2patch) + numpft = 0 +#endif + IF (allocated(elm_patch%substt)) deallocate(elm_patch%substt) + IF (allocated(elm_patch%subend)) deallocate(elm_patch%subend) + IF (allocated(elm_patch%subfrc)) deallocate(elm_patch%subfrc) + IF (allocated(patch2elm%sup)) deallocate(patch2elm%sup) + CALL landpatch%forc_free_mem() + CALL landelm%forc_free_mem() + CALL grid_free_mem(grid_patch) + numpatch = 0 + CALL mesh_free_mem() + + IF (allocated(pixel%lat_s)) deallocate(pixel%lat_s) + IF (allocated(pixel%lat_n)) deallocate(pixel%lat_n) + IF (allocated(pixel%lon_w)) deallocate(pixel%lon_w) + IF (allocated(pixel%lon_e)) deallocate(pixel%lon_e) + pixel%nlon = 0 + pixel%nlat = 0 + + IF (allocated(gblock%lat_s)) deallocate(gblock%lat_s) + IF (allocated(gblock%lat_n)) deallocate(gblock%lat_n) + IF (allocated(gblock%lon_w)) deallocate(gblock%lon_w) + IF (allocated(gblock%lon_e)) deallocate(gblock%lon_e) + IF (allocated(gblock%owner_rank)) deallocate(gblock%owner_rank) + IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) + IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) + gblock%nxblk = 0 + gblock%nyblk = 0 + gblock%nblkme = 0 + CALL ncio_reset_distributed_validation() + + CALL mpas_mpi_detach() colm_mpas_initialized = .false. colm_mpas_restart_ready = .false. + colm_mpas_casename = '' + colm_mpas_dir_landdata = '' + colm_mpas_dir_restart = '' + colm_mpas_lc_year = -1 + colm_mpas_last_lai_year = -1 + colm_mpas_last_lai_period = -1 + colm_mpas_last_idate(:) = -1 + colm_mpas_last_restart_idate(:) = -1 END SUBROUTINE colm_mpas_finalize SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_cell_id, n_mpas_cells, cell_to_element, ierr) - USE MOD_LandElm, only: landelm - USE MOD_LandPatch, only: landpatch, numpatch - USE MOD_Mesh, only: numelm + USE MOD_LandElm, only: landelm + USE MOD_LandPatch, only: landpatch, numpatch + USE MOD_Mesh, only: mesh, numelm + USE MOD_Utils, only: quicksort, find_in_sorted_list1 #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT, only: landpft, numpft + USE MOD_LandPFT, only: landpft, numpft #endif integer, intent(in) :: mpas_cell_id(:) integer, intent(in) :: n_mpas_cells integer, intent(out) :: cell_to_element(:) integer, intent(out) :: ierr - logical, allocatable :: keep_elm(:) - logical, allocatable :: keep_patch(:) - logical, allocatable :: keep_pft(:) - integer, allocatable :: old_to_new(:) - integer, allocatable :: old_element_for_cell(:) - integer :: i - integer :: old_element - integer :: packed_count - - ierr = 1 - IF (n_mpas_cells < 1) RETURN - IF (numelm < 1) RETURN - IF (landelm%nset < 1) RETURN - - allocate(keep_elm(numelm)) - allocate(old_to_new(numelm)) - allocate(old_element_for_cell(n_mpas_cells)) - - keep_elm = .false. - old_to_new = 0 - - DO i = 1, n_mpas_cells - CALL colm_mpas_find_element_by_eindex(mpas_cell_id(i), old_element) - IF (old_element <= 0 .or. old_element > numelm) RETURN - - old_element_for_cell(i) = old_element - keep_elm(old_element) = .true. - ENDDO - - packed_count = 0 - DO i = 1, numelm - IF (keep_elm(i)) THEN - packed_count = packed_count + 1 - old_to_new(i) = packed_count - ENDIF - ENDDO - IF (packed_count /= n_mpas_cells) RETURN - - CALL colm_mpas_pack_mesh(keep_elm, old_to_new) - CALL landelm%pset_pack(keep_elm, packed_count) - CALL colm_mpas_remap_pixelset_ielm(landelm, old_to_new, ierr) - IF (ierr /= 0) RETURN - - IF (landpatch%nset > 0) THEN - allocate(keep_patch(landpatch%nset)) - DO i = 1, landpatch%nset - keep_patch(i) = landpatch%ielm(i) >= 1 .and. landpatch%ielm(i) <= size(old_to_new) - IF (keep_patch(i)) keep_patch(i) = old_to_new(landpatch%ielm(i)) > 0 - ENDDO - CALL landpatch%pset_pack(keep_patch, numpatch) - CALL colm_mpas_remap_pixelset_ielm(landpatch, old_to_new, ierr) - deallocate(keep_patch) - IF (ierr /= 0) RETURN - ENDIF + logical, allocatable :: seen_element(:) + integer, allocatable :: element_order(:) + integer*8, allocatable :: sorted_eindex(:) + integer :: i + integer :: match + integer :: element + ierr = 1 + IF (n_mpas_cells < 1) RETURN + IF (numelm /= n_mpas_cells) RETURN + IF (size(mpas_cell_id) < n_mpas_cells) RETURN + IF (size(cell_to_element) < n_mpas_cells) RETURN + IF (.not. allocated(mesh)) RETURN + IF (size(mesh) /= numelm) RETURN + IF (.not. allocated(landelm%ipxstt) .or. .not. allocated(landelm%ipxend)) RETURN + IF (size(landelm%ipxstt) /= landelm%nset .or. size(landelm%ipxend) /= landelm%nset) RETURN + + CALL colm_mpas_validate_pixelset_element_map(landelm, numelm, ierr) + IF (ierr /= 0 .or. landelm%nset /= numelm) RETURN + IF (numpatch /= landpatch%nset) RETURN + CALL colm_mpas_validate_pixelset_element_map(landpatch, numelm, ierr) + IF (ierr /= 0) RETURN #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (landpft%nset > 0) THEN - allocate(keep_pft(landpft%nset)) - DO i = 1, landpft%nset - keep_pft(i) = landpft%ielm(i) >= 1 .and. landpft%ielm(i) <= size(old_to_new) - IF (keep_pft(i)) keep_pft(i) = old_to_new(landpft%ielm(i)) > 0 - ENDDO - CALL landpft%pset_pack(keep_pft, numpft) - CALL colm_mpas_remap_pixelset_ielm(landpft, old_to_new, ierr) - deallocate(keep_pft) - IF (ierr /= 0) RETURN - ENDIF + IF (numpft /= landpft%nset) RETURN + CALL colm_mpas_validate_pixelset_element_map(landpft, numelm, ierr) + IF (ierr /= 0) RETURN #endif - DO i = 1, n_mpas_cells - cell_to_element(i) = old_to_new(old_element_for_cell(i)) - IF (cell_to_element(i) <= 0) RETURN - ENDDO - - ierr = 0 - END SUBROUTINE colm_mpas_restrict_to_mpas_cells + allocate(seen_element(numelm)) + allocate(sorted_eindex(numelm)) + allocate(element_order(numelm)) - SUBROUTINE colm_mpas_pack_mesh(keep_elm, old_to_new) - USE MOD_Mesh, only: irregular_elm_type, mesh, numelm, copy_elm - logical, intent(in) :: keep_elm(:) - integer, intent(in) :: old_to_new(:) + seen_element = .false. + DO i = 1, landelm%nset + element = landelm%ielm(i) + IF (seen_element(element)) RETURN + IF (landelm%ipxstt(i) /= 1 .or. landelm%ipxend(i) /= mesh(element)%npxl) RETURN + seen_element(element) = .true. + ENDDO + IF (.not. all(seen_element)) RETURN + seen_element = .false. + DO i = 1, numelm + sorted_eindex(i) = mesh(i)%indx + ENDDO + element_order = (/ (i, i = 1, numelm) /) + IF (numelm > 1) CALL quicksort(numelm, sorted_eindex, element_order) + IF (numelm > 1) THEN + IF (any(sorted_eindex(2:numelm) == sorted_eindex(1:numelm-1))) RETURN + ENDIF - type(irregular_elm_type), allocatable :: packed_mesh(:) - integer :: old_elm - integer :: new_elm - integer :: packed_count + DO i = 1, n_mpas_cells + match = find_in_sorted_list1(int(mpas_cell_id(i), kind=8), numelm, sorted_eindex) + IF (match < 1) RETURN + element = element_order(match) + IF (seen_element(element)) RETURN + seen_element(element) = .true. + cell_to_element(i) = element + ENDDO + IF (.not. all(seen_element)) RETURN - packed_count = count(keep_elm) - allocate(packed_mesh(packed_count)) + ierr = 0 + END SUBROUTINE colm_mpas_restrict_to_mpas_cells + + SUBROUTINE colm_mpas_validate_cell_geometry(mpas_cell_id, mpas_cell_lat, mpas_cell_lon, & + n_mpas_cells, cell_to_element, ierr) + USE MOD_Mesh, only: mesh, numelm + USE MOD_Pixel, only: pixel + USE MOD_Utils, only: normalize_longitude, lon_between_floor + USE MOD_MPAS_MPI, only: mpas_rank + integer, intent(in) :: mpas_cell_id(:) + real(r8), intent(in) :: mpas_cell_lat(:) + real(r8), intent(in) :: mpas_cell_lon(:) + integer, intent(in) :: n_mpas_cells + integer, intent(in) :: cell_to_element(:) + integer, intent(out) :: ierr - DO old_elm = 1, size(keep_elm) - IF (.not. keep_elm(old_elm)) CYCLE - new_elm = old_to_new(old_elm) - CALL copy_elm(mesh(old_elm), packed_mesh(new_elm)) - ENDDO + integer :: i + integer :: element + integer :: ipxl + integer :: ilat + integer :: ilon + real(r8) :: lat_deg + real(r8) :: lon_deg + real(r8) :: lon_east_delta + logical :: contains_center + real(r8), parameter :: angular_tolerance = 1.e-8_r8 - IF (allocated(mesh)) deallocate(mesh) - CALL move_alloc(packed_mesh, mesh) - numelm = packed_count - END SUBROUTINE colm_mpas_pack_mesh + ierr = 1 + IF (n_mpas_cells < 1) RETURN + IF (size(mpas_cell_id) < n_mpas_cells .or. size(mpas_cell_lat) < n_mpas_cells .or. & + size(mpas_cell_lon) < n_mpas_cells .or. size(cell_to_element) < n_mpas_cells) RETURN + IF (.not. allocated(mesh) .or. size(mesh) /= numelm) RETURN + IF (.not. allocated(pixel%lat_s) .or. .not. allocated(pixel%lat_n) .or. & + .not. allocated(pixel%lon_w) .or. .not. allocated(pixel%lon_e)) RETURN + + DO i = 1, n_mpas_cells + IF (.not. ieee_is_finite(mpas_cell_lat(i)) .or. .not. ieee_is_finite(mpas_cell_lon(i))) RETURN + IF (abs(mpas_cell_lat(i)) > 0.5_r8 * pi + 1.e-12_r8 .or. & + abs(mpas_cell_lon(i)) > 4._r8 * pi) RETURN + + element = cell_to_element(i) + IF (element < 1 .or. element > numelm) RETURN + IF (mesh(element)%indx /= int(mpas_cell_id(i), kind=8)) RETURN + IF (mesh(element)%npxl < 1) RETURN + IF (.not. allocated(mesh(element)%ilat) .or. .not. allocated(mesh(element)%ilon)) RETURN + IF (size(mesh(element)%ilat) /= mesh(element)%npxl .or. & + size(mesh(element)%ilon) /= mesh(element)%npxl) RETURN + + lat_deg = mpas_cell_lat(i) * 180._r8 / pi + lon_deg = mpas_cell_lon(i) * 180._r8 / pi + CALL normalize_longitude(lon_deg) + contains_center = .false. + + DO ipxl = 1, mesh(element)%npxl + ilat = mesh(element)%ilat(ipxl) + ilon = mesh(element)%ilon(ipxl) + IF (ilat < 1 .or. ilat > pixel%nlat .or. ilon < 1 .or. ilon > pixel%nlon) RETURN + IF (.not. all(ieee_is_finite((/pixel%lat_s(ilat), pixel%lat_n(ilat), & + pixel%lon_w(ilon), pixel%lon_e(ilon)/)))) RETURN + + lon_east_delta = abs(modulo(lon_deg - pixel%lon_e(ilon) + 180._r8, 360._r8) - 180._r8) + IF (lat_deg >= pixel%lat_s(ilat) - angular_tolerance .and. & + lat_deg <= pixel%lat_n(ilat) + angular_tolerance .and. & + (lon_between_floor(lon_deg, pixel%lon_w(ilon), pixel%lon_e(ilon)) .or. & + lon_east_delta <= angular_tolerance)) THEN + contains_center = .true. + EXIT + ENDIF + ENDDO - SUBROUTINE colm_mpas_remap_pixelset_ielm(pixelset, old_to_new, ierr) - USE MOD_Pixelset, only: pixelset_type - type(pixelset_type), intent(inout) :: pixelset - integer, intent(in) :: old_to_new(:) - integer, intent(out) :: ierr + IF (.not. contains_center) THEN + write(*,'(A,I0,A,I0,A,I0,A,2(F13.7,1X))') & + 'CoLM2024 MPAS mesh mismatch on rank ', mpas_rank, ': local cell ', i, & + ', eindex ', mpas_cell_id(i), ', center lon/lat (degrees) ', lon_deg, lat_deg + RETURN + ENDIF + ENDDO - integer :: iset - integer :: old_elm + ierr = 0 + END SUBROUTINE colm_mpas_validate_cell_geometry - ierr = 1 - DO iset = 1, pixelset%nset - old_elm = pixelset%ielm(iset) - IF (old_elm < 1 .or. old_elm > size(old_to_new)) RETURN - IF (old_to_new(old_elm) <= 0) RETURN - pixelset%ielm(iset) = old_to_new(old_elm) - ENDDO + SUBROUTINE colm_mpas_validate_pixelset_element_map(pixelset, num_elements, ierr) + USE MOD_Pixelset, only: pixelset_type + USE MOD_Mesh, only: mesh + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: num_elements + integer, intent(out) :: ierr - ierr = 0 - END SUBROUTINE colm_mpas_remap_pixelset_ielm + integer :: iset + integer :: element - SUBROUTINE colm_mpas_find_element_by_eindex(cell_id, element) - USE MOD_LandElm, only: landelm - integer, intent(in) :: cell_id - integer, intent(out) :: element + ierr = 1 + IF (pixelset%nset < 0) RETURN + IF (pixelset%nset == 0) THEN + ierr = 0 + RETURN + ENDIF + IF (.not. allocated(pixelset%eindex) .or. .not. allocated(pixelset%ielm)) RETURN + IF (size(pixelset%eindex) /= pixelset%nset .or. size(pixelset%ielm) /= pixelset%nset) RETURN + DO iset = 1, pixelset%nset + element = pixelset%ielm(iset) + IF (element < 1 .or. element > num_elements) RETURN + IF (pixelset%eindex(iset) /= mesh(element)%indx) RETURN + ENDDO - integer :: i - integer :: hits - integer*8 :: cell_id_i8 - - element = 0 - hits = 0 - cell_id_i8 = cell_id - DO i = 1, landelm%nset - IF (landelm%eindex(i) == cell_id_i8) THEN - hits = hits + 1 - element = i - ENDIF - ENDDO - IF (hits /= 1) element = 0 - END SUBROUTINE colm_mpas_find_element_by_eindex + ierr = 0 + END SUBROUTINE colm_mpas_validate_pixelset_element_map SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr) USE MOD_LandElm, only: landelm - USE MOD_SPMD_Task, only: p_iam_glb + USE MOD_MPAS_MPI, only: mpas_rank logical, intent(in) :: require_active_patch integer, intent(out) :: ierr @@ -646,7 +867,11 @@ SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr) integer :: iend integer :: local_missing integer :: first_missing - logical :: has_patch + logical :: valid_coverage + real(r8) :: fraction + real(r8) :: total_fraction + real(r8) :: active_fraction + real(r8), parameter :: fraction_tolerance = 1.e-10_r8 ierr = 1 IF (.not. allocated(elm_patch%substt)) RETURN @@ -663,46 +888,105 @@ SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr) local_missing = 0 first_missing = -1 - DO element = 1, landelm%nset - istt = elm_patch%substt(element) - iend = elm_patch%subend(element) - has_patch = .false. - - IF (istt >= 1 .and. iend >= istt .and. iend <= numpatch) THEN - DO patch = istt, iend - IF (patch < 1 .or. patch > numpatch) CYCLE - IF (require_active_patch .and. allocated(patchmask)) THEN - IF (patchmask(patch)) has_patch = .true. - ELSE - has_patch = .true. - ENDIF - ENDDO - ENDIF + DO element = 1, landelm%nset + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + valid_coverage = istt >= 1 .and. iend >= istt .and. iend <= numpatch + total_fraction = 0._r8 + active_fraction = 0._r8 + + IF (valid_coverage) THEN + DO patch = istt, iend + fraction = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(fraction) .or. fraction < 0._r8) THEN + valid_coverage = .false. + EXIT + ENDIF + total_fraction = total_fraction + fraction + IF (.not. require_active_patch .or. patchmask(patch)) & + active_fraction = active_fraction + fraction + ENDDO + ENDIF + IF (.not. ieee_is_finite(total_fraction) .or. & + abs(total_fraction - 1._r8) > fraction_tolerance) valid_coverage = .false. + IF (require_active_patch) THEN + IF (.not. ieee_is_finite(active_fraction) .or. & + abs(active_fraction - total_fraction) > fraction_tolerance) valid_coverage = .false. + ENDIF - IF (.not. has_patch) THEN - local_missing = local_missing + 1 - IF (first_missing < 0) first_missing = element + IF (.not. valid_coverage) THEN + local_missing = local_missing + 1 + IF (first_missing < 0) first_missing = element ENDIF ENDDO IF (local_missing > 0) THEN IF (first_missing > 0 .and. first_missing <= landelm%nset) THEN write(*,'(A,I0,A,I0,A,I0,A,I0)') & - 'CoLM2024 MPAS embedded landdata is missing usable patch coverage on rank ', & - p_iam_glb, ': ', local_missing, ' element(s); first local element ', & + 'CoLM2024 MPAS embedded landdata has incomplete patch coverage on rank ', & + mpas_rank, ': ', local_missing, ' element(s); first local element ', & first_missing, ', eindex ', landelm%eindex(first_missing) ELSE write(*,'(A,I0,A,I0)') & - 'CoLM2024 MPAS embedded landdata is missing usable patch coverage on rank ', & - p_iam_glb, ': ', local_missing + 'CoLM2024 MPAS embedded landdata has incomplete patch coverage on rank ', & + mpas_rank, ': ', local_missing ENDIF RETURN ENDIF ierr = 0 - END SUBROUTINE colm_mpas_validate_element_patch_map + END SUBROUTINE colm_mpas_validate_element_patch_map + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE colm_mpas_validate_pft_fractions(ierr) + USE MOD_LandPFT, only: numpft + USE MOD_MPAS_MPI, only: mpas_rank + integer, intent(out) :: ierr + + integer :: patch + integer :: pft_start + integer :: pft_end + real(r8) :: fraction_sum + real(r8), parameter :: fraction_tolerance = 1.e-10_r8 - SUBROUTINE colm_mpas_ready(ready, patch_count) + ierr = 1 + IF (numpatch == 0) THEN + IF (numpft /= 0) RETURN + ierr = 0 + RETURN + ENDIF + IF (.not. allocated(patch_pft_s) .or. .not. allocated(patch_pft_e)) RETURN + IF (size(patch_pft_s) /= numpatch .or. size(patch_pft_e) /= numpatch) RETURN + IF (numpft > 0) THEN + IF (.not. allocated(pftfrac) .or. size(pftfrac) /= numpft) RETURN + ENDIF + + DO patch = 1, numpatch + pft_start = patch_pft_s(patch) + pft_end = patch_pft_e(patch) + IF (pft_start == -1 .or. pft_end == -1) THEN + IF (pft_start /= -1 .or. pft_end /= -1) EXIT + ELSE + IF (pft_start < 1 .or. pft_end < pft_start .or. pft_end > numpft) EXIT + IF (.not. all(ieee_is_finite(pftfrac(pft_start:pft_end)))) EXIT + IF (any(pftfrac(pft_start:pft_end) < 0._r8)) EXIT + fraction_sum = sum(pftfrac(pft_start:pft_end)) + IF (.not. ieee_is_finite(fraction_sum) .or. & + abs(fraction_sum - 1._r8) > fraction_tolerance) EXIT + ENDIF + ENDDO + + IF (patch <= numpatch) THEN + write(*,'(A,I0,A,I0,A,I0)') 'CoLM2024 MPAS embedded landdata has invalid PFT fractions on rank ', & + mpas_rank, ': local patch ', patch, ', eindex ', landpatch%eindex(patch) + RETURN + ENDIF + + ierr = 0 + END SUBROUTINE colm_mpas_validate_pft_fractions +#endif + + SUBROUTINE colm_mpas_ready(ready, patch_count) logical, intent(out) :: ready integer, intent(out), optional :: patch_count @@ -710,7 +994,8 @@ SUBROUTINE colm_mpas_ready(ready, patch_count) ready = colm_mpas_initialized .and. allocated(elm_patch%substt) .and. & allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) ELSE - ready = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) & + ready = colm_mpas_initialized .and. allocated(forc_t) .and. allocated(oroflag) .and. & + allocated(fsena) .and. allocated(t_grnd) .and. allocated(patchmask) & .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) ENDIF IF (present(patch_count)) THEN @@ -722,21 +1007,29 @@ SUBROUTINE colm_mpas_ready(ready, patch_count) ENDIF END SUBROUTINE colm_mpas_ready - SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, oro, ozone, ierr) integer, intent(in) :: patch - real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow + real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine real(r8), intent(in) :: psrf, pbot, sols, soll, solsd, solld, frl real(r8), intent(in) :: hgt_u, hgt_t, hgt_q, rhoair, hpbl real(r8), intent(in) :: aerdep(14) real(r8), intent(in), optional :: oro real(r8), intent(in), optional :: ozone integer, intent(out) :: ierr + real(r8) :: patch_oro ierr = 1 IF (.not. allocated(forc_t)) RETURN + IF (.not. allocated(coszen)) RETURN IF (patch < 1 .or. patch > size(forc_t)) RETURN + IF (patch > size(coszen)) RETURN + IF (.not. ieee_is_finite(solar_cosine) .or. solar_cosine < -1._r8 .or. solar_cosine > 1._r8) RETURN + IF (present(oro)) THEN + IF (.not. allocated(oroflag) .or. .not. allocated(patchtype)) RETURN + IF (patch > size(oroflag) .or. patch > size(patchtype)) RETURN + ENDIF forc_pco2m(patch) = pco2m forc_po2m (patch) = po2m @@ -748,6 +1041,7 @@ SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, pr forc_prl (patch) = prl forc_rain (patch) = rain forc_snow (patch) = snow + coszen (patch) = solar_cosine forc_psrf (patch) = psrf forc_pbot (patch) = pbot forc_sols (patch) = sols @@ -765,7 +1059,14 @@ SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, pr forc_rhoair(patch) = rhoair forc_hpbl (patch) = hpbl forc_aerdep(:,patch) = aerdep(:) - IF (present(oro) .and. allocated(oroflag)) oroflag(patch) = oro + IF (present(oro)) THEN + patch_oro = 1._r8 + IF (patchtype(patch) >= 99) THEN + patch_oro = 0._r8 + IF (nint(oro) == 2) patch_oro = 2._r8 + ENDIF + oroflag(patch) = patch_oro + ENDIF IF (present(ozone)) THEN forc_ozone(patch) = ozone ELSE @@ -775,10 +1076,11 @@ SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, pr END SUBROUTINE colm_mpas_set_forcing SUBROUTINE colm_mpas_set_element_forcing(element, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + solar_cosine, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, oro, ozone, ierr) integer, intent(in) :: element - real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow + real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine real(r8), intent(in) :: psrf, pbot, sols, soll, solsd, solld, frl real(r8), intent(in) :: hgt_u, hgt_t, hgt_q, rhoair, hpbl real(r8), intent(in) :: aerdep(14) @@ -796,32 +1098,39 @@ SUBROUTINE colm_mpas_set_element_forcing(element, pco2m, po2m, us, vs, tair, qai IF (.not. allocated(elm_patch%substt)) RETURN IF (.not. allocated(elm_patch%subend)) RETURN IF (.not. allocated(elm_patch%subfrc)) RETURN - IF (element < 1 .or. element > size(elm_patch%substt)) RETURN + IF (numpatch < 1) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN istt = elm_patch%substt(element) iend = elm_patch%subend(element) - IF (istt < 1 .or. iend < istt) RETURN + IF (istt < 1 .or. iend < istt .or. iend > numpatch .or. & + iend > size(elm_patch%subfrc)) RETURN did_set = .false. DO patch = istt, iend - IF (patch < 1 .or. patch > numpatch) CYCLE + IF (patch < 1 .or. patch > numpatch) RETURN IF (allocated(patchmask)) THEN IF (.not. patchmask(patch)) CYCLE ENDIF IF (present(oro) .and. present(ozone)) THEN - CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, oro=oro, ozone=ozone, ierr=patch_ierr) ELSEIF (present(oro)) THEN - CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, oro=oro, ierr=patch_ierr) ELSEIF (present(ozone)) THEN - CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, ozone=ozone, ierr=patch_ierr) ELSE - CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & rhoair, hpbl, aerdep, ierr=patch_ierr) ENDIF @@ -833,6 +1142,9 @@ SUBROUTINE colm_mpas_set_element_forcing(element, pco2m, po2m, us, vs, tair, qai END SUBROUTINE colm_mpas_set_element_forcing SUBROUTINE colm_mpas_step(idate, deltim, dolai, doalb, dosst, ierr) + USE MOD_LAIReadin, only: LAI_readin + USE MOD_Namelist, only: DEF_LAI_MONTHLY, DEF_LAI_CHANGE_YEARLY + USE MOD_TimeManager, only: julian2monthday #ifdef GridRiverLakeFlow USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow #endif @@ -841,30 +1153,60 @@ SUBROUTINE colm_mpas_step(idate, deltim, dolai, doalb, dosst, ierr) logical, intent(in) :: dolai, doalb, dosst integer, intent(out) :: ierr - logical :: ready + integer :: lai_month + integer :: lai_mday + integer :: lai_period + integer :: lai_time + integer :: lai_year + logical :: ready CALL colm_mpas_ready(ready) ierr = 1 IF (.not. ready) RETURN - IF (numpatch > 0) CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag) + IF (DEF_LAI_MONTHLY) THEN + CALL julian2monthday(idate(1), idate(2), lai_month, lai_mday) + lai_period = lai_month + lai_time = lai_month + ELSE + lai_period = 1 + (idate(2) - 1) / 8 + lai_time = 1 + 8 * (lai_period - 1) + ENDIF + IF (DEF_LAI_CHANGE_YEARLY) THEN + lai_year = idate(1) + ELSE + lai_year = colm_mpas_lc_year + ENDIF + IF (numpatch > 0) CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag) #ifdef GridRiverLakeFlow CALL grid_riverlake_flow(idate(1), deltim) #endif + ! CoLM updates prescribed LAI/SAI after a period-boundary step so that + ! the new vegetation data are used by the following step. + IF (lai_year /= colm_mpas_last_lai_year .or. lai_period /= colm_mpas_last_lai_period) THEN + CALL LAI_readin(lai_year, lai_time, colm_mpas_dir_landdata) + colm_mpas_last_lai_year = lai_year + colm_mpas_last_lai_period = lai_period + ENDIF colm_mpas_last_idate(:) = idate(:) CALL colm_mpas_write_restart_if_due(idate, deltim, .false., ierr) IF (ierr /= 0) RETURN ierr = 0 END SUBROUTINE colm_mpas_step + SUBROUTINE colm_mpas_force_restart(ierr) + integer, intent(out) :: ierr + + ierr = 1 + IF (.not. colm_mpas_initialized) RETURN + IF (colm_mpas_last_idate(1) <= 0) RETURN + CALL colm_mpas_write_restart_if_due(colm_mpas_last_idate, 0._r8, .true., ierr) + END SUBROUTINE colm_mpas_force_restart + SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) USE MOD_Namelist, only: DEF_WRST_FREQ - USE MOD_SPMD_Task, only: p_is_root USE MOD_TimeManager, only: adj2begin USE MOD_Vars_TimeVariables, only: save_to_restart, WRITE_TimeVariables -#ifdef GridRiverLakeFlow - USE MOD_Grid_RiverLakeTimeVars, only: WRITE_GridRiverLakeTimeVars -#endif integer, intent(in) :: idate(3) real(r8), intent(in) :: deltim logical, intent(in) :: force @@ -875,11 +1217,6 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) integer :: write_lc_year logical :: should_write character(len=256) :: wrst_freq -#if defined(GridRiverLakeFlow) && !defined(MPAS_EMBEDDED_COLM) - character(len=14) :: cdate - character(len=256) :: cyear - character(len=256) :: file_restart -#endif ierr = 0 IF (.not. colm_mpas_restart_ready) RETURN @@ -913,28 +1250,7 @@ SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) write_lc_year = colm_mpas_lc_year #endif -#ifdef GridRiverLakeFlow -#ifdef MPAS_EMBEDDED_COLM CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) -#else - IF (numpatch == 0) THEN - write(cyear,'(i4.4)') write_lc_year - write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') write_idate(1), write_idate(2), write_idate(3) - IF (p_is_root) CALL system('mkdir -p ' // trim(colm_mpas_dir_restart)//'/'//trim(cdate)) - file_restart = trim(colm_mpas_dir_restart)// '/'//trim(cdate)//'/' // & - trim(colm_mpas_casename) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_GridRiverLakeTimeVars(file_restart) - ELSE - CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) - ENDIF -#endif -#else -#ifdef MPAS_EMBEDDED_COLM - CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) -#else - IF (numpatch > 0) CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) -#endif -#endif colm_mpas_last_restart_idate(:) = write_idate(:) END SUBROUTINE colm_mpas_write_restart_if_due @@ -954,13 +1270,29 @@ END FUNCTION colm_mpas_timestamp_reached SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_heat, runoff, & surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & - surface_humidity, emissivity, roughness, albedo, ierr) + u10m, v10m, & + surface_humidity, emissivity, roughness, albedo, friction_velocity, & + stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov, ierr) integer, intent(in) :: patch real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: u10m, v10m real(r8), intent(out) :: surface_humidity real(r8), intent(out) :: emissivity, roughness, albedo + real(r8), intent(out) :: friction_velocity, stability_zeta, bulk_richardson + real(r8), intent(out) :: momentum_profile, heat_profile + real(r8), intent(out) :: moisture_profile, air_density + real(r8), intent(out) :: heat_exchange_velocity, moisture_exchange_velocity + real(r8), intent(out) :: momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov integer, intent(out) :: ierr + real(r8) :: incoming_shortwave + real(r8) :: bad_value + real(r8) :: reference_height_u + real(r8) :: reference_height_t + real(r8) :: reference_height_q ierr = 1 sensible = spval @@ -973,10 +1305,24 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he skin_temp = spval t2m = spval q2m = spval + u10m = spval + v10m = spval surface_humidity = spval emissivity = spval roughness = spval albedo = spval + friction_velocity = spval + stability_zeta = spval + bulk_richardson = spval + momentum_profile = spval + heat_profile = spval + moisture_profile = spval + air_density = spval + heat_exchange_velocity = spval + moisture_exchange_velocity = spval + momentum_coefficient = spval + enthalpy_coefficient = spval + inverse_monin_obukhov = spval IF (.not. allocated(fsena)) RETURN IF (.not. allocated(lfevpa)) RETURN @@ -985,7 +1331,7 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he IF (.not. allocated(rnof)) RETURN IF (.not. allocated(rsur)) RETURN IF (.not. allocated(rsub)) RETURN - IF (.not. allocated(t_grnd)) RETURN + IF (.not. allocated(trad)) RETURN IF (.not. allocated(tref)) RETURN IF (.not. allocated(qref)) RETURN IF (.not. allocated(emis)) RETURN @@ -998,7 +1344,7 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he IF (patch > size(rnof)) RETURN IF (patch > size(rsur)) RETURN IF (patch > size(rsub)) RETURN - IF (patch > size(t_grnd)) RETURN + IF (patch > size(trad)) RETURN IF (patch > size(tref)) RETURN IF (patch > size(qref)) RETURN IF (patch > size(emis)) RETURN @@ -1011,32 +1357,231 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he runoff = rnof(patch) surface_runoff = rsur(patch) subsurface_runoff = rsub(patch) - skin_temp = t_grnd(patch) + skin_temp = trad(patch) t2m = tref(patch) q2m = qref(patch) surface_humidity = qref(patch) IF (allocated(qsfc)) THEN IF (patch <= size(qsfc)) THEN - IF (qsfc(patch) > 0._r8 .and. qsfc(patch) < 1._r8) surface_humidity = qsfc(patch) + IF (qsfc(patch) >= 0._r8 .and. qsfc(patch) < 1._r8) surface_humidity = qsfc(patch) ENDIF ENDIF emissivity = emis(patch) roughness = z0m(patch) - IF (allocated(alb)) THEN - ! ponytail: bulk albedo average; replace with band/beam mapping when MPAS consumes CoLM spectral albedo. - IF (patch <= size(alb,3)) albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) - ENDIF - ierr = 0 - END SUBROUTINE colm_mpas_get_surface + bad_value = 0.5_r8 * abs(spval) + IF (allocated(alb)) THEN + IF (patch <= size(alb,3)) THEN + IF (all(abs(alb(:,:,patch)) < bad_value)) THEN + incoming_shortwave = forc_sols(patch) + forc_soll(patch) + forc_solsd(patch) + forc_solld(patch) + IF (incoming_shortwave > tiny(1._r8)) THEN + albedo = (alb(1,1,patch) * forc_sols(patch) + alb(2,1,patch) * forc_soll(patch) + & + alb(1,2,patch) * forc_solsd(patch) + alb(2,2,patch) * forc_solld(patch)) / & + incoming_shortwave + ELSE + albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) + ENDIF + ENDIF + ENDIF + ENDIF + IF (allocated(ustar)) THEN + IF (patch <= size(ustar)) friction_velocity = ustar(patch) + ENDIF + IF (allocated(zol)) THEN + IF (patch <= size(zol)) stability_zeta = zol(patch) + ENDIF + IF (allocated(rib)) THEN + IF (patch <= size(rib)) bulk_richardson = rib(patch) + ENDIF + IF (allocated(fm)) THEN + IF (patch <= size(fm)) momentum_profile = fm(patch) + ENDIF + IF (allocated(fh)) THEN + IF (patch <= size(fh)) heat_profile = fh(patch) + ENDIF + IF (allocated(fq)) THEN + IF (patch <= size(fq)) moisture_profile = fq(patch) + ENDIF + IF (allocated(forc_rhoair)) THEN + IF (patch <= size(forc_rhoair)) air_density = forc_rhoair(patch) + ENDIF + IF (abs(friction_velocity) < bad_value .and. friction_velocity >= 0._r8) THEN + IF (abs(heat_profile) < bad_value .and. heat_profile > tiny(1._r8)) & + heat_exchange_velocity = vonkar * friction_velocity / heat_profile + IF (abs(moisture_profile) < bad_value .and. moisture_profile > tiny(1._r8)) & + moisture_exchange_velocity = vonkar * friction_velocity / moisture_profile + ENDIF + IF (abs(air_density) < bad_value .and. air_density > 0._r8 .and. & + abs(moisture_exchange_velocity) < bad_value .and. & + moisture_exchange_velocity > tiny(1._r8)) THEN + IF (.not. allocated(forc_q) .or. patch > size(forc_q)) RETURN + IF (.not. ieee_is_finite(forc_q(patch)) .or. forc_q(patch) < 0._r8 .or. & + forc_q(patch) >= 1._r8) RETURN + ! The atmospheric boundary sees canopy-air humidity, not ground qg. + ! Reconstruct the effective bulk value from CoLM's total vapor flux. + surface_humidity = forc_q(patch) + evaporation / & + (air_density * moisture_exchange_velocity) + IF (.not. ieee_is_finite(surface_humidity) .or. surface_humidity < 0._r8 .or. & + surface_humidity >= 1._r8) RETURN + ENDIF + IF (abs(momentum_profile) < bad_value .and. momentum_profile > tiny(1._r8)) THEN + momentum_coefficient = (vonkar / momentum_profile)**2 + IF (abs(moisture_profile) < bad_value .and. moisture_profile > tiny(1._r8)) & + enthalpy_coefficient = vonkar**2 / (momentum_profile * moisture_profile) + ENDIF + CALL colm_mpas_get_patch_reference_heights(patch, reference_height_u, reference_height_t, & + reference_height_q, ierr) + IF (ierr /= 0) RETURN + IF (abs(stability_zeta) < bad_value .and. allocated(displa)) THEN + IF (patch <= size(forc_hgt_u) .and. patch <= size(displa)) THEN + IF (reference_height_u - displa(patch) > tiny(1._r8)) & + inverse_monin_obukhov = stability_zeta / (reference_height_u - displa(patch)) + ENDIF + ENDIF + CALL colm_mpas_get_patch_10m_wind(patch, u10m, v10m, ierr) + IF (ierr /= 0) RETURN + ierr = 0 + END SUBROUTINE colm_mpas_get_surface + + SUBROUTINE colm_mpas_get_patch_reference_heights(patch, height_u, height_t, height_q, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: height_u + real(r8), intent(out) :: height_t + real(r8), intent(out) :: height_q + integer, intent(out) :: ierr + + real(r8) :: canopy_top +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + integer :: pft_start + integer :: pft_end +#endif + + ierr = 1 + height_u = spval + height_t = spval + height_q = spval + IF (.not. allocated(forc_hgt_u) .or. .not. allocated(forc_hgt_t) .or. & + .not. allocated(forc_hgt_q) .or. .not. allocated(htop)) RETURN + IF (patch < 1 .or. patch > size(forc_hgt_u) .or. patch > size(forc_hgt_t) .or. & + patch > size(forc_hgt_q) .or. patch > size(htop)) RETURN + IF (.not. all(ieee_is_finite((/forc_hgt_u(patch), forc_hgt_t(patch), & + forc_hgt_q(patch), htop(patch)/)))) RETURN + IF (forc_hgt_u(patch) <= 0._r8 .or. forc_hgt_t(patch) <= 0._r8 .or. & + forc_hgt_q(patch) <= 0._r8 .or. htop(patch) < 0._r8) RETURN + + canopy_top = htop(patch) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (allocated(patch_pft_s) .and. allocated(patch_pft_e) .and. allocated(htop_p)) THEN + IF (patch <= size(patch_pft_s) .and. patch <= size(patch_pft_e)) THEN + pft_start = patch_pft_s(patch) + pft_end = patch_pft_e(patch) + IF (pft_start >= 1 .and. pft_end >= pft_start .and. pft_end <= size(htop_p)) THEN + IF (.not. all(ieee_is_finite(htop_p(pft_start:pft_end))) .or. & + any(htop_p(pft_start:pft_end) < 0._r8)) RETURN + canopy_top = max(canopy_top, maxval(htop_p(pft_start:pft_end))) + ENDIF + ENDIF + ENDIF +#endif + + height_u = max(forc_hgt_u(patch), canopy_top + 1._r8) + height_t = max(forc_hgt_t(patch), canopy_top + 1._r8) + height_q = max(forc_hgt_q(patch), canopy_top + 1._r8) + ierr = 0 + END SUBROUTINE colm_mpas_get_patch_reference_heights + + SUBROUTINE colm_mpas_get_patch_10m_wind(patch, u10m, v10m, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: u10m + real(r8), intent(out) :: v10m + integer, intent(out) :: ierr + + real(r8) :: zldis + real(r8) :: obu + real(r8) :: effective_wind + real(r8) :: calculated_ustar + real(r8) :: fh2m + real(r8) :: fq2m + real(r8) :: fm10m + real(r8) :: calculated_fm + real(r8) :: calculated_fh + real(r8) :: calculated_fq + real(r8) :: reference_height_u + real(r8) :: reference_height_t + real(r8) :: reference_height_q + + ierr = 1 + u10m = spval + v10m = spval + IF (.not. allocated(forc_us) .or. .not. allocated(forc_vs) .or. & + .not. allocated(forc_hgt_u) .or. .not. allocated(forc_hgt_t) .or. & + .not. allocated(forc_hgt_q) .or. .not. allocated(forc_hpbl) .or. & + .not. allocated(displa) .or. .not. allocated(z0m) .or. & + .not. allocated(zol) .or. .not. allocated(ustar) .or. .not. allocated(fm)) RETURN + IF (patch < 1 .or. patch > size(forc_us) .or. patch > size(forc_vs) .or. & + patch > size(forc_hgt_u) .or. patch > size(forc_hgt_t) .or. & + patch > size(forc_hgt_q) .or. patch > size(forc_hpbl) .or. & + patch > size(displa) .or. patch > size(z0m) .or. patch > size(zol) .or. & + patch > size(ustar) .or. patch > size(fm)) RETURN + IF (.not. all(ieee_is_finite((/forc_us(patch), forc_vs(patch), forc_hgt_u(patch), & + forc_hgt_t(patch), forc_hgt_q(patch), forc_hpbl(patch), & + displa(patch), z0m(patch), zol(patch), ustar(patch), fm(patch)/)))) RETURN + + CALL colm_mpas_get_patch_reference_heights(patch, reference_height_u, reference_height_t, & + reference_height_q, ierr) + IF (ierr /= 0) RETURN + zldis = reference_height_u - displa(patch) + IF (zldis <= 0._r8 .or. reference_height_t <= displa(patch) .or. & + reference_height_q <= displa(patch) .or. z0m(patch) <= 0._r8 .or. & + ustar(patch) < 0._r8 .or. fm(patch) <= 0._r8) RETURN + IF (DEF_USE_CBL_HEIGHT .and. forc_hpbl(patch) < 0._r8) RETURN + + IF (abs(zol(patch)) > tiny(1._r8)) THEN + obu = zldis / zol(patch) + ELSE + obu = huge(1._r8) + ENDIF + effective_wind = ustar(patch) * fm(patch) / vonkar + IF (.not. ieee_is_finite(obu) .or. .not. ieee_is_finite(effective_wind) .or. & + effective_wind < 0._r8) RETURN + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(reference_height_u, reference_height_t, reference_height_q, & + displa(patch), z0m(patch), z0m(patch), z0m(patch), obu, & + effective_wind, forc_hpbl(patch), calculated_ustar, fh2m, fq2m, & + fm10m, calculated_fm, calculated_fh, calculated_fq) + ELSE + CALL moninobuk(reference_height_u, reference_height_t, reference_height_q, & + displa(patch), z0m(patch), z0m(patch), z0m(patch), obu, & + effective_wind, calculated_ustar, fh2m, fq2m, fm10m, & + calculated_fm, calculated_fh, calculated_fq) + ENDIF + IF (.not. ieee_is_finite(fm10m) .or. fm10m <= 0._r8) RETURN + + u10m = forc_us(patch) * fm10m / fm(patch) + v10m = forc_vs(patch) * fm10m / fm(patch) + IF (.not. ieee_is_finite(u10m) .or. .not. ieee_is_finite(v10m)) RETURN + ierr = 0 + END SUBROUTINE colm_mpas_get_patch_10m_wind SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ground_heat, runoff, & surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & - surface_humidity, emissivity, roughness, albedo, ierr) + u10m, v10m, & + surface_humidity, emissivity, roughness, albedo, friction_velocity, & + stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov, ierr) integer, intent(in) :: element real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: u10m, v10m real(r8), intent(out) :: surface_humidity real(r8), intent(out) :: emissivity, roughness, albedo + real(r8), intent(out) :: friction_velocity, stability_zeta, bulk_richardson + real(r8), intent(out) :: momentum_profile, heat_profile + real(r8), intent(out) :: moisture_profile, air_density + real(r8), intent(out) :: heat_exchange_velocity, moisture_exchange_velocity + real(r8), intent(out) :: momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov integer, intent(out) :: ierr integer :: patch @@ -1045,12 +1590,23 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, integer :: iend real(r8) :: wt real(r8) :: sumwt - real(r8) :: albedo_sum - real(r8) :: albedo_wt + real(r8) :: albedo_sum + real(r8) :: albedo_wt + real(r8) :: radiative_wt + real(r8) :: heat_conductance_sum + real(r8) :: moisture_conductance_sum + real(r8) :: humidity_conductance_sum + real(r8) :: exchange_wt(12) + real(r8) :: bad_value real(r8) :: patch_sensible, patch_latent, patch_evaporation, patch_ground_heat real(r8) :: patch_runoff, patch_surface_runoff, patch_subsurface_runoff - real(r8) :: patch_skin_temp, patch_t2m, patch_q2m, patch_surface_humidity + real(r8) :: patch_skin_temp, patch_t2m, patch_q2m, patch_u10m, patch_v10m, patch_surface_humidity real(r8) :: patch_emissivity, patch_roughness, patch_albedo + real(r8) :: patch_friction_velocity, patch_stability_zeta, patch_bulk_richardson + real(r8) :: patch_momentum_profile, patch_heat_profile + real(r8) :: patch_moisture_profile, patch_air_density + real(r8) :: patch_heat_exchange_velocity, patch_moisture_exchange_velocity + real(r8) :: patch_momentum_coefficient, patch_enthalpy_coefficient, patch_inverse_monin_obukhov ierr = 1 sensible = spval @@ -1063,19 +1619,40 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, skin_temp = spval t2m = spval q2m = spval + u10m = spval + v10m = spval surface_humidity = spval emissivity = spval roughness = spval albedo = spval + friction_velocity = spval + stability_zeta = spval + bulk_richardson = spval + momentum_profile = spval + heat_profile = spval + moisture_profile = spval + air_density = spval + heat_exchange_velocity = spval + moisture_exchange_velocity = spval + momentum_coefficient = spval + enthalpy_coefficient = spval + inverse_monin_obukhov = spval IF (.not. allocated(elm_patch%substt)) RETURN IF (.not. allocated(elm_patch%subend)) RETURN IF (.not. allocated(elm_patch%subfrc)) RETURN - IF (element < 1 .or. element > size(elm_patch%substt)) RETURN + IF (numpatch < 1) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN istt = elm_patch%substt(element) iend = elm_patch%subend(element) - IF (istt < 1 .or. iend < istt) RETURN + IF (istt < 1 .or. iend < istt .or. iend > numpatch .or. & + iend > size(elm_patch%subfrc)) RETURN sensible = 0._r8 latent = 0._r8 @@ -1087,11 +1664,31 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, skin_temp = 0._r8 t2m = 0._r8 q2m = 0._r8 + u10m = 0._r8 + v10m = 0._r8 surface_humidity = 0._r8 emissivity = 0._r8 roughness = 0._r8 + friction_velocity = 0._r8 + stability_zeta = 0._r8 + bulk_richardson = 0._r8 + momentum_profile = 0._r8 + heat_profile = 0._r8 + moisture_profile = 0._r8 + air_density = 0._r8 + heat_exchange_velocity = 0._r8 + moisture_exchange_velocity = 0._r8 + momentum_coefficient = 0._r8 + enthalpy_coefficient = 0._r8 + inverse_monin_obukhov = 0._r8 albedo_sum = 0._r8 albedo_wt = 0._r8 + radiative_wt = 0._r8 + heat_conductance_sum = 0._r8 + moisture_conductance_sum = 0._r8 + humidity_conductance_sum = 0._r8 + exchange_wt(:) = 0._r8 + bad_value = 0.5_r8 * abs(spval) sumwt = 0._r8 DO patch = istt, iend @@ -1103,15 +1700,41 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, IF (.not. patchmask(patch)) CYCLE ENDIF wt = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(wt)) RETURN IF (wt <= 0._r8) CYCLE CALL colm_mpas_get_surface(patch, patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & patch_runoff, patch_surface_runoff, patch_subsurface_runoff, & - patch_skin_temp, patch_t2m, patch_q2m, patch_surface_humidity, & - patch_emissivity, patch_roughness, patch_albedo, patch_ierr) + patch_skin_temp, patch_t2m, patch_q2m, patch_u10m, patch_v10m, & + patch_surface_humidity, & + patch_emissivity, patch_roughness, patch_albedo, patch_friction_velocity, & + patch_stability_zeta, patch_bulk_richardson, patch_momentum_profile, & + patch_heat_profile, patch_moisture_profile, patch_air_density, & + patch_heat_exchange_velocity, patch_moisture_exchange_velocity, & + patch_momentum_coefficient, patch_enthalpy_coefficient, & + patch_inverse_monin_obukhov, patch_ierr) IF (patch_ierr /= 0) THEN WRITE(*,*) 'Error: failed to retrieve CoLM2024 patch surface:', element, patch, patch_ierr RETURN ENDIF + IF (.not. ieee_is_finite(patch_skin_temp) .or. patch_skin_temp <= 0._r8 .or. & + abs(patch_skin_temp) >= bad_value) RETURN + IF (.not. all(ieee_is_finite((/patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & + patch_runoff, patch_surface_runoff, patch_subsurface_runoff, patch_t2m, & + patch_q2m, patch_u10m, patch_v10m, patch_surface_humidity, & + patch_emissivity, patch_roughness/)))) RETURN + IF (any(abs((/patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, patch_runoff, & + patch_surface_runoff, patch_subsurface_runoff, patch_t2m, patch_q2m, & + patch_u10m, patch_v10m, patch_surface_humidity, patch_emissivity, & + patch_roughness/)) >= bad_value)) RETURN + IF (patch_t2m <= 0._r8 .or. patch_q2m < 0._r8 .or. patch_q2m >= 1._r8 .or. & + patch_surface_humidity < 0._r8 .or. patch_surface_humidity >= 1._r8 .or. & + patch_emissivity < 0._r8 .or. patch_emissivity > 1._r8 .or. patch_roughness < 0._r8) RETURN + IF (.not. all(ieee_is_finite((/patch_air_density, patch_heat_exchange_velocity, & + patch_moisture_exchange_velocity/)))) RETURN + IF (any(abs((/patch_air_density, patch_heat_exchange_velocity, & + patch_moisture_exchange_velocity/)) >= bad_value)) RETURN + IF (patch_air_density <= 0._r8 .or. patch_heat_exchange_velocity < 0._r8 .or. & + patch_moisture_exchange_velocity < 0._r8) RETURN sumwt = sumwt + wt sensible = sensible + wt * patch_sensible @@ -1121,13 +1744,69 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, runoff = runoff + wt * patch_runoff surface_runoff = surface_runoff + wt * patch_surface_runoff subsurface_runoff = subsurface_runoff + wt * patch_subsurface_runoff - skin_temp = skin_temp + wt * patch_skin_temp + ! CoLM defines trad from outgoing longwave radiation, so preserve the + ! area-weighted radiative flux when reducing patches to one MPAS cell. + skin_temp = skin_temp + wt * patch_emissivity * patch_skin_temp**4 + radiative_wt = radiative_wt + wt * patch_emissivity t2m = t2m + wt * patch_t2m q2m = q2m + wt * patch_q2m + u10m = u10m + wt * patch_u10m + v10m = v10m + wt * patch_v10m surface_humidity = surface_humidity + wt * patch_surface_humidity emissivity = emissivity + wt * patch_emissivity - roughness = roughness + wt * patch_roughness - IF (patch_albedo > 0._r8 .and. patch_albedo < 1._r8) THEN + roughness = roughness + wt * patch_roughness + IF (abs(patch_friction_velocity) < bad_value .and. patch_friction_velocity >= 0._r8) THEN + ! Momentum stress is proportional to ustar**2, so reduce stress + ! rather than linearly averaging patch friction velocities. + friction_velocity = friction_velocity + wt * patch_friction_velocity**2 + exchange_wt(1) = exchange_wt(1) + wt + ENDIF + IF (abs(patch_stability_zeta) < bad_value) THEN + stability_zeta = stability_zeta + wt * patch_stability_zeta + exchange_wt(2) = exchange_wt(2) + wt + ENDIF + IF (abs(patch_bulk_richardson) < bad_value) THEN + bulk_richardson = bulk_richardson + wt * patch_bulk_richardson + exchange_wt(3) = exchange_wt(3) + wt + ENDIF + IF (abs(patch_momentum_profile) < bad_value .and. patch_momentum_profile > tiny(1._r8)) THEN + momentum_profile = momentum_profile + wt * patch_momentum_profile + exchange_wt(4) = exchange_wt(4) + wt + ENDIF + IF (abs(patch_heat_profile) < bad_value .and. patch_heat_profile > tiny(1._r8)) THEN + heat_profile = heat_profile + wt * patch_heat_profile + exchange_wt(5) = exchange_wt(5) + wt + ENDIF + IF (abs(patch_moisture_profile) < bad_value .and. patch_moisture_profile > tiny(1._r8)) THEN + moisture_profile = moisture_profile + wt * patch_moisture_profile + exchange_wt(6) = exchange_wt(6) + wt + ENDIF + air_density = air_density + wt * patch_air_density + exchange_wt(7) = exchange_wt(7) + wt + ! Return one cell-scale exchange velocity whose product with the + ! cell air density exactly preserves the patch-mean conductance. + heat_conductance_sum = heat_conductance_sum + & + wt * patch_air_density * patch_heat_exchange_velocity + moisture_conductance_sum = moisture_conductance_sum + & + wt * patch_air_density * patch_moisture_exchange_velocity + humidity_conductance_sum = humidity_conductance_sum + & + wt * patch_air_density * patch_moisture_exchange_velocity * & + patch_surface_humidity + exchange_wt(8) = exchange_wt(8) + wt + exchange_wt(9) = exchange_wt(9) + wt + IF (abs(patch_momentum_coefficient) < bad_value .and. patch_momentum_coefficient >= 0._r8) THEN + momentum_coefficient = momentum_coefficient + wt * patch_momentum_coefficient + exchange_wt(10) = exchange_wt(10) + wt + ENDIF + IF (abs(patch_enthalpy_coefficient) < bad_value .and. patch_enthalpy_coefficient >= 0._r8) THEN + enthalpy_coefficient = enthalpy_coefficient + wt * patch_enthalpy_coefficient + exchange_wt(11) = exchange_wt(11) + wt + ENDIF + IF (abs(patch_inverse_monin_obukhov) < bad_value) THEN + inverse_monin_obukhov = inverse_monin_obukhov + wt * patch_inverse_monin_obukhov + exchange_wt(12) = exchange_wt(12) + wt + ENDIF + IF (patch_albedo >= 0._r8 .and. patch_albedo <= 1._r8) THEN albedo_sum = albedo_sum + wt * patch_albedo albedo_wt = albedo_wt + wt ENDIF @@ -1144,10 +1823,24 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, skin_temp = spval t2m = spval q2m = spval + u10m = spval + v10m = spval surface_humidity = spval emissivity = spval - roughness = spval - RETURN + roughness = spval + friction_velocity = spval + stability_zeta = spval + bulk_richardson = spval + momentum_profile = spval + heat_profile = spval + moisture_profile = spval + air_density = spval + heat_exchange_velocity = spval + moisture_exchange_velocity = spval + momentum_coefficient = spval + enthalpy_coefficient = spval + inverse_monin_obukhov = spval + RETURN ENDIF sensible = sensible / sumwt @@ -1157,21 +1850,217 @@ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, runoff = runoff / sumwt surface_runoff = surface_runoff / sumwt subsurface_runoff = subsurface_runoff / sumwt - skin_temp = skin_temp / sumwt + IF (radiative_wt <= 0._r8) RETURN + skin_temp = (skin_temp / radiative_wt)**0.25_r8 t2m = t2m / sumwt q2m = q2m / sumwt - surface_humidity = surface_humidity / sumwt + u10m = u10m / sumwt + v10m = v10m / sumwt emissivity = emissivity / sumwt - roughness = roughness / sumwt + roughness = roughness / sumwt + IF (exchange_wt(1) > 0._r8) THEN + friction_velocity = sqrt(friction_velocity / exchange_wt(1)) + ELSE + friction_velocity = spval + ENDIF + IF (exchange_wt(2) > 0._r8) THEN + stability_zeta = stability_zeta / exchange_wt(2) + ELSE + stability_zeta = spval + ENDIF + IF (exchange_wt(3) > 0._r8) THEN + bulk_richardson = bulk_richardson / exchange_wt(3) + ELSE + bulk_richardson = spval + ENDIF + IF (exchange_wt(4) > 0._r8) THEN + momentum_profile = momentum_profile / exchange_wt(4) + ELSE + momentum_profile = spval + ENDIF + IF (exchange_wt(5) > 0._r8) THEN + heat_profile = heat_profile / exchange_wt(5) + ELSE + heat_profile = spval + ENDIF + IF (exchange_wt(6) > 0._r8) THEN + moisture_profile = moisture_profile / exchange_wt(6) + ELSE + moisture_profile = spval + ENDIF + IF (exchange_wt(7) > 0._r8) THEN + air_density = air_density / exchange_wt(7) + ELSE + air_density = spval + ENDIF + IF (exchange_wt(8) > 0._r8 .and. air_density > 0._r8) THEN + heat_exchange_velocity = heat_conductance_sum / (sumwt * air_density) + ELSE + heat_exchange_velocity = spval + ENDIF + IF (exchange_wt(9) > 0._r8 .and. air_density > 0._r8) THEN + moisture_exchange_velocity = moisture_conductance_sum / (sumwt * air_density) + ELSE + moisture_exchange_velocity = spval + ENDIF + IF (moisture_conductance_sum > tiny(1._r8)) THEN + surface_humidity = humidity_conductance_sum / moisture_conductance_sum + ELSE + surface_humidity = surface_humidity / sumwt + ENDIF + IF (.not. ieee_is_finite(surface_humidity) .or. surface_humidity < 0._r8 .or. & + surface_humidity >= 1._r8) RETURN + IF (exchange_wt(10) > 0._r8) THEN + momentum_coefficient = momentum_coefficient / exchange_wt(10) + ELSE + momentum_coefficient = spval + ENDIF + IF (exchange_wt(11) > 0._r8) THEN + enthalpy_coefficient = enthalpy_coefficient / exchange_wt(11) + ELSE + enthalpy_coefficient = spval + ENDIF + IF (exchange_wt(12) > 0._r8) THEN + inverse_monin_obukhov = inverse_monin_obukhov / exchange_wt(12) + ELSE + inverse_monin_obukhov = spval + ENDIF IF (albedo_wt > 0._r8) albedo = albedo_sum / albedo_wt ierr = 0 - END SUBROUTINE colm_mpas_get_element_surface + END SUBROUTINE colm_mpas_get_element_surface + + SUBROUTINE colm_mpas_get_element_boundary_state(element, skin_temp, surface_humidity, & + emissivity, roughness, albedo, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: skin_temp, surface_humidity, emissivity, roughness, albedo + integer, intent(out) :: ierr + + integer :: patch + integer :: istt + integer :: iend + real(r8) :: wt + real(r8) :: sumwt + real(r8) :: radiative_wt + real(r8) :: patch_humidity + real(r8) :: patch_albedo + real(r8) :: bad_value + + ierr = 1 + skin_temp = spval + surface_humidity = spval + emissivity = spval + roughness = spval + albedo = spval + + IF (.not. allocated(elm_patch%substt) .or. .not. allocated(elm_patch%subend) .or. & + .not. allocated(elm_patch%subfrc)) RETURN + IF (.not. allocated(trad) .or. .not. allocated(qref) .or. .not. allocated(emis) .or. & + .not. allocated(z0m) .or. .not. allocated(alb)) RETURN + IF (numpatch < 1 .or. size(elm_patch%subfrc) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt .or. iend > numpatch) RETURN + + skin_temp = 0._r8 + surface_humidity = 0._r8 + emissivity = 0._r8 + roughness = 0._r8 + albedo = 0._r8 + sumwt = 0._r8 + radiative_wt = 0._r8 + bad_value = 0.5_r8 * abs(spval) + + DO patch = istt, iend + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(wt) .or. wt < 0._r8) RETURN + IF (wt <= 0._r8) CYCLE + + patch_humidity = qref(patch) + IF (allocated(qsfc)) THEN + IF (patch <= size(qsfc)) THEN + IF (ieee_is_finite(qsfc(patch)) .and. abs(qsfc(patch)) < bad_value .and. & + qsfc(patch) >= 0._r8 .and. qsfc(patch) < 1._r8) patch_humidity = qsfc(patch) + ENDIF + ENDIF + patch_albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) + + IF (.not. all(ieee_is_finite((/trad(patch), patch_humidity, emis(patch), z0m(patch), & + patch_albedo/)))) RETURN + IF (any(abs((/trad(patch), patch_humidity, emis(patch), z0m(patch), patch_albedo/)) >= & + bad_value)) RETURN + IF (trad(patch) <= 0._r8 .or. patch_humidity < 0._r8 .or. patch_humidity >= 1._r8 .or. & + emis(patch) <= 0._r8 .or. emis(patch) > 1._r8 .or. z0m(patch) < 0._r8 .or. & + patch_albedo < 0._r8 .or. patch_albedo > 1._r8) RETURN + + skin_temp = skin_temp + wt * emis(patch) * trad(patch)**4 + radiative_wt = radiative_wt + wt * emis(patch) + surface_humidity = surface_humidity + wt * patch_humidity + emissivity = emissivity + wt * emis(patch) + roughness = roughness + wt * z0m(patch) + albedo = albedo + wt * patch_albedo + sumwt = sumwt + wt + ENDDO - SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_depth, snow_cover, & - leaf_area_index, soil_liquid, soil_moisture, soil_temperature, ierr) + IF (sumwt <= 0._r8 .or. radiative_wt <= 0._r8) RETURN + skin_temp = (skin_temp / radiative_wt)**0.25_r8 + surface_humidity = surface_humidity / sumwt + emissivity = emissivity / sumwt + roughness = roughness / sumwt + albedo = albedo / sumwt + ierr = 0 + END SUBROUTINE colm_mpas_get_element_boundary_state + + SUBROUTINE colm_mpas_get_element_river_state(element, water_depth, velocity, discharge, ierr) +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeTimeVars, only: river_water_depth_elm, river_velocity_elm, river_discharge_elm +#endif + integer, intent(in) :: element + real(r8), intent(out) :: water_depth + real(r8), intent(out) :: velocity + real(r8), intent(out) :: discharge + integer, intent(out) :: ierr + + real(r8) :: bad_value + + water_depth = spval + velocity = spval + discharge = spval + ierr = 1 + IF (.not. colm_mpas_initialized) RETURN + +#ifdef GridRiverLakeFlow + IF (.not. allocated(river_water_depth_elm) .or. .not. allocated(river_velocity_elm) .or. & + .not. allocated(river_discharge_elm)) RETURN + IF (element < 1 .or. element > size(river_water_depth_elm) .or. & + element > size(river_velocity_elm) .or. element > size(river_discharge_elm)) RETURN + + water_depth = river_water_depth_elm(element) + velocity = river_velocity_elm(element) + discharge = river_discharge_elm(element) + bad_value = 0.5_r8 * abs(spval) + IF (.not. all(ieee_is_finite((/water_depth, velocity, discharge/)))) RETURN + IF (abs(water_depth) < bad_value .and. water_depth < 0._r8) RETURN +#endif + + ierr = 0 + END SUBROUTINE colm_mpas_get_element_river_state + + SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_depth, snow_cover, & + leaf_area_index, vegetation_fraction, soil_availability, ground_temperature, & + soil_liquid, soil_ice, soil_moisture, soil_temperature, ierr) integer, intent(in) :: element real(r8), intent(out) :: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index - real(r8), intent(out) :: soil_liquid(:), soil_moisture(:), soil_temperature(:) + real(r8), intent(out) :: vegetation_fraction, soil_availability, ground_temperature + real(r8), intent(out) :: soil_liquid(:), soil_ice(:), soil_moisture(:), soil_temperature(:) integer, intent(out) :: ierr integer :: patch @@ -1181,15 +2070,23 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d integer :: nlev real(r8) :: wt real(r8) :: sumwt + real(r8) :: vegetation_wt + real(r8) :: availability_wt real(r8) :: bad_value + real(r8), parameter :: negative_tolerance = 1.e-10_r8 real(r8) :: patch_canopy_water real(r8) :: patch_snow_water real(r8) :: patch_snow_depth real(r8) :: patch_snow_cover real(r8) :: patch_lai + real(r8) :: patch_ground_temperature + real(r8) :: patch_fveg + real(r8) :: patch_availability real(r8) :: patch_liquid + real(r8) :: patch_ice real(r8) :: patch_moisture - real(r8) :: soil_wt(size(soil_liquid)) + real(r8) :: soil_wt(nl_soil) + integer :: navailability ierr = 1 canopy_water = spval @@ -1197,12 +2094,19 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d snow_depth = spval snow_cover = spval leaf_area_index = spval + vegetation_fraction = spval + soil_availability = spval + ground_temperature = spval soil_liquid(:) = spval + soil_ice(:) = spval soil_moisture(:) = spval soil_temperature(:) = spval - nlev = min(size(soil_liquid), size(soil_moisture), size(soil_temperature), nl_soil) - IF (nlev < 1) RETURN + IF (size(soil_liquid) < nl_soil) RETURN + IF (size(soil_ice) < nl_soil) RETURN + IF (size(soil_moisture) < nl_soil) RETURN + IF (size(soil_temperature) < nl_soil) RETURN + nlev = nl_soil IF (.not. allocated(elm_patch%substt)) RETURN IF (.not. allocated(elm_patch%subend)) RETURN IF (.not. allocated(elm_patch%subfrc)) RETURN @@ -1211,14 +2115,29 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d IF (.not. allocated(snowdp)) RETURN IF (.not. allocated(fsno)) RETURN IF (.not. allocated(lai)) RETURN + IF (.not. allocated(t_grnd)) RETURN IF (.not. allocated(t_soisno)) RETURN IF (.not. allocated(wliq_soisno)) RETURN IF (.not. allocated(wice_soisno)) RETURN - IF (element < 1 .or. element > size(elm_patch%substt)) RETURN + IF (numpatch < 1) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (size(ldew) < numpatch .or. size(scv) < numpatch .or. size(snowdp) < numpatch .or. & + size(fsno) < numpatch .or. size(lai) < numpatch .or. size(t_grnd) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (lbound(t_soisno, 1) > 1 .or. ubound(t_soisno, 1) < nl_soil) RETURN + IF (lbound(wliq_soisno, 1) > 1 .or. ubound(wliq_soisno, 1) < nl_soil) RETURN + IF (lbound(wice_soisno, 1) > 1 .or. ubound(wice_soisno, 1) < nl_soil) RETURN + IF (lbound(t_soisno, 2) > 1 .or. ubound(t_soisno, 2) < numpatch) RETURN + IF (lbound(wliq_soisno, 2) > 1 .or. ubound(wliq_soisno, 2) < numpatch) RETURN + IF (lbound(wice_soisno, 2) > 1 .or. ubound(wice_soisno, 2) < numpatch) RETURN + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN istt = elm_patch%substt(element) iend = elm_patch%subend(element) - IF (istt < 1 .or. iend < istt) RETURN + IF (istt < 1 .or. iend < istt .or. iend > numpatch .or. iend > size(elm_patch%subfrc)) RETURN bad_value = 0.5_r8 * abs(spval) canopy_water = 0._r8 @@ -1226,11 +2145,17 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d snow_depth = 0._r8 snow_cover = 0._r8 leaf_area_index = 0._r8 + vegetation_fraction = 0._r8 + soil_availability = 0._r8 + ground_temperature = 0._r8 soil_liquid(:) = 0._r8 + soil_ice(:) = 0._r8 soil_moisture(:) = 0._r8 soil_temperature(:) = 0._r8 soil_wt(:) = 0._r8 sumwt = 0._r8 + vegetation_wt = 0._r8 + availability_wt = 0._r8 DO patch = istt, iend IF (patch < 1 .or. patch > numpatch) THEN @@ -1241,18 +2166,22 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d IF (.not. patchmask(patch)) CYCLE ENDIF wt = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(wt)) RETURN IF (wt <= 0._r8) CYCLE patch_canopy_water = ldew(patch) - IF (abs(patch_canopy_water) >= bad_value) patch_canopy_water = 0._r8 patch_snow_water = scv(patch) - IF (abs(patch_snow_water) >= bad_value) patch_snow_water = 0._r8 patch_snow_depth = snowdp(patch) - IF (abs(patch_snow_depth) >= bad_value) patch_snow_depth = 0._r8 patch_snow_cover = fsno(patch) - IF (abs(patch_snow_cover) >= bad_value) patch_snow_cover = 0._r8 patch_lai = lai(patch) - IF (abs(patch_lai) >= bad_value) patch_lai = 0._r8 + patch_ground_temperature = t_grnd(patch) + IF (.not. all(ieee_is_finite((/patch_canopy_water, patch_snow_water, patch_snow_depth, & + patch_snow_cover, patch_lai, patch_ground_temperature/)))) RETURN + IF (any(abs((/patch_canopy_water, patch_snow_water, patch_snow_depth, patch_snow_cover, & + patch_lai, patch_ground_temperature/)) >= bad_value)) RETURN + IF (patch_canopy_water < -negative_tolerance .or. patch_snow_water < -negative_tolerance .or. & + patch_snow_depth < -negative_tolerance .or. patch_snow_cover < -negative_tolerance .or. & + patch_snow_cover > 1._r8 + negative_tolerance .or. patch_lai < -negative_tolerance) RETURN sumwt = sumwt + wt canopy_water = canopy_water + wt * max(0._r8, patch_canopy_water) @@ -1260,18 +2189,56 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d snow_depth = snow_depth + wt * max(0._r8, patch_snow_depth) snow_cover = snow_cover + wt * max(0._r8, min(1._r8, patch_snow_cover)) leaf_area_index = leaf_area_index + wt * max(0._r8, patch_lai) + ground_temperature = ground_temperature + wt * patch_ground_temperature + + IF (allocated(fveg)) THEN + IF (patch <= size(fveg)) THEN + patch_fveg = fveg(patch) + IF (abs(patch_fveg) < bad_value) THEN + vegetation_fraction = vegetation_fraction + wt * max(0._r8, min(1._r8, patch_fveg)) + vegetation_wt = vegetation_wt + wt + ENDIF + ENDIF + ENDIF + + patch_availability = 0._r8 + navailability = 0 + IF (allocated(rstfacsun_out)) THEN + IF (patch <= size(rstfacsun_out)) THEN + IF (abs(rstfacsun_out(patch)) < bad_value) THEN + patch_availability = patch_availability + max(0._r8, min(1._r8, rstfacsun_out(patch))) + navailability = navailability + 1 + ENDIF + ENDIF + ENDIF + IF (allocated(rstfacsha_out)) THEN + IF (patch <= size(rstfacsha_out)) THEN + IF (abs(rstfacsha_out(patch)) < bad_value) THEN + patch_availability = patch_availability + max(0._r8, min(1._r8, rstfacsha_out(patch))) + navailability = navailability + 1 + ENDIF + ENDIF + ENDIF + IF (navailability > 0) THEN + soil_availability = soil_availability + wt * patch_availability / real(navailability, r8) + availability_wt = availability_wt + wt + ENDIF DO n = 1, nlev - IF (n < lbound(t_soisno, 1) .or. n > ubound(t_soisno, 1)) CYCLE - IF (dz_soi(n) <= 0._r8) CYCLE - IF (abs(t_soisno(n, patch)) >= bad_value) CYCLE - IF (abs(wliq_soisno(n, patch)) >= bad_value) CYCLE - IF (abs(wice_soisno(n, patch)) >= bad_value) CYCLE - - patch_liquid = max(0._r8, wliq_soisno(n, patch) / (1000._r8 * dz_soi(n))) - patch_moisture = max(0._r8, (wliq_soisno(n, patch) + wice_soisno(n, patch)) / (1000._r8 * dz_soi(n))) - soil_liquid(n) = soil_liquid(n) + wt * min(1._r8, patch_liquid) - soil_moisture(n) = soil_moisture(n) + wt * min(1._r8, patch_moisture) + IF (.not. ieee_is_finite(dz_soi(n)) .or. dz_soi(n) <= 0._r8) RETURN + IF (.not. all(ieee_is_finite((/t_soisno(n, patch), wliq_soisno(n, patch), & + wice_soisno(n, patch)/)))) RETURN + IF (any(abs((/t_soisno(n, patch), wliq_soisno(n, patch), & + wice_soisno(n, patch)/)) >= bad_value)) RETURN + IF (wliq_soisno(n, patch) < -negative_tolerance .or. & + wice_soisno(n, patch) < -negative_tolerance) RETURN + + patch_liquid = max(0._r8, wliq_soisno(n, patch) / (denh2o * dz_soi(n))) + patch_ice = max(0._r8, wice_soisno(n, patch) / (denice * dz_soi(n))) + patch_moisture = patch_liquid + patch_ice + soil_liquid(n) = soil_liquid(n) + wt * patch_liquid + soil_ice(n) = soil_ice(n) + wt * patch_ice + soil_moisture(n) = soil_moisture(n) + wt * patch_moisture soil_temperature(n) = soil_temperature(n) + wt * t_soisno(n, patch) soil_wt(n) = soil_wt(n) + wt ENDDO @@ -1283,7 +2250,11 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d snow_depth = spval snow_cover = spval leaf_area_index = spval + vegetation_fraction = spval + soil_availability = spval + ground_temperature = spval soil_liquid(:) = spval + soil_ice(:) = spval soil_moisture(:) = spval soil_temperature(:) = spval RETURN @@ -1294,17 +2265,24 @@ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_d snow_depth = snow_depth / sumwt snow_cover = snow_cover / sumwt leaf_area_index = leaf_area_index / sumwt + ground_temperature = ground_temperature / sumwt + IF (vegetation_wt > 0._r8) THEN + vegetation_fraction = vegetation_fraction / vegetation_wt + ELSE + vegetation_fraction = spval + ENDIF + IF (availability_wt > 0._r8) THEN + soil_availability = soil_availability / availability_wt + ELSE + soil_availability = spval + ENDIF + IF (any(soil_wt(1:nlev) <= 0._r8)) RETURN DO n = 1, nlev - IF (soil_wt(n) > 0._r8) THEN - soil_liquid(n) = soil_liquid(n) / soil_wt(n) - soil_moisture(n) = soil_moisture(n) / soil_wt(n) - soil_temperature(n) = soil_temperature(n) / soil_wt(n) - ELSE - soil_liquid(n) = spval - soil_moisture(n) = spval - soil_temperature(n) = spval - ENDIF + soil_liquid(n) = soil_liquid(n) / soil_wt(n) + soil_ice(n) = soil_ice(n) / soil_wt(n) + soil_moisture(n) = soil_moisture(n) / soil_wt(n) + soil_temperature(n) = soil_temperature(n) / soil_wt(n) ENDDO ierr = 0 diff --git a/src/core_atmosphere/physics/physics_colm2024/include/define.h b/src/core_atmosphere/physics/physics_colm2024/include/define.h index d3f5da4b34..52c941b636 100644 --- a/src/core_atmosphere/physics/physics_colm2024/include/define.h +++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h @@ -1,8 +1,8 @@ ! 1. Spatial structure: ! Select one of the following options. -#define GRIDBASED +#undef GRIDBASED #undef CATCHMENT -#undef UNSTRUCTURED +#define UNSTRUCTURED #undef SinglePoint ! 2. Land subgrid type classification: @@ -23,16 +23,13 @@ #undef LULC_IGBP_PC #endif -! 3. If defined, debug information is output. -#define CoLMDEBUG -! 3.1 If defined, range of variables is checked. -#define RangeCheck -! 3.1 If defined, surface data in vector is mapped to gridded data for checking. +! 3. Embedded diagnostics are written through MPAS streams. +#undef CoLMDEBUG +! If defined, surface data in vector is mapped to gridded data for checking. #undef SrfdataDiag -! 4. CoLM uses MPI collectives through MPAS-owned communicators. The legacy -! CoLM process-pool decomposition is disabled in MOD_SPMD_Task. -#define USEMPI +! 4. CoLM uses MPI exclusively through the MPAS-owned communicator. +#define MPAS_MPI ! 5. Hydrological process options. ! 5.1 Two soil hydraulic models can be used. @@ -94,22 +91,8 @@ ! 12. Hyperspectral scheme. #define HYPERSPECTRAL -! MPAS embeds CoLM as a local land-surface physics package on each MPAS rank. -! Reusing the legacy CoLM process split inside MPAS leaves some -! ranks without patch forcing/flux arrays, so the embedded library keeps CoLM -! land state on MPAS-owned cells. MPAS also supplies broadband shortwave forcing. +! MPAS embeds CoLM as a land-surface physics package on every MPAS rank. +! CoLM keeps patch/PFT state below MPAS-owned cells and communicates through the +! MPAS communicator. MPAS supplies CoLM VIS/NIR direct/diffuse forcing. #define MPAS_EMBEDDED_COLM -#ifdef MPAS_EMBEDDED_COLM -#ifndef USEMPI -#define USEMPI -#endif #undef HYPERSPECTRAL -#undef CoLMDEBUG -! CoLM range diagnostics still assume the standalone role split. -#undef RangeCheck -#endif - -#undef COLM_PARALLEL -#if defined(USEMPI) -#define COLM_PARALLEL -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 index df66ec3151..217d078ae9 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 @@ -44,7 +44,7 @@ MODULE MOD_BGC_CNBalanceCheck m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac USE MOD_BGC_Vars_1DFluxes, only: & @@ -151,7 +151,7 @@ SUBROUTINE CBalanceCheck(i,ps,pe,nl_soil,dz_soi,deltim,dlat,dlon) + gap_deadstem_to_litter + gap_livecroot_to_litter + gap_deadcroot_to_litter + gap_gresp_to_litter IF(abs(col_errcb) > cerror) THEN - write(*,*)'column cbalance error = ', col_errcb, i, p_iam_glb + write(*,*)'column cbalance error = ', col_errcb, i, mpas_rank write(*,*)'Latdeg,Londeg=' , dlat, dlon write(*,*)'begcb = ',col_begcb(i) write(*,*)'endcb = ',col_endcb(i) @@ -186,11 +186,7 @@ SUBROUTINE CBalanceCheck(i,ps,pe,nl_soil,dz_soi,deltim,dlat,dlon) write(*,*)'wood_harvestc = ',wood_harvestc(i)*deltim write(*,*)'grainc_to_cropprodc = ',grainc_to_cropprodc(i)*deltim, grainc_to_food_p(ps)*deltim write(*,*)'-1*som_c_leached = ',som_c_leached(i)*deltim -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - CALL abort -#endif + CALL CoLM_stop('BGC carbon balance check failed.') ENDIF END SUBROUTINE CBalanceCheck @@ -237,7 +233,7 @@ SUBROUTINE NBalanceCheck(i,ps,pe,deltim,dlat,dlon) col_errnb =(col_ninputs - col_noutputs)*deltim - (col_endnb(i) - col_begnb(i)) IF (abs(col_errnb) > nerror) THEN ! - write(*,*)'column nbalance error = ',col_errnb, i, p_iam_glb + write(*,*)'column nbalance error = ',col_errnb, i, mpas_rank write(*,*)'Latdeg,Londeg = ',dlat, dlon write(*,*)'begnb = ',col_begnb(i) write(*,*)'endnb = ',col_endnb(i) @@ -260,11 +256,7 @@ SUBROUTINE NBalanceCheck(i,ps,pe,deltim,dlat,dlon) sminn_leached(i)*deltim,denit(i)*deltim,fire_nloss(i)*deltim,& (wood_harvestn(i)+grainn_to_cropprodn(i))*deltim, - som_n_leached(i) ENDIF -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - CALL abort -#endif + CALL CoLM_stop('BGC nitrogen balance check failed.') ENDIF END SUBROUTINE NBalanceCheck diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 index f4cd21b975..ff4c5f506e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 @@ -30,6 +30,7 @@ MODULE MOD_BGC_CNSASU ! USE accumulated transfer fluxes to calculate the matrix. USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix USE MOD_BGC_Vars_TimeInvariants, only: & i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3, floating_cn_ratio @@ -995,7 +996,7 @@ SUBROUTINE inverse(a,c,n) DO k=1,n IF ( a(k,k) == 0.0_r8 )THEN - CALL abort + CALL CoLM_stop('BGC SASU matrix is singular.') ENDIF ENDDO ! diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 index 0d612d9eb7..78227a6b84 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 @@ -126,7 +126,7 @@ MODULE MOD_BGC_CNSummary USE MOD_Vars_TimeInvariants, only: patchclass USE MOD_Vars_Global, only: spval - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE @@ -832,8 +832,8 @@ SUBROUTINE cnveg_carbonflux_summary(i,ps,pe,deltim) #ifdef CROP IF(patchclass(i) .eq. 12)THEN IF(ps .ne. pe)THEN - write(*,*) 'Error: crop patch CONTAINS multiple pfts:',p_iam_glb,'i=',i,'ps',ps,'does not equal to pe',pe - CALL abort + write(*,*) 'Error: crop patch CONTAINS multiple pfts:',mpas_rank,'i=',i,'ps',ps,'does not equal to pe',pe + CALL CoLM_stop('A crop patch contains more than one PFT.') ELSE cropprod1c_loss (i) = cropprod1c_loss_p(ps) grainc_to_cropprodc (i) = grainc_to_food_p (ps) @@ -902,8 +902,8 @@ SUBROUTINE cnveg_nitrogenflux_summary(i,ps,pe) #ifdef CROP IF(patchclass(i) .eq. 12)THEN IF(ps .ne. pe)THEN - write(*,*) 'Error: crop patch contains multiple pfts:',p_iam_glb,'i=',i,'ps',ps,'does not equal to pe',pe - CALL abort + write(*,*) 'Error: crop patch contains multiple pfts:',mpas_rank,'i=',i,'ps',ps,'does not equal to pe',pe + CALL CoLM_stop('A crop patch contains more than one PFT.') ELSE grainn_to_cropprodn (i) = grainn_to_food_p (ps) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 index aa07e6c7c3..9c60ecb83f 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 @@ -44,7 +44,7 @@ MODULE MOD_BGC_Soil_BiogeochemNStateUpdate1 sminn_to_plant_fun_vr , sminn_to_plant_fun_nh4_vr, sminn_to_plant_fun_no3_vr, & sminn_to_denit_excess_vr, f_nit_vr , f_denit_vr , soyfixn_to_sminn, & ndep_to_sminn , ffix_to_sminn , nfix_to_sminn , fert_to_sminn - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 index b255dfe366..12eccccb66 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 @@ -16,6 +16,7 @@ MODULE MOD_BGC_Soil_BiogeochemVerticalProfile USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop USE MOD_Const_PFT, only: rootfr_p USE MOD_BGC_Vars_TimeVariables, only: & nfixation_prof, ndep_prof, altmax_lastyear_indx, w_scalar @@ -209,7 +210,7 @@ SUBROUTINE SoilBiogeochemVerticalProfile(i,ps,pe,nl_soil,nl_soil_full,nbedrock,z write(*,*) 'p, itype(p) : ', i, pftclass(ps:pe) write(*,*) 'cinput_rootfr(p,:): ', cinput_rootfr_p(:,ps:pe) write(*,*) 'ERROR: _prof_sum-1>delta' - CALL abort() + CALL CoLM_stop('BGC soil input profiles do not sum to one.') ENDIF DO m = ps , pe @@ -227,7 +228,7 @@ SUBROUTINE SoilBiogeochemVerticalProfile(i,ps,pe,nl_soil,nl_soil_full,nbedrock,z ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) THEN write(*,*) 'profile sums: ', froot_prof_sum, croot_prof_sum, leaf_prof_sum, stem_prof_sum write(*,*) ' ERROR: sum-1 > delta' - CALL abort + CALL CoLM_stop('BGC vegetation input profiles do not sum to one.') ENDIF ENDDO diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 index ae192eb1c3..5c6e3d4744 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 @@ -196,12 +196,12 @@ SUBROUTINE allocate_1D_BGCFluxes ! -------------------------------------------------------------------- USE MOD_Precision USE MOD_Vars_Global - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -377,10 +377,10 @@ SUBROUTINE deallocate_1D_BGCFluxes () ! -------------------------------------------------------------------- ! deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -557,14 +557,14 @@ SUBROUTINE set_1D_BGCFluxes(Values, Nan) ! -------------------------------------------------------------------- USE MOD_Precision USE MOD_Vars_Global - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch IMPLICIT NONE real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 index 916ac32018..d32bee4b9a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 @@ -339,11 +339,11 @@ SUBROUTINE allocate_1D_BGCPFTFluxes ! -------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN ! bgc variables @@ -662,10 +662,10 @@ SUBROUTINE deallocate_1D_BGCPFTFluxes ! -------------------------------------------------------------------- ! deallocates memory for CoLM PFT 1d [numpft] variables ! -------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN ! bgc variables @@ -985,13 +985,13 @@ SUBROUTINE set_1D_BGCPFTFluxes(Values, Nan) ! -------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT IMPLICIT NONE real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN ! bgc variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 index b91c4e7301..5cfb5c7ee4 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 @@ -409,12 +409,12 @@ SUBROUTINE allocate_BGCPFTimeVariables () ! Allocates memory for CoLM 1d [numpft] variables ! ------------------------------------------------------ USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN ! bgc variables allocate (leafc_p (numpft)); leafc_p (:) = spval @@ -1946,10 +1946,10 @@ SUBROUTINE deallocate_BGCPFTimeVariables () ! -------------------------------------------------- ! Deallocates memory for CoLM 1d [numpft/numpc] variables ! -------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN ! bgc variables deallocate (leafc_p ) @@ -2323,7 +2323,7 @@ END SUBROUTINE deallocate_BGCPFTimeVariables SUBROUTINE check_BGCPFTimeVariables USE MOD_RangeCheck - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE ! bgc variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 index 6d9d9605a9..2a892bc798 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 @@ -143,11 +143,11 @@ SUBROUTINE allocate_BGCTimeInvariants () USE MOD_Precision USE MOD_Vars_Global, only: nl_soil, ndecomp_transitions, ndecomp_pools, spval_i4, spval - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN ! bgc variables @@ -180,7 +180,7 @@ SUBROUTINE READ_BGCTimeInvariants (file_restart) !======================================================================= USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFVector USE MOD_NetCDFSerial #ifdef RangeCheck @@ -298,8 +298,8 @@ SUBROUTINE READ_BGCTimeInvariants (file_restart) CALL check_BGCTimeInvariants () #endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) #endif END SUBROUTINE READ_BGCTimeInvariants @@ -312,7 +312,7 @@ SUBROUTINE WRITE_BGCTimeInvariants (file_restart) !======================================================================= USE MOD_Namelist, only: DEF_REST_CompressLevel - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_NetCDFVector USE MOD_LandPatch @@ -342,11 +342,11 @@ SUBROUTINE WRITE_BGCTimeInvariants (file_restart) ! CALL ncio_write_vector (file_restart, 'peatf_lf ', 'patch', landpatch, peatf_lf , compress) CALL ncio_write_vector (file_restart, 'rice2pdt ', 'patch', landpatch, rice2pdt , compress) -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN #if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) CALL ncio_create_file (file_restart) @@ -456,7 +456,7 @@ END SUBROUTINE WRITE_BGCTimeInvariants SUBROUTINE deallocate_BGCTimeInvariants () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE @@ -464,7 +464,7 @@ SUBROUTINE deallocate_BGCTimeInvariants () ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -493,7 +493,7 @@ END SUBROUTINE deallocate_BGCTimeInvariants !--------------------------------------- SUBROUTINE check_BGCTimeInvariants () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_RangeCheck IMPLICIT NONE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 index ec3ee02169..c39e98b7a5 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 @@ -318,12 +318,12 @@ SUBROUTINE allocate_BGCTimeVariables USE MOD_Precision USE MOD_Vars_Global - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -611,7 +611,7 @@ END SUBROUTINE allocate_BGCTimeVariables SUBROUTINE deallocate_BGCTimeVariables () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE @@ -619,7 +619,7 @@ SUBROUTINE deallocate_BGCTimeVariables () ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -1086,7 +1086,7 @@ SUBROUTINE READ_BGCTimeVariables (file_restart) !======================================================================= USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFVector #ifdef RangeCheck USE MOD_RangeCheck @@ -1240,7 +1240,7 @@ END SUBROUTINE READ_BGCTimeVariables #ifdef RangeCheck SUBROUTINE check_BGCTimeVariables () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_RangeCheck USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_SASU, DEF_USE_DiagMatrix diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 index 8513dde698..6be0468d15 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 @@ -131,7 +131,7 @@ MODULE MOD_BGC_Veg_CNPhenology USE MOD_Precision USE MOD_Namelist, only: DEF_USE_FERT USE MOD_BGC_Daylength, only: daylength - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 index 8cb4a8bba1..db9902d382 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 @@ -23,9 +23,7 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) USE MOD_Vars_1DFluxes USE MOD_LandPatch, only: numpatch,landpatch USE MOD_LandUrban, only: patch2urban - USE MOD_Namelist, only: DEF_forcing, DEF_URBAN_RUN - USE MOD_Forcing, only: forcmask_pch - USE omp_lib + USE MOD_Namelist, only: DEF_URBAN_RUN #ifdef HYPERSPECTRAL USE MOD_HighRes_Parameters #endif @@ -46,19 +44,12 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) ! ====================================================================== -#ifdef OPENMP -!$OMP PARALLEL DO NUM_THREADS(OPENMP) & +!$OMP PARALLEL DO & !$OMP PRIVATE(i, m, u, k, steps_in_one_deltim, deltim_phy) & !$OMP SCHEDULE(STATIC, 1) -#endif DO i = 1, numpatch - ! Apply forcing mask - IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask_pch(i)) CYCLE - ENDIF - ! Apply patch mask, but still run virtual 2m WMO patch (patch ipxstt=-1) IF (DEF_Output_2mWMO) THEN IF (.not. patchmask(i) .and. (landpatch%ipxstt(i)>0) ) CYCLE @@ -347,9 +338,7 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) #endif ENDDO -#ifdef OPENMP !$OMP END PARALLEL DO -#endif END SUBROUTINE CoLMDRIVER ! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 index 2b2ca31314..ba24a6f47f 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 @@ -194,7 +194,7 @@ SUBROUTINE CoLMMAIN ( & #ifdef CROP USE MOD_Irrigation, only: CalIrrigationApplicationFluxes #endif - USE MOD_SPMD_Task + USE MOD_MPAS_MPI #ifdef EXTERNAL_LAKE USE MOD_Lake_Driver, only: external_lake diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 deleted file mode 100644 index f4280b27fe..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90 +++ /dev/null @@ -1,143 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_Const -!----------------------------------------------------------------------- -! DESCRIPTION: -! 1. Define constants (do not rely on satellite parameters) used in RTM. -! 2. Define parameters (IGBP) used in RTM. -! -! REFERENCES: -! [1] L-band Microwave Emission of the Biosphere (L-MEB) Model: Description -! and calibration against experimental data sets over crop fields. -! -! [2] Wigneron, J. P., Jackson, T. J., O'neill, P., De Lannoy, G., de Rosnay, P., Walker, -! J. P., ... & Kerr, Y. (2017). Modelling the passive microwave signature from land surfaces: -! A review of recent results and application to the L-band SMOS & SMAP soil moisture retrieval algorithms. -! Remote Sensing of Environment, 192, 238-262. -! -! AUTHOR: -! Lu Li, 12/2024: Initial version -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global, only: pi, N_land_classification - - IMPLICIT NONE - SAVE - - ! Constant variables - real(r8), parameter :: C = 2.998e8 ! speed of light (m/s) - real(r8), parameter :: mu0 = 4.*pi*1e-7 ! vacuum permeability (H/m) - real(r8), parameter :: eps0 = 8.854e-12 ! vacuum permittivity (Klein and Swift 1977) [Farads/meter] - real(r8), parameter :: z0 = sqrt(mu0/eps0) ! impendace of free space (Ohm) - real(r8), parameter :: eps_w_inf = 4.9 ! dielectric constant at infinite frequency (Stogryn 1971), - real(r8), parameter :: eps_0 = 8.854e-12 ! dielectric constant of free space (Klein and Swift 1977) [Farads/meter] - real(r8), parameter :: rho_soil = 2.66 ! soil specific density (g/cm3) - real(r8), parameter :: f0w = 9. ! relaxation frequency of liquid water (GHz) - real(r8), parameter :: rgh_surf = 2.2 ! soil surface roughness (cm) - complex(r8), parameter :: jj = (0., 1.) ! imaginary unit for complex number - - -#ifdef LULC_IGBP - - ! MODIS IGBP Land Use/Land Cover System Legend - !--------------------------- - ! 0 Ocean ! 海洋 - ! 1 Evergreen Needleleaf Forests ! 常绿针叶林 - ! 2 Evergreen Broadleaf Forests ! 常绿阔叶林 - ! 3 Deciduous Needleleaf Forests ! 落叶针叶林 - ! 4 Deciduous Broadleaf Forests ! 落叶阔叶林 - ! 5 Mixed Forests ! 混交林 - ! 6 Closed Shrublands ! 密闭灌丛 - ! 7 Open Shrublands ! 稀疏灌丛 - ! 8 Woody Savannas ! 木本稀树草原 - ! 9 Savannas ! 稀树草原 - !10 Grasslands ! 草地 - !11 Permanent Wetlands ! 永久性湿地 - !12 Croplands ! 农田 - !13 Urban and Built-up Lands ! 城市与建成区 - !14 Cropland/Natural Vegetation Mosaics ! 农田-自然植被镶嵌区 - !15 Permanent Snow and Ice ! 永久冰雪 - !16 Barren ! 裸地 - !17 Water Bodies ! 水体 - - ! empirical parameters to account for the dependence of optical depth on incidence angle [1] - real(r8), parameter, dimension(N_land_classification) :: tth & - = (/0.80, 1.00, 0.80, 0.49, 0.49, & - 1.00, 1.00, 1.00, 1.00, 1.00, & - 1.00, 1.00, 1.00, 1.00, 1.00, & - 1.00, 2.00/) - real(r8), parameter, dimension(N_land_classification) :: ttv & - = (/0.80, 1.00, 0.80, 0.46, 0.46, & - 1.00, 1.00, 1.00, 1.00, 1.00, & - 1.00, 2.00, 1.00, 2.00, 1.00, & - 1.00, 1.00/) - - ! empirical roughness parameters (Table 2 in [2]) - real(r8), parameter, dimension(N_land_classification) :: hr_SMAP & - = (/0.160, 0.160, 0.160, 0.160, 0.160, & - 0.110, 0.110, 0.125, 0.156, 0.156, & - 0.100, 0.108, 0.000, 0.130, 0.000, & - 0.150, 0.000/) - - real(r8), parameter, dimension(N_land_classification) :: hr_SMOS & - = (/0.300, 0.300, 0.300, 0.300, 0.300, & - 0.100, 0.100, 0.100, 0.100, 0.100, & - 0.100, 0.100, 0.100, 0.100, 0.000, & - 0.100, 0.000/) - - real(r8), parameter, dimension(N_land_classification) :: hr_P16 & - = (/0.350, 0.460, 0.430, 0.450, 0.410, & - 0.260, 0.170, 0.350, 0.230, 0.130, & - 0.020, 0.170, 0.190, 0.220, 0.000, & - 0.020, 0.000/) - - ! b parameters for Wigneron vegetation model (ref?) - real(r8), parameter, dimension(N_land_classification) :: b1 & - = (/0.2600, 0.2260, 0.2600, 0.2260, 0.2260, & - 0.0375, 0.0375, 0.0375, 0.0375, 0.0375, & - 0.0000, 0.0500, 0.0000, 0.0500, 0.0000, & - 0.0000, 0.0500/) - - real(r8), parameter, dimension(N_land_classification) :: b2 & - = (/0.0060, 0.0010, 0.0060, 0.0010, 0.0010, & - 0.0500, 0.0500, 0.0500, 0.0500, 0.0500, & - 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & - 0.0000, 0.0000/) - - real(r8), parameter, dimension(N_land_classification) :: b3 & - = (/0.6900, 0.7000, 0.6900, 0.7000, 0.7000, & - 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & - 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & - 0.0000, 0.0000/) - - ! effective diffusion albedo (Table 3 in [2]) - real(r8), parameter, dimension(N_land_classification) :: w_SMAPL2 & - = (/0.050, 0.050, 0.050, 0.050, 0.050, & - 0.050, 0.050, 0.050, 0.080, 0.050, & - 0.050, 0.000, 0.065, 0.000, 0.000, & - 0.000, 0.000/) - - real(r8), parameter, dimension(N_land_classification) :: w_CMEM & - = (/0.080, 0.095, 0.080, 0.070, 0.070, & - 0.050, 0.050, 0.050, 0.050, 0.050, & - 0.000, 0.000, 0.000, 0.000, 0.000, & - 0.000, 0.000/) - - real(r8), parameter, dimension(N_land_classification) :: w_K16 & - = (/0.050, 0.050, 0.060, 0.030, 0.050, & - 0.030, 0.050, 0.040, 0.020, 0.030, & - 0.000, 0.040, 0.000, 0.020, 0.000, & - 0.000, 0.000/) - - real(r8), parameter, dimension(N_land_classification) :: w_SMAPL4 & - = (/0.120, 0.080, 0.120, 0.100, 0.120, & - 0.140, 0.110, 0.130, 0.120, 0.070, & - 0.000, 0.120, 0.000, 0.150, 0.000, & - 0.000, 0.000/) -#endif - -END MODULE MOD_DA_Const -!----------------------------------------------------------------------------- -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 deleted file mode 100644 index 1ec32f06e1..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 +++ /dev/null @@ -1,137 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_EnKF -!----------------------------------------------------------------------------- -! DESCRIPTION: -! ensemble Kalman filter (EnKF) types -! -! AUTHOR: -! Lu Li, 12/2024: Initial version -! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes -!----------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_SPMD_Task - IMPLICIT NONE - SAVE - -! public functions - PUBLIC :: letkf - - -!----------------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------------- - - SUBROUTINE letkf (& - num_ens, num_obs, & - HA, y, R, infl, & - trans) - -!----------------------------------------------------------------------------- -! Description: -! local transform ensemble Kalman filter -! -! Original author : -! Lu Li, 12/2024 -!----------------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - -!------------------------ Dummy Arguments ------------------------------------ - integer, intent(in) :: num_ens ! ensemble size - integer, intent(in) :: num_obs ! number of observations - real(r8), intent(in) :: HA(num_obs, num_ens) ! ensemble predicted observation matrix - real(r8), intent(in) :: y(num_obs) ! observation vector - real(r8), intent(in) :: R(num_obs) ! observation error variance - real(r8), intent(in) :: infl ! inflation factor - real(r8), intent(out) :: trans(num_ens, num_ens) ! transform matrix (k x k) - -!------------------------ Local Variables ------------------------------------ - real(r8) :: HA_mean(num_obs) ! mean of ensemble predicted observation (l) - real(r8) :: dHA(num_obs, num_ens) ! HA - mean(HA) (l x k) - real(r8) :: dHA_t(num_ens, num_obs) ! transpose of dHA (k x l) - real(r8) :: C(num_ens, num_obs) ! C = (dHA)^T * (R)^-1 (k x l) - real(r8) :: M1(num_ens, num_ens) ! C * dHA (k x k) - real(r8) :: pa_inv(num_ens, num_ens) ! inverse of background error covariance matrix (k x k) - real(r8) :: eigval(num_ens) ! eigenvalues of pa_inv (k) - real(r8) :: eigvec(num_ens, num_ens) ! eigenvectors of pa_inv (k x k) - integer :: lwork - real(r8), allocatable :: work(:) - integer :: err - real(r8) :: M2(num_ens, num_ens) ! M2 = eigvec * eigval^-1 (k x k) - real(r8) :: pa(num_ens, num_ens) ! background error covariance matrix (k x k) - real(r8) :: M3(num_ens, num_obs) ! M3 = pa * C (k x l) - real(r8) :: delta(num_obs) ! increment of observation (l) - real(r8) :: w_avg(num_ens) ! weight (k) - real(r8) :: M4(num_ens, num_ens) ! M4 = eigvec * sqrt((k-1)/eigval) (k x k) - real(r8) :: trans_pert(num_ens, num_ens) ! perturbation transform matrix (k x k) - real(r8) :: I0(num_ens, num_ens) ! identity matrix (k x k) - real(r8) :: one_div_ens(num_ens) ! 1/num_ens - integer :: i, j - -!----------------------------------------------------------------------------- - - ! calculate observation space perturbation - HA_mean = sum(HA, dim=2) / size(HA, dim=2) !(lx1) - DO j = 1, num_ens - dHA(:,j) = HA(:,j) - HA_mean !(lxk) - ENDDO - - ! calculate C, intermediate matrix in localized observation - dHA_t = transpose(dHA) !(kxl) - DO j = 1, num_obs - C(:,j) = dHA_t(:,j) / (R(j)) !(kxl) - ENDDO - - ! calculate C*dHA, intermediate matrix in background error M1 - CALL dgemm('N', 'N', num_ens, num_ens, num_obs, 1.0_8, C, num_ens, dHA, num_obs, 0.0_8, M1, num_ens) - - ! calculate inverse of background error - pa_inv = M1 - do i=1, num_ens - pa_inv(i,i) = M1(i,i) + (num_ens-1)*1.0d0/infl - end do - - ! eigenvalues and eigenvectors of inverse of background error - lwork = 4 * num_ens - allocate( work(lwork) ) - CALL dsyev('V', 'U', num_ens, pa_inv, num_ens, eigval, work, lwork, err) - eigvec = pa_inv !(kxk) - - ! calculate background error covariance matrix pa = eigvec (eigval)^-1 eigvec^T - DO i = 1, num_ens - M2(:,i) = eigvec(:,i) / eigval(i) !(kxk) - ENDDO - CALL dgemm('N', 'T', num_ens, num_ens, num_ens, 1.0_8, M2, num_ens, eigvec, num_ens, 0.0_8, pa, num_ens) !(kxk) - - ! caculate pa * C, intermediate matrix in Kalman gain M3 - CALL dgemm('N', 'N', num_ens, num_obs, num_ens, 1.0_8, pa, num_ens, C, num_ens, 0.0_8, M3, num_ens) !(kxl) - - ! calculate weight - delta = y - HA_mean - CALL dgemm('N', 'N', num_ens, 1, num_obs, 1.0_8, M3, num_ens, delta, num_obs, 0.0_8, w_avg, num_ens) !(kx1) - - ! calculate pertubation transform matrix - DO j = 1, num_ens - M4(:,j) = eigvec(:,j) * sqrt((num_ens-1) / eigval(j)) !(kxk) - ENDDO - CALL dgemm('N', 'T', num_ens, num_ens, num_ens, 1.0_8, M4, num_ens, eigvec, num_ens, 0.0_8, trans_pert, num_ens) !(kxk) - - ! calculate transform matrix - one_div_ens(:) = 1./num_ens - I0 = -1.0 / num_ens - DO i = 1, num_ens - I0(i, i) = 1.0 - 1./num_ens - ENDDO - DO j = 1, num_ens - trans(:, j) = matmul(trans_pert(:, j) + w_avg(:), I0) + one_div_ens(:) - ENDDO - - END SUBROUTINE letkf - -!----------------------------------------------------------------------------- -END MODULE MOD_DA_EnKF -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 deleted file mode 100644 index 8eea429ae2..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 +++ /dev/null @@ -1,267 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_Ensemble -!----------------------------------------------------------------------- -! DESCRIPTION: -! Provide functions to generate ensemble samples for data assimilation -! -! REFERENCES: -! [1] Algorithm Theoretical Basis Document Level 4 Surface and Root -! Zone Soil Moisture (L4_SM) Data Product -! -! AUTHOR: -! Lu Li, 12/2024: Initial version -! Lu Li, 10/2025: Consider correlation & AR(1) process -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Namelist - USE MOD_Vars_TimeVariables - USE MOD_DA_Vars_TimeVariables - USE MOD_Vars_1DForcing - USE MOD_LandPatch - IMPLICIT NONE - SAVE - - ! public functions - PUBLIC :: ensemble - - ! local parameters - ! forcing [parameters used here is consistent with SMAP L4 (Table 4 in [1])] - integer, parameter :: nvar = 4 ! number of pertutated forcing variables - real(r8), parameter :: tau_ar = 24.0 ! correlation time scale in hours - - real(r8) :: dt ! time step in hours - real(r8) :: phi ! AR(1) autocorrelation coefficient consider time scale - real(r8) :: sigma_eps ! standard deviation of noise in AR(1) process - real(r8), dimension(nvar) :: sigma = (/0.5, 0.3, 20.0, 1.0/) ! standard deviation of perturbed forcing variables (prcp, sw, lw, t) - real(r8), dimension(nvar, nvar) :: C = reshape([ & - 1.0, -0.8, 0.5, 0.0, & - -0.8, 1.0, -0.5, 0.4, & - 0.5, -0.5, 1.0, 0.4, & - 0.0, 0.4, 0.4, 1.0], shape=[nvar, nvar]) ! cross-correlation matrix between perturbed forcing variables - real(r8), allocatable :: r_prev(:,:,:) ! previous perturbation (numpatch, nvar, DEF_DA_ENS_NUM) - real(r8), allocatable :: r_curr(:,:,:) ! current perturbation (numpatch, nvar, DEF_DA_ENS_NUM) - logical :: initialized = .false. ! flag to indicate if is initialized - - ! soil moisture [default set 0.002 m3/m3 disterbulance] - integer, parameter :: nvar_sm = 2 ! number of pertutated soil moisture layers - real(r8), parameter :: tau_sm = 3.0 ! correlation time scale in hours - real(r8) :: phi_sm ! AR(1) autocorrelation coefficient consider time scale - real(r8) :: sigma_eps_sm ! standard deviation of noise in AR(1) process - real(r8), dimension(nvar_sm) :: sigma_sm = (/0.035, 0.0552/) ! standard deviation of perturbed soil moisture (equal to 0.002 m3/m3) - real(r8), allocatable :: r_prev_sm(:,:,:) ! previous perturbation (numpatch, nvar_sm, DEF_DA_ENS_NUM) - real(r8), allocatable :: r_curr_sm(:,:,:) ! current perturbation (numpatch, nvar_sm, DEF_DA_ENS_NUM) - -!----------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE ensemble(deltim) - -!----------------------------------------------------------------------- - IMPLICIT NONE - - real(r8), intent(in) :: deltim - -!------------------------ Local Variables ------------------------------ - integer :: np, i, j - - real(r8) :: cov_matrix(nvar, nvar) ! covariance matrix between perturbed forcing variables - real(r8) :: L(nvar, nvar) ! Cholesky decomposition of correlation matrix - integer :: info ! info flag for Cholesky decomposition - real(r8) :: u1(DEF_DA_ENS_NUM/2), u2(DEF_DA_ENS_NUM/2) ! uniform random variables - real(r8) :: z(nvar, DEF_DA_ENS_NUM) ! standard normal random variables - real(r8) :: mean_z(nvar) ! mean of perturbation (nvar) - real(r8) :: std_z(nvar) ! std of perturbation (nvar) - real(r8) :: zxL(nvar, DEF_DA_ENS_NUM) ! correlated random variables (nvar, DEF_DA_ENS_NUM) - - real(r8) :: z_sm(DEF_DA_ENS_NUM) ! standard normal random variables - real(r8) :: mean_z_sm ! mean of perturbation - real(r8) :: std_z_sm ! std of perturbation - real(r8) :: mean_r_sm(nvar_sm) ! mean of perturbation for soil moisture (nvar_sm) - real(r8) :: std_r_sm(nvar_sm) ! std of perturbation for soil moisture (nvar_sm) - real(r8) :: a1(DEF_DA_ENS_NUM) ! temporary disturbed variable for soil moisture layer 1 - real(r8) :: a2(DEF_DA_ENS_NUM) ! temporary disturbed variable for soil moisture layer 2 - -!----------------------------------------------------------------------- - - ! initialize persistent variables - IF (.not. initialized) THEN - allocate(r_prev(numpatch, nvar, DEF_DA_ENS_NUM)) - allocate(r_curr(numpatch, nvar, DEF_DA_ENS_NUM)) - allocate(r_prev_sm(numpatch, nvar_sm, DEF_DA_ENS_NUM)) - allocate(r_curr_sm(numpatch, nvar_sm, DEF_DA_ENS_NUM)) - r_prev = 0.0_r8 - r_curr = 0.0_r8 - r_prev_sm = 0.0_r8 - r_curr_sm = 0.0_r8 - initialized = .true. - ENDIF - - ! calculate AR(1) parameters - dt = deltim/3600 - phi = exp(-dt/tau_ar) - sigma_eps = sqrt(1.0 - phi**2) - phi_sm = exp(-dt/tau_sm) - sigma_eps_sm = sqrt(1.0 - phi_sm**2) - - ! calculate covariance matrix by cross-correlation matrix and standard deviation - cov_matrix = 0.0_r8 - DO i = 1, nvar - DO j = 1, nvar - cov_matrix(i,j) = C(i,j) * sigma(i) * sigma(j) - ENDDO - ENDDO - - ! perform Cholesky decomposition of covariance matrix - L = cov_matrix - CALL dpotrf('L', nvar, L, nvar, info) - DO i = 1, nvar - DO j = i+1, nvar - L(i,j) = 0.0_r8 - ENDDO - ENDDO - IF (info /= 0) THEN - print *, 'Error: Cholesky decomposition failed' - stop - ENDIF - - ! Generate ensemble samples for forcing variables - DO np = 1, numpatch - ! generate disturbance ensemble samples ~ N(0, I) - CALL random_seed() - CALL random_number(u1) - CALL random_number(u2) - DO i = 1, DEF_DA_ENS_NUM/2 - u1(i) = max(u1(i), 1e-10) ! ensure u1 is not zero - z(1,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) - z(1,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) - ENDDO - CALL random_seed() - CALL random_number(u1) - CALL random_number(u2) - DO i = 1, DEF_DA_ENS_NUM/2 - u1(i) = max(u1(i), 1e-10) - z(2,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) - z(2,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) - ENDDO - CALL random_seed() - CALL random_number(u1) - CALL random_number(u2) - DO i = 1, DEF_DA_ENS_NUM/2 - u1(i) = max(u1(i), 1e-10) - z(3,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) - z(3,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) - ENDDO - CALL random_seed() - CALL random_number(u1) - CALL random_number(u2) - DO i = 1, DEF_DA_ENS_NUM/2 - u1(i) = max(u1(i), 1e-10) - z(4,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) - z(4,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) - ENDDO - - ! normalize z to mean 0 and std 1 - DO i = 1, nvar - mean_z(i) = sum(z(i, :))/DEF_DA_ENS_NUM - std_z(i) = sqrt(sum((z(i, :) - mean_z(i))**2)/(DEF_DA_ENS_NUM - 1)) - ENDDO - DO i = 1, nvar - z(i,:) = (z(i,:)-mean_z(i))/std_z(i) - ENDDO - - ! multiply by Cholesky factor to introduce correlation (z*L) - CALL dgemm('N', 'N', nvar, DEF_DA_ENS_NUM, nvar, 1.0_r8, L, nvar, z, nvar, 0.0_r8, zxL, nvar) - - ! introduce correlation using AR(1) process - DO i = 1, nvar - DO j = 1, DEF_DA_ENS_NUM - r_curr(np,i,j) = phi * r_prev(np,i,j) + sigma_eps * zxL(i,j) - ENDDO - ENDDO - ! no AR(1) process, directly use correlated random variables - ! r_curr(np,:,:) = zxL - - ! normalize the disturbance ensemble samples to mean 0 - mean_z = sum(r_curr(np,:,:), dim=2)/DEF_DA_ENS_NUM - DO i = 1, nvar - DO j = 1, DEF_DA_ENS_NUM - r_curr(np,i,j) = r_curr(np,i,j) - mean_z(i) - ENDDO - ENDDO - - ! save current perturbation as previous perturbation for next time step - r_prev = r_curr - - ! generate ensemble samples according different types - DO j = 1, DEF_DA_ENS_NUM - forc_prc_ens(j,np) = forc_prc(np) * exp(r_curr(np,1,j) - 0.5 * sigma(1)**2) - forc_prl_ens(j,np) = forc_prl(np) * exp(r_curr(np,1,j) - 0.5 * sigma(1)**2) - forc_sols_ens(j,np) = forc_sols(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) - forc_soll_ens(j,np) = forc_soll(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) - forc_solsd_ens(j,np) = forc_solsd(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) - forc_solld_ens(j,np) = forc_solld(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2) - forc_frl_ens(j,np) = forc_frl(np) + r_curr(np,3,j) - forc_t_ens(j,np) = forc_t(np) + r_curr(np,4,j) - ENDDO - - IF (DEF_DA_ENS_SM) THEN - ! generate ensemble samples (0, I) for soil moisture - CALL random_seed() - CALL random_number(u1) - CALL random_number(u2) - DO i = 1, DEF_DA_ENS_NUM/2 - u1(i) = max(u1(i), 1e-10) - z_sm(i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i)) - z_sm(i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i)) - ENDDO - mean_z_sm = sum(z_sm)/DEF_DA_ENS_NUM - std_z_sm = sqrt(sum((z_sm - mean_z_sm)**2)/(DEF_DA_ENS_NUM - 1)) - z_sm = (z_sm - mean_z_sm)/std_z_sm - - ! introduce correlation using AR(1) process - DO i = 1, nvar_sm - DO j = 1, DEF_DA_ENS_NUM - r_curr_sm(np,i,j) = phi_sm * r_prev_sm(np,i,j) + sigma_eps_sm * sigma_sm(i) * z_sm(j) - ENDDO - ENDDO - - ! normalize the disturbance ensemble samples to mean 0 - mean_r_sm = sum(r_curr_sm(np,:,:), dim=2)/DEF_DA_ENS_NUM - DO i = 1, nvar_sm - DO j = 1, DEF_DA_ENS_NUM - r_curr_sm(np,i,j) = r_curr_sm(np,i,j) - mean_r_sm(i) - ENDDO - ENDDO - - ! save current perturbation as previous perturbation for next time step - r_prev_sm = r_curr_sm - - ! generate ensemble samples according different types - DO j = 1, DEF_DA_ENS_NUM - a1(j) = wliq_soisno_ens(1,j,np) + r_curr_sm(np,1,j) - a2(j) = wliq_soisno_ens(2,j,np) + r_curr_sm(np,2,j) - ENDDO - DO j = 1, DEF_DA_ENS_NUM - a1(j) = max(1e-10, a1(j)) - a2(j) = max(1e-10, a2(j)) - ENDDO - - ! move residual water to water table - DO j = 1, DEF_DA_ENS_NUM - wa_ens(j, np) = wa_ens(j, np) - (sum(wliq_soisno_ens(1:2, j, np)) - a1(j) - a2(j)) - wliq_soisno_ens(1, j, np) = a1(j) - wliq_soisno_ens(2, j, np) = a2(j) - ENDDO - ENDIF - ENDDO - - END SUBROUTINE ensemble - -!----------------------------------------------------------------------- -END MODULE MOD_DA_Ensemble -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 deleted file mode 100644 index 70ab7e8981..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 +++ /dev/null @@ -1,396 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_Main -!----------------------------------------------------------------------------- -! DESCRIPTION: -! Main procedures for data assimilation -! -! AUTHOR: -! Lu Li, 12/2024 -! Zhilong Fan, Lu Li, 03/2024 -!----------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Spmd_task - USE MOD_Namelist - USE MOD_TimeManager - USE MOD_LandPatch - USE MOD_DA_TWS - USE MOD_DA_SM - USE MOD_DA_Ensemble - USE MOD_Vars_1DFluxes - USE MOD_Vars_TimeVariables - USE MOD_Vars_1DForcing - IMPLICIT NONE - SAVE - -!----------------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------------- - - SUBROUTINE init_DA () - -!----------------------------------------------------------------------------- - IMPLICIT NONE - -!----------------------------------------------------------------------------- - -!############################################################################# -! Init data assimilation for different products -!############################################################################# - IF (DEF_DA_TWS) THEN - IF (DEF_DA_TWS_GRACE) THEN - CALL init_DA_GRACE () - ENDIF - ENDIF - - IF (DEF_DA_SM) THEN - IF (p_is_root) THEN - print *, '[CoLM-DA] initialize surface soil moisture & temperature data assimilation.' - ENDIF - CALL init_DA_SM () - ENDIF - - END SUBROUTINE init_DA - -!----------------------------------------------------------------------------- - - SUBROUTINE run_DA (idate, deltim, dolai, doalb, dosst, oro) - -!----------------------------------------------------------------------------- - IMPLICIT NONE - -!------------------------ Dummy Arguments ------------------------------------ - integer, intent(in) :: idate(3) - real(r8), intent(in) :: deltim - logical, intent(in) :: dolai ! true if time for time-varying vegetation parameter - logical, intent(in) :: doalb ! true if time for surface albedo calculation - logical, intent(in) :: dosst ! true if time for update sst/ice/snow - - real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag - -!------------------------ Local Variables ------------------------------------ - integer :: np, i, maxday - integer :: sdate(3) ! backward date from the end to the begin of the time step - -!----------------------------------------------------------------------------- - - ! use OI for terrestrial water storage - IF (DEF_DA_TWS) THEN - IF (DEF_DA_TWS_GRACE) THEN - CALL run_DA_GRACE (idate, deltim) - ENDIF - ENDIF - - ! use ensemble DA for soil moisture - IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN -!############################################################################# -! Generate ensemble members -!############################################################################# - IF (p_is_compute) THEN - - ! store the non-DA trajectory - z_sno_noda = z_sno - dz_sno_noda = dz_sno - t_soisno_noda = t_soisno - wliq_soisno_noda = wliq_soisno - wice_soisno_noda = wice_soisno - smp_noda = smp - hk_noda = hk - t_grnd_noda = t_grnd - tleaf_noda = tleaf - ldew_noda = ldew - ldew_rain_noda = ldew_rain - ldew_snow_noda = ldew_snow - fwet_snow_noda = fwet_snow - sag_noda = sag - scv_noda = scv - snowdp_noda = snowdp - fveg_noda = fveg - fsno_noda = fsno - sigf_noda = sigf - green_noda = green - tlai_noda = tlai - lai_noda = lai - tsai_noda = tsai - sai_noda = sai - alb_noda = alb - ssun_noda = ssun - ssha_noda = ssha - ssoi_noda = ssoi - ssno_noda = ssno - thermk_noda = thermk - extkb_noda = extkb - extkd_noda = extkd - zwt_noda = zwt - wdsrf_noda = wdsrf - wa_noda = wa - wetwat_noda = wetwat - t_lake_noda = t_lake - lake_icefrac_noda = lake_icefrac - savedtke1_noda = savedtke1 - - tref_noda = tref - h2osoi_noda = h2osoi - - ! Generate ensemble members - CALL ensemble (deltim) - - ! loop over ensemble members - DO i = 1, DEF_DA_ENS_NUM - ! set ensemble forcing variables - forc_t = forc_t_ens(i,:) - forc_prc = forc_prc_ens(i,:) - forc_prl = forc_prl_ens(i,:) - forc_sols = forc_sols_ens(i,:) - forc_soll = forc_soll_ens(i,:) - forc_solsd = forc_solsd_ens(i,:) - forc_solld = forc_solld_ens(i,:) - forc_frl = forc_frl_ens(i,:) - - ! give the i-th trajectory state value to state variables - z_sno = z_sno_ens ( :,i,:) - dz_sno = dz_sno_ens ( :,i,:) - t_soisno = t_soisno_ens ( :,i,:) - wliq_soisno = wliq_soisno_ens ( :,i,:) - wice_soisno = wice_soisno_ens ( :,i,:) - smp = smp_ens ( :,i,:) - hk = hk_ens ( :,i,:) - t_grnd = t_grnd_ens ( i,:) - tleaf = tleaf_ens ( i,:) - ldew = ldew_ens ( i,:) - ldew_rain = ldew_rain_ens ( i,:) - ldew_snow = ldew_snow_ens ( i,:) - fwet_snow = fwet_snow_ens ( i,:) - sag = sag_ens ( i,:) - scv = scv_ens ( i,:) - snowdp = snowdp_ens ( i,:) - fveg = fveg_ens ( i,:) - fsno = fsno_ens ( i,:) - sigf = sigf_ens ( i,:) - green = green_ens ( i,:) - tlai = tlai_ens ( i,:) - lai = lai_ens ( i,:) - tsai = tsai_ens ( i,:) - sai = sai_ens ( i,:) - alb = alb_ens (:,:,i,:) - ssun = ssun_ens (:,:,i,:) - ssha = ssha_ens (:,:,i,:) - ssoi = ssoi_ens (:,:,i,:) - ssno = ssno_ens (:,:,i,:) - thermk = thermk_ens ( i,:) - extkb = extkb_ens ( i,:) - extkd = extkd_ens ( i,:) - zwt = zwt_ens ( i,:) - wdsrf = wdsrf_ens ( i,:) - wa = wa_ens ( i,:) - wetwat = wetwat_ens ( i,:) - t_lake = t_lake_ens ( :,i,:) - lake_icefrac = lake_icefrac_ens( :,i,:) - savedtke1 = savedtke1_ens ( i,:) - - ! run colm - CALL CoLMDRIVER (idate, deltim, dolai, doalb, dosst, oro) - - ! output ensemble members - z_sno_ens ( :,i,:) = z_sno - dz_sno_ens ( :,i,:) = dz_sno - t_soisno_ens ( :,i,:) = t_soisno - wliq_soisno_ens ( :,i,:) = wliq_soisno - wice_soisno_ens ( :,i,:) = wice_soisno - smp_ens ( :,i,:) = smp - hk_ens ( :,i,:) = hk - t_grnd_ens ( i,:) = t_grnd - tleaf_ens ( i,:) = tleaf - ldew_ens ( i,:) = ldew - ldew_rain_ens ( i,:) = ldew_rain - ldew_snow_ens ( i,:) = ldew_snow - fwet_snow_ens ( i,:) = fwet_snow - sag_ens ( i,:) = sag - scv_ens ( i,:) = scv - snowdp_ens ( i,:) = snowdp - fveg_ens ( i,:) = fveg - fsno_ens ( i,:) = fsno - sigf_ens ( i,:) = sigf - green_ens ( i,:) = green - tlai_ens ( i,:) = tlai - lai_ens ( i,:) = lai - tsai_ens ( i,:) = tsai - sai_ens ( i,:) = sai - alb_ens (:,:,i,:) = alb - ssun_ens (:,:,i,:) = ssun - ssha_ens (:,:,i,:) = ssha - ssoi_ens (:,:,i,:) = ssoi - ssno_ens (:,:,i,:) = ssno - thermk_ens ( i,:) = thermk - extkb_ens ( i,:) = extkb - extkd_ens ( i,:) = extkd - zwt_ens ( i,:) = zwt - wdsrf_ens ( i,:) = wdsrf - wa_ens ( i,:) = wa - wetwat_ens ( i,:) = wetwat - t_lake_ens ( :,i,:) = t_lake - lake_icefrac_ens( :,i,:) = lake_icefrac - savedtke1_ens ( i,:) = savedtke1 - - h2osoi_ens(:,i,:) = h2osoi - trad_ens (i,:) = trad - tref_ens (i,:) = tref - qref_ens (i,:) = qref - ustar_ens (i,:) = ustar - qstar_ens (i,:) = qstar - tstar_ens (i,:) = tstar - fm_ens (i,:) = fm - fh_ens (i,:) = fh - fq_ens (i,:) = fq - - fsena_ens (i,:) = fsena - lfevpa_ens(i,:) = lfevpa - fevpa_ens (i,:) = fevpa - rsur_ens (i,:) = rsur - ENDDO - - ! recover the no-DA trajectory - z_sno = z_sno_noda - dz_sno = dz_sno_noda - t_soisno = t_soisno_noda - wliq_soisno = wliq_soisno_noda - wice_soisno = wice_soisno_noda - smp = smp_noda - hk = hk_noda - t_grnd = t_grnd_noda - tleaf = tleaf_noda - ldew = ldew_noda - ldew_rain = ldew_rain_noda - ldew_snow = ldew_snow_noda - fwet_snow = fwet_snow_noda - sag = sag_noda - scv = scv_noda - snowdp = snowdp_noda - fveg = fveg_noda - fsno = fsno_noda - sigf = sigf_noda - green = green_noda - tlai = tlai_noda - lai = lai_noda - tsai = tsai_noda - sai = sai_noda - alb = alb_noda - ssun = ssun_noda - ssha = ssha_noda - ssoi = ssoi_noda - ssno = ssno_noda - thermk = thermk_noda - extkb = extkb_noda - extkd = extkd_noda - zwt = zwt_noda - wdsrf = wdsrf_noda - wa = wa_noda - wetwat = wetwat_noda - t_lake = t_lake_noda - lake_icefrac = lake_icefrac_noda - savedtke1 = savedtke1_noda - - tref = tref_noda - h2osoi = h2osoi_noda - - ENDIF - ENDIF - -!############################################################################# -! Perform data assimilation for different satellite products -!############################################################################# - IF (DEF_DA_SM) THEN - ! backward date from the end to the begin of the time step - sdate = idate - sdate(3) = sdate(3) - nint(deltim) - IF (sdate(3) < 0) THEN - sdate(2) = sdate(2) - 1 - sdate(3) = sdate(3) + 86400 - - IF (sdate(2) < 1) THEN - sdate(1) = sdate(1) - 1 - IF (isleapyear(sdate(1))) THEN - maxday = 366 - ELSE - maxday = 365 - ENDIF - sdate(2) = maxday - ENDIF - ENDIF - - ! data assimilation - IF (DEF_DA_SM) THEN - IF (p_is_root) THEN - print *, '[CoLM-DA] Start surface soil moisture & temperature data assimilation.' - ENDIF - CALL mpi_barrier (p_comm_glb, p_err) - CALL run_DA_SM (sdate, deltim) - ENDIF - ENDIF - -!############################################################################# -! Use ensemble mean for important outputs -!############################################################################# - IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO np = 1, numpatch - ! important state variables - t_soisno_a(:,np) = sum(t_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM - wliq_soisno_a(:,np) = sum(wliq_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM - wice_soisno_a(:,np) = sum(wice_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM - t_grnd_a(np) = sum(t_grnd_ens(:,np), dim=1) / DEF_DA_ENS_NUM - tleaf_a(np) = sum(tleaf_ens(:,np), dim=1) / DEF_DA_ENS_NUM - snowdp_a(np) = sum(snowdp_ens(:,np), dim=1) / DEF_DA_ENS_NUM - - ! diagnostic variables - h2osoi_a(:,np) = sum(h2osoi_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM - t_brt_smap_a(:,np) = sum(t_brt_smap_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM - t_brt_fy3d_a(:,np) = sum(t_brt_fy3d_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM - trad_a(np) = sum(trad_ens(:,np), dim=1) / DEF_DA_ENS_NUM - tref_a(np) = sum(tref_ens(:,np), dim=1) / DEF_DA_ENS_NUM - qref_a(np) = sum(qref_ens(:,np), dim=1) / DEF_DA_ENS_NUM - ustar_a(np) = sum(ustar_ens(:,np), dim=1) / DEF_DA_ENS_NUM - qstar_a(np) = sum(qstar_ens(:,np), dim=1) / DEF_DA_ENS_NUM - tstar_a(np) = sum(tstar_ens(:,np), dim=1) / DEF_DA_ENS_NUM - fm_a(np) = sum(fm_ens(:,np), dim=1) / DEF_DA_ENS_NUM - fh_a(np) = sum(fh_ens(:,np), dim=1) / DEF_DA_ENS_NUM - fq_a(np) = sum(fq_ens(:,np), dim=1) / DEF_DA_ENS_NUM - fsena_a(np) = sum(fsena_ens(:,np), dim=1) / DEF_DA_ENS_NUM - fevpa_a(np) = sum(fevpa_ens(:,np), dim=1) / DEF_DA_ENS_NUM - lfevpa_a(np) = sum(lfevpa_ens(:,np), dim=1) / DEF_DA_ENS_NUM - rsur_a(np) = sum(rsur_ens(:,np), dim=1) / DEF_DA_ENS_NUM - ENDDO - ENDIF - ENDIF - ENDIF - - END SUBROUTINE run_DA - -!----------------------------------------------------------------------------- - - SUBROUTINE end_DA () - -!----------------------------------------------------------------------------- - IMPLICIT NONE - -!----------------------------------------------------------------------------- - - IF (DEF_DA_TWS) THEN - IF (DEF_DA_TWS_GRACE) THEN - CALL end_DA_GRACE () - ENDIF - ENDIF - - IF (DEF_DA_SM) THEN - CALL end_DA_SM () - ENDIF - - END SUBROUTINE end_DA - -!----------------------------------------------------------------------------- -END MODULE MOD_DA_Main -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 deleted file mode 100644 index ef234e5cba..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 +++ /dev/null @@ -1,1431 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_RTM -!----------------------------------------------------------------------- -! DESCRIPTION: -! Forward modeling of brightness temperature observations -! -! AUTHOR: -! Lu Li, 12/2024: Initial version -! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes -! Lu Li, 10/2025: Debug and clean codes -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - USE MOD_Vars_1DForcing - USE MOD_DA_Const - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: nl_soil, nl_lake, N_land_classification - USE MOD_Namelist - IMPLICIT NONE - SAVE - -! public functions - PUBLIC :: forward - -! local variables (parameters depends on frequency and incidence angle of satellite) - real(r8) :: fghz ! frequency of satellite (GHz) - real(r8) :: theta ! incidence angle of satellite (rad) - real(r8) :: f ! frequency (Hz) - real(r8) :: omega ! radian frequency - real(r8) :: lam ! wavelength (m) - real(r8) :: k ! wave number (rad/m) - real(r8) :: kcm ! wave number (rad/cm) - real(r8) :: kr ! size parameter used in calcuate single-particle albedo - -!----------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE forward( & - patchtype, patchclass, dz_sno, & - forc_topo, htop, & - tref, t_soisno, tleaf, & - wliq_soisno, wice_soisno, h2osoi, & - snowdp, lai, sai, & - wf_clay, wf_sand, wf_silt, BD_all, porsl, & - sat_theta, sat_fghz, & - tb_toa_h, tb_toa_v) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Forward modeling of brightness temperature observations -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - USE MOD_Vars_Global, only: nl_soil, nl_lake, maxsnl, spval, dz_soi - USE MOD_DA_Const - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - integer, intent(in) :: patchtype ! land cover type - integer, intent(in) :: patchclass ! land cover class - real(r8), intent(in) :: dz_sno(maxsnl + 1:0) ! layer thickness (m) - real(r8), intent(in) :: forc_topo ! topography [m] - real(r8), intent(in) :: htop ! upper height of vegetation [m] - real(r8), intent(in) :: tref ! 2 m height air temperature [kelvin] - real(r8), intent(in) :: tleaf ! leaf temperature [K] - real(r8), intent(in) :: t_soisno(maxsnl + 1:nl_soil) ! soil temperature [K] - real(r8), intent(in) :: wliq_soisno(maxsnl + 1:nl_soil) ! liquid water in layers [kg/m2] - real(r8), intent(in) :: wice_soisno(maxsnl + 1:nl_soil) ! ice lens in layers [kg/m2] - real(r8), intent(in) :: h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3] - real(r8), intent(in) :: snowdp ! snow depth [meter] - real(r8), intent(in) :: lai ! leaf area index - real(r8), intent(in) :: sai ! stem area index - real(r8), intent(in) :: wf_clay(nl_soil) ! gravimetric fraction of clay - real(r8), intent(in) :: wf_sand(nl_soil) ! gravimetric fraction of sand - real(r8), intent(in) :: wf_silt(nl_soil) ! gravimetric fraction of silt - real(r8), intent(in) :: BD_all(nl_soil) ! bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3) - real(r8), intent(in) :: porsl(nl_soil) ! fraction of soil that is voids [-] - real(r8), intent(in) :: sat_theta ! incidence angle of satellite (rad) - real(r8), intent(in) :: sat_fghz ! frequency of satellite (GHz) - real(r8), intent(out) :: tb_toa_h ! brightness temperature of top-of-atmosphere for H- polarization - real(r8), intent(out) :: tb_toa_v ! brightness temperature of top-of-atmosphere for V- polarization - -!----------------------- Local Variables ------------------------------- - logical :: is_low_veg ! flag for low vegetation - real(r8) :: dz_soisno(maxsnl+1:nl_soil) ! liquid water in layers [kg/m2] - integer :: lb ! lower bound of arrays - real(r8) :: tau_atm ! atmospheric optical depth - real(r8) :: r_r(2) ! rough surface reflectivity for H and V polarizations - real(r8) :: r_sn(2) ! reflectivity between the snow and ground for H and V polarizations - real(r8) :: r_snow(2) ! reflectivity of the snow for H and V polarizations - real(r8) :: tb_soil(2) ! brightness temperature of soil for H and V polarizations - real(r8) :: tb_tos(2) ! brightness temperature of snow-covered ground for H and V polarizations - real(r8) :: tb_tov(2) ! brightness temperature of vegetation (consider snow) for H and V polarizations - real(r8) :: tb_tov_noad(2) ! brightness temperature of vegetation (no downwelling radiation) for H and V polarizations - real(r8) :: tb_au(2) ! upwelling radiation (brightness temperature) of atmosphere - real(r8) :: tb_ad(2) ! downwelling radiation (brightness temperature) of atmosphere - real(r8) :: rho_snow ! snow density (g/cm3) - real(r8) :: liq_snow ! snow liquid water content (cm3/cm3) - real(r8) :: gamma_p(2) ! vegetation opacity for H- and V- polarization - real(r8) :: tb_veg(2) ! brightness temperature of vegetation for H- and V- polarization - real(r8) :: tb_2(2) ! the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer - real(r8) :: tb_3(2) ! upwelling soil emission attenuated by the canopy - real(r8) :: tb_4(2) ! the downwelling cosmic ray reflected by the soil and attenuated by the canopy layer - real(r8) :: tb_toa(2) ! brightness temperature of top-of-atmosphere for H- and V- polarization - real(r8) :: wf_total(nl_soil) ! total gravimetric - real(r8) :: BD_all_surf ! bulk density of soil (g/m3) at surface - real(r8) :: porsl_surf ! soil porosity at surface - real(r8) :: t_surf ! soil temperature at surface (C) - real(r8) :: t_deep ! soil temperature at deep layer (C) - real(r8) :: liq_surf ! liquid volumetric water content at surface (m3/m3) - real(r8) :: ice_surf ! ice volumetric water content at surface (m3/m3) - real(r8) :: wf_clay_surf ! gravimetric clay percent fraction(%) at surface - real(r8) :: wf_sand_surf ! gravimetric sand percent fraction(%) at surface - integer :: i - -!----------------------------------------------------------------------- - -!############################################################################# -! Prepare parameters & states used in the operator -!############################################################################# - ! get depth of soil and snow layers - dz_soisno(maxsnl+1:0) = dz_sno(maxsnl+1:0) - dz_soisno(1:nl_soil) = dz_soi(1:nl_soil) - - ! calculate weighted parameters - wf_total = wf_clay + wf_sand + wf_silt - wf_clay_surf = (wf_clay(1)/wf_total(1)*0.0175 + wf_clay(2)/wf_total(2)*0.0276)/0.0451*100 - wf_sand_surf = (wf_sand(1)/wf_total(1)*0.0175 + wf_sand(2)/wf_total(2)*0.0276)/0.0451*100 - BD_all_surf = (BD_all(1)*0.0175 + BD_all(2)*0.0276)/0.0451/1000 - porsl_surf = (porsl(1)*0.0175 + porsl(2)*0.0276)/0.0451 - - ! caculate temperature (C) at surface and deep soil layers - t_surf = ((t_soisno(1)*(0.0175) + t_soisno(2)*(0.0451 - 0.0175))/0.0451) - tfrz - t_deep = ((t_soisno(7)*(0.8289-0.5) + t_soisno(8)*(1.0 - 0.8289))/0.5) - tfrz - - ! caculate liquid/ice volumetric water (first two layers) - liq_surf = (wliq_soisno(1) + wliq_soisno(2))/(0.0451*denh2o) - ice_surf = (wice_soisno(1) + wice_soisno(2))/(0.0451*denice) - - ! calculate lower bound of snow - lb = 0 - DO i = 0, maxsnl - IF (wliq_soisno(i) < 0.0) THEN - lb = i+1 - EXIT - ENDIF - ENDDO - -!############################################################################# -! Run the forward operator -!############################################################################# - ! check the patch type - IF (patchtype >= 3) THEN ! ocean, lake, ice - tb_toa = spval - ELSE - ! calculate parameters used in operator varied with satellite - CALL calc_parameters(sat_theta, sat_fghz) - -!############################################################################# -! atmosphere module -!############################################################################# - CALL atm(forc_topo, tref, tau_atm, tb_au, tb_ad) - -!############################################################################# -! soil module -!############################################################################# - CALL soil(& - patchclass, & - t_surf, t_deep, & - liq_surf, ice_surf, & - wf_sand_surf, wf_clay_surf, BD_all_surf, porsl_surf, & - r_r, tb_soil) - -!############################################################################# -! vegetation and snow module -! We categorized four different cases for the calculations: -! 1) no vegetation and no snow -! 2) no vegetation with snow -! 3) vegetation without snow -! 4) vegetation with snow -!############################################################################# - ! roughly judge low or high vegetation (only for IGBP) - is_low_veg = .true. - IF (patchclass >= 1 .and. patchclass <= 5) THEN - is_low_veg = .false. - END IF - - ! ensure snow density to <= 1 g/cm3 - IF (snowdp > 0.01) THEN - rho_snow = (wliq_soisno(lb) + wice_soisno(lb))/(dz_soisno(lb)*1e3) - liq_snow = wliq_soisno(lb)*rho_snow/(dz_soisno(lb)*1e3) - - IF (liq_snow > 1.0 .or. rho_snow > 1.0) then - rho_snow = 1.0 - liq_snow = wliq_soisno(lb)*rho_snow/(dz_soisno(lb)*1e3) - END IF - END IF - - ! main procedures - ! -------------------------------------------------------------------- - ! 1) no veg and no snow - ! two components: - ! (1) brightness temperature of soil - ! (2) the downwelling radiation reflected by the soil - ! -------------------------------------------------------------------- - IF ((lai + sai < 1e-6) .and. (snowdp < 0.01)) THEN - tb_tov = tb_soil + tb_ad*r_r - tb_tov_noad = tb_soil - - ! -------------------------------------------------------------------- - ! 2) no veg and has snow - ! two components: - ! (1) brightness temperature of snow - ! (2) the downwelling radiation reflected by the snow - ! -------------------------------------------------------------------- - ELSE IF ((lai + sai < 1e-6) .and. (snowdp > 0.01)) THEN - ! calculate brightness temperature of snow-covered ground - CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_r, r_snow, tb_tos) - - tb_tov = tb_tos + tb_ad*r_snow - tb_tov_noad = tb_tos - - ! -------------------------------------------------------------------- - ! 3) has veg and no snow - ! four components: - ! (1) the direct upwelling vegetation emission, - ! (2) the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer - ! (3) upwelling soil emission attenuated by the canopy - ! (4) the downwelling reflected by the soil and attenuated by the canopy layer - ! -------------------------------------------------------------------- - ELSE IF ((lai + sai > 1e-6) .and. (snowdp < 0.01)) THEN - ! calculate brightness temperature of vegetation - CALL veg(patchclass, lai, htop, 0.0, tleaf, tb_veg, gamma_p) - - DO i = 1, 2 - tb_2(i) = tb_veg(i)*gamma_p(i)*r_r(i) - tb_3(i) = tb_soil(i)*gamma_p(i) - tb_4(i) = tb_ad(i)*r_r(i)*(gamma_p(i)**2) - tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i) - tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i) - END DO - - ! -------------------------------------------------------------------- - ! 4) has veg and has snow - ! We need to determine the positional relationship between vegetation and snow. - ! - ! If vegetation is higher than snow, - ! we first calculate brightness temperature of snow (soil boundary), then calculate - ! four components to derive brightness temperature of top of vegetation: - ! (1) the direct upwelling vegetation emission, - ! (2) the downwelling vegetation emission reflected by the snow and attenuated by the canopy layer - ! (3) upwelling snow emission attenuated by the canopy - ! (4) the downwelling reflected by the snow and attenuated by the canopy layer - ! - ! If vegetation is lower than snow - ! we first calculate brightness temperature of top of vegetation (soil boundary), then calculate - ! four components to derive brightness temperature of top of snow: - ! (1) the direct upwelling vegetation emission, - ! (2) the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer - ! (3) upwelling soil emission attenuated by the canopy - ! (4) the downwelling reflected by the soil and attenuated by the canopy layer - ! -------------------------------------------------------------------- - ELSE IF ((lai + sai > 1e-6) .and. (snowdp > 0.01)) THEN - IF (htop < snowdp) THEN - ! calculate brightness temperature of low vegetation - CALL veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p) - - ! calculate brightness temperature of top of vegetation - DO i = 1, 2 - tb_2(i) = tb_veg(i)*gamma_p(i)*r_r(i) - tb_3(i) = tb_soil(i)*gamma_p(i) - tb_4(i) = tb_ad(i)*r_r(i)*(gamma_p(i)**2) - tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i) - tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i) - END DO - - ! calculate reflectivity between the snow and low veg (adopted from CMEM) - r_sn(:) = 1.0 - tb_tov_noad(:)/t_soisno(1) - - ! calculate brightness temperature of snow-covered ground - CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_sn, r_snow, tb_tos) - - ! calculate brightness temperature of top of snow - tb_tov = tb_tos + tb_ad*r_snow - tb_tov_noad = tb_tos - - ELSE - ! calculate brightness temperature of snow-covered ground - CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_r, r_snow, tb_tos) - - ! calculate brightness temperature of high vegetation - CALL veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p) - - ! calculate brightness temperature of top of vegetation - DO i = 1, 2 - tb_2(i) = tb_veg(i)*gamma_p(i)*r_snow(i) - tb_3(i) = tb_tos(i)*gamma_p(i) - tb_4(i) = tb_ad(i)*r_snow(i)*(gamma_p(i)**2) - tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i) - tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i) - END DO - END IF - END IF - -!############################################################################# -! Caculate brightness temperature of top-of-atmosphere -!############################################################################# - tb_toa = tb_tov*exp(-tau_atm) + tb_au - - END IF - - tb_toa_h = tb_toa(1) - tb_toa_v = tb_toa(2) - - END SUBROUTINE forward - - -!----------------------------------------------------------------------- - - SUBROUTINE calc_parameters (sat_theta, sat_fghz) - -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_DA_Const - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------- - real(r8), intent(in) :: sat_theta, sat_fghz - -!----------------------- Local Variables ------------------------------- - - theta = sat_theta ! incidence angle of satellite (rad) - fghz = sat_fghz ! frequency of satellite (GHz) - f = fghz*1e9 ! frequency (Hz) - omega = 2.0*pi*f ! radian frequency (rad/s) - lam = C/f ! wavelength (m) - k = 2*pi/lam ! wave number (rad/m) - kcm = k/100.0 ! wave number (rad/cm) - kr = k*(0.5*1e-3) ! size parameter used in calcuate single-particle albedo - - END SUBROUTINE calc_parameters - -!----------------------------------------------------------------------- - - SUBROUTINE atm(z, tref, tau_atm, tb_au, tb_ad) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the atmospheric opacity and up and downwelling brightness temperature -! -! REFERENCES: -! [1] Pellarin, T., et al. (2003), Two-year global simulation of L-band brightness -! temperature over land, IEEE Trans. Geosci. Remote Sens., 41, 2135–2139. -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: z ! altitude (m) - real(r8), intent(in) :: tref ! 2m air temperature (K) - real(r8), intent(out) :: tau_atm ! atmospheric optical depth - real(r8), intent(out) :: tb_au(2) ! upwelling radiation (brightness temperature) of atmosphere - real(r8), intent(out) :: tb_ad(2) ! downwelling radiation (brightness temperature) of atmosphere - -!----------------------- Local Variables ------------------------------- - real(r8) :: t_sky = 2.7 ! cosmic ray radiation (K) - real(r8) :: t_eq ! equivalent layer temperature - real(r8) :: gossat - -!----------------------------------------------------------------------- - - ! calculate optical depth of atmosphere [1] eq(A1) - tau_atm = exp(-3.9262 - 0.2211*z/1000 - 0.00369*tref)/cos(theta) - gossat = exp(-tau_atm) - - ! calculate equivalent layer temperature - t_eq = exp(4.9274 + 0.002195*tref) - - ! upwelling radiation (brightness temperature) of atmosphere - tb_au(:) = t_eq*(1.-gossat) - - ! downwelling radiation (brightness temperature) of atmosphere [1] eq(A2) - tb_ad(:) = t_eq*(1.-gossat) + t_sky*gossat - - END SUBROUTINE atm - -!----------------------------------------------------------------------- - - SUBROUTINE soil( & - patchclass, & - t_surf, t_deep, & - liq_surf, ice_surf, & - wf_sand_surf, wf_clay_surf, BD_all_surf, porsl_surf, & - r_r, tb_soil) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate brightness temperature of soil surface -! -! REFERENCES: -! [1] Wigneron et al., 2007, "L-band Microwave Emission of the Biosphere (L-MEB) Model: -! Description and calibration against experimental -! data sets over crop fields" Remote Sensing of Environment. Vol. 107, pp. 639-655k -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - integer, intent(in) :: patchclass ! land cover class - real(r8), intent(in) :: t_surf ! soil temperature at surface (C) - real(r8), intent(in) :: t_deep ! soil temperature at deep layer (C) - real(r8), intent(in) :: liq_surf ! liquid volumetric water content at surface (m3/m3) - real(r8), intent(in) :: ice_surf ! ice volumetric water content at surface (m3/m3) - real(r8), intent(in) :: wf_sand_surf ! gravimetric sand percent fraction(%) at surface - real(r8), intent(in) :: wf_clay_surf ! gravimetric clay percent fraction(%) at surface - real(r8), intent(in) :: BD_all_surf ! bulk density of soil (g/m3) at surface - real(r8), intent(in) :: porsl_surf ! soil porosity at surface - real(r8), intent(out) :: r_r(2) ! rough surface reflectivity for H and V polarizations - real(r8), intent(out) :: tb_soil(2) ! brightness temperature of soil - -!----------------------- Local Variables ------------------------------- - real(r8) :: t_eff(2) ! effective temperature for H and V polarizations, [K] - complex(r8) :: eps_soil ! dielectric constant of soil for H and V polarizations - real(r8) :: r_s(2) ! smooth surface reflectivity for H and V polarizations - complex(r8) :: ew ! dielectric constant of water - logical :: is_desert ! flag for desert soil - real(r8) :: ffrz ! fraction of frozen soil - complex(r8) :: eps_f = (5.0, 0.5) ! dielectric constant of frozen soil - real(r8) :: sal_soil = 0.0 ! soil salinity (psu) - -!----------------------------------------------------------------------- - - ! whether this patch is desert - is_desert = .false. - IF (liq_surf < 0.02 .and. wf_sand_surf > 90) THEN - is_desert = .true. - END IF - - ! calculate ratio of freezed soil - IF (liq_surf + ice_surf <= 0.0d0) THEN - ffrz = 0.0d0 - ELSE - ffrz = ice_surf / (liq_surf + ice_surf) - ENDIF - - ! caculate effective temperature - CALL eff_soil_temp(liq_surf, t_surf, t_deep, t_eff) - - ! caculate dielectric constant of soil (mixture medium) - IF (is_desert) THEN - ! Microwave 1-10GHz permittivity of dry sand (matzler '98, eq.1) - eps_soil = 2.53 + (2.79 - 2.53)/(1 - jj*(fghz/0.27)) + jj*0.002 - ELSE - ! define bulk density and porosity (CMEM) - ! BD_all_surf = (wf_sand_surf*1.60d0 + wf_clay_surf*1.10d0 + (100.0d0 - wf_sand_surf - wf_clay_surf)*1.20d0)/100.0d0 - ! porsl_surf = 1.0d0 - BD_all_surf/2.660d0 - - ! caculate ice or water dielectric constant - IF (ffrz > 0.95) THEN - CALL diel_ice(t_surf, ew) - ELSE - CALL diel_water(-1, liq_surf, t_surf, wf_sand_surf, wf_clay_surf, BD_all_surf, sal_soil, ew) - END IF - - ! caculate dielectric constant in mixed soil - IF (DEF_DA_RTM_diel == 0) THEN - CALL diel_soil_W80 (ew, t_surf, liq_surf, wf_sand_surf, wf_clay_surf, porsl_surf, eps_soil) - ELSE IF (DEF_DA_RTM_diel == 1) THEN - CALL diel_soil_D85 (ew, liq_surf, wf_sand_surf, wf_clay_surf, BD_all_surf, eps_soil) - ELSE IF (DEF_DA_RTM_diel == 2) THEN - CALL diel_soil_M04 (liq_surf, wf_clay_surf, eps_soil) - ELSE IF (DEF_DA_RTM_diel == 3) THEN - CALL diel_soil_M09 (liq_surf, t_surf, wf_clay_surf, eps_soil) - ENDIF - END IF - - ! mix dielectric constant of frozen and non-frozen soil - eps_soil = eps_soil*(1.-ffrz) + eps_f*ffrz - - ! caculate smooth surface reflectivity - CALL smooth_reflectivity(eps_soil, r_s) - - ! caculate rough surface reflectivity - CALL rough_reflectivity(is_desert, patchclass, r_s, r_r) - - ! calculate brightness temperature - IF (is_desert) THEN - CALL desert(t_eff, r_r, eps_soil, tb_soil) - ELSE - tb_soil = t_eff * (1 - r_r) - END IF - - END SUBROUTINE soil - -!----------------------------------------------------------------------- - - SUBROUTINE eff_soil_temp(wc_surf, t_surf, t_deep, t_eff) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the effective temperature of soil -! -! REFERENCES: -! [1] An improved two-layer algorithm for estimating effective soil -! temperature in microwave radiometry using in situ temperature -! and soil moisture measurements -!----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - -! ------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: wc_surf ! soil moisture at surface (m3/m3) - real(r8), intent(in) :: t_surf ! soil temperature (C) at surface - real(r8), intent(in) :: t_deep ! soil temperature (C) at deep layer - real(r8), intent(out) :: t_eff(2) ! effective temperature for H and V polarizations, [K] - -!----------------------- Local Variables ------------------------------- - real(r8) :: C ! parameter depending mainly on frequency - ! and soil moisture to describe the impact of - ! surface temperature on the effective temperature; - ! soil moisture increase, C large, teff close to tsurf - ! soil moisture decrease, C small, tdeep impact teff more - real(r8) :: w0 = 0.30 ! parameter - real(r8) :: bw = 0.30 ! parameter -!----------------------------------------------------------------------- - - IF (wc_surf < 0.0) THEN - C = 0.001 - ELSE - C = max(0.001, (wc_surf/w0)**bw) - ENDIF - t_eff(:) = t_deep + (t_surf - t_deep)*C + tfrz - - END SUBROUTINE eff_soil_temp - -!----------------------------------------------------------------------- - - SUBROUTINE diel_ice(t, eps_i) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate dielectric constant of pure ice -! -! REFERENCES: -! [1] Matzler, C. (2006). Thermal Microwave Radiation: Applications -! for Remote Sensing p456-461 -!----------------------------------------------------------------------- - USE MOD_Const_Physical - USE MOD_Precision - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: t ! temperature (C) - complex(r8), intent(out) :: eps_i ! dielectric constant of ice water - -!----------------------- Local Variables ------------------------------- - real(r8) :: betam ! beta parameter by Mishima et al. (1983) - real(r8) :: dbeta ! corrected delta beta parameter - real(r8) :: beta ! beta parameter - real(r8) :: t_inv ! modified inverse temperature - real(r8) :: tk ! temperature (K) - real(r8) :: alpha ! alpha parameter - real(r8) :: eps_i_r ! real part of pure ice dielectric constant - real(r8) :: eps_i_i ! imaginary part of pure ice dielectric constant - -!----------------------------------------------------------------------- - - ! C to K - tk = t + tfrz - - ! eq.(5.33): calculate beta parameter by Mishima et al. (1983) - betam = (0.0207/tk)*(exp(335./tk)/((exp(335./tk) - 1.)**2.)) + 1.16e-11*(fghz**2.) ! [1](5.33) - - ! eq.(5.35): calculate delta beta parameter - dbeta = exp(-10.02 + 0.0364*t) ! [1](5.35) - - ! eq.(5.34): calculate beta parameter - beta = betam + dbeta ! [1](5.34) - - ! eq.(5.32): calculate alpha parameter - t_inv = 300./tk - 1 ! [1](p.457) - alpha = (0.00504 + 0.0062*t_inv)*exp(-22.1*t_inv) !(GHz) ! [1](5.32) - - ! eq.(5.30): calculate real part of pure ice dielectric constant - eps_i_r = 3.1884 + 9.1e-4*t ! [1](5.30) - - ! eq.(5.31): calculate imaginary part of pure ice dielectric constant - eps_i_i = alpha/fghz + beta*fghz ! [1](5.31) - - ! calculate dielectric constant of pure ice - eps_i = eps_i_r - jj*eps_i_i ! [1](5.31) - - END SUBROUTINE diel_ice - -!----------------------------------------------------------------------- - - SUBROUTINE diel_water(type, swc, t, wf_sand, wf_clay, BD_all, sal, eps_w) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate dielectric constant of water in water (saline water) -! -! REFERENCES: -! [1] Ulaby FT, R. K. Moore, and A. K. Fung, Microwave Remote Sensing: -! Active and Passive. Vol. III. From theory to applications. Artech House, -! Norwood, MA., 1986 -! [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. -!----------------------------------------------------------------------- - USE MOD_Const_Physical - USE MOD_Precision - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - integer, intent(in) :: type ! type of water, 0: pure water, 1: sea water, 2: soil water - real(r8), intent(in) :: swc ! soil water content (m3/m3) - real(r8), intent(in) :: t ! soil temperature (C) - real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%) - real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) - real(r8), intent(in) :: BD_all ! bulk density(g/cm3) - real(r8), intent(in) :: sal ! water salinity (psu) - complex(r8), intent(out) :: eps_w ! dielectric constant of soil water - -!----------------------- Local Variables ------------------------------- - real(r8) :: sigma ! ionic conductivity (S/m) - real(r8) :: a, b ! parameters - real(r8) :: tau_w ! relaxation time of pure water - real(r8) :: eps_w0 ! static dielectric constant of pure water - real(r8) :: wc - -!----------------------------------------------------------------------- - - ! [3] eq.16: tau(T, sal) = tau_w(T) * b(sal, T) - ! calculate relaxation time of pure water (Stogryn) - tau_w = 1.768e-11 - 6.068e-13*t + 1.104e-14*t**2 - 8.111e-17*t**3 ! [2](17) - b = 1.000 + 2.282e-5*sal*t - 7.638e-4*sal - 7.760e-6*sal**2 + 1.105e-8*sal**3 ! [2](18) - tau_w = tau_w*b ! [2](16) - - ! [3] eq.13: eps_w0(sal, T) = eps_w0(T) * a(sal, T) - ! static dielectric constant of pure water (Klein and Swift) - eps_w0 = 87.134 - 1.949e-1*t - 1.276e-2*t**2 + 2.491e-4*t**3 ! [2](14) - a = 1.000 + 1.613e-5*sal*t - 3.656e-3*sal + 3.210e-5*sal**2 - 4.232e-7*sal**3 ! [2](15) - eps_w0 = eps_w0*a ! [2](13) - - IF (type == 0) THEN ! pure water - ! [1] eq.19 - eps_w0 = 88.045 - 0.4147*t + 6.295e-4*t**2 + 1.075e-5*t**3 - eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) - - ELSEIF (type == 1) THEN ! sea water - ! calculate ionic conductivity [1] eq.27, eq.28 - sigma = sal*(0.182521 - 1.46192e-3*sal + 2.09324e-5*sal**2 - 1.28205e-7*sal**3) & - *exp(-1.*(25 - t)* & - (2.033e-2 + 1.266e-4*(25 - t) + 2.464e-6*(25 - t)**2 & - - sal*(1.849e-5 - 2.551e-7*(25 - t) + 2.551e-8*(25 - t)**2))) - - ! diel constant of sea water [1] eq.21 - eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) + jj*sigma/(omega*eps_0) - ELSE - ! calculate soil conductivity - sigma = -1.645 + 1.939*BD_all - 0.02256*wf_sand + 0.01594*wf_clay - IF (sigma < 0.) THEN - sigma = 0. ! negative for very sandy soils with low bulk density - END IF - - ! calculate dielectric constant of soil-water by modified Debye expression - wc = max(0.001, swc) - eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) & - + jj*sigma/(omega*eps_0)*(rho_soil - BD_all)/(rho_soil*wc) - END IF - - END SUBROUTINE diel_water - -!----------------------------------------------------------------------- - - SUBROUTINE diel_soil_W80(ew, t, wc, wf_sand, wf_clay, porsl, eps) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the dielectric constant of a wet soil -! -! REFERENCES: -! [1] Matzler, C. (1998). Microwave permittivity of dry sand. -! IEEE Transactions on Geoscience and Remote Sensing, 36(1), 317-319. -! -! [2] 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. -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -! ------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: t ! soil temperature (C) - real(r8), intent(in) :: wc ! volumetric soil moisture (m3/m3) - real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%) - real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) - real(r8), intent(in) :: porsl ! soil porosity at surface - complex(r8), intent(in) :: ew ! dielectric constant of water - complex(r8), intent(out) :: eps - -!----------------------- Local Variables ------------------------------- - real(r8) :: wp ! wilting point - real(r8) :: wt ! transition moisture point (cm3/cm3) - real(r8) :: gamma ! fitting parameter - real(r8) :: ecl ! conductivity loss - real(r8) :: alpha ! conductivity loss parameter - real(r8) :: sal_sea = 32.5 ! sea water salinity (psu) - real(r8) :: sal_soil = 0.0 ! soil salinity (psu) - complex(r8) :: eps_x ! dielectric constant of the initially absorbed water - complex(r8) :: eps_a = (1.0, 0.0) ! dielectric constant of air, [2]IV - complex(r8) :: eps_r = (5.5, 0.2) ! dielectric constant of rock, [2]IV - complex(r8) :: eps_i = (3.2, 0.1) ! dielectric constant of ice, [2]IV - complex(r8) :: eps_f = (5.0, 0.5) ! dielectric constant of frozen soil - -!----------------------------------------------------------------------- - - ! calculate wilting point at the soil layer - wp = 0.06774 - 0.00064*wf_sand + 0.00478*wf_clay ! [2](1) - - ! calculate fitting parameters - gamma = -0.57*wp + 0.481 ! [2](8) - - ! calculate transition moisture point - wt = 0.49*wp + 0.165 ! [2](9) - - ! calculate dielectric constant of wet soil (when all soil freeze, eps_x = eps_i) - IF (wc <= wt) THEN - eps_x = eps_i + (ew - eps_i)*(wc/wt)*gamma ! [2](3) - eps = wc*eps_x + (porsl - wc)*eps_a + (1.-porsl)*eps_r ! [2](2) - ELSE - eps_x = eps_i + (ew - eps_i)*gamma ! [2](5) - eps = wt*eps_x + (wc - wt)*ew + (porsl - wc)*eps_a + (1.-porsl)*eps_r ! [2](4) - END IF - - ! add conductivity loss for imaginary part - alpha = min(100.*wp, 26.) - ecl = alpha*wc**2 ! [2](6) - eps = eps + jj*ecl ! [2](6) - - END SUBROUTINE diel_soil_W80 - -!----------------------------------------------------------------------- - - SUBROUTINE diel_soil_M04(wc, wf_clay, eps) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the dielectric constant of a wet soil Developed and -! validated from 1 to 10 GHz, adapted for a large range of soil moisture -! -! REFERENCES: -! [1] Mironov et al, Generalized Refractive Mixing Dielectric Model for -! moist soil. IEEE Trans. Geosc. Rem. Sens., vol 42 (4), 773-785. 2004. -! -! [2] Mironov et al, Physically and Mineralogically Based Spectroscopic -! Dielectric Model for Moist Soils. IEEE Trans. Geosc. Rem. Sens., -! vol 47 (7), 2059-2070. 2009. -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -! ------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: wc ! soil moisture (m3/m3) - real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) - complex(r8), intent(out) :: eps - -!----------------------- Local Variables ------------------------------- - real(r8) :: znd, zkd, zxmvt, zep0b, ztaub, zsigmab, zep0u, ztauu - real(r8) :: zsigmau, zcxb, zepwbx, zepwby, zcxu, zepwux, zepwuy - real(r8) :: znb, zkb, znu, zku, zxmvt2, znm, zkm, zepmx, zepmy - integer :: zflag - -!----------------------------------------------------------------------- -!------------------------------------------------------------------------ -! Initializing the GRMDM spectroscopic parameters with clay (fraction) -!------------------------------------------------------------------------ - ! RI & NAC of dry soils - znd = 1.634 - 0.539 * (wf_clay/100) + 0.2748 * (wf_clay/100) ** 2 - zkd = 0.03952 - 0.04038 * (wf_clay / 100) ! [2](18) - - ! Maximum bound water fraction - zxmvt = 0.02863 + 0.30673 * wf_clay / 100 ! [2](19) - - ! Bound water parameters - zep0b = 79.8 - 85.4 * (wf_clay / 100) + 32.7 * (wf_clay / 100)*(wf_clay / 100) ! [2](20) - ztaub = 1.062e-11 + 3.450e-12 * (wf_clay / 100) ! [2](21) - zsigmab = 0.3112 + 0.467 * (wf_clay / 100) ! [2](22) - - ! Unbound (free) water parameters - zep0u = 100 ! [2](24) - ztauu = 8.5e-12 ! [2](25) - zsigmau = 0.3631 + 1.217 * (wf_clay / 100) - - ! Computation of epsilon water (bound & unbound) - zcxb = (zep0b - eps_w_inf) / (1. + (2.*pi*f*ztaub)**2) ! [2](16) - zepwbx = eps_w_inf + zcxb ! [2](16) - zepwby = zcxb * (2.*pi*f*ztaub) + zsigmab / (2.*pi*eps_0*f) ! [2](16) - zcxu = (zep0u - eps_w_inf) / (1 + (2*pi*f*ztauu)**2) ! [2](16) - zepwux = eps_w_inf + zcxu ! [2](16) - zepwuy = zcxu * (2.*pi*f*ztauu) + zsigmau/(2.*pi*eps_0*f) - - ! Computation of refractive index of water (bound & unbound) - znb = sqrt( sqrt( zepwbx**2 + zepwby**2) + zepwbx ) / sqrt(2.0) ! [2](14) - zkb = sqrt( sqrt( zepwbx**2 + zepwby**2) - zepwbx ) / sqrt(2.0) ! [2](15) - znu = sqrt( sqrt( zepwux**2 + zepwuy**2) + zepwux ) / sqrt(2.0) ! [2](14) - zku = sqrt( sqrt( zepwux**2 + zepwuy**2) - zepwux ) / sqrt(2.0) ! [2](15) - - ! Computation of soil refractive index (nm & km): xmv can be a vector - zxmvt2 = min (wc, zxmvt) - zflag = 0 - IF ( wc >= zxmvt ) zflag = 1 - znm = znd + (znb - 1) * zxmvt2 + (znu - 1) * (wc-zxmvt) * zflag ! [2](12) - zkm = zkd + zkb * zxmvt2 + zku * (wc-zxmvt) * zflag ! [2](13) - - ! computation of soil dielectric constant: - zepmx = znm ** 2 - zkm ** 2 ! [2](11) - zepmy = znm * zkm * 2 ! [2](11) - eps = cmplx(zepmx, zepmy, kind=r8) - - END SUBROUTINE diel_soil_M04 - -!----------------------------------------------------------------------- - - SUBROUTINE diel_soil_M09(wc, t, wf_clay, eps) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the dielectric constant of a wet soil Developed and -! validated from 1 to 10 GHz, adapted for a large range of soil moisture -! -! REFERENCES: -! [1] V. L. Mironov, S. V. Fomin, -! "Temperature and mineralogy dependable model for microwave dielectric -! spectra of moist soils", PIERS Online, vol. 5, no. 5, pp. 411-415, 2009. -! -! [2] Mironov et al, Physically and Mineralogically Based Spectroscopic Dielectric -! Model for Moist Soils. IEEE Trans. Geosc. Rem. Sens., vol 47 (7), 2059-2070. 2009. -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -! ------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: t ! soil temperature - real(r8), intent(in) :: wc ! soil moisture (m3/m3) - real(r8), intent(in) :: wf_clay ! weighted fraction (%) - complex(r8), intent(out) :: eps - -!----------------------- Local Variables ------------------------------- - real(r8) :: nd, kd, mvt, ts, e0b, Bb, Bsgb, Fb, eb0 - real(r8) :: dSbR, taub, sigmabt, sigmab, e0u, Bu, Bsgu, Fu, eu0, dHuR, dSuR, tauu, dHbR - real(r8) :: sigmau, sigmaut, cxb, eb_r, eb_i, cxu, eu_r, eu_i, nb, kb, nu, ku, nm, km, eps_r, eps_i - -!----------------------------------------------------------------------- -!------------------------------------------------------------------------ -! Initializing the GRMDM spectroscopic parameters with clay (fraction) -!------------------------------------------------------------------------ - ! RI & NAC of dry soils - nd = 1.634 - 0.539 * (wf_clay/100) + 0.2748 * (wf_clay/100) ** 2 ! [1](11) - kd = 0.03952 - 0.04038 * (wf_clay/100) ! [1](12) - - ! maximum bound water fraction - mvt = 0.02863 + 0.30673 * (wf_clay/100) ! [1](13) - - ! starting temperature for parameters' fit ([1] p.413) - ts = 20. - - ! eb0 computation - e0b = 79.8 - 85.4 * wf_clay + 32.7 * (wf_clay/100) **2 ! [1](14) - Bb = 8.67e-19 - 0.00126 * (wf_clay/100) + 0.00184 * (wf_clay/100) ** 2 - 9.77e-10*(wf_clay**3) - 1.39e-15 *(wf_clay**4) ! [1](15) - Bsgb = 0.0028 + 0.02094e-2*wf_clay - 0.01229e-4*(wf_clay**2) - 5.03e-22*(wf_clay**3) + 4.163e-24*(wf_clay**4) ! [1](23) - Fb = log((e0b - 1)/(e0b + 2)) ! [1](8)(ep0->e0p) - eb0 = (1 + 2*exp(Fb-Bb*(t-ts))) / (1 - exp(Fb-Bb*(t-ts))) ! [1](7)(e0p->ep0) - - ! taub computation - dHbR = 1467 + 2697e-2*wf_clay - 980e-4 *(wf_clay**2) + 1.368e-10*(wf_clay**3) - 8.61e-13 *(wf_clay**4) ! [1](18) - dSbR = 0.888 + 9.7e-2 *wf_clay - 4.262e-4*(wf_clay**2) + 6.79e-21 *(wf_clay**3) + 4.263e-22*(wf_clay**4) ! [1](19) - taub = 48e-12 * exp(dHbR/(t+tfrz)-dSbR)/(t+tfrz) ! [1](9) - - ! sigmab computation - sigmabt = 0.3112 + 0.467e-2*wf_clay ! [1](22) - sigmab = sigmabt + Bsgb*(t-ts) ! [1](10) - - ! unbound (free) water parameters - !------------------- - ! eu0 computation - !------------------- - e0u = 100. ! [1](16) - Bu = 1.11e-4 - 1.603e-7 *wf_clay + 1.239e-9 *(wf_clay**2) + 8.33e-13 *(wf_clay**3) - 1.007e-14*(wf_clay**4) ! [1](17) - Bsgu = 0.00108 + 0.1413e-2*wf_clay - 0.2555e-4*(wf_clay**2) + 0.2147e-6*(wf_clay**3) - 0.0711e-8*(wf_clay**4) ! [1](25) - Fu = log((e0u - 1)/(e0u + 2)) ! [1](8)(ep0->e0p) - eu0 = (1 + 2*exp(Fu-Bu*(t-ts))) / (1-exp(Fu-Bu*(t-ts))) ! [1](7))e0p->ep0) - - !-------------------- - ! tauu computation - !-------------------- - dHuR = 2231 - 143.1e-2 *wf_clay + 223.2e-4*(wf_clay**2) - 142.1e-6*(wf_clay**3) + 27.14e-8 *(wf_clay**4) ! [1](20) - dSuR = 3.649 - 0.4894e-2*wf_clay + 0.763e-4*(wf_clay**2) - 0.4859e-6*(wf_clay**3) + 0.0928e-8*(wf_clay**4) ! [1](21) - tauu = 48e-12 * exp(dHuR/(t+tfrz)-dSuR)/(t+tfrz) ! [1](9) - - !---------------------- - ! sigmau computation - !---------------------- - sigmaut = 0.05_r8 + 1.4_r8*(1.0_r8 - (1.0_r8 - wf_clay*1.e-2_r8)**4.664_r8) ! [1](24) - sigmau = sigmaut + Bsgu*(t-ts) ! [1](10) - - !-------------------------------------------------- - ! computation of epsilon water (bound & unbound) - !-------------------------------------------------- - cxb = (eb0-eps_w_inf) / (1+(2*pi*f*taub)**2) ! [1](6), [2](16) - eb_r = eps_w_inf + cxb ! [1](6), [2](16) - eb_i = cxb*(2*pi*f*taub) + sigmab/(2*pi*eps_0*f) ! [1](6), [2](16) - cxu = (eu0-eps_w_inf) / (1+(2*pi*f*tauu)**2) ! [1](6), [2](16) - eu_r = eps_w_inf + cxu ! [1](6), [2](16) - eu_i = cxu*(2*pi*f*tauu) + sigmau/(2*pi*eps_0*f) ! [1](6), [2](16) - - !-------------------------------------------------------------- - ! computation of refractive index of water (bound & unbound) - !-------------------------------------------------------------- - nb = sqrt(sqrt(eb_r**2+eb_i**2)+eb_r) / sqrt(2.0) ! [1](5) - kb = sqrt(sqrt(eb_r**2+eb_i**2)-eb_r) / sqrt(2.0) ! [1](5) - nu = sqrt(sqrt(eu_r**2+eu_i**2)+eu_r) / sqrt(2.0) ! [1](5) - ku = sqrt(sqrt(eu_r**2+eu_i**2)-eu_r) / sqrt(2.0) ! [1](5) - - !-------------------------------------------------- - ! computation of soil refractive index (nm & km) - !-------------------------------------------------- - IF (wc <= mvt) THEN - nm = nd + (nb-1)*wc ! [2](12) - km = kd + kb*wc ! [2](13) - ELSE - nm = nd + (nb-1)*mvt + (nu-1)*(wc-mvt) ! [2](12) - km = kd + kb*mvt + ku*(wc-mvt) ! [2](13) - ENDIF - - !------------------------------------------- - ! computation of soil dielectric constant - !------------------------------------------- - eps_r = nm**2 - km**2 ! [1](4) - eps_i = 2* nm * km ! [1](4) - eps = cmplx(eps_r, eps_i, kind=r8) - - END SUBROUTINE diel_soil_M09 - -!----------------------------------------------------------------------- - - SUBROUTINE diel_soil_D85(ew, swc, wf_sand, wf_clay, BD_all, eps) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the dielectric constant of a wet soil Developed and validated for 1.4 and 18 GHz. - -! REFERENCES: -! [1] Dobson et al., 1985: Microwave Dielectric behavior of -! wet soil - part II: Dielectric mixing models, -! IEEE Trans. Geosc. Rem. Sens., GE-23, No. 1, 35-46. - -! [2] N. R. Peplinski, F. T. Ulaby, and M. C. Dobson, -! Dielectric Properties of Soils in the 0.3-1.3-GHz Range, -! IEEE Trans. Geosc. Rem. Sens., vol. 33, pp. 803-807, May 1995 - -! [3] N. R. Peplinski, F. T. Ulaby, and M. C. Dobson, -! Corrections to “Dielectric Properties of Soils in the 0.3-1.3-GHz Range", -! IEEE Trans. Geosc. Rem. Sens., vol. 33, p. 1340, November 1995 - -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -! ------------------------ Dummy Argument ------------------------------ - complex(r8), intent(in) :: ew ! dielectric constant of water - real(r8), intent(in) :: swc ! soil moisture - real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%) - real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%) - real(r8), intent(in) :: BD_all ! soil bulk density (g/cm3) - complex(r8), intent(out) :: eps - -!----------------------- Local Variables ------------------------------- - real(r8) :: alphas = 0.65_r8 - real(r8) :: beta, eaa, eps_s, epsi, epsr, wc - -!----------------------------------------------------------------------- - - wc = max(swc, 0.001_r8) - eps_s = (1.01_r8 + 0.44_r8 * rho_soil)**2.0_r8 - 0.062_r8 ! [1](22) - beta = (127.48_r8 - 0.519_r8 * wf_sand - 0.152_r8 * wf_clay) / 100.0_r8 ! [1](30) - eaa = 1.0_r8 + (BD_all / rho_soil) * (eps_s ** alphas - 1.0_r8) & - & + (wc ** beta) * (real(ew) ** alphas) - wc ! [1](28) - epsr = eaa ** (1.0_r8/alphas) ! [2](2),[3] - beta = (133.797_r8 - 0.603_r8 * wf_sand - 0.166_r8 * wf_clay) / 100.0_r8 ! [1](31) 1.33797 -> 133.797, [2](5) - eaa = (wc ** beta) * (abs(aimag(ew)) ** alphas) ! [2](3) - epsi = eaa ** (1.0_r8/alphas) ! [2](3) - eps = cmplx(epsr, epsi, kind=r8) - - END SUBROUTINE diel_soil_D85 - -!----------------------------------------------------------------------- - - SUBROUTINE smooth_reflectivity(eps, r_s) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the smooth surface reflectivity by Fresnel Law -! -! REFERENCES: -! [1] Njoku and Kong, 1977: Theory for passive microwave remote sensing -! of near-surface soil moisture. Journal of Geophysical Research, -! Vol. 82, No. 20, 3108-3118. -!----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - complex(r8), intent(in) :: eps ! dielectric constant of the surface - real(r8), intent(out) :: r_s(2) ! reflectivities of flat surfaces for H and V polarizations - -!----------------------- Local Variables ------------------------------- - complex(r8) :: g ! parameter in Fresnel Law - -!----------------------------------------------------------------------- - - g = sqrt(eps - sin(theta)**2) - r_s(1) = abs((cos(theta) - g)/(cos(theta) + g))**2. - r_s(2) = abs((cos(theta)*eps - g)/(cos(theta)*eps + g))**2. - - END SUBROUTINE smooth_reflectivity - -!----------------------------------------------------------------------- - - SUBROUTINE rough_reflectivity(is_desert, patchclass, r_s, r_r) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the rough surface reflectivity -! -! REFERENCES: -! [1] Kerr and Njokui, 1990: A Semiempirical Model For Interpreting Microwave -! Emission From Semiarid Land Surfaces as Seen From Space -! IEEE Trans. Geosci. Rem. Sens., Vol.28, No.3, 384-393. -! -! [2] Wigneron, J. P., Jackson, T. J., O'neill, P., De Lannoy, G., de Rosnay, P., Walker, -! J. P., ... & Kerr, Y. (2017). Modelling the passive microwave signature from land surfaces: -! A review of recent results and application to the L-band SMOS & SMAP soil moisture retrieval algorithms. -! Remote Sensing of Environment, 192, 238-262. -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_DA_Const - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - logical, intent(in) :: is_desert ! flag for desert soil - integer, intent(in) :: patchclass ! patch class - real(r8), intent(in) :: r_s(2) ! reflectivities of flat surfaces for H and V polarizations - real(r8), intent(out) :: r_r(2) ! reflectivities of rough surfaces for H and V polarizations - -!----------------------- Local Variables ------------------------------- - real(r8) :: Q ! parameter for polarization mixing - real(r8) :: hr(N_land_classification) ! roughness parameter - real(r8) :: nrh(N_land_classification) ! parameter for H polarization - real(r8) :: nrv(N_land_classification) ! parameter for V polarization - -!----------------------------------------------------------------------- - - IF (is_desert) THEN - r_r = r_s - ELSE - ! calculate parameter for polarization mixing due to surface roughness - IF (fghz < 2.) THEN - Q = 0. ! Q is assumed zero at low frequency - ELSE - Q = 0.35*(1.0 - exp(-0.6*rgh_surf**2*fghz)) ! [1](16) - END IF - - ! calculate rough surface reflectivity (default settings used in [2]) - IF (DEF_DA_RTM_rough == 0) THEN - hr(:) = (2.0*kcm*rgh_surf)**2.0 - nrh(:) = 0.0 - nrv(:) = 0.0 - ELSE IF (DEF_DA_RTM_rough == 1) THEN - hr(:) = hr_SMOS - nrh(:) = 2.0 - nrv(:) = 0.0 - ELSE IF (DEF_DA_RTM_rough == 2) THEN - hr(:) = hr_SMAP - nrh(:) = 2.0 - nrv(:) = 2.0 - ELSE IF (DEF_DA_RTM_rough == 3) THEN - hr(:) = hr_P16 - nrh(:) = -1.0 - nrv(:) = -1.0 - END IF - - ! rough surface reflectivity for H and V polarizations - r_r(1) = (Q*r_s(2) + (1.-Q)*r_s(1))*exp(-hr(patchclass)*cos(theta)**nrh(patchclass)) - r_r(2) = (Q*r_s(1) + (1.-Q)*r_s(2))*exp(-hr(patchclass)*cos(theta)**nrv(patchclass)) - END IF - - END SUBROUTINE rough_reflectivity - -!----------------------------------------------------------------------- - - SUBROUTINE desert(t_soil, r_r, eps, tb_desert) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate desert emissivity using Grody and Weng, 2008 -! -! REFERENCES: -! [1] Grody, N. C., & Weng, F. (2008). Microwave emission and scattering from deserts: -! Theory compared with satellite measurements. -! IEEE Transactions on Geoscience and Remote Sensing, 46, 361–375. -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: t_soil(2) ! desert surface temperature (K) (h-pol and v-pol) - real(r8), intent(in) :: r_r(2) ! reflectivity of rough surface (h-pol and v-pol) - complex(r8), intent(in) :: eps ! diel. const of desert - real(r8), intent(out) :: tb_desert(2) ! brightness temperature of soil for H- and V- polarization - -!----------------------- Local Variables ------------------------------- - real(r8) :: f0 = 0.7 ! the fractional volume of spherical particles - ! (f = (4/3)*pi*r^3*n0), - ! r : the particle radius = 0.5 (mm) - ! n0 : the number of particles per unit volume. - real(r8) :: w ! single-particle albedo - real(r8) :: g ! asymmetry parameter - real(r8) :: a ! similarity parameter - real(r8) :: em(2) ! desert soil emissivity - real(r8) :: y_r ! real part of y-parameters - real(r8) :: y_i ! imaginary part of y-parameters - -!----------------------------------------------------------------------- - ! calculate y-parameters (eq.A15) - y_r = (real(eps) - 1)/(real(eps) + 2) ! [1](A15) - y_i = 3*aimag(eps)/(real(eps) + 2)**2 ! [1](A15) - - ! calculate single-particle albedo (eq.A16) - w = (1 - f0)**4*kr**3*y_r**2/ & - ((1 - f0)**4*kr**3*y_r**2 + 1.5*(1 + 2*f0)**2*y_i) ! [1](A16) - - ! calculate asymmetry parameter (p.374) - g = 0.23*kr**2 ! [1]p.374 - - ! calculate similarity parameter (eq.3b) - a = sqrt((1 - w)/(1 - w*g)) ! [1](3b) - - ! calculate desert soil emissivity (eq.A13) - em = (1 - r_r)*(2*a/((1 + a) - (1 - a)*r_r)) ! [1](13) - - ! calculate brightness temperature of desert - tb_desert = t_soil*em - - END SUBROUTINE desert - -!----------------------------------------------------------------------- - - SUBROUTINE veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the brightness temperature on the top of vegetation -! -! REFERENCES: -! [1] Wigneron et al., 2007, "L-band Microwave Emission of the Biosphere (L-MEB) Model: -! Description and calibration against experimental -! data sets over crop fields" Remote Sensing of Environment. Vol. 107, pp. 639-655k -! -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - integer, intent(in) :: patchclass ! land cover class - real(r8), intent(in) :: lai ! leaf area index - real(r8), intent(in) :: tleaf ! leaf temperature (K) - real(r8), intent(out) :: tb_veg(2) ! brightness temperature of vegetation for H- and V- polarization - real(r8), intent(out) :: gamma_p(2) ! vegetation opacity for H- and V- polarization - real(r8), intent(in) :: htop, snowdp - -!----------------------- Local Variables ------------------------------- - real(r8) :: tau_nadir ! vegetation opacity at nadir - real(r8) :: tau_veg(2) ! vegetation opacity for H- and V- polarization - integer :: i - -!----------------------------------------------------------------------- - - ! caculate vegetation opacity (optical depth) at nadir b*VWC - IF (htop < snowdp) THEN - tau_nadir = b1(patchclass)*lai + b2(patchclass) ! low veg ! [1](22) - ELSE - tau_nadir = b3(patchclass) ! high veg - END IF - - ! calculate vegetation optical depth at H- and V- polarizations - tau_veg(1) = tau_nadir*(cos(theta)**2 + tth(patchclass)*sin(theta)**2) ! [1](23) - tau_veg(2) = tau_nadir*(cos(theta)**2 + ttv(patchclass)*sin(theta)**2) ! [1](24) - - ! calculate brightness temperature of vegetation - DO i = 1, 2 - gamma_p(i) = exp(-tau_veg(i)/cos(theta)) ! [1](15) - tb_veg(i) = (1.-w_CMEM(patchclass))*(1.-gamma_p(i))*tleaf - END DO - - END SUBROUTINE veg - -!----------------------------------------------------------------------- - - SUBROUTINE snow(t_snow, t, snowdp, rho_snow, liq_snow, r_sn, r_snow, tb_tos) - -!----------------------------------------------------------------------- -! DESCRIPTION: -! Calculate the brightness temperature of snow-covered ground -! -! REFERENCES: -! [1] Christian Mätzler (1987) Applications of the interaction of -! microwaves with the natural snow cover, Remote Sensing Reviews, 2:2, 259-387, DOI: -! 10.1080/02757258709532086 -! -! [2] Anderson, E. A., 1976: A point energy and mass balance model of a snow cover. -! NOAA Tech. Rep. NWS 19, 150 pp. U.S. Dept. of Commer., Washington, D.C.(eq.5.1) -! -! [3] Hallikainen, M. T., F. Ulaby, and T. Deventer. 1987. Extinction behavior of dry snow in the -! 18- to 90-GHz range. IEEE Trans. Geosci. Remote Sens., GE-25, 737–745. -! -! [4] Microwave remote sensing : active and passive -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Const_Physical - IMPLICIT NONE - -!------------------------ Dummy Argument ------------------------------ - real(r8), intent(in) :: t_snow ! average snow temperature (K) - real(r8), intent(in) :: t ! temperature at bottom of snow (K), i.e., soil or leaf - real(r8), intent(in) :: snowdp ! snow depth (m) - real(r8), intent(in) :: rho_snow ! snow density (g/cm3) - real(r8), intent(in) :: liq_snow ! snow liquid water content (cm3/cm3) - real(r8), intent(in) :: r_sn(2) ! reflectivity between the snow and ground at (1, H-POL. 2, V.) - real(r8), intent(out) :: r_snow(2) ! reflectivity between the snow and air for H- and V- polarization - real(r8), intent(out) :: tb_tos(2) ! brightness temperature of snow-cover ground for H- and V- polarization - -!----------------------- Local Variables ------------------------------- - real(r8) :: sal_snow = 0.0 ! snow salinity (pmm) - real(r8) :: eps_i_r ! real part of dielectric constant of ice - real(r8) :: eps_i_i ! imaginary part of dielectric constant of ice - real(r8) :: eps_i_is ! imaginary part of dielectric constant of impure ice -5(C) - real(r8) :: eps_i_ip ! imaginary part of dielectric constant of pure ice -5(C) - real(r8) :: eps_ds_r ! real part of dielectric constant of dry snow - real(r8) :: eps_ds_i ! imaginary part of dielectric constant of dry snow - real(r8) :: eps_ws_i ! imaginary part of dielectric constant of wet snow - real(r8) :: eps_ws_r ! real part of dielectric constant of wet snow - real(r8) :: eps_w_s = 88. ! dielectric constant of static water - real(r8) :: eps_a_inf, eps_b_inf, eps_c_inf ! infinite frequency dielectric constant of three parts - real(r8) :: eps_a_s, eps_b_s, eps_c_s ! static dielectric constant of three parts - complex(r8) :: eps_i ! dielectric constant of ice - complex(r8) :: eps_a - complex(r8) :: eps_b - complex(r8) :: eps_c ! dielectric constant of three parts - complex(r8) :: eps ! dielectric constant of wet snow - real(r8) :: rho_ds ! density of dry snow (g/cm3) - real(r8) :: rho_i = 0.916 ! density of ice (g/cm3) - real(r8) :: aa = 0.005 - real(r8) :: bb = 0.4975 - real(r8) :: cc = 0.4975 ! fitting parameters - real(r8) :: fa, fb, fc ! relaxation frequency of wet snow - real(r8) :: d ! snow grain size (mm) - real(r8) :: alpha, beta, pp, qq ! parameter used to calculate propogation angle in snow - real(r8) :: theta_s ! propogation angle in snow - complex(r8) :: z_s ! wave impedance in snow - real(r8) :: r_sa ! reflectivity between the snow and air for H- and V- polarization - real(r8) :: tb_2 ! the net apparent temperature contributions due to emission by layers 2 (snow) - real(r8) :: tb_3 ! the net apparent temperature contributions due to emission by layers 3 (soil) - real(r8) :: l2_apu ! extinction coefficient of snow (Beer's Law) - real(r8) :: q = 0.96 ! parameter - real(r8) :: ka_ws ! absorption coefficient of wet snow - real(r8) :: ka_ds ! absorption coefficient of dry snow - real(r8) :: ke ! extinction coefficient of wet snow - real(r8) :: ke_ds ! extinction coefficient of dry snow - real(r8) :: ks ! scattering coefficient of snow - real(r8) :: b_ds, b_ws - real(r8) :: wk_h ! [m], equal to cmem cmem_snow_set_var.F90:476 - integer :: i - -!----------------------------------------------------------------------- - IF (snowdp > 0.01) THEN ! > 1cm - ! calculate dielectric constant of ice - CALL diel_ice(t_snow - tfrz, eps_i) - eps_i_r = real(eps_i) - eps_i_i = aimag(eps_i) - - ! consider the effect of salinity on the dielectric constant of ice - eps_i_is = 0.0026/fghz + 0.00023*(fghz**0.87) ! impure ice -5(C) - eps_i_ip = 6.e-4/fghz + 6.5e-5*(fghz**1.07) ! pure ice -5(C) - eps_i_i = eps_i_i + (eps_i_is - eps_i_ip)*sal_snow/13.0d0 ! corrected imaginary part of diel cons of ice - - ! calculate dielectric constant of dry snow (mixed by air and ice) (Polder–van Santen mixing model) - rho_ds = (rho_snow - liq_snow)/(1.0 - liq_snow) ! caculate density of dry snow, - eps_ds_r = 1.0 + 1.58*rho_ds/(1.0 - 0.365*rho_ds) - eps_ds_i = 3.0*(rho_ds/rho_i)*eps_i_i*(eps_ds_r**2)*(2*eps_ds_r + 1)/ & - ((eps_i_r + 2*eps_ds_r)*(eps_i_r + 2*eps_ds_r**2)) ! negative imaginary part of diel cons of dry snow - - ! calculate dielectric constant of wet snow (Matzler 1987) - IF (liq_snow > 0.) THEN ! wet snow - ! caculate relaxation frequency of three parts (eq.2.26) - fa = f0w*(1 + (aa*(eps_w_s - eps_w_inf)/(eps_ds_r + (aa*(eps_w_inf - eps_ds_r))))) - fb = f0w*(1 + (bb*(eps_w_s - eps_w_inf)/(eps_ds_r + (bb*(eps_w_inf - eps_ds_r))))) - fc = f0w*(1 + (cc*(eps_w_s - eps_w_inf)/(eps_ds_r + (cc*(eps_w_inf - eps_ds_r))))) - - ! caculate infinite frequency dielectric constant of three parts - eps_a_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ & - (1.+aa*((eps_w_inf/eps_ds_r) - 1.)) - eps_b_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ & - (1.+bb*((eps_w_inf/eps_ds_r) - 1.)) - eps_c_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ & - (1.+cc*((eps_w_inf/eps_ds_r) - 1.)) - - ! caculate static dielectric constant of three parts - eps_a_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ & - (1.+aa*((eps_w_s/eps_ds_r) - 1.)) - eps_b_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ & - (1.+bb*((eps_w_s/eps_ds_r) - 1.)) - eps_c_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ & - (1.+cc*((eps_w_s/eps_ds_r) - 1.)) - - ! Debye equations - eps_a = eps_a_inf + (eps_a_s - eps_a_inf)/(1 + jj*fghz/fa) - eps_b = eps_b_inf + (eps_b_s - eps_b_inf)/(1 + jj*fghz/fb) - eps_c = eps_c_inf + (eps_c_s - eps_c_inf)/(1 + jj*fghz/fc) - - ! calculate dielectric constant of wet snow - eps = eps_a + eps_b + eps_c + (eps_ds_r - jj*eps_ds_i) - eps_ws_r = real(eps) - eps_ws_i = -1.*aimag(eps) - ELSE - eps_ws_r = eps_ds_r - eps_ws_i = eps_ds_i - END IF - - ! caculate propogation angle in snow (change medium from air to snow) - alpha = k*abs(aimag(sqrt(eps_ws_r - jj*eps_ws_i))) - beta = k*real(sqrt(eps_ws_r - jj*eps_ws_i)) - pp = 2.*alpha*beta - qq = beta**2 - alpha**2 - (k*k)*(sin(theta)**2) - theta_s = atan(k*sin(theta)/((1./sqrt(2.)) & - *sqrt(sqrt(pp**2.+qq**2.) + qq))) - - ! caclulate wave impedance in snow - z_s = z0/sqrt(eps_ws_r - jj*eps_ws_i) - - ! calculate brightness temperature above snow for H- V- polarization - DO i = 1, 2 - ! Fresnel reflection coefficient between snow and air - IF (i == 1) THEN - r_sa = abs((z_s*cos(theta) - z0*cos(theta_s))/ & - (z_s*cos(theta) + z0*cos(theta_s)))**2 - ELSE - r_sa = abs((z0*cos(theta) - z_s*cos(theta_s))/ & - (z0*cos(theta) + z_s*cos(theta_s)))**2 - END IF - - ! calculate snow grain size (mm) (Anderson 1976, eq.5.1) TODO - d = min(1000*(1.6e-4 + 1.1e-13*((rho_snow*1000.0)**4)), 3.0) - - ! extinction coefficient of dry snow - !//TODO: the paper is not focus on L-band, thus the formula is not suitable - ke_ds = 0.0018*(fghz**2.8)*(d**2)/4.3429 ! [3](14) - - ! absorption coefficient of dry snow - b_ds = (eps_ds_i/eps_ds_r)**2 - ka_ds = 2.*omega*sqrt(mu0*eps_0*eps_ds_r)* & - sqrt(b_ds/(2.*(sqrt(1.+b_ds) + 1.))) - - IF (ke_ds < ka_ds) ke_ds = ka_ds - - ! absorption coefficient of wet snow - b_ws = (eps_ws_i/eps_ws_r)**2 - ka_ws = 2.*omega*sqrt(mu0*eps_0*eps_ws_r)* & - sqrt(b_ws/(2.*(sqrt(1.+b_ws) + 1))) - - ! total extinction (assuming scattering is the same for dry and wet snow) - ke = (ke_ds - ka_ds) + ka_ws - - ! scattering coefficient of dry and wet snow - ks = ke_ds - ka_ds - - wk_h = snowdp/rho_snow - IF (((ke - q*ks)*(1./cos(theta_s))*wk_h) > (log(HUGE(1.)) - 1.)) THEN - l2_apu = sqrt(HUGE(1.)) - ELSE - l2_apu = min(sqrt(HUGE(1.)), exp((ke - q*ks)*(1./cos(theta_s))*wk_h)) - END IF - - ! brightness temperature through snow-air layer ([4] pp.243, eq.4.161) - tb_2 = (1.+r_sn(i)/l2_apu)*(1.-r_sa)*t_snow* & - (ka_ws/(ke - q*ks))*(1.-1./l2_apu)/ & - (1.-r_sn(i)*r_sa/l2_apu**2.) - - ! brightness temperature through soil-snow layer ([4] pp.243, eq.4.162) - tb_3 = ((1.-r_sn(i))*(1.-r_sa)*t)/ & - (l2_apu*(1.-r_sn(i)*r_sa/l2_apu**2.)) - - ! brightness temperature of snow-cover ground - tb_tos(i) = tb_2 + tb_3 - - ! emission by layers 2 (snow) and 3 (soil) - ! reflectivity by layers 2 (snow) and 3 (soil) - r_snow(i) = 1 - (tb_2/t_snow + tb_3/t) - END DO - END IF - - END SUBROUTINE snow -!----------------------------------------------------------------------- -END MODULE MOD_DA_RTM -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 deleted file mode 100644 index 8854feb488..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 +++ /dev/null @@ -1,1787 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_SM -!----------------------------------------------------------------------------- -! DESCRIPTION: -! Data assimilation of surface soil moisture and temperature -! -! AUTHOR: -! Lu Li, 12/2024: Initial version, based on SMAP L1C TB data -! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes -! Lu Li, 07/2025: reframe codes -! Lu Li, 10/2025: support SMAP/FY3D/SYNOP data -!----------------------------------------------------------------------------- - USE MOD_DataType - USE MOD_SpatialMapping - USE MOD_DA_RTM - USE MOD_DA_EnKF - USE MOD_DA_Vars_TimeVariables - USE MOD_Vars_Global, only: pi, nl_soil, maxsnl - USE MOD_LandPatch - USE MOD_Block - USE MOD_Namelist - USE MOD_DA_Vars_TimeVariables - USE MOD_Pixelset - USE MOD_Pixel - USE MOD_Mesh - IMPLICIT NONE - SAVE - -! public functions - PUBLIC :: init_DA_SM - PUBLIC :: run_DA_SM - PUBLIC :: end_DA_SM - - PRIVATE - -! local variables -!############################################################################# -! Universal variables -!############################################################################# - ! time (UTC) at current step - integer :: month, mday, hour ! month, day, hour of current step - character(len=256) :: yearstr, monthstr, daystr, hourstr ! string of year, month, day, hour - integer :: idate_b, idate_e ! begin & end seconds since begin of current day (UTC) - - integer :: num_obs_p - ! mask water - logical, allocatable :: filter(:) ! to mask the water - - ! logical - logical, allocatable :: has_DA ! whether has data assimilation - - ! setting of SMAP satellite - real(r8), parameter :: smap_theta = 40.0*pi/180 ! incidence angle (rad) - real(r8), parameter :: smap_fghz = 1.4 ! frequency (GHz), L-band - - ! setting of FY satellite - real(r8), parameter :: fy3d_theta = 40.0*pi/180 ! incidence angle (rad) - real(r8), parameter :: fy3d_fghz = 1.4 ! frequency (GHz), L-band - - ! parameters of LETKF - real(r8), allocatable :: obs_err(:) ! observation error - real(r8), parameter :: dres = 0.4 ! search localization radius (deg) - real(r8), parameter :: loc_r = 40.0 ! localization radius (km) - real(r8), parameter :: infl = 1.2 ! inflation factor - - ! data assimilation outputs - real(r8), allocatable :: trans(:,:) ! transformation matrix on each patch - real(r8), allocatable :: wliq_soi_ens(:,:) ! soil liquid water content - real(r8), allocatable :: wliq_soi_ens_da(:,:) ! soil liquid water content after data assimilation - real(r8), allocatable :: t_soi_ens(:,:) ! soil temperature - real(r8), allocatable :: t_soi_ens_da(:,:) ! soil temperature after data assimilation - real(r8) :: eff_porsl ! effective porosity of each soil layer - integer :: end_idx(3) - - real(r8), allocatable :: pred_obs_p_ens(:,:) ! predicted observations on each patch - real(r8), allocatable :: obs_p(:) ! observations on each patch - real(r8), allocatable :: obs_err_p(:) ! observation errors on each patch - - real(r8), allocatable :: smap_err(:) ! observation errors for SMAP TB - real(r8), allocatable :: fy3d_err(:) ! observation errors for FY3D TB - real(r8), allocatable :: synop_tref_err(:) ! observation errors for SYNOP 2m temperature - real(r8), allocatable :: synop_qref_err(:) ! observation errors for SYNOP 2m humidity - -!############################################################################# -! For SMAP L1C brightness temperature -!############################################################################# - ! file path - character(len=256) :: file_smap ! SMAP observation file path - character(len=256) :: file_grid_smap ! SMAP world grid file path - - ! grid - type(grid_type) :: grid_smap ! SMAP world grid - type(spatial_mapping_type) :: mg2p_smap ! mapping between SMAP world grid to patch - - ! time variables used to determine whether has obs - real(r8), allocatable :: smap_time(:) ! seconds of all obs since begin of current day (UTC) - real(r8), allocatable :: dt_b_smap(:) ! delta time between SMAP and begin seconds of current day - real(r8), allocatable :: dt_e_smap(:) ! delta time between SMAP and end seconds of current day - - ! logical variables - logical :: has_smap_file ! whether has file of SMAP at target hour - logical :: has_smap_obs ! whether has SMAP obs at current step - - ! observations (dimensions changes with time) - integer :: num_smap_obs ! number of all obs in current file - integer :: num_smap_obs_domain ! number of all obs in simulation domain at current file - real(r8), allocatable :: smap_lat(:) ! latitude of all obs - real(r8), allocatable :: smap_lon(:) ! longitude of all obs - real(r8), allocatable :: smap_tb_h(:) ! H- polarized brightness temperature of all obs ([K]) - real(r8), allocatable :: smap_tb_v(:) ! V- polarized brightness temperature of all obs ([K]) - integer, allocatable :: smap_ii(:) ! i-th lat grid in world map of all obs - integer, allocatable :: smap_jj(:) ! j-th lon grid in world map of all obs - - ! history mean value of smap and colm - real(r8), allocatable :: pred_smap_tb_h_mean(:) ! history mean value of predicted H- polarized temp - real(r8), allocatable :: pred_smap_tb_v_mean(:) ! history mean value of predicted V- polarized temp - real(r8), allocatable :: smap_tb_h_mean(:) ! history mean value of SMAP H- polarized temp - real(r8), allocatable :: smap_tb_v_mean(:) ! history mean value of SMAP V- polarized temp - - ! ensemble predicted observations (at patch) - real(r8), allocatable :: pred_smap_tb_h_pset_ens(:, :) ! predicted H- polarized temp on patch - real(r8), allocatable :: pred_smap_tb_v_pset_ens(:, :) ! predicted V- polarized temp on patch - real(r8), allocatable :: area_pset(:) ! area of each patch across world grid - - ! ensemble predicted observations (at world grid) - type(block_data_real8_3d) :: pred_smap_tb_h_wgrid_ens ! predicted H- polarized temp on world grid - type(block_data_real8_3d) :: pred_smap_tb_v_wgrid_ens ! predicted V- polarized temp on world grid - type(block_data_real8_2d) :: area_smap_wgrid ! area of each patch across world grid - - ! ensemble predicted observations (at obs grid) - real(r8), allocatable :: pred_smap_tb_h_ogrid_ens(:, :) ! predicted H- polarized temp on obs grid - real(r8), allocatable :: pred_smap_tb_v_ogrid_ens(:, :) ! predicted V- polarized temp on obs grid - real(r8) :: area_smap_wgrid_obs ! area of each patch across world grid for each obs - - ! observations around patch (dimensions changes with patch) - integer :: num_smap_p - logical, allocatable :: index_smap_p(:) ! index of obs around each patch - real(r8), allocatable :: smap_lat_p(:) ! latitude of obs around each patch - real(r8), allocatable :: smap_lon_p(:) ! longitude of obs around each patch - real(r8), allocatable :: smap_tb_h_p(:) ! H- polarized brightness temperature of obs around each patch ([K]) - real(r8), allocatable :: smap_tb_v_p(:) ! V- polarized brightness temperature of obs around each patch ([K]) - real(r8), allocatable :: pred_smap_tb_h_p_ens(:, :) ! predicted H- polarized temp around patch - real(r8), allocatable :: pred_smap_tb_v_p_ens(:, :) ! predicted V- polarized temp around patch - - ! history mean value of brightness temperature around patch - real(r8), allocatable :: pred_smap_tb_h_mean_p(:) ! history mean value of predicted H- polarized temp around patch - real(r8), allocatable :: pred_smap_tb_v_mean_p(:) ! history mean value of predicted V- polarized temp around patch - real(r8), allocatable :: smap_tb_h_mean_p(:) ! history mean value of SMAP H- polarized temp around patch - real(r8), allocatable :: smap_tb_v_mean_p(:) ! history mean value of SMAP V- polarized temp around patch - - ! parameters for distance calculation - real(r8), allocatable :: d_smap_p(:) ! distance between obs and patch center - real(r8), parameter :: static_smap_err = 0.1 ! static observation error - -!############################################################################# -! For FY3D L1 brightness temperature -!############################################################################# - ! file path - character(len=256) :: file_fy3d ! FY3D observation file path - character(len=256) :: file_grid_fy3d ! FY3D world grid file path - - ! grid - type(grid_type) :: grid_fy3d ! FY3D world grid - type(spatial_mapping_type) :: mg2p_fy3d ! mapping between FY3D world grid to patch - - ! time variables used to determine whether has obs - real(r8), allocatable :: fy3d_time(:) ! seconds of all obs since begin of current day (UTC) - real(r8), allocatable :: dt_b_fy3d(:) ! delta time between FY3D and begin seconds of current day - real(r8), allocatable :: dt_e_fy3d(:) ! delta time between FY3D and end seconds of current day - - ! logical variables - logical :: has_fy3d_file ! whether has file of FY3D at target hour - logical :: has_fy3d_obs ! whether has FY3D obs at current step - - ! observations (dimensions changes with time) - integer :: num_fy3d_obs ! number of all obs in current file - integer :: num_fy3d_obs_domain ! number of all obs in simulation domain at current file - real(r8), allocatable :: fy3d_lat(:) ! latitude of all obs - real(r8), allocatable :: fy3d_lon(:) ! longitude of all obs - real(r8), allocatable :: fy3d_tb_h(:) ! H- polarized brightness temperature of all obs ([K]) - real(r8), allocatable :: fy3d_tb_v(:) ! V- polarized brightness temperature of all obs ([K]) - integer, allocatable :: fy3d_ii(:) ! i-th lat grid in world map of all obs - integer, allocatable :: fy3d_jj(:) ! j-th lon grid in world map of all obs - - ! history mean value of fy3d and colm - real(r8), allocatable :: pred_fy3d_tb_h_mean(:) ! history mean value of predicted H- polarized temp - real(r8), allocatable :: pred_fy3d_tb_v_mean(:) ! history mean value of predicted V- polarized temp - real(r8), allocatable :: fy3d_tb_h_mean(:) ! history mean value of FY3D H- polarized temp - real(r8), allocatable :: fy3d_tb_v_mean(:) ! history mean value of FY3D V- polarized temp - - ! ensemble predicted observations (at patch) - real(r8), allocatable :: pred_fy3d_tb_h_pset_ens(:, :) ! predicted H- polarized temp on patch - real(r8), allocatable :: pred_fy3d_tb_v_pset_ens(:, :) ! predicted V- polarized temp on patch - - ! ensemble predicted observations (at world grid) - type(block_data_real8_3d) :: pred_fy3d_tb_h_wgrid_ens ! predicted H- polarized temp on world grid - type(block_data_real8_3d) :: pred_fy3d_tb_v_wgrid_ens ! predicted V- polarized temp on world grid - type(block_data_real8_2d) :: area_fy3d_wgrid ! area of each patch across world grid - - ! ensemble predicted observations (at obs grid) - real(r8), allocatable :: pred_fy3d_tb_h_ogrid_ens(:, :) ! predicted H- polarized temp on obs grid - real(r8), allocatable :: pred_fy3d_tb_v_ogrid_ens(:, :) ! predicted V- polarized temp on obs grid - real(r8) :: area_fy3d_wgrid_obs ! area of each patch across world grid for each obs - - ! observations around patch (dimensions changes with patch) - integer :: num_fy3d_p - logical, allocatable :: index_fy3d_p(:) ! index of obs around each patch - real(r8), allocatable :: fy3d_lat_p(:) ! latitude of obs around each patch - real(r8), allocatable :: fy3d_lon_p(:) ! longitude of obs around each patch - real(r8), allocatable :: fy3d_tb_h_p(:) ! H- polarized brightness temperature of obs around each patch ([K]) - real(r8), allocatable :: fy3d_tb_v_p(:) ! V- polarized brightness temperature of obs around each patch ([K]) - real(r8), allocatable :: pred_fy3d_tb_h_p_ens(:, :) ! predicted H- polarized temp around patch - real(r8), allocatable :: pred_fy3d_tb_v_p_ens(:, :) ! predicted V- polarized temp around patch - - ! history mean value of brightness temperature around patch - real(r8), allocatable :: pred_fy3d_tb_h_mean_p(:) ! history mean value of predicted H- polarized temp around patch - real(r8), allocatable :: pred_fy3d_tb_v_mean_p(:) ! history mean value of predicted V- polarized temp around patch - real(r8), allocatable :: fy3d_tb_h_mean_p(:) ! history mean value of FY3D H- polarized temp around patch - real(r8), allocatable :: fy3d_tb_v_mean_p(:) ! history mean value of FY3D V- polarized temp around patch - - ! parameters for distance calculation - real(r8), allocatable :: d_fy3d_p(:) ! distance between obs and patch center - real(r8), parameter :: static_fy3d_err = 10.0 ! static observation error - -!############################################################################# -! For SYNOP 2m temperature and humidity observations -!############################################################################# - ! derived types of pixel index in each rank - ! firstly sorted by pixel latitude index (nlat) and record - ! corresponding longitude index and patch id for each pixel - type :: idx_type - integer, allocatable :: ilon (:) - integer, allocatable :: ipatch (:) - END type idx_type - type(idx_type), allocatable :: idx (:) ! derived types of pixel index at each rank - integer, allocatable :: counter (:) ! counter of pixel longitude index of each latitude index at each rank - - ! file path - character(len=256) :: file_synop ! SYNOP file path - - ! info of all SYNOP sites - character(len=256) :: file_site ! file of location of all SYNOP sites - real(r8), allocatable :: synop_lat_all(:) - real(r8), allocatable :: synop_lon_all(:) ! latitude and longitude of all SYNOP sites - integer :: nsite ! number of all SYNOP sites - integer, allocatable :: iloc_synop (:,:) ! global lat/lon index of pixel cover each site in all SYNOP sites - integer :: counter_rank_nsite ! number of all SYNOP sites located at each rank - integer, allocatable :: ip_rank (:,:) ! patch id of all SYNOP sites located at each rank - integer, allocatable :: idx_lat(:), idx_lon(:), pos(:) ! temporary array save global lat/lon index of each site - integer, allocatable :: synop_lut (:,:) ! look-up-table of all SYNOP sites - - ! time variables used to determine whether has obs - real(r8), allocatable :: synop_time(:) ! seconds of all obs since begin of current day (UTC) - real(r8), allocatable :: dt_b_synop(:) ! delta time between SYNOP and begin seconds of current day - real(r8), allocatable :: dt_e_synop(:) ! delta time between SYNOP and end seconds of current day - - ! logical variables - logical :: has_synop_file ! whether has file of SYNOP at target day - logical :: has_synop_obs ! whether has SYNOP obs at current step - - ! info of SYNOP sites at each step - integer, allocatable :: synop_idx (:,:) ! index of SYNOP sites (rank/patch id) at each step - integer, allocatable :: site_id_rank (:) ! site id of SYNOP sites at each step at each rank - real(r8), allocatable :: tref_ens_rank (:,:) ! predicted 2m temperature of SYNOP sites at each step at each rank - real(r8), allocatable :: qref_ens_rank (:,:) ! predicted 2m humidity of SYNOP sites at each step at each rank - real(r8), allocatable :: qref_ens_o (:,:) ! predicted 2m temperature of SYNOP sites at each step - real(r8), allocatable :: tref_ens_o (:,:) ! predicted 2m humidity of SYNOP sites at each step - - ! observations (dimensions changes with time) - integer :: num_synop_obs ! number of all obs in current file - integer :: num_synop_obs_domain ! number of all obs in simulation domain at current file - real(r8), allocatable :: synop_lat(:) ! latitude of all obs - real(r8), allocatable :: synop_lon(:) ! longitude of all obs - integer, allocatable :: synop_id(:) ! global id of all obs - real(r8), allocatable :: synop_tref(:) ! 2m temperature of all obs ([K]) - integer, allocatable :: synop_qref(:) ! 2m humidity of all obs ([K]) - - ! observations around patch (dimensions changes with patch) - integer :: num_synop_p - logical, allocatable :: index_synop_p(:) ! index of obs around each patch - real(r8), allocatable :: synop_lat_p(:) ! latitude of obs around each patch - real(r8), allocatable :: synop_lon_p(:) ! longitude of obs around each patch - real(r8), allocatable :: synop_qref_p(:) ! 2m temperature of obs around each patch ([K]) - real(r8), allocatable :: synop_tref_p(:) ! 2m humidity of obs around each patch ([K]) - real(r8), allocatable :: synop_p(:) ! concatenate 2m temperature and humidity of obs around each patch - real(r8), allocatable :: qref_ens_p(:,:) ! predicted 2m temperature around patch - real(r8), allocatable :: tref_ens_p(:,:) ! predicted 2m humidity around patch - real(r8), allocatable :: pred_synop_ens_p(:,:) ! predicted 2m temperature and humidity around patch - - ! parameters for distance calculation - real(r8), allocatable :: d_synop_p(:) ! distance between obs and patch center - real(r8), parameter :: static_synop_tref_err = 1.0 ! static observation error (2m temperature) - real(r8), parameter :: static_synop_qref_err = 0.04 ! static observation error (2m humidity) - -!----------------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------------- - - SUBROUTINE init_DA_SM() - -!----------------------------------------------------------------------------- - USE MOD_Spmd_Task - USE MOD_Namelist, only: DEF_DA_obsdir - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_LandPatch - USE MOD_Pixelset - USE MOD_RangeCheck - IMPLICIT NONE - - integer :: np, ie, ipxstt, ipxend, ipxl, i, ilat, isite, ilon, iwork, mesg(2), isrc, ndata, numpxl_lat, numpxl_lon, numpxl - integer, allocatable :: temp (:,:) ! temporary array for receiving data from ranks - -!----------------------------------------------------------------------------- - -#ifndef SinglePoint - IF (DEF_DA_SM_SMAP) THEN - ! grid file path of EASE v2.0, 36km world grid - file_grid_smap = trim(DEF_DA_obsdir)//'/grid/'//'/SMAP_L1C_36km.nc' - CALL grid_smap%define_from_file(file_grid_smap, 'latitude', 'longitude') - - ! map SMAP grid to patch - CALL mg2p_smap%build_arealweighted(grid_smap, landpatch) - ENDIF - - IF (DEF_DA_SM_FY) THEN - ! grid file path of FY3D, 0.25 degree world grid - file_grid_fy3d = trim(DEF_DA_obsdir)//'/grid/'//'/FY3D_L1_0p25.nc' - - CALL grid_fy3d%define_from_file(file_grid_fy3d, 'latitude', 'longitude') - - ! map FY3D grid to patch - CALL mg2p_fy3d%build_arealweighted(grid_fy3d, landpatch) - ENDIF - - IF (DEF_DA_SM_SYNOP) THEN -!############################################################################# -! Makeup derived types of pixel index for fast access at each rank -!############################################################################# - IF (p_is_compute) THEN - allocate (counter (pixel%nlat)) - counter(:) = 0 - - ! count the number of pixel lon index for each pixel lat index - DO np = 1, numpatch - ie = landpatch%ielm(np) - - ipxstt = landpatch%ipxstt(np) - ipxend = landpatch%ipxend(np) - - DO ipxl = ipxstt, ipxend - counter(mesh(ie)%ilat(ipxl)) = counter(mesh(ie)%ilat(ipxl)) + 1 - ENDDO - ENDDO - - ! allocate derived types of index - allocate (idx (pixel%nlat)) - DO i = 1, pixel%nlat - IF (counter(i) > 0) THEN - allocate (idx(i)%ilon(counter(i))) - allocate (idx(i)%ipatch(counter(i))) - - idx(i)%ilon(:) = 0 - idx(i)%ipatch(:) = 0 - ENDIF - ENDDO - - ! fill the index - counter(:) = 0 - DO np = 1, numpatch - ie = landpatch%ielm(np) - - ipxstt = landpatch%ipxstt(np) - ipxend = landpatch%ipxend(np) - - DO ipxl = ipxstt, ipxend - ilat = mesh(ie)%ilat(ipxl) - counter(mesh(ie)%ilat(ipxl)) = counter(mesh(ie)%ilat(ipxl)) + 1 - idx(ilat)%ilon(counter(mesh(ie)%ilat(ipxl))) = mesh(ie)%ilon(ipxl) - idx(ilat)%ipatch(counter(mesh(ie)%ilat(ipxl))) = np - ENDDO - ENDDO - ENDIF - - -!############################################################################# -! Read the location of SYNOP sites and find the located pixel of each site -!############################################################################# - ! file of SYNOP sites - file_site = trim(DEF_DA_obsdir)//'/grid/'//'/SYNOP.nc' - - ! read latitude and longitude of sites - IF (ncio_var_exist(file_site, 'latitude')) THEN - CALL ncio_read_bcast_serial(file_site, 'latitude', synop_lat_all) - CALL ncio_read_bcast_serial(file_site, 'longitude', synop_lon_all) - ENDIF - nsite = size(synop_lat_all) - - ! find the located pixel of each site & broadcast ranks - allocate (iloc_synop (2, nsite)) - iloc_synop(:,:) = -1 - IF (p_is_root) THEN - DO i = 1, nsite - numpxl_lat = count(pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i)) - numpxl_lon = count(pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i)) - - IF (numpxl_lat ==1 .and. numpxl_lon ==1) THEN - IF (allocated (idx_lat)) deallocate (idx_lat) - IF (allocated (idx_lon)) deallocate (idx_lon) - allocate (idx_lat(numpxl_lat)) - allocate (idx_lon(numpxl_lon)) - - idx_lat = pack([(isite, isite=1, pixel%nlat)], pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i)) - idx_lon = pack([(isite, isite=1, pixel%nlon)], pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i)) - - iloc_synop(1,i) = idx_lat(1) - iloc_synop(2,i) = idx_lon(1) - ELSE - iloc_synop(1,i) = -1 - iloc_synop(2,i) = -1 - ENDIF - ENDDO - ENDIF - CALL mpi_bcast(iloc_synop, 2*nsite, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -!############################################################################# -! Assess the patch id of pixel that cover each observation at each rank -!############################################################################# - IF (p_is_compute) THEN - ! count the number of site that located in pixels of each rank - counter_rank_nsite = 0 - DO i = 1, nsite - IF (iloc_synop(1, i) > 0) THEN - IF (counter(iloc_synop(1, i)) > 0) THEN - IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN - counter_rank_nsite = counter_rank_nsite + 1 - ENDIF - ENDIF - ENDIF - ENDDO - - ! assess patch/site id of sites located at each rank - IF (counter_rank_nsite > 0) THEN - allocate (ip_rank (2, counter_rank_nsite)) - counter_rank_nsite = 0 - ip_rank(:,:) = -1 - - DO i = 1, nsite - IF (iloc_synop(1, i) > 0) THEN - IF (counter(iloc_synop(1, i)) > 0) THEN - IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN - numpxl = count(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i)) - IF (allocated (pos)) deallocate (pos) - allocate (pos(numpxl)) - - pos = pack([(ilon, ilon=1, counter(iloc_synop(1, i)))], (idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) - counter_rank_nsite = counter_rank_nsite + 1 - ip_rank(1, counter_rank_nsite) = i - ip_rank(2, counter_rank_nsite) = idx(iloc_synop(1, i))%ipatch(pos(1)) - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF - - ! send the number of site and their patch id to root -#ifdef USEMPI - mesg = (/p_iam_glb, counter_rank_nsite/) - CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (counter_rank_nsite > 0) THEN - CALL mpi_send(ip_rank, 2*counter_rank_nsite, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#endif - - ! deallocate - IF (allocated (counter)) deallocate (counter) - DO i = 1, pixel%nlat - IF (allocated(idx(i)%ilon)) deallocate (idx(i)%ilon) - IF (allocated(idx(i)%ipatch)) deallocate (idx(i)%ipatch) - ENDDO - IF (allocated (idx)) deallocate (idx) - IF (allocated (iloc_synop)) deallocate (iloc_synop) - IF (allocated (ip_rank)) deallocate (ip_rank) - ENDIF - -!############################################################################# -! Generate look-up-table (contains the rank/patch id of each site) at root -!############################################################################# - IF (p_is_root) THEN - allocate (synop_lut (2, nsite)) - synop_lut(:,:) = -1 - -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - ndata = mesg(2) - - IF (ndata > 0) THEN - allocate (temp(2, ndata)) - CALL mpi_recv(temp, 2*ndata, MPI_INTEGER, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - DO i = 1, ndata - synop_lut(1, temp(1,i)) = isrc - synop_lut(2, temp(1,i)) = temp(2,i) - ENDDO - - deallocate(temp) - ENDIF - ENDDO -#endif - ENDIF - ENDIF -#endif - - END SUBROUTINE init_DA_SM - -!----------------------------------------------------------------------------- - - SUBROUTINE run_DA_SM(idate, deltim) - -!----------------------------------------------------------------------------- - USE MOD_Spmd_task - USE MOD_TimeManager - USE MOD_NetCDFBlock - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_Vars_Global - USE MOD_Vars_1DFluxes - USE MOD_Vars_1DForcing - USE MOD_Vars_TimeVariables - USE MOD_Vars_TimeInvariants - USE MOD_DA_Vars_TimeVariables - USE MOD_RangeCheck - USE MOD_UserDefFun - USE MOD_DA_EnKF - USE MOD_Const_Physical, only: denice, denh2o - IMPLICIT NONE - -!------------------------ Dummy Arguments ------------------------------------ - integer, intent(in) :: idate(3) - real(r8), intent(in) :: deltim - -!------------------------ Local Variables ------------------------------------ - real(r8) :: lat_p_n, lat_p_s, lon_p_w, lon_p_e - real(r8) :: lat_p, lon_p - real(r8) :: es, e - integer :: ib, jb, il, jl, ip, iens, iobs, np, i, n, ndata, isrc, j - integer :: sdate(3), smesg(2), rmesg(2) - integer, allocatable :: iloc(:) - integer, allocatable :: itemp(:) - real(r8), allocatable :: dtemp(:,:) - integer :: iwork, mesg(2) - -!----------------------------------------------------------------------------- - -!############################################################################# -! Identify if there are observations at this time step -!############################################################################# - ! Do not perform DA, only calcuate predict BRT for diagnostic - IF (DEF_DA_ENS_NUM == 1) THEN - has_smap_file = .false. - has_fy3d_file = .false. - has_synop_file = .false. - ELSE - ! covert local time to UTC for single point - sdate = idate - CALL adj2begin(sdate) -#ifdef SinglePoint - IF (.not. DEF_simulation_time%greenwich) THEN - CALL localtime2gmt(sdate) - ENDIF -#endif - ! calculate year/month/day/hour of current step - CALL julian2monthday(sdate(1), sdate(2), month, mday) - hour = int(sdate(3)/3600) - - ! whether has file at target day - write (yearstr, '(I4.4)') sdate(1) - write (monthstr, '(I2.2)') month - write (daystr, '(I2.2)') mday - write (hourstr, '(I2.2)') hour - - ! check SMAP brightness temperature observations - IF (DEF_DA_SM_SMAP) THEN - ! file path of SMAP - file_smap = trim(DEF_DA_obsdir)//'/SMAP_L1C_D/'//'/SMAP_L1C_TB_'// & - trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc' - inquire (file=trim(file_smap), exist=has_smap_file) - - ! whether have obs at this time interval - has_smap_obs = .false. - IF (has_smap_file) THEN - CALL ncio_read_bcast_serial(file_smap, 'time', smap_time) - num_smap_obs = size(smap_time) - idate_b = sdate(3) - idate_e = sdate(3) + deltim - allocate (dt_b_smap(num_smap_obs)) - allocate (dt_e_smap(num_smap_obs)) - dt_b_smap = smap_time - idate_b - dt_e_smap = smap_time - idate_e - IF (any(dt_b_smap >= 0 .and. dt_e_smap <= 0)) has_smap_obs = .true. - deallocate (dt_b_smap) - deallocate (dt_e_smap) - ELSE - has_smap_obs = .false. - ENDIF - - ! check if there are obs in simulation domain - IF (has_smap_obs) THEN - CALL ncio_read_bcast_serial(file_smap, 'lat', smap_lat) - CALL ncio_read_bcast_serial(file_smap, 'lon', smap_lon) - - num_smap_obs_domain = count(smap_lat(:) < DEF_domain%edgen .and. smap_lat(:) > DEF_domain%edges .and. & - smap_lon(:) > DEF_domain%edgew .and. smap_lon(:) < DEF_domain%edgee) - IF (num_smap_obs_domain == 0) has_smap_obs = .false. - ENDIF - ELSE - has_smap_file = .false. - has_smap_obs = .false. - ENDIF - - ! check FY brightness temperature observations - IF (DEF_DA_SM_FY) THEN - ! file path of FY3D - file_fy3d = trim(DEF_DA_obsdir)//'/FY3D_L1/'//'/FY3D_L1_TB_'// & - trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc' - inquire (file=trim(file_fy3d), exist=has_fy3d_file) - - ! whether have obs at this time interval - has_fy3d_obs = .false. - IF (has_fy3d_file) THEN - CALL ncio_read_bcast_serial(file_fy3d, 'time', fy3d_time) - num_fy3d_obs = size(fy3d_time) - idate_b = sdate(3) - idate_e = sdate(3) + deltim - allocate (dt_b_fy3d(num_fy3d_obs)) - allocate (dt_e_fy3d(num_fy3d_obs)) - dt_b_fy3d = fy3d_time - idate_b - dt_e_fy3d = fy3d_time - idate_e - IF (any(dt_b_fy3d >= 0 .and. dt_e_fy3d <= 0)) has_fy3d_obs = .true. - deallocate (dt_b_fy3d) - deallocate (dt_e_fy3d) - ELSE - has_fy3d_obs = .false. - ENDIF - - ! check if there are obs in simulation domain - IF (has_fy3d_obs) THEN - CALL ncio_read_bcast_serial(file_fy3d, 'lat', fy3d_lat) - CALL ncio_read_bcast_serial(file_fy3d, 'lon', fy3d_lon) - - num_fy3d_obs_domain = count(fy3d_lat(:) < DEF_domain%edgen .and. fy3d_lat(:) > DEF_domain%edges .and. & - fy3d_lon(:) > DEF_domain%edgew .and. fy3d_lon(:) < DEF_domain%edgee) - IF (num_fy3d_obs_domain == 0) has_fy3d_obs = .false. - ENDIF - ELSE - has_fy3d_file = .false. - has_fy3d_obs = .false. - ENDIF - - ! check SYNOP 2m observations - IF (DEF_DA_SM_SYNOP) THEN - file_synop = trim(DEF_DA_obsdir)//'/SYNOP/'//'/SYNOP_'// & - trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc' - inquire (file=trim(file_synop), exist=has_synop_file) - - ! whether have obs at this time interval - has_synop_obs = .false. - IF (has_synop_file) THEN - CALL ncio_read_bcast_serial(file_synop, 'time', synop_time) - num_synop_obs = size(synop_time) - idate_b = sdate(3) - idate_e = sdate(3) + deltim - allocate (dt_b_synop(num_synop_obs)) - allocate (dt_e_synop(num_synop_obs)) - dt_b_synop = synop_time - idate_b - dt_e_synop = synop_time - idate_e - IF (any(dt_b_synop >= 0 .and. dt_e_synop <= 0)) has_synop_obs = .true. - deallocate (dt_b_synop) - deallocate (dt_e_synop) - ELSE - has_synop_obs = .false. - ENDIF - - ! check if there are obs in simulation domain - IF (has_synop_obs) THEN - CALL ncio_read_bcast_serial(file_synop, 'lat', synop_lat) - CALL ncio_read_bcast_serial(file_synop, 'lon', synop_lon) - - num_synop_obs_domain = count(synop_lat(:) < DEF_domain%edgen .and. synop_lat(:) > DEF_domain%edges .and. & - synop_lon(:) > DEF_domain%edgew .and. synop_lon(:) < DEF_domain%edgee) - IF (num_synop_obs_domain == 0) has_synop_obs = .false. - ENDIF - ELSE - has_synop_file = .false. - has_synop_obs = .false. - ENDIF - ENDIF - - ! print info of observations - IF (p_is_root) THEN - IF (has_smap_obs) THEN - print *, '[CoLM-DA] Have SMAP observations:', trim(file_smap) - ELSE - print *, '[CoLM-DA] No SMAP observations.' - ENDIF - IF (has_fy3d_obs) THEN - print *, '[CoLM-DA] Have FY3D observations:', trim(file_fy3d) - ELSE - print *, '[CoLM-DA] No FY3D observations.' - ENDIF - IF (has_synop_obs) THEN - print *, '[CoLM-DA] Have SYNOP observations:', trim(file_synop) - ELSE - print *, '[CoLM-DA] No SYNOP observations.' - ENDIF - ENDIF - -!############################################################################# -! Allocate memory for variables -!############################################################################# - IF (DEF_DA_SM_SMAP) THEN - ! allocate memory for ensemble predicted observations at patch (for DA or no DA) - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - IF (allocated(pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) - IF (allocated(pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) - allocate (pred_smap_tb_h_pset_ens(DEF_DA_ENS_NUM, numpatch)) - allocate (pred_smap_tb_v_pset_ens(DEF_DA_ENS_NUM, numpatch)) - ENDIF - ENDIF - - ! allocate memory for ensemble predicted observations in vectors (only for DA) -#ifndef SinglePoint - IF (has_smap_obs) THEN - IF (allocated(pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens) - IF (allocated(pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens) - allocate (pred_smap_tb_h_ogrid_ens(num_smap_obs, DEF_DA_ENS_NUM)) - allocate (pred_smap_tb_v_ogrid_ens(num_smap_obs, DEF_DA_ENS_NUM)) - ENDIF -#endif - ENDIF - - IF (DEF_DA_SM_FY) THEN - ! allocate memory for ensemble predicted observations at patch (for DA or no DA) - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - IF (allocated(pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) - IF (allocated(pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) - allocate (pred_fy3d_tb_h_pset_ens(DEF_DA_ENS_NUM, numpatch)) - allocate (pred_fy3d_tb_v_pset_ens(DEF_DA_ENS_NUM, numpatch)) - ENDIF - ENDIF - - ! allocate memory for ensemble predicted observations in vectors (only for DA) -#ifndef SinglePoint - IF (has_fy3d_obs) THEN - IF (allocated(pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens) - IF (allocated(pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens) - allocate (pred_fy3d_tb_h_ogrid_ens(num_fy3d_obs, DEF_DA_ENS_NUM)) - allocate (pred_fy3d_tb_v_ogrid_ens(num_fy3d_obs, DEF_DA_ENS_NUM)) - ENDIF -#endif - ENDIF - - IF (DEF_DA_SM_SYNOP) THEN - ! allocate memory - IF (has_synop_obs) THEN - IF (allocated(synop_idx)) deallocate (synop_idx) - IF (allocated(qref_ens_o)) deallocate (qref_ens_o) - IF (allocated(tref_ens_o)) deallocate (tref_ens_o) - allocate (synop_idx (2, num_synop_obs)) - allocate (qref_ens_o (num_synop_obs, DEF_DA_ENS_NUM)) - allocate (tref_ens_o (num_synop_obs, DEF_DA_ENS_NUM)) - ENDIF - ENDIF - -!############################################################################# -! Calculate predicted observations using observation operator -!############################################################################# - ! forward model (for no DA) - IF (p_is_compute) THEN - ! SMAP forward model - DO np = 1, numpatch - lat_p = patchlatr(np)*180/pi - lon_p = patchlonr(np)*180/pi - CALL forward(& - patchtype(np), patchclass(np), dz_sno(:,np), & - forc_topo(np), htop(np), & - tref(np), t_soisno(:,np), tleaf(np), & - wliq_soisno(:,np), wice_soisno(:,np), h2osoi(:,np), & - snowdp(np), lai(np), sai(np), & - wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & - smap_theta, smap_fghz, & - t_brt_smap(1,np), t_brt_smap(2,np)) - ENDDO - - ! FY3D forward model - DO np = 1, numpatch - CALL forward(& - patchtype(np), patchclass(np), dz_sno(:,np), & - forc_topo(np), htop(np), & - tref(np), t_soisno(:,np), tleaf(np), & - wliq_soisno(:,np), wice_soisno(:,np), h2osoi(:,np), & - snowdp(np), lai(np), sai(np), & - wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & - fy3d_theta, fy3d_fghz, & - t_brt_fy3d(1,np), t_brt_fy3d(2,np)) - ENDDO - ENDIF - - ! forward model for ensemble DA - IF (p_is_compute) THEN - IF (DEF_DA_SM_SMAP) THEN - IF (DEF_DA_ENS_NUM > 1) THEN - DO iens = 1, DEF_DA_ENS_NUM - DO np = 1, numpatch - CALL forward(& - patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & - forc_topo(np), htop(np), & - tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & - wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & - snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & - wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & - smap_theta, smap_fghz, & - pred_smap_tb_h_pset_ens(iens, np), pred_smap_tb_v_pset_ens(iens, np)) - ENDDO - ENDDO - t_brt_smap_ens(1,:,:) = pred_smap_tb_h_pset_ens - t_brt_smap_ens(2,:,:) = pred_smap_tb_v_pset_ens - ENDIF - ENDIF - - IF (DEF_DA_SM_FY) THEN - IF (DEF_DA_ENS_NUM > 1) THEN - DO iens = 1, DEF_DA_ENS_NUM - DO np = 1, numpatch - CALL forward(& - patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & - forc_topo(np), htop(np), & - tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & - wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & - snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & - wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & - fy3d_theta, fy3d_fghz, & - pred_fy3d_tb_h_pset_ens(iens, np), pred_fy3d_tb_v_pset_ens(iens, np)) - ENDDO - ENDDO - t_brt_fy3d_ens(1,:,:) = pred_fy3d_tb_h_pset_ens - t_brt_fy3d_ens(2,:,:) = pred_fy3d_tb_v_pset_ens - ENDIF - ENDIF - - IF (DEF_DA_SM_SYNOP) THEN - IF (DEF_DA_ENS_NUM > 1) THEN - ! calculate relative humidity from specific humidity - DO ip = 1, numpatch - DO iens = 1, DEF_DA_ENS_NUM - es = 6.112 * exp((17.67 * (tref_ens(iens, ip) - 273.15))/ (tref_ens(iens, ip) - 273.15 + 243.5)) - e = (qref_ens(iens, ip) * forc_psrf(ip) / 100) / (0.378 * qref_ens(iens, ip) + 0.622) - rhref_ens(iens, ip) = max(min(1.0d0, e / es), 0.0d0) - ENDDO - ENDDO - ENDIF - ENDIF - ENDIF - -!############################################################################# -! Reading observations data -!############################################################################# - ! read observations data (only for DA) - IF (has_smap_obs) THEN - CALL ncio_read_bcast_serial(file_smap, 'ii' , smap_ii ) - CALL ncio_read_bcast_serial(file_smap, 'jj' , smap_jj ) - CALL ncio_read_bcast_serial(file_smap, 'tb_h', smap_tb_h) - CALL ncio_read_bcast_serial(file_smap, 'tb_v', smap_tb_v) - CALL ncio_read_bcast_serial(file_smap, 'tb_h_colm_mean', pred_smap_tb_h_mean) - CALL ncio_read_bcast_serial(file_smap, 'tb_v_colm_mean', pred_smap_tb_v_mean) - CALL ncio_read_bcast_serial(file_smap, 'tb_h_obs_mean', smap_tb_h_mean) - CALL ncio_read_bcast_serial(file_smap, 'tb_v_obs_mean', smap_tb_v_mean) - ENDIF - IF (has_fy3d_obs) THEN - CALL ncio_read_bcast_serial(file_fy3d, 'ii' , fy3d_ii ) - CALL ncio_read_bcast_serial(file_fy3d, 'jj' , fy3d_jj ) - CALL ncio_read_bcast_serial(file_fy3d, 'tb_h', fy3d_tb_h) - CALL ncio_read_bcast_serial(file_fy3d, 'tb_v', fy3d_tb_v) - CALL ncio_read_bcast_serial(file_fy3d, 'tb_h_colm_mean', pred_fy3d_tb_h_mean) - CALL ncio_read_bcast_serial(file_fy3d, 'tb_v_colm_mean', pred_fy3d_tb_v_mean) - CALL ncio_read_bcast_serial(file_fy3d, 'tb_h_obs_mean', fy3d_tb_h_mean) - CALL ncio_read_bcast_serial(file_fy3d, 'tb_v_obs_mean', fy3d_tb_v_mean) - ENDIF - IF (has_synop_obs) THEN - CALL ncio_read_bcast_serial(file_synop, 'lat', synop_lat ) - CALL ncio_read_bcast_serial(file_synop, 'lon', synop_lon ) - CALL ncio_read_bcast_serial(file_synop, 'id', synop_id ) - CALL ncio_read_bcast_serial(file_synop, 'tref', synop_tref) - CALL ncio_read_bcast_serial(file_synop, 'qref', synop_qref) - ENDIF - -!############################################################################# -! Cropping predicted observations at observations space -!############################################################################# -#ifndef SinglePoint - IF (DEF_DA_SM_SMAP) THEN - IF (has_smap_obs) THEN - ! prepare filter for land patches - allocate (filter(numpatch)) - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - filter(:) = patchtype <= 2 - ENDIF - ENDIF - - ! calculate area of each patch across world grid - IF (p_is_active) CALL allocate_block_data(grid_smap, area_smap_wgrid) - CALL mg2p_smap%get_sumarea(area_smap_wgrid, filter) - - ! mapping predicted observations from patch to world grid - IF (p_is_active) THEN - CALL allocate_block_data(grid_smap, pred_smap_tb_h_wgrid_ens, DEF_DA_ENS_NUM) - CALL allocate_block_data(grid_smap, pred_smap_tb_v_wgrid_ens, DEF_DA_ENS_NUM) - ENDIF - CALL mg2p_smap%pset2grid(pred_smap_tb_h_pset_ens, pred_smap_tb_h_wgrid_ens, spv=spval, msk=filter) - CALL mg2p_smap%pset2grid(pred_smap_tb_v_pset_ens, pred_smap_tb_v_wgrid_ens, spv=spval, msk=filter) - deallocate (filter) - - ! crop the predicted observations - IF (p_is_active) THEN - allocate (iloc(num_smap_obs)) - pred_smap_tb_h_ogrid_ens = -9999.0 - pred_smap_tb_v_ogrid_ens = -9999.0 - - ! crop obs from world grid to all obs grids - ndata = 0 - DO i = 1, num_smap_obs - ib = grid_smap%xblk(smap_jj(i)) - jb = grid_smap%yblk(smap_ii(i)) - il = grid_smap%xloc(smap_jj(i)) - jl = grid_smap%yloc(smap_ii(i)) - IF (ib /= 0 .and. jb /= 0) THEN - IF (gblock%pio(ib, jb) == p_iam_glb) THEN - area_smap_wgrid_obs = area_smap_wgrid%blk(ib, jb)%val(il, jl) - IF (area_smap_wgrid_obs /= 0) THEN -#ifdef USEMPI - ndata = ndata + 1 - iloc(ndata) = i - pred_smap_tb_h_ogrid_ens(ndata, :) = (pred_smap_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs - pred_smap_tb_v_ogrid_ens(ndata, :) = (pred_smap_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs -#else - pred_smap_tb_h_ogrid_ens(i, :) = (pred_smap_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs - pred_smap_tb_v_ogrid_ens(i, :) = (pred_smap_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs -#endif - ENDIF - ENDIF - ENDIF - ENDDO - - ! send data from io to roots -#ifdef USEMPI - smesg = (/p_iam_glb, ndata/) - CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (ndata > 0) THEN - CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (dtemp(ndata, DEF_DA_ENS_NUM)) - dtemp = pred_smap_tb_h_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - dtemp = pred_smap_tb_v_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data + 1, p_comm_glb, p_err) - deallocate (dtemp) - ENDIF -#endif - deallocate (iloc) - deallocate (pred_smap_tb_h_wgrid_ens%blk, pred_smap_tb_v_wgrid_ens%blk) - ENDIF - - ! broadcast from root to all ranks -#ifdef USEMPI - IF (p_is_root) THEN - pred_smap_tb_h_ogrid_ens = -9999.0 - pred_smap_tb_v_ogrid_ens = -9999.0 - DO ip = 0, p_np_active - 1 - CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - ndata = rmesg(2) - IF (ndata > 0) THEN - allocate (itemp(ndata)) - allocate (dtemp(ndata, DEF_DA_ENS_NUM)) - - isrc = rmesg(1) - CALL mpi_recv(itemp, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - pred_smap_tb_h_ogrid_ens(itemp, :) = dtemp - CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data + 1, p_comm_glb, p_stat, p_err) - pred_smap_tb_v_ogrid_ens(itemp, :) = dtemp - - deallocate (itemp) - deallocate (dtemp) - ENDIF - ENDDO - ENDIF - CALL mpi_bcast(pred_smap_tb_h_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast(pred_smap_tb_v_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (DEF_DA_SM_FY) THEN - IF (has_fy3d_obs) THEN - ! prepare filter for land patches - allocate (filter(numpatch)) - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - filter(:) = patchtype <= 2 - ENDIF - ENDIF - - ! calculate area of each patch across world grid - IF (p_is_active) CALL allocate_block_data(grid_fy3d, area_fy3d_wgrid) - CALL mg2p_fy3d%get_sumarea(area_fy3d_wgrid, filter) - - ! mapping predicted observations from patch to world grid - IF (p_is_active) THEN - CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_h_wgrid_ens, DEF_DA_ENS_NUM) - CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_v_wgrid_ens, DEF_DA_ENS_NUM) - ENDIF - CALL mg2p_fy3d%pset2grid(pred_fy3d_tb_h_pset_ens, pred_fy3d_tb_h_wgrid_ens, spv=spval, msk=filter) - CALL mg2p_fy3d%pset2grid(pred_fy3d_tb_v_pset_ens, pred_fy3d_tb_v_wgrid_ens, spv=spval, msk=filter) - deallocate (filter) - - ! crop the predicted observations - IF (p_is_active) THEN - allocate (iloc(num_fy3d_obs)) - pred_fy3d_tb_h_ogrid_ens = -9999.0 - pred_fy3d_tb_v_ogrid_ens = -9999.0 - - ! crop obs from world grid to all obs grids - ndata = 0 - DO i = 1, num_fy3d_obs - ib = grid_fy3d%xblk(fy3d_jj(i)) - jb = grid_fy3d%yblk(fy3d_ii(i)) - il = grid_fy3d%xloc(fy3d_jj(i)) - jl = grid_fy3d%yloc(fy3d_ii(i)) - IF (ib /= 0 .and. jb /= 0) THEN - IF (gblock%pio(ib, jb) == p_iam_glb) THEN - area_fy3d_wgrid_obs = area_fy3d_wgrid%blk(ib, jb)%val(il, jl) - IF (area_fy3d_wgrid_obs /= 0) THEN -#ifdef USEMPI - ndata = ndata + 1 - iloc(ndata) = i - pred_fy3d_tb_h_ogrid_ens(ndata, :) = (pred_fy3d_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs - pred_fy3d_tb_v_ogrid_ens(ndata, :) = (pred_fy3d_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs -#else - pred_fy3d_tb_h_ogrid_ens(i, :) = (pred_fy3d_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs - pred_fy3d_tb_v_ogrid_ens(i, :) = (pred_fy3d_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs -#endif - ENDIF - ENDIF - ENDIF - ENDDO - - ! send data from io to roots -#ifdef USEMPI - smesg = (/p_iam_glb, ndata/) - CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (ndata > 0) THEN - CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (dtemp(ndata, DEF_DA_ENS_NUM)) - dtemp = pred_fy3d_tb_h_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - dtemp = pred_fy3d_tb_v_ogrid_ens(1:ndata, :) - CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data + 1, p_comm_glb, p_err) - deallocate (dtemp) - ENDIF -#endif - deallocate (iloc) - deallocate (pred_fy3d_tb_h_wgrid_ens%blk, pred_fy3d_tb_v_wgrid_ens%blk) - ENDIF - - ! broadcast from root to all ranks -#ifdef USEMPI - IF (p_is_root) THEN - pred_fy3d_tb_h_ogrid_ens = -9999.0 - pred_fy3d_tb_v_ogrid_ens = -9999.0 - DO ip = 0, p_np_active - 1 - CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - ndata = rmesg(2) - IF (ndata > 0) THEN - allocate (itemp(ndata)) - allocate (dtemp(ndata, DEF_DA_ENS_NUM)) - - isrc = rmesg(1) - CALL mpi_recv(itemp, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - pred_fy3d_tb_h_ogrid_ens(itemp, :) = dtemp - CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data + 1, p_comm_glb, p_stat, p_err) - pred_fy3d_tb_v_ogrid_ens(itemp, :) = dtemp - - deallocate (itemp) - deallocate (dtemp) - ENDIF - ENDDO - ENDIF - CALL mpi_bcast(pred_fy3d_tb_h_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast(pred_fy3d_tb_v_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (DEF_DA_SM_SYNOP) THEN - ! crop corresponding index (rank id and patch id) of each observation - IF (has_synop_obs) THEN - synop_idx(:,:) = -1 - IF (p_is_root) THEN - synop_idx = synop_lut(:, synop_id) - ENDIF - CALL mpi_bcast(synop_idx, 2*num_synop_obs, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - ENDIF - - ! recount the number of observations at each rank - IF (has_synop_obs) THEN - IF (p_is_compute) THEN - counter_rank_nsite = 0 - DO i = 1, num_synop_obs - IF (synop_idx(1, i) == p_iam_glb) THEN - counter_rank_nsite = counter_rank_nsite + 1 - ENDIF - ENDDO - ENDIF - ENDIF - - ! allocate memory for rank - IF (has_synop_obs) THEN - IF (p_is_compute) THEN - IF (counter_rank_nsite > 0) THEN - IF (allocated(tref_ens_rank)) deallocate (tref_ens_rank) - IF (allocated(qref_ens_rank)) deallocate (qref_ens_rank) - IF (allocated(site_id_rank)) deallocate (site_id_rank) - allocate (tref_ens_rank (counter_rank_nsite, DEF_DA_ENS_NUM)) - allocate (qref_ens_rank (counter_rank_nsite, DEF_DA_ENS_NUM)) - allocate (site_id_rank (counter_rank_nsite)) - ENDIF - ENDIF - ENDIF - - ! crop observations at each rank according index & send to root - IF (has_synop_obs) THEN - IF (p_is_compute) THEN - counter_rank_nsite = 0 - DO i = 1, num_synop_obs - IF (synop_idx(1, i) == p_iam_glb) THEN - counter_rank_nsite = counter_rank_nsite + 1 - tref_ens_rank(counter_rank_nsite,:) = tref_ens(:, synop_idx(2, i)) - qref_ens_rank(counter_rank_nsite,:) = rhref_ens(:, synop_idx(2, i)) - site_id_rank (counter_rank_nsite) = i - ENDIF - ENDDO - -#ifdef USEMPI - ! send the number of site and their patch id to root - mesg = (/p_iam_glb, counter_rank_nsite/) - CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (counter_rank_nsite > 0) THEN - CALL mpi_send(tref_ens_rank, DEF_DA_ENS_NUM*counter_rank_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send(qref_ens_rank, DEF_DA_ENS_NUM*counter_rank_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send(site_id_rank, counter_rank_nsite, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#endif - - IF (allocated(tref_ens_rank)) deallocate (tref_ens_rank) - IF (allocated(qref_ens_rank)) deallocate (qref_ens_rank) - IF (allocated(site_id_rank)) deallocate (site_id_rank) - ENDIF - ENDIF - - ! concatenate all predicted observations at root & broadcast to all ranks - IF (has_synop_obs) THEN - qref_ens_o = spval - tref_ens_o = spval - IF (p_is_root) THEN -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - ndata = mesg(2) - - IF (ndata > 0) THEN - allocate(tref_ens_rank(ndata, DEF_DA_ENS_NUM)) - allocate(qref_ens_rank(ndata, DEF_DA_ENS_NUM)) - allocate(site_id_rank (ndata)) - - CALL mpi_recv(tref_ens_rank, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv(qref_ens_rank, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv(site_id_rank, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - qref_ens_o(site_id_rank,:) = qref_ens_rank - tref_ens_o(site_id_rank,:) = tref_ens_rank - ENDIF - - IF (allocated(tref_ens_rank)) deallocate(tref_ens_rank) - IF (allocated(qref_ens_rank)) deallocate(qref_ens_rank) - IF (allocated(site_id_rank)) deallocate(site_id_rank) - ENDDO -#endif - ENDIF - CALL mpi_bcast(qref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast(tref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_root, p_comm_glb, p_err) - ENDIF - ENDIF -#endif - -!############################################################################# -! Run data assimilation (for only DA) -!############################################################################# - has_DA = .false. - IF (has_smap_obs .or. has_fy3d_obs .or. has_synop_obs) THEN - ! for grid data assimilation - IF (p_is_compute) THEN - DO np = 1, numpatch - -!############################################################################# -! 1. Find observations around each patch -!############################################################################# - ! regions info around target patch - lat_p_n = patchlatr(np)*180/pi + dres - lat_p_s = patchlatr(np)*180/pi - dres - lon_p_w = patchlonr(np)*180/pi - dres - lon_p_e = patchlonr(np)*180/pi + dres - - ! find observations around each patch - num_obs_p = 0 - num_smap_p = 0 - num_fy3d_p = 0 - num_synop_p = 0 - IF (DEF_DA_SM_SMAP) THEN - IF (has_smap_obs) THEN - num_smap_p = count(smap_lat(:) < lat_p_n .and. smap_lat(:) > lat_p_s .and. & - smap_lon(:) > lon_p_w .and. smap_lon(:) < lon_p_e .and. & - smap_time(:) - idate_b >= 0 .and. smap_time(:) - idate_e <= 0 .and. & - smap_tb_h_mean(:) > 0 .and. pred_smap_tb_h_mean(:) > 0) - ENDIF - ENDIF - IF (DEF_DA_SM_FY) THEN - IF (has_fy3d_obs) THEN - num_fy3d_p = count(fy3d_lat(:) < lat_p_n .and. fy3d_lat(:) > lat_p_s .and. & - fy3d_lon(:) > lon_p_w .and. fy3d_lon(:) < lon_p_e .and. & - fy3d_time(:) - idate_b >= 0 .and. fy3d_time(:) - idate_e <= 0 .and. & - fy3d_tb_h_mean(:) > 0 .and. pred_fy3d_tb_h_mean(:) > 0) - ENDIF - ENDIF - IF (DEF_DA_SM_SYNOP) THEN - IF (has_synop_obs) THEN - num_synop_p = count( & - synop_lat(:) < lat_p_n .and. synop_lat(:) > lat_p_s .and. & - synop_lon(:) > lon_p_w .and. synop_lon(:) < lon_p_e .and. & - synop_time(:) - idate_b >= 0 .and. synop_time(:) - idate_e <= 0 .and. & - tref_ens_o(:,1) > 0) - ENDIF - ENDIF - num_obs_p = num_smap_p + num_fy3d_p + 2*num_synop_p - -!############################################################################# -! 2. Perform data assimilation -!############################################################################# - IF (num_obs_p > 0) THEN - ! allocate memory for data assimilation - allocate (obs_err (num_obs_p )) - allocate (trans (DEF_DA_ENS_NUM,DEF_DA_ENS_NUM)) - allocate (wliq_soi_ens (nl_soil, DEF_DA_ENS_NUM )) - allocate (wliq_soi_ens_da(nl_soil, DEF_DA_ENS_NUM )) - allocate (t_soi_ens (nl_soil, DEF_DA_ENS_NUM )) - allocate (t_soi_ens_da (nl_soil, DEF_DA_ENS_NUM )) - allocate (pred_obs_p_ens (num_obs_p, DEF_DA_ENS_NUM )) - allocate (obs_p (num_obs_p )) - - -!############################################################################# -! 2.1. Prepare observations around target patch for each observation dataset -!############################################################################# - IF (num_smap_p > 0) THEN - ! allocate memory - allocate (index_smap_p (num_smap_p )) - allocate (smap_lat_p (num_smap_p )) - allocate (smap_lon_p (num_smap_p )) - allocate (smap_tb_h_p (num_smap_p )) - allocate (smap_tb_v_p (num_smap_p )) - allocate (pred_smap_tb_h_p_ens (num_smap_p, DEF_DA_ENS_NUM)) - allocate (pred_smap_tb_v_p_ens (num_smap_p, DEF_DA_ENS_NUM)) - allocate (smap_tb_h_mean_p (num_smap_p )) - allocate (smap_tb_v_mean_p (num_smap_p )) - allocate (pred_smap_tb_h_mean_p(num_smap_p )) - allocate (pred_smap_tb_v_mean_p(num_smap_p )) - allocate (smap_err (num_smap_p )) - allocate (d_smap_p (num_smap_p )) - - ! index of observations around target patch - index_smap_p = (smap_lat(:) < lat_p_n .and. smap_lat(:) > lat_p_s .and. & - smap_lon(:) > lon_p_w .and. smap_lon(:) < lon_p_e .and. & - smap_time(:) - idate_b >= 0 .and. smap_time(:) - idate_e <= 0 .and. & - smap_tb_h_mean(:) > 0 .and. pred_smap_tb_h_mean(:) > 0) - - ! crop observations around target patch - smap_lat_p = pack(smap_lat , index_smap_p) - smap_lon_p = pack(smap_lon , index_smap_p) - smap_tb_h_p = pack(smap_tb_h, index_smap_p) - smap_tb_v_p = pack(smap_tb_v, index_smap_p) - - ! crop ensemble predicted observations around target patch - DO i = 1, DEF_DA_ENS_NUM - pred_smap_tb_h_p_ens(:, i) = pack(pred_smap_tb_h_ogrid_ens(:, i), index_smap_p) - pred_smap_tb_v_p_ens(:, i) = pack(pred_smap_tb_v_ogrid_ens(:, i), index_smap_p) - ENDDO - - ! crop mean values around target patch - smap_tb_h_mean_p = pack(smap_tb_h_mean, index_smap_p) - smap_tb_v_mean_p = pack(smap_tb_v_mean, index_smap_p) - pred_smap_tb_h_mean_p = pack(pred_smap_tb_h_mean, index_smap_p) - pred_smap_tb_v_mean_p = pack(pred_smap_tb_v_mean, index_smap_p) - - ! scaling - smap_tb_h_p = smap_tb_h_p - smap_tb_h_mean_p - smap_tb_v_p = smap_tb_v_p - smap_tb_v_mean_p - DO i = 1, DEF_DA_ENS_NUM - pred_smap_tb_h_p_ens(:, i) = pred_smap_tb_h_p_ens(:, i) - pred_smap_tb_h_mean_p - pred_smap_tb_v_p_ens(:, i) = pred_smap_tb_v_p_ens(:, i) - pred_smap_tb_v_mean_p - ENDDO - - ! calculate distance between observation and patch center - d_smap_p = 2*6.3781e3*asin(sqrt(sin((smap_lat_p*pi/180 - patchlatr(np))/2.0)**2 + & - cos(smap_lat_p*pi/180)*cos(patchlatr(np))*sin((smap_lon_p*pi/180 - patchlonr(np))/2.0)**2)) - - ! calculate weighted observation error - smap_err = static_smap_err/(exp((-d_smap_p**2)/(2*loc_r**2))) - ENDIF - - IF (num_fy3d_p > 0) THEN - ! allocate memory - allocate (index_fy3d_p (num_fy3d_p )) - allocate (fy3d_lat_p (num_fy3d_p )) - allocate (fy3d_lon_p (num_fy3d_p )) - allocate (fy3d_tb_h_p (num_fy3d_p )) - allocate (fy3d_tb_v_p (num_fy3d_p )) - allocate (pred_fy3d_tb_h_p_ens (num_fy3d_p, DEF_DA_ENS_NUM)) - allocate (pred_fy3d_tb_v_p_ens (num_fy3d_p, DEF_DA_ENS_NUM)) - allocate (fy3d_tb_h_mean_p (num_fy3d_p )) - allocate (fy3d_tb_v_mean_p (num_fy3d_p )) - allocate (pred_fy3d_tb_h_mean_p(num_fy3d_p )) - allocate (pred_fy3d_tb_v_mean_p(num_fy3d_p )) - allocate (fy3d_err (num_fy3d_p )) - allocate (d_fy3d_p (num_fy3d_p )) - - ! index of observations around target patch - index_fy3d_p = (fy3d_lat(:) < lat_p_n .and. fy3d_lat(:) > lat_p_s .and. & - fy3d_lon(:) > lon_p_w .and. fy3d_lon(:) < lon_p_e .and. & - fy3d_time(:) - idate_b >= 0 .and. fy3d_time(:) - idate_e <= 0 .and. & - fy3d_tb_h_mean(:) > 0 .and. pred_fy3d_tb_h_mean(:) > 0) - - ! crop observations around target patch - fy3d_lat_p = pack(fy3d_lat , index_fy3d_p) - fy3d_lon_p = pack(fy3d_lon , index_fy3d_p) - fy3d_tb_h_p = pack(fy3d_tb_h, index_fy3d_p) - fy3d_tb_v_p = pack(fy3d_tb_v, index_fy3d_p) - - ! crop ensemble predicted observations around target patch - DO i = 1, DEF_DA_ENS_NUM - pred_fy3d_tb_h_p_ens(:, i) = pack(pred_fy3d_tb_h_ogrid_ens(:, i), index_fy3d_p) - pred_fy3d_tb_v_p_ens(:, i) = pack(pred_fy3d_tb_v_ogrid_ens(:, i), index_fy3d_p) - ENDDO - - ! crop mean values around target patch - fy3d_tb_h_mean_p = pack(fy3d_tb_h_mean, index_fy3d_p) - fy3d_tb_v_mean_p = pack(fy3d_tb_v_mean, index_fy3d_p) - pred_fy3d_tb_h_mean_p = pack(pred_fy3d_tb_h_mean, index_fy3d_p) - pred_fy3d_tb_v_mean_p = pack(pred_fy3d_tb_v_mean, index_fy3d_p) - - ! scaling - fy3d_tb_h_p = fy3d_tb_h_p - fy3d_tb_h_mean_p - fy3d_tb_v_p = fy3d_tb_v_p - fy3d_tb_v_mean_p - DO i = 1, DEF_DA_ENS_NUM - pred_fy3d_tb_h_p_ens(:, i) = pred_fy3d_tb_h_p_ens(:, i) - pred_fy3d_tb_h_mean_p - pred_fy3d_tb_v_p_ens(:, i) = pred_fy3d_tb_v_p_ens(:, i) - pred_fy3d_tb_v_mean_p - ENDDO - - ! calculate distance between observation and patch center - d_fy3d_p = 2*6.3781e3*asin(sqrt(sin((fy3d_lat_p*pi/180 - patchlatr(np))/2.0)**2 + & - cos(fy3d_lat_p*pi/180)*cos(patchlatr(np))*sin((fy3d_lon_p*pi/180 - patchlonr(np))/2.0)**2)) - - ! calculate weighted observation error - fy3d_err = static_fy3d_err/(exp((-d_fy3d_p**2)/(2*loc_r**2))) - ENDIF - - IF (num_synop_p > 0) THEN - ! allocate memory - allocate (index_synop_p (num_synop_p )) - allocate (synop_lat_p (num_synop_p )) - allocate (synop_lon_p (num_synop_p )) - allocate (synop_qref_p (num_synop_p )) - allocate (synop_tref_p (num_synop_p )) - allocate (qref_ens_p (num_synop_p, DEF_DA_ENS_NUM )) - allocate (tref_ens_p (num_synop_p, DEF_DA_ENS_NUM )) - allocate (synop_tref_err (num_synop_p )) - allocate (synop_qref_err (num_synop_p )) - allocate (d_synop_p (num_synop_p )) - - ! index of observations around target patch - index_synop_p = ( & - synop_lat(:) < lat_p_n .and. synop_lat(:) > lat_p_s .and. & - synop_lon(:) > lon_p_w .and. synop_lon(:) < lon_p_e .and. & - synop_time(:) - idate_b >= 0 .and. synop_time(:) - idate_e <= 0 .and. & - tref_ens_o(:,1) > 0) - - ! crop observations around target patch - synop_lat_p = pack(synop_lat, index_synop_p) - synop_lon_p = pack(synop_lon, index_synop_p) - synop_qref_p = pack(synop_qref, index_synop_p) - synop_tref_p = pack(synop_tref, index_synop_p) - - ! crop ensemble predicted observations around target patch - DO i = 1, DEF_DA_ENS_NUM - qref_ens_p(:, i) = pack(qref_ens_o(:, i), index_synop_p) - tref_ens_p(:, i) = pack(tref_ens_o(:, i), index_synop_p) - ENDDO - - ! calculate distance between observation and patch center - d_synop_p = 2*6.3781e3*asin(sqrt(sin((synop_lat_p*pi/180 - patchlatr(np))/2.0)**2 + & - cos(synop_lat_p*pi/180)*cos(patchlatr(np))*sin((synop_lon_p*pi/180 - patchlonr(np))/2.0)**2)) - - ! calculate weighted observation error - synop_tref_err = static_synop_tref_err/(exp((-d_synop_p**2)/(2*loc_r**2))) - synop_qref_err = static_synop_qref_err/(exp((-d_synop_p**2)/(2*loc_r**2))) - ENDIF - -!############################################################################# -! 2.2. Concat observations & ensemble predictions around target patch -!############################################################################# - ! index of end of each observation dataset - end_idx(1) = num_smap_p - end_idx(2) = num_smap_p + num_fy3d_p - end_idx(3) = num_smap_p + num_fy3d_p + num_synop_p - - ! concatenate ensemble predictions - IF (num_smap_p > 0) THEN - pred_obs_p_ens(1:end_idx(1),:) = pred_smap_tb_h_p_ens - obs_p(1:end_idx(1)) = smap_tb_h_p - obs_err(1:end_idx(1)) = smap_err - ENDIF - IF (num_fy3d_p > 0) THEN - pred_obs_p_ens(end_idx(1)+1:end_idx(2),:) = pred_fy3d_tb_h_p_ens - obs_p(end_idx(1)+1:end_idx(2)) = fy3d_tb_h_p - obs_err(end_idx(1)+1:end_idx(2)) = fy3d_err - ENDIF - IF (num_synop_p > 0) THEN - pred_obs_p_ens(end_idx(2)+1:end_idx(3),:) = tref_ens_p - pred_obs_p_ens(end_idx(3)+1:,:) = qref_ens_p - obs_p(end_idx(2)+1:end_idx(3)) = synop_tref_p - obs_p(end_idx(3)+1:) = synop_qref_p - obs_err(end_idx(2)+1:end_idx(3)) = synop_tref_err - obs_err(end_idx(3)+1:) = synop_qref_err - ENDIF - !index_nearest = minloc(d_p, dim=1) - -!############################################################################# -! Perform LETKF and postprocess analysis results -!############################################################################# - ! calculate transformation matrix - CALL letkf(DEF_DA_ENS_NUM, num_obs_p, & - pred_obs_p_ens, obs_p, obs_err, infl, & - trans) - - ! calculate analysis value - IF (patchtype(np) < 3) THEN ! ocean, lake, ice - has_DA = .true. - - ! soil layer - DO iens = 1, DEF_DA_ENS_NUM - wliq_soi_ens(:, iens) = wliq_soisno_ens(1:, iens, np) - t_soi_ens(:, iens) = t_soisno_ens(1:, iens, np) - ENDDO - - ! analysis - CALL dgemm('N', 'N', nl_soil, DEF_DA_ENS_NUM, DEF_DA_ENS_NUM, 1.0_8, wliq_soi_ens, & - nl_soil, trans, DEF_DA_ENS_NUM, 0.0_8, wliq_soi_ens_da, nl_soil) - CALL dgemm('N', 'N', nl_soil, DEF_DA_ENS_NUM, DEF_DA_ENS_NUM, 1.0_8, t_soi_ens, & - nl_soil, trans, DEF_DA_ENS_NUM, 0.0_8, t_soi_ens_da, nl_soil) - - ! save analysis results - wliq_soi_ens_da = max(0.0, wliq_soi_ens_da) - DO iens = 1, DEF_DA_ENS_NUM - wliq_soisno_ens(1:2, iens, np) = wliq_soi_ens_da(1:2, iens) - ! limit the change of t_soisno in range of [-20.0, 20.0] - WHERE (t_soi_ens_da(1:2,iens) > t_soisno_ens(1:2,iens,np)) - t_soisno_ens(1:2,iens,np) = t_soisno_ens(1:2,iens,np) + min(20.0, t_soi_ens_da(1:2,iens)-t_soisno_ens(1:2,iens,np)) - ELSEWHERE - t_soisno_ens(1:2,iens,np) = t_soisno_ens(1:2,iens,np) + max(-20.0, t_soi_ens_da(1:2,iens)-t_soisno_ens(1:2,iens,np)) - ENDWHERE - ENDDO - - ! limit the soil liquid and ice water in a reasonable range - DO i = 1, nl_soil - DO iens = 1, DEF_DA_ENS_NUM - ! lower bound - wliq_soisno_ens(i, iens, np) = max(0.0d0, wliq_soisno_ens(i, iens, np)) - wice_soisno_ens(i, iens, np) = max(0.0d0, wice_soisno_ens(i, iens, np)) - IF (wliq_soisno_ens(i, iens, np) == 0.0 .and. wice_soisno_ens(i, iens, np) == 0.0) THEN - IF (t_soisno_ens(i, iens, np)-tfrz < -5.0) THEN - wice_soisno_ens(i, iens, np) = 1e-10 - ELSE - wliq_soisno_ens(i, iens, np) = 1e-10 - ENDIF - ENDIF - - ! upper bound - wliq_soisno_ens(i, iens, np) = min(porsl(i, np)*(dz_soi(i)*denh2o), wliq_soisno_ens(i, iens, np)) - eff_porsl = max(0.0d0, porsl(i, np) - wliq_soisno_ens(i, iens, np)/(dz_soi(i)*denh2o)) - wice_soisno_ens(i, iens, np) = min(eff_porsl*(dz_soi(i)*denice), wice_soisno_ens(i, iens, np)) - ENDDO - ENDDO - - ! move residual water to water table - wa_ens(:, np) = wa_ens(:, np) - sum(wliq_soisno_ens(1:, :, np) - wliq_soi_ens, dim=1) - - ! update volumetric water content for diagnostic - DO iens = 1, DEF_DA_ENS_NUM - h2osoi_ens(:, iens, np) = wliq_soisno_ens(1:, iens, np)/(dz_soi(:)*denh2o) + wice_soisno_ens(1:, iens, np)/(dz_soi(:)*denice) - h2osoi_ens(:, iens, np) = min(1.0d0, h2osoi_ens(:, iens, np)) - h2osoi_ens(:, iens, np) = max(0.0d0, h2osoi_ens(:, iens, np)) - ENDDO - ENDIF - ENDIF - - -!############################################################################# -! deallocate memory changes with patch -!############################################################################# - IF (allocated(trans )) deallocate (trans ) - IF (allocated(smap_err )) deallocate (smap_err ) - IF (allocated(d_smap_p )) deallocate (d_smap_p ) - IF (allocated(fy3d_err )) deallocate (fy3d_err ) - IF (allocated(d_fy3d_p )) deallocate (d_fy3d_p ) - IF (allocated(synop_tref_err )) deallocate (synop_tref_err ) - IF (allocated(synop_qref_err )) deallocate (synop_qref_err ) - IF (allocated(d_synop_p )) deallocate (d_synop_p ) - IF (allocated(pred_obs_p_ens )) deallocate (pred_obs_p_ens ) - IF (allocated(obs_p )) deallocate (obs_p ) - IF (allocated(obs_err )) deallocate (obs_err ) - IF (allocated(wliq_soi_ens )) deallocate (wliq_soi_ens ) - IF (allocated(wliq_soi_ens_da )) deallocate (wliq_soi_ens_da ) - IF (allocated(t_soi_ens )) deallocate (t_soi_ens ) - IF (allocated(t_soi_ens_da )) deallocate (t_soi_ens_da ) - - IF (allocated(index_smap_p )) deallocate (index_smap_p ) - IF (allocated(smap_lat_p )) deallocate (smap_lat_p ) - IF (allocated(smap_lon_p )) deallocate (smap_lon_p ) - IF (allocated(smap_tb_h_p )) deallocate (smap_tb_h_p ) - IF (allocated(smap_tb_v_p )) deallocate (smap_tb_v_p ) - IF (allocated(pred_smap_tb_h_p_ens )) deallocate (pred_smap_tb_h_p_ens ) - IF (allocated(pred_smap_tb_v_p_ens )) deallocate (pred_smap_tb_v_p_ens ) - IF (allocated(smap_tb_h_mean_p )) deallocate (smap_tb_h_mean_p ) - IF (allocated(pred_smap_tb_h_mean_p)) deallocate (pred_smap_tb_h_mean_p) - IF (allocated(smap_tb_v_mean_p )) deallocate (smap_tb_v_mean_p ) - IF (allocated(pred_smap_tb_v_mean_p)) deallocate (pred_smap_tb_v_mean_p) - - IF (allocated(index_fy3d_p )) deallocate (index_fy3d_p ) - IF (allocated(fy3d_lat_p )) deallocate (fy3d_lat_p ) - IF (allocated(fy3d_lon_p )) deallocate (fy3d_lon_p ) - IF (allocated(fy3d_tb_h_p )) deallocate (fy3d_tb_h_p ) - IF (allocated(fy3d_tb_v_p )) deallocate (fy3d_tb_v_p ) - IF (allocated(pred_fy3d_tb_h_p_ens )) deallocate (pred_fy3d_tb_h_p_ens ) - IF (allocated(pred_fy3d_tb_v_p_ens )) deallocate (pred_fy3d_tb_v_p_ens ) - IF (allocated(fy3d_tb_h_mean_p )) deallocate (fy3d_tb_h_mean_p ) - IF (allocated(pred_fy3d_tb_h_mean_p)) deallocate (pred_fy3d_tb_h_mean_p) - IF (allocated(fy3d_tb_v_mean_p )) deallocate (fy3d_tb_v_mean_p ) - IF (allocated(pred_fy3d_tb_v_mean_p)) deallocate (pred_fy3d_tb_v_mean_p) - - IF (allocated(index_synop_p )) deallocate (index_synop_p ) - IF (allocated(synop_lat_p )) deallocate (synop_lat_p ) - IF (allocated(synop_lon_p )) deallocate (synop_lon_p ) - IF (allocated(synop_qref_p )) deallocate (synop_qref_p ) - IF (allocated(synop_tref_p )) deallocate (synop_tref_p ) - IF (allocated(qref_ens_p )) deallocate (qref_ens_p ) - IF (allocated(tref_ens_p )) deallocate (tref_ens_p ) - ENDDO - ENDIF - ENDIF - - -!############################################################################# -! Calculate ensemble brightness temperature after DA for diagnostic -!############################################################################# - IF (has_DA) THEN - IF (p_is_compute) THEN - IF (DEF_DA_SM_SMAP) THEN - IF (DEF_DA_ENS_NUM > 1) THEN - DO iens = 1, DEF_DA_ENS_NUM - DO np = 1, numpatch - CALL forward(& - patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & - forc_topo(np), htop(np), & - tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & - wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & - snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & - wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & - smap_theta, smap_fghz, & - t_brt_smap_ens(1,iens,np), t_brt_smap_ens(2,iens,np)) - ENDDO - ENDDO - ENDIF - ENDIF - - IF (DEF_DA_SM_FY) THEN - IF (DEF_DA_ENS_NUM > 1) THEN - DO iens = 1, DEF_DA_ENS_NUM - DO np = 1, numpatch - CALL forward(& - patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), & - forc_topo(np), htop(np), & - tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), & - wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), & - snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), & - wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), & - fy3d_theta, fy3d_fghz, & - t_brt_fy3d_ens(1,iens,np), t_brt_fy3d_ens(2,iens,np)) - ENDDO - ENDDO - ENDIF - ENDIF - ENDIF - ENDIF - -!############################################################################# -! Deallocate all memory -!############################################################################# - IF (allocated (trans)) deallocate (trans) - IF (allocated (obs_err)) deallocate (obs_err) - IF (allocated (filter )) deallocate (filter ) - IF (allocated (wliq_soi_ens)) deallocate (wliq_soi_ens) - IF (allocated (wliq_soi_ens_da)) deallocate (wliq_soi_ens_da) - IF (allocated (t_soi_ens)) deallocate (t_soi_ens) - IF (allocated (t_soi_ens_da)) deallocate (t_soi_ens_da) - - IF (allocated (smap_time)) deallocate (smap_time) - IF (allocated (dt_b_smap)) deallocate (dt_b_smap) - IF (allocated (dt_e_smap)) deallocate (dt_e_smap) - IF (allocated (smap_lat)) deallocate (smap_lat) - IF (allocated (smap_lon)) deallocate (smap_lon) - IF (allocated (smap_tb_h)) deallocate (smap_tb_h) - IF (allocated (smap_tb_v)) deallocate (smap_tb_v) - IF (allocated (smap_ii)) deallocate (smap_ii) - IF (allocated (smap_jj)) deallocate (smap_jj) - IF (allocated (smap_tb_h_mean)) deallocate (smap_tb_h_mean) - IF (allocated (smap_tb_v_mean)) deallocate (smap_tb_v_mean) - IF (allocated (pred_smap_tb_h_mean)) deallocate (pred_smap_tb_h_mean) - IF (allocated (pred_smap_tb_v_mean)) deallocate (pred_smap_tb_v_mean) - IF (allocated (pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) - IF (allocated (pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) - IF (allocated (pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens) - IF (allocated (pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens) - - IF (allocated (fy3d_time)) deallocate (fy3d_time) - IF (allocated (dt_b_fy3d)) deallocate (dt_b_fy3d) - IF (allocated (dt_e_fy3d)) deallocate (dt_e_fy3d) - IF (allocated (fy3d_lat)) deallocate (fy3d_lat) - IF (allocated (fy3d_lon)) deallocate (fy3d_lon) - IF (allocated (fy3d_tb_h)) deallocate (fy3d_tb_h) - IF (allocated (fy3d_tb_v)) deallocate (fy3d_tb_v) - IF (allocated (fy3d_ii)) deallocate (fy3d_ii) - IF (allocated (fy3d_jj)) deallocate (fy3d_jj) - IF (allocated (fy3d_tb_h_mean)) deallocate (fy3d_tb_h_mean) - IF (allocated (fy3d_tb_v_mean)) deallocate (fy3d_tb_v_mean) - IF (allocated (pred_fy3d_tb_h_mean)) deallocate (pred_fy3d_tb_h_mean) - IF (allocated (pred_fy3d_tb_v_mean)) deallocate (pred_fy3d_tb_v_mean) - IF (allocated (pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) - IF (allocated (pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) - IF (allocated (pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens) - IF (allocated (pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens) - - IF (allocated (synop_time)) deallocate (synop_time) - IF (allocated (synop_lat)) deallocate (synop_lat) - IF (allocated (synop_lon)) deallocate (synop_lon) - IF (allocated (synop_qref)) deallocate (synop_qref) - IF (allocated (synop_tref)) deallocate (synop_tref) - IF (allocated (tref_ens_o)) deallocate (tref_ens_o) - IF (allocated (qref_ens_o)) deallocate (qref_ens_o) - - IF (allocated (synop_idx)) deallocate (synop_idx) - IF (allocated (site_id_rank)) deallocate (site_id_rank) - IF (allocated (tref_ens_rank)) deallocate (tref_ens_rank) - IF (allocated (qref_ens_rank)) deallocate (qref_ens_rank) - IF (allocated (qref_ens_o)) deallocate (qref_ens_o) - IF (allocated (tref_ens_o)) deallocate (tref_ens_o) - - - - END SUBROUTINE run_DA_SM - -!----------------------------------------------------------------------------- - - SUBROUTINE end_DA_SM() - -!----------------------------------------------------------------------------- - IMPLICIT NONE - -!----------------------------------------------------------------------------- - IF (allocated (trans)) deallocate (trans) - IF (allocated (obs_err)) deallocate (obs_err) - IF (allocated (filter )) deallocate (filter ) - IF (allocated (wliq_soi_ens)) deallocate (wliq_soi_ens) - IF (allocated (wliq_soi_ens_da)) deallocate (wliq_soi_ens_da) - IF (allocated (t_soi_ens)) deallocate (t_soi_ens) - IF (allocated (t_soi_ens_da)) deallocate (t_soi_ens_da) - - IF (allocated (smap_time)) deallocate (smap_time) - IF (allocated (dt_b_smap)) deallocate (dt_b_smap) - IF (allocated (dt_e_smap)) deallocate (dt_e_smap) - IF (allocated (smap_lat)) deallocate (smap_lat) - IF (allocated (smap_lon)) deallocate (smap_lon) - IF (allocated (smap_tb_h)) deallocate (smap_tb_h) - IF (allocated (smap_tb_v)) deallocate (smap_tb_v) - IF (allocated (smap_ii)) deallocate (smap_ii) - IF (allocated (smap_jj)) deallocate (smap_jj) - IF (allocated (smap_tb_h_mean)) deallocate (smap_tb_h_mean) - IF (allocated (smap_tb_v_mean)) deallocate (smap_tb_v_mean) - IF (allocated (pred_smap_tb_h_mean)) deallocate (pred_smap_tb_h_mean) - IF (allocated (pred_smap_tb_v_mean)) deallocate (pred_smap_tb_v_mean) - IF (allocated (pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens) - IF (allocated (pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens) - IF (allocated (pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens) - IF (allocated (pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens) - - IF (allocated (fy3d_time)) deallocate (fy3d_time) - IF (allocated (dt_b_fy3d)) deallocate (dt_b_fy3d) - IF (allocated (dt_e_fy3d)) deallocate (dt_e_fy3d) - IF (allocated (fy3d_lat)) deallocate (fy3d_lat) - IF (allocated (fy3d_lon)) deallocate (fy3d_lon) - IF (allocated (fy3d_tb_h)) deallocate (fy3d_tb_h) - IF (allocated (fy3d_tb_v)) deallocate (fy3d_tb_v) - IF (allocated (fy3d_ii)) deallocate (fy3d_ii) - IF (allocated (fy3d_jj)) deallocate (fy3d_jj) - IF (allocated (fy3d_tb_h_mean)) deallocate (fy3d_tb_h_mean) - IF (allocated (fy3d_tb_v_mean)) deallocate (fy3d_tb_v_mean) - IF (allocated (pred_fy3d_tb_h_mean)) deallocate (pred_fy3d_tb_h_mean) - IF (allocated (pred_fy3d_tb_v_mean)) deallocate (pred_fy3d_tb_v_mean) - IF (allocated (pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens) - IF (allocated (pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens) - IF (allocated (pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens) - IF (allocated (pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens) - - IF (allocated (synop_time)) deallocate (synop_time) - IF (allocated (synop_lat)) deallocate (synop_lat) - IF (allocated (synop_lon)) deallocate (synop_lon) - IF (allocated (synop_qref)) deallocate (synop_qref) - IF (allocated (synop_tref)) deallocate (synop_tref) - IF (allocated (tref_ens_o)) deallocate (tref_ens_o) - IF (allocated (qref_ens_o)) deallocate (qref_ens_o) - - IF (allocated (synop_idx)) deallocate (synop_idx) - IF (allocated (site_id_rank)) deallocate (site_id_rank) - IF (allocated (tref_ens_rank)) deallocate (tref_ens_rank) - IF (allocated (qref_ens_rank)) deallocate (qref_ens_rank) - IF (allocated (qref_ens_o)) deallocate (qref_ens_o) - IF (allocated (tref_ens_o)) deallocate (tref_ens_o) - - - END SUBROUTINE end_DA_SM - -!----------------------------------------------------------------------------- -END MODULE MOD_DA_SM -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 deleted file mode 100644 index 90d2e17f9a..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 +++ /dev/null @@ -1,440 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_TWS -!----------------------------------------------------------------------------- -! DESCRIPTION: -! Data assimilation of terrestrial water storge from GRACE satellite -! -! AUTHOR: -! Shupeng Zhang: Initial version -!----------------------------------------------------------------------------- - USE MOD_DataType - USE MOD_SpatialMapping - - IMPLICIT NONE - - PUBLIC :: init_DA_GRACE - PUBLIC :: run_DA_GRACE - PUBLIC :: end_DA_GRACE - - real(r8), allocatable, PUBLIC :: fslp_k_mon (:,:) ! slope factor of runoff - real(r8), allocatable, PUBLIC :: fslp_k (:) ! slope factor of runoff - - PRIVATE - - character(len=256) :: file_grace - type(grid_type) :: grid_grace - - real(r8), allocatable :: longrace(:) - real(r8), allocatable :: latgrace(:) - - integer :: nobstime - integer, allocatable :: obsyear (:) - integer, allocatable :: obsmonth (:) - - type (spatial_mapping_type) :: mg2p_grace - - real(r8), allocatable :: lwe_obs_this (:) - real(r8), allocatable :: err_obs_this (:) - - real(r8), allocatable :: lwe_obs_prev (:) - real(r8), allocatable :: err_obs_prev (:) - - real(r8), allocatable :: wat_prev_m (:) - real(r8), allocatable :: wat_this_m (:) - - real(r8), allocatable :: rnof_acc_prev_m (:) - real(r8), allocatable :: rnof_acc_this_m (:) - real(r8), allocatable :: zwt_acc_prev_m (:) - real(r8), allocatable :: zwt_acc_this_m (:) - - real(r8), allocatable :: rnof_prev_m0 (:) - real(r8), allocatable :: rnof_prev_m1 (:) - real(r8), allocatable :: rnof_this_m (:) - - logical, allocatable :: rnofmask (:) - - logical :: has_prev_grace_obs - integer :: nac_grace_this, nac_grace_prev - - integer :: year_prev, month_prev - -CONTAINS - - ! ---------- - SUBROUTINE init_DA_GRACE () - - USE MOD_Spmd_Task - USE MOD_Namelist, only : DEF_DA_obsdir - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_Mesh, only : numelm - USE MOD_LandElm, only : landelm - USE MOD_LandPatch -#ifdef CROP - USE MOD_LandCrop -#endif - USE MOD_Pixelset - USE MOD_Vars_TimeInvariants, only : patchtype - USE MOD_Forcing, only : forcmask_pch - USE MOD_RangeCheck - IMPLICIT NONE - - ! Local Variables - - real(r8), allocatable :: time_real8(:) - integer :: itime - - file_grace = trim(DEF_DA_obsdir) & - // '/GRACE_JPL/GRCTellus.JPL.200204_202207.GLO.RL06M.MSCNv02CRI.nc' - - CALL ncio_read_bcast_serial (file_grace, 'time', time_real8) - - nobstime = size(time_real8) - allocate (obsyear (nobstime)) - allocate (obsmonth(nobstime)) - - DO itime = 1, nobstime - CALL retrieve_yymm_from_days (time_real8(itime), obsyear(itime), obsmonth(itime)) - ENDDO - - IF (p_is_root) THEN - write(*,*) 'Assimilate GRACE data at' - DO itime = 1, nobstime - write(*,*) obsyear(itime), obsmonth(itime) - ENDDO - ENDIF - - CALL ncio_read_bcast_serial (file_grace, 'lon', longrace) - CALL ncio_read_bcast_serial (file_grace, 'lat', latgrace) - - CALL grid_grace%define_by_center (latgrace,longrace) - - CALL mg2p_grace%build_arealweighted (grid_grace, landelm) - - IF (p_is_compute) THEN - IF (numelm > 0) THEN - allocate (lwe_obs_this (numelm)) - allocate (err_obs_this (numelm)) - allocate (lwe_obs_prev (numelm)) - allocate (err_obs_prev (numelm)) - ENDIF - - IF (numpatch > 0) THEN - allocate (wat_prev_m (numpatch)) - allocate (wat_this_m (numpatch)) - allocate (rnof_acc_prev_m (numpatch)) - allocate (rnof_acc_this_m (numpatch)) - allocate (zwt_acc_prev_m (numpatch)) - allocate (zwt_acc_this_m (numpatch)) - allocate (rnof_prev_m0 (numpatch)) - allocate (rnof_prev_m1 (numpatch)) - allocate (rnof_this_m (numpatch)) - allocate (rnofmask (numpatch)) - - allocate (fslp_k_mon (12,numpatch)) - allocate (fslp_k (numpatch)) - ENDIF - ENDIF - - IF (p_is_compute) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) - ENDIF - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - rnofmask = patchtype == 0 - IF (DEF_forcing%has_missing_value) THEN - rnofmask = rnofmask .and. forcmask_pch - ENDIF - ENDIF - ENDIF - - - has_prev_grace_obs = .false. - - nac_grace_this = 0 - nac_grace_prev = 0 - - IF (p_is_compute) THEN - wat_this_m (:) = 0. - rnof_acc_this_m(:) = 0. - rnof_this_m (:) = 0. - zwt_acc_this_m (:) = 0. - fslp_k_mon (:,:) = 1.0 - fslp_k (:) = 1.0 - ENDIF - - deallocate (time_real8) - - END SUBROUTINE init_DA_GRACE - - ! ---------- - SUBROUTINE run_DA_GRACE (idate, deltim) - - USE MOD_Spmd_task - USE MOD_TimeManager - USE MOD_NetCDFBlock - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_Vars_1DFluxes, only : rnof, rsur - USE MOD_Vars_TimeVariables, only : wat, wa, wdsrf, zwt - USE MOD_RangeCheck - USE MOD_UserDefFun - IMPLICIT NONE - - integer, intent(in) :: idate(3) - real(r8), intent(in) :: deltim - - ! Local Variables - logical :: is_obs_time - integer :: month, mday, itime, ielm, istt, iend, nextmonth - - real(r8) :: sumpct - real(r8) :: w1, w0, r1, r0, var_o, var_m, dw_f, dw_o, dw_a, rr, zwt_ave - real(r8) :: fscal, fprev, fthis - - type(block_data_real8_2d) :: f_grace_lwe ! unit: cm - type(block_data_real8_2d) :: f_grace_err ! unit: cm - - character(len=256) :: sid, logfile - - CALL julian2monthday (idate(1), idate(2), month, mday) - - is_obs_time = any((obsyear == idate(1)) .and. (obsmonth == month)) - - IF (p_is_root) THEN - IF (is_obs_time) THEN - write(*,*) 'GRACE at this time.' - ENDIF - ENDIF - - IF (p_is_compute) THEN - - IF (has_prev_grace_obs) THEN - - nac_grace_prev = nac_grace_prev + 1 - - rnof_acc_prev_m = rnof_acc_prev_m + rnof * deltim - IF (is_obs_time) THEN - rnof_prev_m1 = rnof_prev_m1 + rnof_acc_prev_m - ENDIF - - zwt_acc_prev_m = zwt_acc_prev_m + zwt - ENDIF - - IF (is_obs_time) THEN - - nac_grace_this = nac_grace_this + 1 - - wat_this_m = wat_this_m + wat + wa + wdsrf - - rnof_acc_this_m = rnof_acc_this_m + rnof * deltim - rnof_this_m = rnof_this_m + rnof_acc_this_m - - zwt_acc_this_m = zwt_acc_this_m + zwt - ENDIF - - ENDIF - - IF (is_obs_time .and. (isendofmonth(idate, deltim))) THEN - - itime = findloc_ud((obsyear == idate(1)) .and. (obsmonth == month)) - - IF (p_is_active) THEN - CALL allocate_block_data (grid_grace, f_grace_lwe) - CALL allocate_block_data (grid_grace, f_grace_err) - CALL ncio_read_block_time (file_grace, 'lwe_thickness', grid_grace, itime, f_grace_lwe) - CALL ncio_read_block_time (file_grace, 'uncertainty' , grid_grace, itime, f_grace_err) - ENDIF - - CALL mg2p_grace%grid2pset (f_grace_lwe, lwe_obs_this) - CALL mg2p_grace%grid2pset (f_grace_err, err_obs_this) - - IF (p_is_compute) THEN - - lwe_obs_this = lwe_obs_this * 10.0 ! from cm to mm - err_obs_this = err_obs_this * 10.0 ! from cm to mm - - wat_this_m = wat_this_m / nac_grace_this - - zwt_acc_prev_m = zwt_acc_prev_m / nac_grace_prev - - IF (has_prev_grace_obs) THEN - rnof_prev_m1 = rnof_prev_m1 / nac_grace_this - ENDIF - - IF (has_prev_grace_obs .and. & - (((idate(1) == year_prev) .and. (month_prev == month-1)) & - .or. ((idate(1) == year_prev+1) .and. (month_prev == 12) .and. (month == 1)))) & - THEN - - ! write(sid,'(I0)') p_iam_compute - ! logfile = 'log/grace_log_' // trim(sid) // '.txt' - ! open(12, file = trim(logfile), position = 'append') - - DO ielm = 1, numelm - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - - sumpct = sum(elm_patch%subfrc(istt:iend), mask = rnofmask(istt:iend)) - - IF (sumpct <= 0) THEN - CYCLE - ENDIF - - w1 = sum(wat_this_m (istt:iend) * elm_patch%subfrc(istt:iend), & - mask = rnofmask(istt:iend)) / sumpct - w0 = sum(wat_prev_m (istt:iend) * elm_patch%subfrc(istt:iend), & - mask = rnofmask(istt:iend)) / sumpct - r1 = sum(rnof_prev_m1(istt:iend) * elm_patch%subfrc(istt:iend), & - mask = rnofmask(istt:iend)) / sumpct - r0 = sum(rnof_prev_m0(istt:iend) * elm_patch%subfrc(istt:iend), & - mask = rnofmask(istt:iend)) / sumpct - - zwt_ave = sum(zwt_acc_prev_m(istt:iend) * elm_patch%subfrc(istt:iend), & - mask = rnofmask(istt:iend)) / sumpct - - - var_o = err_obs_this(ielm)**2 + err_obs_prev(ielm)**2 - - dw_f = w1 - w0 - dw_o = lwe_obs_this(ielm) - lwe_obs_prev(ielm) - var_m = (dw_f-dw_o)**2 - var_o - - IF (var_m > 0) THEN - - dw_a = (var_o * dw_f + var_m * dw_o) / (var_m+var_o) - - rr = r1 - r0 - - IF (rr > 0) THEN - - fscal = (1-(dw_a-dw_f)/rr) - - ! (2) method 2: one parameters adjusted - fprev = fslp_k_mon(month,istt) - fthis = fprev * fscal - fthis = min(max(fthis, fprev*0.5), fprev*2.0) - fslp_k_mon(month,istt:iend) = fthis - - fprev = fslp_k_mon(month_prev,istt) - fthis = fprev * fscal - fthis = min(max(fthis, fprev*0.5), fprev*2.0) - fslp_k_mon(month_prev,istt:iend) = fthis - - ! write(12,'(I4,I3,I8,8ES11.2)') idate(1), month, landelm%eindex(ielm), & - ! dw_o, sqrt(var_o), dw_f, sqrt(var_m), dw_a, & - ! rr, zwt_ave, fscal - - ENDIF - - ENDIF - - ENDDO - - ! close(12) - ENDIF - - lwe_obs_prev = lwe_obs_this - err_obs_prev = err_obs_this - - wat_prev_m = wat_this_m - wat_this_m = 0. - - rnof_acc_prev_m = rnof_acc_this_m - rnof_acc_this_m = 0. - - zwt_acc_prev_m = zwt_acc_this_m - zwt_acc_this_m = 0. - - rnof_prev_m0 = rnof_this_m / nac_grace_this - rnof_prev_m1 = 0. - rnof_this_m = 0. - - nac_grace_prev = nac_grace_this - nac_grace_this = 0 - - ENDIF - - has_prev_grace_obs = .true. - year_prev = idate(1) - month_prev = month - - ENDIF - - IF (isendofmonth(idate, deltim)) THEN - IF (p_is_compute .and. (numpatch > 0)) THEN - nextmonth = mod(month+1,12)+1 - fslp_k = fslp_k_mon(nextmonth,:) - ENDIF - ENDIF - - - END SUBROUTINE run_DA_GRACE - - ! --------- - SUBROUTINE end_DA_GRACE () - - IMPLICIT NONE - - IF (allocated(lwe_obs_this)) deallocate(lwe_obs_this) - IF (allocated(err_obs_this)) deallocate(err_obs_this) - IF (allocated(lwe_obs_prev)) deallocate(lwe_obs_prev) - IF (allocated(err_obs_prev)) deallocate(err_obs_prev) - IF (allocated(wat_prev_m )) deallocate(wat_prev_m ) - IF (allocated(wat_this_m )) deallocate(wat_this_m ) - IF (allocated(rnof_acc_prev_m)) deallocate(rnof_acc_prev_m) - IF (allocated(rnof_acc_this_m)) deallocate(rnof_acc_this_m) - IF (allocated(rnof_prev_m0 )) deallocate(rnof_prev_m0 ) - IF (allocated(rnof_prev_m1 )) deallocate(rnof_prev_m1 ) - IF (allocated(rnof_this_m )) deallocate(rnof_this_m ) - IF (allocated(rnofmask )) deallocate(rnofmask ) - - IF (allocated(fslp_k_mon)) deallocate(fslp_k_mon) - IF (allocated(fslp_k)) deallocate(fslp_k) - - IF (allocated(longrace)) deallocate(longrace) - IF (allocated(latgrace)) deallocate(latgrace) - - END SUBROUTINE end_DA_GRACE - - ! --------- - SUBROUTINE retrieve_yymm_from_days (days, yy, mm) - - IMPLICIT NONE - real(r8), intent(in) :: days - integer, intent(out) :: yy, mm - - ! Local Variables - real(r8) :: resday - integer :: mdays(12) - - yy = 2002 - mm = 1 - mdays = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) - - resday = days - DO WHILE (resday > mdays(mm)) - - resday = resday - mdays(mm) - - mm = mm + 1 - IF (mm > 12) THEN - yy = yy + 1 - mm = 1 - IF( (mod(yy,4)==0 .and. mod(yy,100)/=0) .or. mod(yy,400)==0 ) THEN - mdays(2) = 29 - ELSE - mdays(2) = 28 - ENDIF - ENDIF - - ENDDO - - END SUBROUTINE retrieve_yymm_from_days - -END MODULE MOD_DA_TWS -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 deleted file mode 100644 index eb71a15d76..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 +++ /dev/null @@ -1,92 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_Vars_1DFluxes -!----------------------------------------------------------------------------- -! DESCRIPTION: -! Process fluxes variables for diagnostic for data assimilation -! -! AUTHOR: -! Lu Li, 07/2025: Initial version -!----------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Namelist, only: DEF_DA_ENS_NUM - IMPLICIT NONE - SAVE - - ! public functions - PUBLIC :: allocate_1D_DAFluxes - PUBLIC :: deallocate_1D_DAFluxes - - ! define variables - real(r8), allocatable :: fsena_ens (:,:) ! sensible heat from canopy height to atmosphere [W/m2] - real(r8), allocatable :: lfevpa_ens (:,:) ! latent heat flux from canopy height to atmosphere [W/m2] - real(r8), allocatable :: fevpa_ens (:,:) ! evapotranspiration from canopy to atmosphere [mm/s] - real(r8), allocatable :: rsur_ens (:,:) ! surface runoff (mm h2o/s) - - ! save for analysis increment - real(r8), allocatable :: fsena_a (:) ! - real(r8), allocatable :: fevpa_a (:) ! - real(r8), allocatable :: lfevpa_a (:) ! - real(r8), allocatable :: rsur_a (:) ! - -!----------------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------------- - - SUBROUTINE allocate_1D_DAFluxes () - -!----------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_LandPatch - IMPLICIT NONE - -!----------------------------------------------------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - allocate ( fsena_ens (DEF_DA_ENS_NUM, numpatch) ) ; fsena_ens (:,:) = spval - allocate ( lfevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; lfevpa_ens (:,:) = spval - allocate ( fevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; fevpa_ens (:,:) = spval - allocate ( rsur_ens (DEF_DA_ENS_NUM, numpatch) ) ; rsur_ens (:,:) = spval - - allocate ( fsena_a (numpatch) ) ; fsena_a (:) = spval - allocate ( fevpa_a (numpatch) ) ; fevpa_a (:) = spval - allocate ( lfevpa_a (numpatch) ) ; lfevpa_a (:) = spval - allocate ( rsur_a (numpatch) ) ; rsur_a (:) = spval - ENDIF - ENDIF - - END SUBROUTINE allocate_1D_DAFluxes - -!----------------------------------------------------------------------------- - - SUBROUTINE deallocate_1D_DAFluxes() - -!----------------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPatch - -!----------------------------------------------------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - deallocate ( fsena_ens ) - deallocate ( lfevpa_ens ) - deallocate ( fevpa_ens ) - deallocate ( rsur_ens ) - - deallocate ( fsena_a ) - deallocate ( fevpa_a ) - deallocate ( lfevpa_a ) - deallocate ( rsur_a ) - ENDIF - ENDIF - - END SUBROUTINE deallocate_1D_DAFluxes - -!----------------------------------------------------------------------------- -END MODULE MOD_DA_Vars_1DFluxes -#endif \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 deleted file mode 100644 index c082dcdfac..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 +++ /dev/null @@ -1,716 +0,0 @@ -#include - -#ifdef DataAssimilation -MODULE MOD_DA_Vars_TimeVariables -!----------------------------------------------------------------------------- -! DESCRIPTION: -! Process time-varying state variables for data assimilation -! -! AUTHOR: -! Lu Li, 12/2024: Initial version -! Lu Li, 07/2025: Remove unused variables and clean codes -!----------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_TimeManager - USE MOD_Namelist, only: DEF_DA_ENS_NUM - IMPLICIT NONE - SAVE - - ! public functions - PUBLIC :: allocate_DATimeVariables - PUBLIC :: deallocate_DATimeVariables - PUBLIC :: READ_DATimeVariables - PUBLIC :: WRITE_DATimeVariables -#ifdef RangeCheck - PUBLIC :: check_DATimeVariables -#endif - - ! define variables - ! Time-varying state variables which required by restart run, used to store tha noda trajectory state variable - real(r8), allocatable :: z_sno_noda (:,:) ! node depth [m] - real(r8), allocatable :: dz_sno_noda (:,:) ! interface depth [m] - real(r8), allocatable :: t_soisno_noda (:,:) ! soil temperature [K] - real(r8), allocatable :: wliq_soisno_noda (:,:) ! liquid water in layers [kg/m2] - real(r8), allocatable :: wice_soisno_noda (:,:) ! ice lens in layers [kg/m2] - real(r8), allocatable :: smp_noda (:,:) ! soil matrix potential [mm] - real(r8), allocatable :: hk_noda (:,:) ! hydraulic conductivity [mm h2o/s] - real(r8), allocatable :: t_grnd_noda (:) ! ground surface temperature [K] - real(r8), allocatable :: tleaf_noda (:) ! leaf temperature [K] - real(r8), allocatable :: ldew_noda (:) ! depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain_noda (:) ! depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_noda (:) ! depth of rain on foliage [mm] - real(r8), allocatable :: fwet_snow_noda (:) ! vegetation snow fractional cover [-] - real(r8), allocatable :: sag_noda (:) ! non dimensional snow age [-] - real(r8), allocatable :: scv_noda (:) ! snow cover, water equivalent [mm] - real(r8), allocatable :: snowdp_noda (:) ! snow depth [meter] - real(r8), allocatable :: fveg_noda (:) ! fraction of vegetation cover - real(r8), allocatable :: fsno_noda (:) ! fraction of snow cover on ground - real(r8), allocatable :: sigf_noda (:) ! fraction of veg cover, excluding snow-covered veg [-] - real(r8), allocatable :: green_noda (:) ! leaf greenness - real(r8), allocatable :: tlai_noda (:) ! leaf area index - real(r8), allocatable :: lai_noda (:) ! leaf area index - real(r8), allocatable :: tsai_noda (:) ! stem area index - real(r8), allocatable :: sai_noda (:) ! stem area index - real(r8), allocatable :: alb_noda (:,:,:) ! averaged albedo [-] - real(r8), allocatable :: ssun_noda (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssha_noda (:,:,:) ! shaded canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssoi_noda (:,:,:) ! soil absorption for solar radiation (0-1) - real(r8), allocatable :: ssno_noda (:,:,:) ! snow absorption for solar radiation (0-1) - real(r8), allocatable :: thermk_noda (:) ! canopy gap fraction for tir radiation - real(r8), allocatable :: extkb_noda (:) ! (k, g(mu)/mu) direct solar extinction coefficient - real(r8), allocatable :: extkd_noda (:) ! diffuse and scattered diffuse PAR extinction coefficient - real(r8), allocatable :: zwt_noda (:) ! the depth to water table [m] - real(r8), allocatable :: wdsrf_noda (:) ! depth of surface water [mm] - real(r8), allocatable :: wa_noda (:) ! water storage in aquifer [mm] - real(r8), allocatable :: wetwat_noda (:) ! water storage in wetland [mm] - real(r8), allocatable :: t_lake_noda (:,:) ! lake layer teperature [K] - real(r8), allocatable :: lake_icefrac_noda(:,:) ! lake mass fraction of lake layer that is frozen - real(r8), allocatable :: savedtke1_noda (:) ! top level eddy conductivity (W/m K) - - ! diagnostic variables for RTM forward operator - real(r8), allocatable :: tref_noda (:) ! 2 m height air temperature [kelvin] - real(r8), allocatable :: h2osoi_noda (:,:) ! volumetric soil water in layers [m3/m3] - - ! Time-varying state variables which required by restart run - real(r8), allocatable :: z_sno_ens (:,:,:) ! node depth [m] - real(r8), allocatable :: dz_sno_ens (:,:,:) ! interface depth [m] - real(r8), allocatable :: t_soisno_ens (:,:,:) ! soil temperature [K] - real(r8), allocatable :: wliq_soisno_ens (:,:,:) ! liquid water in layers [kg/m2] - real(r8), allocatable :: wice_soisno_ens (:,:,:) ! ice lens in layers [kg/m2] - real(r8), allocatable :: smp_ens (:,:,:) ! soil matrix potential [mm] - real(r8), allocatable :: hk_ens (:,:,:) ! hydraulic conductivity [mm h2o/s] - real(r8), allocatable :: t_grnd_ens (:,:) ! ground surface temperature [K] - real(r8), allocatable :: tleaf_ens (:,:) ! leaf temperature [K] - real(r8), allocatable :: ldew_ens (:,:) ! depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain_ens (:,:) ! depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_ens (:,:) ! depth of rain on foliage [mm] - real(r8), allocatable :: fwet_snow_ens (:,:) ! vegetation snow fractional cover [-] - real(r8), allocatable :: sag_ens (:,:) ! non dimensional snow age [-] - real(r8), allocatable :: scv_ens (:,:) ! snow cover, water equivalent [mm] - real(r8), allocatable :: snowdp_ens (:,:) ! snow depth [meter] - real(r8), allocatable :: fveg_ens (:,:) ! fraction of vegetation cover - real(r8), allocatable :: fsno_ens (:,:) ! fraction of snow cover on ground - real(r8), allocatable :: sigf_ens (:,:) ! fraction of veg cover, excluding snow-covered veg [-] - real(r8), allocatable :: green_ens (:,:) ! leaf greenness - real(r8), allocatable :: tlai_ens (:,:) ! leaf area index - real(r8), allocatable :: lai_ens (:,:) ! leaf area index - real(r8), allocatable :: tsai_ens (:,:) ! stem area index - real(r8), allocatable :: sai_ens (:,:) ! stem area index - real(r8), allocatable :: alb_ens (:,:,:,:) ! averaged albedo [-] - real(r8), allocatable :: ssun_ens (:,:,:,:) ! sunlit canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssha_ens (:,:,:,:) ! shaded canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssoi_ens (:,:,:,:) ! soil absorption for solar radiation (0-1) - real(r8), allocatable :: ssno_ens (:,:,:,:) ! snow absorption for solar radiation (0-1) - real(r8), allocatable :: thermk_ens (:,:) ! canopy gap fraction for tir radiation - real(r8), allocatable :: extkb_ens (:,:) ! (k, g(mu)/mu) direct solar extinction coefficient - real(r8), allocatable :: extkd_ens (:,:) ! diffuse and scattered diffuse PAR extinction coefficient - real(r8), allocatable :: zwt_ens (:,:) ! the depth to water table [m] - real(r8), allocatable :: wdsrf_ens (:,:) ! depth of surface water [mm] - real(r8), allocatable :: wa_ens (:,:) ! water storage in aquifer [mm] - real(r8), allocatable :: wetwat_ens (:,:) ! water storage in wetland [mm] - real(r8), allocatable :: t_lake_ens (:,:,:) ! lake layer teperature [K] - real(r8), allocatable :: lake_icefrac_ens(:,:,:) ! lake mass fraction of lake layer that is frozen - real(r8), allocatable :: savedtke1_ens (:,:) ! top level eddy conductivity (W/m K) - - ! diagnostic variables for DA - real(r8), allocatable :: h2osoi_ens (:,:,:) ! volumetric soil water in layers [m3/m3] - real(r8), allocatable :: t_brt_smap_ens (:,:,:) ! brightness temperature for radiance calculation [K] - real(r8), allocatable :: t_brt_fy3d_ens (:,:,:) ! brightness temperature for radiance calculation [K] - real(r8), allocatable :: t_brt_smap (:,:) ! brightness temperature for radiance calculation [K] - real(r8), allocatable :: t_brt_fy3d (:,:) ! brightness temperature for radiance calculation [K] - real(r8), allocatable :: trad_ens (:,:) ! radiative temperature of surface [K] - real(r8), allocatable :: tref_ens (:,:) ! 2 m height air temperature [kelvin] - real(r8), allocatable :: qref_ens (:,:) ! 2 m height air specific humidity - real(r8), allocatable :: rhref_ens (:,:) ! 2 m height air relative humidity - real(r8), allocatable :: ustar_ens (:,:) ! u* in similarity theory [m/s] - real(r8), allocatable :: qstar_ens (:,:) ! q* in similarity theory [kg/kg] - real(r8), allocatable :: tstar_ens (:,:) ! t* in similarity theory [K] - real(r8), allocatable :: fm_ens (:,:) ! integral of profile FUNCTION for momentum - real(r8), allocatable :: fh_ens (:,:) ! integral of profile FUNCTION for heat - real(r8), allocatable :: fq_ens (:,:) ! integral of profile FUNCTION for moisture - - ! ensemble forcing variables used for ensemble DA - real(r8), allocatable :: forc_t_ens (:,:) ! temperature [K] - real(r8), allocatable :: forc_frl_ens (:,:) ! atmospheric infrared (longwave) radiation [W/m2] - real(r8), allocatable :: forc_prc_ens (:,:) ! convective precipitation [mm/s] - real(r8), allocatable :: forc_prl_ens (:,:) ! large scale precipitation [mm/s] - real(r8), allocatable :: forc_sols_ens (:,:) ! atm vis direct beam solar rad onto srf [W/m2] - real(r8), allocatable :: forc_soll_ens (:,:) ! atm nir direct beam solar rad onto srf [W/m2] - real(r8), allocatable :: forc_solsd_ens (:,:) ! atm vis diffuse solar rad onto srf [W/m2] - real(r8), allocatable :: forc_solld_ens (:,:) ! atm nir diffuse solar rad onto srf [W/m2] - - ! save for analysis increment - real(r8), allocatable :: t_soisno_a (:,:) ! - real(r8), allocatable :: wliq_soisno_a (:,:) ! - real(r8), allocatable :: wice_soisno_a (:,:) ! - real(r8), allocatable :: t_grnd_a (:) ! - real(r8), allocatable :: tleaf_a (:) ! - real(r8), allocatable :: snowdp_a (:) ! - real(r8), allocatable :: h2osoi_a (:,:) ! - real(r8), allocatable :: t_brt_smap_a (:,:) ! - real(r8), allocatable :: t_brt_fy3d_a (:,:) ! - real(r8), allocatable :: trad_a (:) ! - real(r8), allocatable :: tref_a (:) ! - real(r8), allocatable :: qref_a (:) ! - real(r8), allocatable :: ustar_a (:) ! - real(r8), allocatable :: qstar_a (:) ! - real(r8), allocatable :: tstar_a (:) ! - real(r8), allocatable :: fm_a (:) ! - real(r8), allocatable :: fh_a (:) ! - real(r8), allocatable :: fq_a (:) ! - -!----------------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------------- - - SUBROUTINE allocate_DATimeVariables() - -!----------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_LandPatch, only: numpatch - IMPLICIT NONE - -!----------------------------------------------------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - allocate (z_sno_noda (maxsnl+1:0, numpatch)); z_sno_noda (:,:) = spval - allocate (dz_sno_noda (maxsnl+1:0, numpatch)); dz_sno_noda (:,:) = spval - allocate (t_soisno_noda (maxsnl+1:nl_soil,numpatch)); t_soisno_noda (:,:) = spval - allocate (wliq_soisno_noda(maxsnl+1:nl_soil,numpatch)); wliq_soisno_noda (:,:) = spval - allocate (wice_soisno_noda(maxsnl+1:nl_soil,numpatch)); wice_soisno_noda (:,:) = spval - allocate (smp_noda (1:nl_soil,numpatch)); smp_noda (:,:) = spval - allocate (hk_noda (1:nl_soil,numpatch)); hk_noda (:,:) = spval - allocate (t_grnd_noda (numpatch)); t_grnd_noda (:) = spval - allocate (tleaf_noda (numpatch)); tleaf_noda (:) = spval - allocate (ldew_noda (numpatch)); ldew_noda (:) = spval - allocate (ldew_rain_noda (numpatch)); ldew_rain_noda (:) = spval - allocate (ldew_snow_noda (numpatch)); ldew_snow_noda (:) = spval - allocate (fwet_snow_noda (numpatch)); fwet_snow_noda (:) = spval - allocate (sag_noda (numpatch)); sag_noda (:) = spval - allocate (scv_noda (numpatch)); scv_noda (:) = spval - allocate (snowdp_noda (numpatch)); snowdp_noda (:) = spval - allocate (fveg_noda (numpatch)); fveg_noda (:) = spval - allocate (fsno_noda (numpatch)); fsno_noda (:) = spval - allocate (sigf_noda (numpatch)); sigf_noda (:) = spval - allocate (green_noda (numpatch)); green_noda (:) = spval - allocate (tlai_noda (numpatch)); tlai_noda (:) = spval - allocate (lai_noda (numpatch)); lai_noda (:) = spval - allocate (tsai_noda (numpatch)); tsai_noda (:) = spval - allocate (sai_noda (numpatch)); sai_noda (:) = spval - allocate (alb_noda (2,2,numpatch)); alb_noda (:,:,:) = spval - allocate (ssun_noda (2,2,numpatch)); ssun_noda (:,:,:) = spval - allocate (ssha_noda (2,2,numpatch)); ssha_noda (:,:,:) = spval - allocate (ssoi_noda (2,2,numpatch)); ssoi_noda (:,:,:) = spval - allocate (ssno_noda (2,2,numpatch)); ssno_noda (:,:,:) = spval - allocate (thermk_noda (numpatch)); thermk_noda (:) = spval - allocate (extkb_noda (numpatch)); extkb_noda (:) = spval - allocate (extkd_noda (numpatch)); extkd_noda (:) = spval - allocate (zwt_noda (numpatch)); zwt_noda (:) = spval - allocate (wdsrf_noda (numpatch)); wdsrf_noda (:) = spval - allocate (wa_noda (numpatch)); wa_noda (:) = spval - allocate (wetwat_noda (numpatch)); wetwat_noda (:) = spval - allocate (t_lake_noda (nl_lake,numpatch)); t_lake_noda (:,:) = spval - allocate (lake_icefrac_noda (nl_lake,numpatch)); lake_icefrac_noda(:,:) = spval - allocate (savedtke1_noda (numpatch)); savedtke1_noda (:) = spval - - ! diagnostic variables for DA - allocate (h2osoi_noda (1:nl_soil,numpatch)); h2osoi_noda (:,:) = spval - allocate (tref_noda (numpatch)); tref_noda (:) = spval - - ! allocate all time-varying state variables - allocate (z_sno_ens (maxsnl+1:0, DEF_DA_ENS_NUM,numpatch)); z_sno_ens (:,:,:) = spval - allocate (dz_sno_ens (maxsnl+1:0, DEF_DA_ENS_NUM,numpatch)); dz_sno_ens (:,:,:) = spval - allocate (t_soisno_ens (maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); t_soisno_ens (:,:,:) = spval - allocate (wliq_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); wliq_soisno_ens (:,:,:) = spval - allocate (wice_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); wice_soisno_ens (:,:,:) = spval - allocate (smp_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); smp_ens (:,:,:) = spval - allocate (hk_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); hk_ens (:,:,:) = spval - allocate (t_grnd_ens (DEF_DA_ENS_NUM,numpatch)); t_grnd_ens (:,:) = spval - allocate (tleaf_ens (DEF_DA_ENS_NUM,numpatch)); tleaf_ens (:,:) = spval - allocate (ldew_ens (DEF_DA_ENS_NUM,numpatch)); ldew_ens (:,:) = spval - allocate (ldew_rain_ens (DEF_DA_ENS_NUM,numpatch)); ldew_rain_ens (:,:) = spval - allocate (ldew_snow_ens (DEF_DA_ENS_NUM,numpatch)); ldew_snow_ens (:,:) = spval - allocate (fwet_snow_ens (DEF_DA_ENS_NUM,numpatch)); fwet_snow_ens (:,:) = spval - allocate (sag_ens (DEF_DA_ENS_NUM,numpatch)); sag_ens (:,:) = spval - allocate (scv_ens (DEF_DA_ENS_NUM,numpatch)); scv_ens (:,:) = spval - allocate (snowdp_ens (DEF_DA_ENS_NUM,numpatch)); snowdp_ens (:,:) = spval - allocate (fveg_ens (DEF_DA_ENS_NUM,numpatch)); fveg_ens (:,:) = spval - allocate (fsno_ens (DEF_DA_ENS_NUM,numpatch)); fsno_ens (:,:) = spval - allocate (sigf_ens (DEF_DA_ENS_NUM,numpatch)); sigf_ens (:,:) = spval - allocate (green_ens (DEF_DA_ENS_NUM,numpatch)); green_ens (:,:) = spval - allocate (tlai_ens (DEF_DA_ENS_NUM,numpatch)); tlai_ens (:,:) = spval - allocate (lai_ens (DEF_DA_ENS_NUM,numpatch)); lai_ens (:,:) = spval - allocate (tsai_ens (DEF_DA_ENS_NUM,numpatch)); tsai_ens (:,:) = spval - allocate (sai_ens (DEF_DA_ENS_NUM,numpatch)); sai_ens (:,:) = spval - allocate (alb_ens (2,2,DEF_DA_ENS_NUM,numpatch)); alb_ens (:,:,:,:) = spval - allocate (ssun_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssun_ens (:,:,:,:) = spval - allocate (ssha_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssha_ens (:,:,:,:) = spval - allocate (ssoi_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssoi_ens (:,:,:,:) = spval - allocate (ssno_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssno_ens (:,:,:,:) = spval - allocate (thermk_ens (DEF_DA_ENS_NUM,numpatch)); thermk_ens (:,:) = spval - allocate (extkb_ens (DEF_DA_ENS_NUM,numpatch)); extkb_ens (:,:) = spval - allocate (extkd_ens (DEF_DA_ENS_NUM,numpatch)); extkd_ens (:,:) = spval - allocate (zwt_ens (DEF_DA_ENS_NUM,numpatch)); zwt_ens (:,:) = spval - allocate (wdsrf_ens (DEF_DA_ENS_NUM,numpatch)); wdsrf_ens (:,:) = spval - allocate (wa_ens (DEF_DA_ENS_NUM,numpatch)); wa_ens (:,:) = spval - allocate (wetwat_ens (DEF_DA_ENS_NUM,numpatch)); wetwat_ens (:,:) = spval - allocate (t_lake_ens (nl_lake,DEF_DA_ENS_NUM,numpatch)); t_lake_ens (:,:,:) = spval - allocate (lake_icefrac_ens (nl_lake,DEF_DA_ENS_NUM,numpatch)); lake_icefrac_ens(:,:,:) = spval - allocate (savedtke1_ens (DEF_DA_ENS_NUM,numpatch)); savedtke1_ens (:,:) = spval - - ! diagnostic variables for DA - allocate (h2osoi_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); h2osoi_ens (:,:,:) = spval - allocate (t_brt_smap_ens (2,DEF_DA_ENS_NUM,numpatch)); t_brt_smap_ens (:,:,:) = spval - allocate (t_brt_fy3d_ens (2,DEF_DA_ENS_NUM,numpatch)); t_brt_fy3d_ens (:,:,:) = spval - allocate (t_brt_smap (2,numpatch)); t_brt_smap (:,:) = spval - allocate (t_brt_fy3d (2,numpatch)); t_brt_fy3d (:,:) = spval - allocate (trad_ens (DEF_DA_ENS_NUM,numpatch)); trad_ens (:,:) = spval - allocate (tref_ens (DEF_DA_ENS_NUM,numpatch)); tref_ens (:,:) = spval - allocate (qref_ens (DEF_DA_ENS_NUM,numpatch)); qref_ens (:,:) = spval - allocate (rhref_ens (DEF_DA_ENS_NUM,numpatch)); rhref_ens (:,:) = spval - allocate (ustar_ens (DEF_DA_ENS_NUM,numpatch)); ustar_ens (:,:) = spval - allocate (qstar_ens (DEF_DA_ENS_NUM,numpatch)); qstar_ens (:,:) = spval - allocate (tstar_ens (DEF_DA_ENS_NUM,numpatch)); tstar_ens (:,:) = spval - allocate (fm_ens (DEF_DA_ENS_NUM,numpatch)); fm_ens (:,:) = spval - allocate (fh_ens (DEF_DA_ENS_NUM,numpatch)); fh_ens (:,:) = spval - allocate (fq_ens (DEF_DA_ENS_NUM,numpatch)); fq_ens (:,:) = spval - - ! ensemble forcing variables used for ensemble DA - allocate (forc_t_ens (DEF_DA_ENS_NUM,numpatch)); forc_t_ens (:,:) = spval - allocate (forc_frl_ens (DEF_DA_ENS_NUM,numpatch)); forc_frl_ens (:,:) = spval - allocate (forc_prc_ens (DEF_DA_ENS_NUM,numpatch)); forc_prc_ens (:,:) = spval - allocate (forc_prl_ens (DEF_DA_ENS_NUM,numpatch)); forc_prl_ens (:,:) = spval - allocate (forc_sols_ens (DEF_DA_ENS_NUM,numpatch)); forc_sols_ens (:,:) = spval - allocate (forc_soll_ens (DEF_DA_ENS_NUM,numpatch)); forc_soll_ens (:,:) = spval - allocate (forc_solsd_ens (DEF_DA_ENS_NUM,numpatch)); forc_solsd_ens (:,:) = spval - allocate (forc_solld_ens (DEF_DA_ENS_NUM,numpatch)); forc_solld_ens (:,:) = spval - - ! allocate variables for analysis increment - allocate (t_soisno_a (maxsnl+1:nl_soil,numpatch)); t_soisno_a (:,:) = spval - allocate (wliq_soisno_a (maxsnl+1:nl_soil,numpatch)); wliq_soisno_a (:,:) = spval - allocate (wice_soisno_a (maxsnl+1:nl_soil,numpatch)); wice_soisno_a (:,:) = spval - allocate (t_grnd_a (numpatch)); t_grnd_a (:) = spval - allocate (tleaf_a (numpatch)); tleaf_a (:) = spval - allocate (snowdp_a (numpatch)); snowdp_a (:) = spval - allocate (h2osoi_a (1:nl_soil,numpatch)); h2osoi_a (:,:) = spval - allocate (t_brt_smap_a (2,numpatch)); t_brt_smap_a (:,:) = spval - allocate (t_brt_fy3d_a (2,numpatch)); t_brt_fy3d_a (:,:) = spval - - allocate (trad_a (numpatch)); trad_a (:) = spval - allocate (tref_a (numpatch)); tref_a (:) = spval - allocate (qref_a (numpatch)); qref_a (:) = spval - allocate (ustar_a (numpatch)); ustar_a (:) = spval - allocate (qstar_a (numpatch)); qstar_a (:) = spval - allocate (tstar_a (numpatch)); tstar_a (:) = spval - allocate (fm_a (numpatch)); fm_a (:) = spval - allocate (fh_a (numpatch)); fh_a (:) = spval - allocate (fq_a (numpatch)); fq_a (:) = spval - ENDIF - ENDIF - - END SUBROUTINE allocate_DATimeVariables - -!----------------------------------------------------------------------------- - - SUBROUTINE deallocate_DATimeVariables() - -!----------------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPatch, only: numpatch - IMPLICIT NONE - -!----------------------------------------------------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - deallocate (z_sno_noda ) - deallocate (dz_sno_noda ) - deallocate (t_soisno_noda ) - deallocate (wliq_soisno_noda ) - deallocate (wice_soisno_noda ) - deallocate (smp_noda ) - deallocate (hk_noda ) - deallocate (t_grnd_noda ) - deallocate (tleaf_noda ) - deallocate (ldew_noda ) - deallocate (ldew_rain_noda ) - deallocate (ldew_snow_noda ) - deallocate (fwet_snow_noda ) - deallocate (sag_noda ) - deallocate (scv_noda ) - deallocate (snowdp_noda ) - deallocate (fveg_noda ) - deallocate (fsno_noda ) - deallocate (sigf_noda ) - deallocate (green_noda ) - deallocate (tlai_noda ) - deallocate (lai_noda ) - deallocate (tsai_noda ) - deallocate (sai_noda ) - deallocate (alb_noda ) - deallocate (ssun_noda ) - deallocate (ssha_noda ) - deallocate (ssoi_noda ) - deallocate (ssno_noda ) - deallocate (thermk_noda ) - deallocate (extkb_noda ) - deallocate (extkd_noda ) - deallocate (zwt_noda ) - deallocate (wdsrf_noda ) - deallocate (wa_noda ) - deallocate (wetwat_noda ) - deallocate (t_lake_noda ) - deallocate (lake_icefrac_noda ) - deallocate (savedtke1_noda ) - - deallocate (tref_noda ) - deallocate (h2osoi_noda ) - - deallocate (z_sno_ens ) - deallocate (dz_sno_ens ) - deallocate (t_soisno_ens ) - deallocate (wliq_soisno_ens ) - deallocate (wice_soisno_ens ) - deallocate (smp_ens ) - deallocate (hk_ens ) - deallocate (t_grnd_ens ) - deallocate (tleaf_ens ) - deallocate (ldew_ens ) - deallocate (ldew_rain_ens ) - deallocate (ldew_snow_ens ) - deallocate (fwet_snow_ens ) - deallocate (sag_ens ) - deallocate (scv_ens ) - deallocate (snowdp_ens ) - deallocate (fveg_ens ) - deallocate (fsno_ens ) - deallocate (sigf_ens ) - deallocate (green_ens ) - deallocate (tlai_ens ) - deallocate (lai_ens ) - deallocate (tsai_ens ) - deallocate (sai_ens ) - deallocate (alb_ens ) - deallocate (ssun_ens ) - deallocate (ssha_ens ) - deallocate (ssoi_ens ) - deallocate (ssno_ens ) - deallocate (thermk_ens ) - deallocate (extkb_ens ) - deallocate (extkd_ens ) - deallocate (zwt_ens ) - deallocate (wdsrf_ens ) - deallocate (wa_ens ) - deallocate (wetwat_ens ) - deallocate (t_lake_ens ) - deallocate (lake_icefrac_ens ) - deallocate (savedtke1_ens ) - - deallocate (h2osoi_ens ) - deallocate (t_brt_smap_ens ) - deallocate (t_brt_fy3d_ens ) - deallocate (t_brt_smap ) - deallocate (t_brt_fy3d ) - deallocate (trad_ens ) - deallocate (tref_ens ) - deallocate (qref_ens ) - deallocate (rhref_ens ) - deallocate (ustar_ens ) - deallocate (qstar_ens ) - deallocate (tstar_ens ) - deallocate (fm_ens ) - deallocate (fh_ens ) - deallocate (fq_ens ) - - deallocate (forc_t_ens ) - deallocate (forc_frl_ens ) - deallocate (forc_prc_ens ) - deallocate (forc_prl_ens ) - deallocate (forc_sols_ens ) - deallocate (forc_soll_ens ) - deallocate (forc_solsd_ens ) - deallocate (forc_solld_ens ) - - deallocate (t_soisno_a ) - deallocate (wliq_soisno_a ) - deallocate (wice_soisno_a ) - deallocate (t_grnd_a ) - deallocate (tleaf_a ) - deallocate (snowdp_a ) - deallocate (h2osoi_a ) - deallocate (t_brt_smap_a ) - deallocate (t_brt_fy3d_a ) - deallocate (trad_a ) - deallocate (tref_a ) - deallocate (qref_a ) - deallocate (ustar_a ) - deallocate (qstar_a ) - deallocate (tstar_a ) - deallocate (fm_a ) - deallocate (fh_a ) - deallocate (fq_a ) - ENDIF - ENDIF - - END SUBROUTINE deallocate_DATimeVariables - -!----------------------------------------------------------------------------- - - SUBROUTINE WRITE_DATimeVariables (idate, lc_year, site, dir_restart) - -!----------------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_Namelist, only : DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & - DEF_USE_IRRIGATION, DEF_USE_Dynamic_Lake - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_Vars_Global - IMPLICIT NONE - -!------------------------ Dummy Arguments ------------------------------------ - integer, intent(in) :: idate(3) - integer, intent(in) :: lc_year ! year of land cover type data - character(len=*), intent(in) :: site - character(len=*), intent(in) :: dir_restart - -!------------------------ Local Variables ------------------------------------ - character(len=256) :: file_restart - character(len=14) :: cdate - character(len=256) :: cyear ! character for lc_year - integer :: compress - integer :: i - -!----------------------------------------------------------------------------- - compress = DEF_REST_CompressLevel - - ! land cover type year - write(cyear,'(i4.4)') lc_year - write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - - IF (p_is_root) THEN - CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_DA_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - - CALL ncio_create_file_vector (file_restart, landpatch) - - CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') - CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'ens', DEF_DA_ENS_NUM) - - ! Time-varying state variables which reaquired by restart run - CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, z_sno_ens, compress) ! node depth [m] - CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, dz_sno_ens, compress) ! interface depth [m] - CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_soisno_ens, compress) ! soil temperature [K] - CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wliq_soisno_ens, compress) ! liquid water in layers [kg/m2] - CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wice_soisno_ens, compress) ! ice lens in layers [kg/m2] - CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, smp_ens, compress) ! soil matrix potential [mm] - CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, hk_ens, compress) ! hydraulic conductivity [mm h2o/s] - CALL ncio_write_vector (file_restart, 't_grnd', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_grnd_ens, compress) ! ground surface temperature [K] - CALL ncio_write_vector (file_restart, 'tleaf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tleaf_ens, compress) ! leaf temperature [K] - CALL ncio_write_vector (file_restart, 'ldew', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_ens, compress) ! depth of water on foliage [mm] - CALL ncio_write_vector (file_restart, 'ldew_rain', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_rain_ens, compress) ! depth of water on foliage [mm] - CALL ncio_write_vector (file_restart, 'ldew_snow', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_snow_ens, compress) ! depth of water on foliage [mm] - CALL ncio_write_vector (file_restart, 'fwet_snow', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fwet_snow_ens, compress) ! vegetation snow fractional cover [-] - CALL ncio_write_vector (file_restart, 'sag', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sag_ens, compress) ! non dimensional snow age [-] - CALL ncio_write_vector (file_restart, 'scv', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, scv_ens, compress) ! snow cover, water equivalent [mm] - CALL ncio_write_vector (file_restart, 'snowdp', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, snowdp_ens, compress) ! snow depth [meter] - CALL ncio_write_vector (file_restart, 'fveg', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fveg_ens, compress) ! fraction of vegetation cover - CALL ncio_write_vector (file_restart, 'fsno', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fsno_ens, compress) ! fraction of snow cover on ground - CALL ncio_write_vector (file_restart, 'sigf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sigf_ens, compress) ! fraction of veg cover, excluding snow-covered veg [-] - CALL ncio_write_vector (file_restart, 'green', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, green_ens, compress) ! leaf greenness - CALL ncio_write_vector (file_restart, 'tlai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tlai_ens, compress) ! leaf area index - CALL ncio_write_vector (file_restart, 'lai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, lai_ens, compress) ! leaf area index - CALL ncio_write_vector (file_restart, 'tsai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tsai_ens, compress) ! stem area index - CALL ncio_write_vector (file_restart, 'sai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sai_ens, compress) ! stem area index - CALL ncio_write_vector (file_restart, 'alb', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, alb_ens, compress) ! averaged albedo [-] - CALL ncio_write_vector (file_restart, 'ssun', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssun_ens, compress) ! sunlit canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'ssha', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssha_ens, compress) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'ssoi', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssoi_ens, compress) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'ssno', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssno_ens, compress) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'thermk', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, thermk_ens, compress) ! canopy gap fraction for tir radiation - CALL ncio_write_vector (file_restart, 'extkb', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, extkb_ens, compress) ! (k, g(mu)/mu) direct solar extinction coefficient - CALL ncio_write_vector (file_restart, 'extkd', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, extkd_ens, compress) ! diffuse and scattered diffuse PAR extinction coefficient - CALL ncio_write_vector (file_restart, 'zwt', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, zwt_ens, compress) ! the depth to water table [m] - CALL ncio_write_vector (file_restart, 'wdsrf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wdsrf_ens, compress) ! depth of surface water [mm] - CALL ncio_write_vector (file_restart, 'wa', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wa_ens, compress) ! water storage in aquifer [mm] - CALL ncio_write_vector (file_restart, 'wetwat', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wetwat_ens, compress) ! water storage in wetland [mm] - CALL ncio_write_vector (file_restart, 't_lake', 'lake', nl_lake, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_lake_ens, compress) - CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, lake_icefrac_ens, compress) - CALL ncio_write_vector (file_restart, 'savedtke1', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, savedtke1_ens, compress) - - END SUBROUTINE WRITE_DATimeVariables - -!----------------------------------------------------------------------------- - - SUBROUTINE READ_DATimeVariables (idate, lc_year, site, dir_restart) - -!----------------------------------------------------------------------------- - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_NetCDFVector -#ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_LandPatch - USE MOD_Vars_Global - IMPLICIT NONE - -!------------------------ Dummy Arguments ------------------------------------ - integer, intent(in) :: idate(3) - integer, intent(in) :: lc_year !year of land cover type data - character(len=*), intent(in) :: site - character(len=*), intent(in) :: dir_restart - -!------------------------ Local Variables ------------------------------------ - character(len=256) :: file_restart - character(len=14) :: cdate, cyear - -!----------------------------------------------------------------------------- -#ifdef USEMPI - CALL mpi_barrier(p_comm_glb, p_err) -#endif - - IF (p_is_root) THEN - write (*, *) 'Loading DA Time Variables ...' - END IF - - ! land cover type year - write (cyear, '(i4.4)') lc_year - - write (cdate, '(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - file_restart = trim(dir_restart)//'/'//trim(cdate)//'/'//trim(site)//'_restart_DA_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - - ! Time-varying state variables which reaquired by restart run - CALL ncio_read_vector(file_restart, 'z_sno ', -maxsnl, DEF_DA_ENS_NUM, landpatch, z_sno_ens) ! node depth [m] - CALL ncio_read_vector(file_restart, 'dz_sno ', -maxsnl, DEF_DA_ENS_NUM, landpatch, dz_sno_ens) ! interface depth [m] - CALL ncio_read_vector(file_restart, 't_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, t_soisno_ens) ! soil temperature [K] - CALL ncio_read_vector(file_restart, 'wliq_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, wliq_soisno_ens)! liquid water in layers [kg/m2] - CALL ncio_read_vector(file_restart, 'wice_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, wice_soisno_ens)! ice lens in layers [kg/m2] - CALL ncio_read_vector(file_restart, 'smp', nl_soil, DEF_DA_ENS_NUM, landpatch, smp_ens) ! soil matrix potential [mm] - CALL ncio_read_vector(file_restart, 'hk', nl_soil, DEF_DA_ENS_NUM, landpatch, hk_ens) ! hydraulic conductivity [mm h2o/s] - CALL ncio_read_vector(file_restart, 't_grnd ', DEF_DA_ENS_NUM, landpatch, t_grnd_ens) ! ground surface temperature [K] - CALL ncio_read_vector(file_restart, 'tleaf ', DEF_DA_ENS_NUM, landpatch, tleaf_ens) ! leaf temperature [K] - CALL ncio_read_vector(file_restart, 'ldew ', DEF_DA_ENS_NUM, landpatch, ldew_ens) ! depth of water on foliage [mm] - CALL ncio_read_vector(file_restart, 'ldew_rain', DEF_DA_ENS_NUM, landpatch, ldew_rain_ens) ! depth of water on foliage [mm] - CALL ncio_read_vector(file_restart, 'ldew_snow', DEF_DA_ENS_NUM, landpatch, ldew_snow_ens) ! depth of water on foliage [mm] - CALL ncio_read_vector(file_restart, 'fwet_snow', DEF_DA_ENS_NUM, landpatch, fwet_snow_ens) ! vegetation snow fractional cover [-] - CALL ncio_read_vector(file_restart, 'sag ', DEF_DA_ENS_NUM, landpatch, sag_ens) ! non dimensional snow age [-] - CALL ncio_read_vector(file_restart, 'scv ', DEF_DA_ENS_NUM, landpatch, scv_ens) ! snow cover, water equivalent [mm] - CALL ncio_read_vector(file_restart, 'snowdp ', DEF_DA_ENS_NUM, landpatch, snowdp_ens) ! snow depth [meter] - CALL ncio_read_vector(file_restart, 'fveg ', DEF_DA_ENS_NUM, landpatch, fveg_ens) ! fraction of vegetation cover - CALL ncio_read_vector(file_restart, 'fsno ', DEF_DA_ENS_NUM, landpatch, fsno_ens) ! fraction of snow cover on ground - CALL ncio_read_vector(file_restart, 'sigf ', DEF_DA_ENS_NUM, landpatch, sigf_ens) ! fraction of veg cover, excluding snow-covered veg [-] - CALL ncio_read_vector(file_restart, 'green ', DEF_DA_ENS_NUM, landpatch, green_ens) ! leaf greenness - CALL ncio_read_vector(file_restart, 'lai ', DEF_DA_ENS_NUM, landpatch, lai_ens) ! leaf area index - CALL ncio_read_vector(file_restart, 'tlai ', DEF_DA_ENS_NUM, landpatch, tlai_ens) ! leaf area index - CALL ncio_read_vector(file_restart, 'sai ', DEF_DA_ENS_NUM, landpatch, sai_ens) ! stem area index - CALL ncio_read_vector(file_restart, 'tsai ', DEF_DA_ENS_NUM, landpatch, tsai_ens) ! stem area index - CALL ncio_read_vector(file_restart, 'alb ', 2, 2, DEF_DA_ENS_NUM, landpatch, alb_ens) ! averaged albedo [-] - CALL ncio_read_vector(file_restart, 'ssun ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssun_ens) ! sunlit canopy absorption for solar radiation (0-1) - CALL ncio_read_vector(file_restart, 'ssha ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssha_ens) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_read_vector(file_restart, 'ssoi ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssoi_ens) ! soil absorption for solar radiation (0-1) - CALL ncio_read_vector(file_restart, 'ssno ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssno_ens) ! snow absorption for solar radiation (0-1) - CALL ncio_read_vector(file_restart, 'thermk ', DEF_DA_ENS_NUM, landpatch, thermk_ens) ! canopy gap fraction for tir radiation - CALL ncio_read_vector(file_restart, 'extkb ', DEF_DA_ENS_NUM, landpatch, extkb_ens) ! (k, g(mu)/mu) direct solar extinction coefficient - CALL ncio_read_vector(file_restart, 'extkd ', DEF_DA_ENS_NUM, landpatch, extkd_ens) ! diffuse and scattered diffuse PAR extinction coefficient - CALL ncio_read_vector(file_restart, 'zwt ', DEF_DA_ENS_NUM, landpatch, zwt_ens) ! the depth to water table [m] - CALL ncio_read_vector(file_restart, 'wdsrf ', DEF_DA_ENS_NUM, landpatch, wdsrf_ens) ! depth of surface water [mm] - CALL ncio_read_vector(file_restart, 'wa ', DEF_DA_ENS_NUM, landpatch, wa_ens) ! water storage in aquifer [mm] - CALL ncio_read_vector(file_restart, 'wetwat ', DEF_DA_ENS_NUM, landpatch, wetwat_ens) ! water storage in wetland [mm] - CALL ncio_read_vector(file_restart, 't_lake ', nl_lake, DEF_DA_ENS_NUM, landpatch, t_lake_ens) ! lake temperature [K] - CALL ncio_read_vector(file_restart, 'lake_icefrc', nl_lake, DEF_DA_ENS_NUM, landpatch, lake_icefrac_ens) ! lake ice fraction [-] - CALL ncio_read_vector(file_restart, 'savedtke1 ', DEF_DA_ENS_NUM, landpatch, savedtke1_ens) ! saved tke1 [m2/s2] - -#ifdef RangeCheck - CALL check_DATimeVariables -#endif - - IF (p_is_root) THEN - write (*, *) 'Loading DA Time Variables done.' - END IF - - END SUBROUTINE READ_DATimeVariables - -#ifdef RangeCheck -!----------------------------------------------------------------------- - - SUBROUTINE check_DATimeVariables () - -!----------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_RangeCheck - USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & - DEF_USE_SNICAR, DEF_USE_Dynamic_Lake - IMPLICIT NONE - -#ifdef USEMPI - CALL mpi_barrier(p_comm_glb, p_err) -#endif - IF (p_is_root) THEN - write (*, *) 'Checking DA Time Variables ...' - END IF - - CALL check_vector_data ('z_sno [m] ', z_sno_ens ) ! node depth [m] - CALL check_vector_data ('dz_sno [m] ', dz_sno_ens ) ! interface depth [m] - CALL check_vector_data ('t_soisno [K] ', t_soisno_ens ) ! soil temperature [K] - CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno_ens ) ! liquid water in layers [kg/m2] - CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno_ens ) ! ice lens in layers [kg/m2] - CALL check_vector_data ('smp [mm] ', smp_ens ) ! soil matrix potential [mm] - CALL check_vector_data ('hk [mm/s] ', hk_ens ) ! hydraulic conductivity [mm h2o/s] - CALL check_vector_data ('t_grnd [K] ', t_grnd_ens ) ! ground surface temperature [K] - CALL check_vector_data ('tleaf [K] ', tleaf_ens ) ! leaf temperature [K] - CALL check_vector_data ('ldew [mm] ', ldew_ens ) ! depth of water on foliage [mm] - CALL check_vector_data ('ldew_rain [mm] ', ldew_rain_ens ) ! depth of rain on foliage [mm] - CALL check_vector_data ('ldew_snow [mm] ', ldew_snow_ens ) ! depth of snow on foliage [mm] - CALL check_vector_data ('fwet_snow [mm] ', fwet_snow_ens ) ! vegetation snow fractional cover [-] - CALL check_vector_data ('sag [-] ', sag_ens ) ! non dimensional snow age [-] - CALL check_vector_data ('scv [mm] ', scv_ens ) ! snow cover, water equivalent [mm] - CALL check_vector_data ('snowdp [m] ', snowdp_ens ) ! snow depth [meter] - CALL check_vector_data ('fveg [-] ', fveg_ens ) ! fraction of vegetation cover - CALL check_vector_data ('fsno [-] ', fsno_ens ) ! fraction of snow cover on ground - CALL check_vector_data ('sigf [-] ', sigf_ens ) ! fraction of veg cover, excluding snow-covered veg [-] - CALL check_vector_data ('green [-] ', green_ens ) ! leaf greenness - CALL check_vector_data ('lai [-] ', lai_ens ) ! leaf area index - CALL check_vector_data ('tlai [-] ', tlai_ens ) ! leaf area index - CALL check_vector_data ('sai [-] ', sai_ens ) ! stem area index - CALL check_vector_data ('tsai [-] ', tsai_ens ) ! stem area index - CALL check_vector_data ('alb [-] ', alb_ens ) ! averaged albedo [-] - CALL check_vector_data ('ssun [-] ', ssun_ens ) ! sunlit canopy absorption for solar radiation (0-1) - CALL check_vector_data ('ssha [-] ', ssha_ens ) ! shaded canopy absorption for solar radiation (0-1) - CALL check_vector_data ('ssoi [-] ', ssoi_ens ) ! soil absorption for solar radiation (0-1) - CALL check_vector_data ('ssno [-] ', ssno_ens ) ! snow absorption for solar radiation (0-1) - CALL check_vector_data ('thermk [-] ', thermk_ens ) ! canopy gap fraction for tir radiation - CALL check_vector_data ('extkb [-] ', extkb_ens ) ! (k, g(mu)/mu) direct solar extinction coefficient - CALL check_vector_data ('extkd [-] ', extkd_ens ) ! diffuse and scattered diffuse PAR extinction coefficient - CALL check_vector_data ('zwt [m] ', zwt_ens ) ! the depth to water table [m] - CALL check_vector_data ('wdsrf [mm] ', wdsrf_ens ) ! depth of surface water [mm] - CALL check_vector_data ('wa [mm] ', wa_ens ) ! water storage in aquifer [mm] - CALL check_vector_data ('wetwat [mm] ', wetwat_ens ) ! water storage in wetland [mm] - CALL check_vector_data ('t_lake [K] ', t_lake_ens ) ! lake temperature [K] - CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac_ens) ! lake ice fraction [-] - CALL check_vector_data ('savedtke1 [W/m K]', savedtke1_ens ) ! saved tke1 [m2/s2] - -#ifdef USEMPI - CALL mpi_barrier(p_comm_glb, p_err) -#endif - - END SUBROUTINE check_DATimeVariables -!----------------------------------------------------------------------------- -#endif - -END MODULE MOD_DA_Vars_TimeVariables -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 deleted file mode 100644 index 5a864c2a8b..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 +++ /dev/null @@ -1,494 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_BasinNetwork -!-------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Created by Shupeng Zhang, Feb 2025 -!-------------------------------------------------------------------------------- - - USE MOD_Pixelset - USE MOD_ComputePushData - IMPLICIT NONE - - ! -- instances -- - integer :: numbasin - integer, allocatable :: basinindex(:) - - integer :: numbsnhru - type(subset_type) :: basin_hru - - integer :: numrivmth - integer, allocatable :: rivermouth(:) - - integer :: numlake, numresv - integer, allocatable :: lake_id (:) - integer, allocatable :: lake_type(:) ! lake type: - ! 0: not lake; 1: natural lake; - ! 2: reservoir; 3: controlled lake. - integer, allocatable :: bsn2lake (:) - integer, allocatable :: bsn2resv (:) - - type(compute_pushdata_type) :: push_elm2bsn - type(compute_pushdata_type) :: push_bsn2elm - - type(compute_pushdata_type) :: push_elmhru2bsnhru - type(compute_pushdata_type) :: push_bsnhru2elmhru - -CONTAINS - - ! ---------- - SUBROUTINE build_basin_network () - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Utils - USE MOD_NetCDFSerial - USE MOD_Mesh, only: numelm - USE MOD_LandElm, only: landelm - USE MOD_LandHRU, only: elm_hru - IMPLICIT NONE - - ! Local Variables - character(len=256) :: basin_file - integer, allocatable :: basindown(:) - - integer, allocatable :: nups_nst(:), iups_nst(:), nups_all(:), b_up2down(:), orderbsn(:) - - integer , allocatable :: nb_rs(:), irank_rs(:), nrank_rs(:), nave_rs(:), nb_rank(:) - real(r8), allocatable :: wtbsn(:), wt_rs (:), wt_rank (:) - - integer :: totalnumbasin, ibasin, nbasin, iriv - integer :: irank, irankdsp, mesg(2), isrc, nrecv - integer :: iloc, i, j, ithis - real(r8) :: sumwt - - integer, allocatable :: bindex(:), addrbasin(:), elmindex(:) - - ! lake and reservoir - character(len=256) :: lake_info_file - integer, allocatable :: all_lake_id (:), all_lake_type (:), order(:), icache(:) - integer, allocatable :: lake_id_resv(:), lake_type_resv(:) - integer :: ilake, iresv - - - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - basin_file = DEF_CatchmentMesh_data - - ! read in parameters from file. - IF (p_is_root) THEN - CALL ncio_read_serial (basin_file, 'basin_downstream', basindown) - totalnumbasin = size(basindown) - ENDIF - -#ifdef USEMPI - ! divide basins into groups and assign to ranks - IF (p_is_root) THEN - - IF (ncio_var_exist(basin_file, 'weightbasin')) THEN - CALL ncio_read_serial (basin_file, 'weightbasin', wtbsn) - ELSE - allocate (wtbsn (totalnumbasin)); wtbsn(:) = 1. - ENDIF - - ! sort basins from up to down, recorded by "b_up2down" - - allocate (nups_nst (totalnumbasin)); nups_nst(:) = 0 - allocate (iups_nst (totalnumbasin)); iups_nst(:) = 0 - allocate (b_up2down(totalnumbasin)) - - DO i = 1, totalnumbasin - j = basindown(i) - IF (j > 0) THEN - nups_nst(j) = nups_nst(j) + 1 - ENDIF - ENDDO - - ithis = 0 - DO i = 1, totalnumbasin - IF (iups_nst(i) == nups_nst(i)) THEN - - ithis = ithis + 1 - b_up2down(ithis) = i - iups_nst(i) = -1 - - j = basindown(i) - DO WHILE (j > 0) - - iups_nst(j) = iups_nst(j) + 1 - - IF (iups_nst(j) == nups_nst(j)) THEN - ithis = ithis + 1 - b_up2down(ithis) = j - iups_nst(j) = -1 - - j = basindown(j) - ELSE - EXIT - ENDIF - ENDDO - ENDIF - ENDDO - - deallocate (nups_nst) - deallocate (iups_nst) - - allocate (rivermouth (totalnumbasin)) - numrivmth = 0 - DO i = totalnumbasin, 1, -1 - j = basindown(b_up2down(i)) - IF (j <= 0) THEN - numrivmth = numrivmth + 1 - rivermouth(b_up2down(i)) = numrivmth - ELSE - rivermouth(b_up2down(i)) = rivermouth(j) - ENDIF - ENDDO - - allocate (nb_rs (numrivmth)); nb_rs(:) = 0 - allocate (wt_rs (numrivmth)); wt_rs(:) = 0 - DO i = 1, totalnumbasin - nb_rs(rivermouth(i)) = nb_rs(rivermouth(i)) + 1 - wt_rs(rivermouth(i)) = wt_rs(rivermouth(i)) + wtbsn(i) - ENDDO - - sumwt = sum(wt_rs) - - allocate (irank_rs (numrivmth)) - allocate (nrank_rs (numrivmth)) - allocate (nave_rs (numrivmth)) - - irankdsp = -1 - DO i = 1, numrivmth - nrank_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) - IF (nrank_rs(i) > 1) THEN - - nave_rs(i) = nb_rs(i) / nrank_rs(i) - IF (mod(nb_rs(i), nrank_rs(i)) /= 0) THEN - nave_rs(i) = nave_rs(i) + 1 - ENDIF - - irank_rs(i) = irankdsp + 1 - irankdsp = irankdsp + nrank_rs(i) - ENDIF - ENDDO - - allocate (nups_all (totalnumbasin)); nups_all(:) = 1 - - DO i = 1, totalnumbasin - j = basindown(b_up2down(i)) - IF (j > 0) THEN - nups_all(j) = nups_all(j) + nups_all(b_up2down(i)) - ENDIF - ENDDO - - allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 - - allocate (wt_rank (0:p_np_compute-1)); wt_rank(:) = 0 - allocate (nb_rank (0:p_np_compute-1)); nb_rank(:) = 0 - - allocate (orderbsn(totalnumbasin)) - orderbsn(b_up2down) = (/(i, i = 1, totalnumbasin)/) - - ithis = totalnumbasin - DO WHILE (ithis > 0) - - i = b_up2down(ithis) - - IF (addrbasin(i) >= 0) THEN - ithis = ithis - 1 - CYCLE - ENDIF - - j = basindown(i) - IF (j > 0) THEN - IF (addrbasin(j) >= 0) THEN - addrbasin(i) = addrbasin(j) - ithis = ithis - 1 - CYCLE - ENDIF - ENDIF - - iriv = rivermouth(i) - IF (nrank_rs(iriv) > 1) THEN - irank = irank_rs(iriv) - IF (nups_all(i) <= nave_rs(iriv)-nb_rank(irank)) THEN - - addrbasin(i) = p_address_compute(irank) - - nb_rank(irank) = nb_rank(irank) + nups_all(i) - IF (nb_rank(irank) == nave_rs(iriv)) THEN - irank_rs(iriv) = irank_rs(iriv) + 1 - ENDIF - - j = basindown(i) - IF (j > 0) THEN - DO WHILE (j > 0) - nups_all(j) = nups_all(j) - nups_all(i) - ithis = orderbsn(j) - j = basindown(j) - ENDDO - ELSE - ithis = ithis - 1 - ENDIF - ELSE - ithis = ithis - 1 - ENDIF - ELSE - irank = minloc(wt_rank(irankdsp+1:p_np_compute-1), dim=1) + irankdsp - - addrbasin(i) = p_address_compute(irank) - - wt_rank(irank) = wt_rank(irank) + wt_rs(iriv) - ithis = ithis - 1 - ENDIF - - ENDDO - - deallocate (basindown) - deallocate (wtbsn ) - deallocate (b_up2down) - deallocate (nups_all ) - deallocate (orderbsn ) - deallocate (nb_rs ) - deallocate (wt_rs ) - deallocate (irank_rs ) - deallocate (nrank_rs ) - deallocate (nave_rs ) - deallocate (wt_rank ) - deallocate (nb_rank ) - - ENDIF - - - ! send basin index to ranks - IF (p_is_root) THEN - - allocate(basinindex (totalnumbasin)) - basinindex = (/(i, i = 1, totalnumbasin)/) - - DO irank = 0, p_np_compute-1 - - nbasin = count(addrbasin == p_address_compute(irank)) - CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_err) - - IF (nbasin > 0) THEN - allocate (bindex (nbasin)) - - bindex = pack(basinindex, mask = (addrbasin == p_address_compute(irank))) - CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - - deallocate (bindex) - ENDIF - - ENDDO - - deallocate (basinindex) - - ELSEIF (p_is_compute) THEN - - CALL mpi_recv (numbasin, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - IF (numbasin > 0) THEN - - allocate (basinindex (numbasin)) - CALL mpi_recv (basinindex, numbasin, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - numbasin = totalnumbasin - allocate(basinindex (totalnumbasin)) - basinindex = (/(i, i = 1, totalnumbasin)/) -#endif - - - IF (p_is_compute) THEN - IF (numelm > 0) THEN - allocate (elmindex (numelm)) - elmindex = landelm%eindex - ENDIF - ENDIF - - CALL build_compute_pushdata (numelm, elmindex, numbasin, basinindex, push_elm2bsn) - CALL build_compute_pushdata (numbasin, basinindex, numelm, elmindex, push_bsn2elm) - - CALL build_compute_pushdata_subset ( & - numelm, numbasin, push_elm2bsn, elm_hru, push_elmhru2bsnhru, basin_hru, numbsnhru) - - CALL build_compute_pushdata_subset ( & - numbasin, numelm, push_bsn2elm, basin_hru, push_bsnhru2elmhru) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (allocated(addrbasin)) deallocate(addrbasin) - IF (allocated(elmindex )) deallocate(elmindex ) - - - IF (p_is_root) THEN - - lake_info_file = DEF_CatchmentMesh_data - CALL ncio_read_serial (lake_info_file, 'lake_id', all_lake_id) - - lake_info_file = trim(DEF_dir_runtime)//'/HydroLAKES_Reservoir.nc' - CALL ncio_read_serial (lake_info_file, 'hylak_id', lake_id_resv ) - CALL ncio_read_serial (lake_info_file, 'lake_type', lake_type_resv) - - allocate (order (size(lake_id_resv))) - order = (/(iresv, iresv=1,size(lake_id_resv))/) - - CALL quicksort (size(lake_id_resv), lake_id_resv, order) - - lake_type_resv = lake_type_resv(order) - - allocate (all_lake_type (size(all_lake_id))) - all_lake_type(:) = 0 - - DO ibasin = 1, size(all_lake_id) - IF (all_lake_id(ibasin) > 0) THEN - all_lake_type(ibasin) = 1 - iresv = find_in_sorted_list1 (all_lake_id(ibasin), size(lake_id_resv), lake_id_resv) - IF (iresv > 0) THEN - all_lake_type(ibasin) = lake_type_resv(iresv) - ENDIF - ENDIF - ENDDO - - deallocate (lake_id_resv ) - deallocate (lake_type_resv) - deallocate (order) - - ENDIF - - IF (p_is_compute) THEN - IF (numbasin > 0) THEN - allocate (lake_id (numbasin)); lake_id (:) = 0 - allocate (lake_type (numbasin)); lake_type(:) = 0 - ENDIF - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) - - IF (p_is_compute) THEN - mesg = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) - - IF (numbasin > 0) THEN - CALL mpi_send (basinindex, numbasin, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - - CALL mpi_recv (lake_id, numbasin, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - CALL mpi_recv (lake_type, numbasin, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF - - IF (p_is_root) THEN - DO irank = 0, p_np_compute-1 - - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - nbasin = mesg(2) - IF (nbasin > 0) THEN - - allocate(bindex (nbasin)) - CALL mpi_recv (bindex, nbasin, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate(icache (nbasin)) - - icache = all_lake_id (bindex) - CALL mpi_send (icache, nbasin, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_err) - - icache = all_lake_type(bindex) - CALL mpi_send (icache, nbasin, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_err) - - deallocate (bindex) - deallocate (icache) - ENDIF - - ENDDO - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - lake_id = all_lake_id (basinindex) - lake_type = all_lake_type(basinindex) -#endif - - IF (p_is_compute) THEN - IF (numbasin > 0) THEN - numlake = count(lake_type /= 0) - numresv = count(lake_type >= 2) - ELSE - numlake = 0 - numresv = 0 - ENDIF - - IF (numlake > 0) THEN - allocate (bsn2lake (numbasin)) - ilake = 0 - DO ibasin = 1, numbasin - IF (lake_type(ibasin) /= 0) THEN - ilake = ilake + 1 - bsn2lake(ibasin) = ilake - ENDIF - ENDDO - ENDIF - - IF (numresv > 0) THEN - allocate (bsn2resv (numbasin)) - iresv = 0 - DO ibasin = 1, numbasin - IF (lake_type(ibasin) >= 2) THEN - iresv = iresv + 1 - bsn2resv(ibasin) = iresv - ENDIF - ENDDO - ENDIF - ENDIF - - IF (allocated(all_lake_id )) deallocate(all_lake_id ) - IF (allocated(all_lake_type)) deallocate(all_lake_type) - - - END SUBROUTINE build_basin_network - - ! --------- - SUBROUTINE basin_network_final () - - IMPLICIT NONE - - IF (allocated(basinindex)) deallocate(basinindex) - IF (allocated(rivermouth)) deallocate(rivermouth) - - IF (allocated(lake_id )) deallocate(lake_id ) - IF (allocated(lake_type )) deallocate(lake_type ) - - IF (allocated(bsn2lake )) deallocate(bsn2lake ) - IF (allocated(bsn2resv )) deallocate(bsn2resv ) - - END SUBROUTINE basin_network_final - -END MODULE MOD_Catch_BasinNetwork -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 deleted file mode 100644 index fdcff24d4c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 +++ /dev/null @@ -1,310 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_HillslopeFlow -!------------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Shallow water equation solver over hillslopes. -! -! References -! [1] Toro EF. Shock-capturing methods for free-surface shallow flows. -! Chichester: John Wiley & Sons; 2001. -! [2] Liang, Q., Borthwick, A. G. L. (2009). Adaptive quadtree simulation of shallow -! flows with wet-dry fronts over complex topography. -! Computers and Fluids, 38(2), 221-234. -! [3] Audusse, E., Bouchut, F., Bristeau, M.-O., Klein, R., Perthame, B. (2004). -! A Fast and Stable Well-Balanced Scheme with Hydrostatic Reconstruction for -! Shallow Water Flows. SIAM Journal on Scientific Computing, 25(6), 2050-2065. -! -! Created by Shupeng Zhang, May 2023 -!------------------------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - ! -- Parameters -- - real(r8), parameter :: PONDMIN = 1.e-4 - real(r8), parameter :: nmanning_hslp = 0.3 - -CONTAINS - - ! ---------- - SUBROUTINE hillslope_flow (dt) - - USE MOD_SPMD_Task - USE MOD_Catch_BasinNetwork - USE MOD_Catch_HillslopeNetwork - USE MOD_Catch_RiverLakeNetwork - USE MOD_Catch_Vars_TimeVariables - USE MOD_Catch_Vars_1DFluxes - USE MOD_Const_Physical, only: grav - - IMPLICIT NONE - - real(r8), intent(in) :: dt - - ! Local Variables - integer :: nhru, hs, he, ibasin, i, j - - type(hillslope_network_type), pointer :: hillslope - - real(r8), allocatable :: wdsrf_h (:) ! [m] - real(r8), allocatable :: momen_h (:) ! [m^2/s] - real(r8), allocatable :: veloc_h (:) ! [m/s] - - real(r8), allocatable :: sum_hflux_h (:) - real(r8), allocatable :: sum_mflux_h (:) - real(r8), allocatable :: sum_zgrad_h (:) - - real(r8) :: hand_fc, wdsrf_fc, veloc_fc, hflux_fc, mflux_fc - real(r8) :: wdsrf_up, wdsrf_dn, vwave_up, vwave_dn - real(r8) :: hflux_up, hflux_dn, mflux_up, mflux_dn - - real(r8), allocatable :: xsurf_h (:) ! [m/s] - - real(r8) :: friction - real(r8) :: dt_res, dt_this - - logical, allocatable :: mask(:) - real(r8) :: srfbsn, dvol, nextl, nexta, nextv, ddep - - IF (p_is_compute) THEN - - DO ibasin = 1, numbasin - - hs = basin_hru%substt(ibasin) - he = basin_hru%subend(ibasin) - - IF (lake_id(ibasin) > 0) THEN - veloc_bsnhru(hs:he) = 0 - momen_bsnhru(hs:he) = 0 - CYCLE ! skip lakes - ELSE - DO i = hs, he - ! momentum is less or equal than the momentum at last time step. - momen_bsnhru(i) = min(wdsrf_bsnhru_prev(i), wdsrf_bsnhru(i)) * veloc_bsnhru(i) - ENDDO - ENDIF - - hillslope => hillslope_basin(ibasin) - - nhru = hillslope%nhru - - allocate (wdsrf_h (nhru)) - allocate (veloc_h (nhru)) - allocate (momen_h (nhru)) - - allocate (sum_hflux_h (nhru)) - allocate (sum_mflux_h (nhru)) - allocate (sum_zgrad_h (nhru)) - - allocate (xsurf_h (nhru)) - - DO i = 1, nhru - wdsrf_h(i) = wdsrf_bsnhru(hillslope%ihru(i)) - momen_h(i) = momen_bsnhru(hillslope%ihru(i)) - IF (wdsrf_h(i) > 0.) THEN - veloc_h(i) = momen_h(i) / wdsrf_h(i) - ELSE - veloc_h(i) = 0. - ENDIF - ENDDO - - dt_res = dt - DO WHILE (dt_res > 0.) - - DO i = 1, nhru - sum_hflux_h(i) = 0. - sum_mflux_h(i) = 0. - sum_zgrad_h(i) = 0. - ENDDO - - dt_this = dt_res - - DO i = 1, nhru - - j = hillslope%inext(i) - - IF (j <= 0) CYCLE ! lowest HRUs - - ! dry HRU - IF ((wdsrf_h(i) < PONDMIN) .and. (wdsrf_h(j) < PONDMIN)) THEN - CYCLE - ENDIF - - ! reconstruction of height of water near interface - hand_fc = max(hillslope%hand(i), hillslope%hand(j)) - wdsrf_up = max(0., hillslope%hand(i)+wdsrf_h(i) - hand_fc) - wdsrf_dn = max(0., hillslope%hand(j)+wdsrf_h(j) - hand_fc) - - ! velocity at hydrounit downstream face - veloc_fc = 0.5 * (veloc_h(i) + veloc_h(j)) & - + sqrt(grav * wdsrf_up) - sqrt(grav * wdsrf_dn) - - ! depth of water at downstream face - wdsrf_fc = 1/grav * (0.5*(sqrt(grav*wdsrf_up) + sqrt(grav*wdsrf_dn)) & - + 0.25 * (veloc_h(i) - veloc_h(j)))**2.0 - - IF (wdsrf_up > 0) THEN - vwave_up = min(veloc_h(i)-sqrt(grav*wdsrf_up), veloc_fc-sqrt(grav*wdsrf_fc)) - ELSE - vwave_up = veloc_h(j) - 2.0 * sqrt(grav*wdsrf_dn) - ENDIF - - IF (wdsrf_dn > 0) THEN - vwave_dn = max(veloc_h(j)+sqrt(grav*wdsrf_dn), veloc_fc+sqrt(grav*wdsrf_fc)) - ELSE - vwave_dn = veloc_h(i) + 2.0 * sqrt(grav*wdsrf_up) - ENDIF - - hflux_up = veloc_h(i) * wdsrf_up - hflux_dn = veloc_h(j) * wdsrf_dn - mflux_up = veloc_h(i)**2 * wdsrf_up + 0.5*grav * wdsrf_up**2 - mflux_dn = veloc_h(j)**2 * wdsrf_dn + 0.5*grav * wdsrf_dn**2 - - IF (vwave_up >= 0.) THEN - hflux_fc = hillslope%flen(i) * hflux_up - mflux_fc = hillslope%flen(i) * mflux_up - ELSEIF (vwave_dn <= 0.) THEN - hflux_fc = hillslope%flen(i) * hflux_dn - mflux_fc = hillslope%flen(i) * mflux_dn - ELSE - hflux_fc = hillslope%flen(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & - + vwave_up*vwave_dn*(wdsrf_dn-wdsrf_up)) / (vwave_dn-vwave_up) - mflux_fc = hillslope%flen(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & - + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) - ENDIF - - sum_hflux_h(i) = sum_hflux_h(i) + hflux_fc - sum_hflux_h(j) = sum_hflux_h(j) - hflux_fc - - sum_mflux_h(i) = sum_mflux_h(i) + mflux_fc - sum_mflux_h(j) = sum_mflux_h(j) - mflux_fc - - sum_zgrad_h(i) = sum_zgrad_h(i) + hillslope%flen(i) * 0.5*grav * wdsrf_up**2 - sum_zgrad_h(j) = sum_zgrad_h(j) - hillslope%flen(i) * 0.5*grav * wdsrf_dn**2 - - ENDDO - - DO i = 1, nhru - ! constraint 1: CFL condition - IF (hillslope%inext(i) > 0) THEN - IF ((veloc_h(i) /= 0.) .or. (wdsrf_h(i) > 0.)) THEN - dt_this = min(dt_this, hillslope%plen(i)/(abs(veloc_h(i)) + sqrt(grav*wdsrf_h(i)))*0.8) - ENDIF - ENDIF - - ! constraint 2: Avoid negative values of water - xsurf_h(i) = sum_hflux_h(i) / hillslope%area(i) - IF (xsurf_h(i) > 0) THEN - dt_this = min(dt_this, wdsrf_h(i) / xsurf_h(i)) - ENDIF - - ! constraint 3: Avoid change of flow direction - IF ((abs(veloc_h(i)) > 0.1) & - .and. (veloc_h(i) * (sum_mflux_h(i) - sum_zgrad_h(i)) > 0)) THEN - dt_this = min(dt_this, & - abs(momen_h(i) * hillslope%area(i) / (sum_mflux_h(i) - sum_zgrad_h(i)))) - ENDIF - ENDDO - - DO i = 1, nhru - - wdsrf_h(i) = max(0., wdsrf_h(i) - xsurf_h(i) * dt_this) - - IF (wdsrf_h(i) < PONDMIN) THEN - momen_h(i) = 0 - ELSE - friction = grav * nmanning_hslp**2 * abs(momen_h(i)) / wdsrf_h(i)**(7.0/3.0) - momen_h(i) = (momen_h(i) - & - (sum_mflux_h(i) - sum_zgrad_h(i)) / hillslope%area(i) * dt_this) & - / (1 + friction * dt_this) - - IF (hillslope%inext(i) <= 0) THEN - momen_h(i) = min(momen_h(i), 0.) - ENDIF - - IF (all(hillslope%inext /= i)) THEN - momen_h(i) = max(momen_h(i), 0.) - ENDIF - ENDIF - - ENDDO - - IF (hillslope%indx(1) == 0) THEN - srfbsn = minval(hillslope%hand + wdsrf_h) - IF (srfbsn < wdsrf_h(1)) THEN - allocate (mask (hillslope%nhru)) - dvol = (wdsrf_h(1) - srfbsn) * hillslope%area(1) - momen_h(1) = srfbsn/wdsrf_h(1) * momen_h(1) - wdsrf_h(1) = srfbsn - DO WHILE (dvol > 0) - mask = hillslope%hand + wdsrf_h > srfbsn - nexta = sum(hillslope%area, mask = (.not. mask)) - IF (any(mask)) THEN - nextl = minval(hillslope%hand + wdsrf_h, mask = mask) - nextv = nexta*(nextl-srfbsn) - IF (dvol > nextv) THEN - ddep = nextl - srfbsn - dvol = dvol - nextv - ELSE - ddep = dvol/nexta - dvol = 0. - ENDIF - ELSE - ddep = dvol/nexta - dvol = 0. - ENDIF - - srfbsn = srfbsn + ddep - - WHERE (.not. mask) - wdsrf_h = wdsrf_h + ddep - END WHERE - ENDDO - deallocate(mask) - ENDIF - ENDIF - - DO i = 1, nhru - IF (wdsrf_h(i) < PONDMIN) THEN - veloc_h(i) = 0 - ELSE - veloc_h(i) = momen_h(i) / wdsrf_h(i) - ENDIF - - wdsrf_bsnhru_ta(hillslope%ihru(i)) = wdsrf_bsnhru_ta(hillslope%ihru(i)) + wdsrf_h(i) * dt_this - momen_bsnhru_ta(hillslope%ihru(i)) = momen_bsnhru_ta(hillslope%ihru(i)) + momen_h(i) * dt_this - ENDDO - - dt_res = dt_res - dt_this - - ENDDO - - ! SAVE depth of surface water - DO i = 1, nhru - wdsrf_bsnhru(hillslope%ihru(i)) = wdsrf_h(i) - veloc_bsnhru(hillslope%ihru(i)) = veloc_h(i) - ENDDO - - deallocate (wdsrf_h) - deallocate (veloc_h) - deallocate (momen_h) - - deallocate (sum_hflux_h) - deallocate (sum_mflux_h) - deallocate (sum_zgrad_h) - - deallocate (xsurf_h) - - ENDDO - - IF (numbsnhru > 0) wdsrf_bsnhru_prev(:) = wdsrf_bsnhru(:) - - ENDIF - - END SUBROUTINE hillslope_flow - -END MODULE MOD_Catch_HillslopeFlow -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 deleted file mode 100644 index 92ab560435..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 +++ /dev/null @@ -1,381 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_HillslopeNetwork -!-------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Surface networks (hillslope bands): data and communication subroutines. -! -! Created by Shupeng Zhang, May 2023 -!-------------------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - ! -- data type -- - type :: hillslope_network_type - integer :: nhru - integer , pointer :: ihru (:) ! location of HRU in global vector "landhru" - integer , pointer :: indx (:) ! index of HRU - real(r8), pointer :: area (:) ! area of HRU [m^2] - real(r8), pointer :: agwt (:) ! water area only including (patchtype <= 2) [m^2] - real(r8), pointer :: hand (:) ! height above nearest drainage [m] - real(r8), pointer :: elva (:) ! elevation [m] - real(r8), pointer :: plen (:) ! average drainage path length to downstream HRU [m] - real(r8), pointer :: flen (:) ! interface length between this and downstream HRU [m] - integer , pointer :: inext(:) ! location of next HRU in this basin - real(r8), pointer :: fldprof (:,:) ! flood area profile - CONTAINS - final :: hillslope_network_free_mem - END type hillslope_network_type - - integer :: nfldstep - -CONTAINS - - ! ---------- - SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_UserDefFun - IMPLICIT NONE - - integer, intent(in) :: ne - integer, intent(in) :: elmindex (:) - type(hillslope_network_type), pointer :: hillslope_network(:) - - ! Local Variables - character(len=256) :: hillslope_network_file - - integer :: maxnumhru, ie, nhru, hs, i, j - integer :: irank, mesg(2), nrecv, irecv, isrc, idest - - integer , allocatable :: eid (:) - - integer , allocatable :: nhru_all(:), nhru_in_bsn(:) - - integer , allocatable :: indxhru (:,:) - real(r8), allocatable :: handhru (:,:) - real(r8), allocatable :: elvahru (:,:) - real(r8), allocatable :: plenhru (:,:) - real(r8), allocatable :: lfachru (:,:) - integer , allocatable :: nexthru (:,:) - real(r8), allocatable :: fldstep (:,:,:) - - integer , allocatable :: icache (:,:) - real(r8), allocatable :: rcache (:,:), rcache2(:,:,:) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - hillslope_network_file = DEF_CatchmentMesh_data - - IF (p_is_root) THEN - - CALL ncio_read_serial (hillslope_network_file, 'basin_numhru', nhru_all) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_index', indxhru) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_hand', handhru) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_elva', elvahru) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_pathlen', plenhru) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_facelen', lfachru) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_downstream', nexthru) - CALL ncio_read_serial (hillslope_network_file, 'hydrounit_flood_step', fldstep) - - ENDIF - - IF (p_is_root) maxnumhru = size(indxhru,1) - IF (p_is_root) nfldstep = size(fldstep,1) -#ifdef USEMPI - CALL mpi_bcast (maxnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast (nfldstep, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) -#endif - - hillslope_network => null() - - IF (p_is_root) THEN -#ifdef USEMPI - DO irank = 1, p_np_compute - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - nrecv = mesg(2) - isrc = mesg(1) - - IF (nrecv > 0) THEN - - allocate (eid (nrecv)) - allocate (nhru_in_bsn (nrecv)) - allocate (icache (maxnumhru,nrecv)) - allocate (rcache (maxnumhru,nrecv)) - - CALL mpi_recv (eid, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - idest = isrc - - nhru_in_bsn = nhru_all(eid) - CALL mpi_send (nhru_in_bsn, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - icache(:,irecv) = indxhru(:,eid(irecv)) - ENDDO - CALL mpi_send (icache, maxnumhru*nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - rcache(:,irecv) = handhru(:,eid(irecv)) - ENDDO - CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - rcache(:,irecv) = elvahru(:,eid(irecv)) - ENDDO - CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - rcache(:,irecv) = plenhru(:,eid(irecv)) - ENDDO - CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - rcache(:,irecv) = lfachru(:,eid(irecv)) - ENDDO - CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - icache(:,irecv) = nexthru(:,eid(irecv)) - ENDDO - CALL mpi_send (icache, maxnumhru*nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - allocate (rcache2 (nfldstep,maxnumhru,nrecv)) - - DO irecv = 1, nrecv - rcache2(:,:,irecv) = fldstep(:,:,eid(irecv)) - ENDDO - CALL mpi_send (rcache2, nfldstep*maxnumhru*nrecv, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (eid) - deallocate (nhru_in_bsn) - deallocate (icache) - deallocate (rcache) - deallocate (rcache2) - ENDIF - ENDDO -#else - IF (ne > 0) THEN - - allocate (nhru_in_bsn (ne)) - allocate (icache (maxnumhru,ne)) - allocate (rcache (maxnumhru,ne)) - - nhru_in_bsn = nhru_all(elmindex) - - DO ie = 1, ne - icache(:,ie) = indxhru(:,elmindex(ie)) - ENDDO - indxhru = icache - - DO ie = 1, ne - rcache(:,ie) = handhru(:,elmindex(ie)) - ENDDO - handhru = rcache - - DO ie = 1, ne - rcache(:,ie) = elvahru(:,elmindex(ie)) - ENDDO - elvahru = rcache - - DO ie = 1, ne - rcache(:,ie) = plenhru(:,elmindex(ie)) - ENDDO - plenhru = rcache - - DO ie = 1, ne - rcache(:,ie) = lfachru(:,elmindex(ie)) - ENDDO - lfachru = rcache - - DO ie = 1, ne - icache(:,ie) = nexthru(:,elmindex(ie)) - ENDDO - nexthru = icache - - deallocate (icache) - deallocate (rcache) - - allocate (rcache2 (nfldstep,maxnumhru,ne)) - - DO ie = 1, ne - rcache2(:,:,ie) = fldstep(:,:,elmindex(ie)) - ENDDO - fldstep = rcache2 - - deallocate (rcache2) - - ENDIF -#endif - ENDIF - - IF (p_is_compute) THEN - -#ifdef USEMPI - mesg(1:2) = (/p_iam_glb, ne/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (ne > 0) THEN - - CALL mpi_send (elmindex, ne, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (nhru_in_bsn (ne)) - CALL mpi_recv (nhru_in_bsn, ne, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (indxhru (maxnumhru,ne)) - CALL mpi_recv (indxhru, maxnumhru*ne, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (handhru (maxnumhru,ne)) - CALL mpi_recv (handhru, maxnumhru*ne, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (elvahru (maxnumhru,ne)) - CALL mpi_recv (elvahru, maxnumhru*ne, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (plenhru (maxnumhru,ne)) - CALL mpi_recv (plenhru, maxnumhru*ne, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (lfachru (maxnumhru,ne)) - CALL mpi_recv (lfachru, maxnumhru*ne, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (nexthru (maxnumhru,ne)) - CALL mpi_recv (nexthru, maxnumhru*ne, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (fldstep (nfldstep,maxnumhru,ne)) - CALL mpi_recv (fldstep, nfldstep*maxnumhru*ne, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF -#endif - - IF (ne > 0) THEN - allocate( hillslope_network (ne)) - ENDIF - - hs = 0 - - DO ie = 1, ne - - nhru = count(indxhru(:,ie) >= 0) - - IF (nhru > 0) THEN - - IF (nhru /= nhru_in_bsn(ie)) THEN - write(*,*) 'Warning : numbers of hydro units from file mismatch!' - ENDIF - - allocate (hillslope_network(ie)%ihru (nhru)) - allocate (hillslope_network(ie)%indx (nhru)) - allocate (hillslope_network(ie)%area (nhru)) - allocate (hillslope_network(ie)%agwt (nhru)) - allocate (hillslope_network(ie)%hand (nhru)) - allocate (hillslope_network(ie)%elva (nhru)) - allocate (hillslope_network(ie)%plen (nhru)) - allocate (hillslope_network(ie)%flen (nhru)) - allocate (hillslope_network(ie)%inext (nhru)) - - hillslope_network(ie)%indx = indxhru(1:nhru,ie) - hillslope_network(ie)%hand = handhru(1:nhru,ie) ! m - hillslope_network(ie)%elva = elvahru(1:nhru,ie) ! m - hillslope_network(ie)%plen = plenhru(1:nhru,ie) * 1.0e3 ! km to m - hillslope_network(ie)%flen = lfachru(1:nhru,ie) * 1.0e3 ! km to m - - hillslope_network(ie)%ihru = (/ (i, i = hs+1, hs+nhru) /) - - allocate (hillslope_network(ie)%fldprof (nfldstep,nhru)) - - DO i = 1, nhru - DO j = 1, nfldstep - IF (j == 1) THEN - hillslope_network(ie)%fldprof(j,i) = max(fldstep(j,i,ie) * (j-0.5)/nfldstep, 1.e-3) - ELSE - hillslope_network(ie)%fldprof(j,i) = hillslope_network(ie)%fldprof(j-1,i) & - + (fldstep(j,i,ie) - fldstep(j-1,i,ie)) * (j-0.5)/nfldstep - ENDIF - ENDDO - ENDDO - - DO i = 1, nhru - IF (nexthru(i,ie) >= 0) THEN - j = findloc_ud(indxhru(1:nhru,ie) == nexthru(i,ie)) - hillslope_network(ie)%inext(i) = j - ELSE - hillslope_network(ie)%inext(i) = -1 - ENDIF - ENDDO - - ELSE - ! for lake - hillslope_network(ie)%ihru => null() - hillslope_network(ie)%indx => null() - hillslope_network(ie)%area => null() - hillslope_network(ie)%agwt => null() - hillslope_network(ie)%hand => null() - hillslope_network(ie)%elva => null() - hillslope_network(ie)%plen => null() - hillslope_network(ie)%flen => null() - hillslope_network(ie)%inext => null() - ENDIF - - hillslope_network(ie)%nhru = nhru_in_bsn(ie) - hs = hs + nhru_in_bsn(ie) - - ENDDO - - ENDIF - - IF (allocated(nhru_all )) deallocate(nhru_all ) - IF (allocated(nhru_in_bsn)) deallocate(nhru_in_bsn) - - IF (allocated(indxhru)) deallocate(indxhru) - IF (allocated(handhru)) deallocate(handhru) - IF (allocated(elvahru)) deallocate(elvahru) - IF (allocated(plenhru)) deallocate(plenhru) - IF (allocated(lfachru)) deallocate(lfachru) - IF (allocated(nexthru)) deallocate(nexthru) - IF (allocated(fldstep)) deallocate(fldstep) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_root) write(*,'(A)') 'Read hillslope network information done.' - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE hillslope_network_init - - ! --------- - SUBROUTINE hillslope_network_free_mem (this) - - IMPLICIT NONE - type(hillslope_network_type) :: this - - IF (associated(this%ihru )) deallocate(this%ihru ) - IF (associated(this%indx )) deallocate(this%indx ) - IF (associated(this%area )) deallocate(this%area ) - IF (associated(this%agwt )) deallocate(this%agwt ) - IF (associated(this%hand )) deallocate(this%hand ) - IF (associated(this%elva )) deallocate(this%elva ) - IF (associated(this%plen )) deallocate(this%plen ) - IF (associated(this%flen )) deallocate(this%flen ) - IF (associated(this%inext )) deallocate(this%inext ) - IF (associated(this%fldprof)) deallocate(this%fldprof) - - END SUBROUTINE hillslope_network_free_mem - -END MODULE MOD_Catch_HillslopeNetwork -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 deleted file mode 100644 index b773a0d304..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 +++ /dev/null @@ -1,490 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_Hist -!-------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Write out model results in lateral hydrological processes to history files. -! -! Created by Shupeng Zhang, May 2023 -!-------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - USE MOD_Vars_Global, only: spval - - USE MOD_Mesh, only: numelm - USE MOD_LandHRU, only: numhru - USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru - USE MOD_Catch_Reservoir - USE MOD_Catch_Vars_1DFluxes - USE MOD_Vector_ReadWrite - - ! -- ACC Fluxes -- - integer :: nac_basin - - real(r8), allocatable :: a_wdsrf_bsnhru (:) - real(r8), allocatable :: a_veloc_bsnhru (:) - - real(r8), allocatable :: a_wdsrf_hru (:) - real(r8), allocatable :: a_veloc_hru (:) - - real(r8), allocatable :: a_wdsrf_bsn (:) - real(r8), allocatable :: a_veloc_riv (:) - real(r8), allocatable :: a_discharge (:) - - real(r8), allocatable :: a_wdsrf_elm (:) - real(r8), allocatable :: a_veloc_elm (:) - real(r8), allocatable :: a_dschg_elm (:) - - real(r8), allocatable :: a_xsubs_elm (:) - real(r8), allocatable :: a_xsubs_hru (:) - - real(r8), allocatable :: a_volresv (:) - real(r8), allocatable :: a_qresv_in (:) - real(r8), allocatable :: a_qresv_out (:) - - real(r8), allocatable :: ntacc_elm (:) - - ! -- PUBLIC SUBROUTINEs -- - PUBLIC :: hist_basin_init - PUBLIC :: hist_basin_out - PUBLIC :: hist_basin_final - -!-------------------------------------------------------------------------- -CONTAINS - - SUBROUTINE hist_basin_init - - IMPLICIT NONE - - IF (p_is_compute) THEN - IF (numbsnhru > 0) THEN - allocate (a_wdsrf_bsnhru (numbsnhru)) - allocate (a_veloc_bsnhru (numbsnhru)) - ENDIF - - IF (numbasin > 0) THEN - allocate (a_wdsrf_bsn (numbasin)) - allocate (a_veloc_riv (numbasin)) - allocate (a_discharge (numbasin)) - ENDIF - - IF (numelm > 0) allocate (a_xsubs_elm (numelm)) - IF (numhru > 0) allocate (a_xsubs_hru (numhru)) - - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv > 0) allocate (a_volresv (numresv)) - IF (numresv > 0) allocate (a_qresv_in (numresv)) - IF (numresv > 0) allocate (a_qresv_out (numresv)) - ENDIF - ENDIF - - CALL FLUSH_acc_fluxes_basin () - - END SUBROUTINE hist_basin_init - - !-------------------------------------- - SUBROUTINE hist_basin_final () - - IMPLICIT NONE - - IF (allocated(a_wdsrf_bsnhru)) deallocate(a_wdsrf_bsnhru) - IF (allocated(a_veloc_bsnhru)) deallocate(a_veloc_bsnhru) - - IF (allocated(a_wdsrf_bsn)) deallocate(a_wdsrf_bsn) - IF (allocated(a_veloc_riv)) deallocate(a_veloc_riv) - IF (allocated(a_discharge)) deallocate(a_discharge) - - IF (allocated(a_xsubs_elm)) deallocate(a_xsubs_elm) - IF (allocated(a_xsubs_hru)) deallocate(a_xsubs_hru) - - IF (allocated(a_volresv )) deallocate(a_volresv ) - IF (allocated(a_qresv_in )) deallocate(a_qresv_in ) - IF (allocated(a_qresv_out)) deallocate(a_qresv_out) - - END SUBROUTINE hist_basin_final - - !--------------------------------------- - SUBROUTINE hist_basin_out (file_hist, idate) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_ElmVector - USE MOD_HRUVector - USE MOD_LandHRU - USE MOD_Catch_BasinNetwork - IMPLICIT NONE - - character(len=*), intent(in) :: file_hist - integer, intent(in) :: idate(3) - - ! Local variables - character(len=256) :: file_hist_basin - logical :: fexists - integer :: itime_in_file - logical, allocatable :: filter (:) - real(r8), allocatable :: varhist(:) - integer :: i - - IF (p_is_root) THEN - - i = len_trim (file_hist) - DO WHILE (file_hist(i:i) /= '_') - i = i - 1 - ENDDO - file_hist_basin = file_hist(1:i) // 'basin_' // file_hist(i+1:) - - inquire (file=file_hist_basin, exist=fexists) - IF (.not. fexists) THEN - CALL ncio_create_file (trim(file_hist_basin)) - CALL ncio_define_dimension(file_hist_basin, 'time', 0) - CALL ncio_define_dimension(file_hist_basin, 'basin', totalnumelm) - CALL ncio_define_dimension(file_hist_basin, 'hydrounit', totalnumhru) - - CALL ncio_write_serial (file_hist_basin, 'basin', eindex_glb, 'basin') - CALL ncio_put_attr (file_hist_basin, 'basin', 'long_name', 'basin index') - - CALL ncio_write_serial (file_hist_basin, 'basin_hru', eindx_hru, 'hydrounit') - CALL ncio_put_attr (file_hist_basin, 'basin_hru', 'long_name', & - 'basin index of hydrological units') - - CALL ncio_write_serial (file_hist_basin, 'hru_type' , htype_hru, 'hydrounit') - CALL ncio_put_attr (file_hist_basin, 'hru_type' , 'long_name', & - 'index of hydrological units inside basin') - - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv_uniq > 0) THEN - CALL ncio_define_dimension(file_hist_basin, 'reservoir', numresv_uniq) - CALL ncio_write_serial (file_hist_basin, 'resv_hylak_id' , resv_hylak_id, 'reservoir') - CALL ncio_put_attr (file_hist_basin, 'resv_hylak_id' , 'long_name', & - 'HydroLAKE ID of reservoirs') - ENDIF - ENDIF - ENDIF - - CALL ncio_write_time (file_hist_basin, 'time', idate, itime_in_file, DEF_HIST_FREQ) - - ENDIF - - - IF (p_is_compute) THEN - IF (numhru > 0) THEN - allocate (a_wdsrf_hru (numhru)) - allocate (a_veloc_hru (numhru)) - ENDIF - - IF (numelm > 0) THEN - allocate (a_wdsrf_elm (numelm)) - allocate (a_veloc_elm (numelm)) - allocate (a_dschg_elm (numelm)) - allocate (ntacc_elm (numelm)) - ENDIF - ENDIF - - ! ----- water depth in basin ----- - IF (DEF_hist_vars%riv_height) THEN - IF ((p_is_compute) .and. allocated(a_wdsrf_bsn)) THEN - WHERE(a_wdsrf_bsn /= spval) - a_wdsrf_bsn = a_wdsrf_bsn / nac_basin - END WHERE - ENDIF - - CALL compute_push_data (push_bsn2elm, a_wdsrf_bsn, a_wdsrf_elm, spval) - - CALL vector_gather_and_write (& - a_wdsrf_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_wdsrf_bsn', 'basin', & - itime_in_file, 'River Height', 'm') - ENDIF - - ! ----- water velocity in river ----- - IF (DEF_hist_vars%riv_veloct) THEN - IF ((p_is_compute) .and. allocated(a_veloc_riv)) THEN - WHERE(a_veloc_riv /= spval) - a_veloc_riv = a_veloc_riv / nac_basin - END WHERE - ENDIF - - CALL compute_push_data (push_bsn2elm, a_veloc_riv, a_veloc_elm, spval) - - CALL vector_gather_and_write (& - a_veloc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_veloc_riv', 'basin', & - itime_in_file, 'River Velocity', 'm/s') - ENDIF - - ! ----- discharge in river ----- - IF (DEF_hist_vars%discharge) THEN - IF ((p_is_compute) .and. allocated(a_discharge)) THEN - WHERE(a_discharge /= spval) - a_discharge = a_discharge / nac_basin - END WHERE - ENDIF - - CALL compute_push_data (push_bsn2elm, a_discharge, a_dschg_elm, spval) - - CALL vector_gather_and_write (& - a_dschg_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_discharge', 'basin', & - itime_in_file, 'River Discharge', 'm^3/s') - ENDIF - - ! ----- number of time steps for each basin ----- - CALL compute_push_data (push_bsn2elm, ntacc_bsn, ntacc_elm, spval) - - CALL vector_gather_and_write (& - ntacc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'timesteps', 'basin', & - itime_in_file, 'Number of accumulated timesteps for each basin', '-') - - IF (p_is_compute .and. (numbasin > 0)) ntacc_bsn(:) = 0. - - ! ----- water depth in hydro unit ----- - IF (DEF_hist_vars%wdsrf_hru) THEN - IF ((p_is_compute) .and. allocated(a_wdsrf_bsnhru)) THEN - WHERE(a_wdsrf_bsnhru /= spval) - a_wdsrf_bsnhru = a_wdsrf_bsnhru / nac_basin - END WHERE - ENDIF - - CALL compute_push_data (push_bsnhru2elmhru, a_wdsrf_bsnhru, a_wdsrf_hru, spval) - - CALL vector_gather_and_write (& - a_wdsrf_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_wdsrf_hru', 'hydrounit', & - itime_in_file, 'Depth of Surface Water in Hydro unit', 'm') - ENDIF - - ! ----- water velocity in hydro unit ----- - IF (DEF_hist_vars%veloc_hru) THEN - IF ((p_is_compute) .and. allocated(a_veloc_bsnhru)) THEN - WHERE(a_veloc_bsnhru /= spval) - a_veloc_bsnhru = a_veloc_bsnhru / nac_basin - END WHERE - ENDIF - - CALL compute_push_data (push_bsnhru2elmhru, a_veloc_bsnhru, a_veloc_hru, spval) - - CALL vector_gather_and_write (& - a_veloc_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_veloc_hru', 'hydrounit', & - itime_in_file, 'Surface Flow Velocity in Hydro unit', 'm/s') - ENDIF - - ! ----- subsurface water flow between elements ----- - IF (DEF_hist_vars%xsubs_bsn) THEN - IF (p_is_compute) THEN - WHERE(a_xsubs_elm /= spval) - a_xsubs_elm = a_xsubs_elm / nac_basin - END WHERE - ENDIF - - CALL vector_gather_and_write (& - a_xsubs_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_xsubs_bsn', 'basin', & - itime_in_file, 'Subsurface lateral flow between basins', 'm/s') - ENDIF - - ! ----- subsurface water flow between hydro units ----- - IF (DEF_hist_vars%xsubs_hru) THEN - IF (p_is_compute) THEN - WHERE(a_xsubs_hru /= spval) - a_xsubs_hru = a_xsubs_hru / nac_basin - END WHERE - ENDIF - - CALL vector_gather_and_write (& - a_xsubs_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_xsubs_hru', 'hydrounit', & - itime_in_file, 'SubSurface lateral flow between HRUs', 'm/s') - ENDIF - - ! ----- reservoir variables ----- - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv_uniq > 0) THEN - - allocate (varhist (numresv_uniq)) - - IF (DEF_hist_vars%volresv) THEN - - IF (p_is_compute) THEN - IF (numresv > 0) THEN - WHERE (a_volresv /= spval) - a_volresv = a_volresv / nac_basin - END WHERE - ENDIF - ENDIF - - CALL reservoir_gather_var (a_volresv, varhist) - - IF (p_is_root) THEN - CALL ncio_write_serial_time (file_hist_basin, 'volresv', & - itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) - IF (itime_in_file == 1) THEN - CALL ncio_put_attr (file_hist_basin, 'volresv', 'long_name', 'reservoir water volume') - CALL ncio_put_attr (file_hist_basin, 'volresv', 'units', 'm^3') - CALL ncio_put_attr (file_hist_basin, 'volresv', 'missing_value', spval) - ENDIF - ENDIF - ENDIF - - IF (DEF_hist_vars%qresv_in) THEN - - IF (p_is_compute) THEN - IF (numresv > 0) THEN - WHERE (a_qresv_in /= spval) - a_qresv_in = a_qresv_in / nac_basin - END WHERE - ENDIF - ENDIF - - CALL reservoir_gather_var (a_qresv_in, varhist) - - IF (p_is_root) THEN - CALL ncio_write_serial_time (file_hist_basin, 'qresv_in', & - itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) - IF (itime_in_file == 1) THEN - CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'long_name', 'reservoir inflow') - CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'units', 'm^3/s') - CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'missing_value', spval) - ENDIF - ENDIF - ENDIF - - IF (DEF_hist_vars%qresv_out) THEN - - IF (p_is_compute) THEN - IF (numresv > 0) THEN - WHERE (a_qresv_out /= spval) - a_qresv_out = a_qresv_out / nac_basin - END WHERE - ENDIF - ENDIF - - CALL reservoir_gather_var (a_qresv_out, varhist) - - IF (p_is_root) THEN - CALL ncio_write_serial_time (file_hist_basin, 'qresv_out', & - itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel) - IF (itime_in_file == 1) THEN - CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'long_name', 'reservoir outflow') - CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'units', 'm^3/s') - CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'missing_value', spval) - ENDIF - ENDIF - ENDIF - - deallocate (varhist) - - ENDIF - ENDIF - - - CALL FLUSH_acc_fluxes_basin () - - IF (allocated(a_wdsrf_hru)) deallocate(a_wdsrf_hru) - IF (allocated(a_veloc_hru)) deallocate(a_veloc_hru) - - IF (allocated(a_wdsrf_elm)) deallocate(a_wdsrf_elm) - IF (allocated(a_veloc_elm)) deallocate(a_veloc_elm) - IF (allocated(a_dschg_elm)) deallocate(a_dschg_elm) - IF (allocated(ntacc_elm )) deallocate(ntacc_elm ) - - - END SUBROUTINE hist_basin_out - - !----------------------- - SUBROUTINE FLUSH_acc_fluxes_basin () - - USE MOD_SPMD_Task - USE MOD_Mesh, only: numelm - USE MOD_LandHRU, only: numhru - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - IF (p_is_compute) THEN - - nac_basin = 0 - - IF (numbasin > 0) THEN - a_wdsrf_bsn(:) = spval - a_veloc_riv(:) = spval - a_discharge(:) = spval - ENDIF - - IF (numelm > 0) a_xsubs_elm (:) = spval - - IF (numbsnhru > 0) THEN - a_wdsrf_bsnhru(:) = spval - a_veloc_bsnhru(:) = spval - ENDIF - - IF (numhru > 0) a_xsubs_hru(:) = spval - - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv > 0) a_volresv (:) = spval - IF (numresv > 0) a_qresv_in (:) = spval - IF (numresv > 0) a_qresv_out(:) = spval - ENDIF - - ENDIF - - END SUBROUTINE FLUSH_acc_fluxes_basin - - ! ------- - SUBROUTINE accumulate_fluxes_basin - - IMPLICIT NONE - - IF (p_is_compute) THEN - - nac_basin = nac_basin + 1 - - IF (numbasin > 0) THEN - CALL acc1d_basin (wdsrf_bsn_ta, a_wdsrf_bsn) - CALL acc1d_basin (veloc_riv_ta, a_veloc_riv) - CALL acc1d_basin (discharge_ta, a_discharge ) - ENDIF - - IF (numelm > 0) CALL acc1d_basin (xsubs_elm, a_xsubs_elm) - - IF (numbsnhru > 0) THEN - CALL acc1d_basin (wdsrf_bsnhru_ta, a_wdsrf_bsnhru) - CALL acc1d_basin (veloc_bsnhru_ta, a_veloc_bsnhru) - ENDIF - - IF (numhru > 0) CALL acc1d_basin (xsubs_hru, a_xsubs_hru) - - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv > 0) CALL acc1d_basin (volresv_ta, a_volresv ) - IF (numresv > 0) CALL acc1d_basin (qresv_in_ta, a_qresv_in ) - IF (numresv > 0) CALL acc1d_basin (qresv_out_ta, a_qresv_out) - ENDIF - - ENDIF - - END SUBROUTINE accumulate_fluxes_basin - - ! ------- - SUBROUTINE acc1d_basin (var, s) - - USE MOD_Precision - USE MOD_Vars_Global, only: spval - - IMPLICIT NONE - - real(r8), intent(in) :: var(:) - real(r8), intent(inout) :: s (:) - ! Local variables - integer :: i - - DO i = lbound(var,1), ubound(var,1) - IF (var(i) /= spval) THEN - IF (s(i) /= spval) THEN - s(i) = s(i) + var(i) - ELSE - s(i) = var(i) - ENDIF - ENDIF - ENDDO - - END SUBROUTINE acc1d_basin - -END MODULE MOD_Catch_Hist -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 deleted file mode 100644 index 6f078ba38c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 +++ /dev/null @@ -1,496 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_LateralFlow -!------------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Lateral flow. -! -! Lateral flows in CoLM include -! 1. Surface flow over hillslopes; -! 2. Routing flow in rivers; -! 3. Groundwater (subsurface) lateral flow. -! -! Water exchanges between -! 1. surface flow and rivers; -! 2. subsurface flow and rivers. -! -! Created by Shupeng Zhang, May 2023 -!------------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Catch_Vars_TimeVariables - USE MOD_ElementNeighbour - USE MOD_Catch_BasinNetwork - USE MOD_Catch_RiverLakeNetwork - USE MOD_Catch_HillslopeNetwork - USE MOD_Catch_HillslopeFlow - USE MOD_Catch_SubsurfaceFlow - USE MOD_Catch_RiverLakeFlow - USE MOD_Catch_Reservoir - USE MOD_Vars_TimeVariables - USE MOD_Vars_Global, only: dz_soi - USE MOD_Const_Physical, only: denice, denh2o - IMPLICIT NONE - - integer, parameter :: nsubstep = 20 - real(r8) :: dt_average - - real(r8) :: landarea - real(r8), allocatable :: patcharea (:) ! m^2 - -CONTAINS - - ! ---------- - SUBROUTINE lateral_flow_init (lc_year) - -#ifdef CoLMDEBUG - USE MOD_SPMD_Task - USE MOD_Mesh - USE MOD_Pixel - USE MOD_LandPatch - USE MOD_Utils -#endif - USE MOD_Catch_WriteParameters - IMPLICIT NONE - - integer, intent(in) :: lc_year ! which year of land cover data used - - integer :: ip, ie, ipxl - - IF (p_is_compute) THEN - - IF (numpatch > 0) THEN - allocate (patcharea (numpatch)) - patcharea(:) = 0. - DO ip = 1, numpatch - ie = landpatch%ielm(ip) - DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) - patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) - ENDDO - IF (landpatch%has_shared) THEN - patcharea(ip) = patcharea(ip) * landpatch%pctshared(ip) - ENDIF - ENDDO - ENDIF - - landarea = 0. - IF (numpatch > 0) landarea = sum(patcharea) -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, landarea, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) -#endif - ENDIF - - CALL element_neighbour_init (patcharea, lc_year) - CALL river_lake_network_init (patcharea) - CALL subsurface_network_init (patcharea) - CALL reservoir_init () - - CALL write_catch_parameters () - - - END SUBROUTINE lateral_flow_init - - ! ---------- - SUBROUTINE lateral_flow (year, deltime) - - USE MOD_Namelist, only: DEF_Reservoir_Method, DEF_USE_Dynamic_Lake - USE MOD_Mesh, only: numelm - USE MOD_LandHRU, only: landhru, numhru, elm_hru - USE MOD_LandPatch, only: numpatch, elm_patch, hru_patch - - USE MOD_Vars_Global, only: nl_lake - USE MOD_Const_Physical, only: tfrz - USE MOD_Vars_TimeVariables, only: wdsrf, t_lake, lake_icefrac, t_soisno - USE MOD_Vars_TimeInvariants, only: lakedepth, dz_lake - USE MOD_Vars_1DFluxes, only: rsur, rsub, rnof - USE MOD_Catch_Vars_1DFluxes - USE MOD_Catch_Vars_TimeVariables - USE MOD_Catch_RiverLakeNetwork - - USE MOD_Lake, only: adjust_lake_layer - - USE MOD_UserDefFun, only : findloc_ud - USE MOD_RangeCheck - IMPLICIT NONE - - integer, intent(in) :: year - real(r8), intent(in) :: deltime - - ! Local Variables - integer :: i, j, j0, h, ps, pe, istep, s - real(r8) :: rnofsrf, sumarea - real(r8), allocatable :: wdsrf_p (:), wdsrf_hru_p (:) -#ifdef CoLMDEBUG - real(r8) :: dtolw, tolwat, toldis, maxdvol, maxdvol_g, sumdvol - integer :: hs, he, imax, bidmax - real(r8), allocatable :: wdsrf_bsnhru_p(:), delvol(:) -#endif - - IF (p_is_compute) THEN - - ! a) The smallest unit in surface lateral flow (including hillslope flow and river-lake flow) - ! is HRU and the main prognostic variable is "wdsrf_bsnhru" (surface water depth). - ! b) "wdsrf_bsnhru" is updated by aggregating water depths in patches. - ! c) Water surface in a basin ("wdsrf_bsn", defined as the lowest surface water in the basin) - ! is derived from "wdsrf_bsnhru". - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - wdsrf_hru(i) = sum(wdsrf(ps:pe) * hru_patch%subfrc(ps:pe)) - wdsrf_hru(i) = wdsrf_hru(i) / 1.0e3 ! mm to m - ENDDO - - IF (numhru > 0) THEN - allocate (wdsrf_hru_p (numhru)) - wdsrf_hru_p = wdsrf_hru - ENDIF - - IF (numpatch > 0) THEN - allocate (wdsrf_p (numpatch)) - wdsrf_p = wdsrf - ENDIF - - dt_average = 0. - - IF (numbasin > 0) wdsrf_bsn_ta (:) = 0. - IF (numbasin > 0) momen_riv_ta (:) = 0. - IF (numbasin > 0) discharge_ta (:) = 0. - IF (numbsnhru > 0) wdsrf_bsnhru_ta (:) = 0. - IF (numbsnhru > 0) momen_bsnhru_ta (:) = 0. - - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv > 0) volresv_ta (:) = 0. - IF (numresv > 0) qresv_in_ta (:) = 0. - IF (numresv > 0) qresv_out_ta(:) = 0. - ENDIF - - CALL compute_push_data (push_elmhru2bsnhru, wdsrf_hru, wdsrf_bsnhru, spval) - -#ifdef CoLMDEBUG - IF (numbsnhru > 0) THEN - allocate (wdsrf_bsnhru_p (numbsnhru)) - wdsrf_bsnhru_p = wdsrf_bsnhru - ENDIF -#endif - - DO istep = 1, nsubstep - - ! (1) ------------------- Surface flow over hillslopes. ------------------- - CALL hillslope_flow (deltime/nsubstep) - - ! (2) ----------------------- River and Lake flow. ------------------------ - CALL river_lake_flow (year, deltime/nsubstep) - - dt_average = dt_average + deltime/nsubstep/ntimestep_riverlake - - ENDDO - - IF (numbasin > 0) THEN - wdsrf_bsn_ta(:) = wdsrf_bsn_ta(:) / deltime - momen_riv_ta(:) = momen_riv_ta(:) / deltime - - WHERE (wdsrf_bsn_ta > 0) - veloc_riv_ta = momen_riv_ta / wdsrf_bsn_ta - ELSE WHERE - veloc_riv_ta = 0 - END WHERE - - discharge_ta = discharge_ta / deltime - ENDIF - - IF (numbsnhru > 0) THEN - wdsrf_bsnhru_ta(:) = wdsrf_bsnhru_ta(:) / deltime - momen_bsnhru_ta(:) = momen_bsnhru_ta(:) / deltime - - WHERE (wdsrf_bsnhru_ta > 0) - veloc_bsnhru_ta = momen_bsnhru_ta / wdsrf_bsnhru_ta - ELSE WHERE - veloc_bsnhru_ta = 0. - END WHERE - ENDIF - - IF (DEF_Reservoir_Method > 0) THEN - DO i = 1, numresv - IF (year >= dam_build_year(i)) THEN - volresv_ta (i) = volresv_ta (i) / deltime - qresv_in_ta (i) = qresv_in_ta (i) / deltime - qresv_out_ta(i) = qresv_out_ta(i) / deltime - ELSE - volresv_ta (i) = spval - qresv_in_ta (i) = spval - qresv_out_ta(i) = spval - ENDIF - ENDDO - ENDIF - - ! update surface water depth on patches - CALL compute_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval) - DO i = 1, numhru - wdsrf_hru(i) = max(0., wdsrf_hru(i)) - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - wdsrf(ps:pe) = wdsrf_hru(i) * 1.0e3 ! m to mm - ENDDO - - IF (numpatch > 0) THEN - xwsur(:) = (wdsrf_p(:) - wdsrf(:)) / deltime - ENDIF - - ! update surface runoff from hillslope to river - IF (numpatch > 0) rsur(:) = 0. - DO i = 1, numelm - IF (lake_id_elm(i) <= 0) THEN - - rnofsrf = 0. - sumarea = 0. - - IF (lake_id_elm(i) == 0) THEN - j0 = 2 ! regular catchment with river - ELSE - j0 = 1 ! catchment directly to lake - ENDIF - - DO j = j0, hillslope_element(i)%nhru - h = hillslope_element(i)%ihru(j) - rnofsrf = rnofsrf + (wdsrf_hru_p(h) - wdsrf_hru(h)) * hillslope_element(i)%area(j) - sumarea = sumarea + hillslope_element(i)%area(j) - ENDDO - - IF (sumarea > 0.) THEN - rnofsrf = rnofsrf / sumarea * 1.e3 / deltime ! unit: mm/s - DO j = j0, hillslope_element(i)%nhru - h = hillslope_element(i)%ihru(j) - ps = hru_patch%substt(h) - pe = hru_patch%subend(h) - rsur(ps:pe) = rnofsrf - ENDDO - ENDIF - ENDIF - ENDDO - - ! update fraction of flooded area - DO i = 1, numelm - IF (lake_id_elm(i) <= 0) THEN - DO j = 1, hillslope_element(i)%nhru - h = hillslope_element(i)%ihru(j) - ps = hru_patch%substt(h) - pe = hru_patch%subend(h) - - IF (hillslope_element(i)%indx(j) == 0) THEN - fldarea(ps:pe) = 1.0 ! river - ELSE - s = findloc_ud(hillslope_element(i)%fldprof(:,j) <= wdsrf_hru(h), back = .true.) - IF (s == nfldstep) THEN - fldarea(ps:pe) = 1.0 - ELSEIF (s == 0) THEN - fldarea(ps:pe) = sqrt(wdsrf_hru(h)/hillslope_element(i)%fldprof(1,j) * 1./nfldstep**2) - ELSE - fldarea(ps:pe) = sqrt( (wdsrf_hru(h)-hillslope_element(i)%fldprof(s,j)) & - / (hillslope_element(i)%fldprof(s+1,j)-hillslope_element(i)%fldprof(s,j)) & - * real(2*s+1) / nfldstep**2 + real(s**2)/nfldstep**2 ) - ENDIF - ENDIF - ENDDO - ELSE - ps = elm_patch%substt(i) - pe = elm_patch%subend(i) - fldarea(ps:pe) = 1.0 ! lake - ENDIF - ENDDO - -#ifdef CoLMDEBUG - IF (numbasin > 0) THEN - - allocate (delvol (numbasin)) - - delvol(:) = 0 - DO i = numbasin, 1, -1 - hs = basin_hru%substt(i) - he = basin_hru%subend(i) - - IF (lake_id(i) <= 0) THEN - delvol(i) = delvol(i) & - + sum((wdsrf_bsnhru_p(hs:he) - wdsrf_bsnhru(hs:he))* hillslope_basin(i)%area) - ELSE - delvol(i) = delvol(i) & - + sum((wdsrf_bsnhru_p(hs:he) - wdsrf_bsnhru(hs:he))* lakeinfo(i)%area0) - ENDIF - - IF ((riverdown(i) == 0) .or. (riverdown(i) == -3)) THEN - delvol(i) = delvol(i) - discharge_ta(i) * deltime - ENDIF - - IF (riversystem == -1) THEN - j0 = i; j = ilocdown(i) - DO WHILE (j > 0) - - delvol(j) = delvol(j) + delvol(j0) - delvol(j0) = 0 - - IF ((j > i) .and. (ilocdown(j) > 0)) THEN - j0 = j; j = ilocdown(j) - ELSE - EXIT - ENDIF - ENDDO - ENDIF - ENDDO - - sumdvol = sum(delvol) - - IF (riversystem /= -1) THEN - maxdvol = sum(delvol) -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, maxdvol, 1, MPI_REAL8, MPI_SUM, p_comm_rivsys, p_err) - maxdvol = abs(maxdvol) - imax = findloc_ud(riverdown <= 0) - IF (imax > 0) THEN - bidmax = basinindex(imax) - ELSE - bidmax = 0 - ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_rivsys, p_err) -#endif - ELSE - imax = maxloc(abs(delvol),dim=1) - maxdvol = abs(delvol(imax)) - bidmax = basinindex(imax) - ENDIF - - ELSE - maxdvol = 0. - bidmax = 0 - sumdvol = 0. - ENDIF - -#ifdef USEMPI - CALL mpi_allreduce (maxdvol, maxdvol_g, 1, MPI_REAL8, MPI_MAX, p_comm_compute, p_err) - IF (maxdvol < maxdvol_g) THEN - bidmax = 0 - ENDIF - CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, sumdvol, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) -#else - maxdvol_g = maxdvol -#endif - - IF (allocated(wdsrf_bsnhru_p)) deallocate(wdsrf_bsnhru_p) - IF (allocated(delvol )) deallocate(delvol ) -#endif - - ! (3) ------------------- Subsurface lateral flow ------------------- - CALL subsurface_flow (deltime) - - DO i = 1, numpatch - h2osoi(:,i) = wliq_soisno(1:,i)/(dz_soi(1:)*denh2o) + wice_soisno(1:,i)/(dz_soi(1:)*denice) - wat(i) = sum(wice_soisno(1:,i)+wliq_soisno(1:,i)) + ldew(i) + scv(i) + wetwat(i) - ENDDO - - IF (numpatch > 0) rnof = rsur + rsub - - ! (4) ---------------- vertical layers adjustment --------------------- - IF (DEF_USE_Dynamic_Lake) THEN - DO i = 1, numpatch - IF (wdsrf_p(i) >= 100.) THEN - ! wet previously - dz_lake(:,i) = dz_lake(:,i) * wdsrf(i)*1.e-3/sum(dz_lake(:,i)) - ELSE - ! dry previously - dz_lake(:,i) = wdsrf(i)*1.e-3/nl_lake - t_lake (:,i) = t_soisno(1,i) - IF (t_soisno(1,i) >= tfrz) THEN - lake_icefrac(:,i) = 0. - ELSE - lake_icefrac(:,i) = 1. - ENDIF - ENDIF - - IF (wdsrf(i) >= 100.) THEN - CALL adjust_lake_layer (nl_lake, dz_lake(:,i), t_lake(:,i), lake_icefrac(:,i)) - ENDIF - ENDDO - ENDIF - - ENDIF - -#ifdef RangeCheck - IF (p_is_compute .and. (p_iam_compute == 0)) THEN - write(*,'(/,A)') 'Checking Lateral Flow Variables ...' - write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', & - dt_average/nsubstep, ' seconds' - ENDIF - - CALL check_vector_data ('Basin Water Depth [m] ', wdsrf_bsn) - CALL check_vector_data ('River Velocity [m/s]', veloc_riv) - CALL check_vector_data ('HRU Water Depth [m] ', wdsrf_bsnhru) - CALL check_vector_data ('HRU Water Velocity [m/s]', veloc_bsnhru) - CALL check_vector_data ('Subsurface bt basin [m/s]', xsubs_elm) - CALL check_vector_data ('Subsurface bt HRU [m/s]', xsubs_hru) - CALL check_vector_data ('Subsurface bt patch [m/s]', xsubs_pch) - -#ifdef CoLMDEBUG - IF (p_is_compute) THEN - - dtolw = 0 - toldis = 0 - - IF (numpatch > 0) THEN - dtolw = sum(patcharea * xwsur ) / 1.e3 * deltime - tolwat = sum(patcharea * wdsrf_p) / 1.e3 - ENDIF - IF (numbasin > 0) THEN - toldis = sum(discharge_ta*deltime, mask = (riverdown == 0) .or. (riverdown == -3)) - dtolw = dtolw - toldis - ENDIF - -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, tolwat, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, toldis, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) -#endif - IF (p_iam_compute == 0) THEN - write(*,'(A,E9.2,A,I0,A,E9.2,A)') 'River system error: max ', maxdvol_g, & - ' m^3 in river mouth ', bidmax, ', total ', sumdvol, ' m^3' - write(*,'(A,F12.2,A,ES8.1,A,ES10.3,A)') 'Total surface water error: ', dtolw, & - ' m^3 of total ', tolwat, ' m^3, discharge ', toldis, ' m^3' - ENDIF - - dtolw = 0 - IF (numpatch > 0) dtolw = sum(patcharea * xwsub) / 1.e3 * deltime -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) -#endif - IF (p_iam_compute == 0) THEN - write(*,'(A,F12.2,A,ES8.1,A)') 'Total ground water error: ', dtolw, & - ' m^3 in area ', landarea, ' m^2' - ENDIF - ENDIF -#endif -#endif - - IF (allocated(wdsrf_p )) deallocate(wdsrf_p ) - IF (allocated(wdsrf_hru_p)) deallocate(wdsrf_hru_p) - - END SUBROUTINE lateral_flow - - ! ---------- - SUBROUTINE lateral_flow_final () - - IMPLICIT NONE - - CALL river_lake_network_final () - CALL subsurface_network_final () - CALL basin_network_final () - CALL reservoir_final () - - IF (allocated(patcharea)) deallocate(patcharea) - - END SUBROUTINE lateral_flow_final - -END MODULE MOD_Catch_LateralFlow -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 deleted file mode 100644 index 62e2a12557..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 +++ /dev/null @@ -1,497 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_Reservoir -!----------------------------------------------------------------------- -! DESCRIPTION: -! -! Reservoir module in catchment mesh. -! -! Created by Shupeng Zhang, July 2025 -!----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Catch_BasinNetwork, only : numbasin, basinindex, numresv, bsn2resv, lake_id, lake_type - - real(r8), allocatable :: dam_elv (:) ! dam elevation [m] - - ! parameters - real(r8), allocatable :: volresv_total (:) ! total reservoir volume [m^3] - real(r8), allocatable :: volresv_emerg (:) ! emergency reservoir volume [m^3] - real(r8), allocatable :: volresv_adjust(:) ! adjustment reservoir volume [m^3] - real(r8), allocatable :: volresv_normal(:) ! normal reservoir volume [m^3] - - real(r8), allocatable :: qresv_mean (:) ! mean natural reservoir outflow [m^3/s] - real(r8), allocatable :: qresv_flood (:) ! flood reservoir outflow [m^3/s] - real(r8), allocatable :: qresv_adjust (:) ! adjustment reservoir outflow [m^3/s] - real(r8), allocatable :: qresv_normal (:) ! normal reservoir outflow [m^3/s] - - integer, allocatable :: dam_build_year(:) ! year in which the dam/barrier was built - - ! time variables - real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3] - real(r8), allocatable :: qresv_in (:) ! reservoir inflow [m^3/s] - real(r8), allocatable :: qresv_out (:) ! reservoir outflow [m^3/s] - - ! time average variables for output - real(r8), allocatable :: volresv_ta (:) ! reservoir water volume [m^3] - real(r8), allocatable :: qresv_in_ta (:) ! inflow to reservoir [m^3/s] - real(r8), allocatable :: qresv_out_ta (:) ! outflow from reservoir [m^3/s] - - integer :: numresv_uniq - integer, allocatable :: resv_hylak_id (:) ! HydroLAKE ID of reservoir - integer, allocatable :: resv_loc2glb (:) ! global index of reservoir - - ! -- PUBLIC SUBROUTINEs -- - PUBLIC :: reservoir_init - PUBLIC :: reservoir_operation - PUBLIC :: reservoir_gather_var - PUBLIC :: reservoir_final - -CONTAINS - - ! ------- - SUBROUTINE reservoir_init ( ) - - USE MOD_Vars_Global, only: spval - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_Utils - USE MOD_Catch_RiverLakeNetwork, only : wtsrfelv, bedelv, lakeinfo - - IMPLICIT NONE - - ! Local variables - character(len=256) :: basin_info_file, resv_info_file - integer :: maxlakeid, mesg(2), isrc, idest, irank - - integer, allocatable :: lake_id_basin (:), ilat_outlet_basin(:), ilon_outlet_basin(:) - integer, allocatable :: lake_id_resv (:), ilat_outlet_resv (:), ilon_outlet_resv (:) - integer, allocatable :: lake_type_resv(:), lake_id2typ (:) - integer, allocatable :: resv_bsn_id (:), idlist (:) - integer, allocatable :: all_year_basin(:), all_year_resv (:) - - real(r8), allocatable :: all_vol_basin (:), all_qmean_basin (:), all_qflood_basin (:) - real(r8), allocatable :: all_vol_resv (:), all_qmean_resv (:), all_qflood_resv (:) - real(r8), allocatable :: all_dhgt_basin(:), all_dhgt_resv (:), dam_height (:) - - real(r8), allocatable :: rcache(:) - integer, allocatable :: icache(:) - integer :: nbasin, ibasin, irsv, nrecv, nrsv, iloc - - - IF (p_is_compute) THEN - - IF (numresv > 0) THEN - - allocate (dam_elv (numresv)) - - allocate (volresv_total (numresv)) - allocate (volresv_emerg (numresv)) - allocate (volresv_adjust(numresv)) - allocate (volresv_normal(numresv)) - - allocate (qresv_mean (numresv)) - allocate (qresv_flood (numresv)) - allocate (qresv_adjust (numresv)) - allocate (qresv_normal (numresv)) - - allocate (volresv (numresv)) - allocate (qresv_in (numresv)) - allocate (qresv_out (numresv)) - - allocate (volresv_ta (numresv)) - allocate (qresv_in_ta (numresv)) - allocate (qresv_out_ta (numresv)) - - allocate (dam_build_year(numresv)) - - allocate (dam_height (numresv)) - - ENDIF - ENDIF - - ! read in parameters from file. - IF (p_is_root) THEN - - basin_info_file = DEF_CatchmentMesh_data - CALL ncio_read_serial (basin_info_file, 'lake_id', lake_id_basin ) - CALL ncio_read_serial (basin_info_file, 'ilat_outlet', ilat_outlet_basin) - CALL ncio_read_serial (basin_info_file, 'ilon_outlet', ilon_outlet_basin) - - maxlakeid = maxval(lake_id_basin) - IF (maxlakeid > 0) THEN - - resv_info_file = trim(DEF_dir_runtime)//'/HydroLAKES_Reservoir.nc' - CALL ncio_read_serial (resv_info_file, 'hylak_id', lake_id_resv ) - CALL ncio_read_serial (resv_info_file, 'lake_type', lake_type_resv ) - CALL ncio_read_serial (resv_info_file, 'ilat_outlet', ilat_outlet_resv) - CALL ncio_read_serial (resv_info_file, 'ilon_outlet', ilon_outlet_resv) - CALL ncio_read_serial (resv_info_file, 'volresv', all_vol_resv ) - CALL ncio_read_serial (resv_info_file, 'qmean', all_qmean_resv ) - CALL ncio_read_serial (resv_info_file, 'qflood', all_qflood_resv) - - CALL ncio_read_serial (resv_info_file, 'build_year', all_year_resv) - CALL ncio_read_serial (resv_info_file, 'dam_height', all_dhgt_resv) - - allocate (lake_id2typ (-1:maxlakeid)) - lake_id2typ(:) = 0 - - DO irsv = 1, size(lake_id_resv) - IF (lake_id_resv(irsv) <= maxlakeid) THEN - lake_id2typ(lake_id_resv(irsv)) = lake_type_resv(irsv) - ENDIF - ENDDO - - - nbasin = size(lake_id_basin) - - allocate(all_vol_basin (nbasin)); all_vol_basin (:) = spval - allocate(all_qmean_basin (nbasin)); all_qmean_basin (:) = spval - allocate(all_qflood_basin (nbasin)); all_qflood_basin(:) = spval - allocate(all_year_basin (nbasin)); all_year_basin (:) = -99 - allocate(all_dhgt_basin (nbasin)); all_dhgt_basin (:) = spval - - DO ibasin = 1, nbasin - IF (lake_id2typ(lake_id_basin(ibasin)) >= 2) THEN - DO irsv = 1, size(lake_id_resv) - IF (lake_id_basin(ibasin) == lake_id_resv(irsv)) THEN - IF (ilat_outlet_basin(ibasin) == ilat_outlet_resv(irsv)) THEN - IF (ilon_outlet_basin(ibasin) == ilon_outlet_resv(irsv)) THEN - all_vol_basin (ibasin) = all_vol_resv (irsv) - all_qmean_basin (ibasin) = all_qmean_resv (irsv) - all_qflood_basin(ibasin) = all_qflood_resv(irsv) - all_year_basin (ibasin) = all_year_resv (irsv) - all_dhgt_basin (ibasin) = all_dhgt_resv (irsv) - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - - ENDIF - - ENDIF - - IF (p_is_compute) THEN - IF (numresv > 0) THEN - allocate (resv_bsn_id (numresv)) - resv_bsn_id = pack(basinindex, lake_type >= 2) - ENDIF - ENDIF - -#ifdef USEMPI - IF (p_is_root) THEN - DO irank = 0, p_np_compute-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - - allocate (resv_bsn_id (nrecv)) - allocate (rcache (nrecv)) - allocate (icache (nrecv)) - - CALL mpi_recv (resv_bsn_id, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - idest = isrc - - rcache = all_vol_basin(resv_bsn_id) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = all_qmean_basin(resv_bsn_id) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = all_qflood_basin(resv_bsn_id) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - icache = all_year_basin(resv_bsn_id) - CALL mpi_send (icache, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = all_dhgt_basin(resv_bsn_id) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (resv_bsn_id) - deallocate (rcache) - deallocate (icache) - - ENDIF - ENDDO - ENDIF - - IF (p_is_compute) THEN - - mesg(1:2) = (/p_iam_glb, numresv/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (numresv > 0) THEN - CALL mpi_send (resv_bsn_id, numresv, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - - CALL mpi_recv (volresv_total, numresv, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - CALL mpi_recv (qresv_mean, numresv, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - CALL mpi_recv (qresv_flood, numresv, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - CALL mpi_recv (dam_build_year, numresv, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - CALL mpi_recv (dam_height, numresv, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF -#else - IF (numresv > 0) THEN - volresv_total = all_vol_basin (resv_bsn_id) - qresv_mean = all_qmean_basin (resv_bsn_id) - qresv_flood = all_qflood_basin(resv_bsn_id) - dam_build_year = all_year_basin (resv_bsn_id) - dam_height = all_dhgt_basin (resv_bsn_id) - ENDIF -#endif - - IF (p_is_compute) THEN - DO ibasin = 1, numbasin - IF (lake_type(ibasin) >= 2) THEN - - irsv = bsn2resv(ibasin) - - dam_height(irsv) = max(dam_height(irsv), wtsrfelv(ibasin)-bedelv(ibasin)) - dam_height(irsv) = max(dam_height(irsv), lakeinfo(ibasin)%surface(volresv_total(irsv))) - dam_height(irsv) = min(dam_height(irsv), 335.) - - dam_elv (irsv) = bedelv(ibasin) + dam_height(irsv) - volresv_total (irsv) = lakeinfo(ibasin)%volume( dam_height(irsv) ) - - volresv_emerg (irsv) = volresv_total(irsv) * 0.94 - volresv_adjust(irsv) = volresv_total(irsv) * 0.77 - volresv_normal(irsv) = volresv_total(irsv) * 0.7 - - qresv_normal (irsv) = volresv_normal(irsv)*0.7/(180*86400) + qresv_mean(irsv)*0.25 - qresv_adjust (irsv) = (qresv_normal(irsv) + qresv_flood(irsv)) * 0.5 - ENDIF - ENDDO - ENDIF - - - IF (p_is_root) THEN - - nrsv = count(lake_id2typ(lake_id_basin) >= 2) - - IF (nrsv > 0) THEN - - allocate (idlist (nrsv)) - - numresv_uniq = 0 - DO ibasin = 1, size(lake_id_basin) - IF (lake_id2typ(lake_id_basin(ibasin)) >= 2) THEN - CALL insert_into_sorted_list1 ( & - lake_id_basin(ibasin), numresv_uniq, idlist, iloc) - ENDIF - ENDDO - - allocate (resv_hylak_id (numresv_uniq)) - resv_hylak_id = idlist(1:numresv_uniq) - - deallocate (idlist) - - ELSE - numresv_uniq = 0 - ENDIF - - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (numresv_uniq, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - - IF (numresv_uniq > 0) THEN - IF (.not. p_is_root) allocate (resv_hylak_id (numresv_uniq)) - CALL mpi_bcast (resv_hylak_id, numresv_uniq, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - ENDIF -#endif - - IF (p_is_compute) THEN - IF (numresv > 0) THEN - allocate (resv_loc2glb (numresv)) - DO ibasin = 1, numbasin - IF (lake_type(ibasin) >= 2) THEN - resv_loc2glb(bsn2resv(ibasin)) = & - find_in_sorted_list1 (lake_id(ibasin), numresv_uniq, resv_hylak_id) - ENDIF - ENDDO - ENDIF - ENDIF - - - IF (allocated(lake_id2typ )) deallocate (lake_id2typ ) - IF (allocated(lake_id_basin )) deallocate (lake_id_basin ) - IF (allocated(ilat_outlet_basin)) deallocate (ilat_outlet_basin) - IF (allocated(ilon_outlet_basin)) deallocate (ilon_outlet_basin) - IF (allocated(lake_id_resv )) deallocate (lake_id_resv ) - IF (allocated(lake_type_resv )) deallocate (lake_type_resv ) - IF (allocated(ilat_outlet_resv )) deallocate (ilat_outlet_resv ) - IF (allocated(ilon_outlet_resv )) deallocate (ilon_outlet_resv ) - IF (allocated(all_qmean_basin )) deallocate (all_qmean_basin ) - IF (allocated(all_qflood_basin )) deallocate (all_qflood_basin ) - IF (allocated(all_qmean_resv )) deallocate (all_qmean_resv ) - IF (allocated(all_qflood_resv )) deallocate (all_qflood_resv ) - IF (allocated(all_year_basin )) deallocate (all_year_basin ) - IF (allocated(all_year_resv )) deallocate (all_year_resv ) - IF (allocated(all_dhgt_basin )) deallocate (all_dhgt_basin ) - IF (allocated(all_dhgt_resv )) deallocate (all_dhgt_resv ) - IF (allocated(dam_height )) deallocate (dam_height ) - IF (allocated(resv_bsn_id )) deallocate (resv_bsn_id ) - - - END SUBROUTINE reservoir_init - - - SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) - - IMPLICIT NONE - integer, intent(in) :: method - integer, intent(in) :: irsv - real(r8), intent(in) :: qin, vol - real(r8), intent(out) :: qout - - ! local variables - real(r8) :: q1 - - IF (method == 1) THEN - ! *** Reference *** - ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. - ! Development of an improved reservoir operation scheme for global flood modeling. - ! ESS Open Archive . October 24, 2024. - - IF (vol > volresv_emerg(irsv)) THEN - qout = max(qin, qresv_flood(irsv)) - ELSEIF (vol > volresv_adjust(irsv)) THEN - qout = qresv_adjust(irsv) + (qresv_flood(irsv)-qresv_adjust(irsv)) & - * ((vol-volresv_adjust(irsv))/(volresv_emerg(irsv)-volresv_adjust(irsv)))**0.1 - IF (qin > qresv_flood(irsv)) THEN - q1 = qresv_normal(irsv) + (qin-qresv_normal(irsv)) & - * (vol-volresv_normal(irsv))/(volresv_emerg(irsv)-volresv_normal(irsv)) - qout = max(q1, qout) - ENDIF - ELSEIF (vol > volresv_normal(irsv)) THEN - qout = qresv_normal(irsv) + (qresv_adjust(irsv)-qresv_normal(irsv)) & - * ((vol-volresv_normal(irsv))/(volresv_adjust(irsv)-volresv_normal(irsv)))**3. - ELSE - qout = (vol/volresv_normal(irsv))**0.5 * qresv_normal(irsv) - ENDIF - - ENDIF - - END SUBROUTINE reservoir_operation - - - SUBROUTINE reservoir_gather_var (varin, varout) - - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(in) :: varin (:) - real(r8), intent(out) :: varout (:) - - ! local variables - integer :: irsv, irank - real(r8), allocatable :: varall (:,:) - - IF (numresv_uniq == 0) RETURN - - IF (p_is_compute) THEN - varout(:) = spval - DO irsv = 1, numresv - IF (varin(irsv) /= spval) THEN - IF (varout(resv_loc2glb(irsv)) /= spval) THEN - varout(resv_loc2glb(irsv)) = varout(resv_loc2glb(irsv)) + varin(irsv) - ELSE - varout(resv_loc2glb(irsv)) = varin(irsv) - ENDIF - ENDIF - ENDDO -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (varall (numresv_uniq,0:p_np_compute-1)) - ENDIF - - CALL mpi_gather (varout, numresv_uniq, MPI_REAL8, & - varall, numresv_uniq, MPI_REAL8, p_root, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN - - DO irsv = 1, numresv_uniq - DO irank = 0, p_np_compute-1 - IF (irank /= p_root) THEN - IF (varall(irsv,irank) /= spval) THEN - IF (varout(irsv) /= spval) THEN - varout(irsv) = varout(irsv) + varall(irsv,irank) - ELSE - varout(irsv) = varall(irsv,irank) - ENDIF - ENDIF - ENDIF - ENDDO - ENDDO - - deallocate (varall) - ENDIF -#endif - ENDIF - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - CALL mpi_send (varout, numresv_uniq, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - IF (p_is_root) THEN - CALL mpi_recv (varout, numresv_uniq, MPI_REAL8, p_address_compute(p_root), & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF -#endif - - END SUBROUTINE reservoir_gather_var - - - SUBROUTINE reservoir_final () - - IMPLICIT NONE - - IF (allocated(dam_elv )) deallocate (dam_elv ) - - IF (allocated(resv_hylak_id )) deallocate (resv_hylak_id ) - IF (allocated(resv_loc2glb )) deallocate (resv_loc2glb ) - - IF (allocated(volresv_total )) deallocate (volresv_total ) - IF (allocated(volresv_emerg )) deallocate (volresv_emerg ) - IF (allocated(volresv_adjust)) deallocate (volresv_adjust) - IF (allocated(volresv_normal)) deallocate (volresv_normal) - - IF (allocated(qresv_mean )) deallocate (qresv_mean ) - IF (allocated(qresv_flood )) deallocate (qresv_flood ) - IF (allocated(qresv_adjust )) deallocate (qresv_adjust ) - IF (allocated(qresv_normal )) deallocate (qresv_normal ) - - IF (allocated(dam_build_year)) deallocate (dam_build_year) - - IF (allocated(volresv )) deallocate (volresv ) - IF (allocated(qresv_in )) deallocate (qresv_in ) - IF (allocated(qresv_out )) deallocate (qresv_out ) - - IF (allocated(volresv_ta )) deallocate (volresv_ta ) - IF (allocated(qresv_in_ta )) deallocate (qresv_in_ta ) - IF (allocated(qresv_out_ta )) deallocate (qresv_out_ta ) - - END SUBROUTINE reservoir_final - -END MODULE MOD_Catch_Reservoir -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 deleted file mode 100644 index f0c83ba2d8..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 +++ /dev/null @@ -1,596 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_RiverLakeFlow -!------------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Shallow water equation solver in rivers. -! -! References -! [1] Toro EF. Shock-capturing methods for free-surface shallow flows. -! Chichester: John Wiley & Sons; 2001. -! [2] Liang, Q., Borthwick, A. G. L. (2009). Adaptive quadtree simulation of shallow -! flows with wet-dry fronts over complex topography. -! Computers and Fluids, 38(2), 221-234. -! [3] Audusse, E., Bouchut, F., Bristeau, M.-O., Klein, R., Perthame, B. (2004). -! A Fast and Stable Well-Balanced Scheme with Hydrostatic Reconstruction for -! Shallow Water Flows. SIAM Journal on Scientific Computing, 25(6), 2050-2065. -! -! Created by Shupeng Zhang, May 2023 -!------------------------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - real(r8), parameter :: nmanning_riv = 0.03 - - real(r8), parameter :: RIVERMIN = 1.e-5_r8 - real(r8), parameter :: VOLUMEMIN = 1.e-5_r8 - - integer :: ntimestep_riverlake - -CONTAINS - - ! --------- - SUBROUTINE river_lake_flow (year, dt) - - USE MOD_SPMD_Task - USE MOD_Namelist, only : DEF_Reservoir_Method - USE MOD_Utils - USE MOD_Catch_BasinNetwork - USE MOD_Catch_HillslopeNetwork - USE MOD_Catch_RiverLakeNetwork - USE MOD_Catch_Reservoir - USE MOD_Catch_Vars_TimeVariables - USE MOD_Catch_Vars_1DFluxes - USE MOD_Const_Physical, only: grav - IMPLICIT NONE - - integer, intent(in) :: year - real(r8), intent(in) :: dt - - ! Local Variables - integer :: hs, he, i, j, irsv - real(r8) :: dt_this - - real(r8), allocatable :: wdsrf_bsn_ds(:) - real(r8), allocatable :: veloc_riv_ds(:) - real(r8), allocatable :: momen_riv_ds(:) - - real(r16), allocatable :: hflux_fc(:) - real(r16), allocatable :: mflux_fc(:) - real(r16), allocatable :: zgrad_dn(:) - - real(r16), allocatable :: hflux_resv(:) - real(r16), allocatable :: mflux_resv(:) - - real(r16), allocatable :: sum_hflux_riv(:) - real(r16), allocatable :: sum_mflux_riv(:) - real(r16), allocatable :: sum_zgrad_riv(:) - - real(r8) :: veloct_fc, height_fc, momen_fc, zsurf_fc - real(r8) :: bedelv_fc, height_up, height_dn - real(r8) :: vwave_up, vwave_dn, hflux_up, hflux_dn, mflux_up, mflux_dn - real(r8) :: totalvolume, friction, dvol, nextl, nexta, nextv, ddep - real(r8), allocatable :: dt_res(:), dt_all(:), dt_tmp(:) - logical, allocatable :: hmask(:), bsnfilter(:) - - - IF (p_is_compute) THEN - - ! update water depth in basin by aggregating water depths in patches - DO i = 1, numbasin - hs = basin_hru%substt(i) - he = basin_hru%subend(i) - - IF (lake_id(i) <= 0) THEN - ! river or lake catchment - ! Water surface in a basin is defined as the lowest surface water in the basin - wdsrf_bsn(i) = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he)) - handmin(i) - - ELSEIF (lake_id(i) > 0) THEN - ! lake - totalvolume = sum(wdsrf_bsnhru(hs:he) * lakeinfo(i)%area0) - wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume) - ENDIF - - - IF (lake_id(i) == 0) THEN - ! river momentum is less or equal than the momentum at last time step. - IF (wdsrf_bsn_prev(i) < wdsrf_bsn(i)) THEN - momen_riv(i) = wdsrf_bsn_prev(i) * veloc_riv(i) - veloc_riv(i) = momen_riv(i) / wdsrf_bsn(i) - ELSE - momen_riv(i) = wdsrf_bsn(i) * veloc_riv(i) - ENDIF - ELSE - ! water in lake or lake catchment is assumued to be stationary. - ! TODO: lake dynamics - momen_riv(i) = 0 - veloc_riv(i) = 0 - ENDIF - - ENDDO - - IF (numbasin > 0) THEN - - allocate (wdsrf_bsn_ds (numbasin)) - allocate (veloc_riv_ds (numbasin)) - allocate (momen_riv_ds (numbasin)) - allocate (hflux_fc (numbasin)) - allocate (mflux_fc (numbasin)) - allocate (zgrad_dn (numbasin)) - allocate (sum_hflux_riv (numbasin)) - allocate (sum_mflux_riv (numbasin)) - allocate (sum_zgrad_riv (numbasin)) - allocate (bsnfilter (numbasin)) - - IF (DEF_Reservoir_Method > 0) THEN - allocate (hflux_resv (numbasin)) - allocate (mflux_resv (numbasin)) - ENDIF - - ENDIF - - allocate (dt_res (numrivsys)) - allocate (dt_all (numrivsys)) - - ntimestep_riverlake = 0 - - dt_res(:) = dt - - DO WHILE (any(dt_res > 0)) - - ntimestep_riverlake = ntimestep_riverlake + 1 - - DO i = 1, numbasin - bsnfilter(i) = dt_res(irivsys(i)) > 0 - IF (bsnfilter(i)) THEN - sum_hflux_riv(i) = 0. - sum_mflux_riv(i) = 0. - sum_zgrad_riv(i) = 0. - ENDIF - ENDDO - - WHERE (bsnfilter) ntacc_bsn = ntacc_bsn + 1 - - CALL pull_from_downstream (wdsrf_bsn, wdsrf_bsn_ds, bsnfilter) - CALL pull_from_downstream (veloc_riv, veloc_riv_ds, bsnfilter) - CALL pull_from_downstream (momen_riv, momen_riv_ds, bsnfilter) - - ! velocity in ocean or inland depression is assumed to be 0. - IF (numbasin > 0) THEN - WHERE (riverdown <= 0) - veloc_riv_ds = 0. - END WHERE - ENDIF - - dt_all(:) = dt_res(:) - - DO i = 1, numbasin - - IF (.not. bsnfilter(i)) CYCLE - - IF (riverdown(i) >= 0) THEN - - IF (riverdown(i) > 0) THEN - ! both elements are dry. - IF ((wdsrf_bsn(i) < RIVERMIN) .and. (wdsrf_bsn_ds(i) < RIVERMIN)) THEN - hflux_fc(i) = 0 - mflux_fc(i) = 0 - zgrad_dn(i) = 0 - CYCLE - ENDIF - ENDIF - - ! reconstruction of height of water near interface - IF (riverdown(i) > 0) THEN - bedelv_fc = max(bedelv(i), bedelv_ds(i)) - IF ((lake_type(i) == 2) .or. (lake_type(i) == 3)) THEN - ! for reservoir (type=2) or controlled lake (type=3) - IF ((DEF_Reservoir_Method > 0) & - .and. (year >= dam_build_year(bsn2resv(i)))) THEN - bedelv_fc = max(bedelv_fc, dam_elv(bsn2resv(i))) - ENDIF - ENDIF - height_up = max(0., wdsrf_bsn(i) +bedelv(i) -bedelv_fc) - height_dn = max(0., wdsrf_bsn_ds(i)+bedelv_ds(i)-bedelv_fc) - ELSEIF (riverdown(i) == 0) THEN ! for river mouth - bedelv_fc = bedelv(i) - height_up = wdsrf_bsn(i) - ! sea level is assumed to be 0. and sea bed is assumed to be negative infinity. - height_dn = max(0., - bedelv_fc) - ENDIF - - ! velocity at river downstream face (middle region in Riemann problem) - veloct_fc = 0.5 * (veloc_riv(i) + veloc_riv_ds(i)) & - + sqrt(grav * height_up) - sqrt(grav * height_dn) - - ! height of water at downstream face (middle region in Riemann problem) - height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn)) & - + 0.25 * (veloc_riv(i) - veloc_riv_ds(i))) ** 2 - - IF (height_up > 0) THEN - vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) - ELSE - vwave_up = veloc_riv_ds(i) - 2.0 * sqrt(grav*height_dn) - ENDIF - - IF (height_dn > 0) THEN - vwave_dn = max(veloc_riv_ds(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) - ELSE - vwave_dn = veloc_riv(i) + 2.0 * sqrt(grav*height_up) - ENDIF - - hflux_up = veloc_riv(i) * height_up - hflux_dn = veloc_riv_ds(i) * height_dn - mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 - mflux_dn = veloc_riv_ds(i)**2 * height_dn + 0.5*grav * height_dn**2 - - IF (vwave_up >= 0.) THEN - hflux_fc(i) = outletwth(i) * hflux_up - mflux_fc(i) = outletwth(i) * mflux_up - ELSEIF (vwave_dn <= 0.) THEN - hflux_fc(i) = outletwth(i) * hflux_dn - mflux_fc(i) = outletwth(i) * mflux_dn - ELSE - hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & - + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) - mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & - + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) - ENDIF - - sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 - - zgrad_dn(i) = outletwth(i) * 0.5*grav * height_dn**2 - - ELSEIF (riverdown(i) == -3) THEN - ! downstream is not in model region. - ! assume: 1. downstream river bed is equal to this river bed. - ! 2. downstream water surface is equal to this river depth. - ! 3. downstream water velocity is equal to this velocity. - - veloc_riv(i) = max(veloc_riv(i), 0.) - - IF (wdsrf_bsn(i) > riverdpth(i)) THEN - - ! reconstruction of height of water near interface - height_up = wdsrf_bsn(i) - height_dn = riverdpth(i) - - veloct_fc = veloc_riv(i) + sqrt(grav * height_up) - sqrt(grav * height_dn) - height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn))) ** 2 - - vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) - vwave_dn = max(veloc_riv(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) - - hflux_up = veloc_riv(i) * height_up - hflux_dn = veloc_riv(i) * height_dn - mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 - mflux_dn = veloc_riv(i)**2 * height_dn + 0.5*grav * height_dn**2 - - IF (vwave_up >= 0.) THEN - hflux_fc(i) = outletwth(i) * hflux_up - mflux_fc(i) = outletwth(i) * mflux_up - ELSEIF (vwave_dn <= 0.) THEN - hflux_fc(i) = outletwth(i) * hflux_dn - mflux_fc(i) = outletwth(i) * mflux_dn - ELSE - hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & - + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) - mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & - + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) - ENDIF - - sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 - - ELSE - hflux_fc(i) = 0 - mflux_fc(i) = 0 - ENDIF - - ELSEIF (riverdown(i) == -1) THEN ! inland depression - hflux_fc(i) = 0 - mflux_fc(i) = 0 - ENDIF - - IF ((lake_id(i) < 0) .and. (hflux_fc(i) < 0)) THEN - dt_this = dt_all(irivsys(i)) - hflux_fc(i) = & - max(hflux_fc(i), (height_up-height_dn) / dt_this * sum(hillslope_basin(i)%area, & - mask = hillslope_basin(i)%hand <= wdsrf_bsn(i) + handmin(i))) - ENDIF - - ! reservoir operation. - IF (DEF_Reservoir_Method > 0) THEN - IF (lake_type(i) == 2) THEN - IF (year >= dam_build_year(bsn2resv(i))) THEN - hflux_fc(i) = 0. - mflux_fc(i) = 0. - zgrad_dn(i) = 0. - ENDIF - ENDIF - ENDIF - - sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) - sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) - - ENDDO - - IF (numbasin > 0) THEN - hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn - ENDIF - - CALL push_to_downstream (hflux_fc, sum_hflux_riv, bsnfilter) - CALL push_to_downstream (mflux_fc, sum_mflux_riv, bsnfilter) - CALL push_to_downstream (zgrad_dn, sum_zgrad_riv, bsnfilter) - - IF (numbasin > 0) THEN - hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn - ENDIF - - ! reservoir operation. - IF (DEF_Reservoir_Method > 0) THEN - - DO i = 1, numbasin - - hflux_resv(i) = 0. - mflux_resv(i) = 0. - - IF (bsnfilter(i)) THEN - IF ((lake_type(i) == 2) .and. (riverdown(i) /= -1)) THEN - IF (year >= dam_build_year(bsn2resv(i))) THEN - - irsv = bsn2resv(i) - qresv_in(irsv) = - sum_hflux_riv(i) - volresv (irsv) = lakeinfo(i)%volume( wdsrf_bsn(i) ) - - IF (volresv(irsv) > 1.e-4 * volresv_total(irsv)) THEN - CALL reservoir_operation (DEF_Reservoir_Method, & - irsv, qresv_in(irsv), volresv(irsv), qresv_out(irsv)) - ELSE - qresv_out (irsv) = 0. - ENDIF - - hflux_fc(i) = qresv_out(irsv) - mflux_fc(i) = qresv_out(irsv) * sqrt(2*grav*wdsrf_bsn(i)) - - sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) - sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) - - hflux_resv(i) = - hflux_fc(i) - mflux_resv(i) = - mflux_fc(i) - - ENDIF - ENDIF - ENDIF - ENDDO - - CALL push_to_downstream (hflux_resv, sum_hflux_riv, bsnfilter) - CALL push_to_downstream (mflux_resv, sum_mflux_riv, bsnfilter) - - ENDIF - - DO i = 1, numbasin - - IF (.not. bsnfilter(i)) CYCLE - - dt_this = dt_all(irivsys(i)) - - ! constraint 1: CFL condition (only for rivers) - IF ((lake_id(i) == 0) .and. (riverdown(i) /= -1)) THEN - IF ((veloc_riv(i) /= 0.) .or. (wdsrf_bsn(i) > 0.)) THEN - dt_this = min(dt_this, riverlen(i)/(abs(veloc_riv(i))+sqrt(grav*wdsrf_bsn(i)))*0.8) - ENDIF - ENDIF - - ! constraint 2: Avoid negative values of water - IF (sum_hflux_riv(i) > 0) THEN - IF (lake_id(i) <= 0) THEN - ! for river or lake catchment - totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand) & - * hillslope_basin(i)%area, & - mask = wdsrf_bsn(i) + handmin(i) >= hillslope_basin(i)%hand) - ELSEIF (lake_id(i) > 0) THEN - ! for lake - totalvolume = lakeinfo(i)%volume(wdsrf_bsn(i)) - ENDIF - - dt_this = min(dt_this, totalvolume / sum_hflux_riv(i)) - - ENDIF - - ! constraint 3: Avoid change of flow direction (only for rivers) - IF (lake_id(i) == 0) THEN - IF ((abs(veloc_riv(i)) > 0.1) & - .and. (veloc_riv(i) * (sum_mflux_riv(i)-sum_zgrad_riv(i)) > 0)) THEN - dt_this = min(dt_this, & - abs(momen_riv(i) * riverarea(i) / (sum_mflux_riv(i)-sum_zgrad_riv(i)))) - ENDIF - ENDIF - - dt_all(irivsys(i)) = min(dt_this, dt_all(irivsys(i))) - - ENDDO - -#ifdef USEMPI - IF (riversystem /= -1) THEN - CALL mpi_allreduce (MPI_IN_PLACE, dt_all, 1, MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err) - ENDIF -#endif - - DO i = 1, numbasin - - IF (.not. bsnfilter(i)) CYCLE - - IF (lake_id(i) <= 0) THEN - ! rivers or lake catchments - hs = basin_hru%substt(i) - he = basin_hru%subend(i) - allocate (hmask (hillslope_basin(i)%nhru)) - - totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand) & - * hillslope_basin(i)%area, & - mask = wdsrf_bsn(i) + handmin(i) >= hillslope_basin(i)%hand) - - totalvolume = totalvolume - sum_hflux_riv(i) * dt_all(irivsys(i)) - - IF (totalvolume < VOLUMEMIN) THEN - DO j = 1, hillslope_basin(i)%nhru - IF (hillslope_basin(i)%hand(j) <= wdsrf_bsn(i) + handmin(i)) THEN - wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) & - - (wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand(j)) - ENDIF - ENDDO - wdsrf_bsn(i) = 0 - ELSE - - dvol = sum_hflux_riv(i) * dt_all(irivsys(i)) - IF (dvol > VOLUMEMIN) THEN - DO WHILE (dvol > VOLUMEMIN) - hmask = hillslope_basin(i)%hand < wdsrf_bsn(i) + handmin(i) - nextl = maxval(hillslope_basin(i)%hand, mask = hmask) - nexta = sum (hillslope_basin(i)%area, mask = hmask) - nextv = nexta * (wdsrf_bsn(i)+handmin(i)-nextl) - IF (nextv > dvol) THEN - ddep = dvol/nexta - dvol = 0. - ELSE - ddep = wdsrf_bsn(i)+handmin(i) - nextl - dvol = dvol - nextv - ENDIF - - wdsrf_bsn(i) = wdsrf_bsn(i) - ddep - - DO j = 1, hillslope_basin(i)%nhru - IF (hmask(j)) THEN - wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) - ddep - ENDIF - ENDDO - ENDDO - ELSEIF (dvol < -VOLUMEMIN) THEN - hmask = .true. - nexta = 0. - DO WHILE (dvol < -VOLUMEMIN) - IF (any(hmask)) THEN - j = minloc(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he), 1, mask = hmask) - nexta = nexta + hillslope_basin(i)%area(j) - hmask(j) = .false. - ENDIF - IF (any(hmask)) THEN - nextl = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he), mask = hmask) - nextv = nexta*(nextl-(wdsrf_bsn(i)+handmin(i))) - IF ((-dvol) > nextv) THEN - ddep = nextl - (wdsrf_bsn(i)+handmin(i)) - dvol = dvol + nextv - ELSE - ddep = (-dvol)/nexta - dvol = 0. - ENDIF - ELSE - ddep = (-dvol)/nexta - dvol = 0. - ENDIF - - wdsrf_bsn(i) = wdsrf_bsn(i) + ddep - - DO j = 1, hillslope_basin(i)%nhru - IF (.not. hmask(j)) THEN - wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) + ddep - ENDIF - ENDDO - ENDDO - ENDIF - - ENDIF - deallocate(hmask) - - ELSE - totalvolume = lakeinfo(i)%volume(wdsrf_bsn(i)) - totalvolume = totalvolume - sum_hflux_riv(i) * dt_all(irivsys(i)) - wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume) - ENDIF - - IF ((lake_id(i) /= 0) .or. (wdsrf_bsn(i) < RIVERMIN)) THEN - momen_riv(i) = 0 - veloc_riv(i) = 0 - ELSE - friction = grav * nmanning_riv**2 / wdsrf_bsn(i)**(7.0/3.0) * abs(momen_riv(i)) - momen_riv(i) = (momen_riv(i) & - - (sum_mflux_riv(i) - sum_zgrad_riv(i)) / riverarea(i) * dt_all(irivsys(i))) & - / (1 + friction * dt_all(irivsys(i))) - veloc_riv(i) = momen_riv(i) / wdsrf_bsn(i) - ENDIF - - ! inland depression river - IF ((lake_id(i) == 0) .and. (riverdown(i) == -1)) THEN - momen_riv(i) = min(0., momen_riv(i)) - veloc_riv(i) = min(0., veloc_riv(i)) - ENDIF - - veloc_riv(i) = min(veloc_riv(i), 20.) - veloc_riv(i) = max(veloc_riv(i), -20.) - - ENDDO - - DO i = 1, numbasin - IF (bsnfilter(i)) THEN - - wdsrf_bsn_ta (i) = wdsrf_bsn_ta (i) + wdsrf_bsn(i) * dt_all(irivsys(i)) - momen_riv_ta (i) = momen_riv_ta (i) + momen_riv(i) * dt_all(irivsys(i)) - discharge_ta (i) = discharge_ta (i) + hflux_fc (i) * dt_all(irivsys(i)) - - IF (lake_id(i) > 0) THEN ! for lakes - hs = basin_hru%substt(i) - he = basin_hru%subend(i) - DO j = hs, he - wdsrf_bsnhru(j) = & - max(wdsrf_bsn(i) - (lakeinfo(i)%depth(1) - lakeinfo(i)%depth0(j-hs+1)), 0.) - wdsrf_bsnhru_ta(j) = wdsrf_bsnhru_ta(j) + wdsrf_bsnhru(j) * dt_all(irivsys(i)) - ENDDO - ENDIF - - IF (DEF_Reservoir_Method > 0) THEN - IF (lake_type(i) == 2) THEN - IF (year >= dam_build_year(bsn2resv(i))) THEN - irsv = bsn2resv(i) - volresv_ta (irsv) = volresv_ta (irsv) + volresv (irsv) * dt_all(irivsys(i)) - qresv_in_ta (irsv) = qresv_in_ta (irsv) + qresv_in (irsv) * dt_all(irivsys(i)) - qresv_out_ta(irsv) = qresv_out_ta(irsv) + qresv_out(irsv) * dt_all(irivsys(i)) - ENDIF - ENDIF - ENDIF - - ENDIF - ENDDO - - dt_res = dt_res - dt_all - - ENDDO - - IF (numbasin > 0) wdsrf_bsn_prev(:) = wdsrf_bsn(:) - -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, ntimestep_riverlake, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err) -#endif - - IF (allocated(wdsrf_bsn_ds )) deallocate(wdsrf_bsn_ds ) - IF (allocated(veloc_riv_ds )) deallocate(veloc_riv_ds ) - IF (allocated(momen_riv_ds )) deallocate(momen_riv_ds ) - IF (allocated(hflux_fc )) deallocate(hflux_fc ) - IF (allocated(mflux_fc )) deallocate(mflux_fc ) - IF (allocated(zgrad_dn )) deallocate(zgrad_dn ) - IF (allocated(hflux_resv )) deallocate(hflux_resv ) - IF (allocated(mflux_resv )) deallocate(mflux_resv ) - IF (allocated(sum_hflux_riv)) deallocate(sum_hflux_riv) - IF (allocated(sum_mflux_riv)) deallocate(sum_mflux_riv) - IF (allocated(sum_zgrad_riv)) deallocate(sum_zgrad_riv) - IF (allocated(bsnfilter )) deallocate(bsnfilter ) - - ENDIF - - END SUBROUTINE river_lake_flow - -END MODULE MOD_Catch_RiverLakeFlow -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 deleted file mode 100644 index 7ed4ee95a7..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 +++ /dev/null @@ -1,1145 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_RiverLakeNetwork -!-------------------------------------------------------------------------------- -! DESCRIPTION: -! -! River networks: data and communication subroutines. -! -! Created by Shupeng Zhang, May 2023 -!-------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global, only: spval - USE MOD_Pixelset - USE MOD_Catch_BasinNetwork - USE MOD_Catch_HillslopeNetwork - USE MOD_Catch_Vars_TimeVariables - IMPLICIT NONE - - ! -- river parameters -- - real(r8), allocatable :: riverlen (:) - real(r8), allocatable :: riverelv (:) - real(r8), allocatable :: riverwth (:) - real(r8), allocatable :: riverarea (:) - real(r8), allocatable :: riverdpth (:) - - real(r8), allocatable :: basinelv (:) - real(r8), allocatable :: bedelv (:) - real(r8), allocatable :: handmin (:) - - real(r8), allocatable :: wtsrfelv (:) - - ! index of downstream river - ! > 0 : other catchment; 0 : river mouth; -1 : inland depression - integer, allocatable :: riverdown (:) - integer, allocatable :: ilocdown (:) - logical, allocatable :: to_lake (:) - - real(r8), allocatable :: riverlen_ds (:) - real(r8), allocatable :: wtsrfelv_ds (:) - real(r8), allocatable :: riverwth_ds (:) - real(r8), allocatable :: bedelv_ds (:) - - real(r8), allocatable :: outletwth (:) - - integer :: riversystem - - integer :: numrivsys - integer, allocatable :: irivsys (:) - -#ifdef USEMPI - integer :: p_comm_rivsys - - integer :: numbsnlink - integer, allocatable :: linkbindex (:) - - integer :: nlink_me - integer, allocatable :: linkpush (:) - integer, allocatable :: linkpull (:) -#endif - - ! -- lake data type -- - type :: lake_info_type - integer :: nsub - real(r8), allocatable :: area0 (:) ! area data in HRU order - real(r8), allocatable :: area (:) ! area data in the order from deepest to shallowest HRU - real(r8), allocatable :: depth0 (:) ! depth data in HRU order - real(r8), allocatable :: depth (:) ! depth data in the order from deepest to shallowest HRU - ! a curve describing the relationship between depth of water from lake bottom and total water volume - ! the i-th value corresponds to the volume when water depth is at i-th depth - real(r8), allocatable :: dep_vol_curve (:) - CONTAINS - procedure, PUBLIC :: surface => retrieve_lake_surface_from_volume - procedure, PUBLIC :: volume => retrieve_lake_volume_from_surface - final :: lake_info_free_mem - END type lake_info_type - - ! -- lake information -- - type(lake_info_type), allocatable :: lakeinfo (:) - - ! -- information of HRU in basin -- - type(hillslope_network_type), pointer :: hillslope_basin (:) - - - ! ----- subroutines and functions ----- - PUBLIC :: river_lake_network_init - PUBLIC :: pull_from_downstream - PUBLIC :: push_to_downstream - PUBLIC :: calc_riverdepth_from_runoff - PUBLIC :: retrieve_lake_surface_from_volume - PUBLIC :: river_lake_network_final - -CONTAINS - - ! ---------- - SUBROUTINE river_lake_network_init (patcharea) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_Mesh - USE MOD_Pixel - USE MOD_LandElm - USE MOD_LandHRU - USE MOD_LandPatch - USE MOD_ElementNeighbour - USE MOD_DataType - USE MOD_Utils - USE MOD_UserDefFun - USE MOD_Vars_TimeInvariants, only: lakedepth - IMPLICIT NONE - - real(r8), intent(in) :: patcharea (:) - - ! Local Variables - character(len=256) :: river_file, rivdpt_file - logical :: use_calc_rivdpt - - integer :: totalnumbasin, ibasin, jbasin, inb, iloc, ielm, i, j, ilink - integer :: irank, mesg(2), isrc, idest, nrecv - -#ifdef USEMPI - integer :: nblink_all - integer, allocatable :: linkbindex_all (:) - integer, allocatable :: linkrivmth_all (:) -#endif - - logical , allocatable :: is_link (:) - logical , allocatable :: link_on_me (:) - - integer :: nnode - integer, allocatable :: route(:) - - integer , allocatable :: icache (:) - real(r8), allocatable :: rcache (:) - logical , allocatable :: lcache (:) - - integer, allocatable :: bindex(:), addrbasin(:), addrdown(:) - integer, allocatable :: basin_sorted(:), basin_order(:), order (:) - - logical, allocatable :: bsnfilter(:) - - ! for lakes - integer :: ps, pe, nsublake, hs, he, ihru - integer, allocatable :: all_lake_id (:), lake_id_elm (:) - integer , allocatable :: lakedown_id_elm(:), lakedown_id_bsn (:) - real(r8), allocatable :: lakedepth_hru (:), lakedepth_bsnhru(:) - real(r8), allocatable :: lakeoutlet_elm (:), lakeoutlet_bsn (:) - real(r8), allocatable :: unitarea_hru (:), unitarea_bsnhru (:) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - use_calc_rivdpt = DEF_USE_EstimatedRiverDepth - river_file = DEF_CatchmentMesh_data - - ! step 1: read in parameters from file. - IF (p_is_root) THEN - - CALL ncio_read_serial (river_file, 'lake_id', all_lake_id) - - CALL ncio_read_serial (river_file, 'basin_downstream', riverdown) - CALL ncio_read_serial (river_file, 'river_length' , riverlen ) - CALL ncio_read_serial (river_file, 'river_elevation' , riverelv ) - CALL ncio_read_serial (river_file, 'basin_elevation' , basinelv ) - - IF (.not. use_calc_rivdpt) THEN - CALL ncio_read_serial (river_file, 'river_depth' , riverdpth) - ENDIF - - riverlen = riverlen * 1.e3 ! km to m - - totalnumbasin = size(riverdown) - allocate (to_lake (totalnumbasin)) - to_lake = .false. - DO i = 1, totalnumbasin - IF (riverdown(i) > 0) THEN - to_lake(i) = all_lake_id(riverdown(i)) > 0 - ENDIF - ENDDO - - ENDIF - - ! step 2: Estimate river depth by using runoff data. - IF (use_calc_rivdpt) THEN - CALL calc_riverdepth_from_runoff (patcharea) - ENDIF - -#ifdef USEMPI - IF (p_is_root) THEN - - DO irank = 0, p_np_compute-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - - allocate (bindex (nrecv)) - allocate (icache (nrecv)) - allocate (rcache (nrecv)) - allocate (lcache (nrecv)) - - CALL mpi_recv (bindex, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - idest = isrc - - icache = riverdown(bindex) - CALL mpi_send (icache, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - lcache = to_lake(bindex) - CALL mpi_send (lcache, nrecv, MPI_LOGICAL, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = riverlen(bindex) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = riverelv(bindex) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = riverdpth(bindex) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - rcache = basinelv(bindex) - CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (bindex) - deallocate (icache) - deallocate (rcache) - deallocate (lcache) - - ENDIF - ENDDO - - deallocate (all_lake_id) - - ENDIF - - IF (p_is_compute) THEN - - mesg(1:2) = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (numbasin > 0) THEN - CALL mpi_send (basinindex, numbasin, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (riverdown (numbasin)) - CALL mpi_recv (riverdown, numbasin, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (to_lake (numbasin)) - CALL mpi_recv (to_lake, numbasin, MPI_LOGICAL, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (riverlen (numbasin)) - CALL mpi_recv (riverlen, numbasin, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (riverelv (numbasin)) - CALL mpi_recv (riverelv, numbasin, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (riverdpth (numbasin)) - CALL mpi_recv (riverdpth, numbasin, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (basinelv (numbasin)) - CALL mpi_recv (basinelv, numbasin, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - IF (numbasin > 0) THEN - - riverdown = riverdown(basinindex) - to_lake = to_lake (basinindex) - riverlen = riverlen (basinindex) - riverelv = riverelv (basinindex) - riverdpth = riverdpth(basinindex) - basinelv = basinelv (basinindex) - - ENDIF -#endif - -#ifdef USEMPI - ! get address of basins - IF (p_is_root) THEN - - allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1 - - DO irank = 0, p_np_compute-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - allocate (bindex (nrecv)) - - CALL mpi_recv (bindex, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - addrbasin(bindex) = isrc - - deallocate(bindex) - ENDIF - - ENDDO - - ELSEIF (p_is_compute) THEN - - mesg(1:2) = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (numbasin > 0) THEN - CALL mpi_send (basinindex, numbasin, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - - ENDIF - - - IF (p_is_root) THEN - - allocate (addrdown (totalnumbasin)) - allocate (is_link (totalnumbasin)); is_link = .false. - - DO ibasin = 1, totalnumbasin - IF (riverdown(ibasin) >= 1) THEN - addrdown(ibasin) = addrbasin(riverdown(ibasin)) - IF (addrdown(ibasin) /= addrbasin(ibasin)) THEN - is_link(riverdown(ibasin)) = .true. - ENDIF - ELSE - addrdown(ibasin) = addrbasin(ibasin) - ENDIF - ENDDO - - nblink_all = count(is_link) - - IF (nblink_all > 0) THEN - allocate (linkbindex_all (nblink_all)) - allocate (linkrivmth_all (nblink_all)) - linkbindex_all = pack((/(ibasin, ibasin = 1, totalnumbasin)/), mask = is_link) - linkrivmth_all = pack(rivermouth, mask = is_link) - ENDIF - - deallocate (addrdown) - deallocate (is_link ) - - write(*,'(/,A,I5,A,/)') 'There are ', nblink_all, ' links between processors.' - - ENDIF - - CALL mpi_bcast (nblink_all, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (nblink_all > 0) THEN - IF (.not. allocated(linkbindex_all)) allocate (linkbindex_all (nblink_all)) - IF (.not. allocated(linkrivmth_all)) allocate (linkrivmth_all (nblink_all)) - CALL mpi_bcast (linkbindex_all, nblink_all, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast (linkrivmth_all, nblink_all, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - ENDIF -#endif - - IF (p_is_compute) THEN - - IF (numbasin > 0) THEN - allocate (basin_sorted (numbasin)) - allocate (basin_order (numbasin)) - basin_sorted = basinindex - basin_order = (/(ibasin, ibasin = 1, numbasin)/) - - CALL quicksort (numbasin, basin_sorted, basin_order) - ENDIF - - riversystem = -1 - -#ifdef USEMPI - IF (nblink_all > 0) THEN - DO ibasin = 1, numbasin - - iloc = find_in_sorted_list1 (riverdown(ibasin), nblink_all, linkbindex_all) - IF (iloc <= 0) THEN - iloc = find_in_sorted_list1 (basinindex(ibasin), nblink_all, linkbindex_all) - ENDIF - - IF (iloc > 0) THEN - IF (riversystem == -1) THEN - riversystem = linkrivmth_all(iloc) - ELSEIF (riversystem /= linkrivmth_all(iloc)) THEN - write(*,*) 'Warning: river system allocation error!' - ENDIF - ENDIF - ENDDO - ENDIF - - IF (riversystem /= -1) THEN - numbsnlink = count(linkrivmth_all == riversystem) - allocate (linkbindex (numbsnlink)) - linkbindex = pack(linkbindex_all, linkrivmth_all == riversystem) - - allocate (link_on_me (numbsnlink)); link_on_me = .false. - - DO ibasin = 1, numbsnlink - iloc = find_in_sorted_list1 (linkbindex(ibasin), numbasin, basin_sorted) - IF (iloc > 0) THEN - link_on_me(ibasin) = .true. - ENDIF - ENDDO - - nlink_me = count(link_on_me) - - IF (nlink_me > 0) THEN - allocate (linkpush (nlink_me)) - allocate (linkpull (nlink_me)) - ilink = 0 - DO ibasin = 1, numbsnlink - IF (link_on_me(ibasin)) THEN - ilink = ilink + 1 - iloc = find_in_sorted_list1 (linkbindex(ibasin), numbasin, basin_sorted) - linkpush(ilink) = basin_order(iloc) - linkpull(ilink) = ibasin - ENDIF - ENDDO - ENDIF - - deallocate (link_on_me) - ENDIF - - IF (riversystem /= -1) THEN - CALL mpi_comm_split (p_comm_compute, riversystem, p_iam_compute, p_comm_rivsys, p_err) - ELSE - CALL mpi_comm_split (p_comm_compute, MPI_UNDEFINED, p_iam_compute, p_comm_rivsys, p_err) - ENDIF -#endif - - - IF (numbasin > 0) THEN - - allocate (ilocdown (numbasin)); ilocdown(:) = 0 - - DO ibasin = 1, numbasin - IF (riverdown(ibasin) > 0) THEN - iloc = find_in_sorted_list1 (riverdown(ibasin), numbasin, basin_sorted) - IF (iloc > 0) THEN - ilocdown(ibasin) = basin_order(iloc) -#ifdef USEMPI - ELSE - iloc = find_in_sorted_list1 (riverdown(ibasin), numbsnlink, linkbindex) - ilocdown(ibasin) = - iloc -#endif - ENDIF - ENDIF - ENDDO - ENDIF - - - IF (numbasin > 0) allocate (irivsys (numbasin)) - IF (numbasin > 0) allocate (route (numbasin)) - - IF (riversystem == -1) THEN - irivsys(:) = -1 - numrivsys = 0 - DO ibasin = 1, numbasin - IF (irivsys(ibasin) == -1) THEN - - jbasin = ibasin - nnode = 1 - route(nnode) = jbasin - DO WHILE ((riverdown(jbasin) > 0) .and. (irivsys(jbasin) == -1)) - nnode = nnode + 1 - route(nnode) = jbasin - jbasin = ilocdown(jbasin) - ENDDO - - IF (irivsys(jbasin) == -1) THEN - numrivsys = numrivsys + 1 - irivsys(jbasin) = numrivsys - ENDIF - - irivsys(route(1:nnode)) = irivsys(jbasin) - - ENDIF - ENDDO - ELSE - numrivsys = 1 - irivsys(:) = 1 - ENDIF - - IF (numbasin > 0) deallocate (route) - - ENDIF - -#ifdef USEMPI - IF (allocated (linkbindex_all)) deallocate (linkbindex_all) - IF (allocated (linkrivmth_all)) deallocate (linkrivmth_all) -#endif - - - CALL hillslope_network_init (numbasin, basinindex, hillslope_basin) - - IF (p_is_compute) THEN - - IF (numelm > 0) allocate (lake_id_elm (numelm)) - IF (numhru > 0) allocate (lakedepth_hru (numhru)) - IF (numbsnhru > 0) allocate (lakedepth_bsnhru(numbsnhru)) - IF (numelm > 0) allocate (lakedown_id_elm (numelm)) - IF (numbasin > 0) allocate (lakedown_id_bsn (numbasin)) - IF (numelm > 0) allocate (lakeoutlet_elm (numelm)) - IF (numbasin > 0) allocate (lakeoutlet_bsn (numbasin)) - IF (numhru > 0) allocate (unitarea_hru (numhru)) - IF (numbsnhru > 0) allocate (unitarea_bsnhru (numbsnhru)) - - DO ibasin = 1, numbasin - - lakedown_id_bsn(ibasin) = 0 - - IF ((lake_id(ibasin) /= 0) .and. (to_lake(ibasin))) THEN - ! lake to lake .or. lake catchment to lake - lakedown_id_bsn(ibasin) = riverdown(ibasin) - ENDIF - IF ((lake_id(ibasin) > 0) .and. (riverdown(ibasin) == 0)) THEN - ! lake to ocean - lakedown_id_bsn(ibasin) = -9 ! -9 is ocean - ENDIF - ENDDO - - ENDIF - - CALL compute_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) - CALL compute_push_data (push_bsn2elm, lakedown_id_bsn, lakedown_id_elm, -9999) - - IF (p_is_compute) THEN - - unitarea_hru = 0. - lakedepth_hru = 0. - lakeoutlet_elm = 0. - - DO ielm = 1, numelm - hs = elm_hru%substt(ielm) - he = elm_hru%subend(ielm) - DO ihru = hs, he - ps = hru_patch%substt(ihru) - pe = hru_patch%subend(ihru) - - unitarea_hru(ihru) = sum(patcharea(ps:pe)) - - IF (lake_id_elm(ielm) > 0) THEN - lakedepth_hru(ihru) = maxval(lakedepth(ps:pe)) - ENDIF - ENDDO - - IF (lakedown_id_elm(ielm) /= 0) THEN - inb = findloc_ud(elementneighbour(ielm)%glbindex == lakedown_id_elm(ielm)) - IF (inb > 0) lakeoutlet_elm(ielm) = elementneighbour(ielm)%lenbdr(inb) - ENDIF - ENDDO - ENDIF - - CALL compute_push_data (push_elm2bsn, lakeoutlet_elm, lakeoutlet_bsn, spval) - - CALL compute_push_data (push_elmhru2bsnhru, unitarea_hru, unitarea_bsnhru, spval) - CALL compute_push_data (push_elmhru2bsnhru, lakedepth_hru, lakedepth_bsnhru, spval) - - IF (allocated (lake_id_elm )) deallocate (lake_id_elm ) - IF (allocated (lakedepth_hru )) deallocate (lakedepth_hru ) - IF (allocated (lakedown_id_elm)) deallocate (lakedown_id_elm) - IF (allocated (lakedown_id_bsn)) deallocate (lakedown_id_bsn) - IF (allocated (lakeoutlet_elm )) deallocate (lakeoutlet_elm ) - IF (allocated (unitarea_hru )) deallocate (unitarea_hru ) - - IF (p_is_compute) THEN - - IF (numbasin > 0) THEN - - allocate (lakeinfo (numbasin)) - allocate (riverarea (numbasin)) - allocate (riverwth (numbasin)) - allocate (bedelv (numbasin)) - allocate (handmin (numbasin)) - allocate (wtsrfelv (numbasin)) - allocate (riverlen_ds (numbasin)) - allocate (wtsrfelv_ds (numbasin)) - allocate (riverwth_ds (numbasin)) - allocate (bedelv_ds (numbasin)) - allocate (outletwth (numbasin)) - - DO ibasin = 1, numbasin - - hs = basin_hru%substt(ibasin) - he = basin_hru%subend(ibasin) - - IF (lake_id(ibasin) == 0) THEN - - hillslope_basin(ibasin)%area = unitarea_bsnhru(hs:he) - - riverarea(ibasin) = hillslope_basin(ibasin)%area(1) - riverwth (ibasin) = riverarea(ibasin) / riverlen(ibasin) - - ! modify height above nearest drainage data to consider river depth - IF (hillslope_basin(ibasin)%nhru > 1) THEN - hillslope_basin(ibasin)%hand(2:) = & - hillslope_basin(ibasin)%hand(2:) + riverdpth(ibasin) - ENDIF - - wtsrfelv(ibasin) = riverelv(ibasin) - bedelv (ibasin) = riverelv(ibasin) - riverdpth(ibasin) - - handmin(ibasin) = minval(hillslope_basin(ibasin)%hand) - - ELSEIF (lake_id(ibasin) > 0) THEN - - wtsrfelv(ibasin) = basinelv(ibasin) - - bedelv(ibasin) = basinelv(ibasin) - maxval(lakedepth_bsnhru(hs:he)) - - nsublake = he - hs + 1 - lakeinfo(ibasin)%nsub = nsublake - - allocate (lakeinfo(ibasin)%area0 (nsublake)) - allocate (lakeinfo(ibasin)%area (nsublake)) - allocate (lakeinfo(ibasin)%depth0 (nsublake)) - allocate (lakeinfo(ibasin)%depth (nsublake)) - - lakeinfo(ibasin)%area = unitarea_bsnhru (hs:he) - lakeinfo(ibasin)%depth = lakedepth_bsnhru(hs:he) - - ! area data in HRU order - lakeinfo(ibasin)%area0 = lakeinfo(ibasin)%area - - ! depth data in HRU order - lakeinfo(ibasin)%depth0 = lakeinfo(ibasin)%depth - - allocate (order (1:nsublake)) - order = (/(i, i = 1, nsublake)/) - - CALL quicksort (nsublake, lakeinfo(ibasin)%depth, order) - - ! area data in depth order - lakeinfo(ibasin)%area = lakeinfo(ibasin)%area(order) - - ! adjust to be from deepest to shallowest - lakeinfo(ibasin)%depth = lakeinfo(ibasin)%depth(nsublake:1:-1) - lakeinfo(ibasin)%area = lakeinfo(ibasin)%area (nsublake:1:-1) - - allocate (lakeinfo(ibasin)%dep_vol_curve (nsublake)) - - lakeinfo(ibasin)%dep_vol_curve(1) = 0 - DO i = 2, nsublake - lakeinfo(ibasin)%dep_vol_curve(i) = & - lakeinfo(ibasin)%dep_vol_curve(i-1) & - + sum(lakeinfo(ibasin)%area(1:i-1)) & - * (lakeinfo(ibasin)%depth(i-1)-lakeinfo(ibasin)%depth(i)) - ENDDO - - riverlen(ibasin) = 0. - - deallocate (order) - - ELSEIF (lake_id(ibasin) < 0) THEN - - hillslope_basin(ibasin)%area = unitarea_bsnhru(hs:he) - handmin(ibasin) = minval(hillslope_basin(ibasin)%hand) - - ENDIF - - ENDDO - ENDIF - - IF (numbasin > 0) THEN - allocate(bsnfilter (numbasin)) - bsnfilter(:) = .true. - ENDIF - - CALL pull_from_downstream (riverlen, riverlen_ds, bsnfilter) - CALL pull_from_downstream (wtsrfelv, wtsrfelv_ds, bsnfilter) - CALL pull_from_downstream (riverwth, riverwth_ds, bsnfilter) - CALL pull_from_downstream (bedelv , bedelv_ds , bsnfilter) - - IF (allocated(bsnfilter)) deallocate(bsnfilter) - - DO ibasin = 1, numbasin - IF (lake_id(ibasin) < 0) THEN - bedelv(ibasin) = wtsrfelv_ds(ibasin) + minval(hillslope_basin(ibasin)%hand) - ENDIF - ENDDO - - DO ibasin = 1, numbasin - IF (lake_id(ibasin) == 0) THEN - IF ((to_lake(ibasin)) .or. (riverdown(ibasin) <= 0)) THEN - ! river to lake, ocean, inland depression or out of region - outletwth(ibasin) = riverwth(ibasin) - ELSE - ! river to river - outletwth(ibasin) = (riverwth(ibasin) + riverwth_ds(ibasin)) * 0.5 - ENDIF - ELSEIF (lake_id(ibasin) /= 0) THEN - IF ((.not. to_lake(ibasin)) .and. (riverdown(ibasin) /= 0)) THEN - IF (riverdown(ibasin) > 0) THEN - ! lake to river - outletwth(ibasin) = riverwth_ds(ibasin) - ELSEIF (riverdown(ibasin) == -1) THEN - ! lake is inland depression - outletwth(ibasin) = 0 - ENDIF - ELSEIF (to_lake(ibasin)) THEN - ! lake to lake .or. lake catchment to lake - outletwth(ibasin) = lakeoutlet_bsn(ibasin) - ELSEIF (riverdown(ibasin) == 0) THEN - ! lake to ocean - outletwth(ibasin) = lakeoutlet_bsn(ibasin) - ENDIF - ENDIF - ENDDO - - ENDIF - - IF (allocated (lakedepth_bsnhru)) deallocate (lakedepth_bsnhru) - IF (allocated (lakeoutlet_bsn )) deallocate (lakeoutlet_bsn ) - IF (allocated (unitarea_bsnhru )) deallocate (unitarea_bsnhru ) - - IF (allocated(basin_sorted )) deallocate(basin_sorted ) - IF (allocated(basin_order )) deallocate(basin_order ) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) - IF (p_is_root) write(*,'(A)') 'Building river network information done.' - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE river_lake_network_init - - ! ----- pull data from downstream basin ----- - SUBROUTINE pull_from_downstream (datain, dataout, bsnfilter) - - USE MOD_SPMD_Task - - IMPLICIT NONE - - real(r8), intent(in) :: datain (:) - real(r8), intent(inout) :: dataout (:) - logical, intent(in) :: bsnfilter(:) - - ! local variables - integer :: i, ibasin - real(r8), allocatable :: datalink(:) - - IF (p_is_compute) THEN - -#ifdef USEMPI - IF (riversystem /= -1) THEN - allocate (datalink (numbsnlink)); datalink(:) = 0. - DO i = 1, nlink_me - datalink(linkpull(i)) = datain(linkpush(i)) - ENDDO - CALL mpi_allreduce (MPI_IN_PLACE, datalink, numbsnlink, MPI_REAL8, MPI_SUM, p_comm_rivsys, p_err) - ENDIF -#endif - - DO ibasin = 1, numbasin - IF (bsnfilter(ibasin)) THEN - IF (riverdown(ibasin) > 0) THEN - IF (ilocdown(ibasin) > 0) THEN - dataout(ibasin) = datain(ilocdown(ibasin)) -#ifdef USEMPI - ELSEIF (ilocdown(ibasin) < 0) THEN - dataout(ibasin) = datalink(-ilocdown(ibasin)) -#endif - ENDIF - ENDIF - ENDIF - ENDDO - -#ifdef USEMPI - IF (allocated(datalink)) deallocate (datalink) -#endif - ENDIF - - END SUBROUTINE pull_from_downstream - - ! ----- push data to downstream basin ----- - SUBROUTINE push_to_downstream (datain, dataout, bsnfilter) - - USE MOD_SPMD_Task - - IMPLICIT NONE - - real(r16), intent(in) :: datain (:) - real(r16), intent(inout) :: dataout (:) - logical, intent(in) :: bsnfilter(:) - - ! local variables - integer :: i, ibasin - real(r16), allocatable :: datalink(:) - - - IF (p_is_compute) THEN - -#ifdef USEMPI - IF (numbsnlink > 0) THEN - allocate (datalink (numbsnlink)); datalink(:) = 0. - ENDIF -#endif - - DO ibasin = 1, numbasin - IF (bsnfilter(ibasin)) THEN - IF (riverdown(ibasin) > 0) THEN - IF (ilocdown(ibasin) > 0) THEN - dataout(ilocdown(ibasin)) = dataout(ilocdown(ibasin)) + datain(ibasin) -#ifdef USEMPI - ELSEIF (ilocdown(ibasin) < 0) THEN - datalink(-ilocdown(ibasin)) = datalink(-ilocdown(ibasin)) + datain(ibasin) -#endif - ENDIF - ENDIF - ENDIF - ENDDO - -#ifdef USEMPI - IF (riversystem /= -1) THEN - - CALL mpi_allreduce (MPI_IN_PLACE, datalink, numbsnlink, MPI_REAL16, MPI_SUM, p_comm_rivsys, p_err) - - DO i = 1, nlink_me - dataout(linkpush(i)) = dataout(linkpush(i)) + datalink(linkpull(i)) - ENDDO - - deallocate (datalink) - ENDIF -#endif - ENDIF - - END SUBROUTINE push_to_downstream - - ! ----- retrieve river depth from runoff ----- - SUBROUTINE calc_riverdepth_from_runoff (patcharea) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_Utils - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_Pixel - USE MOD_Block - USE MOD_Mesh - USE MOD_Grid - USE MOD_SpatialMapping - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_ElmVector - IMPLICIT NONE - - real(r8), intent(in) :: patcharea (:) - - ! Local Variables - character(len=256) :: file_rnof, file_rivdpt - type(grid_type) :: grid_rnof - type(block_data_real8_2d) :: f_rnof - type(spatial_mapping_type) :: mg2p_rnof - - real(r8), allocatable :: bsnrnof(:) , bsndis(:) - integer, allocatable :: nups_riv(:), iups_riv(:), b_up2down(:) - - integer :: i, j, ithis, ib, jb, iblkme, ps, pe - integer :: iwork, mesg(2), isrc, ndata - real(r8), allocatable :: rcache(:) - real(r8) :: myarea - - real(r8), parameter :: cH_rivdpt = 0.1 - real(r8), parameter :: pH_rivdpt = 0.5 - real(r8), parameter :: B0_rivdpt = 0.0 - real(r8), parameter :: Bmin_rivdpt = 1.0 - - - file_rnof = trim(DEF_dir_runtime) // '/runoff_clim.nc' - - CALL grid_rnof%define_from_file (file_rnof, 'lat', 'lon') - - CALL mg2p_rnof%build_arealweighted (grid_rnof, landelm) - - IF (p_is_active) THEN - CALL allocate_block_data (grid_rnof, f_rnof) - CALL ncio_read_block (file_rnof, 'ro', grid_rnof, f_rnof) - - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - DO j = 1, grid_rnof%ycnt(jb) - DO i = 1, grid_rnof%xcnt(ib) - f_rnof%blk(ib,jb)%val(i,j) = max(f_rnof%blk(ib,jb)%val(i,j), 0.) - ENDDO - ENDDO - ENDDO - ENDIF - - IF (p_is_compute) THEN - IF (numelm > 0) allocate (bsnrnof (numelm)) - ENDIF - - CALL mg2p_rnof%grid2pset (f_rnof, bsnrnof) - - IF (p_is_compute) THEN - IF (numelm > 0) THEN - bsnrnof = bsnrnof /24.0/3600.0 ! from m/day to m/s - DO i = 1, numelm - ps = elm_patch%substt(i) - pe = elm_patch%subend(i) - myarea = sum(patcharea(ps:pe)) - ! total runoff in basin, from m/s to m3/s - bsnrnof(i) = bsnrnof(i) * myarea - ENDDO - ENDIF - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) - - IF (p_is_compute) THEN - mesg = (/p_iam_glb, numelm/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numelm > 0) THEN - CALL mpi_send (bsnrnof, numelm, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDIF - - IF (p_is_root) THEN - - allocate (bsnrnof (totalnumelm)) - - DO iwork = 0, p_np_compute-1 - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate(rcache (ndata)) - - CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - bsnrnof(elm_data_address(p_itis_compute(isrc))%val) = rcache - - deallocate (rcache) - ENDIF - ENDDO - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - bsnrnof(elm_data_address(0)%val) = bsnrnof -#endif - - - IF (p_is_root) THEN - - allocate (nups_riv (totalnumelm)) - allocate (iups_riv (totalnumelm)) - allocate (b_up2down(totalnumelm)) - - allocate (bsndis (totalnumelm)) - - nups_riv(:) = 0 - DO i = 1, totalnumelm - j = riverdown(i) - IF (j > 0) THEN - nups_riv(j) = nups_riv(j) + 1 - ENDIF - ENDDO - - iups_riv(:) = 0 - ithis = 0 - DO i = 1, totalnumelm - IF (iups_riv(i) == nups_riv(i)) THEN - - ithis = ithis + 1 - b_up2down(ithis) = i - - j = riverdown(i) - DO WHILE (j > 0) - - iups_riv(j) = iups_riv(j) + 1 - - IF (iups_riv(j) == nups_riv(j)) THEN - ithis = ithis + 1 - b_up2down(ithis) = j - j = riverdown(j) - ELSE - EXIT - ENDIF - ENDDO - ENDIF - ENDDO - - bsndis(:) = 0. - DO i = 1, totalnumelm - j = b_up2down(i) - bsndis(j) = bsndis(j) + bsnrnof(j) - IF (riverdown(j) > 0) THEN - bsndis(riverdown(j)) = bsndis(riverdown(j)) + bsndis(j) - ENDIF - ENDDO - - allocate (riverdpth (totalnumelm)) - DO i = 1, totalnumelm - riverdpth(i) = max(cH_rivdpt * (bsndis(i)**pH_rivdpt) + B0_rivdpt, Bmin_rivdpt) - ENDDO - - ENDIF - - IF (allocated (bsnrnof )) deallocate(bsnrnof ) - IF (allocated (bsndis )) deallocate(bsndis ) - IF (allocated (nups_riv )) deallocate(nups_riv ) - IF (allocated (iups_riv )) deallocate(iups_riv ) - IF (allocated (b_up2down)) deallocate(b_up2down) - - END SUBROUTINE calc_riverdepth_from_runoff - - ! - FUNCTION retrieve_lake_surface_from_volume (this, volume) result(surface) - - IMPLICIT NONE - - class(lake_info_type) :: this - real(r8), intent(in) :: volume - real(r8) :: surface - - ! Local Variables - integer :: i - - IF (volume <= 0) THEN - surface = 0 - RETURN - ENDIF - - IF (this%nsub == 1) THEN - surface = volume / this%area(1) - ELSE - i = 1 - DO WHILE (i < this%nsub) - IF (volume >= this%dep_vol_curve(i+1)) THEN - i = i + 1 - ELSE - EXIT - ENDIF - ENDDO - surface = this%depth(1) - this%depth(i) + & - (volume - this%dep_vol_curve(i)) / sum(this%area(1:i)) - ENDIF - - END FUNCTION retrieve_lake_surface_from_volume - - ! - FUNCTION retrieve_lake_volume_from_surface (this, surface) result(volume) - - IMPLICIT NONE - - class(lake_info_type) :: this - real(r8), intent(in) :: surface - real(r8) :: volume - - ! Local Variables - integer :: i - - IF (surface <= 0) THEN - volume = 0 - RETURN - ENDIF - - IF (this%nsub == 1) THEN - volume = this%area(1) * surface - ELSE - i = 1 - DO WHILE (i < this%nsub) - IF (surface >= this%depth(1)-this%depth(i+1)) THEN - i = i + 1 - ELSE - EXIT - ENDIF - ENDDO - volume = this%dep_vol_curve(i) & - + (surface - (this%depth(1) - this%depth(i))) * sum(this%area(1:i)) - ENDIF - - END FUNCTION retrieve_lake_volume_from_surface - - ! ---------- - SUBROUTINE river_lake_network_final () - - IMPLICIT NONE - - ! Local Variables - integer :: ilake - - IF (allocated (riverlen )) deallocate(riverlen ) - IF (allocated (riverelv )) deallocate(riverelv ) - IF (allocated (riverwth )) deallocate(riverwth ) - IF (allocated (riverarea )) deallocate(riverarea ) - IF (allocated (riverdpth )) deallocate(riverdpth ) - IF (allocated (basinelv )) deallocate(basinelv ) - IF (allocated (bedelv )) deallocate(bedelv ) - IF (allocated (handmin )) deallocate(handmin ) - IF (allocated (wtsrfelv )) deallocate(wtsrfelv ) - IF (allocated (riverdown )) deallocate(riverdown ) - IF (allocated (ilocdown )) deallocate(ilocdown ) - IF (allocated (to_lake )) deallocate(to_lake ) - IF (allocated (riverlen_ds )) deallocate(riverlen_ds ) - IF (allocated (wtsrfelv_ds )) deallocate(wtsrfelv_ds ) - IF (allocated (riverwth_ds )) deallocate(riverwth_ds ) - IF (allocated (bedelv_ds )) deallocate(bedelv_ds ) - IF (allocated (outletwth )) deallocate(outletwth ) - IF (allocated (irivsys )) deallocate(irivsys ) -#ifdef USEMPI - IF (allocated (linkbindex )) deallocate(linkbindex ) - IF (allocated (linkpush )) deallocate(linkpush ) - IF (allocated (linkpull )) deallocate(linkpull ) -#endif - IF (allocated (lakeinfo )) deallocate(lakeinfo ) - IF (associated(hillslope_basin)) deallocate(hillslope_basin) - - END SUBROUTINE river_lake_network_final - - ! --------- - SUBROUTINE lake_info_free_mem (this) - - IMPLICIT NONE - type(lake_info_type) :: this - - IF (allocated(this%area0 )) deallocate (this%area0 ) - IF (allocated(this%area )) deallocate (this%area ) - IF (allocated(this%depth0)) deallocate (this%depth0) - IF (allocated(this%depth )) deallocate (this%depth ) - IF (allocated(this%dep_vol_curve)) deallocate (this%dep_vol_curve) - - END SUBROUTINE lake_info_free_mem - -END MODULE MOD_Catch_RiverLakeNetwork -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 deleted file mode 100644 index 7bbcf51834..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 +++ /dev/null @@ -1,823 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_SubsurfaceFlow -!------------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Ground water lateral flow. -! -! Ground water fluxes are calculated -! 1. between elements -! 2. between hydrological response units -! 3. between patches inside one HRU -! -! Created by Shupeng Zhang, May 2023 -!------------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_DataType - USE MOD_Catch_HillslopeNetwork - IMPLICIT NONE - - ! --- information of HRU on hillslope --- - type(hillslope_network_type), pointer :: hillslope_element (:) - - integer, allocatable :: lake_id_elm (:) - real(r8), allocatable :: lakedepth_elm(:) - real(r8), allocatable :: riverdpth_elm(:) - real(r8), allocatable :: wdsrf_elm (:) - - real(r8), parameter :: e_ice = 6.0 ! soil ice impedance factor - - ! anisotropy ratio of lateral/vertical hydraulic conductivity (unitless) - ! for USDA soil texture class: - ! 0: undefined - ! 1: clay; 2: silty clay; 3: sandy clay; 4: clay loam; 5: silty clay loam; 6: sandy clay loam; & - ! 7: loam; 8: silty loam; 9: sandy loam; 10: silt; 11: loamy sand; 12: sand - real(r8), parameter :: raniso(0:12) = (/ 1., & - 48., 40., 28., 24., 20., 14., 12., 10., 4., 2., 3., 2. /) - - ! -- neighbour variables -- - type(pointer_real8_1d), allocatable :: agwt_nb (:) ! ground water area (for patchtype <= 2) of neighbours [m^2] - type(pointer_real8_1d), allocatable :: theta_a_nb (:) ! saturated volume content [-] - type(pointer_real8_1d), allocatable :: zwt_nb (:) ! water table depth [m] - type(pointer_real8_1d), allocatable :: Kl_nb (:) ! lateral hydraulic conductivity [m/s] - type(pointer_real8_1d), allocatable :: wdsrf_nb (:) ! depth of surface water [m] - type(pointer_logic_1d), allocatable :: islake_nb (:) ! whether a neighbour is water body - type(pointer_real8_1d), allocatable :: lakedp_nb (:) ! lake depth of neighbour [m] - -CONTAINS - - ! ---------- - SUBROUTINE subsurface_network_init (patcharea) - - USE MOD_SPMD_Task - USE MOD_Utils - USE MOD_Mesh - USE MOD_Pixel - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_ElementNeighbour - USE MOD_ComputePushData, only: compute_push_data - USE MOD_Catch_BasinNetwork, only: push_bsn2elm - USE MOD_Catch_RiverLakeNetwork, only: lake_id, riverdpth - USE MOD_Vars_TimeInvariants, only: patchtype, lakedepth - IMPLICIT NONE - - real(r8), intent(in) :: patcharea (:) - - integer :: ielm, inb, i, ihru, ps, pe, ipatch - - real(r8), allocatable :: agwt_b(:) - real(r8), allocatable :: islake(:) - type(pointer_real8_1d), allocatable :: iswat_nb (:) - - integer, allocatable :: eindex(:) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_compute) THEN - IF (numelm > 0) THEN - allocate (eindex (numelm)) - eindex = landelm%eindex - ENDIF - ENDIF - - CALL hillslope_network_init (numelm, eindex, hillslope_element) - - IF (allocated(eindex)) deallocate (eindex) - - IF (p_is_compute) THEN - - IF (numelm > 0) allocate (lake_id_elm (numelm)) - IF (numelm > 0) allocate (riverdpth_elm(numelm)) - IF (numelm > 0) allocate (lakedepth_elm(numelm)) - IF (numelm > 0) allocate (wdsrf_elm (numelm)) - - CALL compute_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999) - CALL compute_push_data (push_bsn2elm, riverdpth, riverdpth_elm, spval) - - DO ielm = 1, numelm - IF (lake_id_elm(ielm) <= 0) THEN - DO i = 1, hillslope_element(ielm)%nhru - - hillslope_element(ielm)%agwt(i) = 0 - hillslope_element(ielm)%area(i) = 0 - - ihru = hillslope_element(ielm)%ihru(i) - ps = hru_patch%substt(ihru) - pe = hru_patch%subend(ihru) - DO ipatch = ps, pe - hillslope_element(ielm)%area(i) = hillslope_element(ielm)%area(i) + patcharea(ipatch) - IF (patchtype(ipatch) <= 2) THEN - hillslope_element(ielm)%agwt(i) = hillslope_element(ielm)%agwt(i) + patcharea(ipatch) - ENDIF - ENDDO - - ENDDO - ENDIF - ENDDO - - lakedepth_elm(:) = 0. - DO ielm = 1, numelm - IF (lake_id_elm(ielm) > 0) THEN - ps = elm_patch%substt(ielm) - pe = elm_patch%subend(ielm) - lakedepth_elm(ielm) = sum(lakedepth(ps:pe) * elm_patch%subfrc(ps:pe)) - ENDIF - ENDDO - - CALL allocate_neighbour_data (agwt_nb ) - CALL allocate_neighbour_data (theta_a_nb) - CALL allocate_neighbour_data (zwt_nb ) - CALL allocate_neighbour_data (Kl_nb ) - CALL allocate_neighbour_data (wdsrf_nb ) - CALL allocate_neighbour_data (islake_nb ) - CALL allocate_neighbour_data (lakedp_nb ) - CALL allocate_neighbour_data (iswat_nb ) - - IF (numelm > 0) THEN - allocate (agwt_b(numelm)) - allocate (islake(numelm)) - DO ielm = 1, numelm - IF (lake_id_elm(ielm) <= 0) THEN - agwt_b(ielm) = sum(hillslope_element(ielm)%agwt) - islake(ielm) = 0. - ELSE - agwt_b(ielm) = 0. - islake(ielm) = 1. - ENDIF - ENDDO - ENDIF - - CALL retrieve_neighbour_data (lakedepth_elm, lakedp_nb) - - CALL retrieve_neighbour_data (agwt_b, agwt_nb ) - CALL retrieve_neighbour_data (islake, iswat_nb) - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour - islake_nb(ielm)%val(inb) = (iswat_nb(ielm)%val(inb) > 0) - ENDIF - ENDDO - ENDDO - - IF (allocated(agwt_b )) deallocate(agwt_b ) - IF (allocated(islake )) deallocate(islake ) - IF (allocated(iswat_nb)) deallocate(iswat_nb) - - ENDIF - - END SUBROUTINE subsurface_network_init - - ! --------- - SUBROUTINE subsurface_flow (deltime) - - USE MOD_SPMD_Task - USE MOD_UserDefFun - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandHRU - USE MOD_LandPatch - USE MOD_Vars_TimeVariables - USE MOD_Vars_TimeInvariants - USE MOD_Vars_1DFluxes - USE MOD_Catch_HillslopeNetwork - USE MOD_ElementNeighbour - USE MOD_Const_Physical, only: denice, denh2o - USE MOD_Vars_Global, only: pi, nl_soil, zi_soi - USE MOD_Hydro_SoilWater, only: soilwater_aquifer_exchange - - IMPLICIT NONE - - real(r8), intent(in) :: deltime - - ! Local Variables - integer :: nhru, ielm, i, i0, j, ihru, ipatch, ps, pe, hs, he, ilev - - type(hillslope_network_type), pointer :: hrus - - real(r8), allocatable :: theta_a_h (:) - real(r8), allocatable :: zwt_h (:) - real(r8), allocatable :: Kl_h (:) ! [m/s] - real(r8), allocatable :: xsubs_h (:) ! [m/s] - real(r8), allocatable :: xsubs_fc (:) ! [m/s] - - logical :: j_is_river - real(r8) :: theta_s_h, air_h, icefrac, imped, delp - real(r8) :: sumwt, sumarea, zwt_mean - real(r8) :: zsubs_h_up, zsubs_h_dn - real(r8) :: slope, bdamp, Kl_fc, Kl_in - real(r8) :: ca, cb - real(r8) :: alp - - real(r8), allocatable :: theta_a_elm (:) - real(r8), allocatable :: zwt_elm (:) - real(r8), allocatable :: Kl_elm (:) ! [m/s] - - integer :: jnb - real(r8) :: zsubs_up, zwt_up, Kl_up, theta_a_up, area_up - real(r8) :: zsubs_dn, zwt_dn, Kl_dn, theta_a_dn, area_dn - real(r8) :: lenbdr, xsubs_nb - logical :: iam_lake, nb_is_lake, has_river - - ! for water exchange - logical :: is_dry_lake - integer :: izwt - real(r8) :: exwater - real(r8) :: sp_zi(0:nl_soil), sp_dz(1:nl_soil), zwtmm ! [mm] - real(r8) :: vl_r (1:nl_soil) -#ifdef Campbell_SOIL_MODEL - integer, parameter :: nprms = 1 -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - integer, parameter :: nprms = 5 -#endif - real(r8) :: prms (nprms,1:nl_soil) - real(r8) :: vol_ice (1:nl_soil) - real(r8) :: vol_liq (1:nl_soil) - real(r8) :: eff_porosity(1:nl_soil) - logical :: is_permeable(1:nl_soil) - real(r8) :: wresi (1:nl_soil) - real(r8) :: w_sum_before, w_sum_after, errblc - - - IF (p_is_compute) THEN - - xsubs_elm(:) = 0. ! subsurface lateral flow between element basins - xsubs_hru(:) = 0. ! subsurface lateral flow between hydrological response units - xsubs_pch(:) = 0. ! subsurface lateral flow between patches inside one HRU - - xwsub(:) = 0. ! total recharge/discharge from subsurface lateral flow - - IF (numpatch > 0) rsub(:) = 0. - - IF (numelm > 0) THEN - allocate (theta_a_elm (numelm)); theta_a_elm = 0. - allocate (zwt_elm (numelm)); zwt_elm = 0. - allocate (Kl_elm (numelm)); Kl_elm = 0. - ENDIF - - DO ielm = 1, numelm - - hrus => hillslope_element(ielm) - - nhru = hrus%nhru - - IF (lake_id_elm(ielm) > 0) CYCLE ! lake - IF (sum(hrus%agwt) <= 0) CYCLE ! no area of soil, urban or wetland - - allocate (theta_a_h (nhru)); theta_a_h = 0. - allocate (zwt_h (nhru)); zwt_h = 0. - allocate (Kl_h (nhru)); Kl_h = 0. - - DO i = 1, nhru - - IF (hrus%indx(i) == 0) CYCLE ! river - IF (hrus%agwt(i) == 0) CYCLE ! no area of soil, urban or wetland - - ps = hru_patch%substt(hrus%ihru(i)) - pe = hru_patch%subend(hrus%ihru(i)) - - theta_s_h = 0 - sumwt = 0 - DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - theta_s_h = theta_s_h + hru_patch%subfrc(ipatch) & - * sum(porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) & - - wice_soisno(1:nl_soil,ipatch)/denice) / sum(dz_soi(1:nl_soil)) - sumwt = sumwt + hru_patch%subfrc(ipatch) - ENDIF - ENDDO - IF (sumwt > 0) theta_s_h = theta_s_h / sumwt - - IF (theta_s_h > 0.) THEN - - air_h = 0. - zwt_h(i) = 0. - sumwt = 0. - DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - air_h = air_h + hru_patch%subfrc(ipatch) & - * (sum( porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) & - - wliq_soisno(1:nl_soil,ipatch)/denh2o & - - wice_soisno(1:nl_soil,ipatch)/denice ) - wa(ipatch)/1.0e3) - air_h = max(0., air_h) - - zwt_h(i) = zwt_h(i) + zwt(ipatch) * hru_patch%subfrc(ipatch) - - sumwt = sumwt + hru_patch%subfrc(ipatch) - ENDIF - ENDDO - IF (sumwt > 0) air_h = air_h / sumwt - IF (sumwt > 0) zwt_h(i) = zwt_h(i) / sumwt - - IF ((air_h <= 0.) .or. (zwt_h(i) <= 0.)) THEN - theta_a_h(i) = theta_s_h - zwt_h(i) = 0. - ELSE - theta_a_h(i) = air_h / zwt_h(i) - IF (theta_a_h(i) > theta_s_h) THEN - theta_a_h(i) = theta_s_h - zwt_h(i) = air_h / theta_a_h(i) - ENDIF - ENDIF - - Kl_h(i) = 0. - sumwt = 0. - DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - DO ilev = 1, nl_soil - icefrac = min(1., wice_soisno(ilev,ipatch)/denice/dz_soi(ilev)/porsl(ilev,ipatch)) - imped = 10.**(-e_ice*icefrac) - Kl_h(i) = Kl_h(i) + hru_patch%subfrc(ipatch) * raniso(soiltext(ipatch)) & - * hksati(ilev,ipatch)/1.0e3 * imped * dz_soi(ilev)/zi_soi(nl_soil) - ENDDO - sumwt = sumwt + hru_patch%subfrc(ipatch) - ENDIF - ENDDO - IF (sumwt > 0) Kl_h(i) = Kl_h(i) / sumwt - ELSE - ! Frozen soil. - Kl_h(i) = 0. - ENDIF - - ENDDO - - allocate (xsubs_h (nhru)) - allocate (xsubs_fc (nhru)) - - xsubs_h (:) = 0. - xsubs_fc(:) = 0. - - DO i = 1, nhru - - j = hrus%inext(i) - - IF (j <= 0) CYCLE ! downstream is out of catchment - IF (Kl_h(i) == 0.) CYCLE ! this HRU is frozen - - j_is_river = (hrus%indx(j) == 0) - - IF ((.not. j_is_river) .and. (Kl_h(j) == 0.)) CYCLE ! non-river downstream HRU is frozen - - zsubs_h_up = hrus%elva(i) - zwt_h(i) - - IF (.not. j_is_river) THEN - zsubs_h_dn = hrus%elva(j) - zwt_h(j) - ELSE - zsubs_h_dn = hrus%elva(1) - riverdpth_elm(ielm) + wdsrf_hru(hrus%ihru(1)) - ENDIF - - IF (.not. j_is_river) THEN - delp = hrus%plen(i) + hrus%plen(j) - ELSE - delp = hrus%plen(i) - ENDIF - - slope = abs(hrus%elva(i)-hrus%elva(j))/delp - ! from Fan et al., JGR 112(D10125) - IF (slope > 0.16) THEN - bdamp = 4.8 - ELSE - bdamp = 120./(1+150.*slope) - ENDIF - - ! Upstream scheme for hydraulic conductivity - IF ((zsubs_h_up > zsubs_h_dn) .or. j_is_river) THEN - IF (zwt_h(i) > 1.5) THEN - ! from Fan et al., JGR 112(D10125) - Kl_fc = Kl_h(i) * bdamp * exp(-(zwt_h(i)-1.5)/bdamp) - ELSE - Kl_fc = Kl_h(i) * ((1.5-zwt_h(i)) + bdamp) - ENDIF - ELSE - IF (zwt_h(j) > 1.5) THEN - Kl_fc = Kl_h(j) * bdamp * exp(-(zwt_h(j)-1.5)/bdamp) - ELSE - Kl_fc = Kl_h(j) * ((1.5-zwt_h(j)) + bdamp) - ENDIF - ENDIF - - ca = hrus%flen(i) * Kl_fc / theta_a_h(i) / delp / hrus%agwt(i) * deltime - - IF (.not. j_is_river) THEN - cb = hrus%flen(i) * Kl_fc / theta_a_h(j) / delp / hrus%agwt(j) * deltime - ELSE - cb = hrus%flen(i) * Kl_fc / delp / hrus%area(j) * deltime - ENDIF - - xsubs_fc(i) = (zsubs_h_up - zsubs_h_dn) * hrus%flen(i) * Kl_fc / (1+ca+cb) / delp - - xsubs_h(i) = xsubs_h(i) + xsubs_fc(i) / hrus%agwt(i) - - IF (j_is_river) THEN - xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%area(j) - ELSE - xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%agwt(j) - ENDIF - - ENDDO - - IF (hrus%indx(1) == 0) THEN - ! xsubs_h(1) is positive = out of soil column - IF (xsubs_h(1)*deltime > wdsrf_hru(hrus%ihru(1))) THEN - alp = wdsrf_hru(hrus%ihru(1)) / (xsubs_h(1)*deltime) - xsubs_h(1) = xsubs_h(1) * alp - DO i = 2, nhru - IF ((hrus%inext(i) == 1) .and. (hrus%agwt(i) > 0.)) THEN - xsubs_h(i) = xsubs_h(i) - (1.0-alp)*xsubs_fc(i)/hrus%agwt(i) - ENDIF - ENDDO - ENDIF - ENDIF - - ! Update total subsurface lateral flow (1): Between hydrological units - ! for soil, urban, wetland or river patches - DO i = 1, nhru - xsubs_hru(hrus%ihru(i)) = xsubs_h(i) - - ps = hru_patch%substt(hrus%ihru(i)) - pe = hru_patch%subend(hrus%ihru(i)) - DO ipatch = ps, pe - IF ((patchtype(ipatch) <= 2) .or. (hrus%indx(i) == 0)) THEN - xwsub(ipatch) = xwsub(ipatch) + xsubs_h(i) * 1.e3 ! (positive = out of soil column) - ENDIF - ENDDO - - IF (hrus%indx(1) == 0) THEN - DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - rsub(ipatch) = - xsubs_h(1) * hrus%area(1) / sum(hrus%agwt) * 1.0e3 ! m/s to mm/s - ENDIF - ENDDO - ENDIF - ENDDO - - DO i = 1, nhru - ! Inside hydrological units - IF (hrus%agwt(i) > 0) THEN - - bdamp = 4.8 - - IF (zwt_h(i) > 1.5) THEN - ! from Fan et al., JGR 112(D10125) - Kl_in = Kl_h(i) * bdamp * exp(-(zwt_h(i)-1.5)/bdamp) - ELSE - Kl_in = Kl_h(i) * ((1.5-zwt_h(i)) + bdamp) - ENDIF - - ps = hru_patch%substt(hrus%ihru(i)) - pe = hru_patch%subend(hrus%ihru(i)) - sumwt = sum(hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) - IF (sumwt > 0) THEN - zwt_mean = sum(zwt(ps:pe)*hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) / sumwt - - DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - xsubs_pch(ipatch) = - Kl_in * (zwt(ipatch) - zwt_mean) *6.0*pi/hrus%agwt(i) - ! Update total subsurface lateral flow (2): Between patches - xwsub(ipatch) = xwsub(ipatch) + xsubs_pch(ipatch) * 1.e3 ! m/s to mm/s - ENDIF - ENDDO - ENDIF - ENDIF - ENDDO - - sumarea = sum(hrus%agwt) - IF (sumarea > 0) THEN - theta_a_elm (ielm) = sum(theta_a_h * hrus%agwt) / sumarea - zwt_elm (ielm) = sum(zwt_h * hrus%agwt) / sumarea - Kl_elm (ielm) = sum(Kl_h * hrus%agwt) / sumarea - ENDIF - - deallocate (theta_a_h) - deallocate (zwt_h ) - deallocate (Kl_h ) - deallocate (xsubs_h ) - deallocate (xsubs_fc ) - - ENDDO - - DO ielm = 1, numelm - hs = elm_hru%substt(ielm) - he = elm_hru%subend(ielm) - wdsrf_elm(ielm) = sum(wdsrf_hru(hs:he) * elm_hru%subfrc(hs:he)) - ENDDO - - CALL retrieve_neighbour_data (theta_a_elm, theta_a_nb) - CALL retrieve_neighbour_data (zwt_elm , zwt_nb ) - CALL retrieve_neighbour_data (Kl_elm , Kl_nb ) - CALL retrieve_neighbour_data (wdsrf_elm , wdsrf_nb ) - - DO ielm = 1, numelm - - hrus => hillslope_element(ielm) - - iam_lake = (lake_id_elm(ielm) > 0) - - DO jnb = 1, elementneighbour(ielm)%nnb - - IF (elementneighbour(ielm)%glbindex(jnb) == -9) CYCLE ! skip ocean neighbour - - nb_is_lake = islake_nb(ielm)%val(jnb) - - IF (iam_lake .and. nb_is_lake) THEN - CYCLE - ENDIF - - IF (.not. iam_lake) THEN - Kl_up = Kl_elm (ielm) - zwt_up = zwt_elm (ielm) - theta_a_up = theta_a_elm(ielm) - zsubs_up = elementneighbour(ielm)%myelva - zwt_up - area_up = sum(hrus%agwt) - ELSE - theta_a_up = 1. - zsubs_up = elementneighbour(ielm)%myelva - lakedepth_elm(ielm) + wdsrf_elm(ielm) - area_up = elementneighbour(ielm)%myarea - ENDIF - - IF (.not. nb_is_lake) THEN - Kl_dn = Kl_nb(ielm)%val(jnb) - zwt_dn = zwt_nb(ielm)%val(jnb) - theta_a_dn = theta_a_nb(ielm)%val(jnb) - zsubs_dn = elementneighbour(ielm)%elva(jnb) - zwt_dn - area_dn = agwt_nb(ielm)%val(jnb) - ELSE - theta_a_dn = 1. - zsubs_dn = elementneighbour(ielm)%elva(jnb) - lakedp_nb(ielm)%val(jnb) + wdsrf_nb(ielm)%val(jnb) - area_dn = elementneighbour(ielm)%area(jnb) - ENDIF - - IF ((.not. iam_lake) .and. (area_up <= 0)) CYCLE - IF ((.not. nb_is_lake) .and. (area_dn <= 0)) CYCLE - IF ((.not. iam_lake) .and. (Kl_up == 0. )) CYCLE - IF ((.not. nb_is_lake) .and. (Kl_dn == 0. )) CYCLE - - ! water body is dry. - IF (iam_lake .and. (zsubs_up > zsubs_dn) .and. (wdsrf_elm(ielm) == 0.)) THEN - CYCLE - ENDIF - IF (nb_is_lake .and. (zsubs_up < zsubs_dn) .and. (wdsrf_nb(ielm)%val(jnb) == 0.)) THEN - CYCLE - ENDIF - - lenbdr = elementneighbour(ielm)%lenbdr(jnb) - - delp = elementneighbour(ielm)%dist(jnb) - IF (iam_lake) THEN - delp = elementneighbour(ielm)%area(jnb) / lenbdr * 0.5 - ENDIF - IF (nb_is_lake) THEN - delp = elementneighbour(ielm)%myarea / lenbdr * 0.5 - ENDIF - - ! from Fan et al., JGR 112(D10125) - slope = abs(elementneighbour(ielm)%slope(jnb)) - IF (slope > 0.16) THEN - bdamp = 4.8 - ELSE - bdamp = 120./(1+150.*slope) - ENDIF - - ! Upstream scheme for hydraulic conductivity - IF (nb_is_lake .or. ((.not. iam_lake) .and. (zsubs_up > zsubs_dn))) THEN - IF (zwt_up > 1.5) THEN - ! from Fan et al., JGR 112(D10125) - Kl_fc = Kl_up * bdamp * exp(-(zwt_up-1.5)/bdamp) - ELSE - Kl_fc = Kl_up * ((1.5-zwt_up) + bdamp) - ENDIF - ELSE - IF (zwt_dn > 1.5) THEN - Kl_fc = Kl_dn * bdamp * exp(-(zwt_dn-1.5)/bdamp) - ELSE - Kl_fc = Kl_dn * ((1.5-zwt_dn) + bdamp) - ENDIF - ENDIF - - ca = lenbdr * Kl_fc / theta_a_up / delp / area_up * deltime - cb = lenbdr * Kl_fc / theta_a_dn / delp / area_dn * deltime - - xsubs_nb = (zsubs_up - zsubs_dn) * lenbdr * Kl_fc / (1+ca+cb) / delp - - IF (.not. iam_lake) THEN - xsubs_nb = xsubs_nb / sum(hrus%agwt) - ELSE - xsubs_nb = xsubs_nb / elementneighbour(ielm)%myarea - ENDIF - - xsubs_elm(ielm) = xsubs_elm(ielm) + xsubs_nb - - IF (nb_is_lake) THEN - ps = elm_patch%substt(ielm) - pe = elm_patch%subend(ielm) - DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - rsub(ipatch) = rsub(ipatch) + xsubs_nb * 1.e3 - ENDIF - ENDDO - ENDIF - - ENDDO - - ! Update total subsurface lateral flow (3): Between basins - ps = elm_patch%substt(ielm) - pe = elm_patch%subend(ielm) - DO ipatch = ps, pe - IF (iam_lake .or. (patchtype(ipatch) <= 2)) THEN - xwsub(ipatch) = xwsub(ipatch) + xsubs_elm(ielm) * 1.e3 ! m/s to mm/s - ENDIF - ENDDO - - ENDDO - - IF (allocated(theta_a_elm)) deallocate(theta_a_elm) - IF (allocated(zwt_elm )) deallocate(zwt_elm ) - IF (allocated(Kl_elm )) deallocate(Kl_elm ) - - ENDIF - - ! Exchange between soil water and aquifer. - IF (p_is_compute) THEN - - sp_zi(0) = 0. - sp_zi(1:nl_soil) = zi_soi(1:nl_soil) * 1000.0 ! from meter to mm - sp_dz(1:nl_soil) = sp_zi(1:nl_soil) - sp_zi(0:nl_soil-1) - - DO ipatch = 1, numpatch - -#if (defined CoLMDEBUG) - ! For water balance check, the sum of water in soil column before the calcultion - w_sum_before = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & - + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch) -#endif - - IF (DEF_USE_Dynamic_Lake) THEN - is_dry_lake = (patchtype(ipatch) == 4) .and. (zwt(ipatch) > 0.) - ELSE - is_dry_lake = .false. - ENDIF - - IF ((patchtype(ipatch) <= 1) .or. is_dry_lake) THEN - - exwater = xwsub(ipatch) * deltime - -#ifdef Campbell_SOIL_MODEL - vl_r(1:nl_soil) = 0._r8 - prms(1,:) = bsw(1:nl_soil,ipatch) -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - vl_r (1:nl_soil) = theta_r (1:nl_soil,ipatch) - prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,ipatch) - prms(2,1:nl_soil) = n_vgm (1:nl_soil,ipatch) - prms(3,1:nl_soil) = L_vgm (1:nl_soil,ipatch) - prms(4,1:nl_soil) = sc_vgm (1:nl_soil,ipatch) - prms(5,1:nl_soil) = fc_vgm (1:nl_soil,ipatch) -#endif - - DO ilev = 1, nl_soil - vol_ice(ilev) = wice_soisno(ilev,ipatch)/denice*1000. / sp_dz(ilev) - vol_ice(ilev) = min(vol_ice(ilev), porsl(ilev,ipatch)) - - eff_porosity(ilev) = max(wimp, porsl(ilev,ipatch)-vol_ice(ilev)) - is_permeable(ilev) = eff_porosity(ilev) > max(wimp, vl_r(ilev)) - IF (is_permeable(ilev)) THEN - vol_liq(ilev) = wliq_soisno(ilev,ipatch)/denh2o*1000. / sp_dz(ilev) - vol_liq(ilev) = min(eff_porosity(ilev), max(0., vol_liq(ilev))) - wresi(ilev) = wliq_soisno(ilev,ipatch) - sp_dz(ilev)*vol_liq(ilev)/1000. * denh2o - ELSE - vol_liq(ilev) = eff_porosity(ilev) - wresi(ilev) = 0. - ENDIF - ENDDO - - zwtmm = zwt(ipatch) * 1000. ! m -> mm - - ! check consistancy between water table location and liquid water content - DO ilev = 1, nl_soil - IF ((vol_liq(ilev) < eff_porosity(ilev)-1.e-8) .and. (zwtmm <= sp_zi(ilev-1))) THEN - zwtmm = sp_zi(ilev) - ENDIF - ENDDO - - izwt = findloc_ud(zwtmm >= sp_zi, back=.true.) - - IF (izwt <= nl_soil) THEN - IF (is_permeable(izwt) .and. (zwtmm > sp_zi(izwt-1))) THEN - vol_liq(izwt) = (wliq_soisno(izwt,ipatch)/denh2o*1000.0 & - - eff_porosity(izwt)*(sp_zi(izwt)-zwtmm)) / (zwtmm - sp_zi(izwt-1)) - - IF (vol_liq(izwt) < 0.) THEN - zwtmm = sp_zi(izwt) - vol_liq(izwt) = wliq_soisno(izwt,ipatch)/denh2o*1000.0 / (sp_zi(izwt)-sp_zi(izwt-1)) - ENDIF - - vol_liq(izwt) = max(0., min(eff_porosity(izwt), vol_liq(izwt))) - wresi(izwt) = wliq_soisno(izwt,ipatch) - (eff_porosity(izwt)*(sp_zi(izwt)-zwtmm) & - + vol_liq(izwt)*(zwtmm-sp_zi(izwt-1))) /1000. * denh2o - ENDIF - ENDIF - - CALL soilwater_aquifer_exchange ( & - nl_soil, exwater, sp_zi, is_permeable, eff_porosity, vl_r, psi0(:,ipatch), & - hksati(:,ipatch), nprms, prms, porsl(nl_soil,ipatch), wdsrf(ipatch), & - vol_liq, zwtmm, wa(ipatch), izwt) - - ! update the mass of liquid water - DO ilev = nl_soil, 1, -1 - IF (is_permeable(ilev)) THEN - IF (zwtmm < sp_zi(ilev)) THEN - IF (zwtmm >= sp_zi(ilev-1)) THEN - wliq_soisno(ilev,ipatch) = ((eff_porosity(ilev)*(sp_zi(ilev)-zwtmm)) & - + vol_liq(ilev)*(zwtmm-sp_zi(ilev-1)))/1000.0 * denh2o - ELSE - wliq_soisno(ilev,ipatch) = denh2o * eff_porosity(ilev)*sp_dz(ilev)/1000.0 - ENDIF - ELSE - wliq_soisno(ilev,ipatch) = denh2o * vol_liq(ilev)*sp_dz(ilev)/1000.0 - ENDIF - - wliq_soisno(ilev,ipatch) = wliq_soisno(ilev,ipatch) + wresi(ilev) - ENDIF - ENDDO - - zwt(ipatch) = zwtmm/1000.0 - - ELSEIF (patchtype(ipatch) == 2) THEN ! wetland - - wetwat(ipatch) = wdsrf(ipatch) + wa(ipatch) + wetwat(ipatch) - xwsub(ipatch)*deltime - - IF (wetwat(ipatch) > wetwatmax) THEN - wdsrf (ipatch) = wetwat(ipatch) - wetwatmax - wetwat(ipatch) = wetwatmax - wa (ipatch) = 0. - ELSEIF (wetwat(ipatch) < 0) THEN - wa (ipatch) = wetwat(ipatch) - wdsrf (ipatch) = 0. - wetwat(ipatch) = 0. - ELSE - wdsrf(ipatch) = 0. - wa (ipatch) = 0. - ENDIF - - ELSEIF (patchtype(ipatch) == 4) THEN ! land water bodies - - wdsrf(ipatch) = wa(ipatch) + wdsrf(ipatch) - xwsub(ipatch)*deltime - - IF (wdsrf(ipatch) < 0) THEN - wa (ipatch) = wdsrf(ipatch) - wdsrf(ipatch) = 0 - ELSE - wa(ipatch) = 0 - ENDIF - - ENDIF - -#if (defined CoLMDEBUG) - ! For water balance check, the sum of water in soil column after the calcultion - w_sum_after = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & - + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch) - errblc = w_sum_after - w_sum_before + xwsub(ipatch)*deltime - - IF(abs(errblc) > 1.e-3)THEN - write(6,'(A,I0,4E20.5)') 'Warning (Subsurface Runoff): water balance violation ', & - ipatch, errblc, xwsub(ipatch), zwtmm - write(*,*) patchtype(ipatch) - CALL CoLM_stop () - ENDIF -#endif - ENDDO - ENDIF - - END SUBROUTINE subsurface_flow - - ! ---------- - SUBROUTINE subsurface_network_final () - - IMPLICIT NONE - - IF (allocated(lake_id_elm )) deallocate(lake_id_elm ) - IF (allocated(riverdpth_elm)) deallocate(riverdpth_elm) - IF (allocated(lakedepth_elm)) deallocate(lakedepth_elm) - IF (allocated(wdsrf_elm )) deallocate(wdsrf_elm ) - - IF (allocated(theta_a_nb)) deallocate(theta_a_nb) - IF (allocated(zwt_nb )) deallocate(zwt_nb ) - IF (allocated(Kl_nb )) deallocate(Kl_nb ) - IF (allocated(wdsrf_nb )) deallocate(wdsrf_nb ) - IF (allocated(agwt_nb )) deallocate(agwt_nb ) - IF (allocated(islake_nb )) deallocate(islake_nb ) - IF (allocated(lakedp_nb )) deallocate(lakedp_nb ) - - IF (associated(hillslope_element)) deallocate(hillslope_element) - - END SUBROUTINE subsurface_network_final - -END MODULE MOD_Catch_SubsurfaceFlow -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 deleted file mode 100644 index 3eab827aab..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 +++ /dev/null @@ -1,115 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_Vars_1DFluxes -!------------------------------------------------------------------------------------- -! DESCRIPTION: -! -! 1D fluxes in lateral hydrological processes. -! -! Created by Shupeng Zhang, May 2023 -!------------------------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - ! -- fluxes -- - real(r8), allocatable :: xsubs_elm (:) ! subsurface lateral flow between basins [m/s] - real(r8), allocatable :: xsubs_hru (:) ! subsurface lateral flow between hydrological response units [m/s] - real(r8), allocatable :: xsubs_pch (:) ! subsurface lateral flow between patches inside one HRU [m/s] - - real(r8), allocatable :: wdsrf_bsn_ta (:) ! time step average of river height [m] - real(r8), allocatable :: momen_riv_ta (:) ! time step average of river momentum [m^2/s] - real(r8), allocatable :: veloc_riv_ta (:) ! time step average of river velocity [m/s] - real(r8), allocatable :: discharge_ta (:) ! river discharge [m^3/s] - - real(r8), allocatable :: wdsrf_bsnhru_ta (:) ! time step average of surface water depth [m] - real(r8), allocatable :: momen_bsnhru_ta (:) ! time step average of surface water momentum [m^2/s] - real(r8), allocatable :: veloc_bsnhru_ta (:) ! time step average of surface water veloctiy [m/s] - - real(r8), allocatable :: xwsur (:) ! surface water exchange [mm h2o/s] - real(r8), allocatable :: xwsub (:) ! subsurface water exchange [mm h2o/s] - real(r8), allocatable :: fldarea (:) ! fraction of flooded area [-] - - real(r8), allocatable :: ntacc_bsn (:) - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_1D_CatchFluxes - PUBLIC :: deallocate_1D_CatchFluxes - -CONTAINS - - SUBROUTINE allocate_1D_CatchFluxes - - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - USE MOD_Mesh, only: numelm - USE MOD_LandHRU, only: numhru - USE MOD_LandPatch, only: numpatch - USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru - IMPLICIT NONE - - IF (p_is_compute) THEN - - IF (numpatch > 0) THEN - allocate (xsubs_pch (numpatch)) ; xsubs_pch (:) = spval - allocate (xwsur (numpatch)) ; xwsur (:) = spval - allocate (xwsub (numpatch)) ; xwsub (:) = spval - allocate (fldarea (numpatch)) ; fldarea (:) = spval - ENDIF - - IF (numelm > 0) THEN - allocate (xsubs_elm (numelm)) ; xsubs_elm(:) = spval - ENDIF - - IF (numbasin > 0) THEN - allocate (wdsrf_bsn_ta (numbasin)) ; wdsrf_bsn_ta (:) = spval - allocate (momen_riv_ta (numbasin)) ; momen_riv_ta (:) = spval - allocate (veloc_riv_ta (numbasin)) ; veloc_riv_ta (:) = spval - allocate (discharge_ta (numbasin)) ; discharge_ta (:) = spval - ENDIF - - IF (numhru > 0) THEN - allocate (xsubs_hru (numhru)); xsubs_hru(:) = spval - ENDIF - - IF (numbsnhru > 0) THEN - allocate (wdsrf_bsnhru_ta (numbsnhru)) ; wdsrf_bsnhru_ta (:) = spval - allocate (momen_bsnhru_ta (numbsnhru)) ; momen_bsnhru_ta (:) = spval - allocate (veloc_bsnhru_ta (numbsnhru)) ; veloc_bsnhru_ta (:) = spval - ENDIF - - IF (numbasin > 0) allocate (ntacc_bsn (numbasin)) - IF (numbasin > 0) ntacc_bsn(:) = 0. - - ENDIF - - END SUBROUTINE allocate_1D_CatchFluxes - - SUBROUTINE deallocate_1D_CatchFluxes - - IMPLICIT NONE - - IF (allocated(xsubs_elm)) deallocate(xsubs_elm) - IF (allocated(xsubs_hru)) deallocate(xsubs_hru) - IF (allocated(xsubs_pch)) deallocate(xsubs_pch) - - IF (allocated(wdsrf_bsn_ta)) deallocate(wdsrf_bsn_ta) - IF (allocated(momen_riv_ta)) deallocate(momen_riv_ta) - IF (allocated(veloc_riv_ta)) deallocate(veloc_riv_ta) - IF (allocated(discharge_ta)) deallocate(discharge_ta) - - IF (allocated(wdsrf_bsnhru_ta)) deallocate(wdsrf_bsnhru_ta) - IF (allocated(momen_bsnhru_ta)) deallocate(momen_bsnhru_ta) - IF (allocated(veloc_bsnhru_ta)) deallocate(veloc_bsnhru_ta) - - IF (allocated(xwsur )) deallocate(xwsur ) - IF (allocated(xwsub )) deallocate(xwsub ) - IF (allocated(fldarea)) deallocate(fldarea) - - IF (allocated(ntacc_bsn)) deallocate(ntacc_bsn) - - END SUBROUTINE deallocate_1D_CatchFluxes - -END MODULE MOD_Catch_Vars_1DFluxes -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 deleted file mode 100644 index 37b9af417f..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 +++ /dev/null @@ -1,178 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_Vars_TimeVariables -!------------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Time Variables in lateral hydrological processes. -! -! Created by Shupeng Zhang, May 2023 -!------------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Catch_BasinNetwork - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - ! -- state variables (1): necessary for restart -- - real(r8), allocatable :: veloc_elm (:) ! river velocity [m/s] - real(r8), allocatable :: veloc_hru (:) ! surface water velocity [m/s] - real(r8), allocatable :: wdsrf_hru (:) ! surface water depth [m] - - real(r8), allocatable :: wdsrf_elm_prev (:) ! river or lake water depth at previous time step [m] - real(r8), allocatable :: wdsrf_hru_prev (:) ! surface water depth at previous time step [m] - - ! -- state variables (2): only in model -- - real(r8), allocatable :: wdsrf_bsn (:) ! river or lake water depth [m] - real(r8), allocatable :: veloc_riv (:) ! river velocity [m/s] - real(r8), allocatable :: momen_riv (:) ! unit river momentum [m^2/s] - real(r8), allocatable :: wdsrf_bsnhru (:) ! surface water depth [m] - real(r8), allocatable :: veloc_bsnhru (:) ! surface water velocity [m/s] - real(r8), allocatable :: momen_bsnhru (:) ! unit surface water momentum [m^2/s] - - real(r8), allocatable :: wdsrf_bsn_prev (:) ! river or lake water depth at previous time step [m] - real(r8), allocatable :: wdsrf_bsnhru_prev (:) ! surface water depth at previous time step [m] - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_CatchTimeVariables - PUBLIC :: deallocate_CatchTimeVariables - - PUBLIC :: read_CatchTimeVariables - PUBLIC :: write_CatchTimeVariables - -CONTAINS - - SUBROUTINE allocate_CatchTimeVariables - - USE MOD_SPMD_Task - USE MOD_Mesh, only: numelm - USE MOD_LandHRU, only: numhru - IMPLICIT NONE - - IF (p_is_compute) THEN - - IF (numelm > 0) THEN - allocate (veloc_elm (numelm)) - allocate (wdsrf_elm_prev (numelm)) - ENDIF - - IF (numhru > 0) THEN - allocate (veloc_hru (numhru)) - allocate (wdsrf_hru (numhru)) - allocate (wdsrf_hru_prev (numhru)) - ENDIF - - IF (numbasin > 0) allocate (wdsrf_bsn (numbasin)) - IF (numbasin > 0) allocate (veloc_riv (numbasin)) - IF (numbasin > 0) allocate (momen_riv (numbasin)) - IF (numbasin > 0) allocate (wdsrf_bsn_prev(numbasin)) - - IF (numbsnhru > 0) allocate (wdsrf_bsnhru (numbsnhru)) - IF (numbsnhru > 0) allocate (veloc_bsnhru (numbsnhru)) - IF (numbsnhru > 0) allocate (momen_bsnhru (numbsnhru)) - IF (numbsnhru > 0) allocate (wdsrf_bsnhru_prev (numbsnhru)) - - ENDIF - - END SUBROUTINE allocate_CatchTimeVariables - - SUBROUTINE READ_CatchTimeVariables (file_restart) - - USE MOD_Mesh - USE MOD_LandHRU - USE MOD_Vector_ReadWrite - USE MOD_ElmVector - USE MOD_HRUVector - IMPLICIT NONE - - character(len=*), intent(in) :: file_restart - - CALL vector_read_and_scatter (file_restart, veloc_elm, numelm, 'veloc_riv', elm_data_address) - CALL compute_push_data (push_elm2bsn, veloc_elm, veloc_riv, spval) - - CALL vector_read_and_scatter (file_restart, wdsrf_elm_prev, numelm, 'wdsrf_bsn_prev', elm_data_address) - CALL compute_push_data (push_elm2bsn, wdsrf_elm_prev, wdsrf_bsn_prev, spval) - - CALL vector_read_and_scatter (file_restart, veloc_hru, numhru, 'veloc_hru', hru_data_address) - CALL compute_push_data (push_elmhru2bsnhru, veloc_hru, veloc_bsnhru, spval) - - CALL vector_read_and_scatter (file_restart, wdsrf_hru_prev, numhru, 'wdsrf_hru_prev', hru_data_address) - CALL compute_push_data (push_elmhru2bsnhru, wdsrf_hru_prev, wdsrf_bsnhru_prev, spval) - - END SUBROUTINE READ_CatchTimeVariables - - SUBROUTINE WRITE_CatchTimeVariables (file_restart) - - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - USE MOD_Mesh - USE MOD_LandHRU - USE MOD_Vector_ReadWrite - USE MOD_ElmVector - USE MOD_HRUVector - IMPLICIT NONE - - integer :: iwork - character(len=*), intent(in) :: file_restart - - IF (p_is_root) THEN - CALL ncio_create_file (trim(file_restart)) - CALL ncio_define_dimension(file_restart, 'basin', totalnumelm) - CALL ncio_define_dimension(file_restart, 'hydrounit', totalnumhru) - - CALL ncio_write_serial (file_restart, 'basin', eindex_glb, 'basin') - CALL ncio_put_attr (file_restart, 'basin', 'long_name', 'basin index') - - CALL ncio_write_serial (file_restart, 'bsn_hru', eindx_hru, 'hydrounit') - CALL ncio_put_attr (file_restart, 'bsn_hru', & - 'long_name', 'basin index of hydrological units') - - CALL ncio_write_serial (file_restart, 'hru_type' , htype_hru, 'hydrounit') - CALL ncio_put_attr (file_restart, 'hru_type' , & - 'long_name', 'index of hydrological units inside basin') - ENDIF - - CALL compute_push_data (push_bsn2elm, veloc_riv, veloc_elm, spval) - CALL vector_gather_and_write (& - veloc_elm, numelm, totalnumelm, elm_data_address, file_restart, 'veloc_riv', 'basin') - - CALL compute_push_data (push_bsn2elm, wdsrf_bsn_prev, wdsrf_elm_prev, spval) - CALL vector_gather_and_write (& - wdsrf_elm_prev, numelm, totalnumelm, elm_data_address, file_restart, 'wdsrf_bsn_prev', 'basin') - - CALL compute_push_data (push_bsnhru2elmhru, veloc_bsnhru, veloc_hru, spval) - CALL vector_gather_and_write (& - veloc_hru, numhru, totalnumhru, hru_data_address, file_restart, 'veloc_hru', 'hydrounit') - - CALL compute_push_data (push_bsnhru2elmhru, wdsrf_bsnhru_prev, wdsrf_hru_prev, spval) - CALL vector_gather_and_write (& - wdsrf_hru_prev, numhru, totalnumhru, hru_data_address, file_restart, 'wdsrf_hru_prev', 'hydrounit') - - END SUBROUTINE WRITE_CatchTimeVariables - - SUBROUTINE deallocate_CatchTimeVariables - - IMPLICIT NONE - - IF (allocated(veloc_elm)) deallocate(veloc_elm) - IF (allocated(veloc_hru)) deallocate(veloc_hru) - IF (allocated(wdsrf_hru)) deallocate(wdsrf_hru) - - IF (allocated(wdsrf_elm_prev)) deallocate(wdsrf_elm_prev) - IF (allocated(wdsrf_hru_prev)) deallocate(wdsrf_hru_prev) - - IF (allocated (wdsrf_bsn )) deallocate (wdsrf_bsn ) - IF (allocated (veloc_riv )) deallocate (veloc_riv ) - IF (allocated (momen_riv )) deallocate (momen_riv ) - IF (allocated (wdsrf_bsn_prev)) deallocate (wdsrf_bsn_prev) - - IF (allocated (wdsrf_bsnhru )) deallocate (wdsrf_bsnhru ) - IF (allocated (veloc_bsnhru )) deallocate (veloc_bsnhru ) - IF (allocated (momen_bsnhru )) deallocate (momen_bsnhru ) - IF (allocated (wdsrf_bsnhru_prev)) deallocate (wdsrf_bsnhru_prev) - - END SUBROUTINE deallocate_CatchTimeVariables - -END MODULE MOD_Catch_Vars_TimeVariables -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 deleted file mode 100644 index c872b4ebf4..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 +++ /dev/null @@ -1,230 +0,0 @@ -#include - -#ifdef CatchLateralFlow -MODULE MOD_Catch_WriteParameters - -CONTAINS - - SUBROUTINE write_catch_parameters - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_Vector_ReadWrite - USE MOD_ElmVector - USE MOD_Catch_Reservoir - USE MOD_Vars_TimeInvariants, only : wf_sand, wf_clay, wf_om, wf_gravels, patchclass - USE MOD_Catch_SubsurfaceFlow, only : hillslope_element, lake_id_elm - USE MOD_HRUVector, only : totalnumhru, hru_data_address, eindx_hru, htype_hru - USE MOD_Mesh, only : numelm - USE MOD_LandHRU, only : numhru - USE MOD_LandPatch, only : hru_patch - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - character(len=256) :: file_parameters - character(len=1) :: slev - real(r8), allocatable :: hrupara(:), varpara(:) - integer :: ilev, i, ps, pe, ielm, ihru, j - - file_parameters = trim(DEF_dir_output) // '/' // trim(DEF_CASE_NAME) // '/catch_parameters.nc' - - IF (p_is_root) THEN - CALL ncio_create_file (trim(file_parameters)) - CALL ncio_define_dimension(file_parameters, 'hydrounit', totalnumhru) - - CALL ncio_write_serial (file_parameters, 'bsn_hru', eindx_hru, 'hydrounit') - CALL ncio_put_attr (file_parameters, 'bsn_hru', & - 'long_name', 'basin index of hydrological units') - - CALL ncio_write_serial (file_parameters, 'hru_type' , htype_hru, 'hydrounit') - CALL ncio_put_attr (file_parameters, 'hru_type' , & - 'long_name', 'index of hydrological units inside basin') - ENDIF - - IF (p_is_compute) THEN - IF (numhru > 0) allocate (hrupara (numhru)) - ENDIF - - DO ilev = 1, 5 - - write(slev,'(i1.1)') ilev - - ! sand - IF (p_is_compute) THEN - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - hrupara(i) = sum(wf_sand(ilev,ps:pe) * hru_patch%subfrc(ps:pe)) - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_sand_l'//slev, 'hydrounit') - - ! clay - IF (p_is_compute) THEN - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - hrupara(i) = sum(wf_clay(ilev,ps:pe) * hru_patch%subfrc(ps:pe)) - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_clay_l'//slev, 'hydrounit') - - ! organic matter - IF (p_is_compute) THEN - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - hrupara(i) = sum(wf_om(ilev,ps:pe) * hru_patch%subfrc(ps:pe)) - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_om_l'//slev, 'hydrounit') - - ! silt - IF (p_is_compute) THEN - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - hrupara(i) = sum((1-wf_sand(ilev,ps:pe)-wf_gravels(ilev,ps:pe)-wf_om(ilev,ps:pe)-wf_clay(ilev,ps:pe)) * hru_patch%subfrc(ps:pe)) - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_silt_l'//slev, 'hydrounit') - ENDDO - - - - IF (p_is_compute) THEN - DO i = 1, numhru - ps = hru_patch%substt(i) - pe = hru_patch%subend(i) - hrupara(i) = patchclass(ps) - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'lulc_igbp', 'hydrounit') - - IF (p_is_compute) THEN - IF (numhru > 0) hrupara(:) = spval - DO ielm = 1, numelm - IF (lake_id_elm(ielm) <= 0) THEN - DO i = 1, hillslope_element(ielm)%nhru - IF (hillslope_element(ielm)%indx(i) /= 0) THEN - ihru = hillslope_element(ielm)%ihru(i) - hrupara(ihru) = hillslope_element(ielm)%plen(i) * 2. - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_length', 'hydrounit') - - IF (p_is_root) THEN - CALL ncio_put_attr (file_parameters, 'slope_length', 'units', 'm') - CALL ncio_put_attr (file_parameters, 'slope_length', 'missing_value', spval) - ENDIF - - IF (p_is_compute) THEN - IF (numhru > 0) hrupara(:) = spval - DO ielm = 1, numelm - IF (lake_id_elm(ielm) <= 0) THEN - DO i = 1, hillslope_element(ielm)%nhru - IF (hillslope_element(ielm)%indx(i) /= 0) THEN - ihru = hillslope_element(ielm)%ihru(i) - hrupara(ihru) = hillslope_element(ielm)%elva(i) - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'elevation', 'hydrounit') - - IF (p_is_root) THEN - CALL ncio_put_attr (file_parameters, 'elevation', 'units', 'm') - CALL ncio_put_attr (file_parameters, 'elevation', 'missing_value', spval) - ENDIF - - IF (p_is_compute) THEN - IF (numhru > 0) hrupara(:) = spval - DO ielm = 1, numelm - IF (lake_id_elm(ielm) <= 0) THEN - DO i = 1, hillslope_element(ielm)%nhru - IF (hillslope_element(ielm)%indx(i) /= 0) THEN - ihru = hillslope_element(ielm)%ihru(i) - j = hillslope_element(ielm)%inext(i) - IF (j > 0) THEN - hrupara(ihru) = (hillslope_element(ielm)%hand(i) - hillslope_element(ielm)%hand(j)) & - / (hillslope_element(ielm)%plen(i) + hillslope_element(ielm)%plen(j)) - ELSE - hrupara(ihru) = hillslope_element(ielm)%hand(i) / hillslope_element(ielm)%plen(i) - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF - - CALL vector_gather_and_write (& - hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_ratio', 'hydrounit') - - IF (p_is_root) THEN - CALL ncio_put_attr (file_parameters, 'slope_ratio', 'units', '-') - CALL ncio_put_attr (file_parameters, 'slope_ratio', 'missing_value', spval) - ENDIF - - IF (allocated(hrupara)) deallocate(hrupara) - - - ! ----- reservoirs ----- - IF (DEF_Reservoir_Method > 0) THEN - IF (numresv_uniq > 0) THEN - - IF (p_is_root) THEN - CALL ncio_define_dimension (file_parameters, 'reservoir', numresv_uniq) - CALL ncio_write_serial (file_parameters, 'resv_hylak_id' , resv_hylak_id, 'reservoir') - CALL ncio_put_attr (file_parameters, 'resv_hylak_id' , 'long_name', & - 'HydroLAKE ID of reservoirs') - ENDIF - - allocate (varpara (numresv_uniq)) - - CALL reservoir_gather_var (volresv_total, varpara) - IF (p_is_root) THEN - CALL ncio_write_serial (file_parameters, 'volresv_total', varpara, 'reservoir', 1) - CALL ncio_put_attr (file_parameters, 'volresv_total', 'units', 'm^3') - ENDIF - - CALL reservoir_gather_var (qresv_mean, varpara) - IF (p_is_root) THEN - CALL ncio_write_serial (file_parameters, 'qresv_mean', varpara, 'reservoir', 1) - CALL ncio_put_attr (file_parameters, 'qresv_mean', 'units', 'm^3/s') - ENDIF - - CALL reservoir_gather_var (qresv_flood, varpara) - IF (p_is_root) THEN - CALL ncio_write_serial (file_parameters, 'qresv_flood', varpara, 'reservoir', 1) - CALL ncio_put_attr (file_parameters, 'qresv_flood', 'units', 'm^3/s') - ENDIF - - deallocate (varpara) - - ENDIF - ENDIF - - END SUBROUTINE write_catch_parameters - -END MODULE MOD_Catch_WriteParameters -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 deleted file mode 100644 index 8897bb1f3c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 +++ /dev/null @@ -1,711 +0,0 @@ -#include - -MODULE MOD_ElementNeighbour -!--------------------------------------------------------------------------------! -! DESCRIPTION: ! -! ! -! Element Neighbours : data and communication subroutines. ! -! ! -! Created by Shupeng Zhang, May 2023 ! -!--------------------------------------------------------------------------------! - - USE MOD_Precision - USE MOD_DataType - IMPLICIT NONE - - ! -- neighbour parameters -- - type element_neighbour_type - - integer :: nnb ! number of neighbours - real(r8) :: myarea ! area of this element [m^2] - real(r8) :: myelva ! elevation of this element [m] - - integer*8, allocatable :: glbindex (:) ! neighbour global index - - ! data address: (1,:) refers to process, (2,:) refers to location - integer , allocatable :: addr (:,:) - - real(r8), allocatable :: dist (:) ! distance between element centers [m] - real(r8), allocatable :: lenbdr (:) ! length of boundary line [m] - real(r8), allocatable :: area (:) ! area of neighbours [m^2] - real(r8), allocatable :: elva (:) ! elevation of neighbours [m] - real(r8), allocatable :: slope (:) ! slope (positive) [-] - - END type element_neighbour_type - - type(element_neighbour_type), allocatable :: elementneighbour (:) - - ! -- neighbour communication -- - type neighbour_sendrecv_type - integer :: ndata - integer*8, allocatable :: glbindex (:) - integer, allocatable :: ielement (:) - END type neighbour_sendrecv_type - - type(neighbour_sendrecv_type), allocatable :: recvaddr(:) - type(neighbour_sendrecv_type), allocatable :: sendaddr(:) - - INTERFACE allocate_neighbour_data - MODULE procedure allocate_neighbour_data_real8 - MODULE procedure allocate_neighbour_data_logic - END INTERFACE allocate_neighbour_data - -CONTAINS - - ! ---------- - SUBROUTINE element_neighbour_init (patcharea, lc_year) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_NetCDFVector - USE MOD_Mesh - USE MOD_Pixel - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_Utils - IMPLICIT NONE - - integer, intent(in) :: lc_year ! which year of land cover data used - real(r8), intent(in) :: patcharea (:) - - ! Local Variables - character(len=256) :: neighbour_file - - integer :: ielm - integer :: iwork, mesg(2), isrc, idest - integer :: nrecv, irecv - integer :: iloc, iloc1, iloc2 - integer :: nnb, nnbinq, inb, ndata - - integer :: maxnnb - integer , allocatable :: nnball (:) - integer , allocatable :: idxnball (:,:) - real(r8), allocatable :: lenbdall (:,:) - - integer , allocatable :: addrelement(:) - - integer*8, allocatable :: eindex (:) - integer, allocatable :: icache1 (:) - integer, allocatable :: icache2 (:,:) - real(r8), allocatable :: rcache2 (:,:) - - integer*8, allocatable :: elm_sorted (:) - integer, allocatable :: order (:) - integer*8, allocatable :: idxinq (:) - integer, allocatable :: addrinq (:) - - logical, allocatable :: mask(:) - - real(r8), allocatable :: rlon_b(:), rlat_b(:) - type(pointer_real8_1d), allocatable :: rlon_nb(:), rlat_nb(:) - - real(r8), allocatable :: area_b(:) - real(r8), allocatable :: elva_b(:) - - character(len=256) :: lndname, cyear - real(r8), allocatable :: elv_patches(:) - - type(pointer_real8_1d), allocatable :: area_nb (:) ! m^2 - type(pointer_real8_1d), allocatable :: elva_nb (:) ! m - - integer :: istt, iend - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - neighbour_file = DEF_ElementNeighbour_file - - IF (p_is_root) THEN - CALL ncio_read_serial (neighbour_file, 'num_neighbour', nnball ) - CALL ncio_read_serial (neighbour_file, 'idx_neighbour', idxnball) - CALL ncio_read_serial (neighbour_file, 'len_border' , lenbdall) - - maxnnb = size(idxnball,1) - - lenbdall = lenbdall * 1.e3 ! km to m - ENDIF - -#ifdef USEMPI - - CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - - IF (p_is_root) THEN - - allocate (addrelement (size(nnball))) - addrelement(:) = -1 - - DO iwork = 0, p_np_compute-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - - allocate (eindex (nrecv)) - allocate (icache1 (nrecv)) - allocate (icache2 (maxnnb,nrecv)) - allocate (rcache2 (maxnnb,nrecv)) - - CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - addrelement(eindex) = isrc - - idest = isrc - - icache1 = nnball(eindex) - CALL mpi_send (icache1, nrecv, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - icache2(:,irecv) = idxnball(:,eindex(irecv)) - ENDDO - CALL mpi_send (icache2, maxnnb*nrecv, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - rcache2(:,irecv) = lenbdall(:,eindex(irecv)) - ENDDO - CALL mpi_send (rcache2, maxnnb*nrecv, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (eindex ) - deallocate (icache1) - deallocate (icache2) - deallocate (rcache2) - - ENDIF - ENDDO - ENDIF -#endif - - IF (p_is_compute) THEN - - IF (numelm > 0) THEN - allocate (eindex (numelm)) - eindex = landelm%eindex - ENDIF - -#ifdef USEMPI - mesg(1:2) = (/p_iam_glb, numelm/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (numelm > 0) THEN - CALL mpi_send (eindex, numelm, MPI_INTEGER8, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (nnball (numelm)) - CALL mpi_recv (nnball, numelm, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (idxnball (maxnnb,numelm)) - CALL mpi_recv (idxnball, maxnnb*numelm, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (lenbdall (maxnnb,numelm)) - CALL mpi_recv (lenbdall, maxnnb*numelm, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF -#else - allocate (icache1 (numelm)) - allocate (icache2 (maxnnb,numelm)) - allocate (rcache2 (maxnnb,numelm)) - - icache1 = nnball - icache2 = idxnball - rcache2 = lenbdall - - DO ielm = 1, numelm - nnball (ielm) = icache1 (eindex(ielm)) - idxnball (:,ielm) = icache2 (:,eindex(ielm)) - lenbdall (:,ielm) = rcache2 (:,eindex(ielm)) - ENDDO - - deallocate (icache1, icache2, rcache2) -#endif - - IF (numelm > 0) THEN - - allocate (elementneighbour (numelm)) - - DO ielm = 1, numelm - nnb = nnball(ielm) - elementneighbour(ielm)%nnb = nnb - - IF (nnb > 0) THEN - allocate (elementneighbour(ielm)%glbindex (nnb)) - allocate (elementneighbour(ielm)%lenbdr (nnb)) - allocate (elementneighbour(ielm)%addr (2,nnb)) - - elementneighbour(ielm)%glbindex = idxnball(1:nnb,ielm) - elementneighbour(ielm)%lenbdr = lenbdall(1:nnb,ielm) - elementneighbour(ielm)%addr(1,:) = -9999 - ENDIF - ENDDO - ENDIF - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_root) THEN - DO iwork = 0, p_np_compute-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - allocate (eindex (nrecv)) - allocate (icache1 (nrecv)) - - CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - icache1 = addrelement(eindex) - - idest = isrc - CALL mpi_send (icache1, nrecv, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate(eindex, icache1) - ENDIF - ENDDO - ENDIF -#endif - - IF (p_is_compute) THEN - - IF (numelm > 0) THEN - allocate (elm_sorted (numelm)) - allocate (order (numelm)) - - elm_sorted = eindex - order = (/(ielm, ielm = 1, numelm)/) - - CALL quicksort (numelm, elm_sorted, order) - -#ifdef USEMPI - allocate(idxinq (numelm*maxnnb)) -#endif - - nnbinq = 0 - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - - IF (elementneighbour(ielm)%glbindex(inb) <= 0) CYCLE ! skip ocean neighbour - - iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), numelm, elm_sorted) - IF (iloc > 0) THEN - elementneighbour(ielm)%addr(1,inb) = -1 - elementneighbour(ielm)%addr(2,inb) = order(iloc) -#ifdef USEMPI - ELSE - CALL insert_into_sorted_list1 (elementneighbour(ielm)%glbindex(inb), nnbinq, idxinq, iloc) -#endif - ENDIF - ENDDO - ENDDO - ELSE - nnbinq = 0 - ENDIF - -#ifdef USEMPI - mesg(1:2) = (/p_iam_glb, nnbinq/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (nnbinq > 0) THEN - - CALL mpi_send (idxinq(1:nnbinq), nnbinq, MPI_INTEGER8, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (addrinq (nnbinq)) - CALL mpi_recv (addrinq, nnbinq, MPI_INTEGER, & - p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - ENDIF - - IF (nnbinq > 0) allocate(mask (nnbinq)) - - allocate (recvaddr (0:p_np_compute-1)) - DO iwork = 0, p_np_compute-1 - IF (nnbinq > 0) THEN - mask = (addrinq == p_address_compute(iwork)) - ndata = count(mask) - ELSE - ndata = 0 - ENDIF - - recvaddr(iwork)%ndata = ndata - IF (ndata > 0) THEN - allocate (recvaddr(iwork)%glbindex (ndata)) - recvaddr(iwork)%glbindex = pack(idxinq(1:nnbinq), mask) - ENDIF - ENDDO - - IF (nnbinq > 0) deallocate(mask) - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF ((elementneighbour(ielm)%addr(1,inb) == -9999) & - .and. (elementneighbour(ielm)%glbindex(inb) > 0)) THEN ! skip ocean neighbour - - iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & - nnbinq, idxinq(1:nnbinq)) - - iwork = p_itis_compute(addrinq(iloc)) - iloc1 = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & - recvaddr(iwork)%ndata, recvaddr(iwork)%glbindex) - - elementneighbour(ielm)%addr(1,inb) = iwork - elementneighbour(ielm)%addr(2,inb) = iloc1 - ENDIF - ENDDO - ENDDO - - allocate (sendaddr (0:p_np_compute-1)) - DO iwork = 0, p_np_compute-1 - sendaddr(iwork)%ndata = 0 - ENDDO - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN - iwork = elementneighbour(ielm)%addr(1,inb) - sendaddr(iwork)%ndata = sendaddr(iwork)%ndata + 1 - ENDIF - ENDDO - ENDDO - - DO iwork = 0, p_np_compute-1 - IF (sendaddr(iwork)%ndata > 0) THEN - allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) - sendaddr(iwork)%ndata = 0 - ENDIF - ENDDO - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN - iwork = elementneighbour(ielm)%addr(1,inb) - CALL insert_into_sorted_list1 (eindex(ielm), & - sendaddr(iwork)%ndata, sendaddr(iwork)%glbindex, iloc) - ENDIF - ENDDO - ENDDO - - DO iwork = 0, p_np_compute-1 - IF (sendaddr(iwork)%ndata > 0) THEN - IF (sendaddr(iwork)%ndata < size(sendaddr(iwork)%glbindex)) THEN - allocate (icache1 (sendaddr(iwork)%ndata)) - icache1 = sendaddr(iwork)%glbindex(1:sendaddr(iwork)%ndata) - - deallocate (sendaddr(iwork)%glbindex) - allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) - sendaddr(iwork)%glbindex = icache1 - - deallocate (icache1) - ENDIF - ENDIF - ENDDO - - DO iwork = 0, p_np_compute-1 - IF (sendaddr(iwork)%ndata > 0) THEN - allocate (sendaddr(iwork)%ielement (sendaddr(iwork)%ndata)) - - DO inb = 1, sendaddr(iwork)%ndata - iloc = find_in_sorted_list1 (sendaddr(iwork)%glbindex(inb), numelm, elm_sorted) - sendaddr(iwork)%ielement(inb) = order(iloc) - ENDDO - ENDIF - ENDDO -#endif - ENDIF - - IF (allocated(addrelement)) deallocate(addrelement) - IF (allocated(elm_sorted )) deallocate(elm_sorted ) - IF (allocated(nnball )) deallocate(nnball ) - IF (allocated(idxnball )) deallocate(idxnball ) - IF (allocated(lenbdall )) deallocate(lenbdall ) - IF (allocated(eindex )) deallocate(eindex ) - IF (allocated(icache1 )) deallocate(icache1 ) - IF (allocated(icache2 )) deallocate(icache2 ) - IF (allocated(rcache2 )) deallocate(rcache2 ) - IF (allocated(order )) deallocate(order ) - IF (allocated(idxinq )) deallocate(idxinq ) - IF (allocated(addrinq )) deallocate(addrinq ) - IF (allocated(mask )) deallocate(mask ) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - write(cyear,'(i4.4)') lc_year - lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/elevation_patches.nc' - CALL ncio_read_vector (lndname, 'elevation_patches', landpatch, elv_patches) - - IF (p_is_compute) THEN - - DO ielm = 1, numelm - nnb = elementneighbour(ielm)%nnb - IF (nnb > 0) THEN - allocate (elementneighbour(ielm)%dist (nnb)) - allocate (elementneighbour(ielm)%area (nnb)) - allocate (elementneighbour(ielm)%elva (nnb)) - allocate (elementneighbour(ielm)%slope (nnb)) - ENDIF - ENDDO - - IF (numelm > 0) THEN - allocate (rlon_b(numelm)) - allocate (rlat_b(numelm)) - CALL landelm%get_lonlat_radian (rlon_b, rlat_b) - ENDIF - - CALL allocate_neighbour_data (rlon_nb) - CALL allocate_neighbour_data (rlat_nb) - - CALL retrieve_neighbour_data (rlon_b, rlon_nb) - CALL retrieve_neighbour_data (rlat_b, rlat_nb) - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour - elementneighbour(ielm)%dist(inb) = 1.0e3 * arclen ( & - rlat_b (ielm), rlon_b (ielm), & - rlat_nb(ielm)%val(inb), rlon_nb(ielm)%val(inb)) - elementneighbour(ielm)%dist(inb) = max(elementneighbour(ielm)%dist(inb), 90.) - ENDIF - ENDDO - ENDDO - - IF (numelm > 0) THEN - allocate (area_b(numelm)) - allocate (elva_b(numelm)) - DO ielm = 1, numelm - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - area_b(ielm) = sum(patcharea(istt:iend)) - elva_b(ielm) = sum(elv_patches(istt:iend) * elm_patch%subfrc(istt:iend)) - - elementneighbour(ielm)%myarea = area_b(ielm) - elementneighbour(ielm)%myelva = elva_b(ielm) - ENDDO - ENDIF - - CALL allocate_neighbour_data (area_nb) - CALL retrieve_neighbour_data (area_b, area_nb) - - CALL allocate_neighbour_data (elva_nb) - CALL retrieve_neighbour_data (elva_b, elva_nb) - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour - elementneighbour(ielm)%area (inb) = area_nb(ielm)%val(inb) - elementneighbour(ielm)%elva (inb) = elva_nb(ielm)%val(inb) - elementneighbour(ielm)%slope(inb) = & - abs(elva_nb(ielm)%val(inb) - elva_b(ielm)) / elementneighbour(ielm)%dist(inb) - ENDIF - ENDDO - ENDDO - - IF (allocated(rlon_b )) deallocate(rlon_b ) - IF (allocated(rlat_b )) deallocate(rlat_b ) - IF (allocated(elva_b )) deallocate(elva_b ) - IF (allocated(area_b )) deallocate(area_b ) - IF (allocated(rlon_nb)) deallocate(rlon_nb) - IF (allocated(rlat_nb)) deallocate(rlat_nb) - IF (allocated(area_nb)) deallocate(area_nb) - IF (allocated(elva_nb)) deallocate(elva_nb) - - ENDIF - - END SUBROUTINE element_neighbour_init - - ! ---------- - SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Mesh, only: numelm - IMPLICIT NONE - - real(r8), intent(inout) :: vec_in (:) - type(pointer_real8_1d) :: nbdata (:) - - ! Local Variables - logical, allocatable :: smask(:), rmask(:) - integer, allocatable :: req_send(:), req_recv(:) - type(pointer_real8_1d), allocatable :: sbuff(:), rbuff(:) - integer :: iwork, ielm, inb, iloc - - IF (p_is_compute) THEN - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%addr(1,inb)== -1) THEN - iloc = elementneighbour(ielm)%addr(2,inb) - nbdata(ielm)%val(inb) = vec_in(iloc) - ENDIF - ENDDO - ENDDO - -#ifdef USEMPI - CALL mpi_barrier (p_comm_compute, p_err) - - allocate (smask (0:p_np_compute-1)) - allocate (req_send (0:p_np_compute-1)) - allocate (sbuff (0:p_np_compute-1)) - smask(:) = .false. - - DO iwork = 0, p_np_compute-1 - IF (sendaddr(iwork)%ndata > 0) THEN - smask(iwork) = .true. - - allocate (sbuff(iwork)%val (sendaddr(iwork)%ndata)) - sbuff(iwork)%val = vec_in(sendaddr(iwork)%ielement) - - CALL mpi_isend(sbuff(iwork)%val, sendaddr(iwork)%ndata, MPI_REAL8, & - p_address_compute(iwork), 101, p_comm_glb, req_send(iwork), p_err) - ENDIF - ENDDO - - allocate (rmask (0:p_np_compute-1)) - allocate (req_recv (0:p_np_compute-1)) - allocate (rbuff (0:p_np_compute-1)) - rmask(:) = .false. - - DO iwork = 0, p_np_compute-1 - IF (recvaddr(iwork)%ndata > 0) THEN - rmask(iwork) = .true. - - allocate (rbuff(iwork)%val (recvaddr(iwork)%ndata)) - - CALL mpi_irecv(rbuff(iwork)%val, recvaddr(iwork)%ndata, MPI_REAL8, & - p_address_compute(iwork), 101, p_comm_glb, req_recv(iwork), p_err) - ENDIF - ENDDO - - IF (any(rmask)) THEN - - CALL mpi_waitall(count(rmask), pack(req_recv,rmask), MPI_STATUSES_IGNORE, p_err) - - DO ielm = 1, numelm - DO inb = 1, elementneighbour(ielm)%nnb - IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN - iwork = elementneighbour(ielm)%addr(1,inb) - iloc = elementneighbour(ielm)%addr(2,inb) - nbdata(ielm)%val(inb) = rbuff(iwork)%val(iloc) - ENDIF - ENDDO - ENDDO - ENDIF - - IF (any(smask)) THEN - CALL mpi_waitall(count(smask), pack(req_send,smask), MPI_STATUSES_IGNORE, p_err) - ENDIF - - IF (allocated(smask)) deallocate(smask) - IF (allocated(rmask)) deallocate(rmask) - - IF (allocated(req_send)) deallocate(req_send) - IF (allocated(req_recv)) deallocate(req_recv) - - IF (allocated(sbuff)) deallocate(sbuff) - IF (allocated(rbuff)) deallocate(rbuff) - - CALL mpi_barrier (p_comm_compute, p_err) -#endif - - ENDIF - - END SUBROUTINE retrieve_neighbour_data - - ! --- - SUBROUTINE allocate_neighbour_data_real8 (nbdata) - - USE MOD_Mesh, only: numelm - IMPLICIT NONE - - type(pointer_real8_1d), allocatable :: nbdata(:) - integer :: ielm - - IF (numelm > 0) THEN - allocate (nbdata(numelm)) - DO ielm = 1, numelm - IF (elementneighbour(ielm)%nnb > 0) THEN - allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb)) - ENDIF - ENDDO - ENDIF - - END SUBROUTINE allocate_neighbour_data_real8 - - ! --- - SUBROUTINE allocate_neighbour_data_logic (nbdata) - - USE MOD_Mesh, only: numelm - IMPLICIT NONE - - type(pointer_logic_1d), allocatable :: nbdata(:) - integer :: ielm - - IF (numelm > 0) THEN - allocate (nbdata(numelm)) - DO ielm = 1, numelm - IF (elementneighbour(ielm)%nnb > 0) THEN - allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb)) - ENDIF - ENDDO - ENDIF - - END SUBROUTINE allocate_neighbour_data_logic - - ! ---------- - SUBROUTINE element_neighbour_final () - - IMPLICIT NONE - integer :: i - - IF (allocated(elementneighbour)) THEN - DO i = 1, size(elementneighbour) - IF (allocated(elementneighbour(i)%glbindex)) deallocate(elementneighbour(i)%glbindex) - IF (allocated(elementneighbour(i)%addr )) deallocate(elementneighbour(i)%addr ) - IF (allocated(elementneighbour(i)%dist )) deallocate(elementneighbour(i)%dist ) - IF (allocated(elementneighbour(i)%lenbdr)) deallocate(elementneighbour(i)%lenbdr) - IF (allocated(elementneighbour(i)%area )) deallocate(elementneighbour(i)%area ) - IF (allocated(elementneighbour(i)%elva )) deallocate(elementneighbour(i)%elva ) - IF (allocated(elementneighbour(i)%slope )) deallocate(elementneighbour(i)%slope ) - ENDDO - deallocate(elementneighbour) - ENDIF - - IF (allocated(recvaddr)) THEN - DO i = lbound(recvaddr,1), ubound(recvaddr,1) - IF (allocated(recvaddr(i)%glbindex)) deallocate(recvaddr(i)%glbindex) - IF (allocated(recvaddr(i)%ielement)) deallocate(recvaddr(i)%ielement) - ENDDO - ENDIF - - IF (allocated(sendaddr)) THEN - DO i = lbound(sendaddr,1), ubound(sendaddr,1) - IF (allocated(sendaddr(i)%glbindex)) deallocate(sendaddr(i)%glbindex) - IF (allocated(sendaddr(i)%ielement)) deallocate(sendaddr(i)%ielement) - ENDDO - ENDIF - - IF (allocated(recvaddr)) deallocate(recvaddr) - IF (allocated(sendaddr)) deallocate(sendaddr) - - END SUBROUTINE element_neighbour_final - -END MODULE MOD_ElementNeighbour diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 index d41418d8ce..35bf99ce06 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -12,8 +12,8 @@ MODULE MOD_Grid_Reservoir USE MOD_Precision USE MOD_DataType - integer :: totalnumresv - integer :: numresv + integer :: totalnumresv = 0 + integer :: numresv = 0 integer, allocatable :: ucat2resv (:) integer, allocatable :: resv_global_index(:) type(pointer_int32_1d), allocatable :: resv_data_address (:) @@ -47,11 +47,12 @@ MODULE MOD_Grid_Reservoir ! ------- SUBROUTINE reservoir_init ( ) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_Utils - USE MOD_Namelist, only: DEF_ReservoirPara_file - USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid, lake_type + USE MOD_Namelist, only: DEF_ReservoirPara_file + USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid, lake_type + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE @@ -63,14 +64,17 @@ SUBROUTINE reservoir_init ( ) integer, allocatable :: icache (:) integer, parameter :: dam_seq_chunk_size = 1048576 - integer :: i, iloc, irsv, nresv, irank - integer :: istart, iend, local_index + integer :: i, iloc, irsv +#ifndef MPAS_EMBEDDED_COLM + integer :: nresv, irank +#endif + integer :: istart, iend, local_index, global_resv_index parafile = DEF_ReservoirPara_file #ifndef MPAS_EMBEDDED_COLM - IF (p_is_root) THEN + IF (mpas_is_root) THEN CALL ncio_read_serial (parafile, 'dam_GRAND_ID', dam_GRAND_ID) ENDIF @@ -81,7 +85,7 @@ SUBROUTINE reservoir_init ( ) CALL ncio_inquire_length (parafile, 'dam_seq', totalnumresv) #endif - IF (p_is_compute) THEN + IF (.true.) THEN allocate (ucat2resv (numucat)) ucat2resv = 0 @@ -107,12 +111,14 @@ SUBROUTINE reservoir_init ( ) iloc = find_in_sorted_list1 (dam_seq(i), numucat, local_ucid) IF (iloc > 0) THEN local_index = order(iloc) - IF (ucat2resv(local_index) == 0) THEN - numresv = numresv + 1 - lake_type(local_index) = 2 - ucat2resv(local_index) = numresv - resv_global_index(numresv) = i - ENDIF + global_resv_index = istart + i - lbound(dam_seq,1) + IF (ucat2resv(local_index) /= 0) THEN + CALL CoLM_stop('Duplicate dam_seq entry for a local embedded CoLM unit catchment.') + ENDIF + numresv = numresv + 1 + lake_type(local_index) = 2 + ucat2resv(local_index) = numresv + resv_global_index(numresv) = global_resv_index ENDIF ENDDO @@ -140,39 +146,39 @@ SUBROUTINE reservoir_init ( ) ENDIF #ifndef MPAS_EMBEDDED_COLM -#ifdef COLM_PARALLEL - IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:p_np_compute-1)) +#ifdef MPAS_MPI + IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:mpas_size-1)) - IF (p_is_root) THEN - DO irank = 0, p_np_compute-1 + IF (mpas_is_root) THEN + DO irank = 0, mpas_size-1 - IF (p_address_compute(irank) == p_iam_glb) THEN + IF (irank == mpas_rank) THEN nresv = numresv ELSE CALL mpi_recv (nresv, 1, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_stat, p_err) + irank, mpi_tag_mesg, mpas_comm, mpas_status, mpas_mpi_ierr) ENDIF IF (nresv > 0) THEN allocate (resv_data_address(irank)%val (nresv)) - IF (p_address_compute(irank) == p_iam_glb) THEN + IF (irank == mpas_rank) THEN resv_data_address(irank)%val = resv_global_index(1:nresv) ELSE CALL mpi_recv (resv_data_address(irank)%val, nresv, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_data, p_comm_glb, p_stat, p_err) + irank, mpi_tag_data, mpas_comm, mpas_status, mpas_mpi_ierr) ENDIF ENDIF ENDDO ENDIF - IF (p_is_compute .and. (.not. p_is_root)) THEN + IF (.true. .and. (.not. mpas_is_root)) THEN - CALL mpi_send (numresv, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (numresv, 1, MPI_INTEGER, mpas_root, mpi_tag_mesg, mpas_comm, mpas_mpi_ierr) IF (numresv > 0) THEN - CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_err) + CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, mpas_root, & + mpi_tag_data, mpas_comm, mpas_mpi_ierr) ENDIF ENDIF @@ -185,7 +191,7 @@ SUBROUTINE reservoir_init ( ) #endif #endif - IF (p_is_compute) THEN + IF (.true.) THEN IF (numresv > 0) THEN @@ -200,15 +206,17 @@ SUBROUTINE reservoir_init ( ) allocate (qresv_adjust (numresv)) allocate (qresv_normal (numresv)) - allocate (qresv_in (numresv)) - allocate (qresv_out (numresv)) + allocate (qresv_in (numresv)) + allocate (qresv_out (numresv)) + qresv_in(:) = 0._r8 + qresv_out(:) = 0._r8 ENDIF ENDIF #ifdef MPAS_EMBEDDED_COLM - IF (p_is_compute .and. (numresv > 0)) THEN + IF (.true. .and. (numresv > 0)) THEN CALL ncio_read_indexed_serial (parafile, 'dam_year', resv_global_index(1:numresv), icache) dam_build_year = icache @@ -226,34 +234,51 @@ SUBROUTINE reservoir_init ( ) ENDIF #else CALL ncio_read_bcast_serial (parafile, 'dam_year', icache) - IF (p_is_compute .and. (numresv > 0)) THEN + IF (.true. .and. (numresv > 0)) THEN dam_build_year = icache(resv_global_index(1:numresv)) ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_TotalVol_mcm', rcache) - IF (p_is_compute .and. (numresv > 0)) THEN + IF (.true. .and. (numresv > 0)) THEN volresv_total = rcache(resv_global_index(1:numresv))*1.e6 ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_ConVol_mcm', rcache) - IF (p_is_compute .and. (numresv > 0)) THEN + IF (.true. .and. (numresv > 0)) THEN volresv_normal = rcache(resv_global_index(1:numresv))*1.e6 ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_Qn', rcache) - IF (p_is_compute .and. (numresv > 0)) THEN + IF (.true. .and. (numresv > 0)) THEN qresv_normal = rcache(resv_global_index(1:numresv)) ENDIF CALL ncio_read_bcast_serial (parafile, 'dam_Qf', rcache) - IF (p_is_compute .and. (numresv > 0)) THEN + IF (.true. .and. (numresv > 0)) THEN qresv_flood = rcache(resv_global_index(1:numresv)) ENDIF #endif - IF (p_is_compute) THEN - DO irsv = 1, numresv + IF (.true.) THEN + IF (numresv > 0) THEN + IF (any(resv_global_index(1:numresv) < 1) .or. & + any(resv_global_index(1:numresv) > totalnumresv)) THEN + CALL CoLM_stop('Embedded CoLM reservoir index is outside the parameter file.') + ENDIF + IF (.not. all(ieee_is_finite(volresv_total)) .or. & + .not. all(ieee_is_finite(volresv_normal)) .or. & + .not. all(ieee_is_finite(qresv_normal)) .or. & + .not. all(ieee_is_finite(qresv_flood))) THEN + CALL CoLM_stop('Embedded CoLM reservoir parameters contain non-finite values.') + ENDIF + IF (any(dam_build_year <= 0) .or. any(volresv_total <= 0._r8) .or. & + any(volresv_normal <= 0._r8) .or. any(volresv_normal > volresv_total) .or. & + any(qresv_normal < 0._r8) .or. any(qresv_flood < qresv_normal)) THEN + CALL CoLM_stop('Embedded CoLM reservoir parameters are outside their physical ranges.') + ENDIF + ENDIF + DO irsv = 1, numresv volresv_emerg (irsv) = volresv_total(irsv) * 0.94 volresv_adjust(irsv) = volresv_total(irsv) * 0.77 volresv_normal(irsv) = min(volresv_total(irsv)*0.7, volresv_normal(irsv)) @@ -263,24 +288,37 @@ SUBROUTINE reservoir_init ( ) IF (allocated(dam_seq)) deallocate(dam_seq) IF (allocated(order )) deallocate(order ) + IF (allocated(local_ucid)) deallocate(local_ucid) IF (allocated(rcache )) deallocate(rcache ) IF (allocated(icache )) deallocate(icache ) END SUBROUTINE reservoir_init - SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) + SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) - IMPLICIT NONE + USE MOD_MPAS_MPI, only: CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE integer, intent(in) :: method integer, intent(in) :: irsv real(r8), intent(in) :: qin, vol real(r8), intent(out) :: qout ! local variables - real(r8) :: q1 - - IF (method == 1) THEN + real(r8) :: q1 + + IF (irsv < 1 .or. irsv > numresv) THEN + CALL CoLM_stop('Embedded CoLM reservoir operation received an invalid local reservoir index.') + ENDIF + IF (.not. ieee_is_finite(qin) .or. .not. ieee_is_finite(vol) .or. vol < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM reservoir operation received invalid state or forcing.') + ENDIF + IF (method /= 1) THEN + CALL CoLM_stop('Unsupported embedded CoLM reservoir operation method.') + ENDIF + + IF (method == 1) THEN ! *** Reference *** ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. ! Development of an improved reservoir operation scheme for global flood modeling. @@ -331,6 +369,9 @@ SUBROUTINE reservoir_final () IF (allocated(qresv_in )) deallocate (qresv_in ) IF (allocated(qresv_out )) deallocate (qresv_out ) + totalnumresv = 0 + numresv = 0 + END SUBROUTINE reservoir_final END MODULE MOD_Grid_Reservoir diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index 790931e487..0d12dab18a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -10,12 +10,11 @@ MODULE MOD_Grid_RiverLakeFlow !------------------------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_Grid_RiverLakeNetwork USE MOD_Grid_RiverLakeTimeVars USE MOD_Grid_Reservoir - USE MOD_Grid_RiverLakeHist #ifdef GridRiverLakeSediment USE MOD_Grid_RiverLakeSediment, only: grid_sediment_init, grid_sediment_calc, & grid_sediment_final, sediment_diag_accumulate, sediment_forcing_put, & @@ -27,8 +26,6 @@ MODULE MOD_Grid_RiverLakeFlow real(r8), save :: acctime_rnof_max - real(r8) :: acctime_rnof - real(r8), allocatable :: acc_rnof_uc (:) logical, allocatable :: filter_rnof (:) CONTAINS @@ -37,29 +34,35 @@ MODULE MOD_Grid_RiverLakeFlow SUBROUTINE grid_riverlake_flow_init () USE MOD_LandPatch, only: numpatch - USE MOD_Forcing, only: forcmask_pch USE MOD_Vars_TimeInvariants, only: patchtype, patchmask + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE - acctime_rnof_max = DEF_GRIDBASED_ROUTING_MAX_DT - acctime_rnof = 0. - - IF (p_is_compute) THEN - ! Allocate on all ranks (zero-length if numucat/numpatch=0) - ! to avoid passing unallocated arrays to assumed-shape MPI wrappers. - allocate (acc_rnof_uc (numucat)) - acc_rnof_uc = 0. + IF (.not. ieee_is_finite(DEF_GRIDBASED_ROUTING_MAX_DT) .or. & + DEF_GRIDBASED_ROUTING_MAX_DT <= 0._r8) THEN + CALL CoLM_stop('DEF_GRIDBASED_ROUTING_MAX_DT must be finite and positive.') ENDIF + acctime_rnof_max = DEF_GRIDBASED_ROUTING_MAX_DT ! excluding (patchtype >= 99), virtual patches and those forcing missed - IF (p_is_compute) THEN + IF (.true.) THEN + IF (.not. allocated(wdsrf_ucat) .or. .not. allocated(veloc_riv) .or. & + .not. allocated(momen_riv) .or. .not. allocated(acc_rnof_uc)) THEN + CALL CoLM_stop('Embedded CoLM river state is not allocated.') + ENDIF + IF (size(wdsrf_ucat) /= numucat .or. size(veloc_riv) /= numucat .or. & + size(momen_riv) /= numucat .or. size(acc_rnof_uc) /= numucat) THEN + CALL CoLM_stop('Embedded CoLM river state dimensions do not match local unit catchments.') + ENDIF + IF (DEF_Reservoir_Method > 0) THEN + IF (.not. allocated(volresv) .or. size(volresv) /= numresv) THEN + CALL CoLM_stop('Embedded CoLM reservoir state dimensions do not match local reservoirs.') + ENDIF + ENDIF allocate (filter_rnof (numpatch)) IF (numpatch > 0) THEN filter_rnof = patchtype < 99 filter_rnof = filter_rnof .and. patchmask - IF (DEF_forcing%has_missing_value) THEN - filter_rnof = filter_rnof .and. forcmask_pch - ENDIF ENDIF ENDIF @@ -78,23 +81,21 @@ SUBROUTINE grid_riverlake_flow (year, deltime) USE MOD_Utils USE MOD_Namelist, only: DEF_Reservoir_Method, DEF_USE_SEDIMENT USE MOD_Vars_1DFluxes, only: rnof - USE MOD_Mesh, only: numelm USE MOD_LandPatch, only: elm_patch, numpatch USE MOD_Const_Physical, only: grav USE MOD_Vars_Global, only: spval #ifdef GridRiverLakeSediment USE MOD_Vars_1DForcing, only: forc_prc, forc_prl #endif + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE integer, intent(in) :: year real(r8), intent(in) :: deltime ! Local Variables - integer :: i, j, irsv, ntimestep + integer :: i, irsv, ntimestep real(r8) :: dt_this - integer :: sed_clock_start, sed_clock_end, sed_clock_rate - real(r8) :: sed_elapsed real(r8), allocatable :: rnof_gd(:) real(r8), allocatable :: rnof_uc(:) @@ -114,6 +115,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) real(r8), allocatable :: hflux_fc(:) real(r8), allocatable :: mflux_fc(:) real(r8), allocatable :: zgrad_dn(:) + real(r8), allocatable :: acc_discharge(:) real(r8), allocatable :: hflux_resv(:) real(r8), allocatable :: mflux_resv(:) @@ -126,10 +128,10 @@ SUBROUTINE grid_riverlake_flow (year, deltime) real(r8), allocatable :: sum_mflux_riv(:) real(r8), allocatable :: sum_zgrad_riv(:) - real(r8) :: veloct_fc, height_fc, momen_fc, zsurf_fc + real(r8) :: veloct_fc, height_fc real(r8) :: bedelv_fc, height_up, height_dn real(r8) :: vwave_up, vwave_dn, hflux_up, hflux_dn, mflux_up, mflux_dn - real(r8) :: volwater, friction, floodarea + real(r8) :: volwater, friction real(r8), allocatable :: dt_res(:), dt_all(:) logical, allocatable :: ucatfilter(:) real(r8) :: global_dt_remaining(1) @@ -137,13 +139,25 @@ SUBROUTINE grid_riverlake_flow (year, deltime) real(r8) :: totalvol_bef, totalvol_aft, totalrnof, totaldis #endif + IF (.not. ieee_is_finite(deltime) .or. deltime <= 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing timestep must be finite and positive.') + ENDIF + IF (.not. ieee_is_finite(acctime_rnof) .or. acctime_rnof < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing accumulator time is invalid.') + ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN allocate (rnof_gd (numinpm)) allocate (rnof_uc (numucat)) IF (numpatch > 0) THEN + IF (size(filter_rnof) < numpatch .or. size(rnof) < numpatch) THEN + CALL CoLM_stop('Embedded CoLM runoff arrays do not match the local patch count.') + ENDIF + IF (any(filter_rnof(1:numpatch) .and. .not. ieee_is_finite(rnof(1:numpatch)))) THEN + CALL CoLM_stop('Embedded CoLM runoff contains non-finite values on active patches.') + ENDIF CALL compute_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & fillvalue = 0., filter = filter_rnof) ELSE @@ -160,7 +174,13 @@ SUBROUTINE grid_riverlake_flow (year, deltime) fillvalue = 0., mode = 'sum') IF (numucat > 0) THEN + IF (.not. all(ieee_is_finite(rnof_uc))) THEN + CALL CoLM_stop('Embedded CoLM unit-catchment runoff contains non-finite values.') + ENDIF acc_rnof_uc = acc_rnof_uc + rnof_uc*1.e-3*deltime + IF (.not. all(ieee_is_finite(acc_rnof_uc))) THEN + CALL CoLM_stop('Embedded CoLM accumulated runoff contains non-finite values.') + ENDIF ENDIF deallocate(rnof_gd) @@ -220,12 +240,15 @@ SUBROUTINE grid_riverlake_flow (year, deltime) acctime_rnof = acctime_rnof + deltime + IF (.not. ieee_is_finite(acctime_rnof)) THEN + CALL CoLM_stop('Embedded CoLM river routing accumulator time overflowed.') + ENDIF IF (acctime_rnof+0.01 < acctime_rnof_max) THEN RETURN ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN allocate (is_built_resv (numucat)) allocate (wdsrf_next (numucat)) @@ -233,6 +256,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) allocate (hflux_fc (numucat)) allocate (mflux_fc (numucat)) allocate (zgrad_dn (numucat)) + allocate (acc_discharge (numucat)) allocate (sum_hflux_riv (numucat)) allocate (sum_mflux_riv (numucat)) allocate (sum_zgrad_riv (numucat)) @@ -250,6 +274,19 @@ SUBROUTINE grid_riverlake_flow (year, deltime) allocate (dt_res (max(1,numrivsys))) allocate (dt_all (max(1,numrivsys))) + hflux_fc(:) = 0._r8 + mflux_fc(:) = 0._r8 + zgrad_dn(:) = 0._r8 + acc_discharge(:) = 0._r8 + sum_hflux_riv(:) = 0._r8 + sum_mflux_riv(:) = 0._r8 + sum_zgrad_riv(:) = 0._r8 + hflux_sumups(:) = 0._r8 + mflux_sumups(:) = 0._r8 + zgrad_sumups(:) = 0._r8 + IF (allocated(hflux_resv)) hflux_resv(:) = 0._r8 + IF (allocated(mflux_resv)) mflux_resv(:) = 0._r8 + #ifdef CoLMDEBUG totalrnof = sum(acc_rnof_uc) totalvol_bef = 0. @@ -262,7 +299,9 @@ SUBROUTINE grid_riverlake_flow (year, deltime) irsv = ucat2resv(i) IF (year >= dam_build_year(irsv)) THEN is_built_resv(i) = .true. - IF (volresv(irsv) == spval) THEN + IF (.not. ieee_is_finite(volresv(irsv))) THEN + CALL CoLM_stop('Embedded CoLM river routing received a non-finite reservoir volume.') + ELSEIF (abs(volresv(irsv)) >= 0.5_r8 * abs(spval)) THEN volresv(irsv) = floodplain_curve(i)%volume (wdsrf_ucat(i)) ELSE wdsrf_ucat(i) = floodplain_curve(i)%depth (volresv(irsv)) @@ -311,11 +350,13 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDDO global_dt_remaining(1) = maxval(dt_res) -#ifdef COLM_PARALLEL - IF (rivsys_by_multiple_procs) THEN - CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, p_comm_rivsys, p_err) - ENDIF +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM river routing failed to synchronize remaining time.') #endif + IF (.not. ieee_is_finite(global_dt_remaining(1)) .or. global_dt_remaining(1) < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing has invalid remaining integration time.') + ENDIF DO WHILE (global_dt_remaining(1) > 0._r8) @@ -330,16 +371,21 @@ SUBROUTINE grid_riverlake_flow (year, deltime) dt_all = min(dt_res, 60._r8) END WHERE + hflux_fc(:) = 0._r8 + mflux_fc(:) = 0._r8 + zgrad_dn(:) = 0._r8 + sum_hflux_riv(:) = 0._r8 + sum_mflux_riv(:) = 0._r8 + sum_zgrad_riv(:) = 0._r8 + IF (allocated(hflux_resv)) hflux_resv(:) = 0._r8 + IF (allocated(mflux_resv)) mflux_resv(:) = 0._r8 + DO i = 1, numucat ucatfilter(i) = dt_res(irivsys(i)) > 0._r8 IF (.not. ucatfilter(i)) CYCLE - sum_hflux_riv(i) = 0. - sum_mflux_riv(i) = 0. - sum_zgrad_riv(i) = 0. - ! reservoir IF (is_built_resv(i)) THEN hflux_fc(i) = 0. @@ -527,6 +573,13 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDIF + IF (numucat > 0) THEN + IF (any(ucatfilter .and. (.not. ieee_is_finite(sum_hflux_riv) .or. & + .not. ieee_is_finite(sum_mflux_riv) .or. .not. ieee_is_finite(sum_zgrad_riv)))) THEN + CALL CoLM_stop('Embedded CoLM river routing produced non-finite fluxes.') + ENDIF + ENDIF + DO i = 1, numucat IF (.not. ucatfilter(i)) CYCLE @@ -535,7 +588,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ! constraint 1: CFL condition (only for rivers) IF (.not. is_built_resv(i)) THEN - IF ((veloc_riv(i) /= 0.) .or. (wdsrf_ucat(i) > 0.)) THEN + IF ((abs(veloc_riv(i)) > 0._r8) .or. (wdsrf_ucat(i) > 0._r8)) THEN dt_this = min(dt_this, topo_rivlen(i)/(abs(veloc_riv(i))+sqrt(grav*wdsrf_ucat(i)))*0.8) ENDIF ENDIF @@ -567,12 +620,23 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDDO -#ifdef COLM_PARALLEL - IF (rivsys_by_multiple_procs) THEN - CALL mpi_allreduce (MPI_IN_PLACE, dt_all, size(dt_all), MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err) - ENDIF +#ifdef MPAS_MPI + CALL synchronize_river_system_min(dt_all) #endif + DO i = 1, numrivsys + IF (dt_res(i) > 0._r8) THEN + IF (.not. ieee_is_finite(dt_all(i)) .or. dt_all(i) <= 0._r8 .or. dt_all(i) > dt_res(i)) THEN + CALL CoLM_stop('Embedded CoLM river routing produced an invalid integration substep.') + ENDIF + IF (dt_all(i) < dt_res(i)) THEN + IF (dt_res(i) - dt_all(i) >= dt_res(i)) THEN + CALL CoLM_stop('Embedded CoLM river routing substep cannot advance floating-point time.') + ENDIF + ENDIF + ENDIF + ENDDO + DO i = 1, numucat IF (.not. ucatfilter(i)) CYCLE @@ -619,11 +683,13 @@ SUBROUTINE grid_riverlake_flow (year, deltime) veloc_riv(i) = min(veloc_riv(i), 20.) veloc_riv(i) = max(veloc_riv(i), -20.) + momen_riv(i) = wdsrf_ucat(i) * veloc_riv(i) ENDDO DO i = 1, numucat - IF (ucatfilter(i)) THEN + IF (ucatfilter(i)) THEN + acc_discharge(i) = acc_discharge(i) + hflux_fc(i) * dt_all(irivsys(i)) #ifdef CoLMDEBUG IF (ucat_next(i) <= 0) THEN @@ -631,29 +697,6 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDIF #endif - IF (allocated(acctime_ucat) .and. allocated(a_wdsrf_ucat) .and. & - allocated(a_veloc_riv) .and. allocated(a_discharge) .and. & - allocated(a_floodarea)) THEN - acctime_ucat(i) = acctime_ucat(i) + dt_all(irivsys(i)) - - a_wdsrf_ucat(i) = a_wdsrf_ucat(i) + wdsrf_ucat(i) * dt_all(irivsys(i)) - a_veloc_riv (i) = a_veloc_riv (i) + veloc_riv (i) * dt_all(irivsys(i)) - a_discharge (i) = a_discharge (i) + hflux_fc (i) * dt_all(irivsys(i)) - - floodarea = floodplain_curve(i)%floodarea (wdsrf_ucat(i)) - a_floodarea (i) = a_floodarea (i) + floodarea * dt_all(irivsys(i)) - - IF (is_built_resv(i) .and. allocated(acctime_resv) .and. & - allocated(a_volresv) .and. allocated(a_qresv_in) .and. & - allocated(a_qresv_out)) THEN - irsv = ucat2resv(i) - acctime_resv(irsv) = acctime_resv(irsv) + dt_all(irivsys(i)) - a_volresv (irsv) = a_volresv (irsv) + volresv (irsv) * dt_all(irivsys(i)) - a_qresv_in (irsv) = a_qresv_in (irsv) + qresv_in (irsv) * dt_all(irivsys(i)) - a_qresv_out (irsv) = a_qresv_out(irsv) + qresv_out(irsv) * dt_all(irivsys(i)) - ENDIF - ENDIF - ENDIF ENDDO @@ -662,11 +705,13 @@ SUBROUTINE grid_riverlake_flow (year, deltime) END WHERE global_dt_remaining(1) = maxval(dt_res) -#ifdef COLM_PARALLEL - IF (rivsys_by_multiple_procs) THEN - CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, p_comm_rivsys, p_err) - ENDIF +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM river routing failed to synchronize remaining time.') #endif + IF (.not. ieee_is_finite(global_dt_remaining(1)) .or. global_dt_remaining(1) < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing has invalid remaining integration time.') + ENDIF #ifdef GridRiverLakeSediment IF (DEF_USE_SEDIMENT) THEN @@ -703,21 +748,21 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDIF #ifdef CoLMDEBUG -#ifdef COLM_PARALLEL - IF (.not. p_is_compute) ntimestep = 0 - CALL mpi_allreduce (MPI_IN_PLACE, ntimestep, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err) - - IF (.not. p_is_compute) totalvol_bef = 0. - IF (.not. p_is_compute) totalvol_aft = 0. - IF (.not. p_is_compute) totalrnof = 0. - IF (.not. p_is_compute) totaldis = 0. - - CALL mpi_allreduce (MPI_IN_PLACE, totalvol_bef, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, totalvol_aft, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, totalrnof, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, totaldis, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err) +#ifdef MPAS_MPI + IF (.not. .true.) ntimestep = 0 + CALL mpi_allreduce (MPI_IN_PLACE, ntimestep, 1, MPI_INTEGER, MPI_MAX, mpas_comm, mpas_mpi_ierr) + + IF (.not. .true.) totalvol_bef = 0. + IF (.not. .true.) totalvol_aft = 0. + IF (.not. .true.) totalrnof = 0. + IF (.not. .true.) totaldis = 0. + + CALL mpi_allreduce (MPI_IN_PLACE, totalvol_bef, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpi_allreduce (MPI_IN_PLACE, totalvol_aft, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpi_allreduce (MPI_IN_PLACE, totalrnof, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpi_allreduce (MPI_IN_PLACE, totaldis, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(/,A)') 'Checking River Routing Flow ...' write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', acctime_rnof/ntimestep, ' seconds' write(*,'(A,ES8.1,A)') 'Total water before : ', totalvol_bef, ' m^3' @@ -729,7 +774,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) #endif #ifdef GridRiverLakeSediment - IF (DEF_USE_SEDIMENT .and. p_is_compute) THEN + IF (DEF_USE_SEDIMENT .and. .true.) THEN ! All ranks must participate (MPI point-to-point inside push_data). ! fldfrc is now computed inside grid_sediment_calc from per-routing-period ! accumulators (sed_acc_floodarea), not from history-period averages. @@ -737,9 +782,22 @@ SUBROUTINE grid_riverlake_flow (year, deltime) ENDIF #endif + IF (.true.) THEN + IF (acctime_rnof <= 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing cannot form diagnostics over a non-positive period.') + ENDIF + IF (numucat > 0) THEN + discharge_riv = acc_discharge / acctime_rnof + IF (.not. all(ieee_is_finite(discharge_riv))) THEN + CALL CoLM_stop('Embedded CoLM river routing produced non-finite period-mean discharge.') + ENDIF + ENDIF + ENDIF + CALL update_GridRiverLakeElementDiagnostics() + acctime_rnof = 0. - IF (p_is_compute) THEN + IF (.true.) THEN IF (numucat > 0) THEN acc_rnof_uc = 0. ENDIF @@ -751,6 +809,7 @@ SUBROUTINE grid_riverlake_flow (year, deltime) IF (allocated(hflux_fc )) deallocate(hflux_fc ) IF (allocated(mflux_fc )) deallocate(mflux_fc ) IF (allocated(zgrad_dn )) deallocate(zgrad_dn ) + IF (allocated(acc_discharge)) deallocate(acc_discharge) IF (allocated(hflux_resv )) deallocate(hflux_resv ) IF (allocated(mflux_resv )) deallocate(mflux_resv ) IF (allocated(hflux_sumups )) deallocate(hflux_sumups ) @@ -778,7 +837,6 @@ SUBROUTINE grid_riverlake_flow_final () CALL grid_sediment_final() #endif - IF (allocated(acc_rnof_uc)) deallocate(acc_rnof_uc) IF (allocated(filter_rnof)) deallocate(filter_rnof) END SUBROUTINE grid_riverlake_flow_final diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 deleted file mode 100644 index 033dec6575..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90 +++ /dev/null @@ -1,756 +0,0 @@ -#include - -#ifdef GridRiverLakeFlow -MODULE MOD_Grid_RiverLakeHist -!-------------------------------------------------------------------------------- -! DESCRIPTION: -! -! Write out model results in lateral hydrological processes to history files. -! -! Created by Shupeng Zhang, May 2023 -!-------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_DataType -#ifdef GridRiverLakeSediment - USE MOD_Grid_RiverLakeSediment, only: nsed, sed_hist_acctime, & - a_sedcon, a_sedout, a_bedout, a_sedinp, a_netflw, a_layer, a_shearvel -#endif - - ! -- ACC Fluxes -- - real(r8), allocatable :: acctime_ucat (:) - - real(r8), allocatable :: a_wdsrf_ucat (:) - real(r8), allocatable :: a_veloc_riv (:) - real(r8), allocatable :: a_discharge (:) - real(r8), allocatable :: a_floodarea (:) ! flooded area [m^2] - - real(r8), allocatable :: a_wdsrf_ucat_pch (:) - real(r8), allocatable :: a_veloc_riv_pch (:) - real(r8), allocatable :: a_discharge_pch (:) - real(r8), allocatable :: a_dis_rmth_pch (:) - real(r8), allocatable :: a_floodfrc_pch (:) ! flooded area [m^2] - - ! for reservoirs - real(r8), allocatable :: acctime_resv (:) - - real(r8), allocatable :: a_volresv (:) ! reservoir water volume [m^3] - real(r8), allocatable :: a_qresv_in (:) ! inflow to reservoir [m^3/s] - real(r8), allocatable :: a_qresv_out (:) ! outflow from reservoir [m^3/s] - - ! grid information - real(r8), allocatable :: lon_ucat (:) - real(r8), allocatable :: lat_ucat (:) - - ! auxiliary data - type(block_data_real8_2d) :: sumarea_ucat ! 1) area covered by unit catchments - logical, allocatable :: filter_ucat (:) - real(r8), allocatable :: sum_grid_area (:) ! sum area of patches inside one grid - - logical, allocatable :: filter_rivmth (:) ! 2) area covered by river mouths - real(r8), allocatable :: sum_rmth_area (:) - - logical, allocatable :: filter_inpm (:) ! 3) area covered by input matrix - type(block_data_real8_2d) :: sumarea_inpm - - type(block_data_real8_2d) :: allups_mask_grid ! 4) mask of unit catchments with all - real(r8), allocatable :: allups_mask_pch (:) ! upstreams in simulation region - - ! -- PUBLIC SUBROUTINEs -- - PUBLIC :: hist_grid_riverlake_init - PUBLIC :: hist_grid_riverlake_out - PUBLIC :: hist_grid_riverlake_final - -!-------------------------------------------------------------------------- -CONTAINS - - !--------------------------------------- - SUBROUTINE hist_grid_riverlake_init (histform) - - USE MOD_Block - USE MOD_ComputePushData - USE MOD_HistGridded - USE MOD_Grid_RiverLakeNetwork - USE MOD_Grid_Reservoir, only: numresv - USE MOD_LandPatch, only: numpatch - USE MOD_Forcing, only: forcmask_pch - USE MOD_Vars_TimeInvariants, only: patchtype, patchmask - - IMPLICIT NONE - - character(len=*), intent(in) :: histform - - ! Local Variables - logical, allocatable :: filter_basic(:) - real(r8), allocatable :: vec_ucat(:), vec_grid(:), vec_inpm(:), vec_patch(:) - integer :: ilon, iblkme, iblk, jblk - - - ! ----- allocate memory for accumulative variables ----- - IF (p_is_compute) THEN - - allocate (acctime_ucat (numucat)) - allocate (a_wdsrf_ucat (numucat)) - allocate (a_veloc_riv (numucat)) - allocate (a_discharge (numucat)) - allocate (a_floodarea (numucat)) - - allocate (a_wdsrf_ucat_pch (numpatch)) - allocate (a_veloc_riv_pch (numpatch)) - allocate (a_discharge_pch (numpatch)) - allocate (a_dis_rmth_pch (numpatch)) - allocate (a_floodfrc_pch (numpatch)) - - allocate (acctime_resv (numresv)) - allocate (a_volresv (numresv)) - allocate (a_qresv_in (numresv)) - allocate (a_qresv_out (numresv)) - - ENDIF - - CALL flush_acc_fluxes_riverlake () - - ! ----- get longitude and latitude ----- - IF (p_is_root) THEN - allocate (lon_ucat (griducat%nlon)) - allocate (lat_ucat (griducat%nlat)) - - lat_ucat = (griducat%lat_s + griducat%lat_n) * 0.5 - - DO ilon = 1, griducat%nlon - IF (griducat%lon_w(ilon) > griducat%lon_e(ilon)) THEN - lon_ucat(ilon) = (griducat%lon_w(ilon) + griducat%lon_e(ilon)+360.) * 0.5 - CALL normalize_longitude (lon_ucat(ilon)) - ELSE - lon_ucat(ilon) = (griducat%lon_w(ilon) + griducat%lon_e(ilon)) * 0.5 - ENDIF - ENDDO - ENDIF - - ! ----- for auxiliary data ----- - IF (p_is_compute) THEN - allocate (vec_ucat (numucat )) - allocate (vec_grid (numinpm )) - allocate (vec_inpm (numinpm )) - allocate (vec_patch (numpatch)) - - ! Patches excluding (type >= 99), virtual patches and thos forcing missed - allocate (filter_basic (numpatch)) - IF (numpatch > 0) THEN - filter_basic = patchtype < 99 - filter_basic = filter_basic .and. patchmask - IF (DEF_forcing%has_missing_value) THEN - filter_basic = filter_basic .and. forcmask_pch - ENDIF - ENDIF - ENDIF - - ! ----- 1) area and filter covered by unit catchments ----- - IF (p_is_compute) THEN - - IF (numucat > 0) vec_ucat = 1. - - CALL compute_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) - CALL compute_remap_data_grid2pset ( & - remap_patch2inpm, vec_grid, vec_patch, fillvalue = spval, mode = 'average') - - allocate (filter_ucat (numpatch)) - IF (numpatch > 0) THEN - filter_ucat = filter_basic .and. (vec_patch /= spval) - - WHERE (filter_ucat) - vec_patch = 1 - ELSE WHERE - vec_patch = spval - END WHERE - ENDIF - - allocate (sum_grid_area (numinpm)) - CALL compute_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & - fillvalue = spval, filter = filter_ucat) - CALL compute_push_data (allreduce_inpm, vec_grid, sum_grid_area, fillvalue = spval) - ENDIF - -#ifndef MPAS_EMBEDDED_COLM - IF (trim(histform) == 'Gridded') THEN - IF (p_is_active) CALL allocate_block_data (ghist, sumarea_ucat) - CALL mp2g_hist%get_sumarea (sumarea_ucat, filter_ucat) - ENDIF -#endif - - ! ----- 2) area and filter covered by river mouth ----- - IF (p_is_compute) THEN - IF (numucat > 0) THEN - WHERE (ucat_next == -9) - vec_ucat = 1. - ELSE WHERE - vec_ucat = spval - END WHERE - ENDIF - - CALL compute_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval) - CALL compute_remap_data_grid2pset (remap_patch2inpm, vec_grid, vec_patch, & - fillvalue = spval, mode = 'average') - - allocate (filter_rivmth (numpatch)) - IF (numpatch > 0) THEN - filter_rivmth = filter_ucat .and. (vec_patch /= spval) - - WHERE (filter_rivmth) - vec_patch = 1 - ELSE WHERE - vec_patch = spval - END WHERE - ENDIF - - allocate (sum_rmth_area (numinpm)) - - CALL compute_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, & - fillvalue = spval, filter = filter_rivmth) - CALL compute_push_data (allreduce_inpm, vec_grid, sum_rmth_area, fillvalue = spval) - ENDIF - - ! ----- 3) area covered by input matrix ----- - IF (p_is_compute) THEN - IF (numucat > 0) vec_ucat = 1. - CALL compute_push_data (push_ucat2inpm, vec_ucat, vec_inpm, & - fillvalue = spval, mode = 'average') - CALL compute_remap_data_grid2pset (remap_patch2inpm, vec_inpm, vec_patch, & - fillvalue = spval, mode = 'average') - - allocate (filter_inpm (numpatch)) - IF (numpatch > 0) THEN - filter_inpm = filter_basic .and. (vec_patch /= spval) - ENDIF - ENDIF - -#ifndef MPAS_EMBEDDED_COLM - IF (trim(histform) == 'Gridded') THEN - IF (p_is_active) CALL allocate_block_data (ghist, sumarea_inpm) - CALL mp2g_hist%get_sumarea (sumarea_inpm, filter_inpm) - ENDIF -#endif - - ! ----- 4) mask of unit catchments with all upstreams in simulation region ----- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - allocate (allups_mask_pch (numpatch)) - ENDIF - ENDIF - - IF (p_is_compute) THEN - CALL compute_push_data (push_ucat2grid, allups_mask_ucat, vec_grid, fillvalue = spval) - CALL compute_remap_data_grid2pset ( & - remap_patch2inpm, vec_grid, allups_mask_pch, fillvalue = spval, mode = 'average') - ENDIF - -#ifndef MPAS_EMBEDDED_COLM - IF (trim(histform) == 'Gridded') THEN - - IF (p_is_active) CALL allocate_block_data (ghist, allups_mask_grid) - - CALL mp2g_hist%pset2grid (allups_mask_pch, allups_mask_grid, spv = spval, msk = filter_ucat) - - IF (p_is_active) THEN - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - WHERE (sumarea_ucat%blk(iblk,jblk)%val > 0.) - allups_mask_grid%blk(iblk,jblk)%val = & - allups_mask_grid%blk(iblk,jblk)%val / sumarea_ucat%blk(iblk,jblk)%val - ELSE WHERE - allups_mask_grid%blk(iblk,jblk)%val = spval - END WHERE - ENDDO - ENDIF - - ENDIF -#endif - - IF (allocated (vec_ucat )) deallocate (vec_ucat ) - IF (allocated (vec_grid )) deallocate (vec_grid ) - IF (allocated (vec_inpm )) deallocate (vec_inpm ) - IF (allocated (vec_patch )) deallocate (vec_patch ) - IF (allocated (filter_basic)) deallocate (filter_basic) - - END SUBROUTINE hist_grid_riverlake_init - - !--------------------------------------- - SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, is_first_in_file) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_ComputePushData - USE MOD_Grid_RiverLakeNetwork - USE MOD_Grid_Reservoir - USE MOD_Vector_ReadWrite - USE MOD_HistGridded -#ifdef UNSTRUCTURED - USE MOD_HistVector -#endif - USE MOD_LandPatch, only: numpatch - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: histform - integer, intent(in) :: idate(3) - integer, intent(in) :: itime_in_file - logical, intent(in) :: is_first_in_file - - ! Local variables - character(len=256) :: file_hist_ucat - logical :: fexists - integer :: itime_in_file_ucat, i - - real(r8), allocatable :: acc_vec_grid (:) - real(r8), allocatable :: a_floodfrc_ucat (:) ! flooded area fraction - real(r8), allocatable :: a_floodfrc_inpm (:) ! flooded area fraction - - - IF (p_is_root) THEN - i = len_trim (file_hist) - DO WHILE (file_hist(i:i) /= '_') - i = i - 1 - ENDDO - file_hist_ucat = file_hist(1:i) // 'unitcat_' // file_hist(i+1:) - - inquire (file=file_hist_ucat, exist=fexists) - IF (.not. fexists) THEN - - CALL ncio_create_file (trim(file_hist_ucat)) - - CALL ncio_define_dimension (file_hist_ucat, 'time', 0) - CALL ncio_define_dimension (file_hist_ucat, 'lat_ucat', griducat%nlat) - CALL ncio_define_dimension (file_hist_ucat, 'lon_ucat', griducat%nlon) - - CALL ncio_write_serial (file_hist_ucat, 'lat_ucat', lat_ucat, 'lat_ucat') - CALL ncio_write_serial (file_hist_ucat, 'lon_ucat', lon_ucat, 'lon_ucat') - ENDIF - - CALL ncio_write_time (file_hist_ucat, 'time', idate, itime_in_file_ucat, DEF_HIST_FREQ) - - ENDIF - - IF (is_first_in_file) THEN - IF (trim(histform) == 'Gridded') THEN - CALL hist_write_var_real8_2d ( & - file_hist, 'mask_complete_upstream_regird', ghist, -1, allups_mask_grid, compress = 1, & - longname = 'Mask of grids with all upstream located in simulation region', units = '100%') -#ifdef UNSTRUCTURED - ELSE - CALL aggregate_to_vector_and_write_2d ( & - allups_mask_pch, file_hist, 'mask_complete_upstream_regird', -1, filter_ucat, & - longname = 'Mask of grids with all upstream located in simulation region', units = '100%') -#endif - ENDIF - - CALL vector_gather_map2grid_and_write ( & - allups_mask_ucat, numucat, totalnumucat, ucat_data_address, griducat%nlon, x_ucat, & - griducat%nlat, y_ucat, file_hist_ucat, 'mask_complete_upstream', 'lon_ucat', 'lat_ucat', & - longname = 'Mask of grids with all upstream located in simulation region', units = '100%') - ENDIF - - IF (p_is_compute) THEN - allocate (acc_vec_grid (numinpm )) - ENDIF - - IF (DEF_hist_vars%riv_height) THEN - IF (p_is_compute) THEN - IF (numucat > 0) a_wdsrf_ucat = a_wdsrf_ucat / acctime_ucat - CALL compute_push_data (push_ucat2grid, a_wdsrf_ucat, acc_vec_grid, fillvalue = spval) - CALL compute_remap_data_grid2pset ( remap_patch2inpm, acc_vec_grid, a_wdsrf_ucat_pch, & - fillvalue = spval, mode = 'average') - ENDIF - - CALL vector_gather_map2grid_and_write ( a_wdsrf_ucat, numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_wdpth_ucat', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'deepest water depth in river and flood plain', 'm') - ENDIF - - IF (DEF_hist_vars%riv_veloct) THEN - IF (p_is_compute) THEN - IF (numucat > 0) a_veloc_riv = a_veloc_riv / acctime_ucat - CALL compute_push_data (push_ucat2grid, a_veloc_riv, acc_vec_grid, fillvalue = spval) - CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_veloc_riv_pch, & - fillvalue = spval, mode = 'average') - ENDIF - - CALL vector_gather_map2grid_and_write ( a_veloc_riv, numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_veloc_riv', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'water velocity in river', 'm/s') - ENDIF - - IF (DEF_hist_vars%discharge) THEN - IF (p_is_compute) THEN - IF (numucat > 0) a_discharge = a_discharge / acctime_ucat - CALL compute_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) - - IF (numinpm > 0) THEN - WHERE ((sum_grid_area /= spval) .and. (acc_vec_grid /= spval)) - acc_vec_grid = acc_vec_grid / sum_grid_area - ELSE WHERE - acc_vec_grid = spval - END WHERE - ENDIF - - CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_discharge_pch, & - fillvalue = spval, mode = 'sum') - ENDIF - - CALL vector_gather_map2grid_and_write ( a_discharge, numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_discharge', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'discharge in river and flood plain', 'm^3/s') - - IF (p_is_compute) THEN - IF (numucat > 0) THEN - WHERE (ucat_next /= -9) a_discharge = spval - ENDIF - CALL compute_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval) - - IF (numinpm > 0) THEN - WHERE ((sum_rmth_area /= spval) .and. (acc_vec_grid /= spval)) - acc_vec_grid = acc_vec_grid / sum_rmth_area - ELSE WHERE - acc_vec_grid = spval - END WHERE - ENDIF - - CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_dis_rmth_pch, & - fillvalue = spval, mode = 'sum') - ENDIF - - CALL vector_gather_map2grid_and_write ( a_discharge, numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_discharge_rivermouth', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'river mouth discharge into ocean', 'm^3/s') - ENDIF - - IF (DEF_hist_vars%floodfrc) THEN - - IF (p_is_compute) THEN - - IF (numucat > 0) a_floodarea = a_floodarea / acctime_ucat - - allocate (a_floodfrc_ucat (numucat)) - IF (numucat > 0) THEN - WHERE (topo_area > 0) - a_floodfrc_ucat = a_floodarea / topo_area - ELSE WHERE - a_floodfrc_ucat = spval - END WHERE - ENDIF - - allocate (a_floodfrc_inpm (numinpm)) - - CALL compute_push_data (push_ucat2inpm, a_floodfrc_ucat, a_floodfrc_inpm, & - fillvalue = spval, mode = 'average') - - CALL compute_remap_data_grid2pset (remap_patch2inpm, a_floodfrc_inpm, a_floodfrc_pch, & - fillvalue = spval, mode = 'average') - ENDIF - - ENDIF - - - IF (allocated (a_floodfrc_ucat)) deallocate (a_floodfrc_ucat) - IF (allocated (a_floodfrc_inpm)) deallocate (a_floodfrc_inpm) - IF (allocated (acc_vec_grid )) deallocate (acc_vec_grid ) - -#ifdef GridRiverLakeSediment - CALL write_sediment_history (file_hist_ucat, itime_in_file_ucat) -#endif - - ! ----- reservoir variables ----- - IF (DEF_Reservoir_Method > 0) THEN - IF (totalnumresv > 0) THEN - - IF (p_is_root) THEN - IF (.not. fexists) THEN - CALL ncio_define_dimension(file_hist_ucat, 'reservoir', totalnumresv) - CALL ncio_write_serial (file_hist_ucat, 'resv_GRAND_ID' , dam_GRAND_ID, 'reservoir') - CALL ncio_put_attr (file_hist_ucat, 'resv_GRAND_ID', 'long_name', 'reservoir GRAND ID') - ENDIF - ENDIF - - IF (DEF_hist_vars%volresv) THEN - IF (p_is_compute) THEN - IF (numresv > 0) THEN - WHERE (acctime_resv > 0) - a_volresv = a_volresv / acctime_resv - ELSEWHERE - a_volresv = spval - END WHERE - ENDIF - ENDIF - - CALL vector_gather_and_write ( a_volresv, numresv, totalnumresv, resv_data_address, & - file_hist_ucat, 'volresv', 'reservoir', itime_in_file_ucat, 'reservoir water volume', 'm^3') - ENDIF - - IF (DEF_hist_vars%qresv_in) THEN - IF (p_is_compute) THEN - IF (numresv > 0) THEN - WHERE (acctime_resv > 0) - a_qresv_in = a_qresv_in / acctime_resv - ELSEWHERE - a_qresv_in = spval - END WHERE - ENDIF - ENDIF - - CALL vector_gather_and_write ( a_qresv_in, numresv, totalnumresv, resv_data_address, & - file_hist_ucat, 'qresv_in', 'reservoir', itime_in_file_ucat, 'reservoir inflow', 'm^3/s') - ENDIF - - IF (DEF_hist_vars%qresv_out) THEN - IF (p_is_compute) THEN - IF (numresv > 0) THEN - WHERE (acctime_resv > 0) - a_qresv_out = a_qresv_out / acctime_resv - ELSEWHERE - a_qresv_out = spval - END WHERE - ENDIF - ENDIF - - CALL vector_gather_and_write ( a_qresv_out, numresv, totalnumresv, resv_data_address, & - file_hist_ucat, 'qresv_out', 'reservoir', itime_in_file_ucat, 'reservoir outflow', 'm^3/s') - ENDIF - - ENDIF - ENDIF - - CALL flush_acc_fluxes_riverlake () - - END SUBROUTINE hist_grid_riverlake_out - - !----------------------- - SUBROUTINE flush_acc_fluxes_riverlake () - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Grid_RiverLakeNetwork, only: numucat - USE MOD_Grid_Reservoir, only: numresv - IMPLICIT NONE - - IF (p_is_compute) THEN - - IF (numucat > 0) THEN - acctime_ucat (:) = 0. - a_wdsrf_ucat (:) = 0. - a_veloc_riv (:) = 0. - a_discharge (:) = 0. - a_floodarea (:) = 0. - ENDIF - - IF (numresv > 0) THEN - acctime_resv (:) = 0. - a_volresv (:) = 0. - a_qresv_in (:) = 0. - a_qresv_out (:) = 0. - ENDIF - -#ifdef GridRiverLakeSediment - IF (DEF_USE_SEDIMENT .and. allocated(a_sedcon)) THEN - a_sedcon = 0. - a_sedout = 0. - a_bedout = 0. - a_sedinp = 0. - a_netflw = 0. - a_layer = 0. - a_shearvel = 0. - sed_hist_acctime = 0. - ENDIF -#endif - - ENDIF - - END SUBROUTINE flush_acc_fluxes_riverlake - - !--------------------------------------- - SUBROUTINE hist_grid_riverlake_final () - - IMPLICIT NONE - - IF (allocated(acctime_ucat )) deallocate (acctime_ucat ) - IF (allocated(a_wdsrf_ucat )) deallocate (a_wdsrf_ucat ) - IF (allocated(a_veloc_riv )) deallocate (a_veloc_riv ) - IF (allocated(a_discharge )) deallocate (a_discharge ) - IF (allocated(a_floodarea )) deallocate (a_floodarea ) - - IF (allocated(a_wdsrf_ucat_pch)) deallocate (a_wdsrf_ucat_pch) - IF (allocated(a_veloc_riv_pch )) deallocate (a_veloc_riv_pch ) - IF (allocated(a_discharge_pch )) deallocate (a_discharge_pch ) - IF (allocated(a_dis_rmth_pch )) deallocate (a_dis_rmth_pch ) - IF (allocated(a_floodfrc_pch )) deallocate (a_floodfrc_pch ) - - IF (allocated(acctime_resv )) deallocate (acctime_resv ) - IF (allocated(a_volresv )) deallocate (a_volresv ) - IF (allocated(a_qresv_in )) deallocate (a_qresv_in ) - IF (allocated(a_qresv_out )) deallocate (a_qresv_out ) - - IF (allocated(lon_ucat )) deallocate (lon_ucat ) - IF (allocated(lat_ucat )) deallocate (lat_ucat ) - - IF (allocated(filter_ucat )) deallocate (filter_ucat ) - IF (allocated(sum_grid_area )) deallocate (sum_grid_area ) - IF (allocated(filter_rivmth )) deallocate (filter_rivmth ) - IF (allocated(sum_rmth_area )) deallocate (sum_rmth_area ) - IF (allocated(filter_inpm )) deallocate (filter_inpm ) - - IF (allocated(allups_mask_pch )) deallocate (allups_mask_pch ) - - END SUBROUTINE hist_grid_riverlake_final - -#ifdef GridRiverLakeSediment - !--------------------------------------- - SUBROUTINE write_sediment_history (file_hist_ucat, itime_in_file_ucat) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_data_address, & - x_ucat, y_ucat, griducat - USE MOD_Vector_ReadWrite - IMPLICIT NONE - - character(len=*), intent(in) :: file_hist_ucat - integer, intent(in) :: itime_in_file_ucat - - real(r8), allocatable :: a_sedcon_avg(:,:) - real(r8), allocatable :: a_sedout_avg(:,:) - real(r8), allocatable :: a_bedout_avg(:,:) - real(r8), allocatable :: a_sedinp_avg(:,:) - real(r8), allocatable :: a_netflw_avg(:,:) - real(r8), allocatable :: a_layer_avg(:,:) - real(r8), allocatable :: a_shearvel_avg(:) - integer :: ised - character(len=16) :: cised - - IF (.not. DEF_USE_SEDIMENT) RETURN - - ! Allocate on ALL processes (zero-size on non-ranks) to avoid - ! passing unallocated arrays to vector_gather_map2grid_and_write - IF (p_is_compute .and. numucat > 0) THEN - allocate (a_sedcon_avg (nsed, numucat)) - allocate (a_sedout_avg (nsed, numucat)) - allocate (a_bedout_avg (nsed, numucat)) - allocate (a_sedinp_avg (nsed, numucat)) - allocate (a_netflw_avg (nsed, numucat)) - allocate (a_layer_avg (nsed, numucat)) - allocate (a_shearvel_avg(numucat)) - - IF (sed_hist_acctime > 0._r8) THEN - a_shearvel_avg = a_shearvel / sed_hist_acctime - DO ised = 1, nsed - a_sedcon_avg(ised,:) = a_sedcon(ised,:) / sed_hist_acctime - a_sedout_avg(ised,:) = a_sedout(ised,:) / sed_hist_acctime - a_bedout_avg(ised,:) = a_bedout(ised,:) / sed_hist_acctime - a_sedinp_avg(ised,:) = a_sedinp(ised,:) / sed_hist_acctime - a_netflw_avg(ised,:) = a_netflw(ised,:) / sed_hist_acctime - a_layer_avg(ised,:) = a_layer(ised,:) / sed_hist_acctime - ENDDO - ELSE - a_shearvel_avg = 0. - a_sedcon_avg = 0. - a_sedout_avg = 0. - a_bedout_avg = 0. - a_sedinp_avg = 0. - a_netflw_avg = 0. - a_layer_avg = 0. - ENDIF - ELSE - ! Allocate with nsed in first dim so a_xxx_avg(ised,:) is a valid zero-length slice - allocate (a_sedcon_avg (nsed, 0)) - allocate (a_sedout_avg (nsed, 0)) - allocate (a_bedout_avg (nsed, 0)) - allocate (a_sedinp_avg (nsed, 0)) - allocate (a_netflw_avg (nsed, 0)) - allocate (a_layer_avg (nsed, 0)) - allocate (a_shearvel_avg(0)) - ENDIF - - IF (DEF_hist_vars%sedcon) THEN - DO ised = 1, nsed - WRITE(cised, '(I0)') ised - CALL vector_gather_map2grid_and_write ( a_sedcon_avg(ised,:), numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_sedcon_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'suspended sediment concentration, size class ' // trim(cised), 'm^3/m^3') - ENDDO - ENDIF - - IF (DEF_hist_vars%sedout) THEN - DO ised = 1, nsed - WRITE(cised, '(I0)') ised - CALL vector_gather_map2grid_and_write ( a_sedout_avg(ised,:), numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_sedout_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'suspended sediment flux, size class ' // trim(cised), 'm^3/s') - ENDDO - ENDIF - - IF (DEF_hist_vars%bedout) THEN - DO ised = 1, nsed - WRITE(cised, '(I0)') ised - CALL vector_gather_map2grid_and_write ( a_bedout_avg(ised,:), numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_bedout_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'bedload flux, size class ' // trim(cised), 'm^3/s') - ENDDO - ENDIF - - IF (DEF_hist_vars%sedinp) THEN - DO ised = 1, nsed - WRITE(cised, '(I0)') ised - CALL vector_gather_map2grid_and_write ( a_sedinp_avg(ised,:), numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_sedinp_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'sediment erosion input, size class ' // trim(cised), 'm^3/s') - ENDDO - ENDIF - - IF (DEF_hist_vars%netflw) THEN - DO ised = 1, nsed - WRITE(cised, '(I0)') ised - CALL vector_gather_map2grid_and_write ( a_netflw_avg(ised,:), numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_netflw_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'net bed-water exchange flux (incl. shallow deposit), size class ' // trim(cised), 'm^3/s') - ENDDO - ENDIF - - IF (DEF_hist_vars%sedlayer) THEN - DO ised = 1, nsed - WRITE(cised, '(I0)') ised - CALL vector_gather_map2grid_and_write ( a_layer_avg(ised,:), numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_layer_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'active layer storage, size class ' // trim(cised), 'm^3') - ENDDO - ENDIF - - IF (DEF_hist_vars%shearvel) THEN - CALL vector_gather_map2grid_and_write ( a_shearvel_avg, numucat, & - totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, & - file_hist_ucat, 'f_shearvel', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, & - 'shear velocity', 'm/s') - ENDIF - - IF (allocated(a_sedcon_avg )) deallocate (a_sedcon_avg ) - IF (allocated(a_sedout_avg )) deallocate (a_sedout_avg ) - IF (allocated(a_bedout_avg )) deallocate (a_bedout_avg ) - IF (allocated(a_sedinp_avg )) deallocate (a_sedinp_avg ) - IF (allocated(a_netflw_avg )) deallocate (a_netflw_avg ) - IF (allocated(a_layer_avg )) deallocate (a_layer_avg ) - IF (allocated(a_shearvel_avg)) deallocate (a_shearvel_avg) - - END SUBROUTINE write_sediment_history -#endif - -END MODULE MOD_Grid_RiverLakeHist -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 index b3d21e2243..b2fe9cd54b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -14,37 +14,29 @@ MODULE MOD_Grid_RiverLakeNetwork type(grid_type) :: griducat - integer :: totalnumucat - integer :: numucat + integer :: totalnumucat = 0 + integer :: numucat = 0 integer, allocatable :: ucat_ucid (:) ! index in unit catchment numbering - integer, allocatable :: x_ucat (:) ! - integer, allocatable :: y_ucat (:) ! - integer, allocatable :: ucat_gdid (:) ! - - integer, allocatable :: numucat_rank (:) - type(pointer_int32_1d), allocatable :: ucat_data_address (:) ! ----- Part 1: between runoff input elements and unit catchments ----- - integer :: numinpm + integer :: numinpm = 0 integer, allocatable :: inpm_gdid (:) - integer :: inpn + integer :: inpn = 0 integer, allocatable :: idmap_gd2uc (:,:) real(r8), allocatable :: area_gd2uc (:,:) - integer :: nucpart + integer :: nucpart = 0 integer, allocatable :: idmap_uc2gd (:,:) real(r8), allocatable :: area_uc2gd (:,:) type(compute_remapdata_type) :: remap_patch2inpm type(compute_pushdata_type) :: push_inpm2ucat type(compute_pushdata_type) :: push_ucat2inpm - type(compute_pushdata_type) :: push_ucat2grid - type(compute_pushdata_type) :: allreduce_inpm ! ----- Part 2: between upstream and downstream unit catchments ----- integer, allocatable :: ucat_next (:) ! next unit catchment - integer :: upnmax + integer :: upnmax = 0 integer, allocatable :: ucat_ups (:,:) ! upstream unit catchments real(r8), allocatable :: wts_ups (:,:) @@ -52,11 +44,16 @@ MODULE MOD_Grid_RiverLakeNetwork type(compute_pushdata_type) :: push_ups2ucat ! ----- Part 3: river systems ----- - integer :: numrivsys - logical :: rivsys_by_multiple_procs + integer :: numrivsys = 0 integer, allocatable :: irivsys (:) -#ifdef COLM_PARALLEL - integer :: p_comm_rivsys +#ifdef MPAS_MPI + integer :: num_owned_rivsys = 0 + integer, allocatable :: rivsys_send_counts (:) + integer, allocatable :: rivsys_send_displs (:) + integer, allocatable :: rivsys_recv_counts (:) + integer, allocatable :: rivsys_recv_displs (:) + integer, allocatable :: rivsys_send_local (:) + integer, allocatable :: rivsys_recv_owner (:) #endif @@ -70,1168 +67,44 @@ MODULE MOD_Grid_RiverLakeNetwork real(r8), allocatable :: topo_rivman (:) ! river manning coefficient [m] real(r8), allocatable :: topo_rivwth (:) ! river channel width [m] real(r8), allocatable :: topo_rivare (:) ! river channel area [m^2] - real(r8), allocatable :: topo_rivstomax (:) ! max river channel storage [m^3] - - real(r8), allocatable :: topo_area (:) ! floodplain area [m^2] - real(r8), allocatable :: topo_fldhgt (:,:) ! floodplain height profile [m] - - real(r8), allocatable :: bedelv_next (:) ! downstream river bed elevation [m] - real(r8), allocatable :: outletwth (:) ! river outlet width [m] - - type :: vol_dep_curve_type - integer :: nlfp - real(r8) :: rivhgt - real(r8) :: rivare - real(r8) :: rivstomax - real(r8), allocatable :: flphgt (:) ! floodplain height profile [m] - real(r8), allocatable :: flparea (:) ! flood plain area [m^2] - real(r8), allocatable :: flpaccare (:) ! flood plain accumulated area [m^2] - real(r8), allocatable :: flpstomax (:) ! max flood plain storage [m^3] - CONTAINS - procedure, PUBLIC :: depth => retrieve_depth_from_volume - procedure, PUBLIC :: volume => retrieve_volume_from_depth - procedure, PUBLIC :: floodarea => retrieve_area_from_depth - final :: vol_depth_curve_free_mem - END type vol_dep_curve_type - - type(vol_dep_curve_type), allocatable :: floodplain_curve (:) - - - ! ----- Mask of Grids with all upstream area in the simulation region ----- - real(r8), allocatable :: allups_mask_ucat (:) - -CONTAINS - - ! ---------- - SUBROUTINE build_riverlake_network () - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_Mesh - USE MOD_Utils - USE MOD_LandPatch - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - ! Local Variables - character(len=256) :: parafile - - integer, allocatable :: idmap_x(:,:), idmap_y(:,:) - integer, allocatable :: varsize(:) - - integer :: numrivmth - integer, allocatable :: rivermouth(:) - - integer, allocatable :: nups_nst (:), iups_nst (:), nups_all(:) - integer, allocatable :: ucat_next_all(:) - integer, allocatable :: uc_up2down(:), order_ucat(:) - integer, allocatable :: addr_ucat (:) - - integer , allocatable :: nuc_rs(:), irank_rs(:), nrank_rs(:), nave_rs(:) - real(r8), allocatable :: wt_uc (:), wt_rs (:), wt_rank (:), nuc_rank(:) - - integer, allocatable :: grdindex(:) - - - integer, allocatable :: idata1d(:), idata2d(:,:) - real(r8), allocatable :: rdata1d(:), rdata2d(:,:) - - integer, allocatable :: allgrd_in_inp (:), nucat_g2d(:,:), iucat_g(:) - - integer, allocatable :: idmap_uc2gd_all(:,:) - real(r8), allocatable :: area_uc2gd_all (:,:) - - real(r8), allocatable :: ucat_area_all (:) - - integer :: nlat_ucat, nlon_ucat - integer :: nucat, iriv, ngrdall, igrd, ngrd - integer :: p_np_rivsys, color - integer :: irank, irankdsp, self_rank - integer :: iloc, i, j, ithis - real(r8) :: sumwt - logical :: is_new - - -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef MPAS_EMBEDDED_COLM - CALL build_riverlake_network_mpas_embedded() - RETURN -#endif - - ! read in parameters from file. - parafile = DEF_UnitCatchment_file - IF (p_is_root) THEN - -#ifdef MPAS_EMBEDDED_COLM - CALL ncio_inquire_length (parafile, 'seq_next', totalnumucat) -#else - CALL ncio_read_serial (parafile, 'seq_x', x_ucat) - CALL ncio_read_serial (parafile, 'seq_y', y_ucat) - totalnumucat = size(x_ucat) -#endif - - CALL ncio_read_serial (parafile, 'seq_next', ucat_next) - - CALL ncio_inquire_length (parafile, 'lon', nlon_ucat) - CALL ncio_inquire_length (parafile, 'lat', nlat_ucat) - -#ifndef MPAS_EMBEDDED_COLM - CALL ncio_read_serial (parafile, 'inpmat_x', idmap_x) - CALL ncio_read_serial (parafile, 'inpmat_y', idmap_y) - CALL ncio_read_serial (parafile, 'inpmat_area', area_gd2uc) -#endif - - ENDIF - - IF (p_is_root) THEN - - allocate (nups_nst (totalnumucat)) - allocate (iups_nst (totalnumucat)) - - nups_nst(:) = 0 - DO i = 1, totalnumucat - j = ucat_next(i) - IF (j > 0) THEN - nups_nst(j) = nups_nst(j) + 1 - ENDIF - ENDDO - - ! sort unit catchment from upstream to downstream, recorded by "uc_up2down" - allocate (uc_up2down (totalnumucat)) - - ithis = 0 - iups_nst(:) = 0 - DO i = 1, totalnumucat - IF (iups_nst(i) == nups_nst(i)) THEN - - ithis = ithis + 1 - uc_up2down(ithis) = i - iups_nst(i) = -1 - - j = ucat_next(i) - DO WHILE (j > 0) - - iups_nst(j) = iups_nst(j) + 1 - - IF (iups_nst(j) == nups_nst(j)) THEN - ithis = ithis + 1 - uc_up2down(ithis) = j - iups_nst(j) = -1 - - j = ucat_next(j) - ELSE - EXIT - ENDIF - ENDDO - ENDIF - ENDDO - - ENDIF - -#ifdef COLM_PARALLEL - ! divide unit catchments into groups and assign to ranks - IF (p_is_root) THEN - - allocate (wt_uc (totalnumucat)); wt_uc(:) = 1. - - allocate (rivermouth (totalnumucat)) - numrivmth = 0 - DO i = totalnumucat, 1, -1 - j = ucat_next(uc_up2down(i)) - IF (j <= 0) THEN - numrivmth = numrivmth + 1 - rivermouth(uc_up2down(i)) = numrivmth - ELSE - rivermouth(uc_up2down(i)) = rivermouth(j) - ENDIF - ENDDO - - allocate (nuc_rs (numrivmth)); nuc_rs(:) = 0 - allocate (wt_rs (numrivmth)); wt_rs (:) = 0. - DO i = 1, totalnumucat - nuc_rs(rivermouth(i)) = nuc_rs(rivermouth(i)) + 1 - wt_rs (rivermouth(i)) = wt_rs (rivermouth(i)) + wt_uc(i) - ENDDO - - sumwt = sum(wt_rs) - - allocate (irank_rs (numrivmth)) - allocate (nrank_rs (numrivmth)) - allocate (nave_rs (numrivmth)) - - irankdsp = -1 - DO i = 1, numrivmth - nrank_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute) - IF (nrank_rs(i) > 1) THEN - - nave_rs(i) = nuc_rs(i) / nrank_rs(i) - IF (mod(nuc_rs(i), nrank_rs(i)) /= 0) THEN - nave_rs(i) = nave_rs(i) + 1 - ENDIF - - irank_rs(i) = irankdsp + 1 - irankdsp = irankdsp + nrank_rs(i) - ENDIF - ENDDO - - allocate (nups_all (totalnumucat)); nups_all(:) = 1 - - DO i = 1, totalnumucat - j = ucat_next(uc_up2down(i)) - IF (j > 0) THEN - nups_all(j) = nups_all(j) + nups_all(uc_up2down(i)) - ENDIF - ENDDO - - allocate (addr_ucat (totalnumucat)); addr_ucat(:) = -1 - - allocate (wt_rank (0:p_np_compute-1)); wt_rank (:) = 0 - allocate (nuc_rank(0:p_np_compute-1)); nuc_rank(:) = 0 - - allocate (order_ucat (totalnumucat)) - order_ucat(uc_up2down) = (/(i, i = 1, totalnumucat)/) - - ithis = totalnumucat - DO WHILE (ithis > 0) - - i = uc_up2down(ithis) - - IF (addr_ucat(i) >= 0) THEN - ithis = ithis - 1 - CYCLE - ENDIF - - j = ucat_next(i) - IF (j > 0) THEN - IF (addr_ucat(j) >= 0) THEN - addr_ucat(i) = addr_ucat(j) - ithis = ithis - 1 - CYCLE - ENDIF - ENDIF - - iriv = rivermouth(i) - IF (nrank_rs(iriv) > 1) THEN - irank = irank_rs(iriv) - IF (nups_all(i) <= nave_rs(iriv)-nuc_rank(irank)) THEN - - addr_ucat(i) = p_address_compute(irank) - - nuc_rank(irank) = nuc_rank(irank) + nups_all(i) - IF (nuc_rank(irank) == nave_rs(iriv)) THEN - irank_rs(iriv) = irank_rs(iriv) + 1 - ENDIF - - j = ucat_next(i) - IF (j > 0) THEN - DO WHILE (j > 0) - nups_all(j) = nups_all(j) - nups_all(i) - ithis = order_ucat(j) - j = ucat_next(j) - ENDDO - ELSE - ithis = ithis - 1 - ENDIF - ELSE - ithis = ithis - 1 - ENDIF - ELSE - irank = minloc(wt_rank(irankdsp+1:p_np_compute-1), dim=1) + irankdsp - - addr_ucat(i) = p_address_compute(irank) - - wt_rank(irank) = wt_rank(irank) + wt_rs(iriv) - ithis = ithis - 1 - ENDIF - - ENDDO - - deallocate (order_ucat) - deallocate (nups_all ) - deallocate (nuc_rs ) - deallocate (irank_rs ) - deallocate (nrank_rs ) - deallocate (nave_rs ) - deallocate (wt_uc ) - deallocate (wt_rs ) - deallocate (wt_rank ) - deallocate (nuc_rank ) - - ENDIF - - IF (p_is_root) THEN - - allocate(ucat_ucid (totalnumucat)) - ucat_ucid = (/(i, i = 1, totalnumucat)/) - - allocate (numucat_rank (0:p_np_compute-1)) - allocate (ucat_data_address (0:p_np_compute-1)) - - DO irank = 0, p_np_compute-1 - nucat = count(addr_ucat == p_address_compute(irank)) - numucat_rank(irank) = nucat - IF (nucat > 0) THEN - allocate (ucat_data_address(irank)%val (nucat)) - ucat_data_address(irank)%val = & - pack(ucat_ucid, mask = (addr_ucat == p_address_compute(irank))) - ENDIF - ENDDO - - ENDIF - - CALL mpi_bcast (totalnumucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - - ! send unit catchment index to ranks - IF (p_is_root) THEN - - self_rank = -1 - - DO irank = 0, p_np_compute-1 - - nucat = numucat_rank(irank) - IF (p_address_compute(irank) == p_iam_glb) THEN - numucat = nucat - self_rank = irank - CYCLE - ENDIF - - CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_mesg, p_comm_glb, p_err) - - IF (nucat > 0) THEN - - CALL mpi_send (ucat_data_address(irank)%val, nucat, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err) - -#ifndef MPAS_EMBEDDED_COLM - allocate (idata1d (nucat)) - - idata1d = x_ucat (ucat_data_address(irank)%val) - CALL mpi_send (idata1d, nucat, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err) - - idata1d = y_ucat (ucat_data_address(irank)%val) - CALL mpi_send (idata1d, nucat, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err) - - deallocate (idata1d) -#endif - ENDIF - ENDDO - - IF (self_rank >= 0) THEN - nucat = numucat_rank(self_rank) - IF (allocated(idata1d)) deallocate(idata1d) - allocate (idata1d (nucat)) - IF (nucat > 0) idata1d = ucat_data_address(self_rank)%val - - IF (allocated(ucat_ucid)) deallocate(ucat_ucid) - allocate (ucat_ucid (nucat)) - IF (nucat > 0) ucat_ucid = idata1d - -#ifndef MPAS_EMBEDDED_COLM - IF (allocated(x_ucat)) THEN - IF (nucat > 0) idata1d = x_ucat(ucat_ucid) - deallocate (x_ucat) - allocate (x_ucat (nucat)) - IF (nucat > 0) x_ucat = idata1d - ENDIF - - IF (allocated(y_ucat)) THEN - IF (nucat > 0) idata1d = y_ucat(ucat_ucid) - deallocate (y_ucat) - allocate (y_ucat (nucat)) - IF (nucat > 0) y_ucat = idata1d - ENDIF -#endif - - deallocate (idata1d) - ENDIF - - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - - CALL mpi_recv (numucat, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - IF (numucat > 0) THEN - allocate (ucat_ucid (numucat)) -#ifndef MPAS_EMBEDDED_COLM - allocate (x_ucat (numucat)) - allocate (y_ucat (numucat)) -#endif - CALL mpi_recv (ucat_ucid, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) -#ifndef MPAS_EMBEDDED_COLM - CALL mpi_recv (x_ucat, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (y_ucat, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) -#endif - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - numucat = totalnumucat - - allocate(ucat_ucid (totalnumucat)) - ucat_ucid = (/(i, i = 1, totalnumucat)/) - - allocate (numucat_rank (0:0)) - numucat_rank(0) = numucat - - allocate (ucat_data_address (0:0)) - allocate (ucat_data_address(0)%val (numucat)) - ucat_data_address(0)%val = ucat_ucid -#endif - -#ifdef MPAS_EMBEDDED_COLM - IF (p_is_compute) THEN - IF (numucat > 0) THEN - CALL ncio_read_indexed_serial (parafile, 'seq_x', ucat_ucid, x_ucat) - CALL ncio_read_indexed_serial (parafile, 'seq_y', ucat_ucid, y_ucat) - ELSE - IF (.not. allocated(x_ucat)) allocate (x_ucat (0)) - IF (.not. allocated(y_ucat)) allocate (y_ucat (0)) - ENDIF - ENDIF -#endif - - IF (p_is_compute .and. numucat == 0) THEN - IF (.not. allocated(ucat_ucid)) allocate (ucat_ucid (0)) - IF (.not. allocated(x_ucat )) allocate (x_ucat (0)) - IF (.not. allocated(y_ucat )) allocate (y_ucat (0)) - ENDIF - - IF (allocated(addr_ucat)) deallocate(addr_ucat) - - ! ----- Part 1: between runoff input elements and unit catchments ----- - -#ifdef COLM_PARALLEL - CALL mpi_bcast (nlon_ucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast (nlat_ucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) -#endif - - CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) - - CALL build_compute_remapdata (landpatch, griducat, remap_patch2inpm) - - IF (p_is_compute) THEN - numinpm = remap_patch2inpm%num_grid - IF (numinpm > 0) THEN - allocate (inpm_gdid (numinpm)) - inpm_gdid = remap_patch2inpm%ids_me - ELSE - allocate (inpm_gdid (0)) - ENDIF - ENDIF - -#ifdef MPAS_EMBEDDED_COLM - CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) - inpn = varsize(1) - deallocate (varsize) - - IF (p_is_compute) THEN - IF (numucat > 0) THEN - CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) - CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) - CALL ncio_read_indexed_serial (parafile, 'inpmat_area', ucat_ucid, area_gd2uc) - - allocate(idmap_gd2uc (inpn,numucat)) - idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x - - WHERE ((area_gd2uc <= 0) .or. (idmap_gd2uc <= 0)) - idmap_gd2uc = 0 - area_gd2uc = 0. - END WHERE - ELSE - allocate(idmap_gd2uc (inpn,0)) - allocate(area_gd2uc (inpn,0)) - ENDIF - - CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & - nucpart, idmap_uc2gd, area_uc2gd) - ENDIF -#else - IF (p_is_root) THEN - - inpn = size(idmap_x,1) - - allocate(idmap_gd2uc (inpn,totalnumucat)) - - idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x - - WHERE ((area_gd2uc <= 0) .or. (idmap_gd2uc <= 0)) - idmap_gd2uc = 0 - area_gd2uc = 0. - END WHERE - - allocate (nucat_g2d (nlon_ucat,nlat_ucat)) - nucat_g2d(:,:) = 0 - - DO i = 1, totalnumucat - DO j = 1, inpn - IF (idmap_gd2uc(j,i) > 0) THEN - nucat_g2d(idmap_x(j,i),idmap_y(j,i)) = nucat_g2d(idmap_x(j,i),idmap_y(j,i)) + 1 - ENDIF - ENDDO - ENDDO - - nucpart = maxval(nucat_g2d) - ngrdall = count(nucat_g2d > 0) - - allocate (allgrd_in_inp (ngrdall)) - - igrd = 0 - DO i = 1, nlat_ucat - DO j = 1, nlon_ucat - IF (nucat_g2d(j,i) > 0) THEN - igrd = igrd + 1 - allgrd_in_inp(igrd) = (i-1)*nlon_ucat + j - ENDIF - ENDDO - ENDDO - - allocate (idmap_uc2gd_all (nucpart, ngrdall)); idmap_uc2gd_all(:,:) = 0 - allocate (area_uc2gd_all (nucpart, ngrdall)); area_uc2gd_all (:,:) = 0. - - allocate (iucat_g (ngrdall)); iucat_g(:) = 0 - - DO i = 1, totalnumucat - DO j = 1, inpn - IF (idmap_gd2uc(j,i) > 0) THEN - iloc = find_in_sorted_list1 (idmap_gd2uc(j,i), ngrdall, allgrd_in_inp(1:ngrdall)) - iucat_g(iloc) = iucat_g(iloc) + 1 - idmap_uc2gd_all(iucat_g(iloc),iloc) = i - area_uc2gd_all (iucat_g(iloc),iloc) = area_gd2uc(j,i) - ENDIF - ENDDO - ENDDO - - ENDIF - -#ifdef COLM_PARALLEL - CALL mpi_bcast (inpn, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - - IF (p_is_root) THEN - - self_rank = -1 - DO irank = 0, p_np_compute-1 - - nucat = numucat_rank(irank) - - IF (nucat > 0) THEN - IF (p_address_compute(irank) == p_iam_glb) THEN - self_rank = irank - CYCLE - ENDIF - - allocate (idata2d (inpn, nucat)) - DO i = 1, nucat - idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(irank)%val(i)) - ENDDO - - allocate (rdata2d (inpn, nucat)) - DO i = 1, nucat - rdata2d(:,i) = area_gd2uc(:,ucat_data_address(irank)%val(i)) - ENDDO - - CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - - deallocate (idata2d) - deallocate (rdata2d) - ENDIF - ENDDO - - IF (self_rank >= 0) THEN - nucat = numucat_rank(self_rank) - IF (nucat > 0) THEN - allocate (idata2d (inpn, nucat)) - DO i = 1, nucat - idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(self_rank)%val(i)) - ENDDO - - allocate (rdata2d (inpn, nucat)) - DO i = 1, nucat - rdata2d(:,i) = area_gd2uc(:,ucat_data_address(self_rank)%val(i)) - ENDDO - - IF (allocated(idmap_gd2uc)) deallocate(idmap_gd2uc) - IF (allocated(area_gd2uc )) deallocate(area_gd2uc ) - allocate (idmap_gd2uc (inpn, nucat)) - allocate (area_gd2uc (inpn, nucat)) - idmap_gd2uc = idata2d - area_gd2uc = rdata2d - - deallocate (idata2d) - deallocate (rdata2d) - ENDIF - ENDIF - - IF (.not. (p_is_compute .and. numucat > 0)) THEN - IF (allocated(idmap_gd2uc)) deallocate (idmap_gd2uc) - IF (allocated(area_gd2uc )) deallocate (area_gd2uc ) - IF (p_is_compute) THEN - allocate (idmap_gd2uc (inpn,0)) - allocate (area_gd2uc (inpn,0)) - ENDIF - ENDIF - - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - - IF (numucat > 0) THEN - - allocate (idmap_gd2uc (inpn, numucat)) - CALL mpi_recv (idmap_gd2uc, inpn*numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (area_gd2uc (inpn, numucat)) - CALL mpi_recv (area_gd2uc, inpn*numucat, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - ENDIF - - ENDIF - - CALL mpi_bcast (nucpart, 1, mpi_integer, p_address_root, p_comm_glb, p_err) - - IF (p_is_root) THEN - - DO irank = 0, p_np_compute-1 - - IF (p_address_compute(irank) == p_iam_glb) THEN - ngrd = numinpm - ELSE - CALL mpi_recv (ngrd, 1, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_stat, p_err) - ENDIF - - IF (ngrd > 0) THEN - - allocate (grdindex (ngrd)) - allocate (idata2d (nucpart, ngrd)); idata2d(:,:) = 0 - allocate (rdata2d (nucpart, ngrd)); rdata2d(:,:) = 0. - - IF (p_address_compute(irank) == p_iam_glb) THEN - grdindex = inpm_gdid - ELSE - CALL mpi_recv (grdindex, ngrd, MPI_INTEGER, & - p_address_compute(irank), mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - - DO i = 1, ngrd - iloc = find_in_sorted_list1 (grdindex(i), ngrdall, allgrd_in_inp(1:ngrdall)) - IF (iloc > 0) THEN - idata2d(:,i) = idmap_uc2gd_all(:,iloc) - rdata2d(:,i) = area_uc2gd_all (:,iloc) - ENDIF - ENDDO - - IF (p_address_compute(irank) == p_iam_glb) THEN - IF (allocated(idmap_uc2gd)) deallocate(idmap_uc2gd) - IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) - allocate (idmap_uc2gd (nucpart, ngrd)) - allocate (area_uc2gd (nucpart, ngrd)) - idmap_uc2gd = idata2d - area_uc2gd = rdata2d - ELSE - CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - - deallocate (grdindex) - deallocate (idata2d ) - deallocate (rdata2d ) - ENDIF - ENDDO - - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - - CALL mpi_send (numinpm, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (numinpm > 0) THEN - - CALL mpi_send (inpm_gdid, numinpm, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_err) - - allocate (idmap_uc2gd (nucpart,numinpm)) - CALL mpi_recv (idmap_uc2gd, nucpart*numinpm, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (area_uc2gd (nucpart,numinpm)) - CALL mpi_recv (area_uc2gd, nucpart*numinpm, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - allocate (idmap_uc2gd (nucpart,numinpm)) - allocate (area_uc2gd (nucpart,numinpm)) - idmap_uc2gd = 0 - area_uc2gd = 0. - - DO i = 1, numinpm - iloc = find_in_sorted_list1 (inpm_gdid(i), ngrdall, allgrd_in_inp(1:ngrdall)) - IF (iloc > 0) THEN - idmap_uc2gd(:,i) = idmap_uc2gd_all(:,iloc) - area_uc2gd (:,i) = area_uc2gd_all (:,iloc) - ENDIF - ENDDO -#endif -#endif - - IF (p_is_compute) THEN - IF (.not. allocated(idmap_gd2uc)) allocate (idmap_gd2uc (inpn,0)) - IF (.not. allocated(area_gd2uc )) allocate (area_gd2uc (inpn,0)) - IF (.not. allocated(idmap_uc2gd)) allocate (idmap_uc2gd (nucpart,0)) - IF (.not. allocated(area_uc2gd )) allocate (area_uc2gd (nucpart,0)) - ENDIF - - IF (p_is_compute) THEN - IF (numucat > 0) THEN - allocate (ucat_gdid (numucat)) - ucat_gdid = (y_ucat-1)*nlon_ucat + x_ucat - ELSE - allocate (ucat_gdid (0)) - ENDIF - ENDIF - - CALL build_compute_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) - CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) - CALL build_compute_pushdata (numucat, ucat_gdid, numinpm, inpm_gdid, push_ucat2grid) - CALL build_compute_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) - - IF (allocated(idmap_x)) deallocate (idmap_x) - IF (allocated(idmap_y)) deallocate (idmap_y) - IF (p_is_root) THEN - IF (allocated(allgrd_in_inp )) deallocate (allgrd_in_inp ) - IF (allocated(nucat_g2d )) deallocate (nucat_g2d ) - IF (allocated(iucat_g )) deallocate (iucat_g ) - IF (allocated(idmap_uc2gd_all)) deallocate (idmap_uc2gd_all) - IF (allocated(area_uc2gd_all )) deallocate (area_uc2gd_all ) - ENDIF - - ! ----- Part 2: between upstream and downstream unit catchments ----- - - IF (p_is_root) THEN - - upnmax = maxval(nups_nst) - allocate (ucat_ups (upnmax,totalnumucat)) - ucat_ups(:,:) = 0 - allocate (ucat_next_all (totalnumucat)) - ucat_next_all = ucat_next - - iups_nst(:) = 0 - DO i = 1, totalnumucat - j = ucat_next(i) - IF (j > 0) THEN - iups_nst(j) = iups_nst(j) + 1 - ucat_ups(iups_nst(j),j) = i - ENDIF - ENDDO - - ENDIF - - -#ifdef COLM_PARALLEL - CALL mpi_bcast (upnmax, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - - IF (p_is_root) THEN - - self_rank = -1 - DO irank = 0, p_np_compute-1 - - nucat = numucat_rank(irank) - - IF (nucat > 0) THEN - IF (p_address_compute(irank) == p_iam_glb) THEN - self_rank = irank - CYCLE - ENDIF - - allocate (idata1d (nucat)) - idata1d = ucat_next(ucat_data_address(irank)%val) - - allocate (idata2d (upnmax,nucat)) - DO i = 1, nucat - idata2d(:,i) = ucat_ups(:,ucat_data_address(irank)%val(i)) - ENDDO - - CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - - deallocate (idata1d) - deallocate (idata2d) - ENDIF - ENDDO - - IF (self_rank >= 0) THEN - nucat = numucat_rank(self_rank) - IF (nucat > 0) THEN - allocate (idata1d (nucat)) - idata1d = ucat_next(ucat_data_address(self_rank)%val) - - allocate (idata2d (upnmax,nucat)) - DO i = 1, nucat - idata2d(:,i) = ucat_ups(:,ucat_data_address(self_rank)%val(i)) - ENDDO - - IF (allocated(ucat_next)) deallocate(ucat_next) - IF (allocated(ucat_ups )) deallocate(ucat_ups ) - allocate (ucat_next (nucat)) - allocate (ucat_ups (upnmax,nucat)) - ucat_next = idata1d - ucat_ups = idata2d - - deallocate (idata1d) - deallocate (idata2d) - ELSE - IF (allocated(ucat_next)) deallocate(ucat_next) - IF (allocated(ucat_ups )) deallocate(ucat_ups ) - allocate (ucat_next (0)) - allocate (ucat_ups (upnmax,0)) - ENDIF - ENDIF - - IF (.not. (p_is_compute .and. numucat > 0)) THEN - IF (allocated(ucat_ups)) deallocate (ucat_ups) - ENDIF - - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - - IF (numucat > 0) THEN - - allocate (ucat_next (numucat)) - CALL mpi_recv (ucat_next, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (ucat_ups (upnmax, numucat)) - CALL mpi_recv (ucat_ups, upnmax*numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_compute) THEN - IF (.not. allocated(ucat_next)) allocate (ucat_next (0)) - IF (.not. allocated(ucat_ups )) allocate (ucat_ups (upnmax,0)) - allocate (wts_ups (upnmax,numucat)) - IF (numucat > 0) wts_ups(:,:) = 1. - ENDIF - - CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) - CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) - -#ifdef CoLMDEBUG - ! IF (p_is_compute) THEN - ! write(*,'(A,I0,A,I0,A,I0,A)') 'rank ', p_iam_compute, ' has ', numucat, & - ! ' unit catchment with ', sum(push_next2ucat%n_from_other), ' downstream to other ranks' - ! ENDIF -#endif - - ! ----- Part 3: river systems ----- - -#ifdef COLM_PARALLEL - IF (p_is_root) THEN - self_rank = -1 - DO irank = 0, p_np_compute-1 - nucat = numucat_rank(irank) - IF (nucat > 0) THEN - IF (p_address_compute(irank) == p_iam_glb) THEN - self_rank = irank - CYCLE - ENDIF - - allocate (idata1d (nucat)) - idata1d = rivermouth(ucat_data_address(irank)%val) - CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - deallocate (idata1d) - ENDIF - ENDDO - - IF (self_rank >= 0) THEN - nucat = numucat_rank(self_rank) - allocate (idata1d (nucat)) - IF (nucat > 0) idata1d = rivermouth(ucat_data_address(self_rank)%val) - IF (allocated(rivermouth)) deallocate(rivermouth) - allocate (rivermouth (nucat)) - IF (nucat > 0) rivermouth = idata1d - deallocate (idata1d) - ENDIF - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - IF (numucat > 0) THEN - allocate (rivermouth (numucat)) - CALL mpi_recv (rivermouth, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF - - IF (p_is_compute) THEN - IF (numucat > 0) THEN - color = maxval(rivermouth) - CALL mpi_comm_split (p_comm_compute, color, p_iam_compute, p_comm_rivsys, p_err) - ELSE - CALL mpi_comm_split (p_comm_compute, MPI_UNDEFINED, p_iam_compute, p_comm_rivsys, p_err) - ENDIF - - rivsys_by_multiple_procs = .false. - IF (p_comm_rivsys /= MPI_COMM_NULL) THEN - CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err) - IF (p_np_rivsys > 1) THEN - rivsys_by_multiple_procs = .true. - ENDIF - ENDIF - ENDIF -#else - rivsys_by_multiple_procs = .false. -#endif - - IF (p_is_compute) THEN - - IF (numucat > 0) allocate (irivsys (numucat)) - - IF (.not. rivsys_by_multiple_procs) THEN - IF (numucat > 0) THEN - - allocate (order_ucat (numucat)) - order_ucat = (/(i, i = 1, numucat)/) - - CALL quicksort (numucat, rivermouth, order_ucat) - - numrivsys = 1 - irivsys(order_ucat(1)) = numrivsys - DO i = 2, numucat - IF (rivermouth(i) /= rivermouth(i-1)) THEN - numrivsys = numrivsys + 1 - ENDIF - irivsys(order_ucat(i)) = numrivsys - ENDDO - - ENDIF - ELSE - numrivsys = 1 - irivsys(:) = 1 - ENDIF - - ENDIF - - IF (allocated(rivermouth)) deallocate(rivermouth) - IF (allocated(order_ucat)) deallocate(order_ucat) - - ! ----- Parameters for River and Lake ----- - - CALL readin_riverlake_parameter (parafile, 'topo_rivelv', rdata1d = topo_rivelv ) - CALL readin_riverlake_parameter (parafile, 'topo_rivhgt', rdata1d = topo_rivhgt ) - CALL readin_riverlake_parameter (parafile, 'topo_rivlen', rdata1d = topo_rivlen ) - CALL readin_riverlake_parameter (parafile, 'topo_rivman', rdata1d = topo_rivman ) - CALL readin_riverlake_parameter (parafile, 'topo_rivwth', rdata1d = topo_rivwth ) - CALL readin_riverlake_parameter (parafile, 'topo_rivstomax', rdata1d = topo_rivstomax) - CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) - CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) - - IF (p_is_compute) THEN - IF (numucat > 0) THEN - - allocate (lake_type (numucat)) - lake_type(:) = 0 - - allocate (topo_rivare (numucat)) - topo_rivare = topo_rivstomax / topo_rivhgt - - allocate (floodplain_curve (numucat)) - - DO i = 1, numucat - floodplain_curve(i)%nlfp = size(topo_fldhgt,1) - floodplain_curve(i)%rivhgt = topo_rivhgt(i) - floodplain_curve(i)%rivstomax = topo_rivstomax(i) - floodplain_curve(i)%rivare = topo_rivare(i) - - allocate (floodplain_curve(i)%flphgt (0:floodplain_curve(i)%nlfp)) - allocate (floodplain_curve(i)%flparea (0:floodplain_curve(i)%nlfp)) - allocate (floodplain_curve(i)%flpaccare (0:floodplain_curve(i)%nlfp)) - allocate (floodplain_curve(i)%flpstomax (0:floodplain_curve(i)%nlfp)) - - floodplain_curve(i)%flphgt(0) = 0. - floodplain_curve(i)%flphgt(1:) = topo_fldhgt(:,i) - - floodplain_curve(i)%flparea(0) = 0. - floodplain_curve(i)%flparea(1:) = topo_area(i) / floodplain_curve(i)%nlfp - - floodplain_curve(i)%flpaccare(0) = 0. - DO j = 1, floodplain_curve(i)%nlfp - floodplain_curve(i)%flpaccare(j) = & - floodplain_curve(i)%flpaccare(j-1) + floodplain_curve(i)%flparea(j) - ENDDO - - floodplain_curve(i)%flpstomax(0) = 0. - DO j = 1, floodplain_curve(i)%nlfp - floodplain_curve(i)%flpstomax(j) = floodplain_curve(i)%flpstomax(j-1) & - + 0.5 * (floodplain_curve(i)%flparea(j) + floodplain_curve(i)%flparea(j-1)) & - * (floodplain_curve(i)%flphgt(j) - floodplain_curve(i)%flphgt(j-1)) - ENDDO - ENDDO - - allocate (bedelv_next (numucat)) - allocate (outletwth (numucat)) - - ELSE - allocate (bedelv_next (0)) - allocate (outletwth (0)) - ENDIF - ENDIF - - CALL compute_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) - CALL compute_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) - - IF (p_is_compute) THEN - IF (numucat > 0) THEN - WHERE (ucat_next > 0) - outletwth = (outletwth + topo_rivwth) * 0.5 - ELSEWHERE - outletwth = topo_rivwth - END WHERE - ENDIF - ENDIF - - ! ----- Mask of Grids with all upstream area in the simulation region ----- - - IF (p_is_root) allocate (ucat_area_all (totalnumucat)) - -#ifdef COLM_PARALLEL - IF (p_is_compute .and. (.not. p_is_root)) THEN - - IF (numucat > 0) THEN - CALL mpi_send (push_inpm2ucat%sum_area, numucat, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - - ENDIF - - IF (p_is_root) THEN - - DO irank = 0, p_np_compute-1 - IF (numucat_rank(irank) > 0) THEN - - allocate (rdata1d (numucat_rank(irank))) - IF (p_address_compute(irank) == p_iam_glb) THEN - rdata1d = push_inpm2ucat%sum_area - ELSE - CALL mpi_recv (rdata1d, numucat_rank(irank), MPI_REAL8, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - - ucat_area_all(ucat_data_address(irank)%val) = rdata1d - - deallocate (rdata1d) - ENDIF - - ENDDO - ENDIF -#else - ucat_area_all = push_inpm2ucat%sum_area -#endif - - IF (p_is_root) THEN + real(r8), allocatable :: topo_rivstomax (:) ! max river channel storage [m^3] - allocate (allups_mask_ucat (totalnumucat)) - allups_mask_ucat (:) = 0 + real(r8), allocatable :: topo_area (:) ! floodplain area [m^2] + real(r8), allocatable :: topo_fldhgt (:,:) ! floodplain height profile [m] - iups_nst(:) = 0 - DO i = 1, totalnumucat - j = uc_up2down(i) - IF (ucat_area_all(j) > 0.) THEN - IF (iups_nst(j) == nups_nst(j)) THEN + real(r8), allocatable :: bedelv_next (:) ! downstream river bed elevation [m] + real(r8), allocatable :: outletwth (:) ! river outlet width [m] - allups_mask_ucat(j) = 1 + type :: vol_dep_curve_type + integer :: nlfp + real(r8) :: rivhgt + real(r8) :: rivare + real(r8) :: rivstomax + real(r8), allocatable :: flphgt (:) ! floodplain height profile [m] + real(r8), allocatable :: flparea (:) ! flood plain area [m^2] + real(r8), allocatable :: flpaccare (:) ! flood plain accumulated area [m^2] + real(r8), allocatable :: flpstomax (:) ! max flood plain storage [m^3] + CONTAINS + procedure, PUBLIC :: depth => retrieve_depth_from_volume + procedure, PUBLIC :: volume => retrieve_volume_from_depth + procedure, PUBLIC :: floodarea => retrieve_area_from_depth + final :: vol_depth_curve_free_mem + END type vol_dep_curve_type - IF (ucat_next_all(j) > 0) THEN - iups_nst(ucat_next_all(j)) = iups_nst(ucat_next_all(j)) + 1 - ENDIF - ENDIF - ENDIF - ENDDO + type(vol_dep_curve_type), allocatable :: floodplain_curve (:) - ENDIF -#ifdef COLM_PARALLEL - IF (p_is_root) THEN - self_rank = -1 - DO irank = 0, p_np_compute-1 - IF (numucat_rank(irank) > 0) THEN - IF (p_address_compute(irank) == p_iam_glb) THEN - self_rank = irank - CYCLE - ENDIF - - allocate (rdata1d (numucat_rank(irank))) - rdata1d = allups_mask_ucat(ucat_data_address(irank)%val) - - CALL mpi_send (rdata1d, numucat_rank(irank), MPI_REAL8, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - - deallocate (rdata1d) - ENDIF - ENDDO - - IF (self_rank >= 0) THEN - allocate (rdata1d (numucat_rank(self_rank))) - IF (numucat_rank(self_rank) > 0) & - rdata1d = allups_mask_ucat(ucat_data_address(self_rank)%val) - IF (allocated(allups_mask_ucat)) deallocate(allups_mask_ucat) - allocate (allups_mask_ucat (numucat_rank(self_rank))) - IF (numucat_rank(self_rank) > 0) allups_mask_ucat = rdata1d - deallocate (rdata1d) - ENDIF - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - IF (numucat > 0) THEN - allocate (allups_mask_ucat (numucat)) - CALL mpi_recv (allups_mask_ucat, numucat, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF -#endif +CONTAINS - IF (p_is_compute .and. numucat == 0) THEN - IF (.not. allocated(allups_mask_ucat)) allocate (allups_mask_ucat (0)) - ENDIF + ! ---------- + SUBROUTINE build_riverlake_network () + USE MOD_MPAS_MPI, only: mpas_comm, mpas_mpi_ierr, mpas_mpi_check + IMPLICIT NONE - IF (allocated (uc_up2down )) deallocate (uc_up2down ) - IF (allocated (ucat_next_all)) deallocate (ucat_next_all) - IF (allocated (nups_nst )) deallocate (nups_nst ) - IF (allocated (iups_nst )) deallocate (iups_nst ) - IF (allocated (ucat_area_all)) deallocate (ucat_area_all) + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network construction entry') + CALL build_riverlake_network_mpas_embedded() END SUBROUTINE build_riverlake_network @@ -1239,7 +112,7 @@ END SUBROUTINE build_riverlake_network ! --------- SUBROUTINE build_riverlake_network_mpas_embedded () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_NetCDFSerial USE MOD_Mesh @@ -1251,7 +124,6 @@ SUBROUTINE build_riverlake_network_mpas_embedded () integer, allocatable :: varsize(:) integer, allocatable :: idmap_x(:,:), idmap_y(:,:) integer :: nlat_ucat, nlon_ucat - integer :: inpn integer :: i, j parafile = DEF_UnitCatchment_file @@ -1263,7 +135,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) CALL build_compute_remapdata (landpatch, griducat, remap_patch2inpm) - IF (p_is_compute) THEN + IF (.true.) THEN numinpm = remap_patch2inpm%num_grid IF (numinpm > 0) THEN allocate (inpm_gdid (numinpm)) @@ -1273,17 +145,21 @@ SUBROUTINE build_riverlake_network_mpas_embedded () ENDIF ENDIF - CALL build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) + CALL build_mpas_embedded_local_ucats (parafile, nlon_ucat, nlat_ucat, numinpm, inpm_gdid) CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) + IF (size(varsize) /= 2 .or. varsize(1) < 1 .or. varsize(2) /= totalnumucat) THEN + CALL CoLM_Stop ('ERROR: invalid inpmat_x dimensions in the embedded CoLM unit-catchment file.') + ENDIF inpn = varsize(1) deallocate (varsize) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numucat > 0) THEN CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) CALL ncio_read_indexed_serial (parafile, 'inpmat_area', ucat_ucid, area_gd2uc) + CALL validate_mpas_embedded_inpmat (idmap_x, idmap_y, area_gd2uc, inpn, nlon_ucat, nlat_ucat) allocate (idmap_gd2uc (inpn,numucat)) idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x @@ -1300,26 +176,24 @@ SUBROUTINE build_riverlake_network_mpas_embedded () allocate (area_gd2uc (inpn,0)) ENDIF - CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & + CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, nlat_ucat, inpn, numinpm, inpm_gdid, & nucpart, idmap_uc2gd, area_uc2gd) ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN CALL build_compute_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) - CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, inpm_gdid, push_ucat2grid) - CALL build_compute_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm) ENDIF CALL build_mpas_embedded_local_topology (parafile) - IF (p_is_compute) THEN + IF (.true.) THEN allocate (wts_ups (upnmax,numucat)) IF (numucat > 0) wts_ups(:,:) = 1._r8 CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) - CALL check_mpas_embedded_downstream_ownership () CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + CALL check_mpas_embedded_topology_ownership () ENDIF CALL build_mpas_embedded_river_systems (parafile) @@ -1332,8 +206,9 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL readin_riverlake_parameter (parafile, 'topo_rivstomax', rdata1d = topo_rivstomax) CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) + CALL validate_mpas_embedded_river_parameters () - IF (p_is_compute) THEN + IF (.true.) THEN IF (numucat > 0) THEN allocate (lake_type (numucat)) lake_type(:) = 0 @@ -1357,7 +232,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () floodplain_curve(i)%flphgt(1:) = topo_fldhgt(:,i) floodplain_curve(i)%flparea(0) = 0._r8 - floodplain_curve(i)%flparea(1:) = topo_area(i) / floodplain_curve(i)%nlfp + floodplain_curve(i)%flparea(1:) = topo_area(i) / real(floodplain_curve(i)%nlfp, r8) floodplain_curve(i)%flpaccare(0) = 0._r8 DO j = 1, floodplain_curve(i)%nlfp @@ -1384,7 +259,7 @@ SUBROUTINE build_riverlake_network_mpas_embedded () CALL compute_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) CALL compute_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numucat > 0) THEN WHERE (ucat_next > 0) outletwth = (outletwth + topo_rivwth) * 0.5_r8 @@ -1393,13 +268,6 @@ SUBROUTINE build_riverlake_network_mpas_embedded () END WHERE ENDIF - allocate (allups_mask_ucat (numucat)) - IF (numucat > 0) THEN - allups_mask_ucat(:) = 0._r8 - WHERE (push_inpm2ucat%sum_area > 0._r8) - allups_mask_ucat = 1._r8 - END WHERE - ENDIF ENDIF END SUBROUTINE build_riverlake_network_mpas_embedded @@ -1407,7 +275,7 @@ END SUBROUTINE build_riverlake_network_mpas_embedded ! --------- SUBROUTINE build_mpas_embedded_river_systems (parafile) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_Utils IMPLICIT NONE @@ -1416,14 +284,11 @@ SUBROUTINE build_mpas_embedded_river_systems (parafile) integer, allocatable :: mouth_id(:), next_id(:) integer, allocatable :: request(:), request_order(:), request_next(:) - integer, allocatable :: local_mouths(:), all_mouths(:), global_mouths(:) -#ifdef COLM_PARALLEL - integer, allocatable :: counts(:), displs(:) -#endif - integer :: i, iloc, nactive, niter, nlocal_mouths, total_mouths + integer, allocatable :: local_mouths(:) + integer :: i, iloc, nactive, niter, nlocal_mouths logical :: is_new - IF (.not. p_is_compute) RETURN + IF (.not. .true.) RETURN allocate (irivsys (numucat)) allocate (mouth_id (numucat)) @@ -1435,9 +300,7 @@ SUBROUTINE build_mpas_embedded_river_systems (parafile) next_id = ucat_next DO i = 1, numucat - IF (next_id(i) <= 0) THEN - mouth_id(i) = ucat_ucid(i) - ENDIF + IF (next_id(i) <= 0) mouth_id(i) = ucat_ucid(i) ENDDO nactive = count(next_id > 0) @@ -1487,71 +350,227 @@ SUBROUTINE build_mpas_embedded_river_systems (parafile) CALL insert_into_sorted_list1 (mouth_id(i), nlocal_mouths, local_mouths, iloc, is_new) ENDDO -#ifdef COLM_PARALLEL - allocate (counts (0:p_np_compute-1)) - allocate (displs (0:p_np_compute-1)) - CALL mpi_allgather (nlocal_mouths, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, p_comm_compute, p_err) - - displs(0) = 0 - DO i = 1, p_np_compute-1 - displs(i) = displs(i-1) + counts(i-1) - ENDDO - total_mouths = sum(counts) - - allocate (all_mouths (max(1,total_mouths))) - CALL mpi_allgatherv (local_mouths, nlocal_mouths, MPI_INTEGER, all_mouths, counts, displs, & - MPI_INTEGER, p_comm_compute, p_err) - - allocate (global_mouths (max(1,total_mouths))) - numrivsys = 0 - DO i = 1, total_mouths - CALL insert_into_sorted_list1 (all_mouths(i), numrivsys, global_mouths, iloc, is_new) - ENDDO - - p_comm_rivsys = p_comm_compute - rivsys_by_multiple_procs = p_np_compute > 1 - - deallocate (counts) - deallocate (displs) - deallocate (all_mouths) -#else - total_mouths = nlocal_mouths - allocate (global_mouths (max(1,total_mouths))) numrivsys = nlocal_mouths - IF (numrivsys > 0) global_mouths(1:numrivsys) = local_mouths(1:numrivsys) - rivsys_by_multiple_procs = .false. +#ifdef MPAS_MPI + CALL build_river_system_min_exchange(local_mouths(1:numrivsys)) #endif DO i = 1, numucat - irivsys(i) = find_in_sorted_list1 (mouth_id(i), numrivsys, global_mouths(1:numrivsys)) + irivsys(i) = find_in_sorted_list1 (mouth_id(i), numrivsys, local_mouths(1:numrivsys)) IF (irivsys(i) <= 0) CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river-system map is incomplete.') ENDDO deallocate (mouth_id) deallocate (local_mouths) - deallocate (global_mouths) END SUBROUTINE build_mpas_embedded_river_systems +#ifdef MPAS_MPI + ! --------- + SUBROUTINE build_river_system_min_exchange(local_system_id) + + USE MOD_MPAS_MPI + USE MOD_Utils, only: quicksort + IMPLICIT NONE + + integer, intent(in) :: local_system_id(:) + + integer, allocatable :: next_position(:) + integer, allocatable :: recv_system_id(:) + integer, allocatable :: send_system_id(:) + integer, allocatable :: sorted_order(:) + integer, allocatable :: sorted_system_id(:) + integer :: i + integer :: irank + integer :: nrecv + integer :: owner + integer :: position + + IF (size(local_system_id) /= numrivsys) THEN + CALL CoLM_Stop('ERROR: local embedded CoLM river-system count is inconsistent.') + ENDIF + IF (numrivsys > 0) THEN + IF (any(local_system_id <= 0)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system IDs must be positive.') + ENDIF + IF (numrivsys > 1) THEN + IF (any(local_system_id(2:numrivsys) <= local_system_id(1:numrivsys-1))) THEN + CALL CoLM_Stop('ERROR: local embedded CoLM river-system IDs must be sorted and unique.') + ENDIF + ENDIF + ENDIF + IF (allocated(rivsys_send_counts) .or. allocated(rivsys_send_displs) .or. & + allocated(rivsys_recv_counts) .or. allocated(rivsys_recv_displs) .or. & + allocated(rivsys_send_local) .or. allocated(rivsys_recv_owner)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system exchange was initialized more than once.') + ENDIF + + allocate(rivsys_send_counts(0:mpas_size-1), rivsys_send_displs(0:mpas_size-1)) + allocate(rivsys_recv_counts(0:mpas_size-1), rivsys_recv_displs(0:mpas_size-1)) + rivsys_send_counts = 0 + DO i = 1, numrivsys + owner = modulo(local_system_id(i) - 1, mpas_size) + rivsys_send_counts(owner) = rivsys_send_counts(owner) + 1 + ENDDO + + rivsys_send_displs(0) = 0 + DO irank = 1, mpas_size-1 + rivsys_send_displs(irank) = rivsys_send_displs(irank-1) + rivsys_send_counts(irank-1) + ENDDO + + allocate(next_position(0:mpas_size-1)) + next_position = rivsys_send_displs + allocate(rivsys_send_local(numrivsys)) + allocate(send_system_id(max(1,numrivsys))) + DO i = 1, numrivsys + owner = modulo(local_system_id(i) - 1, mpas_size) + position = next_position(owner) + 1 + next_position(owner) = position + rivsys_send_local(position) = i + send_system_id(position) = local_system_id(i) + ENDDO + + CALL mpi_alltoall(rivsys_send_counts, 1, MPI_INTEGER, rivsys_recv_counts, 1, MPI_INTEGER, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system count exchange failed.') + + rivsys_recv_displs(0) = 0 + DO irank = 1, mpas_size-1 + rivsys_recv_displs(irank) = rivsys_recv_displs(irank-1) + rivsys_recv_counts(irank-1) + ENDDO + nrecv = sum(rivsys_recv_counts) + allocate(recv_system_id(max(1,nrecv))) + + CALL mpi_alltoallv(send_system_id, rivsys_send_counts, rivsys_send_displs, MPI_INTEGER, & + recv_system_id, rivsys_recv_counts, rivsys_recv_displs, MPI_INTEGER, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system ID exchange failed.') + + allocate(rivsys_recv_owner(nrecv)) + num_owned_rivsys = 0 + IF (nrecv > 0) THEN + IF (any(recv_system_id(1:nrecv) <= 0)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM received an invalid river-system ID.') + ENDIF + DO i = 1, nrecv + IF (modulo(recv_system_id(i) - 1, mpas_size) /= mpas_rank) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system request reached the wrong owner rank.') + ENDIF + ENDDO + + allocate(sorted_system_id(nrecv), sorted_order(nrecv)) + sorted_system_id = recv_system_id(1:nrecv) + sorted_order = (/(i, i = 1, nrecv)/) + IF (nrecv > 1) CALL quicksort(nrecv, sorted_system_id, sorted_order) + + DO i = 1, nrecv + IF (i == 1) THEN + num_owned_rivsys = num_owned_rivsys + 1 + ELSEIF (sorted_system_id(i) /= sorted_system_id(i-1)) THEN + num_owned_rivsys = num_owned_rivsys + 1 + ENDIF + rivsys_recv_owner(sorted_order(i)) = num_owned_rivsys + ENDDO + deallocate(sorted_system_id, sorted_order) + ENDIF + + deallocate(next_position, recv_system_id, send_system_id) + + END SUBROUTINE build_river_system_min_exchange + + ! --------- + SUBROUTINE synchronize_river_system_min(system_value) + + USE MOD_MPAS_MPI + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + real(r8), intent(inout) :: system_value(:) + + real(r8), allocatable :: owner_min(:) + real(r8), allocatable :: recv_value(:) + real(r8), allocatable :: return_value(:) + real(r8), allocatable :: send_value(:) + real(r8), allocatable :: synced_value(:) + integer :: i + integer :: nrecv + integer :: owner_index + + IF (size(system_value) < max(1,numrivsys)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system timestep array is too small.') + ENDIF + IF (.not. allocated(rivsys_send_counts) .or. .not. allocated(rivsys_send_displs) .or. & + .not. allocated(rivsys_recv_counts) .or. .not. allocated(rivsys_recv_displs) .or. & + .not. allocated(rivsys_send_local) .or. .not. allocated(rivsys_recv_owner)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system exchange is not initialized.') + ENDIF + IF (numrivsys > 0) THEN + IF (.not. all(ieee_is_finite(system_value(1:numrivsys))) .or. & + any(system_value(1:numrivsys) < 0._r8)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system exchange received an invalid timestep.') + ENDIF + ENDIF + + nrecv = sum(rivsys_recv_counts) + allocate(send_value(max(1,numrivsys)), synced_value(max(1,numrivsys))) + allocate(recv_value(max(1,nrecv)), return_value(max(1,nrecv))) + allocate(owner_min(max(1,num_owned_rivsys))) + + DO i = 1, numrivsys + send_value(i) = system_value(rivsys_send_local(i)) + ENDDO + CALL mpi_alltoallv(send_value, rivsys_send_counts, rivsys_send_displs, MPI_REAL8, & + recv_value, rivsys_recv_counts, rivsys_recv_displs, MPI_REAL8, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system timestep exchange failed.') + + owner_min = huge(1._r8) + DO i = 1, nrecv + owner_index = rivsys_recv_owner(i) + IF (owner_index < 1 .or. owner_index > num_owned_rivsys) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system owner address is invalid.') + ENDIF + owner_min(owner_index) = min(owner_min(owner_index), recv_value(i)) + ENDDO + DO i = 1, nrecv + return_value(i) = owner_min(rivsys_recv_owner(i)) + ENDDO + + CALL mpi_alltoallv(return_value, rivsys_recv_counts, rivsys_recv_displs, MPI_REAL8, & + synced_value, rivsys_send_counts, rivsys_send_displs, MPI_REAL8, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system timestep return exchange failed.') + + DO i = 1, numrivsys + system_value(rivsys_send_local(i)) = synced_value(i) + ENDDO + + deallocate(owner_min, recv_value, return_value, send_value, synced_value) + + END SUBROUTINE synchronize_river_system_min +#endif + ! --------- - SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid) + SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, nlat_ucat, numinpm, inpm_gdid) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_Utils IMPLICIT NONE character(len=*), intent(in) :: parafile - integer, intent(in) :: nlon_ucat + integer, intent(in) :: nlon_ucat, nlat_ucat integer, intent(in) :: numinpm integer, intent(in) :: inpm_gdid(:) integer, parameter :: ucat_chunk_size = 131072 integer, allocatable :: inpm_sorted(:), inpm_order(:) integer, allocatable :: seq_x_blk(:), seq_y_blk(:) - integer :: istart, iend, iucat, iloc, grid_id, nfound + integer, allocatable :: local_owner_blk(:), owner_blk(:) + integer :: istart, iend, iucat, iblk, iloc, grid_id, nfound + integer :: covered_count, global_owned - IF (.not. p_is_compute) RETURN + IF (.not. .true.) RETURN IF (numinpm > 0) THEN allocate (inpm_sorted (numinpm)) @@ -1559,63 +578,130 @@ SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_g inpm_sorted = inpm_gdid inpm_order = (/(iucat, iucat = 1, numinpm)/) CALL quicksort (numinpm, inpm_sorted, inpm_order) + IF (any(inpm_sorted < 1) .or. any(inpm_sorted > nlon_ucat*nlat_ucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM runoff input grid contains an out-of-range grid ID.') + ENDIF + IF (numinpm > 1) THEN + IF (any(inpm_sorted(2:) == inpm_sorted(:numinpm-1))) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM runoff input grid contains duplicate local grid IDs.') + ENDIF + ENDIF + ENDIF - nfound = 0 - istart = 1 - DO WHILE (istart <= totalnumucat) - iend = min(istart + ucat_chunk_size - 1, totalnumucat) - CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) - CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) - - DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) - IF (seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN - grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) - iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) - IF (iloc > 0) nfound = nfound + 1 - ENDIF - ENDDO + nfound = 0 + covered_count = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) + CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + IF (size(seq_x_blk) /= size(seq_y_blk)) THEN + CALL CoLM_Stop ('ERROR: seq_x and seq_y lengths differ in the embedded CoLM river network.') + ENDIF + IF (any(seq_x_blk < 1) .or. any(seq_x_blk > nlon_ucat) .or. & + any(seq_y_blk < 1) .or. any(seq_y_blk > nlat_ucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM unit-catchment coordinates are outside the runoff input grid.') + ENDIF - deallocate (seq_x_blk) - deallocate (seq_y_blk) - istart = iend + 1 + allocate (local_owner_blk (size(seq_x_blk))) + allocate (owner_blk (size(seq_x_blk))) + local_owner_blk(:) = huge(1) + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + iblk = iucat - lbound(seq_x_blk,1) + 1 + IF (numinpm > 0 .and. seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) local_owner_blk(iblk) = mpas_rank + ENDIF ENDDO - ELSE - nfound = 0 + +#ifdef MPAS_MPI + CALL mpi_allreduce (local_owner_blk, owner_blk, size(local_owner_blk), MPI_INTEGER, & + MPI_MIN, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network first-pass ownership reduction') +#else + owner_blk = local_owner_blk +#endif + + covered_count = covered_count + count(owner_blk < huge(1)) + nfound = nfound + count(owner_blk == mpas_rank) + + deallocate (seq_x_blk) + deallocate (seq_y_blk) + deallocate (local_owner_blk) + deallocate (owner_blk) + istart = iend + 1 + ENDDO + +#ifdef MPAS_MPI + CALL mpi_allreduce (nfound, global_owned, 1, MPI_INTEGER, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network ownership-count reduction') +#else + global_owned = nfound +#endif + + IF (global_owned /= covered_count) THEN + IF (mpas_is_root) THEN + write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM river network covered ', covered_count, & + ' unit-catchment(s), but assigned ', global_owned + ENDIF + CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network ownership partition is inconsistent.') ENDIF numucat = nfound allocate (ucat_ucid (numucat)) - allocate (x_ucat (numucat)) - allocate (y_ucat (numucat)) - allocate (ucat_gdid (numucat)) - IF (numinpm > 0 .and. numucat > 0) THEN - nfound = 0 - istart = 1 - DO WHILE (istart <= totalnumucat) - iend = min(istart + ucat_chunk_size - 1, totalnumucat) - CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) - CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + nfound = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) + CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + IF (size(seq_x_blk) /= size(seq_y_blk)) THEN + CALL CoLM_Stop ('ERROR: seq_x and seq_y lengths differ in the embedded CoLM river network.') + ENDIF + IF (any(seq_x_blk < 1) .or. any(seq_x_blk > nlon_ucat) .or. & + any(seq_y_blk < 1) .or. any(seq_y_blk > nlat_ucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM unit-catchment coordinates are outside the runoff input grid.') + ENDIF - DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) - IF (seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN - grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) - iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) - IF (iloc > 0) THEN - nfound = nfound + 1 - ucat_ucid(nfound) = iucat - x_ucat(nfound) = seq_x_blk(iucat) - y_ucat(nfound) = seq_y_blk(iucat) - ucat_gdid(nfound) = grid_id - ENDIF - ENDIF - ENDDO + allocate (local_owner_blk (size(seq_x_blk))) + allocate (owner_blk (size(seq_x_blk))) + local_owner_blk(:) = huge(1) - deallocate (seq_x_blk) - deallocate (seq_y_blk) - istart = iend + 1 + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + iblk = iucat - lbound(seq_x_blk,1) + 1 + IF (numinpm > 0 .and. seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) local_owner_blk(iblk) = mpas_rank + ENDIF ENDDO - ENDIF + +#ifdef MPAS_MPI + CALL mpi_allreduce (local_owner_blk, owner_blk, size(local_owner_blk), MPI_INTEGER, & + MPI_MIN, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network final ownership reduction') +#else + owner_blk = local_owner_blk +#endif + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + iblk = iucat - lbound(seq_x_blk,1) + 1 + IF (owner_blk(iblk) == mpas_rank) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + nfound = nfound + 1 + ucat_ucid(nfound) = istart + iucat - lbound(seq_x_blk,1) + ENDIF + ENDDO + + deallocate (seq_x_blk) + deallocate (seq_y_blk) + deallocate (local_owner_blk) + deallocate (owner_blk) + istart = iend + 1 + ENDDO IF (allocated(inpm_sorted)) deallocate (inpm_sorted) IF (allocated(inpm_order )) deallocate (inpm_order ) @@ -1624,7 +710,7 @@ END SUBROUTINE build_mpas_embedded_local_ucats SUBROUTINE build_mpas_embedded_local_topology (parafile) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_Utils IMPLICIT NONE @@ -1636,7 +722,7 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) integer, allocatable :: seq_next_blk(:) integer :: istart, iend, iucat, iloc, idn, local_upnmax - IF (.not. p_is_compute) RETURN + IF (.not. .true.) RETURN IF (numucat > 0) THEN CALL ncio_read_indexed_serial (parafile, 'seq_next', ucat_ucid, ucat_next) @@ -1654,6 +740,7 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) DO WHILE (istart <= totalnumucat) iend = min(istart + ucat_chunk_size - 1, totalnumucat) CALL ncio_read_part_serial (parafile, 'seq_next', istart, iend, seq_next_blk) + CALL validate_mpas_embedded_seq_next (seq_next_blk, istart) DO iucat = lbound(seq_next_blk,1), ubound(seq_next_blk,1) idn = seq_next_blk(iucat) @@ -1673,8 +760,9 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) local_upnmax = 0 ENDIF -#ifdef COLM_PARALLEL - CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err) +#ifdef MPAS_MPI + CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network upstream-degree reduction') #else upnmax = local_upnmax #endif @@ -1698,7 +786,8 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) iloc = find_in_sorted_list1 (idn, numucat, ucat_sorted) IF (iloc > 0) THEN ups_fill(ucat_order(iloc)) = ups_fill(ucat_order(iloc)) + 1 - ucat_ups(ups_fill(ucat_order(iloc)), ucat_order(iloc)) = iucat + ucat_ups(ups_fill(ucat_order(iloc)), ucat_order(iloc)) = & + istart + iucat - lbound(seq_next_blk,1) ENDIF ENDIF ENDDO @@ -1713,81 +802,191 @@ SUBROUTINE build_mpas_embedded_local_topology (parafile) deallocate (ucat_order) ENDIF - END SUBROUTINE build_mpas_embedded_local_topology + END SUBROUTINE build_mpas_embedded_local_topology - ! --------- - SUBROUTINE check_mpas_embedded_downstream_ownership () + ! --------- + SUBROUTINE validate_mpas_embedded_seq_next (seq_next, first_id) - USE MOD_SPMD_Task - IMPLICIT NONE + USE MOD_MPAS_MPI, only: CoLM_Stop + IMPLICIT NONE - logical, allocatable :: id_found(:) - integer :: i, irank, ireq - integer :: local_missing, global_missing - integer :: first_missing, global_first_missing + integer, intent(in) :: seq_next(:) + integer, intent(in) :: first_id + integer :: i, source_id - IF (.not. p_is_compute) RETURN + IF (any(seq_next > totalnumucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM seq_next contains an out-of-range unit-catchment ID.') + ENDIF + IF (any(seq_next <= 0 .and. seq_next /= -9 .and. seq_next /= -10 .and. seq_next /= -99)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM seq_next contains an unsupported outlet code.') + ENDIF + DO i = 1, size(seq_next) + source_id = first_id + i - 1 + IF (seq_next(i) == source_id) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM seq_next contains a self-loop.') + ENDIF + ENDDO - local_missing = 0 - first_missing = huge(1) + END SUBROUTINE validate_mpas_embedded_seq_next - IF (numucat > 0 .and. push_next2ucat%num_req_uniq > 0) THEN - allocate (id_found (push_next2ucat%num_req_uniq)) - id_found(:) = .false. + ! --------- + SUBROUTINE check_mpas_embedded_topology_ownership () + + USE MOD_MPAS_MPI + IMPLICIT NONE - IF (push_next2ucat%nself > 0) id_found(push_next2ucat%self_to) = .true. + integer, allocatable :: next_owner_count(:) + integer, allocatable :: ups_owner_count(:) + integer :: i, iup, irank, ireq + integer :: local_bad, global_bad + integer :: first_bad, global_first_bad -#ifdef COLM_PARALLEL - DO irank = 0, p_np_compute-1 - IF (push_next2ucat%n_from_other(irank) > 0) THEN - id_found(push_next2ucat%other_to(irank)%val) = .true. - ENDIF + IF (.not. .true.) RETURN + + local_bad = 0 + first_bad = huge(1) + + allocate (next_owner_count(push_next2ucat%num_req_uniq)) + next_owner_count(:) = 0 + DO i = 1, push_next2ucat%nself + ireq = push_next2ucat%self_to(i) + next_owner_count(ireq) = next_owner_count(ireq) + 1 + ENDDO +#ifdef MPAS_MPI + DO irank = 0, mpas_size-1 + DO i = 1, push_next2ucat%n_from_other(irank) + ireq = push_next2ucat%other_to(irank)%val(i) + next_owner_count(ireq) = next_owner_count(ireq) + 1 + ENDDO + ENDDO +#endif + + allocate (ups_owner_count(push_ups2ucat%num_req_uniq)) + ups_owner_count(:) = 0 + DO i = 1, push_ups2ucat%nself + ireq = push_ups2ucat%self_to(i) + ups_owner_count(ireq) = ups_owner_count(ireq) + 1 + ENDDO +#ifdef MPAS_MPI + DO irank = 0, mpas_size-1 + DO i = 1, push_ups2ucat%n_from_other(irank) + ireq = push_ups2ucat%other_to(irank)%val(i) + ups_owner_count(ireq) = ups_owner_count(ireq) + 1 ENDDO + ENDDO #endif - DO i = 1, numucat - IF (ucat_next(i) > 0) THEN - ireq = push_next2ucat%addr_single(i) - IF (ireq <= 0 .or. .not. id_found(ireq)) THEN - local_missing = local_missing + 1 - first_missing = min(first_missing, ucat_next(i)) + DO i = 1, numucat + IF (ucat_next(i) > 0) THEN + ireq = push_next2ucat%addr_single(i) + IF (ireq <= 0 .or. ireq > size(next_owner_count)) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_next(i)) + ELSEIF (next_owner_count(ireq) /= 1) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_next(i)) + ENDIF + ENDIF + + DO iup = 1, upnmax + IF (ucat_ups(iup,i) > 0) THEN + ireq = push_ups2ucat%addr_multi(iup,i) + IF (ireq <= 0 .or. ireq > size(ups_owner_count)) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_ups(iup,i)) + ELSEIF (ups_owner_count(ireq) /= 1) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_ups(iup,i)) ENDIF ENDIF ENDDO + ENDDO - deallocate (id_found) - ENDIF + deallocate (next_owner_count) + deallocate (ups_owner_count) -#ifdef COLM_PARALLEL - CALL mpi_allreduce (local_missing, global_missing, 1, MPI_INTEGER, MPI_SUM, p_comm_compute, p_err) - CALL mpi_allreduce (first_missing, global_first_missing, 1, MPI_INTEGER, MPI_MIN, p_comm_compute, p_err) +#ifdef MPAS_MPI + CALL mpi_allreduce (local_bad, global_bad, 1, MPI_INTEGER, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network invalid-owner count reduction') + CALL mpi_allreduce (first_bad, global_first_bad, 1, MPI_INTEGER, MPI_MIN, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network first invalid-owner reduction') #else - global_missing = local_missing - global_first_missing = first_missing + global_bad = local_bad + global_first_bad = first_bad #endif - IF (global_missing > 0) THEN - IF (p_is_root) THEN - write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM GridRiverLakeFlow is missing ', & - global_missing, ' downstream unit-catchment owner(s); first missing seq_next = ', & - global_first_missing + IF (global_bad > 0) THEN + IF (mpas_is_root) THEN + write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM GridRiverLakeFlow has ', & + global_bad, ' non-unique or missing topology owner reference(s); first unit-catchment ID = ', & + global_first_bad ENDIF - CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network ownership is incomplete.') + CALL CoLM_Stop ('ERROR: MPAS domain/landdata must contain exactly one owner for every upstream and downstream unit catchment.') + ENDIF + + END SUBROUTINE check_mpas_embedded_topology_ownership + + ! --------- + SUBROUTINE validate_mpas_embedded_inpmat (idmap_x, idmap_y, area, inpn, nlon_ucat, nlat_ucat) + + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + USE MOD_MPAS_MPI, only: CoLM_Stop + IMPLICIT NONE + + integer, intent(in) :: idmap_x(:,:), idmap_y(:,:) + real(r8), intent(in) :: area(:,:) + integer, intent(in) :: inpn, nlon_ucat, nlat_ucat + integer :: first_map + integer :: grid_id + integer :: imap + integer :: imap_other + integer :: iucat + + IF (size(idmap_x,1) /= inpn .or. size(idmap_y,1) /= inpn .or. size(area,1) /= inpn .or. & + size(idmap_x,2) /= size(idmap_y,2) .or. size(idmap_x,2) /= size(area,2)) THEN + CALL CoLM_Stop ('ERROR: inconsistent inpmat dimensions in the embedded CoLM unit-catchment file.') + ENDIF + IF (.not. all(ieee_is_finite(area))) THEN + CALL CoLM_Stop ('ERROR: non-finite inpmat_area in the embedded CoLM unit-catchment file.') + ENDIF + IF (any(area < 0._r8)) THEN + CALL CoLM_Stop ('ERROR: negative inpmat_area in the embedded CoLM unit-catchment file.') + ENDIF + IF (any((area > 0._r8) .and. & + (idmap_x < 1 .or. idmap_x > nlon_ucat .or. idmap_y < 1 .or. idmap_y > nlat_ucat))) THEN + CALL CoLM_Stop ('ERROR: positive unit-catchment overlap area has an out-of-range runoff grid index.') ENDIF + DO iucat = 1, size(area,2) + first_map = 0 + DO imap = 1, inpn + IF (area(imap,iucat) <= 0._r8) CYCLE + IF (first_map == 0) first_map = imap + grid_id = (idmap_y(imap,iucat)-1) * nlon_ucat + idmap_x(imap,iucat) + DO imap_other = imap + 1, inpn + IF (area(imap_other,iucat) <= 0._r8) CYCLE + IF ((idmap_y(imap_other,iucat)-1) * nlon_ucat + idmap_x(imap_other,iucat) == grid_id) THEN + CALL CoLM_Stop ('ERROR: a unit catchment maps to the same runoff grid more than once.') + ENDIF + ENDDO + ENDDO + IF (first_map == 0) THEN + CALL CoLM_Stop ('ERROR: a unit catchment has no positive runoff-grid overlap area.') + ENDIF + ENDDO - END SUBROUTINE check_mpas_embedded_downstream_ownership + END SUBROUTINE validate_mpas_embedded_inpmat ! --------- - SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, & + SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, nlat_ucat, inpn, numinpm, inpm_gdid, & nucpart, idmap_uc2gd, area_uc2gd) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_Utils IMPLICIT NONE character(len=*), intent(in) :: parafile - integer, intent(in) :: nlon_ucat + integer, intent(in) :: nlon_ucat, nlat_ucat integer, intent(in) :: inpn integer, intent(in) :: numinpm integer, intent(in) :: inpm_gdid(:) @@ -1818,6 +1017,7 @@ SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_g CALL ncio_read_part_serial (parafile, 'inpmat_x', (/1,istart/), (/inpn,iend/), idmap_x_blk) CALL ncio_read_part_serial (parafile, 'inpmat_y', (/1,istart/), (/inpn,iend/), idmap_y_blk) CALL ncio_read_part_serial (parafile, 'inpmat_area', (/1,istart/), (/inpn,iend/), area_blk) + CALL validate_mpas_embedded_inpmat (idmap_x_blk, idmap_y_blk, area_blk, inpn, nlon_ucat, nlat_ucat) DO iucat = lbound(idmap_x_blk,2), ubound(idmap_x_blk,2) DO imap = 1, inpn @@ -1844,8 +1044,9 @@ SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_g nucpart_local = 0 ENDIF -#ifdef COLM_PARALLEL - CALL mpi_allreduce (nucpart_local, nucpart, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_allreduce (nucpart_local, nucpart, 1, MPI_INTEGER, MPI_MAX, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network unit-overlap reduction') #else nucpart = nucpart_local #endif @@ -1865,6 +1066,7 @@ SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_g CALL ncio_read_part_serial (parafile, 'inpmat_x', (/1,istart/), (/inpn,iend/), idmap_x_blk) CALL ncio_read_part_serial (parafile, 'inpmat_y', (/1,istart/), (/inpn,iend/), idmap_y_blk) CALL ncio_read_part_serial (parafile, 'inpmat_area', (/1,istart/), (/inpn,iend/), area_blk) + CALL validate_mpas_embedded_inpmat (idmap_x_blk, idmap_y_blk, area_blk, inpn, nlon_ucat, nlat_ucat) DO iucat = lbound(idmap_x_blk,2), ubound(idmap_x_blk,2) DO imap = 1, inpn @@ -1875,7 +1077,8 @@ SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_g IF (iloc > 0) THEN igrd = inpm_order(iloc) nucat_g(igrd) = nucat_g(igrd) + 1 - idmap_uc2gd(nucat_g(igrd),igrd) = iucat + idmap_uc2gd(nucat_g(igrd),igrd) = & + istart + iucat - lbound(idmap_x_blk,2) area_uc2gd (nucat_g(igrd),igrd) = area_blk(imap,iucat) ENDIF ENDIF @@ -1897,159 +1100,73 @@ END SUBROUTINE build_mpas_embedded_uc2gd #endif ! --------- - SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idata1d) + SUBROUTINE validate_mpas_embedded_river_parameters () - USE MOD_SPMD_Task - USE MOD_NetCDFSerial + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + USE MOD_MPAS_MPI, only: CoLM_Stop IMPLICIT NONE - character(len=*), intent(in) :: parafile - character(len=*), intent(in) :: varname - - real(r8), allocatable, intent(inout), optional :: rdata1d (:) - real(r8), allocatable, intent(inout), optional :: rdata2d (:,:) - integer, allocatable, intent(inout), optional :: idata1d (:) + integer :: j - ! Local Variables - integer :: irank, nucat, ndim1, i - real(r8), allocatable :: rsend1d (:) - real(r8), allocatable :: rsend2d (:,:) - integer, allocatable :: isend1d (:) + IF (.not. .true. .or. numucat <= 0) RETURN -#ifdef MPAS_EMBEDDED_COLM - IF (p_is_compute) THEN - IF (present(rdata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata1d) - IF (present(rdata2d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata2d) - IF (present(idata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, idata1d) + IF (.not. allocated(topo_rivelv) .or. .not. allocated(topo_rivhgt) .or. & + .not. allocated(topo_rivlen) .or. .not. allocated(topo_rivman) .or. & + .not. allocated(topo_rivwth) .or. .not. allocated(topo_rivstomax) .or. & + .not. allocated(topo_area) .or. .not. allocated(topo_fldhgt)) THEN + CALL CoLM_Stop ('ERROR: incomplete embedded CoLM river parameter data.') ENDIF -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) -#endif - RETURN -#endif - - IF (p_is_root) THEN - IF (present(rdata1d)) CALL ncio_read_serial (parafile, varname, rdata1d) - IF (present(rdata2d)) CALL ncio_read_serial (parafile, varname, rdata2d) - IF (present(idata1d)) CALL ncio_read_serial (parafile, varname, idata1d) + IF (size(topo_rivelv) /= numucat .or. size(topo_rivhgt) /= numucat .or. & + size(topo_rivlen) /= numucat .or. size(topo_rivman) /= numucat .or. & + size(topo_rivwth) /= numucat .or. size(topo_rivstomax) /= numucat .or. & + size(topo_area) /= numucat .or. size(topo_fldhgt,2) /= numucat .or. & + size(topo_fldhgt,1) < 1) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM river parameter dimensions do not match local unit catchments.') ENDIF - -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) - - IF (present(rdata2d)) THEN - IF (p_is_root) ndim1 = size(rdata2d,1) - CALL mpi_bcast (ndim1, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + IF (.not. all(ieee_is_finite(topo_rivelv)) .or. .not. all(ieee_is_finite(topo_rivhgt)) .or. & + .not. all(ieee_is_finite(topo_rivlen)) .or. .not. all(ieee_is_finite(topo_rivman)) .or. & + .not. all(ieee_is_finite(topo_rivwth)) .or. .not. all(ieee_is_finite(topo_rivstomax)) .or. & + .not. all(ieee_is_finite(topo_area)) .or. .not. all(ieee_is_finite(topo_fldhgt))) THEN + CALL CoLM_Stop ('ERROR: non-finite embedded CoLM river parameter data.') ENDIF + IF (any(topo_rivhgt <= 0._r8) .or. any(topo_rivlen <= 0._r8) .or. & + any(topo_rivman <= 0._r8) .or. any(topo_rivwth <= 0._r8) .or. & + any(topo_rivstomax <= 0._r8) .or. any(topo_area <= 0._r8)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM river geometry and roughness parameters must be positive.') + ENDIF + IF (any(topo_fldhgt(1,:) <= 0._r8)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM floodplain heights must start above the river bank.') + ENDIF + DO j = 2, size(topo_fldhgt,1) + IF (any(topo_fldhgt(j,:) <= topo_fldhgt(j-1,:))) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM floodplain heights must be strictly increasing.') + ENDIF + ENDDO - ! send unit catchment index to ranks - IF (p_is_root) THEN - - DO irank = 0, p_np_compute-1 - - nucat = numucat_rank(irank) - - IF (nucat > 0) THEN - IF (present(rdata1d)) THEN - allocate (rsend1d (nucat)) - - rsend1d = rdata1d(ucat_data_address(irank)%val) - IF (p_address_compute(irank) == p_iam_glb) THEN - IF (allocated(rdata1d)) deallocate(rdata1d) - allocate (rdata1d (nucat)) - rdata1d = rsend1d - ELSE - CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - - deallocate (rsend1d) - ENDIF - - IF (present(rdata2d)) THEN - allocate (rsend2d (ndim1,nucat)) - - DO i = 1, nucat - rsend2d(:,i) = rdata2d(:,ucat_data_address(irank)%val(i)) - ENDDO - IF (p_address_compute(irank) == p_iam_glb) THEN - IF (allocated(rdata2d)) deallocate(rdata2d) - allocate (rdata2d (ndim1,nucat)) - rdata2d = rsend2d - ELSE - CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - - deallocate (rsend2d) - ENDIF - - IF (present(idata1d)) THEN - allocate (isend1d (nucat)) - - isend1d = idata1d(ucat_data_address(irank)%val) - IF (p_address_compute(irank) == p_iam_glb) THEN - IF (allocated(idata1d)) deallocate(idata1d) - allocate (idata1d (nucat)) - idata1d = isend1d - ELSE - CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_compute(irank), & - mpi_tag_data, p_comm_glb, p_err) - ENDIF - - deallocate (isend1d) - ENDIF - ENDIF - ENDDO - - IF (.not. p_is_compute) THEN - IF (present(rdata1d)) deallocate (rdata1d) - IF (present(rdata2d)) deallocate (rdata2d) - IF (present(idata1d)) deallocate (idata1d) - ENDIF - - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN + END SUBROUTINE validate_mpas_embedded_river_parameters - IF (numucat > 0) THEN - IF (present(rdata1d)) THEN - allocate (rdata1d (numucat)) - CALL mpi_recv (rdata1d, numucat, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF + ! --------- + SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idata1d) - IF (present(rdata2d)) THEN - allocate (rdata2d (ndim1,numucat)) - CALL mpi_recv (rdata2d, ndim1*numucat, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF + USE MOD_MPAS_MPI, only: mpas_comm, mpas_mpi_ierr, mpas_mpi_check + USE MOD_NetCDFSerial, only: ncio_read_indexed_serial + IMPLICIT NONE - IF (present(idata1d)) THEN - allocate (idata1d (numucat)) - CALL mpi_recv (idata1d, numucat, MPI_INTEGER, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF + character(len=*), intent(in) :: parafile + character(len=*), intent(in) :: varname + real(r8), allocatable, intent(inout), optional :: rdata1d (:) + real(r8), allocatable, intent(inout), optional :: rdata2d (:,:) + integer, allocatable, intent(inout), optional :: idata1d (:) + IF (.true.) THEN + IF (present(rdata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata1d) + IF (present(rdata2d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata2d) + IF (present(idata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, idata1d) ENDIF + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-parameter indexed read completion') - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_compute .and. numucat == 0) THEN - IF (present(rdata1d)) THEN - IF (.not. allocated(rdata1d)) allocate (rdata1d (0)) - ENDIF - IF (present(rdata2d)) THEN - IF (.not. allocated(rdata2d)) allocate (rdata2d (ndim1,0)) - ENDIF - IF (present(idata1d)) THEN - IF (.not. allocated(idata1d)) allocate (idata1d (0)) - ENDIF - ENDIF - - END SUBROUTINE readin_riverlake_parameter + END SUBROUTINE readin_riverlake_parameter ! FUNCTION retrieve_depth_from_volume (this, volume) result(depth) @@ -2180,14 +1297,7 @@ SUBROUTINE riverlake_network_final () IMPLICIT NONE - IF (allocated(x_ucat )) deallocate(x_ucat ) - IF (allocated(y_ucat )) deallocate(y_ucat ) - IF (allocated(ucat_ucid )) deallocate(ucat_ucid ) - IF (allocated(ucat_gdid )) deallocate(ucat_gdid ) - - IF (allocated(numucat_rank )) deallocate(numucat_rank ) - IF (allocated(ucat_data_address)) deallocate(ucat_data_address) IF (allocated(inpm_gdid )) deallocate(inpm_gdid ) IF (allocated(idmap_gd2uc )) deallocate(idmap_gd2uc ) @@ -2196,7 +1306,16 @@ SUBROUTINE riverlake_network_final () IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) IF (allocated(ucat_next )) deallocate(ucat_next ) IF (allocated(ucat_ups )) deallocate(ucat_ups ) + IF (allocated(wts_ups )) deallocate(wts_ups ) IF (allocated(irivsys )) deallocate(irivsys ) +#ifdef MPAS_MPI + IF (allocated(rivsys_send_counts)) deallocate(rivsys_send_counts) + IF (allocated(rivsys_send_displs)) deallocate(rivsys_send_displs) + IF (allocated(rivsys_recv_counts)) deallocate(rivsys_recv_counts) + IF (allocated(rivsys_recv_displs)) deallocate(rivsys_recv_displs) + IF (allocated(rivsys_send_local )) deallocate(rivsys_send_local ) + IF (allocated(rivsys_recv_owner )) deallocate(rivsys_recv_owner ) +#endif IF (allocated(topo_rivelv )) deallocate(topo_rivelv ) IF (allocated(topo_rivhgt )) deallocate(topo_rivhgt ) @@ -2212,7 +1331,23 @@ SUBROUTINE riverlake_network_final () IF (allocated(floodplain_curve )) deallocate(floodplain_curve ) - IF (allocated(allups_mask_ucat )) deallocate(allups_mask_ucat ) + CALL grid_free_mem(griducat) + CALL compute_remapdata_free_mem(remap_patch2inpm) + CALL compute_pushdata_free_mem(push_inpm2ucat) + CALL compute_pushdata_free_mem(push_ucat2inpm) + CALL compute_pushdata_free_mem(push_next2ucat) + CALL compute_pushdata_free_mem(push_ups2ucat) + + totalnumucat = 0 + numucat = 0 + numinpm = 0 + inpn = 0 + nucpart = 0 + upnmax = 0 + numrivsys = 0 +#ifdef MPAS_MPI + num_owned_rivsys = 0 +#endif END SUBROUTINE riverlake_network_final diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 index 69c329d91f..1b2a91920c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 @@ -19,8 +19,16 @@ MODULE MOD_Grid_RiverLakeTimeVars ! -- state variables -- real(r8), allocatable :: wdsrf_ucat (:) ! river or lake water depth [m] real(r8), allocatable :: veloc_riv (:) ! river velocity [m/s] + real(r8), allocatable :: discharge_riv (:) ! routing-period mean downstream discharge [m3/s] real(r8), allocatable :: momen_riv (:) ! unit river momentum [m^2/s] real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3] + real(r8) :: acctime_rnof = 0._r8 + real(r8), allocatable :: acc_rnof_uc (:) ! accumulated runoff volume [m^3] + + ! Area-weighted diagnostics on the local CoLM element/MPAS-cell mesh. + real(r8), allocatable :: river_water_depth_elm (:) + real(r8), allocatable :: river_velocity_elm (:) + real(r8), allocatable :: river_discharge_elm (:) ! -- restart file path (saved for deferred sediment restart read) -- character(len=512) :: gridriver_restart_file = '' @@ -31,69 +39,128 @@ MODULE MOD_Grid_RiverLakeTimeVars PUBLIC :: read_GridRiverLakeTimeVars PUBLIC :: write_GridRiverLakeTimeVars + PUBLIC :: update_GridRiverLakeElementDiagnostics CONTAINS SUBROUTINE allocate_GridRiverLakeTimeVars - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Grid_RiverLakeNetwork, only: numucat USE MOD_Grid_Reservoir, only: numresv + USE MOD_Mesh, only: numelm + USE MOD_Vars_Global, only: spval IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN + IF (numucat < 0 .or. numresv < 0) THEN + CALL CoLM_stop('Cannot allocate embedded CoLM river state with negative local dimensions.') + ENDIF + IF (allocated(wdsrf_ucat) .or. allocated(veloc_riv) .or. allocated(discharge_riv) .or. & + allocated(momen_riv) .or. allocated(volresv) .or. allocated(acc_rnof_uc) .or. & + allocated(river_water_depth_elm) .or. allocated(river_velocity_elm) .or. & + allocated(river_discharge_elm)) THEN + CALL CoLM_stop('Embedded CoLM river state was allocated more than once.') + ENDIF allocate (wdsrf_ucat (numucat)) allocate (veloc_riv (numucat)) + allocate (discharge_riv(numucat)) allocate (momen_riv (numucat)) allocate (volresv (numresv)) + allocate (acc_rnof_uc(numucat)) + allocate (river_water_depth_elm(numelm)) + allocate (river_velocity_elm (numelm)) + allocate (river_discharge_elm (numelm)) + wdsrf_ucat = 0._r8 + veloc_riv = 0._r8 + discharge_riv = 0._r8 + momen_riv = 0._r8 + volresv = spval + acc_rnof_uc = 0._r8 + river_water_depth_elm = spval + river_velocity_elm = spval + river_discharge_elm = spval + acctime_rnof = 0._r8 ENDIF END SUBROUTINE allocate_GridRiverLakeTimeVars - SUBROUTINE READ_GridRiverLakeTimeVars (file_restart) + SUBROUTINE READ_GridRiverLakeTimeVars (file_restart, require_complete_restart) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist - USE MOD_Vector_ReadWrite -#ifdef MPAS_EMBEDDED_COLM - USE MOD_NetCDFSerial, only: ncio_read_indexed_serial - USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid - USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index -#else - USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_data_address - USE MOD_Grid_Reservoir, only: numresv, resv_data_address, totalnumresv -#endif + USE MOD_NetCDFSerial, only: ncio_read_bcast_serial, ncio_read_indexed_serial, ncio_var_exist + USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_ucid + USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index + USE MOD_Vars_Global, only: spval + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE - character(len=*), intent(in) :: file_restart + character(len=*), intent(in) :: file_restart + logical, intent(in) :: require_complete_restart + logical :: has_acc_rnof + logical :: has_acctime_rnof + logical :: has_discharge - gridriver_restart_file = trim(file_restart) + gridriver_restart_file = trim(file_restart) + has_acc_rnof = ncio_var_exist(file_restart, 'acc_rnof_uc', .false.) + has_acctime_rnof = ncio_var_exist(file_restart, 'acctime_rnof', .false.) + has_discharge = ncio_var_exist(file_restart, 'discharge_riv', .false.) -#ifdef MPAS_EMBEDDED_COLM - IF (p_is_compute .and. numucat > 0) THEN + IF (.true.) THEN + CALL validate_gridriver_indices(ucat_ucid, numucat, totalnumucat, 'unit-catchment') + ENDIF + IF (.true. .and. numucat > 0) THEN CALL ncio_read_indexed_serial (file_restart, 'wdsrf_ucat', ucat_ucid, wdsrf_ucat) CALL ncio_read_indexed_serial (file_restart, 'veloc_riv', ucat_ucid, veloc_riv ) + IF (has_discharge) CALL ncio_read_indexed_serial (file_restart, 'discharge_riv', ucat_ucid, discharge_riv) + IF (has_acc_rnof) CALL ncio_read_indexed_serial (file_restart, 'acc_rnof_uc', ucat_ucid, acc_rnof_uc) ENDIF -#else - CALL vector_read_and_scatter (file_restart, wdsrf_ucat, numucat, 'wdsrf_ucat', ucat_data_address) - CALL vector_read_and_scatter (file_restart, veloc_riv, numucat, 'veloc_riv', ucat_data_address) -#endif + IF (has_acctime_rnof) CALL ncio_read_bcast_serial (file_restart, 'acctime_rnof', acctime_rnof) + IF (.not. has_acc_rnof .or. .not. has_acctime_rnof) THEN + IF (require_complete_restart) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM river restart is missing runoff-accumulator state required for water-continuous restart.' + ENDIF + CALL CoLM_stop('Use a restart containing acc_rnof_uc and acctime_rnof, or start a new simulation.') + ELSE + acc_rnof_uc = 0._r8 + acctime_rnof = 0._r8 + IF (mpas_is_root) THEN + write(*,'(A)') 'Initializing CoLM river runoff accumulators to zero from legacy cold-start data.' + ENDIF + ENDIF + ENDIF + IF (.not. ieee_is_finite(acctime_rnof) .or. acctime_rnof < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river restart contains an invalid runoff accumulation time.') + ENDIF + IF (.true. .and. numucat > 0) THEN + IF (.not. all(ieee_is_finite(wdsrf_ucat)) .or. any(wdsrf_ucat < 0._r8) .or. & + .not. all(ieee_is_finite(veloc_riv)) .or. .not. all(ieee_is_finite(discharge_riv)) .or. & + .not. all(ieee_is_finite(acc_rnof_uc)) .or. & + any(acc_rnof_uc < 0._r8)) THEN + CALL CoLM_stop('Embedded CoLM river restart contains invalid unit-catchment state.') + ENDIF + ENDIF IF (DEF_Reservoir_Method > 0) THEN IF (totalnumresv > 0) THEN -#ifdef MPAS_EMBEDDED_COLM - IF (p_is_compute .and. numresv > 0) THEN - CALL ncio_read_indexed_serial (file_restart, 'volresv', resv_global_index, volresv) + IF (.true. .and. numresv > 0) THEN + CALL validate_gridriver_indices(resv_global_index, numresv, totalnumresv, 'reservoir') + CALL ncio_read_indexed_serial (file_restart, 'volresv', resv_global_index(1:numresv), volresv) + IF (.not. all(ieee_is_finite(volresv)) .or. & + any(volresv < 0._r8 .and. abs(volresv) < 0.5_r8 * abs(spval))) THEN + CALL CoLM_stop('Embedded CoLM river restart contains invalid reservoir storage.') + ENDIF ENDIF -#else - CALL vector_read_and_scatter (file_restart, volresv, numresv, 'volresv', resv_data_address) -#endif ENDIF ENDIF + CALL update_GridRiverLakeElementDiagnostics() + ! Note: sediment restart is read separately in grid_sediment_read_restart, ! called from grid_riverlake_flow_init after sediment module is initialized. @@ -102,42 +169,13 @@ END SUBROUTINE READ_GridRiverLakeTimeVars SUBROUTINE WRITE_GridRiverLakeTimeVars (file_restart) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist -#ifndef MPAS_EMBEDDED_COLM - USE MOD_NetCDFSerial - USE MOD_Vector_ReadWrite - USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_data_address - USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_data_address -#endif IMPLICIT NONE character(len=*), intent(in) :: file_restart -#ifdef MPAS_EMBEDDED_COLM CALL write_gridriver_restart_mpas_embedded (file_restart) -#else - IF (p_is_root) THEN - CALL ncio_create_file (trim(file_restart)) - CALL ncio_define_dimension(file_restart, 'ucatch', totalnumucat) - ENDIF - - CALL vector_gather_and_write (& - wdsrf_ucat, numucat, totalnumucat, ucat_data_address, file_restart, 'wdsrf_ucat', 'ucatch') - - CALL vector_gather_and_write (& - veloc_riv, numucat, totalnumucat, ucat_data_address, file_restart, 'veloc_riv', 'ucatch') - - IF (DEF_Reservoir_Method > 0) THEN - IF (totalnumresv > 0) THEN - - IF (p_is_root) CALL ncio_define_dimension(file_restart, 'reservoir', totalnumresv) - - CALL vector_gather_and_write (& - volresv, numresv, totalnumresv, resv_data_address, file_restart, 'volresv', 'reservoir') - ENDIF - ENDIF -#endif #ifdef GridRiverLakeSediment IF (DEF_USE_SEDIMENT) THEN @@ -147,12 +185,11 @@ SUBROUTINE WRITE_GridRiverLakeTimeVars (file_restart) END SUBROUTINE WRITE_GridRiverLakeTimeVars -#ifdef MPAS_EMBEDDED_COLM SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) USE mpi, only: MPI_INFO_NULL, MPI_OFFSET_KIND USE pnetcdf - USE MOD_SPMD_Task, only: p_comm_compute + USE MOD_MPAS_MPI, only: mpas_comm, mpas_rank, CoLM_stop USE MOD_Namelist, only: DEF_Reservoir_Method USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_ucid USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index @@ -166,12 +203,23 @@ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) integer :: dim_reservoir integer :: var_wdsrf integer :: var_veloc + integer :: var_discharge + integer :: var_acc_rnof + integer :: var_acctime_rnof integer :: var_volresv logical :: write_reservoir write_reservoir = DEF_Reservoir_Method > 0 .and. totalnumresv > 0 - ierr = nf90mpi_create(p_comm_compute, trim(file_restart), & + IF (totalnumucat < 1) THEN + CALL CoLM_stop('Cannot write an embedded CoLM river restart with no global unit catchments.') + ENDIF + CALL validate_gridriver_indices(ucat_ucid, numucat, totalnumucat, 'unit-catchment') + IF (write_reservoir) THEN + CALL validate_gridriver_indices(resv_global_index, numresv, totalnumresv, 'reservoir') + ENDIF + + ierr = nf90mpi_create(mpas_comm, trim(file_restart), & IOR(NF90_CLOBBER, NF90_64BIT_OFFSET), MPI_INFO_NULL, ncid) CALL pnetcdf_check(ierr, 'create', file_restart) @@ -184,6 +232,15 @@ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) ierr = nf90mpi_def_var(ncid, 'veloc_riv', NF90_DOUBLE, (/dim_ucatch/), var_veloc) CALL pnetcdf_check(ierr, 'define veloc_riv', file_restart) + ierr = nf90mpi_def_var(ncid, 'discharge_riv', NF90_DOUBLE, (/dim_ucatch/), var_discharge) + CALL pnetcdf_check(ierr, 'define discharge_riv', file_restart) + + ierr = nf90mpi_def_var(ncid, 'acc_rnof_uc', NF90_DOUBLE, (/dim_ucatch/), var_acc_rnof) + CALL pnetcdf_check(ierr, 'define acc_rnof_uc', file_restart) + + ierr = nf90mpi_def_var(ncid, 'acctime_rnof', NF90_DOUBLE, varid = var_acctime_rnof) + CALL pnetcdf_check(ierr, 'define acctime_rnof', file_restart) + IF (write_reservoir) THEN ierr = nf90mpi_def_dim(ncid, 'reservoir', int(totalnumresv, MPI_OFFSET_KIND), dim_reservoir) CALL pnetcdf_check(ierr, 'define reservoir dimension', file_restart) @@ -198,13 +255,22 @@ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) ierr = nf90mpi_begin_indep_data(ncid) CALL pnetcdf_check(ierr, 'begin independent data mode', file_restart) - CALL pnetcdf_write_real8_points(ncid, var_wdsrf, ucat_ucid, wdsrf_ucat, numucat, & + CALL pnetcdf_write_real8_points(ncid, var_wdsrf, ucat_ucid, wdsrf_ucat, numucat, totalnumucat, & 'wdsrf_ucat', file_restart) - CALL pnetcdf_write_real8_points(ncid, var_veloc, ucat_ucid, veloc_riv, numucat, & + CALL pnetcdf_write_real8_points(ncid, var_veloc, ucat_ucid, veloc_riv, numucat, totalnumucat, & 'veloc_riv', file_restart) + CALL pnetcdf_write_real8_points(ncid, var_discharge, ucat_ucid, discharge_riv, numucat, totalnumucat, & + 'discharge_riv', file_restart) + CALL pnetcdf_write_real8_points(ncid, var_acc_rnof, ucat_ucid, acc_rnof_uc, numucat, totalnumucat, & + 'acc_rnof_uc', file_restart) + + IF (mpas_rank == 0) THEN + ierr = nf90mpi_put_var(ncid, var_acctime_rnof, acctime_rnof) + CALL pnetcdf_check(ierr, 'write acctime_rnof', file_restart) + ENDIF IF (write_reservoir) THEN - CALL pnetcdf_write_real8_points(ncid, var_volresv, resv_global_index, volresv, numresv, & + CALL pnetcdf_write_real8_points(ncid, var_volresv, resv_global_index, volresv, numresv, totalnumresv, & 'volresv', file_restart) ENDIF @@ -216,47 +282,91 @@ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) END SUBROUTINE write_gridriver_restart_mpas_embedded - SUBROUTINE pnetcdf_write_real8_points(ncid, varid, index, data, ndata, varname, filename) + SUBROUTINE pnetcdf_write_real8_points(ncid, varid, index, data, ndata, global_size, varname, filename) USE mpi, only: MPI_OFFSET_KIND USE pnetcdf, only: nf90mpi_put_var - USE MOD_SPMD_Task, only: CoLM_stop + USE MOD_MPAS_MPI, only: CoLM_stop + USE, intrinsic :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE integer, intent(in) :: ncid integer, intent(in) :: varid integer, intent(in) :: index(:) - real(r8), intent(in) :: data(:) + real(r8), intent(inout) :: data(:) integer, intent(in) :: ndata + integer, intent(in) :: global_size character(len=*), intent(in) :: varname character(len=*), intent(in) :: filename integer :: ierr integer :: i + integer :: iend integer(kind=MPI_OFFSET_KIND) :: start(1) - real(r8) :: value + integer(kind=MPI_OFFSET_KIND) :: count(1) - IF (ndata > size(index) .or. ndata > size(data)) THEN + IF (ndata < 0 .or. ndata > size(index) .or. ndata > size(data)) THEN CALL CoLM_stop('PnetCDF indexed write size mismatch for '//trim(varname)) ENDIF DO i = 1, ndata - IF (index(i) < 1) THEN + IF (index(i) < 1 .or. index(i) > global_size) THEN CALL CoLM_stop('PnetCDF indexed write invalid index for '//trim(varname)) ENDIF + IF (.not. ieee_is_finite(data(i))) THEN + CALL CoLM_stop('PnetCDF indexed write contains non-finite data for '//trim(varname)) + ENDIF + ENDDO + i = 1 + DO WHILE (i <= ndata) + iend = i + DO WHILE (iend < ndata) + IF (index(iend + 1) /= index(iend) + 1) EXIT + iend = iend + 1 + ENDDO start(1) = int(index(i), MPI_OFFSET_KIND) - value = data(i) - ierr = nf90mpi_put_var(ncid, varid, value, start=start) + count(1) = int(iend - i + 1, MPI_OFFSET_KIND) + ierr = nf90mpi_put_var(ncid, varid, data(i:iend), start=start, count=count) CALL pnetcdf_check(ierr, 'write '//trim(varname), filename) + i = iend + 1 ENDDO END SUBROUTINE pnetcdf_write_real8_points + SUBROUTINE validate_gridriver_indices(index, ndata, global_size, label) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: index(:) + integer, intent(in) :: ndata + integer, intent(in) :: global_size + character(len=*), intent(in) :: label + + IF (ndata < 0 .or. ndata > size(index)) THEN + CALL CoLM_stop('Invalid local '//trim(label)//' index count in embedded CoLM river routing.') + ENDIF + IF (global_size < 0) THEN + CALL CoLM_stop('Invalid global '//trim(label)//' count in embedded CoLM river routing.') + ENDIF + IF (ndata > 0) THEN + IF (global_size < 1 .or. any(index(1:ndata) < 1) .or. any(index(1:ndata) > global_size)) THEN + CALL CoLM_stop('Out-of-range '//trim(label)//' index in embedded CoLM river routing.') + ENDIF + ENDIF + IF (ndata > 1) THEN + IF (any(index(2:ndata) <= index(1:ndata-1))) THEN + CALL CoLM_stop('Duplicate or unordered '//trim(label)//' indices in embedded CoLM river routing.') + ENDIF + ENDIF + + END SUBROUTINE validate_gridriver_indices + SUBROUTINE pnetcdf_check(status, action, filename) USE pnetcdf, only: NF90_NOERR, nf90mpi_strerror - USE MOD_SPMD_Task, only: CoLM_stop + USE MOD_MPAS_MPI, only: CoLM_stop IMPLICIT NONE integer, intent(in) :: status @@ -270,7 +380,97 @@ SUBROUTINE pnetcdf_check(status, action, filename) ENDIF END SUBROUTINE pnetcdf_check -#endif + + SUBROUTINE update_GridRiverLakeElementDiagnostics() + + IMPLICIT NONE + + CALL map_GridRiverLakeUcatToElement(wdsrf_ucat, river_water_depth_elm) + CALL map_GridRiverLakeUcatToElement(veloc_riv, river_velocity_elm) + CALL map_GridRiverLakeUcatToElement(discharge_riv, river_discharge_elm) + + END SUBROUTINE update_GridRiverLakeElementDiagnostics + + SUBROUTINE map_GridRiverLakeUcatToElement(ucat_data, element_data) + + USE MOD_ComputePushData, only: compute_push_data, compute_remap_data_grid2pset + USE MOD_Grid_RiverLakeNetwork, only: numucat, numinpm, push_ucat2inpm, remap_patch2inpm + USE MOD_LandPatch, only: numpatch, elm_patch + USE MOD_Mesh, only: numelm + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Vars_Global, only: spval + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + real(r8), intent(in) :: ucat_data(:) + real(r8), intent(inout) :: element_data(:) + + real(r8), allocatable :: grid_data(:) + real(r8), allocatable :: patch_data(:) + real(r8) :: weight + real(r8) :: weight_sum + integer :: element + integer :: patch + integer :: patch_start + integer :: patch_end + + IF (size(ucat_data) /= numucat .or. size(element_data) /= numelm) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic dimensions do not match the local decomposition.') + ENDIF + IF (.not. allocated(elm_patch%substt) .or. .not. allocated(elm_patch%subend) .or. & + .not. allocated(elm_patch%subfrc)) THEN + CALL CoLM_stop('Embedded CoLM river diagnostics require a complete element-patch map.') + ENDIF + IF (size(elm_patch%substt) < numelm .or. size(elm_patch%subend) < numelm .or. & + size(elm_patch%subfrc) < numpatch) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic element-patch map has inconsistent dimensions.') + ENDIF + IF (numucat > 0) THEN + IF (.not. all(ieee_is_finite(ucat_data))) THEN + CALL CoLM_stop('Embedded CoLM river diagnostics contain non-finite unit-catchment values.') + ENDIF + ENDIF + + allocate(grid_data(numinpm)) + allocate(patch_data(numpatch)) + grid_data = spval + patch_data = spval + element_data = spval + + CALL compute_push_data(push_ucat2inpm, ucat_data, grid_data, fillvalue=spval, mode='average') + CALL compute_remap_data_grid2pset(remap_patch2inpm, grid_data, patch_data, fillvalue=spval, mode='average') + + DO element = 1, numelm + patch_start = elm_patch%substt(element) + patch_end = elm_patch%subend(element) + IF (patch_start < 1 .or. patch_end < patch_start .or. patch_end > numpatch) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic encountered an invalid element-patch range.') + ENDIF + + element_data(element) = 0._r8 + weight_sum = 0._r8 + DO patch = patch_start, patch_end + weight = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(weight) .or. weight < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic encountered an invalid patch fraction.') + ENDIF + IF (weight > 0._r8 .and. ieee_is_finite(patch_data(patch)) .and. & + abs(patch_data(patch)) < 0.5_r8 * abs(spval)) THEN + element_data(element) = element_data(element) + weight * patch_data(patch) + weight_sum = weight_sum + weight + ENDIF + ENDDO + IF (weight_sum > 0._r8) THEN + element_data(element) = element_data(element) / weight_sum + ELSE + element_data(element) = spval + ENDIF + ENDDO + + deallocate(grid_data) + deallocate(patch_data) + + END SUBROUTINE map_GridRiverLakeUcatToElement SUBROUTINE deallocate_GridRiverLakeTimeVars @@ -278,8 +478,15 @@ SUBROUTINE deallocate_GridRiverLakeTimeVars IF (allocated (wdsrf_ucat)) deallocate (wdsrf_ucat) IF (allocated (veloc_riv )) deallocate (veloc_riv ) + IF (allocated (discharge_riv)) deallocate (discharge_riv) IF (allocated (momen_riv )) deallocate (momen_riv ) IF (allocated (volresv )) deallocate (volresv ) + IF (allocated (acc_rnof_uc)) deallocate (acc_rnof_uc) + IF (allocated (river_water_depth_elm)) deallocate (river_water_depth_elm) + IF (allocated (river_velocity_elm )) deallocate (river_velocity_elm ) + IF (allocated (river_discharge_elm )) deallocate (river_discharge_elm ) + acctime_rnof = 0._r8 + gridriver_restart_file = '' END SUBROUTINE deallocate_GridRiverLakeTimeVars diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 index e5ef3018ca..f1ddc2df3c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 @@ -3561,50 +3561,31 @@ END FUNCTION find_unsat_lev_lower ! ----- SUBROUTINE print_VSF_iteration_stat_info () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE integer(8), SAVE :: count_implicit_accum = 0 integer(8), SAVE :: count_explicit_accum = 0 integer(8), SAVE :: count_wet2dry_accum = 0 - integer :: iwork - #ifdef CoLMDEBUG - IF (p_is_compute) THEN -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err) -#endif - IF (p_iam_compute == p_root) THEN - count_implicit_accum = count_implicit_accum + count_implicit - count_explicit_accum = count_explicit_accum + count_explicit - count_wet2dry_accum = count_wet2dry_accum + count_wet2dry - -#ifdef USEMPI - CALL mpi_send (count_implicit, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_explicit, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_wet2dry, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_implicit_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_explicit_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (count_wet2dry_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN - -#ifdef USEMPI - iwork = p_address_compute(p_root) - CALL mpi_recv (count_implicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (count_explicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (count_wet2dry , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (count_implicit_accum, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (count_explicit_accum, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (count_wet2dry_accum , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + IF (.true.) THEN +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('VSF implicit-iteration count reduction') + CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('VSF explicit-iteration count reduction') + CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('VSF wet-to-dry count reduction') #endif - - write(*,"(/,A,I13,A,I13,A,I13,A)") 'VSF scheme this step: ', & + IF (mpas_rank == mpas_root) THEN + count_implicit_accum = count_implicit_accum + count_implicit + count_explicit_accum = count_explicit_accum + count_explicit + count_wet2dry_accum = count_wet2dry_accum + count_wet2dry + ENDIF + ENDIF + + IF (mpas_is_root) THEN + write(*,"(/,A,I13,A,I13,A,I13,A)") 'VSF scheme this step: ', & count_implicit, ' (implicit)', count_explicit, ' (explicit)', count_wet2dry, ' (wet2dry)' write(*,"(A,I13,A,I13,A,I13,A)") 'VSF scheme all steps: ', & count_implicit_accum, ' (implicit)', count_explicit_accum, ' (explicit)', & diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 deleted file mode 100644 index 35d7de3e75..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90 +++ /dev/null @@ -1,291 +0,0 @@ -#include - -MODULE MOD_Vector_ReadWrite -!----------------------------------------------------------------------- -! DESCRIPTION: -! -! Read/Write data in vector form. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - PUBLIC :: vector_gather_and_write - PUBLIC :: vector_gather_map2grid_and_write - PUBLIC :: vector_read_and_scatter - -CONTAINS - - ! ------- - SUBROUTINE vector_gather_to_root ( & - vector, vlen, totalvlen, data_address, wdata) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_DataType - IMPLICIT NONE - - real(r8), intent(in) :: vector (:) - integer, intent(in) :: vlen - integer, intent(in) :: totalvlen - - type(pointer_int32_1d), intent(in) :: data_address (0:) - - real(r8), allocatable, intent(inout) :: wdata (:) - - ! Local variables - integer :: iwork, mesg(2), isrc, ndata - real(r8), allocatable :: rcache(:) - - IF (totalvlen <= 0) RETURN - - IF (p_is_root) THEN - allocate (wdata (totalvlen)) - ENDIF - -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) - - IF (p_is_compute .and. (.not. p_is_root)) THEN - mesg = (/p_iam_glb, vlen/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (vlen > 0) THEN - CALL mpi_send (vector, vlen, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDIF - - IF (p_is_root) THEN - IF (p_is_compute .and. vlen > 0) THEN - wdata(data_address(p_iam_compute)%val) = vector - ENDIF - - DO iwork = 0, p_np_compute-1 - IF (p_address_compute(iwork) == p_iam_glb) CYCLE - - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate(rcache (ndata)) - - CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - wdata(data_address(p_itis_compute(isrc))%val) = rcache - - deallocate (rcache) - ENDIF - ENDDO - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - wdata(data_address(0)%val) = vector -#endif - - END SUBROUTINE vector_gather_to_root - - ! ------- - SUBROUTINE vector_gather_and_write ( vector, vlen, totalvlen, data_address, & - fileout, varname, dimname, itime_in_file, longname, units) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_NetCDFSerial - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(in) :: vector (:) - integer, intent(in) :: vlen - integer, intent(in) :: totalvlen - - type(pointer_int32_1d), intent(in) :: data_address (0:) - - character(len=*), intent(in) :: fileout - character(len=*), intent(in) :: varname - character(len=*), intent(in) :: dimname - - integer, intent(in), optional :: itime_in_file - character(len=*), intent(in), optional :: longname - character(len=*), intent(in), optional :: units - - ! Local variables - real(r8), allocatable :: wdata(:) - logical :: write_attr - - - CALL vector_gather_to_root (vector, vlen, totalvlen, data_address, wdata) - - IF (p_is_root) THEN - - IF (present(itime_in_file)) THEN - CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata, & - dimname, 'time', DEF_HIST_CompressLevel) - ELSE - CALL ncio_write_serial (fileout, varname, wdata, & - dimname, DEF_REST_CompressLevel) - ENDIF - - IF (present(itime_in_file)) THEN - write_attr = itime_in_file <= 1 - ELSE - write_attr = .true. - ENDIF - - IF (write_attr) THEN - CALL ncio_put_attr (fileout, varname, 'missing_value', spval) - IF (present(longname)) CALL ncio_put_attr (fileout, varname, 'long_name', longname) - IF (present(units )) CALL ncio_put_attr (fileout, varname, 'units', units ) - ENDIF - - deallocate (wdata) - - ENDIF - - END SUBROUTINE vector_gather_and_write - - ! ------- - SUBROUTINE vector_gather_map2grid_and_write ( & - vector, vlen, totalvlen, data_address, nlon, x_vec, nlat, y_vec, & - fileout, varname, lon_name, lat_name, itime_in_file, longname, units) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_DataType - USE MOD_NetCDFSerial - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: fileout - real(r8), intent(in) :: vector (:) - integer, intent(in) :: vlen - integer, intent(in) :: totalvlen - character(len=*), intent(in) :: varname - character(len=*), intent(in) :: lon_name, lat_name - - type(pointer_int32_1d), intent(in) :: data_address (0:) - - integer, intent(in) :: nlon, x_vec (:) - integer, intent(in) :: nlat, y_vec (:) - - integer, intent(in), optional :: itime_in_file - character(len=*), intent(in), optional :: longname - character(len=*), intent(in), optional :: units - - ! Local variables - integer :: i - real(r8), allocatable :: wdata(:), wdata2d(:,:) - logical :: write_attr - - CALL vector_gather_to_root (vector, vlen, totalvlen, data_address, wdata) - - IF (p_is_root) THEN - - allocate (wdata2d (nlon,nlat)) - wdata2d(:,:) = spval - - DO i = 1, totalvlen - wdata2d(x_vec(i),y_vec(i)) = wdata(i) - ENDDO - - IF (present(itime_in_file)) THEN - CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata2d, & - lon_name, lat_name, 'time', DEF_HIST_CompressLevel) - ELSE - CALL ncio_write_serial (fileout, varname, wdata2d, & - lon_name, lat_name, DEF_REST_CompressLevel) - ENDIF - - IF (present(itime_in_file)) THEN - write_attr = itime_in_file == 1 - ELSE - write_attr = .true. - ENDIF - - IF (write_attr) THEN - CALL ncio_put_attr (fileout, varname, 'missing_value', spval) - IF (present(longname)) CALL ncio_put_attr (fileout, varname, 'long_name', longname) - IF (present(units )) CALL ncio_put_attr (fileout, varname, 'units', units ) - ENDIF - - deallocate (wdata ) - deallocate (wdata2d) - - ENDIF - - END SUBROUTINE vector_gather_map2grid_and_write - - ! ----- - SUBROUTINE vector_read_and_scatter ( & - filein, vector, vlen, varname, data_address) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_DataType - USE MOD_NetCDFSerial - IMPLICIT NONE - - character(len=*), intent(in) :: filein - real(r8), allocatable, intent(inout) :: vector (:) - integer, intent(in) :: vlen - character(len=*), intent(in) :: varname - type(pointer_int32_1d), intent(in) :: data_address (0:) - - ! Local variables - integer :: iwork, ndata - real(r8), allocatable :: rdata(:), rcache(:) - - IF (p_is_root) THEN - CALL ncio_read_serial (filein, varname, rdata) - ENDIF - -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) - - IF (p_is_root) THEN - DO iwork = 0, p_np_compute-1 - IF (allocated(data_address(iwork)%val)) THEN - - ndata = size(data_address(iwork)%val) - allocate(rcache (ndata)) - rcache = rdata(data_address(iwork)%val) - - IF (p_address_compute(iwork) == p_iam_glb) THEN - IF (ndata > 0) THEN - IF (.not. allocated(vector)) allocate(vector(ndata)) - vector = rcache - ENDIF - ELSE - CALL mpi_send (rcache, ndata, MPI_REAL8, & - p_address_compute(iwork), mpi_tag_data, p_comm_glb, p_err) - ENDIF - - deallocate (rcache) - ENDIF - ENDDO - ENDIF - - IF (p_is_compute .and. (.not. p_is_root)) THEN - IF (vlen > 0) THEN - IF (.not. allocated(vector)) allocate(vector(vlen)) - CALL mpi_recv (vector, vlen, MPI_REAL8, p_address_root, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - IF (.not. allocated(vector)) allocate(vector(vlen)) - vector = rdata(data_address(0)%val) -#endif - - IF (p_is_root) deallocate(rdata) - - END SUBROUTINE vector_read_and_scatter - -END MODULE MOD_Vector_ReadWrite diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 deleted file mode 100644 index d479bf8cea..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90 +++ /dev/null @@ -1,685 +0,0 @@ -#include - -MODULE MOD_CheckEquilibrium - -!---------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Check equilibrium state. -! -! Created by Shupeng Zhang, 10/2024 -!---------------------------------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Grid - USE netcdf - USE MOD_NetCDFSerial - USE MOD_SpatialMapping - USE MOD_Forcing, only: forcmask_pch - USE MOD_Vars_Global, only: spval - - ! ----- Variables ----- - integer :: nyearcheck - - integer :: timestrlen - character(len=24) :: timeform - - real(r8), allocatable :: tws_last (:) - real(r8), allocatable :: tws_this (:) - - real(r8), allocatable :: prcp_year (:) - real(r8), allocatable :: et_year (:) - real(r8), allocatable :: rnof_year (:) - real(r8), allocatable :: rchg_year (:) - - real(r8), allocatable :: patcharea (:) ! m^2 - - character(len=256) :: mesg_equilibrium - -#ifndef SinglePoint - type(grid_type) :: gridcheck - type(grid_concat_type) :: gcheck_concat - type(spatial_mapping_type) :: map_check - - integer :: check_data_id = 0 -#endif - - PUBLIC :: CheckEqb_init - PUBLIC :: CheckEquilibrium - PUBLIC :: CheckEqb_final - -CONTAINS - - !----------------------------------------------------------------------- - SUBROUTINE CheckEqb_init (n_spinupcycle, lc_year) - - USE MOD_Utils - USE MOD_Vars_Global, only: nl_soil - USE MOD_Forcing, only: gforc - USE MOD_LandPatch, only: numpatch, landpatch - USE MOD_Pixel, only: pixel - USE MOD_Mesh, only: mesh - USE MOD_Vars_TimeVariables, only: wdsrf, ldew, scv, wetwat, & - wliq_soisno, wice_soisno, wa - IMPLICIT NONE - - integer, intent(in) :: n_spinupcycle - integer, intent(in) :: lc_year - - ! Local Variable - integer :: ilev, ip, ie, ipxl - character(len=256) :: filename, cyear - real(r8) :: totaldtws, totalprcp, pct_dtws_prcp - - - IF (.not. DEF_CheckEquilibrium) RETURN - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - allocate (tws_last (numpatch)); tws_last (:) = spval; - allocate (tws_this (numpatch)); tws_this (:) = spval; - allocate (prcp_year (numpatch)); prcp_year(:) = spval; - allocate (et_year (numpatch)); et_year (:) = spval; - allocate (rnof_year (numpatch)); rnof_year(:) = spval; - allocate (rchg_year (numpatch)); rchg_year(:) = spval; - - ENDIF - ENDIF - - IF (n_spinupcycle >= 10000) THEN - timestrlen = 16 - timeform = "('spinup',I5.5,'-',I4.4)" - ELSEIF (n_spinupcycle >= 1000) THEN - timestrlen = 15 - timeform = "('spinup',I4.4,'-',I4.4)" - ELSEIF (n_spinupcycle >= 100) THEN - timestrlen = 14 - timeform = "('spinup',I3.3,'-',I4.4)" - ELSEIF (n_spinupcycle >= 10) THEN - timestrlen = 13 - timeform = "('spinup',I2.2,'-',I4.4)" - ELSE - timestrlen = 12 - timeform = "('spinup',I1.1,'-',I4.4)" - ENDIF - - mesg_equilibrium = '' - -#ifndef SinglePoint - ! grid -#ifdef GRIDBASED - write(cyear,'(i4.4)') lc_year - filename = trim(DEF_dir_landdata) // '/mesh/' //trim(cyear) // '/mesh.nc' - CALL gridcheck%define_from_file (filename) -#else - CALL gridcheck%define_by_copy (gforc) -#endif - ! grid info for output - CALL gcheck_concat%set (gridcheck) - ! mapping from patch to grid - CALL map_check%build_arealweighted (gridcheck, landpatch) -#endif - - IF ((p_is_compute) .and. (numpatch > 0)) THEN - tws_last = wdsrf ! 1. surface water - CALL add_spv (ldew, tws_last) ! 2. water on foliage - CALL add_spv (scv , tws_last) ! 3. snow cover water equivalent - IF (DEF_USE_VariablySaturatedFlow) THEN - CALL add_spv (wetwat, tws_last) ! 4. water in wetland - ENDIF - DO ilev = 1, nl_soil - CALL add_spv (wliq_soisno(ilev,:), tws_last) ! 5. liquid water in soil - CALL add_spv (wice_soisno(ilev,:), tws_last) ! 6. ice in soil - ENDDO - CALL add_spv (wa, tws_last) ! 7. water in aquifer - ENDIF - - IF (p_is_compute) THEN - - IF (numpatch > 0) THEN - allocate (patcharea (numpatch)) - patcharea(:) = 0. - DO ip = 1, numpatch - ie = landpatch%ielm(ip) - DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) - patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) - ENDDO - IF (landpatch%has_shared) THEN - patcharea(ip) = patcharea(ip) * landpatch%pctshared(ip) - ENDIF - ENDDO - ENDIF - - ENDIF - - nyearcheck = 0 - - END SUBROUTINE CheckEqb_init - - !----------------------------------------------------------------------- - SUBROUTINE CheckEqb_final () - - IMPLICIT NONE - - IF (.not. DEF_CheckEquilibrium) RETURN - - IF (allocated(tws_last )) deallocate(tws_last ) - IF (allocated(tws_this )) deallocate(tws_this ) - IF (allocated(prcp_year)) deallocate(prcp_year) - IF (allocated(et_year )) deallocate(et_year ) - IF (allocated(rnof_year)) deallocate(rnof_year) - IF (allocated(rchg_year)) deallocate(rchg_year) - IF (allocated(patcharea)) deallocate(patcharea) - - END SUBROUTINE CheckEqb_final - - !----------------------------------------------------------------------- - SUBROUTINE CheckEquilibrium ( & - idate, deltim, i_spinupcycle, is_spinup, dir_out, casename) - - USE MOD_Precision - USE MOD_TimeManager - USE MOD_DataType - USE MOD_LandPatch, only: numpatch - USE MOD_Vars_Global, only: nl_soil - USE MOD_Vars_1DForcing, only: forc_prc, forc_prl - USE MOD_Vars_1DFluxes, only: fevpa, rnof, rsur - USE MOD_Vars_TimeInvariants, only: patchtype, patchmask - USE MOD_Vars_TimeVariables, only: wdsrf, ldew, scv, wetwat, wliq_soisno, & - wice_soisno, wa, zwt - - IMPLICIT NONE - - integer, intent(in) :: idate(3) - real(r8), intent(in) :: deltim - integer, intent(in) :: i_spinupcycle - logical, intent(in) :: is_spinup - - character(len=*), intent(in) :: dir_out - character(len=*), intent(in) :: casename - - ! Local variables - logical :: docheck - integer :: ilev - character(len=256) :: filename, timestr - integer :: ncid, time_id, str_id, varid - real(r8) :: totaldtws, totalprcp, pct_dtws_prcp - - real(r8), allocatable :: rchg (:) - real(r8), allocatable :: dtws (:) - logical, allocatable :: filter (:) - real(r8), allocatable :: vecone (:) - type(block_data_real8_2d) :: sumarea - - - IF (.not. DEF_CheckEquilibrium) RETURN - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - CALL add_spv (forc_prc, prcp_year, deltim) - CALL add_spv (forc_prl, prcp_year, deltim) - CALL add_spv (fevpa, et_year, deltim) - CALL add_spv (rnof, rnof_year, deltim) - - allocate (rchg (numpatch)) - rchg = spval - WHERE ((forc_prc /= spval) .and. (forc_prl /= spval) .and. (fevpa /= spval) .and. (rsur /= spval)) - rchg = forc_prc + forc_prl - fevpa - rsur - END WHERE - - CALL add_spv (rchg, rchg_year, deltim) - - deallocate (rchg) - ENDIF - ENDIF - - docheck = isendofyear (idate, deltim) - - IF (docheck) THEN - - IF ((p_is_compute) .and. (numpatch > 0)) THEN - tws_this = wdsrf ! 1. surface water - CALL add_spv (ldew, tws_this) ! 2. water on foliage - CALL add_spv (scv , tws_this) ! 3. snow cover water equivalent - IF (DEF_USE_VariablySaturatedFlow) THEN - CALL add_spv (wetwat, tws_this) ! 4. water in wetland - ENDIF - DO ilev = 1, nl_soil - CALL add_spv (wliq_soisno(ilev,:), tws_this) ! 5. liquid water in soil - CALL add_spv (wice_soisno(ilev,:), tws_this) ! 6. ice in soil - ENDDO - CALL add_spv (wa, tws_this) ! 7. water in aquifer - ENDIF - - nyearcheck = nyearcheck + 1 - - IF (nyearcheck >= 1) THEN - - IF (p_is_compute) THEN - - totaldtws = 0. - totalprcp = 0. - - IF (numpatch > 0) THEN - - allocate (filter (numpatch)) - filter = patchmask - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF -#ifdef CatchLateralFlow - filter = filter .and. (patchtype <= 4) -#else - filter = filter .and. (patchtype <= 2) -#endif - - allocate (dtws (numpatch)) - WHERE (filter) - dtws = tws_this - tws_last - ELSEWHERE - dtws = spval - END WHERE - - IF (any(filter)) THEN - totaldtws = sum(dtws*patcharea, mask=filter) - totalprcp = sum(prcp_year*patcharea, mask=filter) - ENDIF - - allocate (vecone (numpatch)) - vecone(:) = 1. - - ENDIF - -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, totaldtws, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) - CALL mpi_allreduce (MPI_IN_PLACE, totalprcp, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err) - - IF (totalprcp > 0.) THEN - pct_dtws_prcp = totaldtws/totalprcp - ELSE - pct_dtws_prcp = spval - ENDIF - - IF (p_iam_compute == p_root) THEN - CALL mpi_send (pct_dtws_prcp, 1, MPI_REAL8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - ENDIF -#endif - ENDIF - - IF (p_is_root) THEN - - IF (is_spinup) THEN - write(timestr,timeform) i_spinupcycle, idate(1) - ELSE - write(timestr,'(I4.4)') idate(1) - ENDIF - -#ifdef USEMPI - CALL mpi_recv (pct_dtws_prcp, 1, MPI_REAL8, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - IF (pct_dtws_prcp /= spval) THEN - write(mesg_equilibrium,'(A,F0.2,3A)') 'Total delTWS/precipitation is ', & - pct_dtws_prcp*100., '% in ', trim(timestr), '. Check history for detail.' - ELSE - write(mesg_equilibrium,'(3A)') 'Precipitation is 0 ', trim(timestr), '.' - ENDIF - - filename = trim(dir_out) // '/' // trim(casename) //'_check_equilibrium.nc' - - IF (nyearcheck == 1) THEN - - CALL ncio_create_file (trim(filename)) - - CALL ncio_define_dimension(filename, 'iyear', 0) - CALL ncio_define_dimension(filename, 'timestr', timestrlen) - - CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) - CALL nccheck( nf90_inq_dimid(ncid, 'iyear', time_id) ) - CALL nccheck( nf90_inq_dimid(ncid, 'timestr', str_id ) ) - CALL nccheck( nf90_redef(ncid) ) - CALL nccheck( nf90_def_var(ncid, 'iyear', NF90_CHAR, (/str_id,time_id/), varid) ) - CALL nccheck( nf90_put_att(ncid, varid, 'long_name', 'iyear in all spinup cycles') ) - CALL nccheck( nf90_enddef(ncid) ) - CALL nccheck( nf90_close(ncid) ) - -#ifndef SinglePoint - CALL ncio_define_dimension(filename, 'lat' , gcheck_concat%ginfo%nlat) - CALL ncio_define_dimension(filename, 'lon' , gcheck_concat%ginfo%nlon) - - CALL ncio_write_serial (filename, 'lat', gcheck_concat%ginfo%lat_c, 'lat') - CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') - CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - - CALL ncio_write_serial (filename, 'lon', gcheck_concat%ginfo%lon_c, 'lon') - CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') - CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') -#else - CALL ncio_define_dimension(filename, 'patch', numpatch) -#endif - - ENDIF - - CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) - CALL nccheck( nf90_inq_varid(ncid, 'iyear', varid) ) - CALL nccheck( nf90_put_var(ncid, varid, timestr(1:timestrlen), & - (/1,nyearcheck/), (/timestrlen,1/)) ) - CALL nccheck( nf90_close(ncid) ) - - ENDIF - -#ifndef SinglePoint - IF (p_is_active) CALL allocate_block_data (gridcheck, sumarea) - - CALL map_check%get_sumarea (sumarea, filter) - - IF (nyearcheck == 1) THEN - CALL map_and_write_check_var ( & - vecone, filename, 'landarea', -1, sumarea, filter, & - 'area of land excluding water bodies and glaciers in grid', 'km^2', & - amount_in_grid = .true.) - ENDIF - - CALL map_and_write_check_var ( & - dtws, filename, 'tws_change', nyearcheck, sumarea, filter, & - 'Change in terrestrial water storage', 'mm') - CALL map_and_write_check_var ( & - prcp_year, filename, 'total_precipitation', nyearcheck, sumarea, filter, & - 'total precipitation in a year', 'mm') - CALL map_and_write_check_var ( & - et_year, filename, 'total_evapotranspiration', nyearcheck, sumarea, filter, & - 'total evapotranspiration in a year', 'mm') - CALL map_and_write_check_var ( & - rnof_year, filename, 'total_runoff', nyearcheck, sumarea, filter, & - 'total runoff in a year', 'mm') - CALL map_and_write_check_var ( & - rchg_year, filename, 'total_recharge', nyearcheck, sumarea, filter, & - 'total recharge to ground water in a year', 'mm') - CALL map_and_write_check_var ( & - zwt, filename, 'zwt', nyearcheck, sumarea, filter, & - 'depth to water table', 'm') -#else - CALL ncio_write_serial_time (filename, 'tws_change', & - nyearcheck, dtws, 'patch', 'iyear') - IF (nyearcheck == 1) THEN - CALL ncio_put_attr (filename, 'tws_change', 'long_name', & - 'Change in terrestrial water storage') - CALL ncio_put_attr (filename, 'tws_change', 'units', 'mm') - CALL ncio_put_attr (filename, 'tws_change', 'missing_value', spval) - ENDIF - - CALL ncio_write_serial_time (filename, 'total_precipitation', & - nyearcheck, prcp_year, 'patch', 'iyear') - IF (nyearcheck == 1) THEN - CALL ncio_put_attr (filename, 'total_precipitation', 'long_name', & - 'total precipitation in a year') - CALL ncio_put_attr (filename, 'total_precipitation', 'units', 'mm') - CALL ncio_put_attr (filename, 'total_precipitation', 'missing_value', spval) - ENDIF - - CALL ncio_write_serial_time (filename, 'total_evapotranspiration', & - nyearcheck, et_year, 'patch', 'iyear') - IF (nyearcheck == 1) THEN - CALL ncio_put_attr (filename, 'total_evapotranspiration', 'long_name', & - 'total evapotranspiration in a year') - CALL ncio_put_attr (filename, 'total_evapotranspiration', 'units', 'mm') - CALL ncio_put_attr (filename, 'total_evapotranspiration', 'missing_value', spval) - ENDIF - - CALL ncio_write_serial_time (filename, 'total_runoff', & - nyearcheck, rnof_year, 'patch', 'iyear') - IF (nyearcheck == 1) THEN - CALL ncio_put_attr (filename, 'total_runoff', 'long_name', & - 'total runoff in a year') - CALL ncio_put_attr (filename, 'total_runoff', 'units', 'mm') - CALL ncio_put_attr (filename, 'total_runoff', 'missing_value', spval) - ENDIF - - CALL ncio_write_serial_time (filename, 'total_recharge', & - nyearcheck, rchg_year, 'patch', 'iyear') - IF (nyearcheck == 1) THEN - CALL ncio_put_attr (filename, 'total_recharge', 'long_name', & - 'total recharge to ground water in a year') - CALL ncio_put_attr (filename, 'total_recharge', 'units', 'mm') - CALL ncio_put_attr (filename, 'total_recharge', 'missing_value', spval) - ENDIF - - CALL ncio_write_serial_time (filename, 'zwt', & - nyearcheck, zwt, 'patch', 'iyear') - IF (nyearcheck == 1) THEN - CALL ncio_put_attr (filename, 'zwt', 'long_name', 'depth to water table') - CALL ncio_put_attr (filename, 'zwt', 'units', 'm') - CALL ncio_put_attr (filename, 'zwt', 'missing_value', spval) - ENDIF -#endif - ENDIF - - IF ((p_is_compute) .and. (numpatch > 0)) THEN - prcp_year(:) = spval - et_year (:) = spval - rnof_year(:) = spval - rchg_year(:) = spval - tws_last = tws_this - ENDIF - - IF (allocated(dtws )) deallocate(dtws ) - IF (allocated(filter)) deallocate(filter) - IF (allocated(vecone)) deallocate(vecone) - - ENDIF - - END SUBROUTINE CheckEquilibrium - - !----------------------------------------------------------------------- -#ifndef SinglePoint - SUBROUTINE map_and_write_check_var ( & - vector, filename, varname, itime_in_file, sumarea, filter, & - longname, units, amount_in_grid) - - USE MOD_Block - IMPLICIT NONE - - real(r8), intent(in) :: vector(:) - - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - logical, intent(in), optional :: amount_in_grid - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - - ! Local variables - type(block_data_real8_2d) :: data_xy_2d - integer :: xblk, yblk, xloc, yloc, xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: rmesg(3), smesg(3), isrc - real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) - logical :: amount - - IF (p_is_active) CALL allocate_block_data (gridcheck, data_xy_2d) - CALL map_check%pset2grid (vector, data_xy_2d, spv = spval, msk = filter) - - amount = .false. - IF (present(amount_in_grid)) amount = amount_in_grid - - IF (.not. amount) THEN - IF (p_is_active) THEN - DO iblkme = 1, gblock%nblkme - xblk = gblock%xblkme(iblkme) - yblk = gblock%yblkme(iblkme) - - DO yloc = 1, gridcheck%ycnt(yblk) - DO xloc = 1, gridcheck%xcnt(xblk) - - IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN - IF (data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN - data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & - = data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & - / sumarea%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - ELSE - data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval - ENDIF - - ENDDO - ENDDO - - ENDDO - ENDIF - ENDIF - - check_data_id = mod(check_data_id,100) + 1 -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_root) THEN - - allocate (vdata (gcheck_concat%ginfo%nlon, gcheck_concat%ginfo%nlat)) - vdata(:,:) = spval - -#ifdef USEMPI - DO idata = 1, gcheck_concat%ndatablk - CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & - check_data_id, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - - xgdsp = gcheck_concat%xsegs(ixseg)%gdsp - ygdsp = gcheck_concat%ysegs(iyseg)%gdsp - xcnt = gcheck_concat%xsegs(ixseg)%cnt - ycnt = gcheck_concat%ysegs(iyseg)%cnt - - allocate (rbuf(xcnt,ycnt)) - - CALL mpi_recv (rbuf, xcnt*ycnt, MPI_REAL8, & - isrc, check_data_id, p_comm_glb, p_stat, p_err) - - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf - deallocate (rbuf) - - ENDDO -#else - DO iyseg = 1, gcheck_concat%nyseg - DO ixseg = 1, gcheck_concat%nxseg - iblk = gcheck_concat%xsegs(ixseg)%blk - jblk = gcheck_concat%ysegs(iyseg)%blk - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - xbdsp = gcheck_concat%xsegs(ixseg)%bdsp - ybdsp = gcheck_concat%ysegs(iyseg)%bdsp - xgdsp = gcheck_concat%xsegs(ixseg)%gdsp - ygdsp = gcheck_concat%ysegs(iyseg)%gdsp - xcnt = gcheck_concat%xsegs(ixseg)%cnt - ycnt = gcheck_concat%ysegs(iyseg)%cnt - - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & - data_xy_2d%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - ENDIF - ENDDO - ENDDO -#endif - - IF (itime_in_file >= 1) THEN - CALL ncio_write_serial_time (filename, varname, itime_in_file, vdata, & - 'lon', 'lat', 'iyear', compress = 1) - ELSE - CALL ncio_write_serial (filename, varname, vdata, 'lon', 'lat', compress = 1) - ENDIF - - IF (itime_in_file <= 1) THEN - CALL ncio_put_attr (filename, varname, 'long_name', longname) - CALL ncio_put_attr (filename, varname, 'units', units) - CALL ncio_put_attr (filename, varname, 'missing_value', spval) - ENDIF - - deallocate (vdata) - - ENDIF - -#ifdef USEMPI - IF (p_is_active) THEN - DO iyseg = 1, gcheck_concat%nyseg - DO ixseg = 1, gcheck_concat%nxseg - - iblk = gcheck_concat%xsegs(ixseg)%blk - jblk = gcheck_concat%ysegs(iyseg)%blk - - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - xbdsp = gcheck_concat%xsegs(ixseg)%bdsp - ybdsp = gcheck_concat%ysegs(iyseg)%bdsp - xcnt = gcheck_concat%xsegs(ixseg)%cnt - ycnt = gcheck_concat%ysegs(iyseg)%cnt - - allocate (sbuf (xcnt,ycnt)) - sbuf = data_xy_2d%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - - smesg = (/p_iam_glb, ixseg, iyseg/) - CALL mpi_send (smesg, 3, MPI_INTEGER, & - p_address_root, check_data_id, p_comm_glb, p_err) - CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, & - p_address_root, check_data_id, p_comm_glb, p_err) - - deallocate (sbuf) - - ENDIF - ENDDO - ENDDO - ENDIF -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE map_and_write_check_var -#endif - - !----------------------------------------------------------------------- - SUBROUTINE add_spv (var, s, dt) - - USE MOD_Precision - - IMPLICIT NONE - - real(r8), intent(in) :: var(:) - real(r8), intent(inout) :: s (:) - real(r8), intent(in), optional :: dt - ! Local variables - integer :: i - - IF (present(dt)) THEN - DO i = lbound(var,1), ubound(var,1) - IF (var(i) /= spval) THEN - IF (s(i) /= spval) THEN - s(i) = s(i) + var(i)*dt - ELSE - s(i) = var(i)*dt - ENDIF - ENDIF - ENDDO - ELSE - DO i = lbound(var,1), ubound(var,1) - IF (var(i) /= spval) THEN - IF (s(i) /= spval) THEN - s(i) = s(i) + var(i) - ELSE - s(i) = var(i) - ENDIF - ENDIF - ENDDO - ENDIF - - END SUBROUTINE add_spv - -END MODULE MOD_CheckEquilibrium diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 deleted file mode 100644 index cafdfd6086..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90 +++ /dev/null @@ -1,377 +0,0 @@ -#include - -#ifdef CROP -MODULE MOD_CropReadin - -!----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: CROP_readin - -CONTAINS - - SUBROUTINE CROP_readin () -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Read in crop planting date from data, and fertilization from data. -! Save these data in patch vector. -! -! Original: Shupeng Zhang, Zhongwang Wei, and Xingjie Lu, 2022 -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_LandPatch - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_SpatialMapping - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - - USE MOD_Vars_Global - USE MOD_LandPFT - USE MOD_Vars_PFTimeVariables - USE MOD_RangeCheck - USE MOD_Block - - IMPLICIT NONE - - character(len=256) :: file_crop - type(grid_type) :: grid_crop - type(block_data_real8_2d) :: f_xy_crop - type(spatial_mapping_type) :: mg2patch_crop - type(spatial_mapping_type) :: mg2pft_crop - character(len=256) :: file_irrig - type(grid_type) :: grid_irrig - type(block_data_int32_2d) :: f_xy_irrig - type(spatial_mapping_type) :: mg2pft_irrig - - character(len=256) :: file_irrigalloc - type(grid_type) :: grid_irrigalloc - type(block_data_real8_2d) :: f_xy_irrigalloc - type(spatial_mapping_type) :: mg2p_irrigalloc - - character(len=256) :: file_fert - type(grid_type) :: grid_fert - type(block_data_real8_2d) :: f_xy_fert - type(spatial_mapping_type) :: mg2pft_fert - - real(r8),allocatable :: pdrice2_tmp (:) - real(r8),allocatable :: plantdate_tmp (:) - real(r8),allocatable :: fertnitro_tmp (:) - integer ,allocatable :: irrig_method_tmp (:) - - real(r8),allocatable :: fertilizer_tmp (:) - real(r8),allocatable :: manure_tmp (:) - - ! Local variables - real(r8), allocatable :: lat(:), lon(:) - real(r8) :: missing_value - integer :: cft, npatch, ipft - character(len=2) :: cx - integer :: iblkme, iblk, jblk - integer :: maxvalue, minvalue - - ! READ in crops - - file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' - - CALL ncio_read_bcast_serial (file_crop, 'lat', lat) - CALL ncio_read_bcast_serial (file_crop, 'lon', lon) - - CALL grid_crop%define_by_center (lat, lon) - - IF (p_is_active) THEN - CALL allocate_block_data (grid_crop, f_xy_crop) - ENDIF - - ! missing value - IF (p_is_root) THEN - CALL ncio_get_attr (file_crop, 'pdrice2', 'missing_value', missing_value) - ENDIF -#ifdef USEMPI - CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err) -#endif - IF (p_is_active) THEN - CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) - ENDIF - - CALL mg2patch_crop%build_arealweighted (grid_crop, landpatch) - CALL mg2patch_crop%set_missing_value (f_xy_crop, missing_value) - - CALL mg2pft_crop%build_arealweighted (grid_crop, landpft) - CALL mg2pft_crop%set_missing_value (f_xy_crop, missing_value) - - IF (allocated(lon)) deallocate(lon) - IF (allocated(lat)) deallocate(lat) - - IF (p_is_compute) THEN - IF (numpatch > 0) allocate(pdrice2_tmp (numpatch)) - IF (numpft > 0) allocate(plantdate_tmp (numpft)) - IF (numpft > 0) allocate(fertnitro_tmp (numpft)) - IF (numpft > 0) allocate(irrig_method_tmp (numpft)) - ENDIF - - ! (1) Read in plant date for rice2. - file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' - IF (p_is_active) THEN - CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) - ENDIF - - CALL mg2patch_crop%grid2pset (f_xy_crop, pdrice2_tmp) - - IF (p_is_compute) THEN - DO npatch = 1, numpatch - IF (pdrice2_tmp(npatch) /= spval) THEN - pdrice2 (npatch) = int(pdrice2_tmp (npatch)) - ELSE - pdrice2 (npatch) = 0 - ENDIF - ENDDO - ENDIF - -#ifdef RangeCheck - CALL check_vector_data ('plant date value for rice2 ', pdrice2) -#endif - - ! (2) Read in plant date. - IF (p_is_compute) THEN - IF (numpft > 0) plantdate_p(:) = -99999999._r8 - ENDIF - - file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' - DO cft = 15, 78 - write(cx, '(i2.2)') cft - IF (p_is_active) THEN - CALL ncio_read_block_time (file_crop, & - 'PLANTDATE_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) - ENDIF - - CALL mg2pft_crop%grid2pset (f_xy_crop, plantdate_tmp) - - IF (p_is_compute) THEN - DO ipft = 1, numpft - IF(landpft%settyp(ipft) .eq. cft)THEN - plantdate_p(ipft) = plantdate_tmp(ipft) - IF(plantdate_p(ipft) <= 0._r8) THEN - plantdate_p(ipft) = -99999999._r8 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - -#ifdef RangeCheck - CALL check_vector_data ('plantdate_pfts value ', plantdate_p) -#endif - - ! (3) Read in fertlization - IF (DEF_FERT_SOURCE == 1) THEN - IF (p_is_compute) THEN - IF (numpft > 0) fertnitro_p(:) = -99999999._r8 - ENDIF - - file_fert = trim(DEF_dir_runtime) // '/crop/fertnitro_fillcoast.nc' - DO cft = 15, 78 - write(cx, '(i2.2)') cft - IF (p_is_active) THEN - CALL ncio_read_block_time (file_fert, & - 'CONST_FERTNITRO_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) - ENDIF - - CALL mg2pft_crop%grid2pset (f_xy_crop, fertnitro_tmp) - - IF (p_is_compute) THEN - DO ipft = 1, numpft - IF(landpft%settyp(ipft) .eq. cft)THEN - fertnitro_p(ipft) = fertnitro_tmp(ipft) - IF(fertnitro_p(ipft) <= 0._r8) THEN - fertnitro_p(ipft) = 0._r8 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - - ELSEIF (DEF_FERT_SOURCE == 2)THEN - IF (p_is_compute) THEN - IF (numpft > 0) THEN - allocate(fertilizer_tmp(numpft)) - allocate(manure_tmp(numpft)) - ENDIF - ENDIF - - file_fert = trim(DEF_dir_runtime) // '/crop/fertilizer_2015soc.nc' - - CALL ncio_read_bcast_serial (file_fert, 'lat', lat) - CALL ncio_read_bcast_serial (file_fert, 'lon', lon) - CALL grid_fert%define_by_center (lat, lon) - - IF (p_is_active) THEN - CALL allocate_block_data (grid_fert, f_xy_fert) - ENDIF - - CALL mg2pft_fert%build_arealweighted (grid_fert, landpft) - - IF (allocated(lon)) deallocate(lon) - IF (allocated(lat)) deallocate(lat) - - IF (p_is_compute) THEN - fertnitro_p(:) = -99999999._r8 - manunitro_p(:) = -99999999._r8 - ENDIF - - ! read manure - IF (p_is_active) THEN - CALL ncio_read_block (file_fert, 'manure', grid_fert, f_xy_fert) - ENDIF - - CALL mg2pft_fert%grid2pset (f_xy_fert, manure_tmp) - - IF (p_is_compute) THEN - DO ipft = 1, numpft - IF (landpft%settyp(ipft) .ge. 15) THEN - manunitro_p(ipft) = manure_tmp(ipft) - IF (manunitro_p(ipft) < 0._r8) THEN - manunitro_p(ipft) = 0._r8 - ENDIF - ENDIF - ENDDO - ENDIF - - ! read fertilizer - DO cft = 1, 64 - IF (p_is_active) THEN - CALL ncio_read_block_time (file_fert, 'fertilizer', grid_fert, cft, f_xy_fert) - ENDIF - - CALL mg2pft_fert%grid2pset (f_xy_fert, fertilizer_tmp) - - IF (p_is_compute) THEN - DO ipft = 1, numpft - IF (landpft%settyp(ipft) .eq. cft+14) THEN - fertnitro_p(ipft) = fertilizer_tmp(ipft) - IF (fertnitro_p(ipft) < 0._r8) THEN - fertnitro_p(ipft) = 0._r8 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - - IF (allocated (fertilizer_tmp)) deallocate(fertilizer_tmp) - IF (allocated (manure_tmp)) deallocate(manure_tmp) - ENDIF - -#ifdef RangeCheck - CALL check_vector_data ('fert nitro value ', fertnitro_p) -#endif - - ! (4) Read in irrigation method - !file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method.nc' - file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method_96x144.nc' - - CALL ncio_read_bcast_serial (file_irrig, 'lat', lat) - CALL ncio_read_bcast_serial (file_irrig, 'lon', lon) - - CALL grid_irrig%define_by_center (lat, lon) - - IF (p_is_active) THEN - CALL allocate_block_data (grid_irrig, f_xy_irrig) - ENDIF - - CALL mg2pft_irrig%build_arealweighted (grid_irrig, landpft) - - IF (allocated(lon)) deallocate(lon) - IF (allocated(lat)) deallocate(lat) - - IF (p_is_compute) THEN - IF (numpft > 0) irrig_method_p(:) = -99999999 - ENDIF - - DO cft = 1, N_CFT - IF (p_is_active) THEN - CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig) - ENDIF - - CALL mg2pft_irrig%grid2pset_dominant (f_xy_irrig, irrig_method_tmp) - - IF (p_is_compute) THEN - DO ipft = 1, numpft - - IF(landpft%settyp(ipft) .eq. cft + 14)THEN - irrig_method_p(ipft) = irrig_method_tmp(ipft) - IF(irrig_method_p(ipft) < 0) THEN - irrig_method_p(ipft) = -99999999 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - -#ifdef RangeCheck - CALL check_vector_data ('irrigation method ', irrig_method_p) -#endif - - IF (allocated (pdrice2_tmp )) deallocate(pdrice2_tmp ) - IF (allocated (plantdate_tmp)) deallocate(plantdate_tmp) - IF (allocated (fertnitro_tmp)) deallocate(fertnitro_tmp) - IF (allocated (irrig_method_tmp)) deallocate(irrig_method_tmp) - - IF (DEF_IRRIGATION_ALLOCATION == 3) THEN - ! (5) Read in irrigation allocated to groundwater - file_irrigalloc = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_allocation.nc' - - CALL ncio_read_bcast_serial (file_irrigalloc, 'lat', lat) - CALL ncio_read_bcast_serial (file_irrigalloc, 'lon', lon) - - CALL grid_irrigalloc%define_by_center (lat, lon) - - IF (p_is_active) THEN - CALL allocate_block_data (grid_irrigalloc, f_xy_irrigalloc) - ENDIF - - call mg2p_irrigalloc%build_arealweighted (grid_irrigalloc, landpatch) - - IF (allocated(lon)) deallocate(lon) - IF (allocated(lat)) deallocate(lat) - - IF (p_is_compute) THEN - irrig_gw_alloc(:) = 0._r8 - ENDIF - - IF (p_is_active) THEN - CALL ncio_read_block (file_irrigalloc, 'irrig_gw_alloc', grid_irrigalloc, f_xy_irrigalloc) - ENDIF - - call mg2p_irrigalloc%grid2pset (f_xy_irrigalloc, irrig_gw_alloc) - -#ifdef RangeCheck - CALL check_vector_data ('irrigation goundwater allocation ', irrig_gw_alloc) -#endif - - ! (6) Read in irrigation allocated to surfacewater - IF (p_is_compute) THEN - irrig_sw_alloc(:) = 0._r8 - ENDIF - - IF (p_is_active) THEN - CALL ncio_read_block (file_irrigalloc, 'irrig_sw_alloc', grid_irrigalloc, f_xy_irrigalloc) - ENDIF - - call mg2p_irrigalloc%grid2pset (f_xy_irrigalloc, irrig_sw_alloc) - -#ifdef RangeCheck - CALL check_vector_data ('irrigation surfacewater allocation ', irrig_sw_alloc) -#endif - ENDIF - - END SUBROUTINE CROP_readin - -END MODULE MOD_CropReadin -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 index 153f26922b..92f68e3262 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 @@ -32,7 +32,7 @@ SUBROUTINE init_fire_data (YY) ! longitude info. Initialize fire data read in. !----------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_Grid USE MOD_NetCDFSerial @@ -59,12 +59,12 @@ SUBROUTINE init_fire_data (YY) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_active) THEN + IF (.true.) THEN CALL allocate_block_data (grid_fire, f_xy_fire) ENDIF file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' - IF (p_is_active) THEN + IF (.true.) THEN CALL ncio_read_block (file_fire, 'abm', grid_fire, f_xy_fire) ENDIF CALL mg2p_fire%grid2pset (f_xy_fire, abm_lf) @@ -73,7 +73,7 @@ SUBROUTINE init_fire_data (YY) #endif file_fire = trim(DEF_dir_runtime) // '/fire/peatf_colm_360x720_c100428.nc' - IF (p_is_active) THEN + IF (.true.) THEN CALL ncio_read_block (file_fire, 'peatf', grid_fire, f_xy_fire) ENDIF CALL mg2p_fire%grid2pset (f_xy_fire, peatf_lf) @@ -82,7 +82,7 @@ SUBROUTINE init_fire_data (YY) #endif file_fire = trim(DEF_dir_runtime) // '/fire/gdp_colm_360x720_c100428.nc' - IF (p_is_active) THEN + IF (.true.) THEN CALL ncio_read_block (file_fire, 'gdp', grid_fire, f_xy_fire) ENDIF CALL mg2p_fire%grid2pset (f_xy_fire, gdp_lf) @@ -104,7 +104,7 @@ SUBROUTINE update_hdm_data (YY) ! Original: Xingjie Lu and Shupeng Zhang, 2022 !----------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_DataType USE MOD_Namelist USE MOD_NetCDFBlock @@ -122,7 +122,7 @@ SUBROUTINE update_hdm_data (YY) file_fire = trim(DEF_dir_runtime) & // '/fire/colmforc.Li_2017_HYDEv3.2_CMIP6_hdm_0.5x0.5_AVHRR_simyr1850-2016_c180202.nc' - IF (p_is_active) THEN + IF (.true.) THEN CALL allocate_block_data (grid_fire, f_xy_fire) CALL ncio_read_block_time (file_fire, 'hdm', grid_fire, itime, f_xy_fire) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 deleted file mode 100644 index feff68e280..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90 +++ /dev/null @@ -1,1810 +0,0 @@ -#include - -MODULE MOD_Forcing - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! read in the atmospheric forcing using user defined interpolation method or -! downscaling forcing -! -! !REVISIONS: -! Yongjiu Dai and Hua Yuan, 04/2014: initial code from CoLM2014 (metdata.F90, -! GETMET.F90 and rd_forcing.F90 -! -! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version -! 2) codes for dealing with missing forcing value -! 3) interface for downscaling -! -! !TODO...(need complement) -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Namelist - USE MOD_Grid - USE MOD_SpatialMapping - USE MOD_UserSpecifiedForcing - USE MOD_TimeManager - USE MOD_SPMD_Task - USE MOD_MonthlyinSituCO2MaunaLoa - USE MOD_Vars_Global, only: pi - USE MOD_OrbCoszen - USE MOD_UserDefFun - - IMPLICIT NONE - - type (grid_type), PUBLIC :: gforc - - type (spatial_mapping_type) :: mg2p_forc ! area weighted mapping from forcing to model unit - - real(r8) :: forc_missing_value - logical, allocatable :: forcmask_pch (:) - - ! for Forcing_Downscaling - type(block_data_real8_2d) :: topo_grid, maxelv_grid - - type(pointer_real8_1d), allocatable :: forc_topo_grid (:) - type(pointer_real8_1d), allocatable :: forc_maxelv_grid (:) - - type(pointer_real8_1d), allocatable :: forc_t_grid (:) - type(pointer_real8_1d), allocatable :: forc_th_grid (:) - type(pointer_real8_1d), allocatable :: forc_q_grid (:) - type(pointer_real8_1d), allocatable :: forc_pbot_grid (:) - type(pointer_real8_1d), allocatable :: forc_rho_grid (:) - type(pointer_real8_1d), allocatable :: forc_prc_grid (:) - type(pointer_real8_1d), allocatable :: forc_prl_grid (:) - type(pointer_real8_1d), allocatable :: forc_lwrad_grid (:) - type(pointer_real8_1d), allocatable :: forc_swrad_grid (:) - type(pointer_real8_1d), allocatable :: forc_hgt_grid (:) - type(pointer_real8_1d), allocatable :: forc_us_grid (:) - type(pointer_real8_1d), allocatable :: forc_vs_grid (:) - - type(pointer_real8_1d), allocatable :: forc_t_part (:) - type(pointer_real8_1d), allocatable :: forc_th_part (:) - type(pointer_real8_1d), allocatable :: forc_q_part (:) - type(pointer_real8_1d), allocatable :: forc_pbot_part (:) - type(pointer_real8_1d), allocatable :: forc_rhoair_part (:) - type(pointer_real8_1d), allocatable :: forc_prc_part (:) - type(pointer_real8_1d), allocatable :: forc_prl_part (:) - type(pointer_real8_1d), allocatable :: forc_frl_part (:) - type(pointer_real8_1d), allocatable :: forc_swrad_part (:) - type(pointer_real8_1d), allocatable :: forc_us_part (:) - type(pointer_real8_1d), allocatable :: forc_vs_part (:) - - logical, allocatable :: glacierss (:) - - ! local variables - integer :: deltim_int ! model time step length - ! real(r8) :: deltim_real ! model time step length - - ! for SinglePoint - type(timestamp), allocatable :: forctime (:) - integer, allocatable :: iforctime(:) - - logical :: forcing_read_ahead - real(r8), allocatable :: forc_disk(:,:) - - type(timestamp), allocatable :: tstamp_LB(:) ! time stamp of low boundary data - type(timestamp), allocatable :: tstamp_UB(:) ! time stamp of up boundary data - - type(block_data_real8_2d) :: avgcos ! time-average of cos(zenith) - type(block_data_real8_2d) :: metdata ! forcing data -#ifdef URBAN_MODEL - type(block_data_real8_2d) :: rainf - type(block_data_real8_2d) :: snowf -#endif - - type(block_data_real8_2d), allocatable :: forcn (:) ! forcing data - type(block_data_real8_2d), allocatable :: forcn_LB (:) ! forcing data at lower boundary - type(block_data_real8_2d), allocatable :: forcn_UB (:) ! forcing data at upper boundary - - PUBLIC :: forcing_init - PUBLIC :: read_forcing - -CONTAINS - -!----------------------------------------------------------------------- - SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulcc_call) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Block - USE MOD_DataType - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch -#ifdef CROP - USE MOD_LandCrop -#endif - USE MOD_UserSpecifiedForcing - USE MOD_NetCDFSerial - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_Vars_TimeInvariants - USE MOD_Vars_1DForcing - IMPLICIT NONE - - character(len=*), intent(in) :: dir_forcing - real(r8), intent(in) :: deltatime ! model time step - type(timestamp), intent(in) :: ststamp - integer, intent(in) :: lc_year ! which year of land cover data used - type(timestamp), intent(in), optional :: etstamp - logical, intent(in), optional :: lulcc_call ! whether it is a lulcc CALL - - ! Local variables - integer :: idate(3) - type(timestamp) :: tstamp - character(len=256) :: filename, lndname, cyear - integer :: ivar, year, month, day, time_i - integer :: ielm, istt, iend - type(block_data_real8_2d) :: areagrid - - integer :: iblkme, xblk, yblk, xloc, yloc - - CALL init_user_specified_forcing - - ! CO2 data initialization - CALL init_monthly_co2_mlo - - ! get value of fmetdat and deltim - deltim_int = int(deltatime) - ! deltim_real = deltatime - - ! set initial values - IF (allocated(tstamp_LB)) deallocate(tstamp_LB) - IF (allocated(tstamp_UB)) deallocate(tstamp_UB) - allocate (tstamp_LB(NVAR)) - allocate (tstamp_UB(NVAR)) - tstamp_LB(:) = timestamp(-1, -1, -1) - tstamp_UB(:) = timestamp(-1, -1, -1) - - idate = (/ststamp%year, ststamp%day, ststamp%sec/) - CALL adj2begin (idate) - - CALL metread_latlon (dir_forcing, idate) - - IF (p_is_active) THEN - - IF (allocated(forcn )) deallocate(forcn ) - IF (allocated(forcn_LB)) deallocate(forcn_LB) - IF (allocated(forcn_UB)) deallocate(forcn_UB) - allocate (forcn (NVAR)) - allocate (forcn_LB (NVAR)) - allocate (forcn_UB (NVAR)) - - DO ivar = 1, NVAR - CALL allocate_block_data (gforc, forcn (ivar)) - CALL allocate_block_data (gforc, forcn_LB(ivar)) - CALL allocate_block_data (gforc, forcn_UB(ivar)) - ENDDO - - ! allocate memory for forcing data - CALL allocate_block_data (gforc, metdata) ! forcing data - CALL allocate_block_data (gforc, avgcos ) ! time-average of cos(zenith) -#if (defined URBAN_MODEL && defined SinglePoint) - CALL allocate_block_data (gforc, rainf) - CALL allocate_block_data (gforc, snowf) -#endif - - ENDIF - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - allocate (forcmask_pch(numpatch)); forcmask_pch(:) = .true. - ENDIF - ENDIF - - IF (DEF_forcing%has_missing_value) THEN - - tstamp = idate - CALL setstampLB(tstamp, 1, year, month, day, time_i) - filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) - tstamp_LB(1) = timestamp(-1, -1, -1) - - IF (p_is_root) THEN - CALL ncio_get_attr (filename, vname(1), trim(DEF_forcing%missing_value_name), & - forc_missing_value) - ENDIF -#ifdef USEMPI - CALL mpi_bcast (forc_missing_value, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err) -#endif - - CALL ncio_read_block_time (filename, vname(1), gforc, time_i, metdata) - - ENDIF - - IF (trim(DEF_Forcing_Interp_Method) == 'arealweight') THEN - IF (present(lulcc_call)) CALL mg2p_forc%forc_free_mem - CALL mg2p_forc%build_arealweighted (gforc, landpatch) - ELSEIF (trim(DEF_Forcing_Interp_Method) == 'bilinear') THEN - IF (present(lulcc_call)) CALL mg2p_forc%forc_free_mem - CALL mg2p_forc%build_bilinear (gforc, landpatch) - ENDIF - - IF (DEF_forcing%has_missing_value) THEN - CALL mg2p_forc%set_missing_value (metdata, forc_missing_value, forcmask_pch) - ENDIF - - IF (p_is_compute .and. (numpatch > 0)) THEN - forc_topo = elvmean - WHERE(forc_topo == spval) forc_topo = 0. - ENDIF - - IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN - - IF (p_is_active) CALL allocate_block_data (gforc, topo_grid) - CALL mg2p_forc%pset2grid (forc_topo, topo_grid, msk = patchmask) - - IF (p_is_active) CALL allocate_block_data (gforc, areagrid) - CALL mg2p_forc%get_sumarea(areagrid, patchmask) - CALL block_data_division (topo_grid, areagrid) - - IF (p_is_active) CALL allocate_block_data (gforc, maxelv_grid) - CALL mg2p_forc%pset2grid_max (forc_topo, maxelv_grid, msk = patchmask) - - - CALL mg2p_forc%allocate_part (forc_topo_grid ) - CALL mg2p_forc%allocate_part (forc_maxelv_grid) - - CALL mg2p_forc%allocate_part (forc_t_grid ) - CALL mg2p_forc%allocate_part (forc_th_grid ) - CALL mg2p_forc%allocate_part (forc_q_grid ) - CALL mg2p_forc%allocate_part (forc_pbot_grid ) - CALL mg2p_forc%allocate_part (forc_rho_grid ) - CALL mg2p_forc%allocate_part (forc_prc_grid ) - CALL mg2p_forc%allocate_part (forc_prl_grid ) - CALL mg2p_forc%allocate_part (forc_lwrad_grid ) - CALL mg2p_forc%allocate_part (forc_swrad_grid ) - CALL mg2p_forc%allocate_part (forc_hgt_grid ) - CALL mg2p_forc%allocate_part (forc_us_grid ) - CALL mg2p_forc%allocate_part (forc_vs_grid ) - - CALL mg2p_forc%allocate_part (forc_t_part ) - CALL mg2p_forc%allocate_part (forc_th_part ) - CALL mg2p_forc%allocate_part (forc_q_part ) - CALL mg2p_forc%allocate_part (forc_pbot_part ) - CALL mg2p_forc%allocate_part (forc_rhoair_part) - CALL mg2p_forc%allocate_part (forc_prc_part ) - CALL mg2p_forc%allocate_part (forc_prl_part ) - CALL mg2p_forc%allocate_part (forc_frl_part ) - CALL mg2p_forc%allocate_part (forc_swrad_part ) - CALL mg2p_forc%allocate_part (forc_us_part ) - CALL mg2p_forc%allocate_part (forc_vs_part ) - - CALL mg2p_forc%grid2part (topo_grid, forc_topo_grid ) - CALL mg2p_forc%grid2part (maxelv_grid, forc_maxelv_grid) - - IF (p_is_compute .and. (numpatch > 0)) THEN - allocate (glacierss(numpatch)) - glacierss(:) = patchtype(:) == 3 - ENDIF - - ENDIF - - forcing_read_ahead = .false. - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - IF (USE_SITE_ForcingReadAhead .and. present(etstamp)) THEN - forcing_read_ahead = .true. - CALL metread_time (dir_forcing, ststamp, etstamp, deltatime) - ELSE - CALL metread_time (dir_forcing) - ENDIF - allocate (iforctime(NVAR)) - ENDIF - - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - - filename = trim(dir_forcing)//trim(fprefix(1)) - -#ifndef URBAN_MODEL - IF (ncio_var_exist(filename,'reference_height_v')) THEN - CALL ncio_read_serial (filename, 'reference_height_v', Height_V) - ENDIF - - IF (ncio_var_exist(filename,'reference_height_t')) THEN - CALL ncio_read_serial (filename, 'reference_height_t', Height_T) - ENDIF - - IF (ncio_var_exist(filename,'reference_height_q')) THEN - CALL ncio_read_serial (filename, 'reference_height_q', Height_Q) - ENDIF -#else - IF (ncio_var_exist(filename,'measurement_height_above_ground')) THEN - CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_V) - CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_T) - CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_Q) - ENDIF -#endif - - ENDIF - - END SUBROUTINE forcing_init - - ! ---- forcing finalize ---- - SUBROUTINE forcing_final () - - USE MOD_LandPatch, only: numpatch - IMPLICIT NONE - - IF (allocated(forcmask_pch)) deallocate(forcmask_pch) - IF (allocated(glacierss )) deallocate(glacierss ) - IF (allocated(forctime )) deallocate(forctime ) - IF (allocated(iforctime )) deallocate(iforctime ) - IF (allocated(forc_disk )) deallocate(forc_disk ) - IF (allocated(tstamp_LB )) deallocate(tstamp_LB ) - IF (allocated(tstamp_UB )) deallocate(tstamp_UB ) - - IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - CALL mg2p_forc%deallocate_part (forc_topo_grid ) - CALL mg2p_forc%deallocate_part (forc_maxelv_grid) - - CALL mg2p_forc%deallocate_part (forc_t_grid ) - CALL mg2p_forc%deallocate_part (forc_th_grid ) - CALL mg2p_forc%deallocate_part (forc_q_grid ) - CALL mg2p_forc%deallocate_part (forc_pbot_grid ) - CALL mg2p_forc%deallocate_part (forc_rho_grid ) - CALL mg2p_forc%deallocate_part (forc_prc_grid ) - CALL mg2p_forc%deallocate_part (forc_prl_grid ) - CALL mg2p_forc%deallocate_part (forc_lwrad_grid ) - CALL mg2p_forc%deallocate_part (forc_swrad_grid ) - CALL mg2p_forc%deallocate_part (forc_hgt_grid ) - CALL mg2p_forc%deallocate_part (forc_us_grid ) - CALL mg2p_forc%deallocate_part (forc_vs_grid ) - - CALL mg2p_forc%deallocate_part (forc_t_part ) - CALL mg2p_forc%deallocate_part (forc_th_part ) - CALL mg2p_forc%deallocate_part (forc_q_part ) - CALL mg2p_forc%deallocate_part (forc_pbot_part ) - CALL mg2p_forc%deallocate_part (forc_rhoair_part) - CALL mg2p_forc%deallocate_part (forc_prc_part ) - CALL mg2p_forc%deallocate_part (forc_prl_part ) - CALL mg2p_forc%deallocate_part (forc_frl_part ) - CALL mg2p_forc%deallocate_part (forc_swrad_part ) - CALL mg2p_forc%deallocate_part (forc_us_part ) - CALL mg2p_forc%deallocate_part (forc_vs_part ) - - ENDIF - ENDIF - ENDIF - - END SUBROUTINE forcing_final - - ! ------------ - SUBROUTINE forcing_reset () - - IMPLICIT NONE - - tstamp_LB(:) = timestamp(-1, -1, -1) - tstamp_UB(:) = timestamp(-1, -1, -1) - - END SUBROUTINE forcing_reset - - -!----------------------------------------------------------------------- - SUBROUTINE read_forcing (idate, dir_forcing, is_spinup) - USE MOD_OrbCosazi - USE MOD_Precision - USE MOD_Namelist - USE MOD_Const_Physical, only: rgas, grav - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables, only: alb - USE MOD_Vars_1DForcing - USE MOD_Vars_2DForcing - USE MOD_Block - USE MOD_SPMD_Task - USE MOD_DataType - USE MOD_Mesh - USE MOD_LandPatch - USE MOD_RangeCheck - USE MOD_UserSpecifiedForcing - USE MOD_ForcingDownscaling, only: rair, cpair, downscale_forcings, downscale_wind, downscale_wind_simple - USE MOD_NetCDFVector - - IMPLICIT NONE - - integer, intent(in) :: idate(3) - character(len=*), intent(in) :: dir_forcing - logical, intent(in) :: is_spinup - - ! local variables: - integer :: ivar, istt, iend, id(3) - integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ipart, ne - real(r8) :: calday ! Julian cal day (1.xx to 365.xx) - real(r8) :: sunang, cloud, difrat, vnrat - real(r8) :: a, hsolar, ratio_rvrf - type(block_data_real8_2d) :: forc_xy_solarin - integer :: ii - character(10) :: cyear = "2005" - character(256):: lndname - - type(timestamp) :: mtstamp - integer :: dtLB, dtUB - real(r8) :: cosz, coszen(numpatch), cosa, cosazi(numpatch), balb - integer :: year, month, mday - logical :: has_u,has_v - real solar, frl, prcp, tm, us, vs, pres, qm - real(r8) :: pco2m - real(r8), dimension(12, numpatch) :: spaceship !NOTE: 12 is the dimension size of spaceship - integer target_server, ierr - - IF (p_is_active) THEN - !------------------------------------------------------------ - ! READ in THE ATMOSPHERIC FORCING - ! read lower and upper boundary forcing data - CALL metreadLBUB(idate, dir_forcing, is_spinup) - ! set model time stamp - id(:) = idate(:) - !CALL adj2end(id) - mtstamp = id - has_u = .true. - has_v = .true. - ! loop for variables - DO ivar = 1, NVAR - IF (ivar == 5 .and. trim(vname(ivar)) == 'NULL') has_u = .false. - IF (ivar == 6 .and. trim(vname(ivar)) == 'NULL') has_v = .false. - IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE - IF (trim(tintalgo(ivar)) == 'NULL') CYCLE - - ! to make sure the forcing data calculated is in the range of time - ! interval [LB, UB] - IF ( (mtstamp < tstamp_LB(ivar)) .or. (tstamp_UB(ivar) < mtstamp) ) THEN - write(6, *) "the data required is out of range! STOP!"; CALL CoLM_stop() - ENDIF - - ! calculate distance to lower/upper boundary - dtLB = mtstamp - tstamp_LB(ivar) - dtUB = tstamp_UB(ivar) - mtstamp - - ! linear method, for T, Pres, Q, W, LW - IF (tintalgo(ivar) == 'linear') THEN - IF ( (dtLB+dtUB) > 0 ) THEN - CALL block_data_linear_interp ( & - forcn_LB(ivar), real(dtUB,r8)/real(dtLB+dtUB,r8), & - forcn_UB(ivar), real(dtLB,r8)/real(dtLB+dtUB,r8), & - forcn(ivar)) - ELSE - CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) - ENDIF - ENDIF - - ! for precipitation, two algorithms available - ! nearest method, for precipitation - IF (tintalgo(ivar) == 'nearest') THEN - IF (dtLB <= dtUB) THEN - CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) - ELSE - CALL block_data_copy (forcn_UB(ivar), forcn(ivar)) - ENDIF - ENDIF - - ! set all the same value, for precipitation - IF (tintalgo(ivar) == 'uniform') THEN - IF (trim(timelog(ivar)) == 'forward') THEN - CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) - ELSE - CALL block_data_copy (forcn_UB(ivar), forcn(ivar)) - ENDIF - ENDIF - - ! coszen method, for SW - IF (tintalgo(ivar) == 'coszen') THEN - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - DO j = 1, gforc%ycnt(jb) - DO i = 1, gforc%xcnt(ib) - - ilat = gforc%ydsp(jb) + j - ilon = gforc%xdsp(ib) + i - IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon - - calday = calendarday(mtstamp) - cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) - cosz = max(0.001, cosz) - ! 10/24/2024, yuan: deal with time log with backward or forward - IF (trim(timelog(ivar)) == 'forward') THEN - forcn(ivar)%blk(ib,jb)%val(i,j) = & - cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_LB(ivar)%blk(ib,jb)%val(i,j) - ELSE - forcn(ivar)%blk(ib,jb)%val(i,j) = & - cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_UB(ivar)%blk(ib,jb)%val(i,j) - ENDIF - - ENDDO - ENDDO - ENDDO - ENDIF - - ENDDO - - ! preprocess for forcing data, only for QIAN data right now? - CALL metpreprocess (gforc, forcn, & - DEF_forcing%has_missing_value, forcn_UB(1), forc_missing_value) - - CALL allocate_block_data (gforc, forc_xy_solarin) - - CALL block_data_copy (forcn(1), forc_xy_t ) - CALL block_data_copy (forcn(2), forc_xy_q ) - CALL block_data_copy (forcn(3), forc_xy_psrf ) - CALL block_data_copy (forcn(3), forc_xy_pbot ) - CALL block_data_copy (forcn(4), forc_xy_prl, sca = 2/3._r8) - CALL block_data_copy (forcn(4), forc_xy_prc, sca = 1/3._r8) - CALL block_data_copy (forcn(7), forc_xy_solarin) - CALL block_data_copy (forcn(8), forc_xy_frl ) - IF (DEF_USE_CBL_HEIGHT) THEN - CALL block_data_copy (forcn(9), forc_xy_hpbl ) - ENDIF - - IF (has_u .and. has_v) THEN - CALL block_data_copy (forcn(5), forc_xy_us ) - CALL block_data_copy (forcn(6), forc_xy_vs ) - ELSEIF (has_u) THEN - CALL block_data_copy (forcn(5), forc_xy_us , sca = 1/sqrt(2.0_r8)) - CALL block_data_copy (forcn(5), forc_xy_vs , sca = 1/sqrt(2.0_r8)) - ELSEIF (has_v) THEN - CALL block_data_copy (forcn(6), forc_xy_us , sca = 1/sqrt(2.0_r8)) - CALL block_data_copy (forcn(6), forc_xy_vs , sca = 1/sqrt(2.0_r8)) - ELSE - IF (.not.trim(DEF_forcing%dataset) == 'CPL7') THEN - write(6, *) "At least one of the wind components must be provided! STOP!"; - CALL CoLM_stop() - ENDIF - ENDIF - - CALL flush_block_data (forc_xy_hgt_u, real(HEIGHT_V,r8)) - CALL flush_block_data (forc_xy_hgt_t, real(HEIGHT_T,r8)) - CALL flush_block_data (forc_xy_hgt_q, real(HEIGHT_Q,r8)) - - IF (solarin_all_band) THEN - - IF (trim(DEF_forcing%dataset) == 'QIAN') THEN - !--------------------------------------------------------------- - ! 04/2014, yuan: NOTE! codes from CLM4.5-CESM1.2.0 - ! relationship between incoming NIR or VIS radiation and ratio of - ! direct to diffuse radiation calculated based on one year's worth of - ! hourly CAM output from CAM version cam3_5_55 - !--------------------------------------------------------------- - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - DO j = 1, gforc%ycnt(jb) - DO i = 1, gforc%xcnt(ib) - - hsolar = forc_xy_solarin%blk(ib,jb)%val(i,j)*0.5_R8 - - ! NIR (dir, diff) - ratio_rvrf = min(0.99_R8,max(0.29548_R8 + 0.00504_R8*hsolar & - -1.4957e-05_R8*hsolar**2 + 1.4881e-08_R8*hsolar**3,0.01_R8)) - forc_xy_soll %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar - forc_xy_solld%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar - - ! VIS (dir, diff) - ratio_rvrf = min(0.99_R8,max(0.17639_R8 + 0.00380_R8*hsolar & - -9.0039e-06_R8*hsolar**2 + 8.1351e-09_R8*hsolar**3,0.01_R8)) - forc_xy_sols %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar - forc_xy_solsd%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar - - ENDDO - ENDDO - ENDDO - - ELSE - !--------------------------------------------------------------- - ! as the downward solar is in full band, an empirical expression - ! will be used to divide fractions of band and incident - ! (visible, near-infrad, dirct, diffuse) - ! Julian calday (1.xx to 365.xx) - !--------------------------------------------------------------- - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - DO j = 1, gforc%ycnt(jb) - DO i = 1, gforc%xcnt(ib) - - IF (DEF_forcing%has_missing_value) THEN - IF (forcn_UB(1)%blk(ib,jb)%val(i,j) == forc_missing_value) THEN - CYCLE - ENDIF - ENDIF - - ilat = gforc%ydsp(jb) + j - ilon = gforc%xdsp(ib) + i - IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon - - a = max(0., forc_xy_solarin%blk(ib,jb)%val(i,j)) - calday = calendarday(idate) - sunang = orb_coszen (calday, gforc%rlon(ilon), gforc%rlat(ilat)) - - IF (sunang .eq. 0)THEN - cloud = 0. - ELSE - cloud = (1160.*sunang-a)/(963.*sunang) - ENDIF - cloud = max(cloud,0.) - cloud = min(cloud,1.) - cloud = max(0.58,cloud) - - difrat = 0.0604/(sunang-0.0223)+0.0683 - IF(difrat.lt.0.) difrat = 0. - IF(difrat.gt.1.) difrat = 1. - - difrat = difrat+(1.0-difrat)*cloud - vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.)) - - forc_xy_sols %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*vnrat - forc_xy_soll %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*(1.0-vnrat) - forc_xy_solsd%blk(ib,jb)%val(i,j) = a*difrat*vnrat - forc_xy_solld%blk(ib,jb)%val(i,j) = a*difrat*(1.0-vnrat) - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF - - ! [GET ATMOSPHERE CO2 CONCENTRATION DATA] - year = idate(1) - CALL julian2monthday (idate(1), idate(2), month, mday) - pco2m = get_monthly_co2_mlo(year, month)*1.e-6 - CALL block_data_copy (forc_xy_pbot, forc_xy_pco2m, sca = pco2m ) - CALL block_data_copy (forc_xy_pbot, forc_xy_po2m , sca = 0.209_r8 ) - - ENDIF - - IF ((.not. DEF_USE_Forcing_Downscaling).and.(.not. DEF_USE_Forcing_Downscaling_Simple)) THEN - - ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] - ! -> the 1d vector of subgrid points [numpatch] - CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m) - CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m ) - CALL mg2p_forc%grid2pset (forc_xy_us , forc_us ) - CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs ) - - CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf ) - - CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols ) - CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll ) - CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd) - CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld) - - CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t) - CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u) - CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q) - - IF (DEF_USE_CBL_HEIGHT) THEN - CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl) - ENDIF - - CALL mg2p_forc%grid2pset (forc_xy_t , forc_t ) - CALL mg2p_forc%grid2pset (forc_xy_q , forc_q ) - CALL mg2p_forc%grid2pset (forc_xy_prc , forc_prc ) - CALL mg2p_forc%grid2pset (forc_xy_prl , forc_prl ) - CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot ) - CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl ) - - IF (p_is_compute) THEN - - DO np = 1, numpatch - - IF (.not. forcmask_pch(np)) CYCLE - - ! The standard measuring conditions for temperature are two meters above the ground - ! Scientists have measured the most frigid temperature ever - ! recorded on the continent's eastern highlands: about (180K) colder than dry ice. - IF(forc_t(np) < 180.) forc_t(np) = 180. - ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; - ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 - IF(forc_t(np) > 326.) forc_t(np) = 326. - - forc_rhoair(np) = (forc_pbot(np) & - - 0.378*forc_q(np)*forc_pbot(np)/(0.622+0.378*forc_q(np)))& - / (rgas*forc_t(np)) - - ENDDO - - ENDIF - - ELSE - ! ------------------------------------------------------ - ! Forcing downscaling module - ! ------------------------------------------------------ - ! init forcing on patches - CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m) - CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m ) - CALL mg2p_forc%grid2pset (forc_xy_us , forc_us ) - CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs ) - CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf ) - CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols ) - CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll ) - CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd) - CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld) - CALL mg2p_forc%grid2pset (forc_xy_solarin, forc_swrad) - CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t) - CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u) - CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q) - CALL mg2p_forc%grid2pset (forc_xy_t , forc_t ) - CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot ) - CALL mg2p_forc%grid2pset (forc_xy_q , forc_q ) - CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl ) - - IF (DEF_USE_CBL_HEIGHT) THEN - CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl) - ENDIF - - ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] - ! -> the 1d vector of subgrid points [numelm] - ! by selected mapping methods - CALL mg2p_forc%grid2part (forc_xy_t , forc_t_grid ) - CALL mg2p_forc%grid2part (forc_xy_q , forc_q_grid ) - CALL mg2p_forc%grid2part (forc_xy_prc , forc_prc_grid ) - CALL mg2p_forc%grid2part (forc_xy_prl , forc_prl_grid ) - CALL mg2p_forc%grid2part (forc_xy_pbot , forc_pbot_grid ) - CALL mg2p_forc%grid2part (forc_xy_frl , forc_lwrad_grid) - CALL mg2p_forc%grid2part (forc_xy_hgt_t, forc_hgt_grid ) - CALL mg2p_forc%grid2part (forc_xy_solarin, forc_swrad_grid) - CALL mg2p_forc%grid2part (forc_xy_us, forc_us_grid ) - CALL mg2p_forc%grid2part (forc_xy_vs, forc_vs_grid ) - - calday = calendarday(idate) - - IF (p_is_compute) THEN - DO np = 1, numpatch ! patches - - ! calculate albedo of each patches - IF (forc_sols(np)+forc_solsd(np)+forc_soll(np)+forc_solld(np) == 0.) THEN - balb = 0 - ELSE - balb = ( alb(1,1,np)*forc_sols (np) + alb(1,2,np)*forc_solsd(np) & - + alb(2,1,np)*forc_soll (np) + alb(2,2,np)*forc_solld(np) ) & - / (forc_sols(np)+forc_solsd(np)+forc_soll(np)+forc_solld(np)) - ENDIF - - DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch - - IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE - - ! The standard measuring conditions for temperature are two meters above - ! the ground. Scientists have measured the most frigid temperature ever - ! recorded on the continent's eastern highlands: about (180K) colder than - ! dry ice. - IF (forc_t_grid(np)%val(ipart) < 180.) forc_t_grid(np)%val(ipart) = 180. - ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; - ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 - IF (forc_t_grid(np)%val(ipart) > 326.) forc_t_grid(np)%val(ipart) = 326. - - forc_rho_grid(np)%val(ipart) = (forc_pbot_grid(np)%val(ipart) & - - 0.378*forc_q_grid(np)%val(ipart)*forc_pbot_grid(np)%val(ipart) & - /(0.622+0.378*forc_q_grid(np)%val(ipart)))/(rgas*forc_t_grid(np)%val(ipart)) - - forc_th_grid(np)%val(ipart) = forc_t_grid(np)%val(ipart) & - * (1.e5/forc_pbot_grid(np)%val(ipart)) ** (rair/cpair) - - ! calculate sun zenith angle and sun azimuth angle and turn to degree - coszen(np) = orb_coszen(calday, patchlonr(np), patchlatr(np)) - cosazi(np) = orb_cosazi(calday, patchlonr(np), patchlatr(np), coszen(np)) - - ! downscale forcing from grid to part - IF (DEF_USE_Forcing_Downscaling) THEN - ! Complex downscaling with topographic effects - CALL downscale_forcings ( & - glacierss(np), & - - ! non-adjusted forcing - forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), & - forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), & - forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), & - forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), & - forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), & - forc_hgt_grid(np)%val(ipart), forc_swrad_grid(np)%val(ipart), & - forc_us_grid(np)%val(ipart), forc_vs_grid(np)%val(ipart), & - - ! topography-based factor on patch - slp_type_patches(:,np), asp_type_patches(:,np), cur_patches(np), & - - ! other factors - calday, coszen(np), cosazi(np), & - - ! adjusted forcing - forc_topo(np), forc_t_part(np)%val(ipart), & - forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), & - forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), & - forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), & - - forc_frl_part(np)%val(ipart), forc_swrad_part(np)%val(ipart), & - forc_us_part(np)%val(ipart), forc_vs_part(np)%val(ipart), & - - ! optional factors for complex downscaling - area_type_patches(:,np), svf_patches(np), balb, & -#ifdef SinglePoint - sf_lut_patches (:,:,np) & -#else - sf_curve_patches(:,:,np) & -#endif - ) - - ELSEIF (DEF_USE_Forcing_Downscaling_Simple) THEN - ! Simple downscaling without optional parameters - CALL downscale_forcings ( & - glacierss(np), & - - ! non-adjusted forcing - forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), & - forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), & - forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), & - forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), & - forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), & - forc_hgt_grid(np)%val(ipart), forc_swrad_grid(np)%val(ipart), & - forc_us_grid(np)%val(ipart), forc_vs_grid(np)%val(ipart), & - - ! topography-based factor on patch - slp_type_patches(:,np), asp_type_patches(:,np), cur_patches(np), & - - ! other factors - calday, coszen(np), cosazi(np), & - - ! adjusted forcing - forc_topo(np), forc_t_part(np)%val(ipart), & - forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), & - forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), & - forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), & - - forc_frl_part(np)%val(ipart), forc_swrad_part(np)%val(ipart), & - forc_us_part(np)%val(ipart), forc_vs_part(np)%val(ipart) & - ) - - ENDIF - - ENDDO - ENDDO - ENDIF - - ! mapping parts to patches - CALL mg2p_forc%part2pset (forc_t_part, forc_t ) - CALL mg2p_forc%part2pset (forc_q_part, forc_q ) - CALL mg2p_forc%part2pset (forc_pbot_part, forc_pbot ) - CALL mg2p_forc%part2pset (forc_rhoair_part, forc_rhoair) - CALL mg2p_forc%part2pset (forc_prc_part, forc_prc ) - CALL mg2p_forc%part2pset (forc_prl_part, forc_prl ) - CALL mg2p_forc%part2pset (forc_frl_part, forc_frl ) - CALL mg2p_forc%part2pset (forc_swrad_part, forc_swrad ) - CALL mg2p_forc%part2pset (forc_us_part, forc_us ) - CALL mg2p_forc%part2pset (forc_vs_part, forc_vs ) - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - forc_psrf = forc_pbot - ENDIF - ENDIF - - ! wind downscaling - IF (p_is_compute) THEN - IF (DEF_USE_Forcing_Downscaling) THEN - DO np = 1, numpatch - IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle - CALL downscale_wind(forc_us(np), forc_vs(np), slp_type_patches(:,np), & - asp_type_patches(:,np), area_type_patches(:,np), cur_patches(np)) - ENDDO - - ELSEIF (DEF_USE_Forcing_Downscaling_Simple) THEN - DO np = 1, numpatch - IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle - CALL downscale_wind_simple(forc_us(np), forc_vs(np), slp_type_patches(:,np), & - asp_type_patches(:,np), cur_patches(np)) - ENDDO - - ENDIF - ENDIF - -#ifndef SinglePoint - IF (trim(DEF_DS_precipitation_adjust_scheme) == 'III') THEN - ! Sisi Chen, Lu Li, Yongjiu Dai et al., 2024, JGR - ! Using MPI to pass the forcing variable field to Python to - ! accomplish precipitation downscaling - IF (p_is_compute) THEN - spaceship(1,1:numpatch) = forc_topo - spaceship(2,1:numpatch) = forc_t - spaceship(3,1:numpatch) = forc_pbot - spaceship(4,1:numpatch) = forc_q - spaceship(5,1:numpatch) = forc_frl - spaceship(6,1:numpatch) = forc_swrad - spaceship(7,1:numpatch) = forc_us - spaceship(8,1:numpatch) = forc_vs - spaceship(9,1:numpatch) = INT(calday) - spaceship(10,1:numpatch) = patchlatr - spaceship(11,1:numpatch) = patchlonr - - target_server = p_iam_glb/5+p_np_glb - CALL MPI_SEND(spaceship,12*numpatch,MPI_REAL8,target_server,0,MPI_COMM_WORLD,ierr) - CALL MPI_RECV(forc_prc,numpatch,MPI_REAL8,target_server,0,MPI_COMM_WORLD,& - MPI_STATUS_IGNORE,ierr) - - forc_prl = forc_prc/3600*2/3._r8 - forc_prc = forc_prc/3600*1/3._r8 - ENDIF - ENDIF - - ! mapping forc_prl to forc_prl_part, forc_prc to forc_prc_part - IF (p_is_compute) THEN - DO np = 1, numpatch ! patches - DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch - IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE - - forc_prl_part(np)%val(ipart) = forc_prl(np) - forc_prc_part(np)%val(ipart) = forc_prc(np) - - ENDDO - ENDDO - ENDIF - - ! Conservation of convective and large scale precipitation in the grid of forcing - CALL mg2p_forc%normalize (forc_xy_prc, forc_prc_part) - CALL mg2p_forc%normalize (forc_xy_prl, forc_prl_part) - - ! mapping parts to patches - CALL mg2p_forc%part2pset (forc_prc_part, forc_prc) - CALL mg2p_forc%part2pset (forc_prl_part, forc_prl) - - ! Conservation of short- and long- waves radiation in the grid of forcing - CALL mg2p_forc%normalize (forc_xy_solarin, forc_swrad_part) - CALL mg2p_forc%normalize (forc_xy_frl, forc_frl_part ) - CALL mg2p_forc%part2pset (forc_frl_part, forc_frl ) - CALL mg2p_forc%part2pset (forc_swrad_part, forc_swrad ) -#endif - - ! divide fractions of downscaled shortwave radiation - IF (p_is_compute) THEN - DO j = 1, numpatch - a = forc_swrad(j) - IF (isnan_ud(a)) a = 0 - calday = calendarday(idate) - sunang = orb_coszen (calday, patchlonr(j), patchlatr(j)) - IF (sunang.eq.0) THEN - cloud = 0. - ELSE - cloud = (1160.*sunang-a)/(963.*sunang) - ENDIF - cloud = max(cloud,0.0001) - cloud = min(cloud,1.) - cloud = max(0.58,cloud) - - difrat = 0.0604/(sunang-0.0223)+0.0683 - IF(difrat.lt.0.) difrat = 0. - IF(difrat.gt.1.) difrat = 1. - - difrat = difrat+(1.0-difrat)*cloud - vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.)) - - forc_sols(j) = a*(1.0-difrat)*vnrat - forc_soll(j) = a*(1.0-difrat)*(1.0-vnrat) - forc_solsd(j) = a*difrat*vnrat - forc_solld(j) = a*difrat*(1.0-vnrat) - ENDDO - ENDIF - ENDIF - -#ifdef RangeCheck -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) write(*,'(/, A20)') 'Checking forcing ...' - - CALL check_vector_data ('Forcing us [m/s] ', forc_us ) - CALL check_vector_data ('Forcing vs [m/s] ', forc_vs ) - CALL check_vector_data ('Forcing t [kelvin]', forc_t ) - CALL check_vector_data ('Forcing q [kg/kg] ', forc_q ) - CALL check_vector_data ('Forcing prc [mm/s] ', forc_prc ) - CALL check_vector_data ('Forcing psrf [pa] ', forc_psrf ) - CALL check_vector_data ('Forcing prl [mm/s] ', forc_prl ) - CALL check_vector_data ('Forcing sols [W/m2] ', forc_sols ) - CALL check_vector_data ('Forcing soll [W/m2] ', forc_soll ) - CALL check_vector_data ('Forcing solsd [W/m2] ', forc_solsd) - CALL check_vector_data ('Forcing solld [W/m2] ', forc_solld) - CALL check_vector_data ('Forcing frl [W/m2] ', forc_frl ) - IF (DEF_USE_CBL_HEIGHT) THEN - CALL check_vector_data ('Forcing hpbl ', forc_hpbl ) - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif -#endif - - END SUBROUTINE read_forcing - - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! read lower and upper boundary forcing data, a major interface of this -! MODULE -! -! !REVISIONS: -! 04/2014, Hua Yuan: initial code -! -!----------------------------------------------------------------------- - SUBROUTINE metreadLBUB (idate, dir_forcing, is_spinup) - - USE MOD_UserSpecifiedForcing - USE MOD_Namelist - USE MOD_Block - USE MOD_DataType - USE MOD_Block - USE MOD_NetCDFBlock - USE MOD_RangeCheck - IMPLICIT NONE - - integer, intent(in) :: idate(3) - character(len=*), intent(in) :: dir_forcing - logical, intent(in) :: is_spinup - - ! Local variables - integer :: ivar, year, month, day, time_i - integer :: iblkme, ib, jb, i, j - type(timestamp) :: mtstamp - character(len=256) :: filename - - mtstamp = idate - - DO ivar = 1, NVAR - - IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE - - ! lower and upper boundary data already exist, CYCLE - IF ( .not.(tstamp_LB(ivar)=='NULL') .and. .not.(tstamp_UB(ivar)=='NULL') .and. & - tstamp_LB(ivar)<=mtstamp .and. mtstampendyr .or. (month>endmo .and. year==endyr) ) THEN - write(*,*) 'model year/month: ', year, month - write(*,*) 'forcing end year/month defined: ', endyr, endmo - print *, 'Warning: reaching the END of forcing data defined!' - ENDIF - - ! read forcing data - filename = trim(dir_forcing)//trim(metfilename(year, month, day, ivar, is_spinup)) - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - - IF (forcing_read_ahead) THEN - metdata%blk(gblock%xblkme(1),gblock%yblkme(1))%val = forc_disk(time_i,ivar) - ELSE -#ifndef URBAN_MODEL - CALL ncio_read_site_time (filename, vname(ivar), time_i, metdata) -#else - IF (trim(vname(ivar)) == 'Rainf') THEN - CALL ncio_read_site_time (filename, 'Rainf', time_i, rainf) - CALL ncio_read_site_time (filename, 'Snowf', time_i, snowf) - - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - metdata%blk(ib,jb)%val(1,1) = rainf%blk(ib,jb)%val(1,1) & - + snowf%blk(ib,jb)%val(1,1) - ENDDO - ELSE - CALL ncio_read_site_time (filename, vname(ivar), time_i, metdata) - ENDIF -#endif - ENDIF - ELSE - CALL ncio_read_block_time (filename, vname(ivar), gforc, time_i, metdata) - ENDIF - - CALL block_data_copy (metdata, forcn_UB(ivar)) - - ! calculate time average coszen, for shortwave radiation - IF (ivar == 7) THEN - CALL calavgcos(idate) - ENDIF - ENDIF - - ENDDO - - END SUBROUTINE metreadLBUB - - -!----------------------------------------------------------------------- - SUBROUTINE metread_latlon (dir_forcing, idate) - - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - USE MOD_UserSpecifiedForcing - USE MOD_Namelist - IMPLICIT NONE - - character(len=*), intent(in) :: dir_forcing - integer, intent(in) :: idate(3) - - ! Local variables - character(len=256) :: filename - integer :: year, month, day, time_i - type(timestamp) :: mtstamp - real(r8), allocatable :: latxy (:,:) ! latitude values in 2d - real(r8), allocatable :: lonxy (:,:) ! longitude values in 2d - real(r8), allocatable :: lon_in(:) - real(r8), allocatable :: lat_in(:) - - IF (trim(DEF_forcing%dataset) == 'POINT' .or. trim(DEF_forcing%dataset) == 'CPL7' ) THEN - CALL gforc%define_by_ndims (360, 180) - ELSE - - mtstamp = idate - - CALL setstampLB(mtstamp, 1, year, month, day, time_i) - filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) - tstamp_LB(1) = timestamp(-1, -1, -1) - - IF (dim2d) THEN - CALL ncio_read_bcast_serial (filename, latname, latxy) - CALL ncio_read_bcast_serial (filename, lonname, lonxy) - - allocate (lat_in (size(latxy,2))) - allocate (lon_in (size(lonxy,1))) - lat_in = latxy(1,:) - lon_in = lonxy(:,1) - - deallocate (latxy) - deallocate (lonxy) - ELSE - CALL ncio_read_bcast_serial (filename, latname, lat_in) - CALL ncio_read_bcast_serial (filename, lonname, lon_in) - ENDIF - - IF (.not. DEF_forcing%regional) THEN - CALL gforc%define_by_center (lat_in, lon_in) - ELSE - CALL gforc%define_by_center (lat_in, lon_in, & - south = DEF_forcing%regbnd(1), north = DEF_forcing%regbnd(2), & - west = DEF_forcing%regbnd(3), east = DEF_forcing%regbnd(4)) - ENDIF - - deallocate (lat_in) - deallocate (lon_in) - ENDIF - - CALL gforc%set_rlon () - CALL gforc%set_rlat () - - END SUBROUTINE metread_latlon - -!----------------------------------------------------------------------- - SUBROUTINE metread_time (dir_forcing, ststamp, etstamp, deltime) - - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - USE MOD_UserSpecifiedForcing - USE MOD_Namelist - IMPLICIT NONE - - character(len=*), intent(in) :: dir_forcing - type(timestamp), intent(in), optional :: ststamp, etstamp - real(r8), intent(in), optional :: deltime - - ! Local variables - character(len=256) :: filename - character(len=256) :: timeunit, timestr - real(r8), allocatable :: forctime_sec(:), metcache(:,:,:) - integer :: year, month, day, hour, minute, second - integer :: itime, maxday, id(3) - integer*8 :: sec_long - integer :: ivar, ntime, its, ite, it - real(r8) firstsec - - type(timestamp) :: etstamp_f - type(timestamp), allocatable :: forctime_ (:) - - - filename = trim(dir_forcing)//trim(fprefix(1)) - - CALL ncio_read_serial (filename, 'time', forctime_sec) - CALL ncio_get_attr (filename, 'time', 'units', timeunit) - - timestr = timeunit(15:18) // ' ' // timeunit(20:21) // ' ' // timeunit(23:24) & - // ' ' // timeunit(26:27) // ' ' // timeunit(29:30) // ' ' // timeunit(32:33) - read(timestr,*) year, month, day, hour, minute, second - - allocate (forctime (size(forctime_sec))) - - id(1) = year - id(2) = get_calday(month*100+day, isleapyear(year)) - id(3) = hour*3600 + minute*60 + second - - firstsec = forctime_sec(1) - DO WHILE (firstsec > 86400) - CALL ticktime (86400., id) - firstsec = firstsec - 86400 - ENDDO - CALL ticktime (firstsec, id) - - !forctime(1)%year = year - !forctime(1)%day = get_calday(month*100+day, isleapyear(year)) - !forctime(1)%sec = hour*3600 + minute*60 + second + forctime_sec(1) - - !id(:) = (/forctime(1)%year, forctime(1)%day, forctime(1)%sec/) - CALL adj2end(id) - forctime(1) = id - - ntime = size(forctime) - - DO itime = 2, ntime - id(:) = (/forctime(itime-1)%year, forctime(itime-1)%day, forctime(itime-1)%sec/) - CALL ticktime (forctime_sec(itime)-forctime_sec(itime-1), id) - forctime(itime) = id - ENDDO - - IF (forcing_read_ahead) THEN - - CALL ticktime (deltime, id) - etstamp_f = id - - IF ((ststamp < forctime(1)) .or. (etstamp_f < etstamp)) THEN - write(*,*) 'Error: Forcing does not cover simulation period!' - write(*,*) 'Model start ', ststamp, ' -> Model END ', etstamp - write(*,*) 'Forc start ', forctime(1), ' -> Forc END ', etstamp_f - CALL CoLM_stop () - ELSE - its = 1 - DO WHILE (.not. (ststamp < forctime(its+1))) - its = its + 1 - IF (its >= ntime) EXIT - ENDDO - - ite = ntime - DO WHILE (etstamp < forctime(ite-1)) - ite = ite - 1 - IF (ite <= 1) EXIT - ENDDO - - ntime = ite-its+1 - - allocate (forctime_(ntime)) - DO it = 1, ntime - forctime_(it) = forctime(it+its-1) - ENDDO - - deallocate (forctime) - allocate (forctime (ntime)) - DO it = 1, ntime - forctime(it) = forctime_(it) - ENDDO - - deallocate(forctime_) - ENDIF - - allocate (forc_disk (size(forctime),NVAR)) - - filename = trim(dir_forcing)//trim(metfilename(-1,-1,-1,-1)) - DO ivar = 1, NVAR - IF (trim(vname(ivar)) /= 'NULL') THEN -#ifndef URBAN_MODEL - CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache) - forc_disk(:,ivar) = metcache(1,1,:) -#else - IF (trim(vname(ivar)) == 'Rainf') THEN - CALL ncio_read_period_serial (filename, 'Rainf', its, ite, metcache) - forc_disk(:,ivar) = metcache(1,1,:) - - CALL ncio_read_period_serial (filename, 'Snowf', its, ite, metcache) - forc_disk(:,ivar) = forc_disk(:,ivar) + metcache(1,1,:) - ELSE - CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache) - forc_disk(:,ivar) = metcache(1,1,:) - ENDIF -#endif - ENDIF - ENDDO - - IF (allocated(metcache)) deallocate(metcache) - ENDIF - - END SUBROUTINE metread_time - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! set the lower boundary time stamp and record information, -! a KEY FUNCTION of this MODULE -! -! - for time stamp, set it regularly as the model time step. -! - for record information, account for: -! o year alternation -! o month alternation -! o leap year -! o required data just beyond the first record -! -! !REVISIONS: -! 04/2014, Hua Yuan: initial code -! -!----------------------------------------------------------------------- - SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) - - IMPLICIT NONE - type(timestamp), intent(in) :: mtstamp - integer, intent(in) :: var_i - integer, intent(out) :: year - integer, intent(out) :: month - integer, intent(out) :: mday - integer, intent(out) :: time_i - - integer :: i, day, sec, ntime - integer :: months(0:12) - - year = mtstamp%year - day = mtstamp%day - sec = mtstamp%sec - - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - - ntime = size(forctime) - time_i = 1 - - IF ((mtstamp < forctime(1)) .or. (forctime(ntime) < mtstamp)) THEN - write(*,*) 'Error: Forcing does not cover simulation period!' - write(*,*) 'Need ', mtstamp, ', Forc start ', forctime(1), ', Forc END', forctime(ntime) - CALL CoLM_stop () - ELSE - DO WHILE (.not. (mtstamp < forctime(time_i+1))) - time_i = time_i + 1 - ENDDO - iforctime(var_i) = time_i - tstamp_LB(var_i) = forctime(iforctime(var_i)) - ENDIF - - RETURN - ENDIF - - tstamp_LB(var_i)%year = year - tstamp_LB(var_i)%day = day - - ! in the case of one year one file - IF ( trim(groupby) == 'year' ) THEN - - ! calculate the initial second - sec = 86400*(day-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(day-1) - tstamp_LB(var_i)%sec = sec - - ! set time stamp (ststamp_LB) - IF (sec < 0) THEN - tstamp_LB(var_i)%sec = 86400 + sec - tstamp_LB(var_i)%day = day - 1 - IF (tstamp_LB(var_i)%day == 0) THEN - tstamp_LB(var_i)%year = year - 1 - IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN - tstamp_LB(var_i)%day = 366 - ELSE - tstamp_LB(var_i)%day = 365 - ENDIF - ENDIF - ENDIF - - ! set record info (year, time_i) - IF ( sec<0 .or. (sec==0 .and. offset(var_i).NE.0) ) THEN - - ! IF the required data just behind the first record - ! -> set to the first record - IF ( year==startyr .and. month==startmo .and. day==1 ) THEN - sec = offset(var_i) - - ! ELSE, set to one record backward - ELSE - sec = 86400 + sec - day = day - 1 - IF (day == 0) THEN - year = year - 1 - IF ( isleapyear(year) ) THEN - day = 366 - ELSE - day = 365 - ENDIF - ENDIF - ENDIF - ENDIF ! ENDIF (sec <= 0) - - ! in case of leapyear with a non-leapyear calendar - ! USE the data 1 day before after FEB 28th (Julian day 59). - IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN - day = day - 1 - ENDIF - - ! get record time index - sec = 86400*(day-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - ENDIF - - ! in the case of one month one file - IF ( trim(groupby) == 'month' ) THEN - - IF ( isleapyear(year) ) THEN - months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) - ELSE - months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) - ENDIF - - ! calculate initial month and day values - CALL julian2monthday(year, day, month, mday) - - ! calculate initial second value - sec = 86400*(mday-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(mday-1) - tstamp_LB(var_i)%sec = sec - - ! set time stamp (ststamp_LB) - IF (sec < 0) THEN - tstamp_LB(var_i)%sec = 86400 + sec - tstamp_LB(var_i)%day = day - 1 - IF (tstamp_LB(var_i)%day == 0) THEN - tstamp_LB(var_i)%year = year - 1 - IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN - tstamp_LB(var_i)%day = 366 - ELSE - tstamp_LB(var_i)%day = 365 - ENDIF - ENDIF - ENDIF - - ! set record info (year, month, time_i) - IF ( sec<0 .or. (sec==0 .and. offset(var_i).ne.0) ) THEN - - ! IF just behind the first record -> set to first record - IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN - sec = offset(var_i) - - ! set to one record backward - ELSE - sec = 86400 + sec - mday = mday - 1 - IF (mday == 0) THEN - month = month - 1 - ! bug found by Zhu Siguang & Zhang Xiangxiang, 05/19/2014 - ! move the below line in the 'ELSE' statement - !mday = months(month) - months(month-1) - IF (month == 0) THEN - month = 12 - year = year - 1 - mday = 31 - ELSE - mday = months(month) - months(month-1) - ENDIF - ENDIF - ENDIF - ENDIF - - ! in case of leapyear with a non-leapyear calendar - ! USE the data 1 day before, i.e., FEB 28th. - IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN - mday = 28 - ENDIF - - ! get record time index - sec = 86400*(mday-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - ENDIF - - ! in the case of one day one file - IF ( trim(groupby) == 'day' ) THEN - - ! calculate initial month and day values - CALL julian2monthday(year, day, month, mday) - - ! calculate initial second value - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - sec = (time_i-1)*dtime(var_i) + offset(var_i) - tstamp_LB(var_i)%sec = sec - - ! set time stamp (ststamp_LB) - IF (sec < 0) THEN - tstamp_LB(var_i)%sec = 86400 + sec - tstamp_LB(var_i)%day = day - 1 - IF (tstamp_LB(var_i)%day == 0) THEN - tstamp_LB(var_i)%year = year - 1 - IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN - tstamp_LB(var_i)%day = 366 - ELSE - tstamp_LB(var_i)%day = 365 - ENDIF - ENDIF - - IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN - sec = offset(var_i) - ! set to one record backward - ELSE - sec = 86400 + sec - year = tstamp_LB(var_i)%year - CALL julian2monthday(tstamp_LB(var_i)%year, tstamp_LB(var_i)%day, month, mday) - ENDIF - ENDIF - - ! in case of leapyear with a non-leapyear calendar - ! USE the data 1 day before, i.e., FEB 28th. - IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN - mday = 28 - ENDIF - - ! get record time index - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - ENDIF - - IF (time_i <= 0) THEN - write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop() - ENDIF - - RETURN - - END SUBROUTINE setstampLB - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! set the upper boundary time stamp and record information, -! a KEY FUNCTION of this MODULE -! -! !REVISIONS: -! 04/2014, Hua Yuan: initial code -! -!----------------------------------------------------------------------- - SUBROUTINE setstampUB(var_i, year, month, mday, time_i) - - IMPLICIT NONE - integer, intent(in) :: var_i - integer, intent(out) :: year - integer, intent(out) :: month - integer, intent(out) :: mday - integer, intent(out) :: time_i - - integer :: day, sec - integer :: months(0:12) - - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - IF ( tstamp_UB(var_i) == 'NULL' ) THEN - tstamp_UB(var_i) = forctime(iforctime(var_i)+1) - ELSE - iforctime(var_i) = iforctime(var_i) + 1 - tstamp_LB(var_i) = forctime(iforctime(var_i)) - tstamp_UB(var_i) = forctime(iforctime(var_i)+1) - ENDIF - - time_i = iforctime(var_i)+1 - year = tstamp_UB(var_i)%year - day = tstamp_UB(var_i)%day - - CALL julian2monthday(year, day, month, mday) - - RETURN - ENDIF - - ! calculate the time stamp - IF ( tstamp_UB(var_i) == 'NULL' ) THEN - tstamp_UB(var_i) = tstamp_LB(var_i) + dtime(var_i) - ELSE - tstamp_LB(var_i) = tstamp_UB(var_i) - tstamp_UB(var_i) = tstamp_UB(var_i) + dtime(var_i) - ENDIF - - ! calculate initial year, day, and second values - year = tstamp_UB(var_i)%year - day = tstamp_UB(var_i)%day - sec = tstamp_UB(var_i)%sec - - IF ( trim(groupby) == 'year' ) THEN - - ! adjust year value - IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN - sec = 0 - day = day + 1 - IF( isleapyear(year) .and. day==367) THEN - year = year + 1; day = 1 - ENDIF - IF( .not. isleapyear(year) .and. day==366) THEN - year = year + 1; day = 1 - ENDIF - ENDIF - - ! in case of leapyear with a non-leapyear calendar - ! USE the data 1 day before after FEB 28th (Julian day 59). - IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN - day = day - 1 - ENDIF - - ! set record index - sec = 86400*(day-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - ENDIF - - IF ( trim(groupby) == 'month' ) THEN - - IF ( isleapyear(year) ) THEN - months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) - ELSE - months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) - ENDIF - - ! calculate initial month and day values - CALL julian2monthday(year, day, month, mday) - - ! record in the next day, adjust year, month and second values - IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN - sec = 0 - mday = mday + 1 - IF ( mday > (months(month)-months(month-1)) ) THEN - mday = 1 - ! bug found by Zhu Siguang, 05/25/2014 - ! move the below line in the 'ELSE' statement - !month = month + 1 - IF (month == 12) THEN - month = 1 - year = year + 1 - ELSE - month = month + 1 - ENDIF - ENDIF - ENDIF - - ! in case of leapyear with a non-leapyear calendar - ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB. - IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN - mday = 28 - ENDIF - - ! set record index - sec = 86400*(mday-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - ENDIF - - IF ( trim(groupby) == 'day' ) THEN - IF ( isleapyear(year) ) THEN - months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) - ELSE - months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) - ENDIF - - ! calculate initial month and day values - CALL julian2monthday(year, day, month, mday) - !mday = day - - ! record in the next day, adjust year, month and second values - IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN - sec = 0 - mday = mday + 1 - IF ( mday > (months(month)-months(month-1)) ) THEN - mday = 1 - ! bug found by Zhu Siguang, 05/25/2014 - ! move the below line in the 'ELSE' statement - !month = month + 1 - IF (month == 12) THEN - month = 1 - year = year + 1 - ELSE - month = month + 1 - ENDIF - ENDIF - ENDIF - - ! in case of leapyear with a non-leapyear calendar - ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB. - IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN - mday = 28 - ENDIF - - ! set record index - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - ENDIF - - IF (time_i < 0) THEN - write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop() - ENDIF - - RETURN - - END SUBROUTINE setstampUB - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! calculate time average coszen value between [LB, UB] -! -! !REVISIONS: -! 04/2014, Hua Yuan: this method is adapted from CLM -! -!----------------------------------------------------------------------- - SUBROUTINE calavgcos(idate) - - USE MOD_Block - USE MOD_DataType - IMPLICIT NONE - - integer, intent(in) :: idate(3) - - integer :: ntime, iblkme, ib, jb, i, j, ilon, ilat - real(r8) :: calday, cosz - type(timestamp) :: tstamp - - tstamp = idate !tstamp_LB(7) - ntime = 0 - DO WHILE (tstamp < tstamp_UB(7)) - ntime = ntime + 1 - tstamp = tstamp + deltim_int - ENDDO - - tstamp = idate !tstamp_LB(7) - CALL flush_block_data (avgcos, 0._r8) - - DO WHILE (tstamp < tstamp_UB(7)) - - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - DO j = 1, gforc%ycnt(jb) - DO i = 1, gforc%xcnt(ib) - - ilat = gforc%ydsp(jb) + j - ilon = gforc%xdsp(ib) + i - IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon - - calday = calendarday(tstamp) - cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) - cosz = max(0.001, cosz) - avgcos%blk(ib,jb)%val(i,j) = avgcos%blk(ib,jb)%val(i,j) & - + cosz / real(ntime,r8) ! * deltim_real /real(tstamp_UB(7)-tstamp_LB(7)) - - ENDDO - ENDDO - ENDDO - - tstamp = tstamp + deltim_int - - ENDDO - - END SUBROUTINE calavgcos - -END MODULE MOD_Forcing diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 deleted file mode 100644 index c557b30784..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 +++ /dev/null @@ -1,1049 +0,0 @@ -#include - -MODULE MOD_ForcingDownscaling - -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! Downscaling meteorological forcings -! -! !INITIAL: -! The Community Land Model version 5.0 (CLM5.0) -! -! !REVISIONS: -! Updated by Yongjiu Dai, January 16, 2023 -! Revised by Lu Li, January 24, 2024 -! Revised by Sisi Chen, Lu Li, June, 2024 -!----------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Qsadv - USE MOD_Namelist - USE MOD_Const_Physical - USE MOD_Vars_Global - USE MOD_UserDefFun - - IMPLICIT NONE - - real(r8), parameter :: SHR_CONST_MWDAIR = 28.966_r8 ! molecular weight dry air [kg/kmole] - real(r8), parameter :: SHR_CONST_MWWV = 18.016_r8 ! molecular weight water vapor - real(r8), parameter :: SHR_CONST_AVOGAD = 6.02214e26_r8 ! Avogadro's number [molecules/kmole] - real(r8), parameter :: SHR_CONST_BOLTZ = 1.38065e-23_r8 ! Boltzmann's constant [J/K/molecule] - ! Universal gas constant [J/K/kmole] - real(r8), parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ - ! Dry air gas constant [J/K/kg] - real(r8), parameter :: rair = SHR_CONST_RGAS/SHR_CONST_MWDAIR - - ! On the windward side of the range, annual mean lapse rates of 3.9-5.2 (deg km-1), substantially - ! smaller than the often-assumed 6.5 (deg km-1). The data sets show similar seasonal and diurnal - ! variability, with lapse rates smallest (2.5-3.5 deg km-1) in late-summer minimum temperatures, - ! and largest (6.5-7.5 deg km-1) in spring maximum temperatures. Geographic (windward versus lee - ! side) differences in lapse rates are substantial. [Minder et al., 2010, Surface temperature - ! lapse rates over complex terrain: Lessons from the Cascade Mountains. JGR, 115, - ! doi:10.1029/2009JD013493] - ! - ! Kunkel, K. E., 1989: Simple procedures for extrapolation of humidity variables in the - ! mountainous western United States. J. Climate, 2, 656-669. lapse_rate = /Jan - - ! Dec/4.4,5.9,7.1,7.8,8.1,8.2,8.1,8.1,7.7,6.8,5.5,4.7/ (deg km-1) - real(r8), parameter :: lapse_rate = 0.006_r8 ! surface temperature lapse rate (deg m-1) - - SAVE - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: downscale_forcings ! Downscale atmospheric forcing - -! PRIVATE MEMBER FUNCTIONS: - PRIVATE :: rhos ! calculate atmospheric density - -!----------------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------------- - - PURE FUNCTION rhos(qbot, pbot, tbot) - -!----------------------------------------------------------------------------- -! DESCRIPTION: -! Compute atmospheric density (kg/m**3) -!----------------------------------------------------------------------------- - - IMPLICIT NONE - - ! ARGUMENTS: - real(r8) :: rhos ! function result: atmospheric density (kg/m**3) - real(r8), intent(in) :: qbot ! atmospheric specific humidity (kg/kg) - real(r8), intent(in) :: pbot ! atmospheric pressure (Pa) - real(r8), intent(in) :: tbot ! atmospheric temperature (K) - - ! LOCAL VARIABLES: - real(r8) :: egcm - real(r8) :: wv_to_dair_weight_ratio ! ratio of molecular weight of water vapor to dry air [-] - - wv_to_dair_weight_ratio = SHR_CONST_MWWV/SHR_CONST_MWDAIR - - egcm = qbot*pbot / (wv_to_dair_weight_ratio + (1._r8 - wv_to_dair_weight_ratio)*qbot) - rhos = (pbot - (1._r8 - wv_to_dair_weight_ratio)*egcm) / (rair*tbot) - - END FUNCTION rhos - -!----------------------------------------------------------------------------- - - SUBROUTINE downscale_forcings (& - glaciers, & - - ! non-adjusted forcing - forc_topo_g ,forc_maxelv_g ,forc_t_g ,forc_th_g ,forc_q_g ,& - forc_pbot_g ,forc_rho_g ,forc_prc_g ,forc_prl_g ,forc_lwrad_g ,& - forc_hgt_g ,forc_swrad_g ,forc_us_g ,forc_vs_g , & - - ! topography-based factor on patch - slp_type_c, asp_type_c, cur_c, & - - ! other factors - julian_day, coszen, cosazi, & - - ! adjusted forcing - forc_topo_c ,forc_t_c ,forc_th_c ,forc_q_c ,forc_pbot_c ,& - forc_rho_c ,forc_prc_c ,forc_prl_c ,forc_lwrad_c, forc_swrad_c, & - forc_us_c ,forc_vs_c, & - - ! optional parameters for full downscaling - area_type_c, svf_c, alb, & -#ifdef SinglePoint - sf_lut_c & -#else - sf_curve_c & -#endif - ) - -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! Downscale atmospheric forcing fields. -! -! Downscaling is done based on the difference between each land model -! column's elevation and the atmosphere's surface elevation (which is -! the elevation at which the atmospheric forcings are valid). -! -! Note that the downscaling procedure can result in changes in grid -! cell mean values compared to what was provided by the atmosphere. We -! conserve fluxes of mass and energy, but allow states such as -! temperature to differ. -!----------------------------------------------------------------------------- - - IMPLICIT NONE - - integer, parameter :: S = 1370 ! solar constant (W/m**2) - real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith angle - - ! ARGUMENTS: - logical, intent(in) :: glaciers ! true: glacier column (itypwat = 3) - real(r8), intent(in) :: julian_day ! day of year - real(r8), intent(in) :: coszen ! cosine of sun zenith angle at an hour - real(r8), intent(in) :: cosazi ! cosine of sun azimuth angle at an hour - - ! topography-based factor - real(r8), intent(in) :: cur_c ! curvature - ! topographic aspect of each type of one patch(rad) - can be different dimensions - real(r8), intent(in) :: asp_type_c (:) - ! topographic slope of each character of one patch - can be different dimensions - real(r8), intent(in) :: slp_type_c (:) - - ! optional parameters for complex downscaling - real(r8), intent(in), optional :: alb ! blue sky albedo - real(r8), intent(in), optional :: svf_c ! sky view factor - ! area percentage of each character of one patch - real(r8), intent(in), optional :: area_type_c(:) -#ifdef SinglePoint - ! look up table of shadow mask of a patch - real(r8), intent(in), optional :: sf_lut_c (:,:) -#else - ! curve of shadow mask of a patch - real(r8), intent(in), optional :: sf_curve_c (:,:) -#endif - - ! non-downscaled fields: - real(r8), intent(in) :: forc_topo_g ! atmospheric surface height [m] - real(r8), intent(in) :: forc_maxelv_g ! max atmospheric surface height [m] - real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin] - real(r8), intent(in) :: forc_th_g ! atmospheric potential temperature [Kelvin] - real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg] - real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] - real(r8), intent(in) :: forc_rho_g ! atmospheric density [kg/m**3] - real(r8), intent(in) :: forc_prc_g ! convective precipitation in grid [mm/s] - real(r8), intent(in) :: forc_prl_g ! large-scale precipitation in grid [mm/s] - real(r8), intent(in) :: forc_lwrad_g ! grid downward longwave [W/m**2] - real(r8), intent(in) :: forc_swrad_g ! grid downward shortwave [W/m**2] - real(r8), intent(in) :: forc_hgt_g ! atmospheric reference height [m] - real(r8), intent(in) :: forc_us_g ! eastward wind [m/s] - real(r8), intent(in) :: forc_vs_g ! northward wind [m/s] - - ! downscaled fields: - real(r8), intent(in) :: forc_topo_c ! column surface height [m] - real(r8), intent(out) :: forc_t_c ! atmospheric temperature [Kelvin] - real(r8), intent(out) :: forc_th_c ! atmospheric potential temperature [Kelvin] - real(r8), intent(out) :: forc_q_c ! atmospheric specific humidity [kg/kg] - real(r8), intent(out) :: forc_pbot_c ! atmospheric pressure [Pa] - real(r8), intent(out) :: forc_rho_c ! atmospheric density [kg/m**3] - real(r8), intent(out) :: forc_prc_c ! column convective precipitation [mm/s] - real(r8), intent(out) :: forc_prl_c ! column large-scale precipitation [mm/s] - real(r8), intent(out) :: forc_lwrad_c ! column downward longwave [W/m**2] - real(r8), intent(out) :: forc_swrad_c ! column downward shortwave [W/m**2] - real(r8), intent(out) :: forc_us_c ! column eastward wind [m/s] - real(r8), intent(out) :: forc_vs_c ! column northward wind [m/s] - - ! Local variables for topo downscaling: - real(r8) :: hsurf_g, hsurf_c - real(r8) :: Hbot, zbot - real(r8) :: tbot_g, pbot_g, thbot_g, qbot_g, qs_g, es_g, rhos_g - real(r8) :: tbot_c, pbot_c, thbot_c, qbot_c, qs_c, es_c, rhos_c - real(r8) :: rhos_c_estimate, rhos_g_estimate - real(r8) :: dum1, dum2 - real(r8) :: max_elev_c ! the maximum column level elevation value within the grid - real(r8) :: delta_prc_c ! deviation of the column convective prec. from the grid level prec. - real(r8) :: delta_prl_c ! deviation of the column large-scale prec. from the grid level prec. - -!----------------------------------------------------------------------------- - - ! -------------------------------------------------------------------------------------- - ! 1. adjust air temperature, potential temperature, specific humidity, pressure, density - ! -------------------------------------------------------------------------------------- - hsurf_g = forc_topo_g ! gridcell sfc elevation - tbot_g = forc_t_g ! atm sfc temp - thbot_g = forc_th_g ! atm sfc pot temp - qbot_g = forc_q_g ! atm sfc spec humid - pbot_g = forc_pbot_g ! atm sfc pressure - rhos_g = forc_rho_g ! atm density - zbot = forc_hgt_g ! atm ref height - - hsurf_c = forc_topo_c ! column sfc elevation - tbot_c = tbot_g-lapse_rate*(hsurf_c-hsurf_g) ! adjust [temp] for column - Hbot = rair*0.5_r8*(tbot_g+tbot_c)/grav ! scale ht at avg temp - pbot_c = pbot_g*exp(-(hsurf_c-hsurf_g)/Hbot) ! adjust [press] for column - - ! Derivation of potential temperature calculation: - ! - ! The textbook definition would be: - ! thbot_c = tbot_c * (p0/pbot_c)^(rair/cpair) - ! - ! Note that pressure is related to scale height as: - ! pbot_c = p0 * exp(-zbot/Hbot) - ! - ! Plugging this in to the textbook definition, then manipulating, we get: - ! thbot_c = tbot_c * (p0/(p0*exp(-zbot/Hbot)))^(rair/cpair) - ! = tbot_c * (1/exp(-zbot/Hbot))^(rair/cpair) - ! = tbot_c * (exp(zbot/Hbot))^(rair/cpair) - ! = tbot_c * exp((zbot/Hbot) * (rair/cpair)) - - ! But we want everything expressed in delta form, resulting in: - ! adjust [pot temp] for column - thbot_c = thbot_g + (tbot_c - tbot_g)*exp((zbot/Hbot)*(rair/cpair)) - - CALL Qsadv(tbot_g,pbot_g,es_g,dum1,qs_g,dum2) ! es, qs for gridcell - CALL Qsadv(tbot_c,pbot_c,es_c,dum1,qs_c,dum2) ! es, qs for column - qbot_c = qbot_g*(qs_c/qs_g) ! adjust [q] for column - - rhos_c_estimate = rhos(qbot=qbot_c, pbot=pbot_c, tbot=tbot_c) - rhos_g_estimate = rhos(qbot=qbot_g, pbot=pbot_g, tbot=tbot_g) - rhos_c = rhos_g * (rhos_c_estimate / rhos_g_estimate) ! adjust [density] for column - - ! save - forc_t_c = tbot_c - forc_th_c = thbot_c - forc_q_c = qbot_c - forc_pbot_c = pbot_c - forc_rho_c = rhos_c - - ! -------------------------------------------------------------------------------------- - ! 2. adjust wind speed - ! -------------------------------------------------------------------------------------- - forc_us_c = forc_us_g - forc_vs_c = forc_vs_g - - ! -------------------------------------------------------------------------------------- - ! 3. adjust longwave radiation and shortwave radiation - ! -------------------------------------------------------------------------------------- - CALL downscale_longwave (glaciers, & - forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & - forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) - - ! Check if optional parameters are present for complex downscaling - IF (present(area_type_c) .and. present(svf_c) .and. present(alb) .and. & -#ifdef SinglePoint - present(sf_lut_c) & -#else - present(sf_curve_c) & -#endif - ) THEN - ! Complex downscaling with topographic effects - CALL downscale_shortwave(& - forc_topo_g, forc_pbot_g, forc_swrad_g, & - forc_topo_c, forc_pbot_c, forc_swrad_c, & - julian_day, coszen, cosazi, alb, & - slp_type_c, asp_type_c, svf_c, & -#ifdef SinglePoint - sf_lut_c, & -#else - sf_curve_c, & -#endif - area_type_c) - ELSE - ! Simple downscaling - CALL downscale_shortwave_simple(& - forc_topo_g, forc_pbot_g, forc_swrad_g, & - forc_topo_c, forc_pbot_c, forc_swrad_c, & - julian_day, coszen, cosazi, & - slp_type_c, asp_type_c) - ENDIF - - ! -------------------------------------------------------------------------------------- - ! 4. adjust precipitation - ! -------------------------------------------------------------------------------------- - IF (trim(DEF_DS_precipitation_adjust_scheme) == 'I') THEN - ! Tesfa et al, 2020: Exploring Topography-Based Methods for Downscaling - ! Subgrid Precipitation for Use in Earth System Models. Equation (5) - ! https://doi.org/ 10.1029/2019JD031456 - - IF (forc_maxelv_g /= 0.) THEN - delta_prc_c = forc_prc_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g - ELSE - delta_prc_c = 0. - ENDIF - forc_prc_c = forc_prc_g + delta_prc_c ! convective precipitation [mm/s] - IF (forc_prc_c<=0) forc_prc_c = forc_prc_g ! the limit value is non-negative - IF (forc_prc_c==0) forc_prc_c = 1.0e-10_r8 ! avoid denominator being 0 when conserving water quantity - - IF (forc_maxelv_g /= 0.) THEN - delta_prl_c = forc_prl_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g - ELSE - delta_prl_c = 0. - ENDIF - forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s] - IF (forc_prl_c<=0) forc_prl_c = forc_prl_g ! the limit value is non-negative - IF (forc_prl_c==0) forc_prl_c = 1.0e-10_r8 ! avoid denominator being 0 when conserving water quantity - - ELSEIF (trim(DEF_DS_precipitation_adjust_scheme) == 'II') THEN - ! Liston, G. E. and Elder, K.: A meteorological distribution system - ! for high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol., 7, 217-234, 2006. - ! Equation (33) and Table 1: chi range from January to December: - ! [0.35,0.35,0.35,0.30,0.25,0.20,0.20,0.20,0.20,0.25,0.30,0.35] (1/km) - - delta_prc_c = forc_prc_g *1.0*0.27*(forc_topo_c - forc_topo_g) & - /(1.0 - 0.27*(forc_topo_c - forc_topo_g)) - forc_prc_c = forc_prc_g + delta_prc_c ! large scale precipitation [mm/s] - - delta_prl_c = forc_prl_g *1.0*0.27*(forc_topo_c - forc_topo_g) & - /(1.0 - 0.27*(forc_topo_c - forc_topo_g)) - forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s] - ENDIF - - IF (forc_prl_c < 0) THEN - write(*,*) 'negative prl', forc_prl_g, forc_maxelv_g, forc_topo_c, forc_topo_g - forc_prl_c = 0. - ENDIF - - IF (forc_prc_c < 0) THEN - write(*,*) 'negative prc', forc_prc_g, forc_maxelv_g, forc_topo_c, forc_topo_g - forc_prc_c = 0. - ENDIF - - END SUBROUTINE downscale_forcings -!----------------------------------------------------------------------------- - - SUBROUTINE downscale_wind(forc_us_g, forc_vs_g, & - slp_type_c, asp_type_c, area_type_c, cur_c) - -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! Downscale wind speed -! -! Liston, G. E. and Elder, K.: A meteorological distribution system for -! high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol., -! 7, 217-234, 2006. -!----------------------------------------------------------------------------- - - IMPLICIT NONE - - ! ARGUMENTS: - real(r8), intent(inout) :: forc_us_g ! eastward wind (m/s) - real(r8), intent(inout) :: forc_vs_g ! northward wind (m/s) - - real(r8), intent(in) :: cur_c ! curvature - ! topographic aspect of each character of one patch - real(r8), intent(in) :: asp_type_c (1:num_slope_type) - ! topographic slope of each character of one patch - real(r8), intent(in) :: slp_type_c (1:num_slope_type) - ! area percentage of each character of one patch - real(r8), intent(in) :: area_type_c (1:num_slope_type) - - ! local variables - real(r8) :: wind_dir ! wind direction - real(r8) :: ws_g ! non-downscaled wind speed - real(r8) :: wind_dir_slp (1:num_slope_type) ! the slope in the direction of the wind - real(r8) :: ws_c_type(1:num_slope_type) ! downscaled wind speed of each type in each patch - real(r8) :: ws_c ! downscaled wind speed - real(r8) :: scale_factor ! Combined scaling factor for regulating wind speed - integer :: g, c, i - -!----------------------------------------------------------------------------- - - ! calculate wind direction - IF (forc_us_g == 0.) THEN - wind_dir = PI/2 - ELSE - wind_dir = atan(forc_vs_g /forc_us_g) - ENDIF - - ! non-adjusted wind speed - ws_g = sqrt(forc_vs_g *forc_vs_g +forc_us_g *forc_us_g ) - - ! compute the slope in the direction of the wind - DO i = 1, num_slope_type - wind_dir_slp(i) = slp_type_c(i)*cos(wind_dir-asp_type_c(i)) - ENDDO - - ! compute wind speed adjustment - DO i = 1, num_slope_type - scale_factor = (1+(0.58*wind_dir_slp(i))+0.42*cur_c) - ! Limiting the scope of proportionality adjustments - IF (scale_factor>1.5) THEN - scale_factor = 1.5 - ELSEIF (scale_factor<-1.5) THEN - scale_factor = -1.5 - ENDIF - ws_c_type(i) = ws_g *scale_factor*area_type_c(i) - ENDDO - - ! adjusted wind speed - ws_c = sum(ws_c_type(:)) - forc_us_g = ws_c*cos(wind_dir) - forc_vs_g = ws_c*sin(wind_dir) - - END SUBROUTINE downscale_wind - -!----------------------------------------------------------------------------- - - SUBROUTINE downscale_wind_simple(forc_us_g, forc_vs_g, & - slp_type_c, area_type_c, cur_c) - -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! Downscale wind speed using a simple method for land-atmosphere coupling models -!----------------------------------------------------------------------------- - - IMPLICIT NONE - - ! ARGUMENTS: - real(r8), intent(inout) :: forc_us_g ! eastward wind (m/s) - real(r8), intent(inout) :: forc_vs_g ! northward wind (m/s) - - real(r8), intent(in) :: cur_c ! curvature - ! topographic slope of each character of one patch - real(r8), intent(in) :: slp_type_c (1:num_aspect_type) - ! area percentage of each character of one patch - real(r8), intent(in) :: area_type_c (1:num_aspect_type) - - ! local variables - real(r8) :: asp_type_c(1:num_aspect_type) ! topographic aspect of each type of one patch (rad) - real(r8) :: slp_type_c_rad ! Convert tan slope value to slope angle value - - real(r8) :: wind_dir ! wind direction - real(r8) :: ws_g ! non-downscaled wind speed - real(r8) :: wind_dir_slp (1:num_aspect_type) ! the slope in the direction of the wind - real(r8) :: ws_c_type(1:num_aspect_type) ! downscaled wind speed of each type in each patch - real(r8) :: ws_c ! downscaled wind speed - real(r8) :: scale_factor ! Combined scaling factor for regulating wind speed - integer :: u_sign, v_sign, i, wind_dir_u, wind_dir_v - - ! Initialize aspect type - asp_type_c(1) = 0.0_r8*PI/180 ! north - asp_type_c(2) = 45.0_r8*PI/180 ! northeast - asp_type_c(3) = 90.0_r8*PI/180 ! east - asp_type_c(4) = 135.0_r8*PI/180 ! southeast - asp_type_c(5) = 180.0_r8*PI/180 ! south - asp_type_c(6) = 225.0_r8*PI/180 ! southwest - asp_type_c(7) = 270.0_r8*PI/180 ! west - asp_type_c(8) = 315.0_r8*PI/180 ! northwest - asp_type_c(9) = -9999.0_r8 ! flat -!----------------------------------------------------------------------------- - - ! calculate wind direction - IF (forc_us_g == 0.) THEN - wind_dir = PI/2 - ELSE - wind_dir = atan2(forc_vs_g, forc_us_g) - ENDIF - - ! convert to 0-2*PI range - !wind_dir = wind_dir + 3*PI/2 - !wind_dir = mod(wind_dir, 2*PI) - - ! 0° is north - IF (wind_dir > PI/2) THEN - wind_dir = 2*PI - wind_dir + PI/2 - ELSE - wind_dir = PI/2 - wind_dir - ENDIF - - ! non-adjusted wind speed - ws_g = sqrt(forc_vs_g *forc_vs_g +forc_us_g *forc_us_g ) - - ! log the + - sign of the u,v direction - IF (forc_us_g >= 0.0_r8) THEN - u_sign = 1 - ELSE - u_sign = -1 - ENDIF - IF (forc_vs_g >= 0.0_r8) THEN - v_sign = 1 - ELSE - v_sign = -1 - ENDIF - - - ! compute the slope in the direction of the wind - DO i = 1, num_aspect_type - IF (slp_type_c(i) == -1.0e36) THEN - ! no slope in the direction of the aspect - wind_dir_slp(i) = -1.0e36 - ELSE - ! slope in the direction of the wind - slp_type_c_rad = atan(slp_type_c(i)) - wind_dir_slp(i) = slp_type_c_rad*cos(wind_dir-asp_type_c(i)) - ENDIF - ENDDO - - ! compute wind speed adjustment - DO i = 1, num_aspect_type - ! For the flat area, we do not adjust the wind speed - IF (asp_type_c(i) == -9999.0_r8) THEN - scale_factor = 1.0_r8 - ELSE IF ((wind_dir_slp(i) == -1.0e36).or.(cur_c == -1.0e36)) THEN - ! no slope in the direction of the aspect - scale_factor = -1.0e36 - ELSE - scale_factor = (1+(0.58*wind_dir_slp(i))+0.42*cur_c) - !write(*,*) 'scale_factor', scale_factor, 'wind_dir_slp(i)', wind_dir_slp(i), 'cur_c', cur_c - ENDIF - - ! Limiting the scope of proportionality adjustments - IF (scale_factor>1.5) THEN - scale_factor = 1.5 - ELSEIF (scale_factor<-1.5) THEN - scale_factor = -1.5 - ENDIF - - ! Downscale wind speed for each type in each patch - IF ((scale_factor == -1.0e36).or.(area_type_c(i) == -1.0e36)) THEN - ws_c_type(i) = -1.0e36 - ELSE - ws_c_type(i) = ws_g *scale_factor*area_type_c(i) - ENDIF - - ENDDO - - ! adjusted wind speed - ws_c = sum(ws_c_type(:),mask=ws_c_type(:) /= -1.0e36) - - ! caculate u and v components of the wind - IF (wind_dir > PI/2) THEN - wind_dir = 2*PI - wind_dir + PI/2 - ELSE - wind_dir = PI/2 - wind_dir - ENDIF - - forc_us_g = u_sign*sqrt((ws_c*cos(wind_dir))**2) - forc_vs_g = v_sign*sqrt((ws_c*sin(wind_dir))**2) - - END SUBROUTINE downscale_wind_simple -!----------------------------------------------------------------------------- - - SUBROUTINE downscale_longwave (glaciers, & - forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, & - forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c) - -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! Downscale longwave radiation -!----------------------------------------------------------------------------- - - IMPLICIT NONE - - ! ARGUMENTS: - logical, intent(in) :: glaciers ! true: glacier column - - real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) - real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin] - real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg] - real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] - real(r8), intent(in) :: forc_lwrad_g ! downward longwave (W/m**2) - - real(r8), intent(in) :: forc_topo_c ! column surface height (m) - real(r8), intent(in) :: forc_t_c ! atmospheric temperature [Kelvin] - real(r8), intent(in) :: forc_q_c ! atmospheric specific humidity [kg/kg] - real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] - real(r8), intent(out):: forc_lwrad_c ! downward longwave (W/m**2) - - ! LOCAL VARIABLES: - real(r8) :: hsurf_c ! column-level elevation (m) - real(r8) :: hsurf_g ! gridcell-level elevation (m) - - real(r8) :: pv_g ! the water vapor pressure at grid cell (hPa) - real(r8) :: pv_c ! the water vapor pressure at column (hPa) - real(r8) :: emissivity_clearsky_g ! clear-sky emissivity at grid cell - real(r8) :: emissivity_clearsky_c ! clear-sky emissivity at grid column - real(r8) :: emissivity_allsky_g ! all-sky emissivity at grid cell - real(r8) :: es_g, es_c, dum1, dum2, dum3 - - real(r8), parameter :: lapse_rate_longwave = 0.032_r8 ! longwave radiation lapse rate (W m-2 m-1) - ! relative limit for how much longwave downscaling can be done (unitless) - real(r8), parameter :: longwave_downscaling_limit = 0.5_r8 - -!-------------------------------------------------------------------------- - - ! Initialize (needs to be done for ALL active columns) - forc_lwrad_c = forc_lwrad_g - hsurf_g = forc_topo_g - hsurf_c = forc_topo_c - - IF (trim(DEF_DS_longwave_adjust_scheme) == 'I') THEN - ! Fiddes and Gruber, 2014, TopoSCALE v.1.0: downscaling gridded climate data in complex - ! terrain. Geosci. Model Dev., 7, 387-405. doi:10.5194/gmd-7-387-2014. Equation (1) (2) - ! (3); here, the empirical parameters x1 and x2 are different from Konzelmann et al. (1994) - ! where x1 = 0.443 and x2 = 8 (optimal for measurements on the Greenland ice sheet) - - CALL Qsadv(forc_t_g, forc_pbot_g, es_g,dum1,dum2,dum3) - CALL Qsadv(forc_t_c, forc_pbot_c, es_c,dum1,dum2,dum3) - pv_g = forc_q_g*es_g/100._r8 ! (hPa) - pv_c = forc_q_c*es_c/100._r8 ! (hPa) - - emissivity_clearsky_g = 0.23_r8 + 0.43_r8*(pv_g/forc_t_g)**(1._r8/5.7_r8) - emissivity_clearsky_c = 0.23_r8 + 0.43_r8*(pv_c/forc_t_c)**(1._r8/5.7_r8) - emissivity_allsky_g = forc_lwrad_g / (5.67e-8_r8*forc_t_g**4) - - forc_lwrad_c = & - (emissivity_clearsky_c + (emissivity_allsky_g - emissivity_clearsky_g)) & - * 5.67e-8_r8*forc_t_c**4 - ELSE - ! Longwave radiation is downscaled by assuming a linear decrease in downwelling longwave - ! radiation with increasing elevation (0.032 W m-2 m-1, limited to 0.5 - 1.5 times the - ! gridcell mean value, then normalized to conserve gridcell total energy) (Van Tricht et - ! al., 2016, TC) Figure 6, doi:10.5194/tc-10-2379-2016 - - IF (glaciers) THEN - forc_lwrad_c = forc_lwrad_g - lapse_rate_longwave * (hsurf_c-hsurf_g) - - ! Here we assume that deltaLW = (dLW/dT)*(dT/dz)*deltaz - ! We get dLW/dT = 4*eps*sigma*T^3 = 4*LW/T from the Stefan-Boltzmann law, - ! evaluated at the mean temp. We assume the same temperature lapse rate as above. - - ELSE - forc_lwrad_c = forc_lwrad_g & - - 4.0_r8 * forc_lwrad_g/(0.5_r8*(forc_t_c+forc_t_g)) & - * lapse_rate * (hsurf_c - hsurf_g) - ENDIF - ENDIF - - ! But ensure that we don't depart too far from the atmospheric forcing value: - ! negative values of lwrad are certainly bad, but small positive values might - ! also be bad. We can especially run into trouble due to the normalization: a - ! small lwrad value in one column can lead to a big normalization factor, - ! leading to huge lwrad values in other columns. - - forc_lwrad_c = min(forc_lwrad_c, forc_lwrad_g * (1._r8 + longwave_downscaling_limit)) - forc_lwrad_c = max(forc_lwrad_c, forc_lwrad_g * (1._r8 - longwave_downscaling_limit)) - - END SUBROUTINE downscale_longwave - -!----------------------------------------------------------------------------- - SUBROUTINE downscale_shortwave( & - forc_topo_g, forc_pbot_g, forc_swrad_g, & - forc_topo_c, forc_pbot_c, forc_swrad_c, & - julian_day, coszen, cosazi, alb, & - slp_type_c, asp_type_c, svf_c, & -#ifdef SinglePoint - sf_lut_c, & -#else - sf_curve_c, & -#endif - area_type_c) - -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Rouf, T., Mei, Y., Maggioni, V., Houser, P., & Noonan, M. (2020). A -! Physically Based Atmospheric Variables Downscaling Technique. Journal -! of Hydrometeorology, 21(1), 93-108. -! https://doi.org/10.1175/JHM-D-19-0109.1 -! -! Sisi Chen, Lu Li, Yongjiu Dai, et al. Exploring Topography -! Downscaling Methods for Hyper-Resolution Land Surface Modeling. -! Authorea. April 25, 2024. DOI: 10.22541/au.171403656.68476353/v1 -! -! Must be done after downscaling of surface pressure -!----------------------------------------------------------------------------- - - IMPLICIT NONE - - integer, parameter :: S = 1370 ! solar constant (W/m**2) - real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith - ! relative limit for how much shortwave downscaling can be done (unitless) - real(r8), parameter :: shortwave_downscaling_limit = 0.5_r8 - - ! ARGUMENTS: - real(r8), intent(in) :: julian_day ! day of year - real(r8), intent(in) :: coszen ! zenith angle at an hour - real(r8), intent(in) :: cosazi ! azimuth angle at an hour - real(r8), intent(in) :: alb ! blue sky albedo - - real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) - real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] - real(r8), intent(in) :: forc_swrad_g ! downward shortwave (W/m**2) - - real(r8), intent(in) :: forc_topo_c ! column surface height (m) - real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] - real(r8), intent(out):: forc_swrad_c ! downward shortwave (W/m**2) - - real(r8), intent(in) :: svf_c ! sky view factor -# ifdef SinglePoint - ! look up table of shadow mask of a patch - real(r8), intent(in) :: sf_lut_c (1:num_azimuth,1:num_zenith) -# else - ! curve of shadow mask of a patch - real(r8), intent(in) :: sf_curve_c (1:num_azimuth,1:num_zenith_parameter) -# endif - ! topographic aspect of each character of one patch (°) - real(r8), intent(in) :: asp_type_c (1:num_slope_type) - ! topographic slope of each character of one patch - real(r8), intent(in) :: slp_type_c (1:num_slope_type) - ! area percentage of each character of one patch - real(r8), intent(in) :: area_type_c(1:num_slope_type) - - ! LOCAL VARIABLES: - real(r8) :: zen_rad, zen_deg, azi_rad, azi_deg ! rad and deg of sun zenith and azimuth angle - integer :: idx_azi, idx_zen ! index used to cal shadow factor from - ! look up table - real(r8) :: sf_c ! shadow factor - real(r8) :: rt_R ! The ratio of the current distance between - ! the sun and the earth - real(r8) :: toa_swrad ! top of atmosphere shortwave radiation - real(r8) :: clr_idx ! atmospheric transparency - real(r8) :: diff_wgt ! diffuse weight - real(r8) :: k_c ! column broadband attenuation coefficient [Pa^-1] - real(r8) :: opt_factor ! optical length factor - real(r8) :: a_p - real(r8) :: svf, balb - - real(r8) :: diff_swrad_g, beam_swrad_g ! diffuse and beam radiation - real(r8) :: diff_swrad_c, beam_swrad_c, refl_swrad_c! downscaled diffuse, beam radiation - ! and reflect radiation - real(r8) :: beam_swrad_type (1:num_slope_type) ! beam radiation of one characterized patch - real(r8) :: refl_swrad_type (1:num_slope_type) ! refl. radiation of one characterized patch - real(r8) :: tcf_type (1:num_slope_type) ! terrain configure factor - real(r8) :: cosill_type (1:num_slope_type) ! illumination angle (cos) at defined types - - real(r8) :: zenith_segment, a1, a2 ! Segmented function segmentation - ! points (rad), parameter1, parameter2 - - integer :: i - -!----------------------------------------------------------------------------- - - ! calculate shadow factor according to sun zenith and azimuth angle - zen_rad = acos(coszen) - azi_rad = acos(cosazi) - azi_deg = azi_rad*180.0/PI ! turn deg - - idx_azi = INT(azi_deg*num_azimuth/360) - - IF (idx_azi==0) idx_azi = 1 - -#ifdef SinglePoint - zen_deg = zen_rad*180/PI ! turn deg - idx_zen = INT(zen_deg*num_zenith/90) - IF (idx_zen==0) idx_zen = 1 - !constrain the upper boundary of zenith angle to 90 deg - IF (idx_zen>num_zenith) idx_zen = num_zenith - - sf_c = sf_lut_c(idx_azi, idx_zen) -#else - ! Constructing a shadow factor function from zenith angle parameters - ! shadow factor = exp(-1*exp(a1*zenith+a2)) - zenith_segment = sf_curve_c(idx_azi, 1) ! Segmented function segmentation points (rad) - a1 = sf_curve_c(idx_azi, 2) ! parameter of function - a2 = sf_curve_c(idx_azi, 3) ! parameter of function - - IF (zen_rad <= zenith_segment) THEN - sf_c = 1. - ELSEIF (a1<=1e-10) THEN - sf_c = 1. - ELSE - sf_c = exp(-1*exp(min(a1*zen_rad+a2,3.5))) - ENDIF -#endif - - IF (sf_c<0) sf_c = 0 - IF (sf_c>1) sf_c = 1 - - ! calculate top-of-atmosphere incident shortwave radiation - rt_R = 1-0.01672*cos(0.9856*(julian_day-4)) - toa_swrad = S*(rt_R**2)*coszen - - ! calculate clearness index - IF (toa_swrad.eq.0) THEN - clr_idx = 0 - ELSE - clr_idx = forc_swrad_g/toa_swrad - ENDIF - IF (clr_idx>1) clr_idx = 1 - - ! calculate diffuse weight - ! Ruiz-Arias, J. A., Alsamamra, H., Tovar-Pescador, J., & Pozo-Vázquez, D. (2010). - ! Proposal of a regressive model for the hourly diffuse solar radiation under all sky - ! conditions. Energy Conversion and Management, 51(5), 881-893. - ! https://doi.org/10.1016/j.enconman.2009.11.024 - diff_wgt = 0.952-1.041*exp(-1*exp(min(2.3-4.702*clr_idx,3.5))) - IF (diff_wgt>1) diff_wgt = 1 - IF (diff_wgt<0) diff_wgt = 0 - - ! calculate diffuse and beam radiation - diff_swrad_g = forc_swrad_g*diff_wgt - beam_swrad_g = forc_swrad_g*(1-diff_wgt) - - ! calculate broadband attenuation coefficient [Pa^-1] - IF (clr_idx.le.0) THEN - k_c = 0 - ELSE - k_c = log(clr_idx)/forc_pbot_c - ENDIF - - ! calculate factor to account for the difference of optical path length - ! due to pressure difference - opt_factor = exp(k_c*(forc_pbot_g-forc_pbot_c)) - ! Control the boundary of optical path length - IF ((opt_factor>10000).or.(opt_factor<-10000)) opt_factor = 0 - - ! Adjust the zenith angle so that the range of zenith angles is less than 85° - IF (zen_rad>thr) zen_rad=thr - - ! loop for four defined types to downscale beam radiation - DO i = 1, num_slope_type - ! calculate the cosine of solar illumination angle, cos(θ), - ! ranging between −1 and 1, indicates if the sun is below or - ! above the local horizon (note that values lower than 0 are set to 0 indicate self shadow) - cosill_type(i) = cos(slp_type_c(i))+tan(zen_rad)*sin(slp_type_c(i))*cos(asp_type_c(i)) - IF (cosill_type(i)>1) cosill_type(i) = 1 - IF (cosill_type(i)<0) cosill_type(i) = 0 - - ! downscaling beam radiation - a_p = area_type_c(i) - IF (a_p.gt.1.0) a_p = 1 - IF (a_p.lt.0) a_p = 0 - beam_swrad_type(i) = sf_c*cosill_type(i)*opt_factor*a_p*beam_swrad_g - ENDDO - beam_swrad_c = sum(beam_swrad_type) - - ! downscaling diffuse radiation - svf = svf_c - IF (svf>1) svf = 1 - IF (svf<0) svf = 0 - diff_swrad_c = svf*diff_swrad_g - - ! downscaling reflected radiation - balb = alb - DO i = 1, num_slope_type - tcf_type(i) = (1+cos(slp_type_c(i)))/2-svf - IF (tcf_type(i)<0) tcf_type(i) = 0 - - IF (isnan_ud(alb)) THEN - refl_swrad_type(i) = -1.0e36 - ELSE - IF ((balb<0).or.(balb>1)) balb = 0 - refl_swrad_type(i) = balb*tcf_type(i)*(beam_swrad_c*coszen+(1-svf)*diff_swrad_c) - ENDIF - ENDDO - refl_swrad_c = sum(refl_swrad_type, mask = refl_swrad_type /= -1.0e36) - forc_swrad_c = beam_swrad_c+diff_swrad_c+refl_swrad_c - - ! But ensure that we don't depart too far from the atmospheric forcing value: - ! negative values of swrad are certainly bad, but small positive values might - ! also be bad. We can especially run into trouble due to the normalization: a - ! small swrad value in one column can lead to a big normalization factor, - ! leading to huge swrad values in other columns. - - forc_swrad_c = min(forc_swrad_c, & - forc_swrad_g * (1._r8 + shortwave_downscaling_limit)) - forc_swrad_c = max(forc_swrad_c, & - forc_swrad_g * (1._r8 - shortwave_downscaling_limit)) - ! Ensure that the denominator is not 0 during shortwave normalization - IF (forc_swrad_c==0.) forc_swrad_c = 0.0001 - - END SUBROUTINE downscale_shortwave - -!----------------------------------------------------------------------------- - SUBROUTINE downscale_shortwave_simple( & - forc_topo_g, forc_pbot_g, forc_swrad_g, & - forc_topo_c, forc_pbot_c, forc_swrad_c, & - julian_day, coszen, cosazi, & - slp_type_c, area_type_c) -!----------------------------------------------------------------------------- -! !DESCRIPTION: -! This subroutine performs a simple downscaling of shortwave radiation for -! land-atmosphere coupling models. The adjustments are only made for direct -! radiation without considering the impact of shadow factor. -! - IMPLICIT NONE - - integer, parameter :: S = 1370 ! solar constant (W/m**2) - real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith - ! relative limit for how much shortwave downscaling can be done (unitless) - real(r8), parameter :: shortwave_downscaling_limit = 0.2_r8 - - ! ARGUMENTS: - real(r8), intent(in) :: julian_day ! day of year - real(r8), intent(in) :: coszen ! zenith angle at an hour - real(r8), intent(in) :: cosazi ! azimuth angle at an hour - - real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m) - real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa] - real(r8), intent(in) :: forc_swrad_g ! downward shortwave (W/m**2) - - real(r8), intent(in) :: forc_topo_c ! column surface height (m) - real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa] - real(r8), intent(out):: forc_swrad_c ! downward shortwave (W/m**2) - - ! tan value of topographic slope of each direction of one patch - real(r8), intent(in) :: slp_type_c (1:num_aspect_type) - ! area percentage of each character of one patch - real(r8), intent(in) :: area_type_c(1:num_aspect_type) - - ! LOCAL VARIABLES: - - real(r8) :: asp_type_c (1:num_aspect_type) ! topographic aspect fraction of one patch (%100) num_aspect_type = 1:north, 2:northeast, 3:east, - ! 4:southeast, 5:south, 6:southwest, 7:west, 8:northwest, 9:flat - real(r8) :: slp_type_c_rad ! Convert tan slope value to slope angle value - - real(r8) :: zen_rad, azi_rad ! rad of sun zenith and azimuth angle - integer :: idx_azi, idx_zen ! index used to cal shadow factor from - ! look up table - real(r8) :: sf_c ! shadow factor - real(r8) :: rt_R ! The ratio of the current distance between - ! the sun and the earth - real(r8) :: toa_swrad ! top of atmosphere shortwave radiation - real(r8) :: clr_idx ! atmospheric transparency - real(r8) :: diff_wgt ! diffuse weight - real(r8) :: k_c ! column broadband attenuation coefficient [Pa^-1] - real(r8) :: opt_factor ! optical length factor - real(r8) :: a_p - real(r8) :: diff_swrad_g, beam_swrad_g ! diffuse and beam radiation - real(r8) :: diff_swrad_c, beam_swrad_c ! downscaled diffuse, beam radiation - - real(r8) :: beam_swrad_type (1:num_aspect_type) ! beam radiation of one characterized patch - real(r8) :: cosill_type (1:num_aspect_type) ! illumination angle (cos) at defined types - - integer :: i -!------------------------------------------------------------------------------ - - ! Initialize aspect type - asp_type_c(1) = 0.0_r8*PI/180 ! north - asp_type_c(2) = 45.0_r8*PI/180 ! northeast - asp_type_c(3) = 90.0_r8*PI/180 ! east - asp_type_c(4) = 135.0_r8*PI/180 ! southeast - asp_type_c(5) = 180.0_r8*PI/180 ! south - asp_type_c(6) = 225.0_r8*PI/180 ! southwest - asp_type_c(7) = 270.0_r8*PI/180 ! west - asp_type_c(8) = 315.0_r8*PI/180 ! northwest - asp_type_c(9) = -9999.0_r8 ! flat - - ! calculate shadow factor according to sun zenith and azimuth angle - zen_rad = acos(coszen) - azi_rad = acos(cosazi) - - ! calculate top-of-atmosphere incident shortwave radiation - rt_R = 1-0.01672*cos(0.9856*(julian_day-4)) - toa_swrad = S*(rt_R**2)*coszen - - ! calculate clearness index - IF (toa_swrad < 1.e-7) THEN - clr_idx = 0 - ELSE - clr_idx = forc_swrad_g/toa_swrad - ENDIF - IF (clr_idx>1) clr_idx = 1 - - ! calculate diffuse weight - ! Ruiz-Arias, J. A., Alsamamra, H., Tovar-Pescador, J., & Pozo-Vázquez, D. (2010). - ! Proposal of a regressive model for the hourly diffuse solar radiation under all sky - ! conditions. Energy Conversion and Management, 51(5), 881-893. - ! https://doi.org/10.1016/j.enconman.2009.11.024 - diff_wgt = 0.952-1.041*exp(-1*exp(min(2.3-4.702*clr_idx,3.5))) - IF (diff_wgt>1) diff_wgt = 1 - IF (diff_wgt<0) diff_wgt = 0 - - ! calculate diffuse and beam radiation - diff_swrad_g = forc_swrad_g*diff_wgt - beam_swrad_g = forc_swrad_g*(1-diff_wgt) - - ! calculate broadband attenuation coefficient [Pa^-1] - IF (clr_idx.le.0) THEN - k_c = 0 - ELSE - k_c = log(clr_idx)/forc_pbot_c - ENDIF - - ! calculate factor to account for the difference of optical path length - ! due to pressure difference - opt_factor = exp(k_c*(forc_pbot_g-forc_pbot_c)) - ! Control the boundary of optical path length - IF ((opt_factor>10000).or.(opt_factor<-10000)) opt_factor = 0 - - ! Adjust the zenith angle so that the range of zenith angles is less than 85° - IF (zen_rad>thr) zen_rad = thr - - ! loop for four defined types to downscale beam radiation - DO i = 1, num_aspect_type - ! calculate the cosine of solar illumination angle, cos(θ), - ! ranging between −1 and 1, indicates if the sun is below or - ! above the local horizon (note that values lower than 0 are set to 0 indicate self shadow) - IF (i == 9) THEN - ! flat area, no slope - cosill_type(i) = 1.0_r8 - ELSE - slp_type_c_rad = atan(slp_type_c(i)) - cosill_type(i) = cos(slp_type_c_rad)+tan(zen_rad)*sin(slp_type_c_rad)*cos(asp_type_c(i)) - ENDIF - - ! Ensure that the cosine of illumination angle is between 0 and 1 - IF (cosill_type(i)>1) cosill_type(i) = 1 - IF (cosill_type(i)<0) cosill_type(i) = 0 - - ! downscaling beam radiation - a_p = area_type_c(i) - IF (a_p.gt.1.0) a_p = 1 - IF (a_p.lt.0) a_p = 0 - beam_swrad_type(i) = cosill_type(i)*opt_factor*a_p*beam_swrad_g - ENDDO - beam_swrad_c = sum(beam_swrad_type) - - ! do not downscale diffuse radiation - diff_swrad_c = diff_swrad_g - - forc_swrad_c = beam_swrad_c+diff_swrad_c - - ! But ensure that we don't depart too far from the atmospheric forcing value: - ! negative values of swrad are certainly bad, but small positive values might - ! also be bad. We can especially run into trouble due to the normalization: a - ! small swrad value in one column can lead to a big normalization factor, - ! leading to huge swrad values in other columns. - - forc_swrad_c = min(forc_swrad_c, & - forc_swrad_g * (1._r8 + shortwave_downscaling_limit)) - forc_swrad_c = max(forc_swrad_c, & - forc_swrad_g * (1._r8 - shortwave_downscaling_limit)) - ! Ensure that the denominator is not 0 during shortwave normalization - IF (forc_swrad_c < 1.e-4) forc_swrad_c = 0.0001 - - END SUBROUTINE downscale_shortwave_simple - - - -END MODULE MOD_ForcingDownscaling diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 index 07f8a0894c..34e84dd24d 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 @@ -16,6 +16,7 @@ MODULE MOD_Glacier ! 01/2023, Hua Yuan: added snow layer absorption in GLACIER_TEMP() !----------------------------------------------------------------------- USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop IMPLICIT NONE SAVE @@ -325,7 +326,7 @@ SUBROUTINE GLACIER_TEMP (patchtype,lb ,nl_ice ,deltim ,& IF(abs(errore)>.2)THEN write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) - STOP + CALL CoLM_stop('GLACIER_TEMP energy balance violation.') ENDIF 100 format(10(f7.3)) #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 index bf41b8b68b..a2706532ec 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 @@ -72,7 +72,7 @@ SUBROUTINE GroundTemperature (patchtype,is_dry_lake,lb,nl_soil,deltim,& USE MOD_Namelist, only: DEF_USE_SNICAR, DEF_SPLIT_SOILSNOW USE MOD_PhaseChange USE MOD_SoilThermalParameters - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Utils IMPLICIT NONE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 deleted file mode 100644 index e60eeee954..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90 +++ /dev/null @@ -1,5033 +0,0 @@ -#include - -MODULE MOD_Hist - -!---------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Write out gridded model results to history files. -! -! Original version: Yongjiu Dai, September 15, 1999, 03/2014 -! -! !REVISIONS: -! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version -! -! TODO...(need complement) -!---------------------------------------------------------------------------- - - USE MOD_Vars_1DAccFluxes - USE MOD_Vars_Global, only: spval - USE MOD_NetCDFSerial - - USE MOD_HistGridded -#if (defined UNSTRUCTURED || defined CATCHMENT) - USE MOD_HistVector -#endif -#ifdef SinglePoint - USE MOD_HistSingle -#endif -#ifdef CatchLateralFlow - USE MOD_Catch_Hist -#endif -#ifdef GridRiverLakeFlow - USE MOD_Grid_RiverLakeHist -#endif -#ifdef EXTERNAL_LAKE - USE MOD_Lake_Hist -#endif - - PUBLIC :: hist_init - PUBLIC :: hist_out - PUBLIC :: hist_final - - character(len=10) :: HistForm ! 'Gridded', 'Vector', 'Single' - - character(len=256) :: file_last = 'null' - -!-------------------------------------------------------------------------- -CONTAINS - - SUBROUTINE hist_init (dir_hist, lulcc_call) - - IMPLICIT NONE - - character(len=*) , intent(in) :: dir_hist - logical, optional, intent(in) :: lulcc_call - - CALL allocate_acc_fluxes () - CALL FLUSH_acc_fluxes () - - HistForm = 'Gridded' -#if (defined UNSTRUCTURED || defined CATCHMENT) - IF (DEF_HISTORY_IN_VECTOR) THEN - HistForm = 'Vector' - ENDIF -#endif -#ifdef SinglePoint - HistForm = 'Single' -#endif - - IF (HistForm == 'Gridded') THEN - IF (present(lulcc_call)) THEN - CALL hist_gridded_init (dir_hist, lulcc_call) - ELSE - CALL hist_gridded_init (dir_hist) - ENDIF -#ifdef SinglePoint - ELSEIF (HistForm == 'Single') THEN - CALL hist_single_init () -#endif - ENDIF - -#ifdef CatchLateralFlow - CALL hist_basin_init () -#endif - -#ifdef GridRiverLakeFlow - CALL hist_grid_riverlake_init (HistForm) -#endif - - END SUBROUTINE hist_init - - - SUBROUTINE hist_final () - - IMPLICIT NONE - - CALL deallocate_acc_fluxes () - -#ifdef SinglePoint - CALL hist_single_final () -#endif - -#ifdef CatchLateralFlow - CALL hist_basin_final () -#endif - -#ifdef GridRiverLakeFlow - CALL hist_grid_riverlake_final () -#endif - - END SUBROUTINE hist_final - - - SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & - dir_hist, casename) - -!======================================================================= -! Original version: Yongjiu Dai, September 15, 1999, 03/2014 -!======================================================================= - - USE MOD_Precision - USE MOD_Namelist - USE MOD_TimeManager - USE MOD_SPMD_Task - USE MOD_Vars_1DAccFluxes, filter_dt_ => filter_dt - USE MOD_Vars_1DFluxes, only: nsensor - USE MOD_Vars_TimeVariables, only: wa, wat, wetwat, wdsrf - USE MOD_Block - USE MOD_DataType - USE MOD_LandPatch - USE MOD_SpatialMapping - USE MOD_Vars_TimeInvariants, only: patchtype, patchclass, patchmask -#ifdef URBAN_MODEL - USE MOD_LandUrban -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeInvariants, only: pftclass - USE MOD_LandPFT, only: patch_pft_s -#endif - USE MOD_Forcing, only: forcmask_pch -#ifdef DataAssimilation - USE MOD_DA_TWS, only: fslp_k_mon - USE MOD_Vars_Global - USE MOD_DA_Vars_TimeVariables - USE MOD_Const_Physical, only: denh2o -#endif - - IMPLICIT NONE - - integer, intent(in) :: idate(3) - real(r8), intent(in) :: deltim - type(timestamp), intent(in) :: itstamp - type(timestamp), intent(in) :: etstamp - type(timestamp), intent(in) :: ptstamp - - character(len=*), intent(in) :: dir_hist - character(len=*), intent(in) :: casename - - ! Local variables - logical :: lwrite - character(len=256) :: file_hist - integer :: itime_in_file - integer :: month, day - integer :: days_month(1:12) - character(len=10) :: cdate - - type(block_data_real8_2d) :: sumarea - type(block_data_real8_2d) :: sumarea_dt - type(block_data_real8_2d) :: sumarea_urb - type(block_data_real8_2d) :: sumarea_one - real(r8), allocatable :: vecacc (:) - real(r8), allocatable :: nac_one (:) - logical, allocatable :: filter (:) - logical, allocatable :: filter_dt (:) - -#ifdef CROP - type(block_data_real8_2d) :: sumarea_crop - type(block_data_real8_2d) :: sumarea_irrig - logical, allocatable :: filter_crop (:) - logical, allocatable :: filter_irrig (:) -#endif - - integer i, u -#ifdef URBAN_MODEL - logical, allocatable :: filter_urb (:) -#endif - -#ifdef DataAssimilation - integer :: np - real(r8), allocatable :: a_wliq_h2osoi_5cm (:) - real(r8), allocatable :: a_t_soisno_5cm (:) - real(r8), allocatable :: a_wliq_soisno_ens_mean (:,:) - real(r8), allocatable :: a_wliq_soisno_5cm_ens (:,:) - real(r8), allocatable :: a_wliq_h2osoi_5cm_a (:) - real(r8), allocatable :: a_t_soisno_ens_mean (:,:) - real(r8), allocatable :: a_t_soisno_5cm_ens (:,:) - real(r8), allocatable :: a_t_soisno_5cm_a (:) - real(r8), allocatable :: a_t_brt_smap_a (:,:) - real(r8), allocatable :: a_t_brt_fy3d_a (:,:) - real(r8), allocatable :: a_wliq_soisno_5cm_ens_std (:) - real(r8), allocatable :: a_t_soisno_5cm_ens_std (:) - real(r8), allocatable :: a_t_brt_smap_ens_std (:,:) - real(r8), allocatable :: a_t_brt_fy3d_ens_std (:,:) -#endif - - IF (itstamp <= ptstamp) THEN - CALL FLUSH_acc_fluxes () - RETURN - ELSE - CALL accumulate_fluxes () - ENDIF - - select CASE (trim(adjustl(DEF_HIST_FREQ))) - CASE ('TIMESTEP') - lwrite = .true. - CASE ('HOURLY') - lwrite = isendofhour (idate, deltim) .or. (.not. (itstamp < etstamp)) - CASE ('DAILY') - lwrite = isendofday (idate, deltim) .or. (.not. (itstamp < etstamp)) - CASE ('MONTHLY') - lwrite = isendofmonth(idate, deltim) .or. (.not. (itstamp < etstamp)) - CASE ('YEARLY') - lwrite = isendofyear (idate, deltim) .or. (.not. (itstamp < etstamp)) - CASE default - lwrite = .false. - write(*,*) & - 'Warning : Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.' - write(*,*) & - ' Set to FALSE by default. ' - END select - - IF (lwrite) THEN - - CALL julian2monthday(idate(1), idate(2), month, day) - - days_month = (/31,28,31,30,31,30,31,31,30,31,30,31/) - IF (isleapyear(idate(1))) days_month(2) = 29 - - IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN - write(cdate,'(i4.4)') idate(1) -#ifdef SinglePoint - IF (USE_SITE_HistWriteBack) THEN - memory_to_disk = isendofyear(idate,deltim) .or. (.not. (itstamp < etstamp)) - ENDIF -#endif - ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN - write(cdate,'(i4.4,"-",i2.2)') idate(1), month -#ifdef SinglePoint - IF (USE_SITE_HistWriteBack) THEN - memory_to_disk = isendofmonth(idate,deltim) .or. (.not. (itstamp < etstamp)) - ENDIF -#endif - ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN - write(cdate,'(i4.4,"-",i2.2,"-",i2.2)') idate(1), month, day -#ifdef SinglePoint - IF (USE_SITE_HistWriteBack) THEN - memory_to_disk = isendofday(idate,deltim) .or. (.not. (itstamp < etstamp)) - ENDIF -#endif - ELSE - write(*,*) 'Warning : Please USE one of DAY/MONTH/YEAR for history group.' - ENDIF - - file_hist = trim(dir_hist) // '/' // trim(casename) //'_hist_'//trim(cdate)//'.nc' - - CALL hist_write_time (file_hist, file_last, 'time', idate, itime_in_file) - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - allocate (filter (numpatch)) - allocate (filter_dt (numpatch)) - allocate (vecacc (numpatch)) - ENDIF -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - allocate (filter_urb (numurban)) - ENDIF -#endif -#ifdef CROP - IF (numpatch > 0) THEN - allocate (filter_crop (numpatch)) - allocate (filter_irrig (numpatch)) - ENDIF -#endif - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (p_is_active) THEN - CALL allocate_block_data (ghist, sumarea) - CALL allocate_block_data (ghist, sumarea_dt) -#ifdef URBAN_MODEL - CALL allocate_block_data (ghist, sumarea_urb) -#endif -#ifdef CROP - CALL allocate_block_data (ghist, sumarea_crop) - CALL allocate_block_data (ghist, sumarea_irrig) -#endif - ENDIF - ENDIF - - ! --------------------------------------------------- - ! Meteorological forcing and patch mask filter applying. - ! --------------------------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype < 99 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - filter_dt = filter .and. patchmask .and. (nac_dt > 0) - - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - CALL mp2g_hist%get_sumarea (sumarea_dt, filter_dt) - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (trim(file_hist) /= trim(file_last)) THEN - CALL hist_write_var_real8_2d (file_hist, 'landarea', ghist, -1, sumarea, & - compress = 1, longname = 'land area', units = 'km2') - CALL hist_write_var_real8_2d (file_hist, 'landfraction', ghist, -1, landfraction, & - compress = 1, longname = 'land fraction', units = '-') - ENDIF - ENDIF - -#ifdef CROP - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - filter_crop(:) = patchtype < 99 - filter_crop(:) = patchclass == 12 - - IF (DEF_forcing%has_missing_value) THEN - filter_crop = filter_crop .and. forcmask_pch - ENDIF - - filter_crop = filter_crop .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea_crop, filter_crop) - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (trim(file_hist) /= trim(file_last)) THEN - CALL hist_write_var_real8_2d (file_hist, 'croparea', ghist, 1, sumarea_crop, & - compress = 1, longname = 'crop area', units = 'km2') - ENDIF - ENDIF - - IF (DEF_USE_IRRIGATION) THEN - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF((pftclass(patch_pft_s(i)).GE.npcropmin).and.(MOD(pftclass(patch_pft_s(i)),2).EQ.0))THEN - filter_irrig(i) = .true. - ELSE - filter_irrig(i) = .false. - ENDIF - ELSE - filter_irrig(i) = .false. - ENDIF - ENDDO - IF (DEF_forcing%has_missing_value) THEN - filter_irrig = filter_irrig .and. forcmask_pch - ENDIF - filter_irrig = filter_irrig .and. patchmask - ENDIF - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea_irrig, filter_irrig) - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (trim(file_hist) /= trim(file_last)) THEN - CALL hist_write_var_real8_2d (file_hist, 'irrigarea', ghist, 1, sumarea_irrig, & - compress = 1, longname = 'irrigation area', units = 'km2') - ENDIF - ENDIF -#endif - - ! wind in eastward direction [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%xy_us, & - a_us, file_hist, 'f_xy_us', itime_in_file, sumarea, filter, & - 'wind in eastward direction', 'm/s') - - ! wind in northward direction [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%xy_vs, & - a_vs, file_hist, 'f_xy_vs', itime_in_file, sumarea, filter, & - 'wind in northward direction','m/s') - - ! temperature at reference height [kelvin] - CALL write_history_variable_2d ( DEF_hist_vars%xy_t, & - a_t, file_hist, 'f_xy_t', itime_in_file, sumarea, filter, & - 'temperature at reference height','kelvin') - - ! specific humidity at reference height [kg/kg] - CALL write_history_variable_2d ( DEF_hist_vars%xy_q, & - a_q, file_hist, 'f_xy_q', itime_in_file, sumarea, filter, & - 'specific humidity at reference height','kg/kg') - - ! convective precipitation [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xy_prc, & - a_prc, file_hist, 'f_xy_prc', itime_in_file, sumarea, filter, & - 'convective precipitation','mm/s') - - ! large scale precipitation [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xy_prl, & - a_prl, file_hist, 'f_xy_prl', itime_in_file, sumarea, filter, & - 'large scale precipitation','mm/s') - - ! atmospheric pressure at the surface [pa] - CALL write_history_variable_2d ( DEF_hist_vars%xy_pbot, & - a_pbot, file_hist, 'f_xy_pbot', itime_in_file, sumarea, filter, & - 'atmospheric pressure at the surface','pa') - - ! atmospheric infrared (longwave) radiation [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%xy_frl, & - a_frl, file_hist, 'f_xy_frl', itime_in_file, sumarea, filter, & - 'atmospheric infrared (longwave) radiation','W/m2') - - ! downward solar radiation at surface [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%xy_solarin, & - a_solarin, file_hist, 'f_xy_solarin', itime_in_file, sumarea, filter, & - 'downward solar radiation at surface','W/m2') - - ! rain [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xy_rain, & - a_rain, file_hist, 'f_xy_rain', itime_in_file, sumarea, filter, & - 'rain','mm/s') - - ! snow [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xy_snow, & - a_snow, file_hist, 'f_xy_snow', itime_in_file, sumarea, filter, & - 'snow','mm/s') - - IF (DEF_USE_CBL_HEIGHT) THEN - ! atmospheric boundary layer height [m] - CALL write_history_variable_2d ( DEF_hist_vars%xy_hpbl, & - a_hpbl, file_hist, 'f_xy_hpbl', itime_in_file, sumarea, filter, & - 'boundary layer height','m') - ENDIF - - IF (DEF_USE_OZONESTRESS)THEN - CALL write_history_variable_2d ( DEF_hist_vars%o3uptakesun, & - a_o3uptakesun, file_hist, 'f_o3uptakesun', itime_in_file, sumarea, filter, & - 'Accumulated ozone uptake by sunlit leaf','mmol O3 m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%o3uptakesha, & - a_o3uptakesha, file_hist, 'f_o3uptakesha', itime_in_file, sumarea, filter, & - 'Accumulated ozone uptake by shaded leaf','mmol O3 m-2') - ENDIF - - ! ------------------------------------------------------------------------------------------ - ! Mapping the fluxes and state variables at patch [numpatch] to grid - ! ------------------------------------------------------------------ - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype < 99 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! wind stress: E-W [kg/m/s2] - CALL write_history_variable_2d ( DEF_hist_vars%taux, & - a_taux, file_hist, 'f_taux', itime_in_file, sumarea, filter, & - 'wind stress: E-W','kg/m/s2') - - ! wind stress: N-S [kg/m/s2] - CALL write_history_variable_2d ( DEF_hist_vars%tauy, & - a_tauy, file_hist, 'f_tauy', itime_in_file, sumarea, filter, & - 'wind stress: N-S','kg/m/s2') - - ! sensible heat from canopy height to atmosphere [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%fsena, & - a_fsena, file_hist, 'f_fsena', itime_in_file, sumarea, filter, & - 'sensible heat from canopy height to atmosphere','W/m2') - - ! latent heat flux from canopy height to atmosphere [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%lfevpa, & - a_lfevpa, file_hist, 'f_lfevpa', itime_in_file, sumarea, filter, & - 'latent heat flux from canopy height to atmosphere','W/m2') - - ! evapotranspiration from canopy to atmosphere [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%fevpa, & - a_fevpa, file_hist, 'f_fevpa', itime_in_file, sumarea, filter, & - 'evapotranspiration from canopy height to atmosphere','mm/s') - - ! sensible heat from leaves [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%fsenl, & - a_fsenl, file_hist, 'f_fsenl', itime_in_file, sumarea, filter, & - 'sensible heat from leaves','W/m2') - - ! evaporation+transpiration from leaves [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%fevpl, & - a_fevpl, file_hist, 'f_fevpl', itime_in_file, sumarea, filter, & - 'evaporation+transpiration from leaves','mm/s') - - ! transpiration rate [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%etr, & - a_etr, file_hist, 'f_etr', itime_in_file, sumarea, filter, & - 'transpiration rate','mm/s') - - ! sensible heat flux from ground [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%fseng, & - a_fseng, file_hist, 'f_fseng', itime_in_file, sumarea, filter, & - 'sensible heat flux from ground','W/m2') - - ! evaporation heat flux from ground [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%fevpg, & - a_fevpg, file_hist, 'f_fevpg', itime_in_file, sumarea, filter, & - 'evaporation flux from ground','mm/s') - - ! ground heat flux [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%fgrnd, & - a_fgrnd, file_hist, 'f_fgrnd', itime_in_file, sumarea, filter, & - 'ground heat flux','W/m2') - - ! solar absorbed by sunlit canopy [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%sabvsun, & - a_sabvsun, file_hist, 'f_sabvsun', itime_in_file, sumarea, filter, & - 'solar absorbed by sunlit canopy','W/m2') - - ! solar absorbed by shaded [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%sabvsha, & - a_sabvsha, file_hist, 'f_sabvsha', itime_in_file, sumarea, filter, & - 'solar absorbed by shaded','W/m2') - - ! solar absorbed by ground [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%sabg, & - a_sabg, file_hist, 'f_sabg', itime_in_file, sumarea, filter, & - 'solar absorbed by ground','W/m2') - - ! outgoing long-wave radiation from ground+canopy [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%olrg, & - a_olrg, file_hist, 'f_olrg', itime_in_file, sumarea, filter, & - 'outgoing long-wave radiation from ground+canopy','W/m2') - - ! net radiation [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%rnet, & - a_rnet, file_hist, 'f_rnet', itime_in_file, sumarea, filter, & - 'net radiation','W/m2') - - ! the error of water balance [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xerr, & - a_xerr, file_hist, 'f_xerr', itime_in_file, sumarea, filter, & - 'the error of water banace','mm/s') - - ! the error of energy balance [W/m2] - CALL write_history_variable_2d ( DEF_hist_vars%zerr, & - a_zerr, file_hist, 'f_zerr', itime_in_file, sumarea, filter, & - 'the error of energy balance','W/m2') - - ! surface runoff [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%rsur, & - a_rsur, file_hist, 'f_rsur', itime_in_file, sumarea, filter, & - 'surface runoff','mm/s') - -#ifndef CatchLateralFlow - ! saturation excess surface runoff [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%rsur_se, & - a_rsur_se, file_hist, 'f_rsur_se', itime_in_file, sumarea, filter, & - 'saturation excess surface runoff','mm/s') - - ! infiltration excess surface runoff [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%rsur_ie, & - a_rsur_ie, file_hist, 'f_rsur_ie', itime_in_file, sumarea, filter, & - 'infiltration excess surface runoff','mm/s') -#endif - - ! subsurface runoff [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%rsub, & - a_rsub, file_hist, 'f_rsub', itime_in_file, sumarea, filter, & - 'subsurface runoff','mm/s') - - ! total runoff [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%rnof, & - a_rnof, file_hist, 'f_rnof', itime_in_file, sumarea, filter, & - 'total runoff','mm/s') - -#ifdef DataAssimilation - IF (DEF_DA_TWS_GRACE) THEN - ! slope factors for runoff [-] - IF (p_is_compute .and. (numpatch > 0)) THEN - vecacc = fslp_k_mon(month, :) - WHERE (vecacc /= spval) vecacc = vecacc*nac - ENDIF - CALL write_history_variable_2d(.true., & - vecacc, file_hist, 'f_slope_factor_k', itime_in_file, sumarea, filter, & - 'slope factor [k] for runoff', '-') - ENDIF -#endif - -#ifdef CatchLateralFlow - ! rate of surface water depth change [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xwsur, & - a_xwsur, file_hist, 'f_xwsur', itime_in_file, sumarea, filter, & - 'rate of surface water depth change','mm/s') - - ! rate of ground water change [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%xwsub, & - a_xwsub, file_hist, 'f_xwsub', itime_in_file, sumarea, filter, & - 'rate of ground water change','mm/s') - - ! fraction of flooded area [-] - CALL write_history_variable_2d ( DEF_hist_vars%fldarea, & - a_fldarea, file_hist, 'f_fldarea', itime_in_file, sumarea, filter, & - 'fraction of flooded area','-') -#endif - - ! interception [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%qintr, & - a_qintr, file_hist, 'f_qintr', itime_in_file, sumarea, filter, & - 'interception','mm/s') - - ! infiltration [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%qinfl, & - a_qinfl, file_hist, 'f_qinfl', itime_in_file, sumarea, filter, & - 'f_qinfl','mm/s') - - ! throughfall [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%qdrip, & - a_qdrip, file_hist, 'f_qdrip', itime_in_file, sumarea, filter, & - 'total throughfall','mm/s') - - ! total water storage [mm] - CALL write_history_variable_2d ( DEF_hist_vars%wat, & - a_wat, file_hist, 'f_wat', itime_in_file, sumarea, filter, & - 'total water storage','mm') - - ! instantaneous total water storage [mm] - IF (p_is_compute .and. (numpatch > 0)) THEN - vecacc = wat - WHERE(vecacc /= spval) vecacc = vecacc * nac - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%wat_inst, & - vecacc, file_hist, 'f_wat_inst', itime_in_file, sumarea, filter, & - 'instantaneous total water storage','mm') - - ! canopy assimilation rate [mol m-2 s-1] - CALL write_history_variable_2d ( DEF_hist_vars%assim, & - a_assim, file_hist, 'f_assim', itime_in_file, sumarea, filter, & - 'canopy assimilation rate','mol m-2 s-1') - - ! respiration (plant+soil) [mol m-2 s-1] - CALL write_history_variable_2d ( DEF_hist_vars%respc, & - a_respc, file_hist, 'f_respc', itime_in_file, sumarea, filter, & - 'respiration (plant+soil)','mol m-2 s-1') - - ! groundwater recharge rate [mm/s] - CALL write_history_variable_2d ( DEF_hist_vars%qcharge & - .and. (.not.DEF_USE_VariablySaturatedFlow), & - a_qcharge, file_hist, 'f_qcharge', itime_in_file, sumarea, filter, & - 'groundwater recharge rate','mm/s') - - ! ground surface temperature [K] - CALL write_history_variable_2d ( DEF_hist_vars%t_grnd, & - a_t_grnd, file_hist, 'f_t_grnd', itime_in_file, sumarea, filter, & - 'ground surface temperature','K') - - ! leaf temperature [K] - CALL write_history_variable_2d ( DEF_hist_vars%tleaf, & - a_tleaf, file_hist, 'f_tleaf', itime_in_file, sumarea, filter, & - 'leaf temperature','K') - - ! depth of water on foliage [mm] - CALL write_history_variable_2d ( DEF_hist_vars%ldew, & - a_ldew, file_hist, 'f_ldew', itime_in_file, sumarea, filter, & - 'depth of water on foliage','mm') - - ! snow cover, water equivalent [mm] - CALL write_history_variable_2d ( DEF_hist_vars%scv, & - a_scv, file_hist, 'f_scv', itime_in_file, sumarea, filter, & - 'snow cover, water equivalent','mm') - - ! snow depth [meter] - CALL write_history_variable_2d ( DEF_hist_vars%snowdp, & - a_snowdp, file_hist, 'f_snowdp', itime_in_file, sumarea, filter, & - 'snow depth','meter') - - ! fraction of snow cover on ground - CALL write_history_variable_2d ( DEF_hist_vars%fsno, & - a_fsno, file_hist, 'f_fsno', itime_in_file, sumarea, filter, & - 'fraction of snow cover on ground','-') - - ! fraction of saturation area on ground - CALL write_history_variable_2d ( DEF_hist_vars%frcsat, & - a_frcsat, file_hist, 'f_frcsat', itime_in_file, sumarea, filter, & - 'fraction of saturation area on ground','-') - - ! fraction of veg cover, excluding snow-covered veg [-] - CALL write_history_variable_2d ( DEF_hist_vars%sigf, & - a_sigf, file_hist, 'f_sigf', itime_in_file, sumarea, filter, & - 'fraction of veg cover, excluding snow-covered veg','-') - - ! leaf greenness - CALL write_history_variable_2d ( DEF_hist_vars%green, & - a_green, file_hist, 'f_green', itime_in_file, sumarea, filter, & - 'leaf greenness','-') - - ! leaf area index - CALL write_history_variable_2d ( DEF_hist_vars%lai, & - a_lai, file_hist, 'f_lai', itime_in_file, sumarea, filter, & - 'leaf area index','m2/m2') - - ! leaf area index - CALL write_history_variable_2d ( DEF_hist_vars%laisun, & - a_laisun, file_hist, 'f_laisun', itime_in_file, sumarea, filter, & - 'sunlit leaf area index','m2/m2') - - ! leaf area index - CALL write_history_variable_2d ( DEF_hist_vars%laisha, & - a_laisha, file_hist, 'f_laisha', itime_in_file, sumarea, filter, & - 'shaded leaf area index','m2/m2') - - ! stem area index - CALL write_history_variable_2d ( DEF_hist_vars%sai, & - a_sai, file_hist, 'f_sai', itime_in_file, sumarea, filter, & - 'stem area index','m2/m2') - - ! averaged albedo [visible, direct; direct, diffuse] - CALL write_history_variable_4d ( DEF_hist_vars%alb, & - a_alb, file_hist, 'f_alb', itime_in_file, & - 'band', 1, 2, 'rtyp', 1, 2, sumarea_dt, filter_dt, & - 'averaged albedo','-',nac_dt) - - ! averaged bulk surface emissivity - CALL write_history_variable_2d ( DEF_hist_vars%emis, & - a_emis, file_hist, 'f_emis', itime_in_file, sumarea, filter, & - 'averaged bulk surface emissivity','-') - - ! effective roughness [m] - CALL write_history_variable_2d ( DEF_hist_vars%z0m, & - a_z0m, file_hist, 'f_z0m', itime_in_file, sumarea, filter, & - 'effective roughness','m') - - ! radiative temperature of surface [K] - CALL write_history_variable_2d ( DEF_hist_vars%trad, & - a_trad, file_hist, 'f_trad', itime_in_file, sumarea, filter, & - 'radiative temperature of surface','kelvin') - - ! 2 m height air temperature [kelvin] - CALL write_history_variable_2d ( DEF_hist_vars%tref, & - a_tref, file_hist, 'f_tref', itime_in_file, sumarea, filter, & - '2 m height air temperature','kelvin') - -IF (DEF_Output_2mWMO) THEN - ! 2 m WMO air temperature [kelvin] - CALL write_history_variable_2d ( DEF_hist_vars%t2m_wmo, & - a_t2m_wmo, file_hist, 'f_t2m_wmo', itime_in_file, sumarea, filter, & - '2 m WMO air temperature','kelvin') -ENDIF - - ! 2 m height air specific humidity [kg/kg] - CALL write_history_variable_2d ( DEF_hist_vars%qref, & - a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, & - '2 m height air specific humidity','kg/kg') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype == 2 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (trim(file_hist) /= trim(file_last)) THEN - CALL hist_write_var_real8_2d (file_hist, 'area_wetland', ghist, -1, sumarea, & - compress = 1, longname = 'area of wetland', units = 'km2') - ENDIF - ENDIF - - ! wetland water storage [mm] - IF (DEF_USE_Dynamic_Wetland) THEN - IF (p_is_compute .and. (numpatch > 0)) THEN - vecacc = a_wdsrf - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & - vecacc, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, & - 'wetland water storage','mm') - ELSE - CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & - a_wetwat, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, & - 'wetland water storage','mm') - ENDIF - - ! instantaneous wetland water storage [mm] - IF (p_is_compute .and. (numpatch > 0)) THEN - vecacc = wetwat - WHERE(vecacc /= spval) vecacc = vecacc * nac - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%wetwat_inst, & - vecacc, file_hist, 'f_wetwat_inst', itime_in_file, sumarea, filter, & - 'instantaneous wetland water storage','mm') - - IF (p_is_compute .and. (numpatch > 0)) THEN - vecacc = a_zwt - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%wetzwt, & - vecacc, file_hist, 'f_wetzwt', itime_in_file, sumarea, filter, & - 'the depth to water table in wetland','m') - - ! ------------------------------------------------------------------ - ! Mapping the urban variables at patch [numurban] to grid - ! ------------------------------------------------------------------ - -#ifdef URBAN_MODEL - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i = 1, numpatch - IF (patchtype(i) == 1) THEN - u = patch2urban(i) - - filter_urb(u) = .true. - - IF (DEF_forcing%has_missing_value) THEN - filter_urb(u) = filter_urb(u) .and. forcmask_pch(i) - ENDIF - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist_urb%get_sumarea (sumarea_urb, filter_urb) - ENDIF - - ! sensible heat from building roof [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_roof, & - a_senroof, file_hist, 'f_fsenroof', itime_in_file, sumarea_urb, filter_urb, & - 'sensible heat from urban roof [W/m2]','W/m2') - - ! sensible heat from building sunlit wall [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsun, & - a_senwsun, file_hist, 'f_fsenwsun', itime_in_file, sumarea_urb, filter_urb, & - 'sensible heat from urban sunlit wall [W/m2]','W/m2') - - ! sensible heat from building shaded wall [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsha, & - a_senwsha, file_hist, 'f_fsenwsha', itime_in_file, sumarea_urb, filter_urb, & - 'sensible heat from urban shaded wall [W/m2]','W/m2') - - ! sensible heat from impervious ground [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gimp, & - a_sengimp, file_hist, 'f_fsengimp', itime_in_file, sumarea_urb, filter_urb, & - 'sensible heat from urban impervious ground [W/m2]','W/m2') - - ! sensible heat from pervious ground [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gper, & - a_sengper, file_hist, 'f_fsengper', itime_in_file, sumarea_urb, filter_urb, & - 'sensible heat from urban pervious ground [W/m2]','W/m2') - - ! sensible heat from urban tree [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_urbl, & - a_senurbl, file_hist, 'f_fsenurbl', itime_in_file, sumarea_urb, filter_urb, & - 'sensible heat from urban tree [W/m2]','W/m2') - - ! latent heat flux from building roof [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_roof, & - a_lfevproof, file_hist, 'f_lfevproof', itime_in_file, sumarea_urb, filter_urb, & - 'latent heat from urban roof [W/m2]','W/m2') - - ! latent heat flux from impervious ground [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gimp, & - a_lfevpgimp, file_hist, 'f_lfevpgimp', itime_in_file, sumarea_urb, filter_urb, & - 'latent heat from urban impervious ground [W/m2]','W/m2') - - ! latent heat flux from pervious ground [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gper, & - a_lfevpgper, file_hist, 'f_lfevpgper', itime_in_file, sumarea_urb, filter_urb, & - 'latent heat from urban pervious ground [W/m2]','W/m2') - - ! latent heat flux from urban tree [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_urbl, & - a_lfevpurbl, file_hist, 'f_lfevpurbl', itime_in_file, sumarea_urb, filter_urb, & - 'latent heat from urban tree [W/m2]','W/m2') - - ! sensible flux from heat or cool AC [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fhac, & - a_fhac, file_hist, 'f_fhac', itime_in_file, sumarea_urb, filter_urb, & - 'sensible flux from heat or cool AC [W/m2]','W/m2') - - ! waste heat flux from heat or cool AC [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fwst, & - a_fwst, file_hist, 'f_fwst', itime_in_file, sumarea_urb, filter_urb, & - 'waste heat flux from heat or cool AC [W/m2]','W/m2') - - ! flux from inner and outer air exchange [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fach, & - a_fach, file_hist, 'f_fach', itime_in_file, sumarea_urb, filter_urb, & - 'flux from inner and outter air exchange [W/m2]','W/m2') - - ! flux from total heating/cooling [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%fhah, & - a_fhah, file_hist, 'f_fhah', itime_in_file, sumarea_urb, filter_urb, & - 'flux from heating/cooling [W/m2]','W/m2') - - ! flux from metabolism [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%meta, & - a_meta, file_hist, 'f_fmeta', itime_in_file, sumarea_urb, filter_urb, & - 'flux from human metabolism [W/m2]','W/m2') - - ! flux from vehicle [W/m2] - CALL write_history_variable_urb_2d ( DEF_hist_vars%vehc, & - a_vehc, file_hist, 'f_fvehc', itime_in_file, sumarea_urb, filter_urb, & - 'flux from traffic [W/m2]','W/m2') - - ! temperature of inner building [K] - CALL write_history_variable_urb_2d ( DEF_hist_vars%t_room, & - a_t_room, file_hist, 'f_t_room', itime_in_file, sumarea_urb, filter_urb, & - 'temperature of inner building [K]','kelvin') - - ! temperature of outer building [K] - CALL write_history_variable_urb_2d ( DEF_hist_vars%tafu, & - a_tafu, file_hist, 'f_tafu', itime_in_file, sumarea_urb, filter_urb, & - 'temperature of outer building [K]','kelvin') - - ! temperature of building roof [K] - CALL write_history_variable_urb_2d ( DEF_hist_vars%t_roof, & - a_troof, file_hist, 'f_t_roof', itime_in_file, sumarea_urb, filter_urb, & - 'temperature of urban roof [K]','kelvin') - - ! temperature of building wall [K] - CALL write_history_variable_urb_2d ( DEF_hist_vars%t_wall, & - a_twall, file_hist, 'f_t_wall', itime_in_file, sumarea_urb, filter_urb, & - 'temperature of urban wall [K]','kelvin') -#endif - - ! ------------------------------------------------------------------ - ! Mapping the fluxes and state variables at patch [numpatch] to grid - ! ------------------------------------------------------------------ - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - filter(:) = patchtype < 99 - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! 1: assimsun enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%assimsun, & - a_assimsun, file_hist, 'f_assimsun', itime_in_file, sumarea, filter, & - 'Photosynthetic assimilation rate of sunlit leaf for needleleaf evergreen temperate tree',& - 'mol m-2 s-1') - - ! 1: assimsha enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%assimsha, & - a_assimsha, file_hist, 'f_assimsha', itime_in_file, sumarea, filter, & - 'Photosynthetic assimilation rate of shaded leaf for needleleaf evergreen temperate tree',& - 'mol m-2 s-1') - - ! 1: etrsun enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%etrsun, & - a_etrsun, file_hist, 'f_etrsun', itime_in_file, sumarea, filter, & - 'Transpiration rate of sunlit leaf for needleleaf evergreen temperate tree','mm s-1') - - ! 1: etrsha enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%etrsha, & - a_etrsha, file_hist, 'f_etrsha', itime_in_file, sumarea, filter, & - 'Transpiration rate of shaded leaf for needleleaf evergreen temperate tree','mm s-1') - - ! rstfacsun - CALL write_history_variable_2d ( DEF_hist_vars%rstfacsun, & - a_rstfacsun, file_hist, 'f_rstfacsun', itime_in_file, sumarea, filter, & - 'Ecosystem level Water stress factor on sunlit canopy','unitless') - - ! rstfacsha - CALL write_history_variable_2d ( DEF_hist_vars%rstfacsha, & - a_rstfacsha, file_hist, 'f_rstfacsha', itime_in_file, sumarea, filter, & - 'Ecosystem level Water stress factor on shaded canopy','unitless') - - ! gssun - CALL write_history_variable_2d ( DEF_hist_vars%gssun, & - a_gssun, file_hist, 'f_gssun', itime_in_file, sumarea, filter, & - 'Ecosystem level canopy conductance on sunlit canopy','mol m-2 s-1') - - ! gssha - CALL write_history_variable_2d ( DEF_hist_vars%gssha, & - a_gssha, file_hist, 'f_gssha', itime_in_file, sumarea, filter, & - 'Ecosystem level canopy conductance on shaded canopy','mol m-2 s-1') - - ! soil resistance [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%rss, & - a_rss, file_hist, 'f_rss', itime_in_file, sumarea, filter, & - 'soil surface resistance','s/m') - -#ifdef BGC - ! leaf carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%leafc, & - a_leafc, file_hist, 'f_leafc', itime_in_file, sumarea, filter, & - 'leaf carbon display pool','gC/m2') - - ! leaf carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%leafc_storage, & - a_leafc_storage, file_hist, 'f_leafc_storage', itime_in_file, sumarea, filter, & - 'leaf carbon storage pool','gC/m2') - - ! leaf carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%leafc_xfer, & - a_leafc_xfer, file_hist, 'f_leafc_xfer', itime_in_file, sumarea, filter, & - 'leaf carbon transfer pool','gC/m2') - - ! fine root carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%frootc, & - a_frootc, file_hist, 'f_frootc', itime_in_file, sumarea, filter, & - 'fine root carbon display pool','gC/m2') - - ! fine root carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%frootc_storage, & - a_frootc_storage, file_hist, 'f_frootc_storage', itime_in_file, sumarea, filter, & - 'fine root carbon storage pool','gC/m2') - - ! fine root carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%frootc_xfer, & - a_frootc_xfer, file_hist, 'f_frootc_xfer', itime_in_file, sumarea, filter, & - 'fine root carbon transfer pool','gC/m2') - - ! live stem carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemc, & - a_livestemc, file_hist, 'f_livestemc', itime_in_file, sumarea, filter, & - 'live stem carbon display pool','gC/m2') - - ! live stem carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storage, & - a_livestemc_storage, file_hist, 'f_livestemc_storage', itime_in_file, sumarea, filter,& - 'live stem carbon storage pool','gC/m2') - - ! live stem carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xfer, & - a_livestemc_xfer, file_hist, 'f_livestemc_xfer', itime_in_file, sumarea, filter, & - 'live stem carbon transfer pool','gC/m2') - - ! dead stem carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemc, & - a_deadstemc, file_hist, 'f_deadstemc', itime_in_file, sumarea, filter, & - 'dead stem carbon display pool','gC/m2') - - ! dead stem carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storage, & - a_deadstemc_storage, file_hist, 'f_deadstemc_storage', itime_in_file, sumarea, filter,& - 'dead stem carbon storage pool','gC/m2') - - ! dead stem carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xfer, & - a_deadstemc_xfer, file_hist, 'f_deadstemc_xfer', itime_in_file, sumarea, filter, & - 'dead stem carbon transfer pool','gC/m2') - - ! live coarse root carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootc, & - a_livecrootc, file_hist, 'f_livecrootc', itime_in_file, sumarea, filter, & - 'live coarse root carbon display pool','gC/m2') - - ! live coarse root carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storage, & - a_livecrootc_storage, file_hist, 'f_livecrootc_storage', & - itime_in_file, sumarea, filter, & - 'live coarse root carbon storage pool','gC/m2') - - ! live coarse root carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xfer, & - a_livecrootc_xfer, file_hist, 'f_livecrootc_xfer', itime_in_file, sumarea, filter, & - 'live coarse root carbon transfer pool','gC/m2') - - ! dead coarse root carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc, & - a_deadcrootc, file_hist, 'f_deadcrootc', itime_in_file, sumarea, filter, & - 'dead coarse root carbon display pool','gC/m2') - - ! dead coarse root carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storage, & - a_deadcrootc_storage, file_hist, 'f_deadcrootc_storage', & - itime_in_file, sumarea, filter, & - 'dead coarse root carbon storage pool','gC/m2') - - ! dead coarse root carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xfer, & - a_deadcrootc_xfer, file_hist, 'f_deadcrootc_xfer', itime_in_file, sumarea, filter, & - 'dead coarse root carbon transfer pool','gC/m2') - -#ifdef CROP - ! grain carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%grainc, & - a_grainc, file_hist, 'f_grainc', itime_in_file, sumarea, filter, & - 'grain carbon display pool','gC/m2') - - ! grain carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%grainc_storage, & - a_grainc_storage, file_hist, 'f_grainc_storage', itime_in_file, sumarea, filter, & - 'grain carbon storage pool','gC/m2') - - ! grain carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%grainc_xfer, & - a_grainc_xfer, file_hist, 'f_grainc_xfer', itime_in_file, sumarea, filter, & - 'grain carbon transfer pool','gC/m2') -#endif - - ! leaf nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%leafn, & - a_leafn, file_hist, 'f_leafn', itime_in_file, sumarea, filter, & - 'leaf nitrogen display pool','gN/m2') - - ! leaf nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%leafn_storage, & - a_leafn_storage, file_hist, 'f_leafn_storage', itime_in_file, sumarea, filter, & - 'leaf nitrogen storage pool','gN/m2') - - ! leaf nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%leafn_xfer, & - a_leafn_xfer, file_hist, 'f_leafn_xfer', itime_in_file, sumarea, filter, & - 'leaf nitrogen transfer pool','gN/m2') - - ! fine root nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%frootn, & - a_frootn, file_hist, 'f_frootn', itime_in_file, sumarea, filter, & - 'fine root nitrogen display pool','gN/m2') - - ! fine root nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%frootn_storage, & - a_frootn_storage, file_hist, 'f_frootn_storage', itime_in_file, sumarea, filter, & - 'fine root nitrogen storage pool','gN/m2') - - ! fine root nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%frootn_xfer, & - a_frootn_xfer, file_hist, 'f_frootn_xfer', itime_in_file, sumarea, filter, & - 'fine root nitrogen transfer pool','gN/m2') - - ! live stem nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemn, & - a_livestemn, file_hist, 'f_livestemn', itime_in_file, sumarea, filter, & - 'live stem nitrogen display pool','gN/m2') - - ! live stem nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storage, & - a_livestemn_storage, file_hist, 'f_livestemn_storage', & - itime_in_file, sumarea, filter, & - 'live stem nitrogen storage pool','gN/m2') - - ! live stem nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xfer, & - a_livestemn_xfer, file_hist, 'f_livestemn_xfer', itime_in_file, sumarea, filter, & - 'live stem nitrogen transfer pool','gN/m2') - - ! dead stem nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemn, & - a_deadstemn, file_hist, 'f_deadstemn', itime_in_file, sumarea, filter, & - 'dead stem nitrogen display pool','gN/m2') - - ! dead stem nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storage, & - a_deadstemn_storage, file_hist, 'f_deadstemn_storage', & - itime_in_file, sumarea, filter, & - 'dead stem nitrogen storage pool','gN/m2') - - ! dead stem nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xfer, & - a_deadstemn_xfer, file_hist, 'f_deadstemn_xfer', itime_in_file, sumarea, filter, & - 'dead stem nitrogen transfer pool','gN/m2') - - ! live coarse root nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootn, & - a_livecrootn, file_hist, 'f_livecrootn', itime_in_file, sumarea, filter, & - 'live coarse root nitrogen display pool','gN/m2') - - ! live coarse root nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storage, & - a_livecrootn_storage, file_hist, 'f_livecrootn_storage', & - itime_in_file, sumarea, filter, & - 'live coarse root nitrogen storage pool','gN/m2') - - ! live coarse root nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xfer, & - a_livecrootn_xfer, file_hist, 'f_livecrootn_xfer', itime_in_file, sumarea, filter, & - 'live coarse root nitrogen transfer pool','gN/m2') - - ! dead coarse root nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn, & - a_deadcrootn, file_hist, 'f_deadcrootn', itime_in_file, sumarea, filter, & - 'dead coarse root nitrogen display pool','gN/m2') - - ! dead coarse root nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storage, & - a_deadcrootn_storage, file_hist, 'f_deadcrootn_storage', & - itime_in_file, sumarea, filter, & - 'dead coarse root nitrogen storage pool','gN/m2') - - ! dead coarse root nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xfer, & - a_deadcrootn_xfer, file_hist, 'f_deadcrootn_xfer', itime_in_file, sumarea, filter, & - 'dead coarse root nitrogen transfer pool','gN/m2') - -#ifdef CROP - ! grain nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%grainn, & - a_grainn, file_hist, 'f_grainn', itime_in_file, sumarea, filter, & - 'grain nitrogen display pool','gN/m2') - - ! grain nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%grainn_storage, & - a_grainn_storage, file_hist, 'f_grainn_storage', itime_in_file, sumarea, filter, & - 'grain nitrogen storage pool','gN/m2') - - ! grain nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%grainn_xfer, & - a_grainn_xfer, file_hist, 'f_grainn_xfer', itime_in_file, sumarea, filter, & - 'grain nitrogen transfer pool','gN/m2') -#endif - - ! retranslocation nitrogen pool - CALL write_history_variable_2d ( DEF_hist_vars%retrasn, & - a_retransn, file_hist, 'f_retrasn', itime_in_file, sumarea, filter, & - 'retranslocation nitrogen pool','gN/m2') - - ! gross primary productivity - CALL write_history_variable_2d ( DEF_hist_vars%gpp, & - a_gpp, file_hist, 'f_gpp', itime_in_file, sumarea, filter, & - 'gross primary productivity','gC/m2/s') - - ! gross primary productivity - CALL write_history_variable_2d ( DEF_hist_vars%downreg, & - a_downreg, file_hist, 'f_downreg', itime_in_file, sumarea, filter, & - 'gpp downregulation due to N limitation','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%fpg, & - a_fpg, file_hist, 'f_fpg', itime_in_file, sumarea, filter, & - 'fraction of gpp potential','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%fpi, & - a_fpi, file_hist, 'f_fpi', itime_in_file, sumarea, filter, & - 'fraction of immobalization','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%totvegc, & - a_totvegc, file_hist, 'f_totvegc', itime_in_file, sumarea, filter, & - 'total vegetation carbon','gC m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totlitc, & - a_totlitc, file_hist, 'f_totlitc', itime_in_file, sumarea, filter, & - 'total litter carbon','gC m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totsomc, & - a_totsomc, file_hist, 'f_totsomc', itime_in_file, sumarea, filter, & - 'total soil organic carbon','gC m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totcwdc, & - a_totcwdc, file_hist, 'f_totcwdc', itime_in_file, sumarea, filter, & - 'total coarse woody debris carbon','gC m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totcolc, & - a_totcolc, file_hist, 'f_totcolc', itime_in_file, sumarea, filter, & - 'total ecosystem carbon','gC m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totvegn, & - a_totvegn, file_hist, 'f_totvegn', itime_in_file, sumarea, filter, & - 'total vegetation nitrogen','gN m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totlitn, & - a_totlitn, file_hist, 'f_totlitn', itime_in_file, sumarea, filter, & - 'total litter nitrogen','gN m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totsomn, & - a_totsomn, file_hist, 'f_totsomn', itime_in_file, sumarea, filter, & - 'total soil organic nitrogen','gN m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totcwdn, & - a_totcwdn, file_hist, 'f_totcwdn', itime_in_file, sumarea, filter, & - 'total coarse woody debris nitrogen','gN m-2') - - CALL write_history_variable_2d ( DEF_hist_vars%totcoln, & - a_totcoln, file_hist, 'f_totcoln', itime_in_file, sumarea, filter, & - 'total ecosystem nitrogen','gN m-2') - - ! autotrophic respiration - CALL write_history_variable_2d ( DEF_hist_vars%ar , & - a_ar, file_hist, 'f_ar', itime_in_file, sumarea, filter, & - 'autotrophic respiration','gC/m2/s') - -! ! CWD production -! CALL write_history_variable_2d ( DEF_hist_vars%cwdprod , & -! a_cwdprod, file_hist, 'f_cwdprod', itime_in_file, sumarea, filter, & -! 'CWD production','gC/m2/s') -! -! ! CWD decomposition -! CALL write_history_variable_2d ( DEF_hist_vars%cwddecomp , & -! a_cwddecomp, file_hist, 'f_cwddecomp', itime_in_file, sumarea, filter, & -! 'CWD decomposition','gC/m2/s') - - ! heterotrophic respiration - CALL write_history_variable_2d ( DEF_hist_vars%hr , & - a_hr, file_hist, 'f_hr', itime_in_file, sumarea, filter, & - 'heterotrophic respiration','gC/m2/s') - -#ifdef CROP - ! crop phase - CALL write_history_variable_2d ( DEF_hist_vars%cphase, & - a_cphase, file_hist, 'f_cphase', itime_in_file, sumarea, filter, & - 'crop phase','unitless') - - ! heat unit index - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_hui (:) - ENDIF - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%hui, & - vecacc, file_hist, 'f_hui', itime_in_file, sumarea, filter, & - 'heat unit index','unitless') - - ! gdd needed to harvest - CALL write_history_variable_2d ( DEF_hist_vars%gddmaturity, & - a_gddmaturity, file_hist, 'f_gddmaturity', itime_in_file, sumarea, filter, & - 'gdd needed to harvest','ddays') - - ! gdd past planting date for crop - CALL write_history_variable_2d ( DEF_hist_vars%gddplant, & - a_gddplant, file_hist, 'f_gddplant', itime_in_file, sumarea, filter, & - 'gdd past planting date for crop','ddays') - - ! vernalization response - CALL write_history_variable_2d ( DEF_hist_vars%vf, & - a_vf, file_hist, 'f_vf', itime_in_file, sumarea, filter, & - 'vernalization response', 'unitless') - - ! 1-yr crop production carbon - CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c, & - a_cropprod1c, file_hist, 'f_cropprod1c', itime_in_file, sumarea, filter, & - '1-yr crop production carbon','gC/m2') - - ! loss rate of 1-yr crop production carbon - CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c_loss, & - a_cropprod1c_loss, file_hist, 'f_cropprod1c_loss', itime_in_file, sumarea, filter, & - 'loss rate of 1-yr crop production carbon','gC/m2/s') - - ! crop seed deficit - CALL write_history_variable_2d ( DEF_hist_vars%cropseedc_deficit, & - a_cropseedc_deficit, file_hist, 'f_cropseedc_deficit', & - itime_in_file, sumarea, filter, & - 'crop seed deficit','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - ! grain to crop production carbon - CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_cropprodc, & - vecacc, file_hist, 'f_grainc_to_cropprodc', itime_in_file, sumarea, filter, & - 'grain to crop production carbon','gC/m2/s') - - ! grain to crop seed carbon - CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_seed, & - a_grainc_to_seed, file_hist, 'f_grainc_to_seed', itime_in_file, sumarea, filter, & - 'grain to crop seed carbon','gC/m2/s') - ! grain to crop seed carbon - CALL write_history_variable_2d ( DEF_hist_vars%fert_to_sminn, & - a_fert_to_sminn, file_hist, 'f_fert_to_sminn', itime_in_file, sumarea, filter, & - 'fertilization','gN/m2/s') - - IF (DEF_USE_IRRIGATION) THEN - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF((pftclass(patch_pft_s(i)).GE.npcropmin).and.(MOD(pftclass(patch_pft_s(i)),2).EQ.0))THEN - filter_irrig(i) = .true. - ELSE - filter_irrig(i) = .false. - ENDIF - ELSE - filter_irrig(i) = .false. - ENDIF - ENDDO - IF (DEF_forcing%has_missing_value) THEN - filter_irrig = filter_irrig .and. forcmask_pch - ENDIF - filter_irrig = filter_irrig .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea_irrig, filter_irrig) - ENDIF - - ! total irrigation amounts at growing season - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_sum_irrig (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig, & - vecacc, file_hist, 'f_sum_irrig', itime_in_file, sumarea_irrig, filter_irrig, & - 'total irrigation amounts at growing season','kg/m2') - - ! total irrigation amounts demand at growing season - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_sum_deficit_irrig (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%sum_deficit_irrig, & - vecacc, file_hist, 'f_sum_deficit_irrig', itime_in_file, sumarea_irrig, filter_irrig, & - 'total irrigation amounts demand at growing season','kg/m2') - - ! total irrigation times at growing season - CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, & - a_sum_irrig_count, file_hist, 'f_sum_irrig_count', itime_in_file, sumarea_irrig, filter_irrig, & - 'total irrigation times at growing season','-') - - ! irrigation waterstorage [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_waterstorage (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%waterstorage, & - vecacc, file_hist, 'f_waterstorage', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation waterstorage','kg/m2') - - ! irrigation demand for ground water [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_groundwater_demand (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%groundwater_demand, & - vecacc, file_hist, 'f_groundwater_demand', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation demand for ground water','kg/m2') - - ! irrigation supply from ground water [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_groundwater_supply (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%groundwater_supply, & - vecacc, file_hist, 'f_groundwater_supply', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation supply from ground water','kg/m2') - - ! irrigation demand for reservoir or river [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_reservoirriver_demand (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_demand, & - vecacc, file_hist, 'f_reservoirriver_demand', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation demand for reservoir or river','kg/m2') - - ! irrigation supply from reservoir or river [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_reservoirriver_supply (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & - vecacc, file_hist, 'f_reservoirriver_supply', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation supply from reservoir or river','kg/m2') - - ! irrigation supply from reservoir [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_reservoir_supply (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & - vecacc, file_hist, 'f_reservoir_supply', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation supply from reservoir','kg/m2') - - ! irrigation supply from river [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_river_supply (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & - vecacc, file_hist, 'f_river_supply', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation supply from river','kg/m2') - - ! irrigation supply from runoff [kg/m2] - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_runoff_supply (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, & - vecacc, file_hist, 'f_runoff_supply', itime_in_file, sumarea_irrig, filter_irrig, & - 'irrigation supply from runoff','kg/m2') - ENDIF -#endif - - ! grain to crop seed carbon - CALL write_history_variable_2d ( DEF_hist_vars%ndep_to_sminn, & - a_ndep_to_sminn, file_hist, 'f_ndep_to_sminn', itime_in_file, sumarea, filter, & - 'nitrogen deposition','gN/m2/s') - - IF(DEF_USE_DiagMatrix)THEN - ! leaf carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%leafcCap, & - a_leafcCap, file_hist, 'f_leafcCap', itime_in_file, sumarea, filter, & - 'leaf carbon display pool Capacity','gC/m2') - - ! leaf carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%leafc_storageCap, & - a_leafc_storageCap, file_hist, 'f_leafc_storageCap', & - itime_in_file, sumarea, filter, & - 'leaf carbon storage pool capacity','gC/m2') - - ! leaf carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%leafc_xferCap, & - a_leafc_xferCap, file_hist, 'f_leafc_xferCap', itime_in_file, sumarea, filter, & - 'leaf carbon transfer pool capacity','gC/m2') - - ! fine root carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%frootcCap, & - a_frootcCap, file_hist, 'f_frootcCap', itime_in_file, sumarea, filter, & - 'fine root carbon display pool Capacity','gC/m2') - - ! fine root carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%frootc_storageCap, & - a_frootc_storageCap, file_hist, 'f_frootc_storageCap', & - itime_in_file, sumarea, filter, & - 'fine root carbon storage pool capacity','gC/m2') - - ! fine root carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%frootc_xferCap, & - a_frootc_xferCap, file_hist, 'f_frootc_xferCap', itime_in_file, sumarea, filter, & - 'fine root carbon transfer pool capacity','gC/m2') - - ! live stem carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemcCap, & - a_livestemcCap, file_hist, 'f_livestemcCap', itime_in_file, sumarea, filter, & - 'live stem carbon display pool Capacity','gC/m2') - - ! live stem carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storageCap, & - a_livestemc_storageCap, file_hist, 'f_livestemc_storageCap', & - itime_in_file, sumarea, filter, & - 'live stem carbon storage pool capacity','gC/m2') - - ! live stem carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xferCap, & - a_livestemc_xferCap, file_hist, 'f_livestemc_xferCap', & - itime_in_file, sumarea, filter, & - 'live stem carbon transfer pool capacity','gC/m2') - - ! dead stem carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemcCap, & - a_deadstemcCap, file_hist, 'f_deadstemcCap', itime_in_file, sumarea, filter, & - 'dead stem carbon display pool Capacity','gC/m2') - - ! dead stem carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storageCap, & - a_deadstemc_storageCap, file_hist, 'f_deadstemc_storageCap', & - itime_in_file, sumarea, filter, & - 'dead stem carbon storage pool capacity','gC/m2') - - ! dead stem carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xferCap, & - a_deadstemc_xferCap, file_hist, 'f_deadstemc_xferCap', & - itime_in_file, sumarea, filter, & - 'dead stem carbon transfer pool capacity','gC/m2') - - ! live coarse root carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootcCap, & - a_livecrootcCap, file_hist, 'f_livecrootcCap', itime_in_file, sumarea, filter, & - 'live coarse root carbon display pool Capacity','gC/m2') - - ! live coarse root carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storageCap, & - a_livecrootc_storageCap, file_hist, 'f_livecrootc_storageCap', & - itime_in_file, sumarea, filter, & - 'live coarse root carbon storage pool capacity','gC/m2') - - ! live coarse root carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xferCap, & - a_livecrootc_xferCap, file_hist, 'f_livecrootc_xferCap', & - itime_in_file, sumarea, filter, & - 'live coarse root carbon transfer pool capacity','gC/m2') - - ! dead coarse root carbon display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootcCap, & - a_deadcrootcCap, file_hist, 'f_deadcrootcCap', itime_in_file, sumarea, filter, & - 'dead coarse root carbon display pool Capacity','gC/m2') - - ! dead coarse root carbon storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storageCap, & - a_deadcrootc_storageCap, file_hist, 'f_deadcrootc_storageCap', & - itime_in_file, sumarea, filter, & - 'dead coarse root carbon storage pool capacity','gC/m2') - - ! dead coarse root carbon transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xferCap, & - a_deadcrootc_xferCap, file_hist, 'f_deadcrootc_xferCap', & - itime_in_file, sumarea, filter, & - 'dead coarse root carbon transfer pool capacity','gC/m2') - - ! leaf nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%leafnCap, & - a_leafnCap, file_hist, 'f_leafnCap', itime_in_file, sumarea, filter, & - 'leaf nitrogen display pool Capacity','gC/m2') - - ! leaf nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%leafn_storageCap, & - a_leafn_storageCap, file_hist, 'f_leafn_storageCap', & - itime_in_file, sumarea, filter, & - 'leaf nitrogen storage pool capacity','gC/m2') - - ! leaf nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%leafn_xferCap, & - a_leafn_xferCap, file_hist, 'f_leafn_xferCap', itime_in_file, sumarea, filter, & - 'leaf nitrogen transfer pool capacity','gC/m2') - - ! fine root nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%frootnCap, & - a_frootnCap, file_hist, 'f_frootnCap', itime_in_file, sumarea, filter, & - 'fine root nitrogen display pool Capacity','gC/m2') - - ! fine root nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%frootn_storageCap, & - a_frootn_storageCap, file_hist, 'f_frootn_storageCap', & - itime_in_file, sumarea, filter, & - 'fine root nitrogen storage pool capacity','gC/m2') - - ! fine root nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%frootn_xferCap, & - a_frootn_xferCap, file_hist, 'f_frootn_xferCap', itime_in_file, sumarea, filter, & - 'fine root nitrogen transfer pool capacity','gC/m2') - - ! live stem nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemnCap, & - a_livestemnCap, file_hist, 'f_livestemnCap', itime_in_file, sumarea, filter, & - 'live stem nitrogen display pool Capacity','gC/m2') - - ! live stem nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storageCap, & - a_livestemn_storageCap, file_hist, 'f_livestemn_storageCap', & - itime_in_file, sumarea, filter, & - 'live stem nitrogen storage pool capacity','gC/m2') - - ! live stem nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xferCap, & - a_livestemn_xferCap, file_hist, 'f_livestemn_xferCap', & - itime_in_file, sumarea, filter, & - 'live stem nitrogen transfer pool capacity','gC/m2') - - ! dead stem nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemnCap, & - a_deadstemnCap, file_hist, 'f_deadstemnCap', itime_in_file, sumarea, filter, & - 'dead stem nitrogen display pool Capacity','gC/m2') - - ! dead stem nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storageCap, & - a_deadstemn_storageCap, file_hist, 'f_deadstemn_storageCap', & - itime_in_file, sumarea, filter, & - 'dead stem nitrogen storage pool capacity','gC/m2') - - ! dead stem nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xferCap, & - a_deadstemn_xferCap, file_hist, 'f_deadstemn_xferCap', & - itime_in_file, sumarea, filter, & - 'dead stem nitrogen transfer pool capacity','gC/m2') - - ! live coarse root nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootnCap, & - a_livecrootnCap, file_hist, 'f_livecrootnCap', itime_in_file, sumarea, filter, & - 'live coarse root nitrogen display pool Capacity','gC/m2') - - ! live coarse root nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storageCap, & - a_livecrootn_storageCap, file_hist, 'f_livecrootn_storageCap', & - itime_in_file, sumarea, filter, & - 'live coarse root nitrogen storage pool capacity','gC/m2') - - ! live coarse root nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xferCap, & - a_livecrootn_xferCap, file_hist, 'f_livecrootn_xferCap', & - itime_in_file, sumarea, filter, & - 'live coarse root nitrogen transfer pool capacity','gC/m2') - - ! dead coarse root nitrogen display pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootnCap, & - a_deadcrootnCap, file_hist, 'f_deadcrootnCap', itime_in_file, sumarea, filter, & - 'dead coarse root nitrogen display pool Capacity','gC/m2') - - ! dead coarse root nitrogen storage pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storageCap, & - a_deadcrootn_storageCap, file_hist, 'f_deadcrootn_storageCap', & - itime_in_file, sumarea, filter, & - 'dead coarse root nitrogen storage pool capacity','gC/m2') - - ! dead coarse root nitrogen transfer pool - CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xferCap, & - a_deadcrootn_xferCap, file_hist, 'f_deadcrootn_xferCap', & - itime_in_file, sumarea, filter, & - 'dead coarse root nitrogen transfer pool capacity','gC/m2') - - ENDIF - - IF(DEF_USE_OZONESTRESS)THEN - ! ozone concentration - CALL write_history_variable_2d ( DEF_hist_vars%xy_ozone, & - a_ozone, file_hist, 'f_xy_ozone', itime_in_file, sumarea, filter, & - 'Ozone concentration','mol/mol') - ENDIF - - ! litter 1 carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr1c_vr, & - a_litr1c_vr, file_hist, 'f_litr1c_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 1 carbon density in soil layers','gC/m3') - - ! litter 2 carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr2c_vr, & - a_litr2c_vr, file_hist, 'f_litr2c_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 2 carbon density in soil layers','gC/m3') - - ! litter 3 carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr3c_vr, & - a_litr3c_vr, file_hist, 'f_litr3c_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 3 carbon density in soil layers','gC/m3') - - ! soil 1 carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil1c_vr, & - a_soil1c_vr, file_hist, 'f_soil1c_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 1 carbon density in soil layers','gC/m3') - - ! soil 2 carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil2c_vr, & - a_soil2c_vr, file_hist, 'f_soil2c_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 2 carbon density in soil layers','gC/m3') - - ! soil 3 carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil3c_vr, & - a_soil3c_vr, file_hist, 'f_soil3c_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 3 carbon density in soil layers','gC/m3') - - ! coarse woody debris carbon density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%cwdc_vr, & - a_cwdc_vr, file_hist, 'f_cwdc_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'coarse woody debris carbon density in soil layers','gC/m3') - - ! litter 1 nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr1n_vr, & - a_litr1n_vr, file_hist, 'f_litr1n_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 1 nitrogen density in soil layers','gN/m3') - - ! litter 2 nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr2n_vr, & - a_litr2n_vr, file_hist, 'f_litr2n_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 2 nitrogen density in soil layers','gN/m3') - - ! litter 3 nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr3n_vr, & - a_litr3n_vr, file_hist, 'f_litr3n_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 3 nitrogen density in soil layers','gN/m3') - - ! soil 1 nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil1n_vr, & - a_soil1n_vr, file_hist, 'f_soil1n_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 1 nitrogen density in soil layers','gN/m3') - - ! soil 2 nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil2n_vr, & - a_soil2n_vr, file_hist, 'f_soil2n_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 2 nitrogen density in soil layers','gN/m3') - - ! soil 3 nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil3n_vr, & - a_soil3n_vr, file_hist, 'f_soil3n_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 3 nitrogen density in soil layers','gN/m3') - - ! coarse woody debris nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%cwdn_vr, & - a_cwdn_vr, file_hist, 'f_cwdn_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'coarse woody debris nitrogen density in soil layers','gN/m3') - - ! mineral nitrogen density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%sminn_vr, & - a_sminn_vr, file_hist, 'f_sminn_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'mineral nitrogen density in soil layers','gN/m3') - - ! total nitrogen percentage in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%totsoiln_vr, & - a_totsoiln_vr, file_hist, 'f_totsoiln_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,& - 'Total nitrogen in soil layers, percentage of total soil nitrogen in total soil mass','%') - - ! bulk density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%BD_all, & - a_BD_all, file_hist, 'f_BD_all', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'bulk density in soil layers','kg/m3') - - ! field capacity in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%wfc, & - a_wfc, file_hist, 'f_wfc', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'field capacity in soil layers','m3/m3') - - ! organic matter density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%OM_density, & - a_OM_density, file_hist, 'f_OM_density', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'organic matter density in soil layers','kg/m3') - - IF (DEF_USE_NITRIF) THEN - ! O2 soil Concentration for non-inundated area - CALL write_history_variable_3d ( DEF_hist_vars%CONC_O2_UNSAT, & - a_conc_o2_unsat, file_hist, 'f_CONC_O2_UNSAT', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'O2 soil Concentration for non-inundated area','mol/m3') - - ! O2 consumption from HR and AR for non-inundated area - CALL write_history_variable_3d ( DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT, & - a_o2_decomp_depth_unsat, file_hist, 'f_O2_DECOMP_DEPTH_UNSAT', & - itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'O2 consumption from HR and AR for non-inundated area','mol/m3/s') - ENDIF - - IF (DEF_USE_FIRE) THEN - CALL write_history_variable_2d ( DEF_hist_vars%abm, & - vecacc, file_hist, 'f_abm', itime_in_file, sumarea, filter, & - 'peak crop fire month','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%gdp, & - vecacc, file_hist, 'f_gdp', itime_in_file, sumarea, filter, & - 'gdp','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%peatf, & - vecacc, file_hist, 'f_peatf', itime_in_file, sumarea, filter, & - 'peatf','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%hdm, & - vecacc, file_hist, 'f_hdm', itime_in_file, sumarea, filter, & - 'hdm','unitless') - - CALL write_history_variable_2d ( DEF_hist_vars%lnfm, & - vecacc, file_hist, 'f_lnfm', itime_in_file, sumarea, filter, & - 'lnfm','unitless') - ENDIF - - IF(DEF_USE_DiagMatrix)THEN - ! litter 1 carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr1cCap_vr, & - a_litr1cCap_vr, file_hist, 'f_litr1cCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 1 carbon capacity density in soil layers','gC/m3') - - ! litter 2 carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr2cCap_vr, & - a_litr2cCap_vr, file_hist, 'f_litr2cCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 2 carbon capacity density in soil layers','gC/m3') - - ! litter 3 carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr3cCap_vr, & - a_litr3cCap_vr, file_hist, 'f_litr3cCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 3 carbon capacity density in soil layers','gC/m3') - - ! soil 1 carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil1cCap_vr, & - a_soil1cCap_vr, file_hist, 'f_soil1cCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 1 carbon capacity density in soil layers','gC/m3') - - ! soil 2 carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil2cCap_vr, & - a_soil2cCap_vr, file_hist, 'f_soil2cCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 2 carbon capacity density in soil layers','gC/m3') - - ! soil 3 carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil3cCap_vr, & - a_soil3cCap_vr, file_hist, 'f_soil3cCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 3 carbon capacity density in soil layers','gC/m3') - - ! coarse woody debris carbon capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%cwdcCap_vr, & - a_cwdcCap_vr, file_hist, 'f_cwdcCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'coarse woody debris carbon capacity density in soil layers','gC/m3') - - ! litter 1 nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr1nCap_vr, & - a_litr1nCap_vr, file_hist, 'f_litr1nCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 1 nitrogen capacity density in soil layers','gN/m3') - - ! litter 2 nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr2nCap_vr, & - a_litr2nCap_vr, file_hist, 'f_litr2nCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 2 nitrogen capacity density in soil layers','gN/m3') - - ! litter 3 nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%litr3nCap_vr, & - a_litr3nCap_vr, file_hist, 'f_litr3nCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'litter 3 nitrogen capacity density in soil layers','gN/m3') - - ! soil 1 nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil1nCap_vr, & - a_soil1nCap_vr, file_hist, 'f_soil1nCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 1 nitrogen capacity density in soil layers','gN/m3') - - ! soil 2 nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil2nCap_vr, & - a_soil2nCap_vr, file_hist, 'f_soil2nCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 2 nitrogen capacity density in soil layers','gN/m3') - - ! soil 3 nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%soil3nCap_vr, & - a_soil3nCap_vr, file_hist, 'f_soil3nCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,'soil 3 nitrogen capacity density in soil layers','gN/m3') - - ! coarse woody debris nitrogen capacity density in soil layers - CALL write_history_variable_3d ( DEF_hist_vars%cwdnCap_vr, & - a_cwdnCap_vr, file_hist, 'f_cwdnCap_vr', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter,& - 'coarse woody debris nitrogen capacity density in soil layers','gN/m3') - - ! Temperature environmental scalar - CALL write_history_variable_3d ( DEF_hist_vars%t_scalar, & - a_t_scalar, file_hist, 'f_t_scalar', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter, 'Temperature environmental scalar','unitless') - - ! Water environmental scalar - CALL write_history_variable_3d ( DEF_hist_vars%w_scalar, & - a_w_scalar, file_hist, 'f_w_scalar', itime_in_file, 'soil', 1, nl_soil, & - sumarea, filter, 'Water environmental scalar','unitless') - - ENDIF - - - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) .ne. 12 .and. patchtype(i) .eq. 0)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! 1: gpp enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%gpp_enftemp, & - a_gpp_enftemp, file_hist, 'f_gpp_enftemp', itime_in_file, sumarea, filter, & - 'gross primary productivity for needleleaf evergreen temperate tree','gC/m2/s') - - ! 1: leaf carbon display pool enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%leafc_enftemp, & - a_leafc_enftemp, file_hist, 'f_leafc_enftemp', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for needleleaf evergreen temperate tree','gC/m2') - - ! 1: leaf area index enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%lai_enftemp, & - a_lai_enftemp, file_hist, 'f_lai_enftemp', itime_in_file, sumarea, filter, & - 'leaf area index for needleleaf evergreen temperate tree','m2/m2') - - ! 1: npp enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%npp_enftemp, & - a_npp_enftemp, file_hist, 'f_npp_enftemp', itime_in_file, sumarea, filter, & - 'npp for needleleaf evergreen temperate tree','m2/m2') - - ! 1: npp to leafc enf temperate - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_enftemp, & - a_npptoleafc_enftemp, file_hist, 'f_npptoleafc_enftemp', itime_in_file, sumarea, filter, & - 'npp to leafc for needleleaf evergreen temperate tree','m2/m2') - - ! 2: gpp enf boreal - CALL write_history_variable_2d ( DEF_hist_vars%gpp_enfboreal, & - a_gpp_enfboreal, file_hist, 'f_gpp_enfboreal', itime_in_file, sumarea, filter, & - 'gross primary productivity for needleleaf evergreen boreal tree','gC/m2/s') - - ! 2: leaf carbon display pool enf boreal - CALL write_history_variable_2d ( DEF_hist_vars%leafc_enfboreal, & - a_leafc_enfboreal, file_hist, 'f_leafc_enfboreal', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for needleleaf evergreen boreal tree','gC/m2') - - ! 2: leaf area index enf boreal - CALL write_history_variable_2d ( DEF_hist_vars%lai_enfboreal, & - a_lai_enfboreal, file_hist, 'f_lai_enfboreal', itime_in_file, sumarea, filter, & - 'leaf area index for needleleaf evergreen boreal tree','m2/m2') - - ! 2: npp enf boreal - CALL write_history_variable_2d ( DEF_hist_vars%npp_enfboreal, & - a_npp_enfboreal, file_hist, 'f_npp_enfboreal', itime_in_file, sumarea, filter, & - 'npp for needleleaf evergreen boreal tree','m2/m2') - - ! 2: npp to leafc enf boreal - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_enfboreal, & - a_npptoleafc_enfboreal, file_hist, 'f_npptoleafc_enfboreal', itime_in_file, sumarea, filter, & - 'npp to leafc for needleleaf evergreen boreal tree','m2/m2') - - ! 3: gpp dnf boreal - CALL write_history_variable_2d ( DEF_hist_vars%gpp_dnfboreal, & - a_gpp_dnfboreal, file_hist, 'f_gpp_dnfboreal', itime_in_file, sumarea, filter, & - 'gross primary productivity for needleleaf deciduous boreal tree','gC/m2/s') - - ! 3: leaf carbon display pool dnf boreal - CALL write_history_variable_2d ( DEF_hist_vars%leafc_dnfboreal, & - a_leafc_dnfboreal, file_hist, 'f_leafc_dnfboreal', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for needleleaf deciduous boreal tree','gC/m2') - - ! 3: leaf area index dnf boreal - CALL write_history_variable_2d ( DEF_hist_vars%lai_dnfboreal, & - a_lai_dnfboreal, file_hist, 'f_lai_dnfboreal', itime_in_file, sumarea, filter, & - 'leaf area index for needleleaf deciduous boreal tree','m2/m2') - - ! 3: npp dnf boreal - CALL write_history_variable_2d ( DEF_hist_vars%npp_dnfboreal, & - a_npp_dnfboreal, file_hist, 'f_npp_dnfboreal', itime_in_file, sumarea, filter, & - 'npp for needleleaf deciduous boreal tree','m2/m2') - - ! 3: npp to leafc dnf boreal - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dnfboreal, & - a_npptoleafc_dnfboreal, file_hist, 'f_npptoleafc_dnfboreal', itime_in_file, sumarea, filter, & - 'npp to leafc for needleleaf deciduous boreal tree','m2/m2') - - ! 4: gpp ebf trop - CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftrop, & - a_gpp_ebftrop, file_hist, 'f_gpp_ebftrop', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf evergreen tropical tree','gC/m2/s') - - ! 4: leaf carbon display pool ebf trop - CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftrop, & - a_leafc_ebftrop, file_hist, 'f_leafc_ebftrop', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf evergreen tropical tree','gC/m2') - - ! 4: leaf area index ebf trop - CALL write_history_variable_2d ( DEF_hist_vars%lai_ebftrop, & - a_lai_ebftrop, file_hist, 'f_lai_ebftrop', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf evergreen tropical tree','m2/m2') - - ! 4: npp ebf trop - CALL write_history_variable_2d ( DEF_hist_vars%npp_ebftrop, & - a_npp_ebftrop, file_hist, 'f_npp_ebftrop', itime_in_file, sumarea, filter, & - 'npp for broadleaf evergreen tropical tree','m2/m2') - - ! 4: npp to leafc ebf trop - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebftrop, & - a_npptoleafc_ebftrop, file_hist, 'f_npptoleafc_ebftrop', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf evergreen tropical tree','m2/m2') - - ! 5: gpp ebf temp - CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftemp, & - a_gpp_ebftemp, file_hist, 'f_gpp_ebftemp', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf evergreen temperate tree','gC/m2/s') - - ! 5: leaf carbon display pool ebf temp - CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftemp, & - a_leafc_ebftemp, file_hist, 'f_leafc_ebftemp', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf evergreen temperate tree','gC/m2') - - ! 5: leaf area index ebf temp - CALL write_history_variable_2d ( DEF_hist_vars%lai_ebftemp, & - a_lai_ebftemp, file_hist, 'f_lai_ebftemp', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf evergreen temperate tree','m2/m2') - - ! 5: npp ebf temp - CALL write_history_variable_2d ( DEF_hist_vars%npp_ebftemp, & - a_npp_ebftemp, file_hist, 'f_npp_ebftemp', itime_in_file, sumarea, filter, & - 'npp for broadleaf evergreen temperate tree','m2/m2') - - ! 5: npp to leafc ebf temp - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebftemp, & - a_npptoleafc_ebftemp, file_hist, 'f_npptoleafc_ebftemp', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf evergreen temperate tree','m2/m2') - - ! 6: gpp dbf trop - CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftrop, & - a_gpp_dbftrop, file_hist, 'f_gpp_dbftrop', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf deciduous tropical tree','gC/m2/s') - - ! 6: leaf carbon display pool dbf trop - CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftrop, & - a_leafc_dbftrop, file_hist, 'f_leafc_dbftrop', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf deciduous tropical tree','gC/m2') - - ! 6: leaf area index dbf trop - CALL write_history_variable_2d ( DEF_hist_vars%lai_dbftrop, & - a_lai_dbftrop, file_hist, 'f_lai_dbftrop', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf evergreen temperate tree','m2/m2') - - ! 6: npp dbf trop - CALL write_history_variable_2d ( DEF_hist_vars%npp_dbftrop, & - a_npp_dbftrop, file_hist, 'f_npp_dbftrop', itime_in_file, sumarea, filter, & - 'npp for broadleaf evergreen temperate tree','m2/m2') - - ! 6: npp to leafc dbf trop - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbftrop, & - a_npptoleafc_dbftrop, file_hist, 'f_npptoleafc_dbftrop', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf evergreen temperate tree','m2/m2') - - ! 7: gpp dbf temp - CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftemp, & - a_gpp_dbftemp, file_hist, 'f_gpp_dbftemp', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf deciduous temperate tree','gC/m2/s') - - ! 7: leaf carbon display pool dbf temp - CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftemp, & - a_leafc_dbftemp, file_hist, 'f_leafc_dbftemp', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf deciduous temperate tree','gC/m2') - - ! 7: leaf area index dbf temp - CALL write_history_variable_2d ( DEF_hist_vars%lai_dbftemp, & - a_lai_dbftemp, file_hist, 'f_lai_dbftemp', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf decidous temperate tree','m2/m2') - - ! 7: npp dbf temp - CALL write_history_variable_2d ( DEF_hist_vars%npp_dbftemp, & - a_npp_dbftemp, file_hist, 'f_npp_dbftemp', itime_in_file, sumarea, filter, & - 'npp for broadleaf decidous temperate tree','m2/m2') - - ! 7: npp to leafc dbf temp - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbftemp, & - a_npptoleafc_dbftemp, file_hist, 'f_npptoleafc_dbftemp', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf decidous temperate tree','m2/m2') - - ! 8: gpp dbf boreal - CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbfboreal, & - a_gpp_dbfboreal, file_hist, 'f_gpp_dbfboreal', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf deciduous boreal tree','gC/m2/s') - - ! 8: leaf carbon display pool dbf boreal - CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbfboreal, & - a_leafc_dbfboreal, file_hist, 'f_leafc_dbfboreal', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf deciduous boreal tree','gC/m2') - - ! 8: leaf area index dbf boreal - CALL write_history_variable_2d ( DEF_hist_vars%lai_dbfboreal, & - a_lai_dbfboreal, file_hist, 'f_lai_dbfboreal', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf decidous boreal tree','m2/m2') - - ! 8: npp dbf boreal - CALL write_history_variable_2d ( DEF_hist_vars%npp_dbfboreal, & - a_npp_dbfboreal, file_hist, 'f_npp_dbfboreal', itime_in_file, sumarea, filter, & - 'npp for broadleaf decidous boreal tree','m2/m2') - - ! 8: npp to leafc dbf boreal - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbfboreal, & - a_npptoleafc_dbfboreal, file_hist, 'f_npptoleafc_dbfboreal', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf decidous boreal tree','m2/m2') - - ! 9: gpp ebs temp - CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebstemp, & - a_gpp_ebstemp, file_hist, 'f_gpp_ebstemp', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf evergreen temperate shrub','gC/m2/s') - - ! 9: leaf carbon display pool ebs temp - CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebstemp, & - a_leafc_ebstemp, file_hist, 'f_leafc_ebstemp', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf evergreen temperate shrub','gC/m2') - - ! 9: leaf area index ebs temp - CALL write_history_variable_2d ( DEF_hist_vars%lai_ebstemp, & - a_lai_ebstemp, file_hist, 'f_lai_ebstemp', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf evergreen temperate shrub','m2/m2') - - ! 9: npp ebs temp - CALL write_history_variable_2d ( DEF_hist_vars%npp_ebstemp, & - a_npp_ebstemp, file_hist, 'f_npp_ebstemp', itime_in_file, sumarea, filter, & - 'npp for broadleaf evergreen temperate shrub','m2/m2') - - ! 9: npp to leafc ebs temp - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebstemp, & - a_npptoleafc_ebstemp, file_hist, 'f_npptoleafc_ebstemp', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf evergreen temperate shrub','m2/m2') - - ! 10: gpp dbs temp - CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbstemp, & - a_gpp_dbstemp, file_hist, 'f_gpp_dbstemp', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf deciduous temperate shrub','gC/m2/s') - - ! 10: leaf carbon display pool dbs temp - CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbstemp, & - a_leafc_dbstemp, file_hist, 'f_leafc_dbstemp', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf deciduous temperate shrub','gC/m2') - - ! 10: leaf area index dbs temp - CALL write_history_variable_2d ( DEF_hist_vars%lai_dbstemp, & - a_lai_dbstemp, file_hist, 'f_lai_dbstemp', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf deciduous temperate shrub','m2/m2') - - ! 10: npp dbs temp - CALL write_history_variable_2d ( DEF_hist_vars%npp_dbstemp, & - a_npp_dbstemp, file_hist, 'f_npp_dbstemp', itime_in_file, sumarea, filter, & - 'npp for broadleaf deciduous temperate shrub','m2/m2') - - ! 10: npp to leafc dbs temp - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbstemp, & - a_npptoleafc_dbstemp, file_hist, 'f_npptoleafc_dbstemp', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf deciduous temperate shrub','m2/m2') - - ! 11: gpp dbs boreal - CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbsboreal, & - a_gpp_dbsboreal, file_hist, 'f_gpp_dbsboreal', itime_in_file, sumarea, filter, & - 'gross primary productivity for broadleaf deciduous boreal shrub','gC/m2/s') - - ! 11: leaf carbon display pool dbs boreal - CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbsboreal, & - a_leafc_dbsboreal, file_hist, 'f_leafc_dbsboreal', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for broadleaf deciduous boreal shrub','gC/m2') - - ! 11: leaf area index dbs boreal - CALL write_history_variable_2d ( DEF_hist_vars%lai_dbsboreal, & - a_lai_dbsboreal, file_hist, 'f_lai_dbsboreal', itime_in_file, sumarea, filter, & - 'leaf area index for broadleaf deciduous boreal shrub','m2/m2') - - ! 11: npp dbs boreal - CALL write_history_variable_2d ( DEF_hist_vars%npp_dbsboreal, & - a_npp_dbsboreal, file_hist, 'f_npp_dbsboreal', itime_in_file, sumarea, filter, & - 'npp for broadleaf deciduous boreal shrub','m2/m2') - - ! 11: npp to leafc dbs boreal - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbsboreal, & - a_npptoleafc_dbsboreal, file_hist, 'f_npptoleafc_dbsboreal', itime_in_file, sumarea, filter, & - 'npp to leafc for broadleaf deciduous boreal shrub','m2/m2') - - ! 12: gpp arctic c3 grass - CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3arcgrass, & - a_gpp_c3arcgrass, file_hist, 'f_gpp_c3arcgrass', itime_in_file, sumarea, filter, & - 'gross primary productivity for c3 arctic grass','gC/m2/s') - - ! 12: leaf carbon display pool c3 arctic grass - CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3arcgrass, & - a_leafc_c3arcgrass, file_hist, 'f_leafc_c3arcgrass', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for c3 arctic grass','gC/m2') - - ! 12: leaf area index c3 arctic grass - CALL write_history_variable_2d ( DEF_hist_vars%lai_c3arcgrass, & - a_lai_c3arcgrass, file_hist, 'f_lai_c3arcgrass', itime_in_file, sumarea, filter, & - 'leaf area index for c3 arctic grass','gC/m2') - - ! 12: npp c3 arctic grass - CALL write_history_variable_2d ( DEF_hist_vars%npp_c3arcgrass, & - a_npp_c3arcgrass, file_hist, 'f_npp_c3arcgrass', itime_in_file, sumarea, filter, & - 'npp for c3 arctic grass','gC/m2') - - ! 12: npp to leafc c3 arctic grass - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c3arcgrass, & - a_npptoleafc_c3arcgrass, file_hist, 'f_npptoleafc_c3arcgrass', itime_in_file, sumarea, filter, & - 'npp to leafc for c3 arctic grass','gC/m2') - - ! 13: gpp c3 grass - CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3grass, & - a_gpp_c3grass, file_hist, 'f_gpp_c3grass', itime_in_file, sumarea, filter, & - 'gross primary productivity for c3 grass','gC/m2/s') - - ! 13: leaf carbon display pool arctic c3 grass - CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, & - a_leafc_c3grass, file_hist, 'f_leafc_c3grass', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for c3 arctic grass','gC/m2') - - ! 13: leaf area index arctic c3 grass - CALL write_history_variable_2d ( DEF_hist_vars%lai_c3grass, & - a_lai_c3grass, file_hist, 'f_lai_c3grass', itime_in_file, sumarea, filter, & - 'leaf area index for c3 arctic grass','gC/m2') - - ! 13: npp arctic c3 grass - CALL write_history_variable_2d ( DEF_hist_vars%npp_c3grass, & - a_npp_c3grass, file_hist, 'f_npp_c3grass', itime_in_file, sumarea, filter, & - 'npp for c3 arctic grass','gC/m2') - - ! 13: npp to leafc arctic c3 grass - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c3grass, & - a_npptoleafc_c3grass, file_hist, 'f_npptoleafc_c3grass', itime_in_file, sumarea, filter, & - 'npp to leafc for c3 arctic grass','gC/m2') - - ! 14: gpp c4 grass - CALL write_history_variable_2d ( DEF_hist_vars%gpp_c4grass, & - a_gpp_c4grass, file_hist, 'f_gpp_c4grass', itime_in_file, sumarea, filter, & - 'gross primary productivity for c4 grass','gC/m2/s') - - ! 14: leaf carbon display pool arctic c4 grass - CALL write_history_variable_2d ( DEF_hist_vars%leafc_c4grass, & - a_leafc_c4grass, file_hist, 'f_leafc_c4grass', itime_in_file, sumarea, filter, & - 'leaf carbon display pool for c4 arctic grass','gC/m2') - - ! 14: leaf area index arctic c4 grass - CALL write_history_variable_2d ( DEF_hist_vars%lai_c4grass, & - a_lai_c4grass, file_hist, 'f_lai_c4grass', itime_in_file, sumarea, filter, & - 'leaf area index for c4 arctic grass','gC/m2') - - ! 14: npp arctic c4 grass - CALL write_history_variable_2d ( DEF_hist_vars%npp_c4grass, & - a_npp_c4grass, file_hist, 'f_npp_c4grass', itime_in_file, sumarea, filter, & - 'npp for c4 arctic grass','gC/m2') - - ! 14: npp to leafc arctic c4 grass - CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c4grass, & - a_npptoleafc_c4grass, file_hist, 'f_npptoleafc_c4grass', itime_in_file, sumarea, filter, & - 'npp to leafc for c4 arctic grass','gC/m2') - -#ifdef CROP -!***************************************** - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_manunitro (:) - ENDIF - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%manunitro, & - vecacc, file_hist, 'f_manunitro', itime_in_file, sumarea, filter, & - 'nitrogen in manure','gN/m2/yr') - - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_hui (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%huiswheat, & - vecacc, file_hist, 'f_huiswheat', itime_in_file, sumarea, filter, & - 'heat unit index (rainfed spring wheat)','unitless') - -!************************************************************ -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & -! .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdcorn, & -! a_pdcorn, file_hist, 'f_pdcorn', & -! itime_in_file, sumarea, filter, 'planting date of corn', 'day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdswheat, & -! a_pdswheat, file_hist, 'f_pdswheat', & -! itime_in_file, sumarea, filter,'planting date of spring wheat','day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdwwheat, & -! a_pdwwheat, file_hist, 'f_pdwwheat', & -! itime_in_file, sumarea, filter,'planting date of winter wheat','day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & -! .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdsoybean, & -! a_pdsoybean, file_hist, 'f_pdsoybean', & -! itime_in_file, sumarea, filter,'planting date of soybean','day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdcotton, & -! a_pdcotton, file_hist, 'f_pdcotton', & -! itime_in_file, sumarea, filter,'planting date of cotton','day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdrice1, & -! a_pdrice1, file_hist, 'f_pdrice1', & -! itime_in_file, sumarea, filter,'planting date of rice1','day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdrice2, & -! a_pdrice2, file_hist, 'f_pdrice2', & -! itime_in_file, sumarea, filter,'planting date of rice2','day') -! -! IF (p_is_compute) THEN -! IF (numpatch > 0) THEN -! DO i=1,numpatch -! IF(patchclass(i) == 12)THEN -! IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN -! filter(i) = .true. -! ELSE -! filter(i) = .false. -! ENDIF -! ELSE -! filter(i) = .false. -! ENDIF -! ENDDO -! ENDIF -! ENDIF -! -! IF (HistForm == 'Gridded') THEN -! CALL mp2g_hist%get_sumarea (sumarea, filter) -! ENDIF -! -! CALL write_history_variable_2d ( DEF_hist_vars%pdsugarcane, & -! a_pdsugarcane, file_hist, 'f_pdsugarcane', & -! itime_in_file, sumarea, filter,'planting date of sugarcane','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 & - .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_corn, & - a_fertnitro_corn, file_hist, 'f_fertnitro_corn', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for corn','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_swheat, & - a_fertnitro_swheat, file_hist, 'f_fertnitro_swheat', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for spring wheat','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_wwheat, & - a_fertnitro_wwheat, file_hist, 'f_fertnitro_wwheat', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for winter wheat','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & - .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_soybean, & - a_fertnitro_soybean, file_hist, 'f_fertnitro_soybean', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for soybean','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_cotton, & - a_fertnitro_cotton, file_hist, 'f_fertnitro_cotton', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for cotton','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice1, & - a_fertnitro_rice1, file_hist, 'f_fertnitro_rice1', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for rice1','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice2, & - a_fertnitro_rice2, file_hist, 'f_fertnitro_rice2', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for rice2','gN/m2/yr') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_sugarcane, & - a_fertnitro_sugarcane, file_hist, 'f_fertnitro_sugarcane', & - itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr') - - IF(DEF_USE_IRRIGATION)THEN - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 17)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, & - a_irrig_method_corn, file_hist, 'f_irrig_method_corn', & - itime_in_file, sumarea, filter,'irrigation method for corn','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.19 .or. pftclass(patch_pft_s(i)).eq.20)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, & - a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', & - itime_in_file, sumarea, filter,'irrigation method for spring wheat','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.21 .or. pftclass(patch_pft_s(i)).eq.22)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, & - a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', & - itime_in_file, sumarea, filter,'irrigation method for winter wheat','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.23 .or. pftclass(patch_pft_s(i)).eq.24 & - .or. pftclass(patch_pft_s(i)).eq.77 .or. pftclass(patch_pft_s(i)).eq.78)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, & - a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', & - itime_in_file, sumarea, filter,'irrigation method for soybean','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.41 .or. pftclass(patch_pft_s(i)).eq.42)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, & - a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', & - itime_in_file, sumarea, filter,'irrigation method for cotton','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.61 .or. pftclass(patch_pft_s(i)).eq.62)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, & - a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', & - itime_in_file, sumarea, filter,'irrigation method for rice1','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.61 .or. pftclass(patch_pft_s(i)).eq.62)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, & - a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', & - itime_in_file, sumarea, filter,'irrigation method for rice2','-') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)).eq.67 .or. pftclass(patch_pft_s(i)).eq.68)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, & - a_irrig_method_sugarcane, file_hist, 'f_irrig_method_sugarcane', & - itime_in_file, sumarea, filter,'irrigation method for sugarcane','-') - - ENDIF - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 17)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed temperate corn - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, & - vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed temperate corn)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 18)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated temperate corn - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, & - vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated temperate corn)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 19)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed spring wheat - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, & - vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed spring wheat)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 20)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated spring wheat - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, & - vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated spring wheat)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 21)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed winter wheat - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, & - vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed winter wheat)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 22)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated winter wheat - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, & - vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated winter wheat)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 23)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed temperate soybean - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, & - vecacc, file_hist, 'f_plantdate_rainfed_temp_soybean', & - itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed temperate soybean)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 24)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated temperate soybean - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, & - vecacc, file_hist, 'f_plantdate_irrigated_temp_soybean', & - itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated temperate soybean)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 41)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed cotton - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, & - vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed cotton)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 42)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated cotton - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, & - vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated cotton)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 61)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed rice - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, & - vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed rice)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 62)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated rice - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, & - vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated rice)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 67)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed sugarcane - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, & - vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed sugarcane)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 68)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated sugarcane - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, & - vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated sugarcane)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 75)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed trop corn - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, & - vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed trop corn)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 76)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated trop corn - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, & - vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated trop corn)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 77)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of rainfed trop soybean - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, & - vecacc, file_hist, 'f_plantdate_rainfed_trop_soybean', & - itime_in_file, sumarea, filter, & - 'Crop planting date (rainfed trop soybean)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 78)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of irrigated trop soybean - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, & - vecacc, file_hist, 'f_plantdate_irrigated_trop_soybean', & - itime_in_file, sumarea, filter, & - 'Crop planting date (irrigated trop soybean)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 15)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! planting date of unmanaged crop production - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_plantdate (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, & - vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, & - 'Crop planting date (unmanaged crop production)','day') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 17)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to corn production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_corn, & - vecacc, file_hist, 'f_cropprodc_rainfed_temp_corn', itime_in_file, sumarea, filter, & - 'Crop production (rainfed temperate corn)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 18)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to corn production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_corn, & - vecacc, file_hist, 'f_cropprodc_irrigated_temp_corn', itime_in_file, sumarea, filter, & - 'Crop production (irrigated temperate corn)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 19)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to spring wheat production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_spwheat, & - vecacc, file_hist, 'f_cropprodc_rainfed_spwheat', itime_in_file, sumarea, filter, & - 'Crop production (rainfed spring wheat)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 20)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to spring wheat production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_spwheat, & - vecacc, file_hist, 'f_cropprodc_irrigated_spwheat', itime_in_file, sumarea, filter, & - 'Crop production (irrigated spring wheat)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 21)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to winter wheat production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_wtwheat, & - vecacc, file_hist, 'f_cropprodc_rainfed_wtwheat', itime_in_file, sumarea, filter, & - 'Crop production (rainfed winter wheat)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 22)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to winter wheat production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_wtwheat, & - vecacc, file_hist, 'f_cropprodc_irrigated_wtwheat', itime_in_file, sumarea, filter, & - 'Crop production (irrigated winter wheat)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 23)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to soybean production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_soybean, & - vecacc, file_hist, 'f_cropprodc_rainfed_temp_soybean', & - itime_in_file, sumarea, filter, & - 'Crop production (rainfed temperate soybean)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 24)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to soybean production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_soybean, & - vecacc, file_hist, 'f_cropprodc_irrigated_temp_soybean', & - itime_in_file, sumarea, filter, & - 'Crop production (irrigated temperate soybean)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 41)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to cotton production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_cotton, & - vecacc, file_hist, 'f_cropprodc_rainfed_cotton', itime_in_file, sumarea, filter, & - 'Crop production (rainfed cotton)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 42)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to cotton production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_cotton, & - vecacc, file_hist, 'f_cropprodc_irrigated_cotton', itime_in_file, sumarea, filter, & - 'Crop production (irrigated cotton)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 61)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to rice production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_rice, & - vecacc, file_hist, 'f_cropprodc_rainfed_rice', itime_in_file, sumarea, filter, & - 'Crop production (rainfed rice)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 62)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to rice production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_rice, & - vecacc, file_hist, 'f_cropprodc_irrigated_rice', itime_in_file, sumarea, filter, & - 'Crop production (irrigated rice)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 67)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to sugarcane production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_sugarcane, & - vecacc, file_hist, 'f_cropprodc_rainfed_sugarcane', itime_in_file, sumarea, filter, & - 'Crop production (rainfed sugarcane)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 68)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to sugarcane production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_sugarcane, & - vecacc, file_hist, 'f_cropprodc_irrigated_sugarcane', itime_in_file, sumarea, filter, & - 'Crop production (irrigated sugarcane)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 75)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to sugarcane production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_corn, & - vecacc, file_hist, 'f_cropprodc_rainfed_trop_corn', itime_in_file, sumarea, filter, & - 'Crop production (rainfed_trop_corn)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 76)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to sugarcane production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_corn, & - vecacc, file_hist, 'f_cropprodc_irrigated_trop_corn', itime_in_file, sumarea, filter, & - 'Crop production (irrigated_trop_corn)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 77)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to sugarcane production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_soybean, & - vecacc, file_hist, 'f_cropprodc_rainfed_trop_soybean', & - itime_in_file, sumarea, filter, & - 'Crop production (rainfed trop soybean)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 78)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to sugarcane production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_soybean, & - vecacc, file_hist, 'f_cropprodc_irrigated_trop_soybean', & - itime_in_file, sumarea, filter, & - 'Crop production (irrigated trop soybean)','gC/m2/s') - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - DO i=1,numpatch - IF(patchclass(i) == 12)THEN - IF(pftclass(patch_pft_s(i)) .eq. 15)THEN - filter(i) = .true. - ELSE - filter(i) = .false. - ENDIF - ELSE - filter(i) = .false. - ENDIF - ENDDO - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! grain to unmanaged crop production carbon - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - vecacc (:) = a_grainc_to_cropprodc (:) - ENDIF - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_unmanagedcrop, & - vecacc, file_hist, 'f_cropprodc_unmanagedcrop', itime_in_file, sumarea, filter, & - 'Crop production (unmanaged crop production)','gC/m2/s') -#endif -#endif - ! -------------------------------------------------------------------- - ! Temperature and water (excluding land water bodies and ocean patches) - ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; - ! land water bodies => 4; ocean => 99] - ! -------------------------------------------------------------------- - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype <= 3 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! soil temperature [K] - CALL write_history_variable_3d ( DEF_hist_vars%t_soisno, & - a_t_soisno, file_hist, 'f_t_soisno', & - itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & - sumarea, filter, 'soil temperature','K') - - ! liquid water in soil layers [kg/m2] - CALL write_history_variable_3d ( DEF_hist_vars%wliq_soisno, & - a_wliq_soisno, file_hist, 'f_wliq_soisno', & - itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & - sumarea, filter,'liquid water in soil layers','kg/m2') - - ! ice lens in soil layers [kg/m2] - CALL write_history_variable_3d ( DEF_hist_vars%wice_soisno, & - a_wice_soisno, file_hist, 'f_wice_soisno', & - itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & - sumarea, filter, 'ice lens in soil layers', 'kg/m2') - - -#ifdef DataAssimilation - IF (p_is_compute) THEN - allocate (a_wliq_h2osoi_5cm (numpatch )); a_wliq_h2osoi_5cm = spval - allocate (a_t_soisno_5cm (numpatch )); a_t_soisno_5cm = spval - - allocate (a_wliq_soisno_ens_mean(maxsnl+1:nl_soil,numpatch)); a_wliq_soisno_ens_mean = spval - allocate (a_wliq_soisno_5cm_ens (DEF_DA_ENS_NUM,numpatch )); a_wliq_soisno_5cm_ens = spval - allocate (a_wliq_h2osoi_5cm_a (numpatch )); a_wliq_h2osoi_5cm_a = spval - - allocate (a_t_soisno_ens_mean (maxsnl+1:nl_soil,numpatch)); a_t_soisno_ens_mean = spval - allocate (a_t_soisno_5cm_ens (DEF_DA_ENS_NUM,numpatch )); a_t_soisno_5cm_ens = spval - allocate (a_t_soisno_5cm_a (numpatch )); a_t_soisno_5cm_a = spval - - allocate (a_t_brt_smap_a (2,numpatch )); a_t_brt_smap_a = spval - allocate (a_t_brt_fy3d_a (2,numpatch )); a_t_brt_fy3d_a = spval - - allocate (a_wliq_soisno_5cm_ens_std(numpatch )); a_wliq_soisno_5cm_ens_std = spval - allocate (a_t_soisno_5cm_ens_std (numpatch )); a_t_soisno_5cm_ens_std = spval - allocate (a_t_brt_smap_ens_std (2,numpatch )); a_t_brt_smap_ens_std = spval - allocate (a_t_brt_fy3d_ens_std (2,numpatch )); a_t_brt_fy3d_ens_std = spval - END IF - - IF (p_is_compute) THEN -!############################################################################# -! States before DA -!############################################################################# - ! calculate surface liquid soil moisture (0-5cm) before DA - a_wliq_h2osoi_5cm = (a_wliq_soisno(1,:) + a_wliq_soisno(2,:) + & - a_wliq_soisno(3, :)*(0.05 - 0.0451)/(0.0906 - 0.0451))/(0.05*denh2o) - - ! calculate surface liquid soil moisture (0-5cm) before DA - a_t_soisno_5cm = (a_t_soisno(1,:)*0.0175 + a_t_soisno(2,:)*(0.0451 - 0.0175))/(0.0451) - -!############################################################################# -! States after DA -!############################################################################# - ! calculate surface liquid soil moisture (0-5cm) after DA - a_wliq_soisno_ens_mean = sum(a_wliq_soisno_ens, dim=2) / DEF_DA_ENS_NUM - a_wliq_soisno_5cm_ens = (a_wliq_soisno_ens(1,:,:) + a_wliq_soisno_ens(2,:,:) + & - a_wliq_soisno_ens(3,:,:)*(0.05-0.0451)/(0.0906-0.0451))/(0.05*denh2o) - a_wliq_h2osoi_5cm_a = (a_wliq_soisno_ens_mean(1,:) + a_wliq_soisno_ens_mean(2,:) + & - a_wliq_soisno_ens_mean(3,:)*(0.05 - 0.0451)/(0.0906 - 0.0451))/(0.05*denh2o) - - ! calculate surface soil temperature (0-5cm) before DA & after DA - a_t_soisno_ens_mean = sum(a_t_soisno_ens, dim=2) / DEF_DA_ENS_NUM - a_t_soisno_5cm_ens = (a_t_soisno_ens(1,:,:)*0.0175 + a_t_soisno_ens(2,:,:)*(0.0451 - 0.0175))/(0.0451) - a_t_soisno_5cm_a = (a_t_soisno_ens_mean(1,:)*0.0175 + a_t_soisno_ens_mean(2,:)*(0.0451 - 0.0175))/(0.0451) - -!############################################################################# -! brightness temperature after DA -!############################################################################# - a_t_brt_smap_a = sum(a_t_brt_smap_ens, dim=2) / DEF_DA_ENS_NUM - a_t_brt_fy3d_a = sum(a_t_brt_fy3d_ens, dim=2) / DEF_DA_ENS_NUM - -!############################################################################# -! Standard deviation of states and brightness temperature -!############################################################################# - ! calculate standard deviation of surface soil moisture, temperature and brightness temperature - DO np = 1, numpatch - a_wliq_soisno_5cm_ens_std(np) = & - sqrt(sum((a_wliq_soisno_5cm_ens(:,np)-a_wliq_h2osoi_5cm_a(np))**2)/real(DEF_DA_ENS_NUM-1)) - a_t_soisno_5cm_ens_std(np) = & - sqrt(sum((a_t_soisno_5cm_ens(:,np)-a_t_soisno_5cm_a(np))**2)/real(DEF_DA_ENS_NUM-1)) - IF (DEF_DA_SM_SMAP) THEN - IF (patchtype(np) >= 3) cycle - a_t_brt_smap_ens_std(1,np) = & - sqrt(sum((a_t_brt_smap_ens(1,:,np)-a_t_brt_smap_a(1,np))**2)/real(DEF_DA_ENS_NUM-1)) - a_t_brt_smap_ens_std(2,np) = & - sqrt(sum((a_t_brt_smap_ens(2,:,np)-a_t_brt_smap_a(2,np))**2)/real(DEF_DA_ENS_NUM-1)) - ENDIF - IF (DEF_DA_SM_FY) THEN - IF (patchtype(np) >= 3) cycle - a_t_brt_fy3d_ens_std(1,np) = & - sqrt(sum((a_t_brt_fy3d_ens(1,:,np)-a_t_brt_fy3d_a(1,np))**2)/real(DEF_DA_ENS_NUM-1)) - a_t_brt_fy3d_ens_std(2,np) = & - sqrt(sum((a_t_brt_fy3d_ens(2,:,np)-a_t_brt_fy3d_a(2,np))**2)/real(DEF_DA_ENS_NUM-1)) - ENDIF - ENDDO - ENDIF - - ! surface soil moisture (0-5cm) before and after DA - CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_h2osoi_5cm, & - a_wliq_h2osoi_5cm, file_hist, 'f_wliq_h2osoi_5cm', itime_in_file, & - sumarea, filter, 'Volumetric liquid water content in 0-5cm', 'm3/m3') - CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_h2osoi_5cm_a, & - a_wliq_h2osoi_5cm_a, file_hist, 'f_wliq_h2osoi_5cm_a', itime_in_file, & - sumarea, filter, 'Analysis volumetric liquid water content in 0-5cm', 'm3/m3') - - ! surface soil temperature (0-5cm) before and after DA - CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm, & - a_t_soisno_5cm, file_hist, 'f_t_soisno_5cm', itime_in_file, & - sumarea, filter, 'Soil temperature in 0-5cm', 'K') - CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm_a, & - a_t_soisno_5cm_a, file_hist, 'f_t_soisno_5cm_a', itime_in_file, & - sumarea, filter, 'Analysis soil temperature in 0-5cm', 'K') - - ! ensemble soil moisture & temperature in soil layers [kg/m2] - IF (DEF_DA_ENS_NUM > 1) THEN - CALL write_history_variable_4d(DEF_hist_vars%DA_wliq_soisno_ens, & - a_wliq_soisno_ens, file_hist, 'f_wliq_soisno_ens', itime_in_file, 'soilsnow', maxsnl + 1, nl_soil - maxsnl, & - 'ens', 1, DEF_DA_ENS_NUM, sumarea, filter, 'ensemble liquid water in soil layers', 'kg/m2') - CALL write_history_variable_4d(DEF_hist_vars%DA_t_soisno_ens, & - a_t_soisno_ens, file_hist, 'f_t_soisno_ens', itime_in_file, 'soilsnow', maxsnl + 1, nl_soil - maxsnl, & - 'ens', 1, DEF_DA_ENS_NUM, sumarea, filter, 'ensemble soil temperature', 'K') - ENDIF - - ! standard deviation of ensemble surface soil moisture and temperature (0-5cm) - CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_soisno_5cm_ens_std, & - a_wliq_soisno_5cm_ens_std, file_hist, 'f_wliq_soisno_ens_5cm_ens_std', itime_in_file, & - sumarea, filter, 'Standard deviation of ensemble volumetric liquid water content in 0-5cm', 'm3/m3') - CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm_ens_std, & - a_t_soisno_5cm_ens_std, file_hist, 'f_t_soisno_ens_5cm_ens_std', itime_in_file, & - sumarea, filter, 'Standard deviation of ensemble soil temperature in 0-5cm', 'K') - - ! -------------------------------------------------------------------- - ! brightness temperature (excluding land ice, land water bodies and ocean patches) - ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; - ! land water bodies => 4; ocean => 99] - ! -------------------------------------------------------------------- - - IF (HistForm == 'Gridded') THEN - IF (p_is_active) THEN - CALL allocate_block_data(ghist, sumarea) - END IF - END IF - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype <= 2 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - END IF - - filter = filter .and. patchmask - END IF - END IF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea(sumarea, filter) - END IF - - ! brightness temperature for SMAP and FY satellites - IF (DEF_DA_SM_SMAP) THEN - CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap, & - a_t_brt_smap, file_hist, 'f_t_brt_smap', itime_in_file, 'band', 1, 2, sumarea, filter, & - 'H- & V- polarized brightness temperature for SMAP satellite (L-band, 1.4GHz)', 'K') - CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap_a, & - a_t_brt_smap_a, file_hist, 'f_t_brt_smap_a', itime_in_file, 'band', 1, 2, sumarea, filter, & - 'Analysis H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K') - IF (DEF_DA_ENS_NUM > 1) THEN - CALL write_history_variable_4d(DEF_hist_vars%DA_t_brt_smap_ens, & - a_t_brt_smap_ens, file_hist, 'f_t_brt_smap_ens', itime_in_file, 'band', 1, 2, 'ens', 1, DEF_DA_ENS_NUM, & - sumarea, filter, 'ensemble H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K') - END IF - CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap_ens_std, & - a_t_brt_smap_ens_std, file_hist, 'f_t_brt_smap_ens_std', itime_in_file, 'band', 1, 2, & - sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K') - ENDIF - - IF (DEF_DA_SM_FY) THEN - CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d, & - a_t_brt_fy3d, file_hist, 'f_t_brt_fy3d', itime_in_file, 'band', 1, 2, sumarea, filter, & - 'H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') - CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d_a, & - a_t_brt_fy3d_a, file_hist, 'f_t_brt_fy3d_a', itime_in_file, 'band', 1, 2, sumarea, filter, & - 'Analysis H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') - IF (DEF_DA_ENS_NUM > 1) THEN - CALL write_history_variable_4d(DEF_hist_vars%DA_t_brt_fy3d_ens, & - a_t_brt_fy3d_ens, file_hist, 'f_t_brt_fy3d_ens', itime_in_file, 'band', 1, 2, 'ens', 1, DEF_DA_ENS_NUM, & - sumarea, filter, 'ensemble H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') - END IF - CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d_ens_std, & - a_t_brt_fy3d_ens_std, file_hist, 'f_t_brt_fy3d_ens_std', itime_in_file, 'band', 1, 2, & - sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K') - ENDIF - - IF (p_is_compute) THEN - deallocate (a_wliq_h2osoi_5cm) - deallocate (a_t_soisno_5cm) - deallocate (a_wliq_soisno_ens_mean) - deallocate (a_wliq_soisno_5cm_ens) - deallocate (a_wliq_h2osoi_5cm_a) - deallocate (a_t_soisno_ens_mean) - deallocate (a_t_soisno_5cm_ens) - deallocate (a_t_soisno_5cm_a) - deallocate (a_t_brt_smap_a) - deallocate (a_t_brt_fy3d_a) - deallocate (a_wliq_soisno_5cm_ens_std) - deallocate (a_t_soisno_5cm_ens_std) - deallocate (a_t_brt_smap_ens_std) - deallocate (a_t_brt_fy3d_ens_std) - END IF - -#endif - - ! -------------------------------------------------------------------- - ! additional diagnostic variables for output (vegetated land only <=2) - ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; - ! land water bodies => 4; ocean => 99] - ! -------------------------------------------------------------------- - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype <= 2 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! volumetric soil water in layers [m3/m3] - CALL write_history_variable_3d ( DEF_hist_vars%h2osoi, & - a_h2osoi, file_hist, 'f_h2osoi', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & - 'volumetric water in soil layers','m3/m3') - - IF (DEF_USE_VariablySaturatedFlow) THEN - ! water flux between water layers [mm h2o/s] - CALL write_history_variable_3d ( DEF_hist_vars%qlayer, & - a_qlayer, file_hist, 'f_qlayer', itime_in_file, 'soilinterface', 0, nl_soil+1, & - sumarea, filter, 'water flux between soil layers','mm/s') - ENDIF - - ! fraction of root water uptake from each soil layer, all layers add to 1, - ! when PHS is not defined water exchange between soil layers and root. - ! Positive: soil->root [mm h2o/s], when PHS is defined - CALL write_history_variable_3d ( DEF_hist_vars%rootr, & - a_rootr, file_hist, 'f_rootr', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & - 'root water uptake', 'mm h2o/s') - - IF (DEF_USE_PLANTHYDRAULICS) THEN - ! vegetation water potential [mm] - CALL write_history_variable_3d ( DEF_hist_vars%vegwp, & - a_vegwp, file_hist, 'f_vegwp', & - itime_in_file, 'vegnodes', 1, nvegwcs, sumarea, filter, & - 'vegetation water potential', 'mm') - ENDIF - - ! water table depth [m] - CALL write_history_variable_2d ( DEF_hist_vars%zwt, & - a_zwt, file_hist, 'f_zwt', itime_in_file, sumarea, filter, & - 'the depth to water table','m') - - ! -------------------------------------------------------------------- - ! depth of surface water (including land ice and ocean patches) - ! -------------------------------------------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = (patchtype <= 4) - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! water storage in aquifer [mm] - CALL write_history_variable_2d ( DEF_hist_vars%wa, & - a_wa, file_hist, 'f_wa', itime_in_file, sumarea, filter, & - 'water storage in aquifer','mm') - - ! instantaneous water storage in aquifer [mm] - IF (p_is_compute) THEN - vecacc = wa - WHERE(vecacc /= spval) vecacc = vecacc * nac - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%wa_inst, & - vecacc, file_hist, 'f_wa_inst', itime_in_file, sumarea, filter, & - 'instantaneous water storage in aquifer','mm') - - ! depth of surface water [mm] - CALL write_history_variable_2d ( DEF_hist_vars%wdsrf, & - a_wdsrf, file_hist, 'f_wdsrf', itime_in_file, sumarea, filter, & - 'depth of surface water','mm') - - ! instantaneous depth of surface water [mm] - IF (p_is_compute) THEN - vecacc = wdsrf - WHERE(vecacc /= spval) vecacc = vecacc * nac - ENDIF - CALL write_history_variable_2d ( DEF_hist_vars%wdsrf_inst, & - vecacc, file_hist, 'f_wdsrf_inst', itime_in_file, sumarea, filter, & - 'instantaneous depth of surface water','mm') - - ! ----------------------------------------------- - ! Land water bodies' ice fraction and temperature - ! ----------------------------------------------- - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - filter(:) = patchtype == 4 - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (trim(file_hist) /= trim(file_last)) THEN - CALL hist_write_var_real8_2d (file_hist, 'area_lake', ghist, -1, sumarea, & - compress = 1, longname = 'area of lake', units = 'km2') - ENDIF - ENDIF - - ! lake layer depth [m] - CALL write_history_variable_3d ( DEF_hist_vars%dz_lake .and. DEF_USE_Dynamic_Lake, & - a_dz_lake, file_hist, 'f_dz_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, & - 'lake layer thickness','m') - - ! lake temperature [K] - CALL write_history_variable_3d ( DEF_hist_vars%t_lake, & - a_t_lake, file_hist, 'f_t_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, & - 'lake temperature','K') - - ! lake ice fraction cover [0-1] - CALL write_history_variable_3d ( DEF_hist_vars%lake_icefrac, & - a_lake_icefrac, file_hist, 'f_lake_icefrac', itime_in_file, 'lake', 1, nl_lake, & - sumarea, filter, 'lake ice fraction cover','0-1') - - ! lake water deficit due to evaporation [mm/s] - IF (.not. DEF_USE_Dynamic_Lake) THEN - CALL write_history_variable_2d ( DEF_hist_vars%lake_deficit, & - a_lake_deficit, file_hist, 'f_lake_deficit', itime_in_file, sumarea, filter, & - 'lake water deficit due to evaporation','mm/s') - ENDIF - -#ifdef EXTERNAL_LAKE - CALL LakeVarsSaveHist (nl_lake, file_hist, HistForm, itime_in_file, sumarea, filter) -#endif - - ! -------------------------------- - ! Retrieve through averaged fluxes - ! -------------------------------- - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - filter(:) = patchtype < 99 - - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - - filter = filter .and. patchmask - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! u* in similarity theory [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%ustar, & - a_ustar, file_hist, 'f_ustar', itime_in_file, sumarea, filter, & - 'u* in similarity theory based on patch','m/s') - - ! u* in similarity theory [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%ustar2, & - a_ustar2, file_hist, 'f_ustar2', itime_in_file, sumarea, filter, & - 'u* in similarity theory based on grid','m/s') - - ! t* in similarity theory [K] - CALL write_history_variable_2d ( DEF_hist_vars%tstar, & - a_tstar, file_hist, 'f_tstar', itime_in_file, sumarea, filter, & - 't* in similarity theory','K') - - ! q* in similarity theory [kg/kg] - CALL write_history_variable_2d ( DEF_hist_vars%qstar, & - a_qstar, file_hist, 'f_qstar', itime_in_file, sumarea, filter, & - 'q* in similarity theory', 'kg/kg') - - ! dimensionless height (z/L) used in Monin-Obukhov theory - CALL write_history_variable_2d ( DEF_hist_vars%zol, & - a_zol, file_hist, 'f_zol', itime_in_file, sumarea, filter, & - 'dimensionless height (z/L) used in Monin-Obukhov theory','-') - - ! bulk Richardson number in surface layer - CALL write_history_variable_2d ( DEF_hist_vars%rib, & - a_rib, file_hist, 'f_rib', itime_in_file, sumarea, filter, & - 'bulk Richardson number in surface layer','-') - - ! integral of profile FUNCTION for momentum - CALL write_history_variable_2d ( DEF_hist_vars%fm, & - a_fm, file_hist, 'f_fm', itime_in_file, sumarea, filter, & - 'integral of profile FUNCTION for momentum','-') - - ! integral of profile FUNCTION for heat - CALL write_history_variable_2d ( DEF_hist_vars%fh, & - a_fh, file_hist, 'f_fh', itime_in_file, sumarea, filter, & - 'integral of profile FUNCTION for heat','-') - - ! integral of profile FUNCTION for moisture - CALL write_history_variable_2d ( DEF_hist_vars%fq, & - a_fq, file_hist, 'f_fq', itime_in_file, sumarea, filter, & - 'integral of profile FUNCTION for moisture','-') - - ! 10m u-velocity [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%us10m, & - a_us10m, file_hist, 'f_us10m', itime_in_file, sumarea, filter, & - '10m u-velocity','m/s') - - ! 10m v-velocity [m/s] - CALL write_history_variable_2d ( DEF_hist_vars%vs10m, & - a_vs10m, file_hist, 'f_vs10m', itime_in_file, sumarea, filter, & - '10m v-velocity','m/s') - - ! integral of profile FUNCTION for momentum at 10m [-] - CALL write_history_variable_2d ( DEF_hist_vars%fm10m, & - a_fm10m, file_hist, 'f_fm10m', itime_in_file, sumarea, filter, & - 'integral of profile FUNCTION for momentum at 10m','-') - - ! total reflected solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%sr, & - a_sr, file_hist, 'f_sr', itime_in_file, sumarea, filter, & - 'reflected solar radiation at surface [W/m2]','W/m2') - - ! incident direct beam vis solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solvd, & - a_solvd, file_hist, 'f_solvd', itime_in_file, sumarea, filter, & - 'incident direct beam vis solar radiation (W/m2)','W/m2') - - ! incident diffuse beam vis solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solvi, & - a_solvi, file_hist, 'f_solvi', itime_in_file, sumarea, filter, & - 'incident diffuse beam vis solar radiation (W/m2)','W/m2') - - ! incident direct beam nir solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solnd, & - a_solnd, file_hist, 'f_solnd', itime_in_file, sumarea, filter, & - 'incident direct beam nir solar radiation (W/m2)','W/m2') - - ! incident diffuse beam nir solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solni, & - a_solni, file_hist, 'f_solni', itime_in_file, sumarea, filter, & - 'incident diffuse beam nir solar radiation (W/m2)','W/m2') - - ! reflected direct beam vis solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srvd, & - a_srvd, file_hist, 'f_srvd', itime_in_file, sumarea, filter, & - 'reflected direct beam vis solar radiation (W/m2)','W/m2') - - ! reflected diffuse beam vis solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srvi, & - a_srvi, file_hist, 'f_srvi', itime_in_file, sumarea, filter, & - 'reflected diffuse beam vis solar radiation (W/m2)','W/m2') - - ! reflected direct beam nir solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srnd, & - a_srnd, file_hist, 'f_srnd', itime_in_file, sumarea, filter, & - 'reflected direct beam nir solar radiation (W/m2)','W/m2') - - ! reflected diffuse beam nir solar radiation (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srni, & - a_srni, file_hist, 'f_srni', itime_in_file, sumarea, filter, & - 'reflected diffuse beam nir solar radiation (W/m2)','W/m2') - - ! local noon fluxes - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - filter(:) = nac_ln > 0 - IF (DEF_forcing%has_missing_value) THEN - filter = filter .and. forcmask_pch - ENDIF - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - ! incident direct beam vis solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solvdln, & - a_solvdln, file_hist, 'f_solvdln', itime_in_file, sumarea, filter, & - 'incident direct beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! incident diffuse beam vis solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solviln, & - a_solviln, file_hist, 'f_solviln', itime_in_file, sumarea, filter, & - 'incident diffuse beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! incident direct beam nir solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solndln, & - a_solndln, file_hist, 'f_solndln', itime_in_file, sumarea, filter, & - 'incident direct beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! incident diffuse beam nir solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%solniln, & - a_solniln, file_hist, 'f_solniln', itime_in_file, sumarea, filter, & - 'incident diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! reflected direct beam vis solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srvdln, & - a_srvdln, file_hist, 'f_srvdln', itime_in_file, sumarea, filter, & - 'reflected direct beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! reflected diffuse beam vis solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srviln, & - a_srviln, file_hist, 'f_srviln', itime_in_file, sumarea, filter, & - 'reflected diffuse beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! reflected direct beam nir solar radiation at local noon (W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srndln, & - a_srndln, file_hist, 'f_srndln', itime_in_file, sumarea, filter, & - 'reflected direct beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) - - ! reflected diffuse beam nir solar radiation at local noon(W/m2) - CALL write_history_variable_2d ( DEF_hist_vars%srniln, & - a_srniln, file_hist, 'f_srniln', itime_in_file, sumarea, filter, & - 'reflected diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln) - - - IF ((p_is_compute) .and. (numpatch > 0)) THEN - filter = (patchtype == 0) .and. patchmask - IF (DEF_forcing%has_missing_value) filter = filter .and. forcmask_pch - ENDIF - IF (HistForm == 'Gridded') THEN - CALL mp2g_hist%get_sumarea (sumarea, filter) - ENDIF - - CALL write_history_variable_3d ( DEF_hist_vars%sensors, & - a_sensors, file_hist, 'f_sensors', itime_in_file, 'sensor', 1, nsensor, & - sumarea, filter, 'variable sensors','user defined') - -#ifdef CatchLateralFlow - CALL hist_basin_out (file_hist, idate) -#endif - -#ifdef GridRiverLakeFlow - CALL hist_grid_riverlake_out (file_hist, HistForm, idate, & - itime_in_file, trim(file_hist)/=trim(file_last)) - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - allocate (nac_one (numpatch)) - nac_one = 1. - ENDIF - ENDIF - - IF (HistForm == 'Gridded') THEN - IF (p_is_active) CALL allocate_block_data (ghist, sumarea_one) - IF (p_is_active) CALL flush_block_data (sumarea_one, 1.) - ENDIF - - CALL write_history_variable_2d ( DEF_hist_vars%riv_height, a_wdsrf_ucat_pch, & - file_hist, 'f_wdpth_ucat_regrid', itime_in_file, sumarea_ucat, filter_ucat, & - 'regridded deepest water depth in river and flood plain', 'm', nac_one) - - CALL write_history_variable_2d ( DEF_hist_vars%riv_veloct, a_veloc_riv_pch, & - file_hist, 'f_veloc_riv_regrid', itime_in_file, sumarea_ucat, filter_ucat, & - 'regridded water velocity in river', 'm/s', nac_one) - - CALL write_history_variable_2d ( DEF_hist_vars%discharge, a_discharge_pch, & - file_hist, 'f_discharge', itime_in_file, sumarea_one, filter_ucat, & - 'regridded discharge in river and flood plain', 'm^3/s', & - nac_one, input_mode = 'total') - - CALL write_history_variable_2d ( DEF_hist_vars%discharge, a_dis_rmth_pch, & - file_hist, 'f_discharge_rivermouth_regrid', itime_in_file, sumarea_one, & - filter_ucat, 'regridded river mouth discharge into ocean', 'm^3/s', & - nac_one, input_mode = 'total') - - CALL write_history_variable_2d ( DEF_hist_vars%floodfrc, a_floodfrc_pch, & - file_hist, 'f_floodfrc', itime_in_file, sumarea_inpm, filter_inpm, & - 'flooded area fraction', '100%', nac_one) - - IF (trim(HistForm) == 'Gridded') THEN - CALL write_history_variable_2d ( DEF_hist_vars%floodarea, a_floodfrc_pch, & - file_hist, 'f_floodarea', itime_in_file, sumarea_one, filter_inpm, & - 'flooded area', 'km^2', nac_one) - ENDIF - - IF (allocated(nac_one )) deallocate (nac_one ) -#endif - - IF (allocated(filter )) deallocate (filter ) - IF (allocated(filter_dt )) deallocate (filter_dt ) -#ifdef URBAN_MODEL - IF (allocated(filter_urb)) deallocate (filter_urb) -#endif - - CALL FLUSH_acc_fluxes () - -#ifdef SinglePoint - IF (USE_SITE_HistWriteBack .and. memory_to_disk) THEN - itime_mem = 0 - ENDIF -#endif - - file_last = file_hist - - ENDIF - - END SUBROUTINE hist_out - - - SUBROUTINE write_history_variable_2d ( is_hist, & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & - longname, units, acc_num, input_mode) - - USE MOD_Vars_1DAccFluxes, only: nac - - IMPLICIT NONE - - logical, intent(in) :: is_hist - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - real(r8), intent(in), optional :: acc_num(:) - - character(len=*), intent(in), optional :: input_mode - - IF (.not. is_hist) RETURN - -#ifndef SinglePoint - IF ( .not. present(acc_num) ) THEN - IF (p_is_compute) & - WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - ELSE - IF (p_is_compute) & - WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num - ENDIF -#else - IF ( .not. present(acc_num) ) THEN - WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - ELSE - WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num - ENDIF -#endif - - select CASE (HistForm) - CASE ('Gridded') - IF (present(input_mode)) THEN - CALL flux_map_and_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units, input_mode) - ELSE - CALL flux_map_and_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) - ENDIF -#if (defined UNSTRUCTURED || defined CATCHMENT) - CASE ('Vector') - IF (present(input_mode)) THEN - CALL aggregate_to_vector_and_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, filter, longname, units, input_mode) - ELSE - CALL aggregate_to_vector_and_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, filter, longname, units) - ENDIF -#endif -#ifdef SinglePoint - CASE ('Single') - CALL single_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, longname, units) -#endif - END select - - END SUBROUTINE write_history_variable_2d - - -#ifdef URBAN_MODEL - SUBROUTINE write_history_variable_urb_2d ( is_hist, & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & - longname, units) - - IMPLICIT NONE - - logical, intent(in) :: is_hist - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - - IF (.not. is_hist) RETURN - - select CASE (HistForm) - CASE ('Gridded') - CALL flux_map_and_write_urb_2d ( & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) -#if (defined UNSTRUCTURED || defined CATCHMENT) - CASE ('Vector') - !TODO: currently, it is not applicable to urban variables - CALL aggregate_to_vector_and_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, filter, longname, units) -#endif -#ifdef SinglePoint - CASE ('Single') - CALL single_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, longname, units) -#endif - END select - - END SUBROUTINE write_history_variable_urb_2d -#endif - - - SUBROUTINE write_history_variable_3d ( is_hist, & - acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & - sumarea, filter, longname, units) - - IMPLICIT NONE - - logical, intent(in) :: is_hist - - real(r8), intent(inout) :: acc_vec(:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name - integer, intent(in) :: lb1, ndim1 - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in) :: longname - character (len=*), intent(in) :: units - - ! Local variables - integer :: iblkme, xblk, yblk, xloc, yloc, i1 - integer :: compress - - IF (.not. is_hist) RETURN - - select CASE (HistForm) - CASE ('Gridded') - CALL flux_map_and_write_3d ( & - acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & - sumarea, filter, longname, units) -#if (defined UNSTRUCTURED || defined CATCHMENT) - CASE ('Vector') - CALL aggregate_to_vector_and_write_3d ( & - acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & - filter, longname, units) -#endif -#ifdef SinglePoint - CASE ('Single') - CALL single_write_3d (acc_vec, file_hist, varname, itime_in_file, & - dim1name, ndim1, longname, units) -#endif - END select - - END SUBROUTINE write_history_variable_3d - - - SUBROUTINE write_history_variable_4d ( is_hist, & - acc_vec, file_hist, varname, itime_in_file, & - dim1name, lb1, ndim1, dim2name, lb2, ndim2, & - sumarea, filter, longname, units, acc_num) - - IMPLICIT NONE - - logical, intent(in) :: is_hist - - real(r8), intent(inout) :: acc_vec(:,:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name, dim2name - integer, intent(in) :: lb1, ndim1, lb2, ndim2 - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in) :: longname - character (len=*), intent(in) :: units - real(r8), intent(in), optional:: acc_num(:) - - ! Local variables - integer :: i1, i2 - - IF (.not. is_hist) RETURN - -#ifndef SinglePoint - IF ( .not. present(acc_num) ) THEN - IF (p_is_compute) & - WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - ELSE - IF (p_is_compute) THEN - DO i1 = lbound(acc_vec,1), ubound(acc_vec,1) - DO i2 = lbound(acc_vec,2), ubound(acc_vec,2) - WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) & - acc_vec(i1,i2,:) = acc_vec(i1,i2,:) / acc_num - ENDDO - ENDDO - ENDIF - ENDIF -#else - IF ( .not. present(acc_num) ) THEN - WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - ELSE - DO i1 = lbound(acc_vec,1), ubound(acc_vec,1) - DO i2 = lbound(acc_vec,2), ubound(acc_vec,2) - WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) & - acc_vec(i1,i2,:) = acc_vec(i1,i2,:) / acc_num - ENDDO - ENDDO - ENDIF -#endif - - select CASE (HistForm) - CASE ('Gridded') - CALL flux_map_and_write_4d ( & - acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & - dim2name, lb2, ndim2, sumarea, filter, longname, units) -#if (defined UNSTRUCTURED || defined CATCHMENT) - CASE ('Vector') - CALL aggregate_to_vector_and_write_4d ( & - acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & - dim2name, lb2, ndim2, filter, longname, units) -#endif -#ifdef SinglePoint - CASE ('Single') - CALL single_write_4d (acc_vec, file_hist, varname, itime_in_file, & - dim1name, ndim1, dim2name, ndim2, longname, units) -#endif - END select - - END SUBROUTINE write_history_variable_4d - - - SUBROUTINE hist_write_time (filename, filelast, dataname, time, itime) - - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: filelast - character (len=*), intent(in) :: dataname - integer, intent(in) :: time(3) - integer, intent(out) :: itime - - select CASE (HistForm) - CASE ('Gridded') - CALL hist_gridded_write_time (filename, filelast, dataname, time, itime) -#if (defined UNSTRUCTURED || defined CATCHMENT) - CASE ('Vector') - CALL hist_vector_write_time (filename, filelast, dataname, time, itime) -#endif -#ifdef SinglePoint - CASE ('Single') - CALL hist_single_write_time (filename, filelast, dataname, time, itime) -#endif - END select - - END SUBROUTINE hist_write_time - -END MODULE MOD_Hist diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 deleted file mode 100644 index 051f429903..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 +++ /dev/null @@ -1,1079 +0,0 @@ -#include - -MODULE MOD_HistGridded - -!---------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Write out gridded model results to history files. -! -! Original version: Yongjiu Dai, September 15, 1999, 03/2014 -! -! !REVISIONS: -! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version -! -! TODO...(need complement) -!---------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_DataType - USE MOD_SpatialMapping - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_SPMD_Task -#ifdef USEMPI - USE MOD_HistWriteBack -#endif - - type(grid_type), target :: ghist - type(spatial_mapping_type) :: mp2g_hist - type(spatial_mapping_type) :: mp2g_hist_urb - - type(block_data_real8_2d) :: landfraction - - type(grid_concat_type) :: hist_concat - - integer :: hist_data_id - -!-------------------------------------------------------------------------- -CONTAINS - - SUBROUTINE hist_gridded_init (dir_hist, lulcc_call) - - USE MOD_SPMD_Task - USE MOD_Vars_Global - USE MOD_Block - USE MOD_LandPatch -#ifdef URBAN_MODEL - USE MOD_LandUrban -#endif - USE MOD_Vars_1DAccFluxes - USE MOD_Forcing, only: gforc -#ifdef SinglePoint - USE MOD_SingleSrfData -#endif - USE MOD_Utils - IMPLICIT NONE - - character(len=*) , intent(in) :: dir_hist - logical, optional, intent(in) :: lulcc_call - - ! Local Variables - type(block_data_real8_2d) :: gridarea - integer :: iblkme, xblk, yblk, xloc, yloc, xglb, yglb - - IF (DEF_hist_grid_as_forcing) THEN - CALL ghist%define_by_copy (gforc) - ELSE - CALL ghist%define_by_res (DEF_hist_lon_res, DEF_hist_lat_res) - ENDIF - - IF (present(lulcc_call)) CALL mp2g_hist%forc_free_mem - CALL mp2g_hist%build_arealweighted (ghist, landpatch) - -#ifdef URBAN_MODEL - IF (present(lulcc_call)) CALL mp2g_hist_urb%forc_free_mem - CALL mp2g_hist_urb%build_arealweighted (ghist, landurban) -#endif - - IF (p_is_active) THEN - CALL allocate_block_data (ghist, landfraction) - CALL allocate_block_data (ghist, gridarea) - - DO iblkme = 1, gblock%nblkme - xblk = gblock%xblkme(iblkme) - yblk = gblock%yblkme(iblkme) - DO yloc = 1, ghist%ycnt(yblk) - DO xloc = 1, ghist%xcnt(xblk) - xglb = ghist%xdsp(xblk) + xloc - yglb = ghist%ydsp(yblk) + yloc - gridarea%blk(xblk,yblk)%val(xloc,yloc) = areaquad ( & - ghist%lat_s(yglb), ghist%lat_n(yglb), ghist%lon_w(xglb), ghist%lon_e(xglb)) - ENDDO - ENDDO - ENDDO - ENDIF - - CALL mp2g_hist%get_sumarea (landfraction) - CALL block_data_division (landfraction, gridarea) - - CALL hist_concat%set (ghist) -#ifdef SinglePoint - hist_concat%ginfo%lat_c(:) = SITE_lat_location - hist_concat%ginfo%lon_c(:) = SITE_lon_location -#endif - - IF (trim(DEF_HIST_mode) == 'one') THEN - hist_data_id = 10001 - ENDIF - - END SUBROUTINE hist_gridded_init - - - SUBROUTINE flux_map_and_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & - longname, units, input_mode) - - USE MOD_Block - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character(len=*), intent(in), optional :: input_mode - - ! Local variables - type(block_data_real8_2d) :: flux_xy_2d - integer :: iblkme, xblk, yblk, xloc, yloc - integer :: compress - - IF (p_is_active) CALL allocate_block_data (ghist, flux_xy_2d) - - IF (present(input_mode)) THEN - CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter, input_mode = input_mode) - ELSE - CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) - ENDIF - - IF (p_is_active) THEN - DO iblkme = 1, gblock%nblkme - xblk = gblock%xblkme(iblkme) - yblk = gblock%yblkme(iblkme) - - DO yloc = 1, ghist%ycnt(yblk) - DO xloc = 1, ghist%xcnt(xblk) - - IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN - IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN - flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & - = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & - / sumarea%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - ELSE - flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval - ENDIF - - ENDDO - ENDDO - - ENDDO - ENDIF - - compress = DEF_HIST_CompressLevel - CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, & - flux_xy_2d, compress, longname, units) - - END SUBROUTINE flux_map_and_write_2d - - - SUBROUTINE flux_map_and_write_urb_2d ( & - acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & - longname, units) - - USE MOD_Block - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - - ! Local variables - type(block_data_real8_2d) :: flux_xy_2d - integer :: iblkme, xblk, yblk, xloc, yloc - integer :: compress - - IF (p_is_compute) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - IF (p_is_active) CALL allocate_block_data (ghist, flux_xy_2d) - - CALL mp2g_hist_urb%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter) - - IF (p_is_active) THEN - DO iblkme = 1, gblock%nblkme - xblk = gblock%xblkme(iblkme) - yblk = gblock%yblkme(iblkme) - - DO yloc = 1, ghist%ycnt(yblk) - DO xloc = 1, ghist%xcnt(xblk) - - IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN - IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN - flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & - = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) & - / sumarea%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - ELSE - flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval - ENDIF - - ENDDO - ENDDO - - ENDDO - ENDIF - - compress = DEF_HIST_CompressLevel - CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & - compress, longname, units) - - END SUBROUTINE flux_map_and_write_urb_2d - - - SUBROUTINE flux_map_and_write_3d ( & - acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, sumarea, filter, & - longname, units) - - USE MOD_Block - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name - integer, intent(in) :: lb1, ndim1 - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in) :: longname - character (len=*), intent(in) :: units - - ! Local variables - type(block_data_real8_3d) :: flux_xy_3d - integer :: iblkme, xblk, yblk, xloc, yloc, i1 - integer :: compress - - IF (p_is_compute) THEN - WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - ENDIF - IF (p_is_active) THEN - CALL allocate_block_data (ghist, flux_xy_3d, ndim1, lb1) - ENDIF - - CALL mp2g_hist%pset2grid (acc_vec, flux_xy_3d, spv = spval, msk = filter) - - IF (p_is_active) THEN - DO iblkme = 1, gblock%nblkme - xblk = gblock%xblkme(iblkme) - yblk = gblock%yblkme(iblkme) - - DO yloc = 1, ghist%ycnt(yblk) - DO xloc = 1, ghist%xcnt(xblk) - - IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN - DO i1 = flux_xy_3d%lb1, flux_xy_3d%ub1 - IF (flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) /= spval) THEN - flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) & - = flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) & - / sumarea%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - ENDDO - ELSE - flux_xy_3d%blk(xblk,yblk)%val(:,xloc,yloc) = spval - ENDIF - - ENDDO - ENDDO - - ENDDO - ENDIF - - compress = DEF_HIST_CompressLevel - CALL hist_write_var_real8_3d (file_hist, varname, dim1name, ghist, & - itime_in_file, flux_xy_3d, compress, longname, units) - - END SUBROUTINE flux_map_and_write_3d - - - SUBROUTINE flux_map_and_write_4d ( & - acc_vec, file_hist, varname, itime_in_file, & - dim1name, lb1, ndim1, dim2name, lb2, ndim2, & - sumarea, filter, longname, units) - - USE MOD_Block - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:,:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name, dim2name - integer, intent(in) :: lb1, ndim1, lb2, ndim2 - - type(block_data_real8_2d), intent(in) :: sumarea - logical, intent(in) :: filter(:) - character (len=*), intent(in) :: longname - character (len=*), intent(in) :: units - - ! Local variables - type(block_data_real8_4d) :: flux_xy_4d - integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2 - integer :: compress - - IF (p_is_active) THEN - CALL allocate_block_data (ghist, flux_xy_4d, ndim1, ndim2, lb1 = lb1, lb2 = lb2) - ENDIF - - CALL mp2g_hist%pset2grid (acc_vec, flux_xy_4d, spv = spval, msk = filter) - - IF (p_is_active) THEN - DO iblkme = 1, gblock%nblkme - xblk = gblock%xblkme(iblkme) - yblk = gblock%yblkme(iblkme) - - DO yloc = 1, ghist%ycnt(yblk) - DO xloc = 1, ghist%xcnt(xblk) - - IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN - DO i1 = flux_xy_4d%lb1, flux_xy_4d%ub1 - DO i2 = flux_xy_4d%lb2, flux_xy_4d%ub2 - IF (flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spval) THEN - flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) & - = flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) & - / sumarea%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - ENDDO - ENDDO - ELSE - flux_xy_4d%blk(xblk,yblk)%val(:,:,xloc,yloc) = spval - ENDIF - - ENDDO - ENDDO - - ENDDO - ENDIF - - compress = DEF_HIST_CompressLevel - CALL hist_write_var_real8_4d (file_hist, varname, dim1name, dim2name, & - ghist, itime_in_file, flux_xy_4d, compress, longname, units) - - END SUBROUTINE flux_map_and_write_4d - - - SUBROUTINE hist_gridded_write_time ( & - filename, filelast, dataname, time, itime) - - USE MOD_Block - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: filelast - character (len=*), intent(in) :: dataname - - integer, intent(in) :: time(3) - integer, intent(out) :: itime - - ! Local variables - character(len=256) :: fileblock - integer :: iblkme, iblk, jblk - logical :: fexists - - itime = 0 - IF (trim(DEF_HIST_mode) == 'one') THEN - IF (p_is_root) THEN -#ifdef USEMPI - IF (DEF_HIST_WriteBack) THEN - CALL hist_writeback_latlon_time (filename, filelast, dataname, time, hist_concat) - itime = 1 - ELSE -#endif - inquire (file=filename, exist=fexists) - IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN - - CALL ncio_create_file (trim(filename)) - CALL ncio_define_dimension(filename, 'time', 0) - CALL ncio_define_dimension(filename, 'lat' , hist_concat%ginfo%nlat) - CALL ncio_define_dimension(filename, 'lon' , hist_concat%ginfo%nlon) - - CALL ncio_write_serial (filename, 'lat', hist_concat%ginfo%lat_c, 'lat') - CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') - CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - - CALL ncio_write_serial (filename, 'lon', hist_concat%ginfo%lon_c, 'lon') - CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') - CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') - -#ifndef SinglePoint - CALL ncio_write_serial (filename, 'lat_s', hist_concat%ginfo%lat_s, 'lat') - CALL ncio_write_serial (filename, 'lat_n', hist_concat%ginfo%lat_n, 'lat') - CALL ncio_write_serial (filename, 'lon_w', hist_concat%ginfo%lon_w, 'lon') - CALL ncio_write_serial (filename, 'lon_e', hist_concat%ginfo%lon_e, 'lon') -#endif - - CALL ncio_write_colm_dimension (filename) - - ENDIF - - CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) - -#ifdef USEMPI - ENDIF -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (itime, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) -#endif - - ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - - IF (p_is_active) THEN - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - IF (ghist%ycnt(jblk) <= 0) CYCLE - IF (ghist%xcnt(iblk) <= 0) CYCLE - - CALL get_filename_block (filename, iblk, jblk, fileblock) - - inquire (file=fileblock, exist=fexists) - IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN - CALL ncio_create_file (trim(fileblock)) - CALL ncio_define_dimension (fileblock, 'time', 0) - CALL hist_write_grid_info (fileblock, ghist, iblk, jblk) - ENDIF - - CALL ncio_write_time (fileblock, dataname, time, itime, DEF_HIST_FREQ) - - ENDDO - - ENDIF -#ifdef USEMPI -#ifdef MPAS_EMBEDDED_COLM - CALL mpi_allreduce (MPI_IN_PLACE, itime, 1, MPI_INTEGER, MPI_MAX, p_comm_group, p_err) -#else - IF (.not. p_is_root) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) -#endif -#endif - - ENDIF - - END SUBROUTINE hist_gridded_write_time - - - SUBROUTINE hist_write_var_real8_2d ( & - filename, dataname, grid, itime, wdata, compress, longname, units) - - USE MOD_Block - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - type (grid_type), intent(in) :: grid - integer, intent(in) :: itime - - type (block_data_real8_2d), intent(in) :: wdata - - integer, intent(in) :: compress - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp - integer :: rmesg(3), smesg(3), isrc - character(len=256) :: fileblock - real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:) - - IF (trim(DEF_HIST_mode) == 'one') THEN - - IF (p_is_root) THEN - -#ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN - - allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) - vdata(:,:) = spval - - DO idata = 1, hist_concat%ndatablk - CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & - hist_data_id, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - allocate (rbuf(xcnt,ycnt)) - - CALL mpi_recv (rbuf, xcnt*ycnt, MPI_REAL8, & - isrc, hist_data_id, p_comm_glb, p_stat, p_err) - - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf - deallocate (rbuf) - - ENDDO - - ELSE - IF (itime == -1) THEN - CALL hist_writeback_var_header (hist_data_id, filename, dataname, & - 2, 'lon', 'lat', '', '', '', compress, longname, units) - ELSE - CALL hist_writeback_var_header (hist_data_id, filename, dataname, & - 3, 'lon', 'lat', 'time', '', '', compress, longname, units) - ENDIF - ENDIF -#else - allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) - vdata(:,:) = spval - - DO iyseg = 1, hist_concat%nyseg - DO ixseg = 1, hist_concat%nxseg - iblk = hist_concat%xsegs(ixseg)%blk - jblk = hist_concat%ysegs(iyseg)%blk - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - xbdsp = hist_concat%xsegs(ixseg)%bdsp - ybdsp = hist_concat%ysegs(iyseg)%bdsp - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & - wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - ENDIF - ENDDO - ENDDO -#endif - -#ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN -#endif - IF (itime >= 1) THEN - - CALL ncio_write_serial_time (filename, dataname, itime, vdata, & - 'lon', 'lat', 'time', compress) - - ELSEIF (itime == -1) THEN - CALL ncio_write_serial (filename, dataname, vdata, 'lon', 'lat', compress) - ENDIF - - IF (itime <= 1) THEN - CALL ncio_put_attr (filename, dataname, 'long_name', longname) - CALL ncio_put_attr (filename, dataname, 'units', units) - CALL ncio_put_attr (filename, dataname, 'missing_value', spval) - ENDIF - - deallocate (vdata) -#ifdef USEMPI - ENDIF -#endif - - ENDIF - -#ifdef USEMPI - IF (p_is_active) THEN - DO iyseg = 1, hist_concat%nyseg - DO ixseg = 1, hist_concat%nxseg - - iblk = hist_concat%xsegs(ixseg)%blk - jblk = hist_concat%ysegs(iyseg)%blk - - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - xbdsp = hist_concat%xsegs(ixseg)%bdsp - ybdsp = hist_concat%ysegs(iyseg)%bdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - allocate (sbuf (xcnt,ycnt)) - sbuf = wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - - IF (.not. DEF_HIST_WriteBack) THEN - smesg = (/p_iam_glb, ixseg, iyseg/) - CALL mpi_send (smesg, 3, MPI_INTEGER, & - p_address_root, hist_data_id, p_comm_glb, p_err) - CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, & - p_address_root, hist_data_id, p_comm_glb, p_err) - ELSE - CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata2d = sbuf) - ENDIF - - deallocate (sbuf) - - ENDIF - ENDDO - ENDDO - ENDIF -#endif - - hist_data_id = mod(hist_data_id-10000,10000) + 100001 - - ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - - IF (p_is_active) THEN - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE - - CALL get_filename_block (filename, iblk, jblk, fileblock) - - IF (itime >= 1) THEN - - CALL ncio_write_serial_time (fileblock, dataname, itime, & - wdata%blk(iblk,jblk)%val, 'lon', 'lat', 'time', compress) - - ELSEIF (itime == -1) THEN - CALL ncio_write_serial (fileblock, dataname, & - wdata%blk(iblk,jblk)%val, 'lon', 'lat', compress) - ENDIF - - ENDDO - - ENDIF - ENDIF - - END SUBROUTINE hist_write_var_real8_2d - - - SUBROUTINE hist_write_var_real8_3d ( & - filename, dataname, dim1name, grid, itime, wdata, compress, longname, units) - - USE MOD_Block - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - character (len=*), intent(in) :: dim1name - type (grid_type), intent(in) :: grid - integer, intent(in) :: itime - - type (block_data_real8_3d), intent(in) :: wdata - - integer, intent(in) :: compress - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: xcnt, ycnt, ndim1, xbdsp, ybdsp, xgdsp, ygdsp, idim1 - integer :: rmesg(4), smesg(4), isrc - character(len=256) :: fileblock - real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) - - IF (trim(DEF_HIST_mode) == 'one') THEN - - IF (p_is_root) THEN - -#ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN - - DO idata = 1, hist_concat%ndatablk - - CALL mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, & - hist_data_id, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - ndim1 = rmesg(4) - - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - allocate (rbuf (ndim1,xcnt,ycnt)) - - CALL mpi_recv (rbuf, ndim1*xcnt*ycnt, MPI_REAL8, & - isrc, hist_data_id, p_comm_glb, p_stat, p_err) - - IF (idata == 1) THEN - allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat, ndim1)) - vdata(:,:,:) = spval - ENDIF - - DO idim1 = 1, ndim1 - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1) = rbuf(idim1,:,:) - ENDDO - - deallocate (rbuf) - ENDDO - - ELSE - CALL hist_writeback_var_header (hist_data_id, filename, dataname, & - 4, 'lon', 'lat', dim1name, 'time', '', compress, longname, units) - ENDIF -#else - ndim1 = wdata%ub1 - wdata%lb1 + 1 - allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat, ndim1)) - vdata(:,:,:) = spval - - DO iyseg = 1, hist_concat%nyseg - DO ixseg = 1, hist_concat%nxseg - iblk = hist_concat%xsegs(ixseg)%blk - jblk = hist_concat%ysegs(iyseg)%blk - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - xbdsp = hist_concat%xsegs(ixseg)%bdsp - ybdsp = hist_concat%ysegs(iyseg)%bdsp - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - DO idim1 = 1, ndim1 - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt,idim1) = & - wdata%blk(iblk,jblk)%val(wdata%lb1+idim1-1,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - ENDDO - ENDIF - ENDDO - ENDDO -#endif - - -#ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN -#endif - CALL ncio_define_dimension (filename, dim1name, ndim1) - - CALL ncio_write_serial_time (filename, dataname, itime, & - vdata, 'lon', 'lat', dim1name, 'time', compress) - - IF (itime == 1) THEN - CALL ncio_put_attr (filename, dataname, 'long_name', longname) - CALL ncio_put_attr (filename, dataname, 'units', units) - CALL ncio_put_attr (filename, dataname, 'missing_value', spval) - ENDIF - - deallocate (vdata) -#ifdef USEMPI - ENDIF -#endif - ENDIF - -#ifdef USEMPI - IF (p_is_active) THEN - - DO iyseg = 1, hist_concat%nyseg - DO ixseg = 1, hist_concat%nxseg - - iblk = hist_concat%xsegs(ixseg)%blk - jblk = hist_concat%ysegs(iyseg)%blk - - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - xbdsp = hist_concat%xsegs(ixseg)%bdsp - ybdsp = hist_concat%ysegs(iyseg)%bdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - ndim1 = size(wdata%blk(iblk,jblk)%val,1) - - allocate (sbuf (ndim1,xcnt,ycnt)) - sbuf = wdata%blk(iblk,jblk)%val(:, xbdsp+1:xbdsp+xcnt, ybdsp+1:ybdsp+ycnt) - - IF (.not. DEF_HIST_WriteBack) THEN - smesg = (/p_iam_glb, ixseg, iyseg, ndim1/) - CALL mpi_send (smesg, 4, MPI_INTEGER, & - p_address_root, hist_data_id, p_comm_glb, p_err) - CALL mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_REAL8, & - p_address_root, hist_data_id, p_comm_glb, p_err) - ELSE - CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata3d = sbuf) - ENDIF - - deallocate (sbuf) - ENDIF - ENDDO - ENDDO - ENDIF -#endif - - hist_data_id = mod(hist_data_id-10000,10000) + 100001 - - ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - - IF (p_is_active) THEN - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE - - CALL get_filename_block (filename, iblk, jblk, fileblock) - - CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) - - CALL ncio_write_serial_time (fileblock, dataname, itime, & - wdata%blk(iblk,jblk)%val, dim1name, 'lon', 'lat', 'time', compress) - - ENDDO - - ENDIF - ENDIF - - END SUBROUTINE hist_write_var_real8_3d - - - SUBROUTINE hist_write_var_real8_4d ( & - filename, dataname, dim1name, dim2name, grid, itime, wdata, compress, longname, units) - - USE MOD_Block - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: dataname - character (len=*), intent(in) :: dim1name, dim2name - type (grid_type), intent(in) :: grid - integer, intent(in) :: itime - - type (block_data_real8_4d), intent(in) :: wdata - - integer, intent(in) :: compress - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: iblkme, iblk, jblk, idata, ixseg, iyseg - integer :: xcnt, ycnt, ndim1, ndim2, xbdsp, ybdsp, xgdsp, ygdsp, idim1, idim2 - integer :: rmesg(5), smesg(5), isrc - character(len=256) :: fileblock - real(r8), allocatable :: rbuf(:,:,:,:), sbuf(:,:,:,:), vdata(:,:,:,:) - - IF (trim(DEF_HIST_mode) == 'one') THEN - - IF (p_is_root) THEN - -#ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN - - DO idata = 1, hist_concat%ndatablk - - CALL mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, & - hist_data_id, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - ndim1 = rmesg(4) - ndim2 = rmesg(5) - - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - allocate (rbuf (ndim1,ndim2,xcnt,ycnt)) - - CALL mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & - isrc, hist_data_id, p_comm_glb, p_stat, p_err) - - IF (idata == 1) THEN - allocate (vdata (hist_concat%ginfo%nlon,hist_concat%ginfo%nlat,ndim1,ndim2)) - vdata(:,:,:,:) = spval - ENDIF - - DO idim1 = 1, ndim1 - DO idim2 = 1, ndim2 - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1, idim2) = rbuf(idim1,idim2,:,:) - ENDDO - ENDDO - - deallocate (rbuf) - ENDDO - - ELSE - CALL hist_writeback_var_header (hist_data_id, filename, dataname, & - 5, 'lon', 'lat', dim1name, dim2name, 'time', compress, longname, units) - ENDIF -#else - ndim1 = wdata%ub1 - wdata%lb1 + 1 - ndim2 = wdata%ub2 - wdata%lb2 + 1 - allocate (vdata (hist_concat%ginfo%nlon,hist_concat%ginfo%nlat,ndim1,ndim2)) - vdata(:,:,:,:) = spval - - DO iyseg = 1, hist_concat%nyseg - DO ixseg = 1, hist_concat%nxseg - iblk = hist_concat%xsegs(ixseg)%blk - jblk = hist_concat%ysegs(iyseg)%blk - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - xbdsp = hist_concat%xsegs(ixseg)%bdsp - ybdsp = hist_concat%ysegs(iyseg)%bdsp - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - DO idim1 = 1, ndim1 - DO idim2 = 1, ndim2 - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1, idim2) = & - wdata%blk(iblk,jblk)%val(idim1,idim2,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - ENDDO - ENDDO - ENDIF - ENDDO - ENDDO - -#endif - -#ifdef USEMPI - IF (.not. DEF_HIST_WriteBack) THEN -#endif - CALL ncio_define_dimension (filename, dim1name, ndim1) - CALL ncio_define_dimension (filename, dim2name, ndim2) - - CALL ncio_write_serial_time (filename, dataname, itime, vdata, & - 'lon', 'lat', dim1name, dim2name, 'time', compress) - - IF (itime == 1) THEN - CALL ncio_put_attr (filename, dataname, 'long_name', longname) - CALL ncio_put_attr (filename, dataname, 'units', units) - CALL ncio_put_attr (filename, dataname, 'missing_value', spval) - ENDIF - - deallocate (vdata) -#ifdef USEMPI - ENDIF -#endif - ENDIF - -#ifdef USEMPI - IF (p_is_active) THEN - - DO iyseg = 1, hist_concat%nyseg - DO ixseg = 1, hist_concat%nxseg - - iblk = hist_concat%xsegs(ixseg)%blk - jblk = hist_concat%ysegs(iyseg)%blk - - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - xbdsp = hist_concat%xsegs(ixseg)%bdsp - ybdsp = hist_concat%ysegs(iyseg)%bdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt - - ndim1 = size(wdata%blk(iblk,jblk)%val,1) - ndim2 = size(wdata%blk(iblk,jblk)%val,2) - allocate (sbuf (ndim1,ndim2,xcnt,ycnt)) - sbuf = wdata%blk(iblk,jblk)%val(:,:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - - IF (.not. DEF_HIST_WriteBack) THEN - smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/) - CALL mpi_send (smesg, 5, MPI_INTEGER, & - p_address_root, hist_data_id, p_comm_glb, p_err) - CALL mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & - p_address_root, hist_data_id, p_comm_glb, p_err) - ELSE - CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata4d = sbuf) - ENDIF - - deallocate (sbuf) - ENDIF - ENDDO - ENDDO - ENDIF -#endif - - hist_data_id = mod(hist_data_id-10000,10000) + 100001 - - ELSEIF (trim(DEF_HIST_mode) == 'block') THEN - IF (p_is_active) THEN - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE - - CALL get_filename_block (filename, iblk, jblk, fileblock) - - CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1) - CALL ncio_define_dimension (fileblock, dim2name, wdata%ub2-wdata%lb2+1) - - CALL ncio_write_serial_time (fileblock, dataname, itime, & - wdata%blk(iblk,jblk)%val, dim1name, dim2name, 'lon', 'lat', 'time', compress) - - ENDDO - - ENDIF - ENDIF - - END SUBROUTINE hist_write_var_real8_4d - - - SUBROUTINE hist_write_grid_info (fileblock, grid, iblk, jblk) - - USE MOD_Block - IMPLICIT NONE - - character(len=*), intent(in) :: fileblock - type (grid_type), intent(in) :: grid - integer, intent(in) :: iblk, jblk - - ! Local variable - integer :: yl, yu, xl, xu, nx - real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:) - - allocate (lon_w (grid%xcnt(iblk))) - allocate (lon_e (grid%xcnt(iblk))) - allocate (lat_s (grid%ycnt(jblk))) - allocate (lat_n (grid%ycnt(jblk))) - - yl = grid%ydsp(jblk) + 1 - yu = grid%ydsp(jblk) + grid%ycnt(jblk) - - lat_s = grid%lat_s(yl:yu) - lat_n = grid%lat_n(yl:yu) - - IF (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) THEN - xl = grid%xdsp(iblk) + 1 - xu = grid%nlon - nx = grid%nlon - grid%xdsp(iblk) - lon_w(1:nx) = grid%lon_w(xl:xu) - lon_e(1:nx) = grid%lon_e(xl:xu) - - xl = 1 - xu = grid%xcnt(iblk) - nx - lon_w(nx+1:grid%xcnt(iblk)) = grid%lon_w(xl:xu) - lon_e(nx+1:grid%xcnt(iblk)) = grid%lon_e(xl:xu) - ELSE - xl = grid%xdsp(iblk) + 1 - xu = grid%xdsp(iblk) + grid%xcnt(iblk) - lon_w = grid%lon_w(xl:xu) - lon_e = grid%lon_e(xl:xu) - ENDIF - - CALL ncio_define_dimension (fileblock, 'lat', grid%ycnt(jblk)) - CALL ncio_define_dimension (fileblock, 'lon', grid%xcnt(iblk)) - CALL ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat') - CALL ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat') - CALL ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon') - CALL ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon') - - CALL ncio_write_colm_dimension (fileblock) - - END SUBROUTINE hist_write_grid_info - -END MODULE MOD_HistGridded diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 deleted file mode 100644 index 2c1b748491..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 +++ /dev/null @@ -1,370 +0,0 @@ -#include - -#ifdef SinglePoint -MODULE MOD_HistSingle - -!---------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Write out model results at sites to history files. -! -! Created by Shupeng Zhang, July 2023 -! -! TODO...(need complement) -!---------------------------------------------------------------------------- - USE MOD_Precision - USE MOD_NetCDFSerial - USE MOD_Namelist, only: USE_SITE_HistWriteBack - USE MOD_SPMD_Task - - logical :: memory_to_disk - - integer :: ntime_mem - integer :: itime_mem - integer, allocatable :: time_memory (:) - - ! -- data type -- - type hist_memory_type - character(len=256) :: varname - real(r8), allocatable :: v2d (:,:) - real(r8), allocatable :: v3d (:,:,:) - real(r8), allocatable :: v4d (:,:,:,:) - type(hist_memory_type), pointer :: next - END type hist_memory_type - - type(hist_memory_type), target :: hist_memory - type(hist_memory_type), pointer :: thisvar, nextvar - -CONTAINS - - ! -- initialize history IO -- - SUBROUTINE hist_single_init () - - USE MOD_Namelist - IMPLICIT NONE - - ! Local Variables - real(r8) :: secs_group, secs_write - - IF (USE_SITE_HistWriteBack) THEN - - IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN - secs_group = 366*24*3600 - ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN - secs_group = 31*24*3600 - ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN - secs_group = 24*3600 - ENDIF - - select CASE (trim(adjustl(DEF_HIST_FREQ))) - CASE ('TIMESTEP') - secs_write = DEF_simulation_time%timestep - CASE ('HOURLY') - secs_write = 3600 - CASE ('DAILY') - secs_write = 24*3600 - CASE ('MONTHLY') - secs_write = 31*24*3600 - CASE ('YEARLY') - secs_write = 366*24*3600 - END select - - ntime_mem = ceiling(secs_group / secs_write) + 2 - - allocate (time_memory (ntime_mem)) - - itime_mem = 0 - - hist_memory%next => null() - hist_memory%varname = '' - - thisvar => hist_memory - - ENDIF - - END SUBROUTINE hist_single_init - - ! -- finalize history IO -- - SUBROUTINE hist_single_final () - - IMPLICIT NONE - - IF (USE_SITE_HistWriteBack) THEN - - thisvar => hist_memory%next - DO WHILE (associated(thisvar)) - nextvar => thisvar%next - IF (allocated(thisvar%v2d)) deallocate(thisvar%v2d) - IF (allocated(thisvar%v3d)) deallocate(thisvar%v3d) - IF (allocated(thisvar%v4d)) deallocate(thisvar%v4d) - deallocate(thisvar) - thisvar => nextvar - ENDDO - - deallocate (time_memory) - - ENDIF - - END SUBROUTINE hist_single_final - - ! -- write history time -- - SUBROUTINE hist_single_write_time (filename, filelast, dataname, time, itime) - - USE MOD_Namelist - USE MOD_TimeManager - USE MOD_SingleSrfData - USE MOD_NetCDFSerial - USE MOD_Landpatch, only: numpatch -#ifdef URBAN_MODEL - USE MOD_Landurban, only: numurban -#endif - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: filelast - character (len=*), intent(in) :: dataname - - integer, intent(in) :: time(3) - integer, intent(out) :: itime - - ! Local variables - integer :: minutes - logical :: fexists - - inquire (file=filename, exist=fexists) - IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN - CALL ncio_create_file (trim(filename)) - CALL ncio_define_dimension(filename, 'patch', numpatch) - - CALL ncio_write_serial (filename, 'lat', SITE_lat_location) - CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') - CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - - CALL ncio_write_serial (filename, 'lon', SITE_lon_location) - CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') - CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') - - CALL ncio_write_colm_dimension (filename) - - IF (.not. USE_SITE_HistWriteBack) THEN - CALL ncio_define_dimension(filename, 'time', 0) - ENDIF - - ENDIF - - IF (USE_SITE_HistWriteBack) THEN - - minutes = minutes_since_1900 (time(1), time(2), time(3)) - - select CASE (trim(adjustl(DEF_HIST_FREQ))) - CASE ('HOURLY') - minutes = minutes - 30 - CASE ('DAILY') - minutes = minutes - 720 - CASE ('MONTHLY') - minutes = minutes - 21600 - CASE ('YEARLY') - minutes = minutes - 262800 - END select - - itime_mem = itime_mem + 1 - time_memory(itime_mem) = minutes - - IF (memory_to_disk) THEN - CALL ncio_define_dimension(filename, 'time', itime_mem) - CALL ncio_write_serial (filename, dataname, time_memory(1:itime_mem), 'time') - CALL ncio_put_attr (filename, dataname, 'long_name', 'time') - CALL ncio_put_attr (filename, dataname, 'units', 'minutes since 1900-1-1 0:0:0') - ENDIF - - thisvar => hist_memory - - ELSE - CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) - ENDIF - - END SUBROUTINE hist_single_write_time - - ! -- write 2D data -- - SUBROUTINE single_write_2d ( & - acc_vec, file_hist, varname, itime_in_file, longname, units) - - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - IF (USE_SITE_HistWriteBack) THEN - - IF (.not. associated(thisvar%next)) THEN - allocate (thisvar%next) - thisvar => thisvar%next - - thisvar%next => null() - thisvar%varname = varname - allocate(thisvar%v2d (size(acc_vec),ntime_mem)) - ELSE - thisvar => thisvar%next - ENDIF - - IF (thisvar%varname /= varname) THEN - write(*,*) 'Warning: history variable in memory is wrong: ' & - // trim(thisvar%varname) // ' should be ' // trim(varname) - CALL CoLM_stop () - ENDIF - - thisvar%v2d(:,itime_mem) = acc_vec(:) - - IF (memory_to_disk) THEN - CALL ncio_write_serial (file_hist, varname, & - thisvar%v2d(:,1:itime_mem), 'patch', 'time') - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - - ELSE - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - 'patch', 'time') - IF (itime_in_file == 1) THEN - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - ENDIF - - END SUBROUTINE single_write_2d - - ! -- write 3D data -- - SUBROUTINE single_write_3d ( & - acc_vec, file_hist, varname, itime_in_file, dim1name, ndim1, longname, units) - - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name - integer, intent(in) :: ndim1 - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - WHERE (acc_vec /= spval) acc_vec = acc_vec / nac - - IF (USE_SITE_HistWriteBack) THEN - - IF (.not. associated(thisvar%next)) THEN - allocate (thisvar%next) - thisvar => thisvar%next - - thisvar%next => null() - thisvar%varname = varname - allocate(thisvar%v3d (ndim1,size(acc_vec,2),ntime_mem)) - ELSE - thisvar => thisvar%next - ENDIF - - IF (thisvar%varname /= varname) THEN - write(*,*) 'Warning: history variable in memory is wrong: ' & - // trim(thisvar%varname) // ' should be ' // trim(varname) - CALL CoLM_stop () - ENDIF - - thisvar%v3d(:,:,itime_mem) = acc_vec - - IF (memory_to_disk) THEN - CALL ncio_define_dimension (file_hist, dim1name, ndim1) - CALL ncio_write_serial (file_hist, varname, thisvar%v3d(:,:,1:itime_mem), & - dim1name, 'patch', 'time') - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - - ELSE - CALL ncio_define_dimension (file_hist, dim1name, ndim1) - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - dim1name, 'patch', 'time') - IF (itime_in_file == 1) THEN - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - ENDIF - - END SUBROUTINE single_write_3d - - ! -- write 4D data -- - SUBROUTINE single_write_4d ( & - acc_vec, file_hist, varname, itime_in_file, & - dim1name, ndim1, dim2name, ndim2, longname, units) - - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(inout) :: acc_vec(:,:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name - integer, intent(in) :: ndim1 - character(len=*), intent(in) :: dim2name - integer, intent(in) :: ndim2 - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - IF (USE_SITE_HistWriteBack) THEN - - IF (.not. associated(thisvar%next)) THEN - allocate (thisvar%next) - thisvar => thisvar%next - - thisvar%next => null() - thisvar%varname = varname - allocate(thisvar%v4d (ndim1,ndim2,size(acc_vec,3),ntime_mem)) - ELSE - thisvar => thisvar%next - ENDIF - - IF (thisvar%varname /= varname) THEN - write(*,*) 'Warning: history variable in memory is wrong: ' & - // trim(thisvar%varname) // ' should be ' // trim(varname) - CALL CoLM_stop () - ENDIF - - thisvar%v4d(:,:,:,itime_mem) = acc_vec - - IF (memory_to_disk) THEN - CALL ncio_define_dimension (file_hist, dim1name, ndim1) - CALL ncio_define_dimension (file_hist, dim2name, ndim2) - CALL ncio_write_serial (file_hist, varname, thisvar%v4d(:,:,:,1:itime_mem), & - dim1name, dim2name, 'patch', 'time') - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - - ELSE - CALL ncio_define_dimension (file_hist, dim1name, ndim1) - CALL ncio_define_dimension (file_hist, dim2name, ndim2) - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - dim1name, dim2name, 'patch', 'time') - IF (itime_in_file == 1) THEN - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - ENDIF - - END SUBROUTINE single_write_4d - -END MODULE MOD_HistSingle -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 deleted file mode 100644 index 3311b4e2e2..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 +++ /dev/null @@ -1,623 +0,0 @@ -#include - -#if (defined UNSTRUCTURED || defined CATCHMENT) -MODULE MOD_HistVector - -!---------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Write out vectorized model results to history files. -! -! Created by Shupeng Zhang, May 2023 -! -! TODO...(need complement) -!---------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Vars_Global, only: spval - USE MOD_Mesh - USE MOD_LandElm -#ifdef CATCHMENT - USE MOD_LandHRU -#endif - USE MOD_Pixelset - USE MOD_NetCDFSerial -#ifdef CATCHMENT - USE MOD_HRUVector -#else - USE MOD_ElmVector -#endif - -CONTAINS - - ! -- write history time -- - SUBROUTINE hist_vector_write_time (filename, filelast, dataname, time, itime_in_file) - - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: filelast - character (len=*), intent(in) :: dataname - integer, intent(in) :: time(3) - integer, intent(out) :: itime_in_file - - ! Local Variables - logical :: fexists - - IF (p_is_root) THEN - - inquire (file=filename, exist=fexists) - IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN - CALL ncio_create_file (trim(filename)) - CALL ncio_define_dimension(filename, 'time', 0) - -#ifdef CATCHMENT - CALL ncio_define_dimension(filename, 'hydrounit', totalnumhru) - - CALL ncio_write_serial (filename, 'bsn_hru', eindx_hru, 'hydrounit') - CALL ncio_put_attr (filename, 'bsn_hru', 'long_name', & - 'basin index of hydrological units in mesh') - - CALL ncio_write_serial (filename, 'typ_hru' , htype_hru, 'hydrounit') - CALL ncio_put_attr (filename, 'typ_hru' , 'long_name', & - 'index of hydrological units inside basin') -#else - CALL ncio_define_dimension(filename, 'element', totalnumelm) - CALL ncio_write_serial (filename, 'elmindex', eindex_glb, 'element') - CALL ncio_put_attr (filename, 'elmindex', 'long_name', & - 'element index in mesh') -#endif - - CALL ncio_write_colm_dimension (filename) - - ENDIF - - CALL ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) - - ENDIF - - END SUBROUTINE hist_vector_write_time - - - SUBROUTINE aggregate_to_vector_and_write_2d ( & - acc_vec_patch, file_hist, varname, itime_in_file, filter, & - longname, units, input_mode) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_LandPatch - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(in) :: acc_vec_patch (:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - logical, intent(in) :: filter(:) - - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - character(len=*), intent(in), optional :: input_mode - - ! Local variables - integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - logical, allocatable :: mask(:) - real(r8), allocatable :: frac(:) - real(r8), allocatable :: acc_vec(:), rcache(:) - real(r8) :: sumwt - character(len=256) :: inmode - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_compute) THEN -#ifdef CATCHMENT - numset = numhru -#else - numset = numelm -#endif - - inmode = 'average' - IF (present(input_mode)) inmode = trim(input_mode) - - IF (numset > 0) THEN - - allocate (acc_vec (numset)) - acc_vec(:) = spval - - DO iset = 1, numset -#ifdef CATCHMENT - istt = hru_patch%substt(iset) - iend = hru_patch%subend(iset) -#else - istt = elm_patch%substt(iset) - iend = elm_patch%subend(iset) -#endif - - IF ((istt > 0) .and. (iend >= istt)) THEN - allocate (mask(istt:iend)) - allocate (frac(istt:iend)) - mask = (acc_vec_patch(istt:iend) /= spval) .and. filter(istt:iend) - IF (any(mask)) THEN - IF (trim(inmode) == 'average') THEN -#ifdef CATCHMENT - frac = hru_patch%subfrc(istt:iend) -#else - frac = elm_patch%subfrc(istt:iend) -#endif - sumwt = sum(frac, mask = mask) - acc_vec(iset) = sum(frac * acc_vec_patch(istt:iend), mask = mask) - acc_vec(iset) = acc_vec(iset) / sumwt - ELSE - acc_vec(iset) = sum(acc_vec_patch(istt:iend), mask = mask) - ENDIF - ENDIF - deallocate(mask) - deallocate(frac) - ENDIF - ENDDO - ENDIF - -#ifdef USEMPI - mesg = (/p_iam_glb, numset/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numset > 0) THEN - CALL mpi_send (acc_vec, numset, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#endif - ENDIF - - IF (p_is_root) THEN - -#ifdef CATCHMENT - totalnumset = totalnumhru -#else - totalnumset = totalnumelm -#endif - - IF (.not. allocated(acc_vec)) THEN - allocate (acc_vec (totalnumset)) - ENDIF - -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate(rcache (ndata)) - CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - -#ifdef CATCHMENT - acc_vec(hru_data_address(p_itis_compute(isrc))%val) = rcache -#else - acc_vec(elm_data_address(p_itis_compute(isrc))%val) = rcache -#endif - - deallocate (rcache) - ENDIF - ENDDO -#else -#ifdef CATCHMENT - acc_vec(hru_data_address(0)%val) = acc_vec -#else - acc_vec(elm_data_address(0)%val) = acc_vec -#endif -#endif - ENDIF - - IF (p_is_root) THEN - - compress = DEF_HIST_CompressLevel - - IF (itime_in_file >= 1) THEN -#ifdef CATCHMENT - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - 'hydrounit', 'time', compress) -#else - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - 'element', 'time', compress) -#endif - ELSE -#ifdef CATCHMENT - CALL ncio_write_serial (file_hist, varname, acc_vec, 'hydrounit', compress) -#else - CALL ncio_write_serial (file_hist, varname, acc_vec, 'element', compress) -#endif - ENDIF - - IF (itime_in_file <= 1) THEN - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - - ENDIF - - IF (allocated(acc_vec)) deallocate (acc_vec) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE aggregate_to_vector_and_write_2d - - - SUBROUTINE aggregate_to_vector_and_write_3d ( & - acc_vec_patch, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, filter, & - longname, units) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_LandPatch - USE MOD_Vars_1DAccFluxes, only: nac - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(in) :: acc_vec_patch (lb1:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name - integer, intent(in) :: lb1, ndim1 - - logical, intent(in) :: filter(:) - - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - integer :: ub1, i1 - logical, allocatable :: mask(:) - real(r8), allocatable :: frac(:) - real(r8), allocatable :: acc_vec(:,:), rcache(:,:) - real(r8) :: sumwt - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ub1 = lb1 + ndim1 - 1 - - IF (p_is_compute) THEN -#ifdef CATCHMENT - numset = numhru -#else - numset = numelm -#endif - - IF (numset > 0) THEN - - allocate (acc_vec (lb1:ub1,numset)) - - acc_vec(:,:) = spval - - DO iset = 1, numset -#ifdef CATCHMENT - istt = hru_patch%substt(iset) - iend = hru_patch%subend(iset) -#else - istt = elm_patch%substt(iset) - iend = elm_patch%subend(iset) -#endif - - IF ((istt > 0) .and. (iend >= istt)) THEN - allocate (mask(istt:iend)) - allocate (frac(istt:iend)) - DO i1 = lb1, ub1 - mask = (acc_vec_patch(i1,istt:iend) /= spval) .and. filter(istt:iend) - IF (any(mask)) THEN -#ifdef CATCHMENT - frac = hru_patch%subfrc(istt:iend) -#else - frac = elm_patch%subfrc(istt:iend) -#endif - sumwt = sum(frac, mask = mask) - acc_vec(i1,iset) = sum(frac * acc_vec_patch(i1,istt:iend), mask = mask) - acc_vec(i1,iset) = acc_vec(i1,iset) / sumwt / nac - ENDIF - ENDDO - deallocate(mask) - deallocate(frac) - ENDIF - ENDDO - ENDIF - -#ifdef USEMPI - mesg = (/p_iam_glb, numset/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numset > 0) THEN - CALL mpi_send (acc_vec, ndim1 * numset, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#endif - ENDIF - - IF (p_is_root) THEN - -#ifdef CATCHMENT - totalnumset = totalnumhru -#else - totalnumset = totalnumelm -#endif - - IF (.not. allocated(acc_vec)) THEN - allocate (acc_vec (ndim1,totalnumset)) - ENDIF - -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate(rcache (ndim1,ndata)) - CALL mpi_recv (rcache, ndim1*ndata, MPI_REAL8, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - DO i1 = 1, ndim1 -#ifdef CATCHMENT - acc_vec(i1,hru_data_address(p_itis_compute(isrc))%val) = rcache(i1,:) -#else - acc_vec(i1,elm_data_address(p_itis_compute(isrc))%val) = rcache(i1,:) -#endif - - ENDDO - - deallocate (rcache) - ENDIF - ENDDO -#else - DO i1 = lb1, ub1 -#ifdef CATCHMENT - acc_vec(i1,hru_data_address(0)%val) = acc_vec(i1,:) -#else - acc_vec(i1,elm_data_address(0)%val) = acc_vec(i1,:) -#endif - ENDDO -#endif - ENDIF - - IF (p_is_root) THEN - - CALL ncio_define_dimension (file_hist, dim1name, ndim1) - - compress = DEF_HIST_CompressLevel - - IF (itime_in_file >= 1) THEN -#ifdef CATCHMENT - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - dim1name, 'hydrounit', 'time', compress) -#else - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - dim1name, 'element', 'time', compress) -#endif - ELSE -#ifdef CATCHMENT - CALL ncio_write_serial (file_hist, varname, acc_vec, & - dim1name, 'hydrounit', compress) -#else - CALL ncio_write_serial (file_hist, varname, acc_vec, & - dim1name, 'element', compress) -#endif - ENDIF - - IF (itime_in_file <= 1) THEN - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - - ENDIF - - IF (allocated(acc_vec)) deallocate (acc_vec) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE aggregate_to_vector_and_write_3d - - - SUBROUTINE aggregate_to_vector_and_write_4d ( & - acc_vec_patch, file_hist, varname, itime_in_file, & - dim1name, lb1, ndim1, dim2name, lb2, ndim2, filter, & - longname, units) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_LandPatch - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - real(r8), intent(in) :: acc_vec_patch (lb1:,lb2:,:) - character(len=*), intent(in) :: file_hist - character(len=*), intent(in) :: varname - integer, intent(in) :: itime_in_file - character(len=*), intent(in) :: dim1name, dim2name - integer, intent(in) :: lb1, ndim1, lb2, ndim2 - - logical, intent(in) :: filter(:) - - character(len=*), intent(in) :: longname - character(len=*), intent(in) :: units - - ! Local variables - integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress - integer :: ub1, i1, ub2, i2 - logical, allocatable :: mask(:) - real(r8), allocatable :: frac(:) - real(r8), allocatable :: acc_vec(:,:,:), rcache(:,:,:) - real(r8) :: sumwt - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ub1 = lb1 + ndim1 - 1 - ub2 = lb2 + ndim2 - 1 - - IF (p_is_compute) THEN -#ifdef CATCHMENT - numset = numhru -#else - numset = numelm -#endif - - IF (numset > 0) THEN - - allocate (acc_vec (lb1:ub1,lb2:ub2,numset)) - - acc_vec(:,:,:) = spval - - DO iset = 1, numset -#ifdef CATCHMENT - istt = hru_patch%substt(iset) - iend = hru_patch%subend(iset) -#else - istt = elm_patch%substt(iset) - iend = elm_patch%subend(iset) -#endif - - IF ((istt > 0) .and. (iend >= istt)) THEN - allocate (mask(istt:iend)) - allocate (frac(istt:iend)) - DO i1 = lb1, ub1 - DO i2 = lb2, ub2 - mask = (acc_vec_patch(i1,i2,istt:iend) /= spval) .and. filter(istt:iend) - IF (any(mask)) THEN -#ifdef CATCHMENT - frac = hru_patch%subfrc(istt:iend) -#else - frac = elm_patch%subfrc(istt:iend) -#endif - sumwt = sum(frac, mask = mask) - acc_vec(i1,i2,iset) = sum(frac * acc_vec_patch(i1,i2,istt:iend), mask = mask) - acc_vec(i1,i2,iset) = acc_vec(i1,i2,iset) / sumwt - ENDIF - ENDDO - ENDDO - deallocate(mask) - deallocate(frac) - ENDIF - ENDDO - ENDIF - -#ifdef USEMPI - mesg = (/p_iam_glb, numset/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numset > 0) THEN - CALL mpi_send (acc_vec, ndim1 * ndim2 * numset, MPI_REAL8, & - p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#endif - ENDIF - - IF (p_is_root) THEN - -#ifdef CATCHMENT - totalnumset = totalnumhru -#else - totalnumset = totalnumelm -#endif - - IF (.not. allocated(acc_vec)) THEN - allocate (acc_vec (ndim1,ndim2,totalnumset)) - ENDIF - -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate(rcache (ndim1,ndim2,ndata)) - CALL mpi_recv (rcache, ndim1 * ndim2 * ndata, MPI_REAL8, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - DO i1 = 1, ndim1 - DO i2 = 1, ndim2 -#ifdef CATCHMENT - acc_vec(i1,i2,hru_data_address(p_itis_compute(isrc))%val) = rcache(i1,i2,:) -#else - acc_vec(i1,i2,elm_data_address(p_itis_compute(isrc))%val) = rcache(i1,i2,:) -#endif - ENDDO - ENDDO - - deallocate (rcache) - ENDIF - ENDDO -#else - DO i1 = lb1, ub1 - DO i2 = lb2, ub2 -#ifdef CATCHMENT - acc_vec(i1,i2,hru_data_address(0)%val) = acc_vec(i1,i2,:) -#else - acc_vec(i1,i2,elm_data_address(0)%val) = acc_vec(i1,i2,:) -#endif - ENDDO - ENDDO -#endif - ENDIF - - IF (p_is_root) THEN - - CALL ncio_define_dimension (file_hist, dim1name, ndim1) - CALL ncio_define_dimension (file_hist, dim2name, ndim2) - - compress = DEF_HIST_CompressLevel - - IF (itime_in_file >= 1) THEN -#ifdef CATCHMENT - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - dim1name, dim2name, 'hydrounit', 'time', compress) -#else - CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, & - dim1name, dim2name, 'element', 'time', compress) -#endif - ELSE -#ifdef CATCHMENT - CALL ncio_write_serial (file_hist, varname, acc_vec, & - dim1name, dim2name, 'hydrounit', compress) -#else - CALL ncio_write_serial (file_hist, varname, acc_vec, & - dim1name, dim2name, 'element', compress) -#endif - ENDIF - - IF (itime_in_file <= 1) THEN - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF - - ENDIF - - IF (allocated(acc_vec)) deallocate (acc_vec) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE aggregate_to_vector_and_write_4d - - -END MODULE MOD_HistVector -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 deleted file mode 100644 index 05397d1516..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 +++ /dev/null @@ -1,743 +0,0 @@ -#include - -#ifdef USEMPI -MODULE MOD_HistWriteBack -!---------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Write out data to history files by a dedicated process. -! -! Author: Shupeng Zhang, 11/2023 -!---------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - - ! type of send buffer - type :: HistSendBufferType - integer :: dataid - integer :: datatag - integer :: sendreqs (3) - integer :: sendint4 (5) - character(len=256) :: sendchar (9) - real(r8), allocatable :: senddata (:) - type(HistSendBufferType), pointer :: next - END type HistSendBufferType - - ! Sending Variables - type(HistSendBufferType), pointer :: HistSendBuffer - type(HistSendBufferType), pointer :: LastSendBuffer - - ! type of times - type :: timenodetype - character(len=256) :: filename - character(len=256) :: filelast - character(len=256) :: timename - integer :: time(3) - integer :: req (4) - type(timenodetype), pointer :: next - END type timenodetype - - ! time nodes - integer :: dataid_zero = 0 - integer :: req_zero - type(timenodetype), pointer :: timenodes, lasttime - - ! dimension information - logical :: SDimInited = .false. - - ! 1: grid-based - integer :: nGridData, nxGridSeg, nyGridSeg - integer, allocatable :: xGridDsp(:), xGridCnt(:) - integer, allocatable :: yGridDsp(:), yGridCnt(:) - - integer :: nlat, nlon - real(r8), allocatable :: lat_c(:), lat_s(:), lat_n(:) - real(r8), allocatable :: lon_c(:), lon_w(:), lon_e(:) - - ! Memory limits - integer*8, parameter :: MaxHistMemSize = 1073741824_8 ! 1024^3 - integer*8 :: TotalMemSize = 0 - - integer :: itime_in_file_wb - - ! tags - integer, parameter :: tag_next = 1 - integer, parameter :: tag_time = 2 - integer, parameter :: tag_dims = 3 - -CONTAINS - - SUBROUTINE hist_writeback_daemon () - - USE MOD_Namelist, only: DEF_HIST_FREQ - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - ! Local Variables - integer :: dataid, tag - integer :: time(3), ndims, ndim1, ndim2, dimlens(4), compress - integer :: i, idata, isrc, ixseg, iyseg, xdsp, ydsp, xcnt, ycnt, idim1, idim2 - - integer :: recvint4 (5) - character(len=256) :: recvchar (9) - real(r8), allocatable :: datathis (:) - - character(len=256) :: filename, filelast, dataname, longname, units - character(len=256) :: dim1name, dim2name, dim3name, dim4name, dim5name - logical :: fexists - - real(r8), allocatable :: wdata1d(:), wdata2d(:,:), wdata3d(:,:,:), wdata4d(:,:,:,:) - real(r8), allocatable :: tmp3d(:,:,:), tmp4d(:,:,:,:) - - - DO WHILE (.true.) - - CALL mpi_recv (dataid, 1, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_next, p_comm_glb_plus, p_stat, p_err) - - IF (dataid < 0) THEN - - EXIT - - ELSEIF (dataid == 0) THEN - - CALL mpi_recv (filename, 256, MPI_CHARACTER, & - MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) - - CALL mpi_recv (filelast, 256, MPI_CHARACTER, & - MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) - - CALL mpi_recv (dataname, 256, MPI_CHARACTER, & - MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) - - CALL mpi_recv (time, 3, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) - - IF (.not. SDimInited) THEN - - CALL mpi_recv (nGridData, 1, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (nxGridSeg, 1, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (nyGridSeg, 1, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - - allocate (xGridDsp (nxGridSeg)) - allocate (xGridCnt (nxGridSeg)) - allocate (yGridDsp (nyGridSeg)) - allocate (yGridCnt (nyGridSeg)) - - CALL mpi_recv (xGridDsp, nxGridSeg, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (xGridCnt, nxGridSeg, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (yGridDsp, nyGridSeg, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (yGridCnt, nyGridSeg, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - - CALL mpi_recv (nlat, 1, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - - allocate(lat_c(nlat)) - allocate(lat_s(nlat)) - allocate(lat_n(nlat)) - - CALL mpi_recv (lat_c, nlat, MPI_REAL8, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (lat_s, nlat, MPI_REAL8, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (lat_n, nlat, MPI_REAL8, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - - CALL mpi_recv (nlon, 1, MPI_INTEGER, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - - allocate(lon_c(nlon)) - allocate(lon_w(nlon)) - allocate(lon_e(nlon)) - - CALL mpi_recv (lon_c, nlon, MPI_REAL8, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (lon_w, nlon, MPI_REAL8, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - CALL mpi_recv (lon_e, nlon, MPI_REAL8, & - MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) - - SDimInited = .true. - - ENDIF - - inquire (file=filename, exist=fexists) - IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN - - CALL ncio_create_file (trim(filename)) - - CALL ncio_define_dimension(filename, 'time', 0) - - CALL ncio_define_dimension(filename, 'lat', nlat) - CALL ncio_define_dimension(filename, 'lon', nlon) - - CALL ncio_write_serial (filename, 'lat', lat_c, 'lat') - CALL ncio_write_serial (filename, 'lon', lon_c, 'lon') - CALL ncio_write_serial (filename, 'lat_s', lat_s, 'lat') - CALL ncio_write_serial (filename, 'lat_n', lat_n, 'lat') - CALL ncio_write_serial (filename, 'lon_w', lon_w, 'lon') - CALL ncio_write_serial (filename, 'lon_e', lon_e, 'lon') - - CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') - CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') - CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') - - CALL ncio_write_colm_dimension (filename) - - ENDIF - - CALL ncio_write_time (filename, dataname, time, itime_in_file_wb, DEF_HIST_FREQ) - - ELSE - - !-------------------------------- - ! receive and write history data. - !-------------------------------- - - ! (1) data header - tag = dataid*10 - CALL mpi_recv (recvint4(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err) - - ndims = recvint4(1) - compress = recvint4(2) - - CALL mpi_recv (recvchar(1:9), 256*9, MPI_CHARACTER, & - MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err) - - filename = recvchar(1) - dataname = recvchar(2) - dim1name = recvchar(3) - dim2name = recvchar(4) - dim3name = recvchar(5) - dim4name = recvchar(6) - dim5name = recvchar(7) - longname = recvchar(8) - units = recvchar(9) - - ! (2) data - tag = dataid*10+1 - - DO idata = 1, nGridData - - CALL mpi_recv (recvint4(1:5), 5, MPI_INTEGER, MPI_ANY_SOURCE, & - tag, p_comm_glb_plus, p_stat, p_err) - - isrc = recvint4(1) - ixseg = recvint4(2) - iyseg = recvint4(3) - ndim1 = recvint4(4) - ndim2 = recvint4(5) - - xdsp = xGridDsp(ixseg) - ydsp = yGridDsp(iyseg) - xcnt = xGridCnt(ixseg) - ycnt = yGridCnt(iyseg) - - SELECTCASE (ndims) - CASE (2:3) - - dimlens = (/nlon, nlat, 0, 0/) - - IF (.not. allocated(wdata2d)) THEN - allocate (wdata2d (nlon,nlat)) - ENDIF - - allocate (datathis(xcnt*ycnt)) - CALL mpi_recv (datathis, xcnt*ycnt, MPI_REAL8, & - isrc, tag, p_comm_glb_plus, p_stat, p_err) - - wdata2d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt) = & - reshape(datathis,(/xcnt,ycnt/)) - - CASE (4) - - dimlens = (/ndim1, nlon, nlat, 0/) - - IF (.not. allocated(wdata3d)) THEN - allocate (wdata3d (nlon,nlat,ndim1)) - allocate (tmp3d (ndim1,nlon,nlat)) - ENDIF - - allocate (datathis(ndim1*xcnt*ycnt)) - CALL mpi_recv (datathis, ndim1*xcnt*ycnt, MPI_REAL8, & - isrc, tag, p_comm_glb_plus, p_stat, p_err) - - tmp3d = reshape(datathis,(/ndim1,xcnt,ycnt/)) - DO idim1 = 1, ndim1 - wdata3d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt, idim1) = tmp3d(idim1, :, :) - ENDDO - - CASE (5) - - dimlens = (/ndim1, ndim2, nlon, nlat/) - - IF (.not. allocated(wdata4d)) THEN - allocate (wdata4d (nlon,nlat,ndim1,ndim2)) - allocate (tmp4d (ndim1,ndim2,nlon,nlat)) - ENDIF - - allocate (datathis(ndim1*ndim2*xcnt*ycnt)) - CALL mpi_recv (datathis, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & - isrc, tag, p_comm_glb_plus, p_stat, p_err) - - tmp4d = reshape(datathis,(/ndim1, ndim2, xcnt, ycnt/)) - - DO idim1 = 1, ndim1 - DO idim2 = 1, ndim2 - wdata4d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt, idim1, idim2) = & - tmp4d(idim1, idim2, :, :) - ENDDO - ENDDO - - ENDSELECT - - deallocate (datathis) - - ENDDO - - - IF (ndims >= 4) CALL ncio_define_dimension (filename, dim3name, dimlens(1)) - IF (ndims >= 5) CALL ncio_define_dimension (filename, dim4name, dimlens(2)) - - SELECTCASE (ndims) - CASE (2) ! for variables with [lon,lat] - - CALL ncio_write_serial (filename, dataname, wdata2d, dim1name, dim2name, compress) - - deallocate(wdata2d) - CASE (3) ! for variables with [lon,lat,time] - - CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata2d, & - dim1name, dim2name, dim3name, compress) - - deallocate(wdata2d) - CASE (4) ! for variables with [lon,lat,dim3,time] - - CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata3d, & - dim1name, dim2name, dim3name, dim4name, compress) - - deallocate(tmp3d ) - deallocate(wdata3d) - CASE (5) ! for variables with [lon,lat,dim3,dim4,time] - - CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata4d, & - dim1name, dim2name, dim3name, dim4name, dim5name, compress) - - deallocate(tmp4d ) - deallocate(wdata4d) - ENDSELECT - - IF (itime_in_file_wb <= 1) THEN - CALL ncio_put_attr (filename, dataname, 'long_name', longname) - CALL ncio_put_attr (filename, dataname, 'units', units) - CALL ncio_put_attr (filename, dataname, 'missing_value', spval) - ENDIF - - write(*,'(3A,I0,2A)') 'HIST WriteBack: ', trim(basename(filename)), & - ' (time ', itime_in_file_wb, '): ', trim(dataname) - - ENDIF - - ENDDO - - END SUBROUTINE hist_writeback_daemon - - ! ----- - SUBROUTINE hist_writeback_latlon_time (filename, filelast, timename, time, HistConcat) - - USE MOD_Namelist - USE MOD_Grid - IMPLICIT NONE - - character (len=*), intent(in) :: filename - character (len=*), intent(in) :: filelast - character (len=*), intent(in) :: timename - integer, intent(in) :: time(3) - type(grid_concat_type), intent(in) :: HistConcat - - ! Local Variables - integer :: i - logical :: senddone - integer :: sendstat(MPI_STATUS_SIZE,4) - type(timenodetype), pointer :: tempnode - - IF (.not. associated(timenodes)) THEN - allocate (timenodes) - lasttime => timenodes - ELSE - allocate (lasttime%next) - lasttime => lasttime%next - ENDIF - - lasttime%filename = filename - lasttime%filelast = filelast - lasttime%timename = timename - lasttime%time = time - lasttime%next => null() - - CALL mpi_isend (dataid_zero, 1, MPI_INTEGER, & - p_address_history_task, tag_next, p_comm_glb_plus, req_zero, p_err) - - CALL mpi_isend (lasttime%filename, 256, MPI_CHARACTER, & - p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(1), p_err) - - CALL mpi_isend (lasttime%filelast, 256, MPI_CHARACTER, & - p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(2), p_err) - - CALL mpi_isend (lasttime%timename, 256, MPI_CHARACTER, & - p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(3), p_err) - - CALL mpi_isend (lasttime%time, 3, MPI_INTEGER, & - p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(4), p_err) - - - IF (.not. SDimInited) THEN - - nGridData = HistConcat%ndatablk - nxGridSeg = HistConcat%nxseg - nyGridSeg = HistConcat%nyseg - - allocate (xGridDsp (nxGridSeg)) - allocate (xGridCnt (nxGridSeg)) - allocate (yGridDsp (nyGridSeg)) - allocate (yGridCnt (nyGridSeg)) - - DO i = 1, nxGridSeg - xGridDsp(i) = HistConcat%xsegs(i)%gdsp - xGridCnt(i) = HistConcat%xsegs(i)%cnt - ENDDO - - DO i = 1, nyGridSeg - yGridDsp(i) = HistConcat%ysegs(i)%gdsp - yGridCnt(i) = HistConcat%ysegs(i)%cnt - ENDDO - - CALL mpi_send (nGridData, 1, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (nxGridSeg, 1, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (nyGridSeg, 1, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - - CALL mpi_send (xGridDsp, nxGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (xGridCnt, nxGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (yGridDsp, nyGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (yGridCnt, nyGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - - nlat = HistConcat%ginfo%nlat - nlon = HistConcat%ginfo%nlon - allocate(lat_c(nlat)); lat_c = HistConcat%ginfo%lat_c - allocate(lat_s(nlat)); lat_s = HistConcat%ginfo%lat_s - allocate(lat_n(nlat)); lat_n = HistConcat%ginfo%lat_n - allocate(lon_c(nlon)); lon_c = HistConcat%ginfo%lon_c - allocate(lon_w(nlon)); lon_w = HistConcat%ginfo%lon_w - allocate(lon_e(nlon)); lon_e = HistConcat%ginfo%lon_e - - CALL mpi_send (nlat, 1, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (lat_c, nlat, MPI_REAL8, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (lat_s, nlat, MPI_REAL8, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (lat_n, nlat, MPI_REAL8, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (nlon, 1, MPI_INTEGER, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (lon_c, nlon, MPI_REAL8, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (lon_w, nlon, MPI_REAL8, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - CALL mpi_send (lon_e, nlon, MPI_REAL8, p_address_history_task, tag_dims, & - p_comm_glb_plus, p_err) - - SDimInited = .true. - - ENDIF - - DO WHILE (associated(timenodes%next)) - - CALL MPI_TestAll (4, timenodes%req, senddone, sendstat(:,1:4), p_err) - - IF (senddone) THEN - tempnode => timenodes - timenodes => timenodes%next - deallocate(tempnode) - ELSE - EXIT - ENDIF - ENDDO - - END SUBROUTINE hist_writeback_latlon_time - - ! ----- - SUBROUTINE hist_writeback_var_header (dataid, filename, dataname, & - ndims, dim1name, dim2name, dim3name, dim4name, dim5name, & - compress, longname, units) - - IMPLICIT NONE - - integer, intent(in) :: dataid - character(len=*), intent(in) :: filename, dataname - integer, intent(in) :: ndims - character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name, dim5name - integer, intent(in) :: compress - character(len=*), intent(in) :: longname, units - - ! Local Variables - logical :: senddone - integer :: sendstat(MPI_STATUS_SIZE,3) - type(HistSendBufferType), pointer :: TempSendBuffer - - ! append sending buffer - IF (.not. associated(HistSendBuffer)) THEN - allocate (HistSendBuffer) - LastSendBuffer => HistSendBuffer - ELSE - allocate (LastSendBuffer%next) - LastSendBuffer => LastSendBuffer%next - ENDIF - - LastSendBuffer%next => null() - - ! clean sending buffer and free memory - DO WHILE (associated(HistSendBuffer%next)) - - CALL MPI_Testall (3, HistSendBuffer%sendreqs, senddone, sendstat(:,1:3), p_err) - - IF (senddone) THEN - - TempSendBuffer => HistSendBuffer - HistSendBuffer => HistSendBuffer%next - - IF (allocated(TempSendBuffer%senddata)) THEN - deallocate (TempSendBuffer%senddata) - ENDIF - deallocate (TempSendBuffer) - ELSE - EXIT - ENDIF - ENDDO - - LastSendBuffer%dataid = dataid - LastSendBuffer%datatag = dataid*10 - - LastSendBuffer%sendint4(1:2) = (/ndims, compress/) - - LastSendBuffer%sendchar(1) = filename - LastSendBuffer%sendchar(2) = dataname - LastSendBuffer%sendchar(3) = dim1name - LastSendBuffer%sendchar(4) = dim2name - LastSendBuffer%sendchar(5) = dim3name - LastSendBuffer%sendchar(6) = dim4name - LastSendBuffer%sendchar(7) = dim5name - LastSendBuffer%sendchar(8) = longname - LastSendBuffer%sendchar(9) = units - - CALL mpi_isend (LastSendBuffer%dataid, 1, MPI_INTEGER, & - p_address_history_task, tag_next, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) - - CALL mpi_isend (LastSendBuffer%sendint4(1:2), 2, MPI_INTEGER, & - p_address_history_task, LastSendBuffer%datatag, & - p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) - - CALL mpi_isend (LastSendBuffer%sendchar, 256*9, MPI_CHARACTER, & - p_address_history_task, LastSendBuffer%datatag, & - p_comm_glb_plus, LastSendBuffer%sendreqs(3), p_err) - - END SUBROUTINE hist_writeback_var_header - - ! ----- - SUBROUTINE hist_writeback_var ( dataid, ixseg, iyseg, & - wdata1d, wdata2d, wdata3d, wdata4d) - - IMPLICIT NONE - - integer, intent(in) :: dataid, ixseg, iyseg - - real(r8), intent(in), optional :: wdata1d(:) - real(r8), intent(in), optional :: wdata2d(:,:) - real(r8), intent(in), optional :: wdata3d(:,:,:) - real(r8), intent(in), optional :: wdata4d(:,:,:,:) - - ! Local Variables - integer :: totalsize, ndim1, ndim2 - logical :: senddone - integer :: sendstat(MPI_STATUS_SIZE,2) - type(HistSendBufferType), pointer :: TempSendBuffer - - ! append sending buffer - IF (.not. associated(HistSendBuffer)) THEN - allocate (HistSendBuffer) - LastSendBuffer => HistSendBuffer - TotalMemSize = 0 - ELSE - allocate (LastSendBuffer%next) - LastSendBuffer => LastSendBuffer%next - ENDIF - - LastSendBuffer%next => null() - - ! clean sending buffer and free memory - DO WHILE (associated(HistSendBuffer%next)) - - IF (TotalMemSize > MaxHistMemSize) THEN - CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), sendstat(:,1:2), p_err) - ELSE - CALL MPI_Testall (2, HistSendBuffer%sendreqs(1:2), senddone, sendstat(:,1:2), p_err) - IF (.not. senddone) EXIT - ENDIF - - TotalMemSize = TotalMemSize - size(HistSendBuffer%senddata) - - TempSendBuffer => HistSendBuffer - HistSendBuffer => HistSendBuffer%next - deallocate(TempSendBuffer%senddata) - deallocate(TempSendBuffer) - - ENDDO - - LastSendBuffer%datatag = dataid*10+1 - - ndim1 = 0 - ndim2 = 0 - - IF (present(wdata2d)) THEN - - totalsize = size(wdata2d) - allocate(LastSendBuffer%senddata(totalsize)) - LastSendBuffer%senddata = reshape(wdata2d, (/totalsize/)) - - ELSEIF (present(wdata3d)) THEN - - ndim1 = size(wdata3d,1) - totalsize = size(wdata3d) - allocate(LastSendBuffer%senddata(totalsize)) - LastSendBuffer%senddata = reshape(wdata3d, (/totalsize/)) - - ELSEIF (present(wdata4d)) THEN - - ndim1 = size(wdata4d,1) - ndim2 = size(wdata4d,2) - totalsize = size(wdata4d) - allocate(LastSendBuffer%senddata(totalsize)) - LastSendBuffer%senddata = reshape(wdata4d, (/totalsize/)) - - ENDIF - - TotalMemSize = TotalMemSize + totalsize - - LastSendBuffer%sendint4(1:5) = (/p_iam_glb_plus, ixseg, iyseg, ndim1, ndim2/) - - CALL mpi_isend (LastSendBuffer%sendint4(1:5), 5, MPI_INTEGER, & - p_address_history_task, LastSendBuffer%datatag, & - p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) - - CALL mpi_isend (LastSendBuffer%senddata, totalsize, MPI_REAL8, & - p_address_history_task, LastSendBuffer%datatag, & - p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) - - END SUBROUTINE hist_writeback_var - - ! ----- - SUBROUTINE hist_writeback_exit () - - IMPLICIT NONE - - ! Local Variables - integer :: dataid, nreq - integer :: sendstat(MPI_STATUS_SIZE,4) - type(timenodetype), pointer :: tempnode - type(HistSendBufferType), pointer :: TempSendBuffer - - lasttime => null() - DO WHILE (associated(timenodes)) - - CALL MPI_WaitAll (4, timenodes%req, sendstat(:,1:4), p_err) - - tempnode => timenodes - timenodes => timenodes%next - deallocate(tempnode) - ENDDO - - LastSendBuffer => null() - DO WHILE (associated(HistSendBuffer)) - - IF (allocated(HistSendBuffer%senddata)) THEN - CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), sendstat(:,1:2), p_err) - deallocate(HistSendBuffer%senddata) - ELSE - CALL MPI_Waitall (3, HistSendBuffer%sendreqs(1:3), sendstat(:,1:3), p_err) - ENDIF - - TempSendBuffer => HistSendBuffer - HistSendBuffer => HistSendBuffer%next - deallocate (TempSendBuffer) - - ENDDO - - IF (allocated(xGridDsp)) deallocate(xGridDsp) - IF (allocated(yGridDsp)) deallocate(yGridDsp) - IF (allocated(xGridCnt)) deallocate(xGridCnt) - IF (allocated(yGridCnt)) deallocate(yGridCnt) - IF (allocated(lat_c )) deallocate(lat_c ) - IF (allocated(lat_s )) deallocate(lat_s ) - IF (allocated(lat_n )) deallocate(lat_n ) - IF (allocated(lon_c )) deallocate(lon_c ) - IF (allocated(lon_w )) deallocate(lon_w ) - IF (allocated(lon_e )) deallocate(lon_e ) - - - IF (.not. p_is_history_task) THEN - CALL mpi_barrier (p_comm_glb, p_err) - ENDIF - - IF (p_is_root) THEN - dataid = -1 - CALL mpi_send (dataid, 1, MPI_INTEGER, p_address_history_task, & - tag_next, p_comm_glb_plus, p_err) - ENDIF - - CALL mpi_barrier (p_comm_glb_plus, p_err) - - END SUBROUTINE hist_writeback_exit - - ! ---- - character(len=256) FUNCTION basename (fullname) - - IMPLICIT NONE - character(len=*), intent(in) :: fullname - - ! Local variables - integer :: i, n - - i = len_trim (fullname) - DO WHILE (i > 0) - IF (fullname(i:i) == '/') EXIT - i = i - 1 - ENDDO - - IF (i > 0) THEN - basename = fullname(i+1:) - ELSE - basename = fullname - ENDIF - - END FUNCTION basename - -END MODULE MOD_HistWriteBack -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 index 69deecce49..fcc804e623 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 @@ -30,7 +30,7 @@ MODULE MOD_Irrigation USE MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs USE MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE PUBLIC :: CalIrrigationNeeded diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 index 367999943b..c1dd5caffa 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 @@ -28,7 +28,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) USE MOD_Precision USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_UserDefFun USE MOD_NetCDFVector USE MOD_LandPatch @@ -110,7 +110,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) ENDIF #endif - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch @@ -189,7 +189,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) #endif - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 index 2628092057..d0d067c122 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 @@ -30,8 +30,9 @@ MODULE MOD_LeafInterception ! 2019.06 Hua Yuan: 1) add wrapper for PFT and PC, and 2) remove sigf by using lai+sai ! 2014.04 Yongjiu Dai ! 2002.08.31 Yongjiu Dai - USE MOD_Precision - USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice, hfus + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice, hfus USE MOD_Namelist, only: DEF_Interception_scheme, DEF_VEG_SNOW IMPLICIT NONE @@ -336,13 +337,13 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code: ' write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap - CALL abort + CALL CoLM_stop() ENDIF IF (DEF_VEG_SNOW .and. abs(ldew-ldew_rain-ldew_snow) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code when DEF_VEG_SNOW: ' write(6,*) ldew, ldew_rain, ldew_snow - CALL abort + CALL CoLM_stop() ENDIF #endif @@ -527,7 +528,7 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code : ' write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap - CALL abort + CALL CoLM_stop() ENDIF CALL check_interception_balance('CoLM202x', & @@ -705,7 +706,7 @@ SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code : ' write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap - CALL abort + CALL CoLM_stop() ENDIF #endif @@ -921,7 +922,7 @@ SUBROUTINE LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa write(6,*) 'Mass balance error in CLM5 interception:' write(6,*) 'Error:', w, 'ldew:', ldew, 'outflow:', (pg_rain+pg_snow)*deltim write(6,*) 'satcap_rain:', satcap_rain, 'satcap_snow:', satcap_snow - CALL abort + CALL CoLM_stop() ENDIF CALL check_interception_balance('CLM5', & @@ -1168,7 +1169,7 @@ SUBROUTINE LEAF_interception_NOAHMP(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,s IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code : ' write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap - CALL abort + CALL CoLM_stop() ENDIF CALL check_interception_balance('NoahMP', & @@ -1439,7 +1440,7 @@ SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code : ' write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap - CALL abort + CALL CoLM_stop() ENDIF CALL check_interception_balance('MATSIRO', & @@ -1795,7 +1796,7 @@ SUBROUTINE LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN write(6,*) 'something wrong in interception code : ' write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap - CALL abort + CALL CoLM_stop() ENDIF CALL check_interception_balance('VIC', & @@ -2144,7 +2145,7 @@ SUBROUTINE LEAF_interception_JULES(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa IF (abs(w_l) > 1.e-6) THEN write(6,*) 'JULES interception mass balance error: ', w_l write(6,*) 'ldew=', ldew, ' pg*dt=', (pg_rain+pg_snow)*deltim - CALL abort + CALL CoLM_stop() ENDIF CALL check_interception_balance('JULES', & @@ -2430,7 +2431,7 @@ SUBROUTINE check_interception_balance(scheme_name, & write(6,*) 'Component consistency error in ', scheme_name, ':' write(6,*) 'ldew=', ldew, ' ldew_rain+ldew_snow=', ldew_rain+ldew_snow write(6,*) 'diff=', ldew - (ldew_rain + ldew_snow) - CALL abort + CALL CoLM_stop() ENDIF ! Check B: non-negativity @@ -2442,7 +2443,7 @@ SUBROUTINE check_interception_balance(scheme_name, & write(6,*) 'Negative value error in ', scheme_name, ':' write(6,*) 'ldew=', ldew, ' ldew_rain=', ldew_rain, ' ldew_snow=', ldew_snow write(6,*) 'pg_rain=', pg_rain, ' pg_snow=', pg_snow - CALL abort + CALL CoLM_stop() ENDIF ! Check C: flux consistency (qintr == qintr_rain + qintr_snow) @@ -2450,7 +2451,7 @@ SUBROUTINE check_interception_balance(scheme_name, & write(6,*) 'Flux consistency error in ', scheme_name, ':' write(6,*) 'qintr=', qintr, ' qintr_rain+qintr_snow=', qintr_rain+qintr_snow write(6,*) 'diff=', qintr - (qintr_rain + qintr_snow) - CALL abort + CALL CoLM_stop() ENDIF END SUBROUTINE check_interception_balance diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 index 48a3f61941..35c3fa20bf 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 @@ -7,7 +7,7 @@ MODULE MOD_LeafTemperature USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW, & DEF_VEG_SNOW - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE @@ -109,7 +109,7 @@ SUBROUTINE LeafTemperature ( & USE MOD_CanopyLayerProfile USE MOD_TurbulenceLEddy USE MOD_AssimStomataConductance - USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + USE MOD_Vars_1DForcing, only: forc_height_mode USE MOD_Vars_TimeInvariants, only: patchclass USE MOD_Const_LC, only: z0mr, displar USE MOD_PlantHydraulic, only:PlantHydraulicStress_twoleaf, getvegwp_twoleaf @@ -533,7 +533,7 @@ SUBROUTINE LeafTemperature ( & hu_ = hu; ht_ = ht; hq_ = hq; - IF (trim(HEIGHT_mode) == 'absolute') THEN + IF (forc_height_mode == 'absolute') THEN IF (hu <= htop+1) THEN hu_ = htop + 1. @@ -563,7 +563,7 @@ SUBROUTINE LeafTemperature ( & IF(zldis <= 0.0) THEN write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort + CALL CoLM_stop() ENDIF CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,um,obu) @@ -848,7 +848,7 @@ SUBROUTINE LeafTemperature ( & etr = etrsun + etrsha IF(abs(etr - sum(rootflux)) .gt. 1.e-7)THEN write(6,*) 'Warning: water balance violation in vegetation PHS', & - ipatch,p_iam_glb, etr, sum(rootflux), abs(etr-sum(rootflux)) + ipatch,mpas_rank, etr, sum(rootflux), abs(etr-sum(rootflux)) CALL CoLM_stop() ENDIF ENDIF @@ -1403,7 +1403,7 @@ SUBROUTINE LeafTemperature ( & ldew = ldew_rain + ldew_snow ENDIF ELSE - CALL abort + CALL CoLM_stop() ENDIF ! Bug fix: When DEF_VEG_SNOW is false, only ldew is updated above diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 index df68a494b7..1150338e53 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 @@ -21,8 +21,9 @@ MODULE MOD_LeafTemperaturePC ! ///////////////////////////////////////////////////////////////////// ! !----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW, & DEF_VEG_SNOW IMPLICIT NONE @@ -119,7 +120,7 @@ SUBROUTINE LeafTemperaturePC ( & USE MOD_AssimStomataConductance USE MOD_PlantHydraulic, only: PlantHydraulicStress_twoleaf USE MOD_Ozone, only: CalcOzoneStress - USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + USE MOD_Vars_1DForcing, only: forc_height_mode IMPLICIT NONE @@ -920,7 +921,7 @@ SUBROUTINE LeafTemperaturePC ( & hu_ = hu; ht_ = ht; hq_ = hq; - IF (trim(HEIGHT_mode) == 'absolute') THEN + IF (forc_height_mode == 'absolute') THEN IF (hu <= htop_lay(toplay)+1) THEN hu_ = htop_lay(toplay) + 1. @@ -950,7 +951,7 @@ SUBROUTINE LeafTemperaturePC ( & IF(zldis <= 0.0) THEN write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort + CALL CoLM_stop() ENDIF CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,um,obu) @@ -1935,7 +1936,7 @@ SUBROUTINE LeafTemperaturePC ( & ldew (i) = ldew_snow(i) ENDIF ELSE - CALL abort + CALL CoLM_stop() ENDIF IF ( DEF_VEG_SNOW ) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 index 365fd4e68c..7137498b28 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 @@ -33,7 +33,7 @@ SUBROUTINE init_lightning_data (idate) ! Initialize lightning data read in. !----------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_TimeManager USE MOD_Grid diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 index 4fcb84bd62..b602d4f391 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 @@ -114,7 +114,7 @@ SUBROUTINE update_ndep_data_annually (YY, iswrite) ! Created by Xingjie Lu and Shupeng Zhang, 2022 !----------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist, only: DEF_USE_PN USE MOD_DataType USE MOD_NetCDFBlock @@ -132,14 +132,14 @@ SUBROUTINE update_ndep_data_annually (YY, iswrite) itime = max(min(YY,2006),1849) - 1848 - IF (p_is_active) THEN + IF (.true.) THEN CALL allocate_block_data (grid_ndep, f_xy_ndep) CALL ncio_read_block_time (file_ndep, 'NDEP_year', grid_ndep, itime, f_xy_ndep) ENDIF CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) - IF (p_is_compute .and. iswrite) THEN + IF (.true. .and. iswrite) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) @@ -177,7 +177,7 @@ SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) ! Created by Xingjie Lu and Shupeng Zhang, 2022 ! !----------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist, only: DEF_USE_PN USE MOD_DataType USE MOD_NetCDFBlock @@ -195,14 +195,14 @@ SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) itime = (max(min(YY,2006),1849) - 1849)*12 + MM - IF (p_is_active) THEN + IF (.true.) THEN CALL allocate_block_data (grid_ndep, f_xy_ndep) CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) ENDIF CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) - IF (p_is_compute .and. iswrite) THEN + IF (.true. .and. iswrite) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 index 21729cfff0..d2c1ce98d3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 @@ -63,7 +63,7 @@ END SUBROUTINE init_nitrif_data ! ---------- SUBROUTINE update_nitrif_data (month) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_DataType USE MOD_Vars_Global, only: nl_soil @@ -83,12 +83,12 @@ SUBROUTINE update_nitrif_data (month) character(len=2) :: cx integer :: nsl, npatch, m - IF (p_is_compute) THEN + IF (.true.) THEN allocate(tCONC_O2_UNSAT_tmp (numpatch)) allocate(tO2_DECOMP_DEPTH_UNSAT_tmp(numpatch)) ENDIF - IF (p_is_active) THEN + IF (.true.) THEN CALL allocate_block_data (grid_nitrif, f_xy_nitrif) ENDIF @@ -97,14 +97,14 @@ SUBROUTINE update_nitrif_data (month) write(cx,'(i2.2)') nsl file_nitrif = trim(DEF_dir_runtime)//& '/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l'//trim(cx)//'.nc' - IF (p_is_active) THEN + IF (.true.) THEN CALL ncio_read_block_time (file_nitrif, & 'CONC_O2_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tCONC_O2_UNSAT_tmp) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) @@ -131,14 +131,14 @@ SUBROUTINE update_nitrif_data (month) write(cx,'(i2.2)') nsl file_nitrif = trim(DEF_dir_runtime)//& '/nitrif/O2_DECOMP_DEPTH_UNSAT/O2_DECOMP_DEPTH_UNSAT_l'//trim(cx)//'.nc' - IF (p_is_active) THEN + IF (.true.) THEN CALL ncio_read_block_time (file_nitrif, & 'O2_DECOMP_DEPTH_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN DO npatch = 1, numpatch m = patchclass(npatch) @@ -160,7 +160,7 @@ SUBROUTINE update_nitrif_data (month) CALL check_vector_data ('O2_DECOMP_DEPTH_UNSAT', tO2_DECOMP_DEPTH_UNSAT) #endif - IF (p_is_compute) THEN + IF (.true.) THEN deallocate (tCONC_O2_UNSAT_tmp) deallocate (tO2_DECOMP_DEPTH_UNSAT_tmp) ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 index 20904245a8..0e871774f3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 @@ -187,14 +187,16 @@ SUBROUTINE init_ozone_data (idate) ! longitude info. Initialize Ozone data read in. !----------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_TimeManager USE MOD_Grid USE MOD_NetCDFSerial USE MOD_NetCDFBlock USE MOD_LandPatch +#ifdef RangeCheck USE MOD_RangeCheck +#endif IMPLICIT NONE integer, intent(in) :: idate(3) @@ -242,7 +244,9 @@ SUBROUTINE update_ozone_data (time, deltim) USE MOD_TimeManager USE MOD_Namelist USE MOD_NetCDFBlock +#ifdef RangeCheck USE MOD_RangeCheck +#endif IMPLICIT NONE type(timestamp), intent(in) :: time diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 index a7127f8c58..914b3c9d0a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 @@ -53,7 +53,7 @@ SUBROUTINE meltf (patchtype,is_dry_lake,lb,nl_soil,deltim, & !----------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Hydro_SoilFunction USE MOD_Const_Physical, only: tfrz, hfus, grav USE MOD_Namelist @@ -354,7 +354,7 @@ SUBROUTINE meltf_snicar (patchtype,is_dry_lake,lb,nl_soil,deltim, & !----------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Hydro_SoilFunction USE MOD_Const_Physical, only: tfrz, hfus, grav USE MOD_Namelist @@ -654,7 +654,7 @@ SUBROUTINE meltf_urban (lb,nl_soil,deltim, & !----------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Const_Physical, only: tfrz, hfus IMPLICIT NONE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 index f85365c619..e06656a824 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 @@ -4,7 +4,7 @@ MODULE MOD_PlantHydraulic !----------------------------------------------------------------------- USE MOD_Precision USE MOD_Namelist, only: DEF_RSS_SCHEME - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE SAVE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 index 32c623c28d..c98e654406 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 @@ -39,7 +39,7 @@ SUBROUTINE SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,& USE MOD_Namelist, only: DEF_TOPMOD_method USE MOD_IncompleteGamma, only: GRATIO - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE !-------------------------- Dummy Arguments ---------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 index 74df71130c..ec1aa32286 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 @@ -28,7 +28,7 @@ MODULE MOD_SnowSnicar ! !USES: USE MOD_Precision USE MOD_Vars_Global, only: maxsnl - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE ! SAVE @@ -500,14 +500,14 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Error check for snow grain size: #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." write (iulog,*) "flg_snw_ice= ", flg_snw_ice write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl write (iulog,*) "h2osno(c)= ", h2osno_lcl - CALL abort + CALL CoLM_stop() ENDIF ENDDO ENDIF @@ -1027,7 +1027,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN flg_dover = 0 #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) @@ -1039,7 +1039,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) write(iulog,*) "frac_sno: ", frac_sno - CALL abort + CALL CoLM_stop() ENDIF #endif ELSE @@ -1053,9 +1053,9 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) IF (abs(energy_sum) > 0.00001_r8) THEN #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum - CALL abort + CALL CoLM_stop() ENDIF #endif ENDIF @@ -1065,7 +1065,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Check that albedo is less than 1 IF (albout_lcl(bnd_idx) > 1.0) THEN #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & @@ -1091,7 +1091,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) - CALL abort + CALL CoLM_stop() ENDIF #endif ENDIF @@ -1511,9 +1511,9 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN snw_shp_lcl(:) = snow_shape_koch_snowflake ELSE - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "snow_shape = ", snow_shape - CALL abort + CALL CoLM_stop() ENDIF ENDIF @@ -1533,9 +1533,9 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type - CALL abort + CALL CoLM_stop() ENDIF ENDIF @@ -1615,14 +1615,14 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) ! Error check for snow grain size: - IF (p_is_root) THEN + IF (mpas_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." write (iulog,*) "flg_snw_ice= ", flg_snw_ice write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl write (iulog,*) "h2osno(c)= ", h2osno_lcl - CALL abort + CALL CoLM_stop() ENDIF ENDDO ENDIF @@ -2248,7 +2248,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & flx_abs_lcl(i,bnd_idx) = F_abs(i) ! ERROR check: negative absorption - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) @@ -2260,7 +2260,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) - CALL abort + CALL CoLM_stop() ENDIF ENDIF ENDDO @@ -2301,7 +2301,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! Energy conservation check: ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (abs(energy_sum) > 0.00001_r8) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum write(iulog,*) "F_abs_sum: ",F_abs_sum @@ -2312,13 +2312,13 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "bnd_idx", bnd_idx write(iulog,*) "F_abs", F_abs write(iulog,*) "albedo", albedo - CALL abort + CALL CoLM_stop() ENDIF ENDIF albout_lcl(bnd_idx) = albedo ! Check that albedo is less than 1 - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (albout_lcl(bnd_idx) > 1.0) THEN write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx @@ -2345,7 +2345,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) - CALL abort + CALL CoLM_stop() ENDIF ENDIF @@ -2607,9 +2607,9 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz ,& IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN dr_fresh = 0.0_r8 ELSEIF ( dr_fresh < 0.0_r8 ) THEN - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min - CALL abort + CALL CoLM_stop() ENDIF ENDIF @@ -2749,15 +2749,15 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type - CALL abort + CALL CoLM_stop() ENDIF ENDIF ! ! Open optics file: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Attempting to read snow optical properties .....' write(iulog,*) subname,trim(fsnowoptics) ENDIF @@ -2781,7 +2781,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) #ifdef MODAL_AER ! size-dependent BC parameters and BC enhancement factors - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' ENDIF ! @@ -2848,13 +2848,13 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ! ! - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Successfully read snow optical properties' ENDIF ! print some diagnostics: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) @@ -2869,7 +2869,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF ! #ifdef MODAL_AER - IF (p_is_root) THEN + IF (mpas_is_root) THEN ! unique dimensionality for modal aerosol optical properties write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) @@ -2882,7 +2882,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) ENDIF #else - IF (p_is_root) THEN + IF (mpas_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & @@ -2890,7 +2890,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (DO_SNO_OC) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) @@ -2923,7 +2923,7 @@ SUBROUTINE SnowAge_init( fsnowaging ) character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name ! ! Open snow aging (effective radius evolution) file: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Attempting to read snow aging parameters .....' write(iulog,*) subname,trim(fsnowaging) ENDIF @@ -2936,12 +2936,12 @@ SUBROUTINE SnowAge_init( fsnowaging ) CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) ! - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Successfully read snow aging properties' ENDIF ! ! print some diagnostics: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 index 10dad47088..808626426b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 @@ -25,7 +25,7 @@ MODULE MOD_SnowSnicar_HiRes ! !USES: USE MOD_Precision USE MOD_Vars_Global, only: maxsnl - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE ! SAVE @@ -497,14 +497,14 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Error check for snow grain size: #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." write (iulog,*) "flg_snw_ice= ", flg_snw_ice write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl write (iulog,*) "h2osno(c)= ", h2osno_lcl - CALL abort + CALL CoLM_stop('SNICAR encountered inconsistent snow-layer state.') ENDIF ENDDO ENDIF @@ -1024,7 +1024,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN flg_dover = 0 #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) @@ -1036,7 +1036,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) write(iulog,*) "frac_sno: ", frac_sno - CALL abort + CALL CoLM_stop('SNICAR aerosol concentration is outside its valid range.') ENDIF #endif ELSE @@ -1050,9 +1050,9 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) IF (abs(energy_sum) > 0.00001_r8) THEN #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum - CALL abort + CALL CoLM_stop('SNICAR energy conservation check failed.') ENDIF #endif ENDIF @@ -1062,7 +1062,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Check that albedo is less than 1 IF (albout_lcl(bnd_idx) > 1.0) THEN #ifndef _OPENACC - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & @@ -1088,7 +1088,7 @@ SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) - CALL abort + CALL CoLM_stop('SNICAR snow-grain radius is outside its valid range.') ENDIF #endif ENDIF @@ -1507,9 +1507,9 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN snw_shp_lcl(:) = snow_shape_koch_snowflake ELSE - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "snow_shape = ", snow_shape - CALL abort + CALL CoLM_stop('SNICAR received an unsupported snow shape.') ENDIF ENDIF @@ -1529,9 +1529,9 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type - CALL abort + CALL CoLM_stop('SNICAR received an unsupported atmospheric profile.') ENDIF ENDIF @@ -1611,14 +1611,14 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) ! Error check for snow grain size: - IF (p_is_root) THEN + IF (mpas_is_root) THEN DO i=snl_top,snl_btm,1 IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." write (iulog,*) "flg_snw_ice= ", flg_snw_ice write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl write (iulog,*) "h2osno(c)= ", h2osno_lcl - CALL abort + CALL CoLM_stop('SNICAR-AD encountered inconsistent snow-layer state.') ENDIF ENDDO ENDIF @@ -2244,7 +2244,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & flx_abs_lcl(i,bnd_idx) = F_abs(i) ! ERROR check: negative absorption - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) @@ -2256,7 +2256,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) - CALL abort + CALL CoLM_stop('SNICAR-AD aerosol concentration is outside its valid range.') ENDIF ENDIF ENDDO @@ -2297,7 +2297,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! Energy conservation check: ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (abs(energy_sum) > 0.00001_r8) THEN write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum write(iulog,*) "F_abs_sum: ",F_abs_sum @@ -2308,13 +2308,13 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "bnd_idx", bnd_idx write(iulog,*) "F_abs", F_abs write(iulog,*) "albedo", albedo - CALL abort + CALL CoLM_stop('SNICAR-AD energy conservation check failed.') ENDIF ENDIF albout_lcl(bnd_idx) = albedo ! Check that albedo is less than 1 - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (albout_lcl(bnd_idx) > 1.0) THEN write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx @@ -2341,7 +2341,7 @@ SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) - CALL abort + CALL CoLM_stop('SNICAR-AD snow-grain radius is outside its valid range.') ENDIF ENDIF @@ -2603,9 +2603,9 @@ SUBROUTINE SnowAge_grain( dtime , snl , dz , & IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN dr_fresh = 0.0_r8 ELSEIF ( dr_fresh < 0.0_r8 ) THEN - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min - CALL abort + CALL CoLM_stop('SNICAR snow-grain growth is negative.') ENDIF ENDIF @@ -2745,15 +2745,15 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain ELSE - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type - CALL abort + CALL CoLM_stop('SNICAR-AD received an unsupported atmospheric profile.') ENDIF ENDIF ! ! Open optics file: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Attempting to read snow optical properties .....' write(iulog,*) subname,trim(fsnowoptics) ENDIF @@ -2777,7 +2777,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) #ifdef MODAL_AER ! size-dependent BC parameters and BC enhancement factors - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' ENDIF ! @@ -2844,13 +2844,13 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ! ! - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Successfully read snow optical properties' ENDIF ! print some diagnostics: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) @@ -2865,7 +2865,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF ! #ifdef MODAL_AER - IF (p_is_root) THEN + IF (mpas_is_root) THEN ! unique dimensionality for modal aerosol optical properties write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) @@ -2878,7 +2878,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) ENDIF #else - IF (p_is_root) THEN + IF (mpas_is_root) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & @@ -2886,7 +2886,7 @@ SUBROUTINE SnowOptics_init( fsnowoptics ) ENDIF #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (DO_SNO_OC) THEN write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) @@ -2919,7 +2919,7 @@ SUBROUTINE SnowAge_init( fsnowaging ) character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name ! ! Open snow aging (effective radius evolution) file: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Attempting to read snow aging parameters .....' write(iulog,*) subname,trim(fsnowaging) ENDIF @@ -2932,12 +2932,12 @@ SUBROUTINE SnowAge_init( fsnowaging ) CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) ! - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(iulog,*) 'Successfully read snow aging properties' ENDIF ! ! print some diagnostics: - IF (p_is_root) THEN + IF (mpas_is_root) THEN write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 index bc5571c3d1..3c0e6246a0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 @@ -130,7 +130,7 @@ SUBROUTINE THERMAL (ipatch ,patchtype,is_dry_lake,lb ,deltim , #ifdef vanGenuchten_Mualem_SOIL_MODEL USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq #endif - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW, & DEF_USE_LCT,DEF_USE_PFT,DEF_USE_PC,DEF_PC_CROP_SPLIT diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 deleted file mode 100644 index 692a8a5be6..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90 +++ /dev/null @@ -1,969 +0,0 @@ -#include - -MODULE MOD_UserSpecifiedForcing - -!DESCRIPTION -!=========== - !---This MODULE is used for read atmospheric forcing dataset from various sources. - ! ------------------------------------------------------------ - ! Read forcing data from : - ! 1) PRINCETON 2) GSWP2 3) GSWP3 - ! 4) QIAN 5) CRUNCEPV4 6) CRUNCEPV7 - ! 7) ERA5LAND 8) ERA5 9) MSWX - ! 10) WFDE5 11) CRUJRA 12) WFDEI - ! 13) JRA55 14) GDAS 15) CLDAS - ! 16) CMFD 17) TPMFD 18) CMIP6 - ! 19) POINT 20) JRA3Q 21) CRA40 - ! - ! PLEASE modify the following codes when specified forcing used - ! ------------------------------------------------------------ -!Original Author: -!------------------- - !---Shupeng Zhang and Zhongwang Wei - -!References: -!------------------- - !---In preparation - -!ANCILLARY FUNCTIONS AND SUBROUTINES -!------------------- - !* :SUBROUTINE:"init_user_specified_forcing" : initialization of the selected forcing dataset - !* :SUBROUTINE:"metfilename" : identify the forcing file name - !* :SUBROUTINE:"metpreprocess" : preprocess the forcing data - -!REVISION HISTORY - !---------------- - ! 2023.05.01 Shupeng Zhang and Zhongwang Wei @ SYSU - ! 2021.12.02 Shupeng Zhang and Zhongwang Wei @ SYSU - ! Siguang Zhu and Nan Wei, 10/2014: metpreprocess for forc_q calibration - ! Hua Yuan, 04/2014: initial code of forcing structure for CoLM2014 - - USE MOD_Precision - - IMPLICIT NONE - - character(len=256) :: dataset - - logical :: solarin_all_band ! whether solar radiation in all bands is available - - character(len=256) :: HEIGHT_mode ! observation height mode - real(r8) :: HEIGHT_V ! observation height of wind speed - real(r8) :: HEIGHT_T ! observation height of air temperature - real(r8) :: HEIGHT_Q ! observation height of specific humidity - - integer :: NVAR ! variable number of forcing data - integer :: startyr ! start year of forcing data - integer :: startmo ! start month of forcing data - integer :: endyr ! END year of forcing data - integer :: endmo ! END month of forcing data - - integer, allocatable :: dtime(:) ! time interval of forcing data - integer, allocatable :: offset(:) ! offset of forcing data - - logical :: leapyear ! leapyear calendar - logical :: data2d ! data in 2 dimension (lon, lat) - logical :: hightdim ! have "z" dimension - logical :: dim2d ! lat/lon value in 2 dimension (lon, lat) - - character(len=256) :: latname ! dimension name of latitude - character(len=256) :: lonname ! dimension name of longitude - - character(len=256) :: groupby ! file grouped by year/month - - character(len=256), allocatable :: fprefix(:) ! file prefix - character(len=256), allocatable :: vname(:) ! variable name - character(len=256), allocatable :: timelog(:) ! variable time log info - character(len=256), allocatable :: tintalgo(:) ! interpolation algorithm - - ! ----- public subroutines ----- - PUBLIC :: init_user_specified_forcing ! initialization of the selected forcing dataset - PUBLIC :: metfilename ! identify the forcing file name - PUBLIC :: metpreprocess ! preprocess the forcing data - -CONTAINS - - ! ---------------- - SUBROUTINE init_user_specified_forcing - - USE MOD_Namelist - IMPLICIT NONE - - ! Local variables - integer :: ivar,NVAR_default - - NVAR = DEF_forcing%NVAR - NVAR_default=NVAR - IF (DEF_USE_CBL_HEIGHT) THEN - NVAR=NVAR+1 - ENDIF - - IF (allocated(dtime )) deallocate(dtime) - IF (allocated(offset)) deallocate(offset) - allocate (dtime (NVAR)) - allocate (offset (NVAR)) - - IF (allocated(fprefix )) deallocate(fprefix ) - IF (allocated(vname )) deallocate(vname ) - IF (allocated(timelog )) deallocate(timelog ) - IF (allocated(tintalgo)) deallocate(tintalgo) - allocate (fprefix (NVAR)) - allocate (vname (NVAR)) - allocate (timelog (NVAR)) - allocate (tintalgo (NVAR)) - - solarin_all_band = DEF_forcing%solarin_all_band ! whether solar radiation in all bands - HEIGHT_mode = DEF_forcing%HEIGHT_mode ! observation height mode - HEIGHT_V = DEF_forcing%HEIGHT_V ! observation height of wind speed - HEIGHT_T = DEF_forcing%HEIGHT_T ! observation height of air temperature - HEIGHT_Q = DEF_forcing%HEIGHT_Q ! observation height of specific humidity - - startyr = DEF_forcing%startyr ! start year of forcing data - startmo = DEF_forcing%startmo ! start month of forcing data - endyr = DEF_forcing%endyr ! end year of forcing data - endmo = DEF_forcing%endmo ! end month of forcing data - dtime(:) = DEF_forcing%dtime(:) ! time interval of forcing data - offset(:) = DEF_forcing%offset(:) ! offset of forcing data - - leapyear = DEF_forcing%leapyear ! whether leapyear calendar - data2d = DEF_forcing%data2d ! whether data in 2 dimension (lon, lat) - hightdim = DEF_forcing%hightdim ! whether have "z" dimension (height) - dim2d = DEF_forcing%dim2d ! whether lat/lon in 2 dimension (lon,lat) - - latname = DEF_forcing%latname ! dimension name of latitude - lonname = DEF_forcing%lonname ! dimension name of longitude - - groupby = DEF_forcing%groupby ! file grouped by year/month - - DO ivar = 1, NVAR_default - fprefix (ivar) = DEF_forcing%fprefix(ivar) ! file prefix - vname (ivar) = DEF_forcing%vname(ivar) ! variable name - timelog (ivar) = DEF_forcing%timelog(ivar) ! variable name - tintalgo(ivar) = DEF_forcing%tintalgo(ivar) ! interpolation algorithm - ENDDO - IF (DEF_USE_CBL_HEIGHT) THEN - fprefix (NVAR) = DEF_forcing%CBL_fprefix - vname (NVAR) = DEF_forcing%CBL_vname - tintalgo(NVAR) = DEF_forcing%CBL_tintalgo - dtime (NVAR) = DEF_forcing%CBL_dtime - offset (NVAR) = DEF_forcing%CBL_offset - ENDIF - END SUBROUTINE init_user_specified_forcing - - ! ---------------- - FUNCTION metfilename(year, month, day, var_i, is_spinup) - - USE MOD_Namelist - IMPLICIT NONE - - integer, intent(in) :: year - integer, intent(in) :: month - integer, intent(in) :: day - integer, intent(in) :: var_i - - logical, intent(in), optional :: is_spinup - - character(len=256) :: metfilename - character(len=256) :: yearstr - character(len=256) :: monthstr - - write(yearstr, '(I4.4)') year - write(monthstr, '(I2.2)') month - - IF (present(is_spinup)) THEN - IF (DEF_USE_ClimForcing_for_Spinup .and. is_spinup) THEN - yearstr = 'clim' - ENDIF - ENDIF - - select CASE (trim(DEF_forcing%dataset)) - CASE ('PRINCETON') ! Princeton forcing data - !DESCRIPTION - !=========== - !---Princeton Global Meteorological Forcing Dataset for Land Surface Modeling - - !data source: - !------------------- - !---https://rda.ucar.edu/datasets/ds314.0/ - - !References: - !------------------- - !---Sheffield, J., G. Goteti, and E. F. Wood, 2006: Development of a 50-year - ! high-resolution global dataset of meteorological forcings for land surface modeling J. - ! Climate, 19(13), 3088-3111. - - !REVISION HISTORY - !---------------- - !---2022.05.01 Zhongwang Wei @ SYSU: remove the "z" dimension - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(yearstr)//'.nc' - CASE ('GSWP3') ! GSWP3 forcing data - !DESCRIPTION - !=========== - !---Global Meteorological Forcing Dataset for Global Soil Wetness Project Phase 3 - - !data source: - !------------------- - !---http://hydro.iis.u-tokyo.ac.jp/GSWP3/ - !---https://www.isimip.org/gettingstarted/input-data-bias-adjustment/details/4/ - - !References: - !------------------- - !---Dirmeyer, P. A., Gao, X., Zhao, M., Guo, Z., Oki, T. and Hanasaki, N. (2006) GSWP-2: - ! Multimodel Analysis and Implications for Our Perception of the Land Surface. Bulletin - ! of the American Meteorological Society, 87(10), 1381-98. - - !REVISION HISTORY - !---------------- - !--- - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' - CASE ('QIAN') ! Qian forcing data - !DESCRIPTION - !=========== - !---Qian Global Meteorological Forcing Dataset from 1948 to 2004 - - !data source: - !------------------- - !---Not available now! - - !References: - !------------------- - !---Qian T., and co-authors, 2006: Simulation of Global Land Surface Conditions from 1948 - ! to 2004. Part I: Forcing Data and Evaluations. J. Hydrometeorol., 7, 953-975. - - !REVISION HISTORY - !---------------- - !--- - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' - CASE ('CRUNCEPV4') ! CRUNCEP V4 forcing data - !DESCRIPTION - !=========== - !---CRUNCEP Version 4 - Atmospheric Forcing Data for the Community Land Model - - !data source: - !------------------- - !---http://dods.extra.cea.fr/data/p529viov/cruncep/V5_1901_2013/ - - !References: - !------------------- - !---Viovy, N. (2010), CRU‐NCEP dataset. - ! [Available at: http://dods.extra.cea.fr/data/p529viov/cruncep/readme.htm.] - - !REVISION HISTORY - !---------------- - !--- - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' - CASE ('CRUNCEPV7') ! CRUNCEP V7 forcing data - !DESCRIPTION - !=========== - !---CRUNCEP Version 7 - Atmospheric Forcing Data for the Community Land Model - - !data source: - !------------------- - !---https://rda.ucar.edu/datasets/ds314.3/ - - !References: - !------------------- - !---Viovy, Nicolas. (2018). CRUNCEP Version 7 - - ! Atmospheric Forcing Data for the Community Land Model. - ! Research Data Archive at the National Center for Atmospheric Research, - ! Computational and Information Systems Laboratory. - ! https://doi.org/10.5065/PZ8F-F017. Accessed 05 May 2023. - - !REVISION HISTORY - !---------------- - !--- - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' - CASE ('ERA5LAND') ! ERA5-Land forcing data - !DESCRIPTION - !=========== - !---enhanced global dataset for the land component of the fifth - ! generation of European ReAnalysis (ERA5) - - !data source: - !------------------- - !---https://cds.climate.copernicus.eu/cdsapp#!/dataset/reanalysis-era5-land?tab=form - - !References: - !------------------- - !---Muñoz-Sabater, J., Dutra, E., Agustí-Panareda, A., Albergel, C., Arduini, G., Balsamo, - ! G., Boussetta, S., Choulga, M., Harrigan, S., Hersbach, H. and Martens, B., 2021. - ! ERA5-Land: A state-of-the-art global reanalysis dataset for land applications. Earth - ! System Science Data, 13(9), pp.4349-4383. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; - ! remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr) - select CASE (var_i) - CASE (1) - metfilename = trim(metfilename) // '_2m_temperature.nc' - CASE (2) - metfilename = trim(metfilename) //'_specific_humidity.nc' - CASE (3) - metfilename = trim(metfilename) //'_surface_pressure.nc' - CASE (4) - metfilename = trim(metfilename) //'_total_precipitation_m_hr.nc' - CASE (5) - metfilename = trim(metfilename) //'_10m_u_component_of_wind.nc' - CASE (6) - metfilename = trim(metfilename) //'_10m_v_component_of_wind.nc' - CASE (7) - metfilename = trim(metfilename) //'_surface_solar_radiation_downwards_w_m2.nc' - CASE (8) - metfilename = trim(metfilename) //'_surface_thermal_radiation_downwards_w_m2.nc' - END select - CASE ('ERA5') ! ERA5 forcing data - !DESCRIPTION - !=========== - !---The fifth generation of European ReAnalysis (ERA5) - - !data source: - !------------------- - !---https://cds.climate.copernicus.eu/cdsapp#! - ! /dataset/reanalysis-era5-single-levels?tab=overview - - !References: - !------------------- - !---Hersbach, H., Bell, B., Berrisford, P., Hirahara, S., Horányi, A., Muñoz‐Sabater, J., - ! Nicolas, J., Peubey, C., Radu, R., Schepers, D. and Simmons, A., 2020. The ERA5 global - ! reanalysis. Quarterly Journal of the Royal Meteorological Society, 146(730), - ! pp.1999-2049. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; remove - ! offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr) - select CASE (var_i) - CASE (1) - metfilename = trim(metfilename) // '_2m_temperature.nc4' - CASE (2) - metfilename = trim(metfilename) //'_q.nc4' - CASE (3) - metfilename = trim(metfilename) //'_surface_pressure.nc4' - CASE (4) - metfilename = trim(metfilename) //'_mean_total_precipitation_rate.nc4' - CASE (5) - metfilename = trim(metfilename) //'_10m_u_component_of_wind.nc4' - CASE (6) - metfilename = trim(metfilename) //'_10m_v_component_of_wind.nc4' - CASE (7) - metfilename = trim(metfilename) //'_mean_surface_downward_short_wave_radiation_flux.nc4' - CASE (8) - metfilename = trim(metfilename) //'_mean_surface_downward_long_wave_radiation_flux.nc4' - END select - CASE ('MSWX') ! MSWX forcing data - !DESCRIPTION - !=========== - !---Multi-Source Weather forcing data - - !data source: - !------------------- - !---https://www.gloh2o.org/mswx/ - - !References: - !------------------- - !---Beck, H.E., van Dijk, A.I., Larraondo, P.R., McVicar, T.R., Pan, M., Dutra, E. and - ! Miralles, D.G., 2022. MSWX: Global 3-hourly 0.1 bias-corrected meteorological data - ! including near-real-time updates and forecast ensembles. Bulletin of the American - ! Meteorological Society, 103(3), pp.E710-E732. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: Regroup data into monthly - - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)//'.nc' - CASE ('WFDE5') - !DESCRIPTION - !=========== - !---WATCH Forcing Data methodology applied to ERA5 reanalysis data - - !data source: - !------------------- - !---https://doi.org/10.24381/cds.20d54e34 - - !References: - !------------------- - !---Cucchi, M., Weedon, G.P., Amici, A., Bellouin, N., Lange, S., Müller Schmied, H., - ! Hersbach, H. and Buontempo, C., 2020. WFDE5: bias-adjusted ERA5 reanalysis data - ! for impact studies. Earth System Science Data, 12(3), pp.2097-2120. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; - ! remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'_v2.1.nc' - CASE ('CRUJRA') - !DESCRIPTION - !=========== - !---Collection of CRU JRA forcing datasets of gridded land surface blend - ! of Climatic Research Unit (CRU) and Japanese reanalysis (JRA) data - - !data source: - !------------------- - !---https://catalogue.ceda.ac.uk/uuid/863a47a6d8414b6982e1396c69a9efe8 - - !References: - !------------------- - !---University of East Anglia Climatic Research Unit; Harris, I.C. (2019): - ! CRU JRA: Collection of CRU JRA forcing datasets of gridded land surface blend - ! of Climatic Research Unit (CRU) and Japanese reanalysis (JRA) data.. - ! Centre for Environmental Data Analysis, date of citation. - !http://catalogue.ceda.ac.uk/uuid/863a47a6d8414b6982e1396c69a9efe8 - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; - ! remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'.365d.noc.nc' - - - CASE ('WFDEI') - !DESCRIPTION - !=========== - !---WATCH Forcing Data methodology applied to ERA-Interim reanalysis data - - !data source: - !------------------- - !---https://doi.org/10.24381/cds.20d54e34 - - !References: - !------------------- - !---Weedon, G.P., Balsamo, G., Bellouin, N., Gomes, S., Best, M.J. and Viterbo, P., 2014. - ! The WFDEI meteorological forcing data set: WATCH Forcing Data methodology applied - ! to ERA‐Interim reanalysis data. Water Resources Research, 50(9), pp.7505-7514. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; - ! remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc' - CASE ('JRA3Q') - !DESCRIPTION - !=========== - !---Japanese Reanalysis for Three Quarters of a Century - - !data source: - !------------------- - !---https://rda.ucar.edu/datasets/ds640.0/ - - !References: - !------------------- - !---Kosaka Y., S. Kobayashi, Y. Harada, C. Kobayashi, H. Naoe, K. Yoshimoto, M. Harada, N. - ! Goto, J. Chiba, K. Miyaoka, R. Sekiguchi, M. Deushi, H. Kamahori, T. Nakaegawa; T. - ! Y.Tanaka, T. Tokuhiro, Y. Sato, Y. Matsushita, and K. Onogi, 2024: The JRA-3Q - ! reanalysis. J. Meteor. Soc. Japan, 102, https://doi.org/10.2151/jmsj.2024-004. - - - !REVISION HISTORY - !---------------- - !---2024.03.04 Zhongwang Wei @ SYSU: remove offset and scale_factor - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)//'.nc' - - CASE ('JRA55') - !DESCRIPTION - !=========== - !---the Japanese 55-year Reanalysis - - !data source: - !------------------- - !---https://jra.kishou.go.jp/JRA-55/index_en.html - - !References: - !------------------- - !---Kobayashi, S., Y. Ota, Y. Harada, A. Ebita, M. Moriya, H. Onoda, K. Onogi, - ! H. Kamahori, C. Kobayashi, H. Endo, K. Miyaoka, and K. Takahashi , 2015: - ! The JRA-55 Reanalysis: General specifications and basic characteristics. - ! J. Meteor. Soc. Japan, 93, 5-48, doi:10.2151/jmsj.2015-001. - !---Harada, Y., H. Kamahori, C. Kobayashi, H. Endo, S. Kobayashi, Y. Ota, H. Onoda, - ! K. Onogi, K. Miyaoka, and K. Takahashi, 2016: The JRA-55 Reanalysis: Representation - ! of atmospheric circulation and climate variability, J. Meteor. Soc. Japan, 94, - ! 269-302, doi:10.2151/jmsj.2016-015. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; - ! remove offset and scale_factor - - - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc' - - - CASE ('GDAS') - !DESCRIPTION - !=========== - !--- Forcing Data From Global Data Assimilation System - - !data source: - !------------------- - !--https://disc.sci.gsfc.nasa.gov/datasets/GLDAS_NOAH025_3H_V2.1/summary - - !References: - !------------------- - !---Beaudoing, H. and M. Rodell, NASA/GSFC/HSL (2020), GLDAS Noah Land Surface Model L4 3 - ! hourly 0.25 x 0.25 degree V2.1, Greenbelt, Maryland, USA, Goddard Earth Sciences Data - ! and Information Services Center (GES DISC), Accessed: [Data Access Date], - ! 10.5067/E7TYRXPJKWOQ - !---Rodell, M., P.R. Houser, U. Jambor, J. Gottschalck, K. Mitchell, C. Meng, K. Arsenault, - ! B. Cosgrove, J. Radakovich, M. Bosilovich, J.K. Entin, J.P. Walker, D. Lohmann, and D. - ! Toll, 2004: The Global Land Data Assimilation System, Bull. Amer. Meteor. Soc., 85, - ! 381-394, doi:10.1175/BAMS-85-3-381 - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: merge the data into monthly file; - ! zip file to reduce the size of the data; remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc4' - CASE ('CLDAS') - - !DESCRIPTION - !=========== - !---The Real-Time Product Dataset Of The China Meteorological Administration - ! Land Data Assimilation System - - !data source: - !------------------- - !--CMA, not pulicly available - - !References: - !------------------- - !---Xia, Y.L.; Hao, Z.C.; Shi, C.X.; Li, Y.H.; Meng, J.; Xu, T.R.; Wu, X.Y.; Zhang, B.Q. - ! Regional and global land data assimilation systems: Innovations, challenges, and - ! prospects. J. Meteorol. Res. 2019, 33, 159-189. - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: gap filling for the missing data; - ! zip file to reduce the size of the data; remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//'-'//trim(yearstr)//trim(monthstr)//'.nc' - CASE ('CMFD') - !DESCRIPTION - !=========== - !--- The China Meteorological Forcing Dataset - - !data source: - !------------------- - !--https://data.tpdc.ac.cn/en/data/8028b944-daaa-4511-8769-965612652c49/ - - !References: - !------------------- - !---He, J., Yang, K., Tang, W., Lu, H., Qin, J., Chen, Y. and Li, X., 2020. - ! The first high-resolution meteorological forcing dataset for land process - ! studies over China. Scientific data, 7(1), p.25. - - !REVISION HISTORY - !---------------- - !--- - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc4' - CASE ('CMFDv2') - !DESCRIPTION - !=========== - !--- The China Meteorological Forcing Dataset version 2.0 - - !data source: - !------------------- - !--https://data.tpdc.ac.cn/en/data/e60dfd96-5fd8-493f-beae-e8e5d24dece4 - - !References: - !------------------- - !---He, J., Yang, K., Li, X., Tang, W., Shao, C., Jiang, Y., Ding, B. 2024. - ! The China Meteorological Forcing Dataset (CMFD) version 2.0. - ! National Tibetan Plateau/Third Pole Environment Data Center, - ! https://doi.org/10.11888/Atmos.tpdc.300398. https://cstr.cn/18406.11.Atmos.tpdc.300398. - - !REVISION HISTORY - !---------------- - !--- - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc' - CASE ('CMIP6') - !DESCRIPTION - !=========== - !---the Climate Model Intercomparison Project Phase 6 (CMIP6) forcing data sets - - !data source: - !------------------- - !---https://esgf-node.llnl.gov/projects/cmip6/ - - !References: - !------------------- - !--- - - !REVISION HISTORY - !---------------- - !---2021.11.01 Zhongwang Wei @ SYSU: regroup the data into monthly file; - ! zip file to reduce the size of the data; remove offset and scale_factor - - - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc' - - CASE ('CRA40') - !DESCRIPTION - !=========== - !---CMA first-generation global atmospheric reanalysis (RA) covering 1979-2018 (CRA-40) - - !data source: - !------------------- - !---https://data.cma.cn/en - - !References: - !------------------- - !---Liu, Z., Jiang, L., Shi, C. et al. CRA-40/Atmosphere—The First-Generation Chinese - ! Atmospheric Reanalysis (1979-2018): System Description and Performance Evaluation. J - ! Meteorol Res 37, 1-19 (2023). https://doi.org/10.1007/s13351-023-2086-x - - - - !REVISION HISTORY - !---------------- - !---2024.04.10 Zhongwang Wei @ SYSU: regroup the data into annual file; - ! zip file to reduce the size of the data; remove offset and scale_factor - - - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc' - CASE ('TPMFD') - !DESCRIPTION - !=========== - !---A high-resolution near-surface meteorological forcing dataset for the Third Pole region - - !data source: - !------------------- - !---https://data.tpdc.ac.cn/zh-hans/data/44a449ce-e660-44c3-bbf2-31ef7d716ec7 - - !References: - !------------------- - !---Yang, K., Jiang, Y., Tang, W., He, J., Shao, C., Zhou, X., Lu, H., - ! Chen, Y., Li, X., Shi, J. (2023). A high-resolution near-surface - ! meteorological forcing dataset for the Third Pole region （TPMFD, 1979-2020）. - ! National Tibetan Plateau/Third Pole Environment Data Center, - ! https://doi.org/10.11888/Atmos.tpdc.300398. https://cstr.cn/18406.11.Atmos.tpdc.300398. - - !REVISION HISTORY - !---------------- - !---2023.11.01 Zhongwang Wei @ SYSU: regroup the data into monthly file; - ! zip file to reduce the size of the data; remove offset and scale_factor - - metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc' - CASE ('IsoGSM') - !DESCRIPTION - !=========== - !--- Isotopes-incorporated Global Spectral Model (IsoGSM) - - !data source: - !------------------- - !---https://isotope.iis.u-tokyo.ac.jp/about-our-lab?lang=en - - !References: - !------------------- - !---Bong, H., Cauquoin, A., Okazaki, A., Chang, E.-C., Werner, M., Wei, Z., et al. (2024). - ! Process-based intercomparison of water isotope-enabled models and reanalysis nudging effects. - ! Journal of Geophysical Research: Atmospheres, 129, e2023JD038719. - ! https://doi.org/10.1029/2023JD038719 - - !REVISION HISTORY - !---------------- - !---2025.03.23 Zhongwang Wei @ SYSU: add the isotope forcing data - - metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc' - - - CASE ('POINT') - metfilename = '/'//trim(fprefix(1)) - END select - IF (DEF_USE_CBL_HEIGHT) THEN - select CASE (var_i) - CASE (9) - metfilename = '/'//trim(fprefix(9))//'_'//trim(yearstr)//'_'//trim(monthstr)//& - '_boundary_layer_height.nc4' - END select - ENDIF - END FUNCTION metfilename - - ! preprocess for forcing data [not applicable yet for PRINCETON] - ! ------------------------------------------------------------ - SUBROUTINE metpreprocess(grid, forcn, has_missing_value, forcfirst, missing_value) - - USE MOD_Const_Physical - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_Qsadv - IMPLICIT NONE - type(grid_type), intent(in) :: grid - type(block_data_real8_2d), intent(inout) :: forcn(:) - type(block_data_real8_2d), intent(in) :: forcfirst - logical, intent(in) :: has_missing_value - real(r8), intent(in) :: missing_value - - integer :: iblkme, ib, jb, i, j - real(r8) :: es, esdT, qsat_tmp, dqsat_tmpdT, e, ea - - !---------------------------------------------------------------------------- - ! use polynomials to calculate saturation vapor pressure and derivative with - ! respect to temperature: over water when t > 0 c and over ice when t <= 0 c - ! required to convert relative humidity to specific humidity - !---------------------------------------------------------------------------- - IF (trim(DEF_forcing%dataset) == 'POINT') THEN -#ifdef SinglePoint - CALL qsadv(forcn(1)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1), & - forcn(3)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1)) THEN - forcn(2)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1) = qsat_tmp - ENDIF -#endif - ELSE - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - DO j = 1, grid%ycnt(jb) - DO i = 1, grid%xcnt(ib) - - IF (has_missing_value) THEN - IF (forcfirst%blk(ib,jb)%val(i,j) == missing_value) THEN - CYCLE - ENDIF - ENDIF - - select CASE (trim(DEF_forcing%dataset)) - - CASE ('PRINCETON') - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('GSWP2') - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('GSWP3') - IF (forcn(1)%blk(ib,jb)%val(i,j)<212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0 - IF (forcn(4)%blk(ib,jb)%val(i,j)<0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('QIAN') - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - e = forcn(3)%blk(ib,jb)%val(i,j) * forcn(2)%blk(ib,jb)%val(i,j) & - / (0.622_R8 + 0.378_R8 * forcn(2)%blk(ib,jb)%val(i,j)) - ea = 0.70_R8 + 5.95e-05_R8 * 0.01_R8 * e & - * exp(1500.0_R8/forcn(1)%blk(ib,jb)%val(i,j)) - forcn(8)%blk(ib,jb)%val(i,j) = ea * stefnc * forcn(1)%blk(ib,jb)%val(i,j)**4 - - CASE ('CRUNCEPV4') - - IF (forcn(1)%blk(ib,jb)%val(i,j) < 212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0 - IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - IF (forcn(7)%blk(ib,jb)%val(i,j) < 0.0) forcn(7)%blk(ib,jb)%val(i,j) = 0.0 - ! 12th grade of Typhoon 32.7-36.9 m/s - IF (abs(forcn(5)%blk(ib,jb)%val(i,j)) > 40.0) forcn(5)%blk(ib,jb)%val(i,j) = & - 40.0*forcn(5)%blk(ib,jb)%val(i,j)/abs(forcn(5)%blk(ib,jb)%val(i,j)) - IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) forcn(6)%blk(ib,jb)%val(i,j) = & - 40.0*forcn(6)%blk(ib,jb)%val(i,j)/abs(forcn(6)%blk(ib,jb)%val(i,j)) - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('CRUNCEPV7') - - IF (forcn(1)%blk(ib,jb)%val(i,j) < 212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0 - IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - IF (forcn(7)%blk(ib,jb)%val(i,j) < 0.0) forcn(7)%blk(ib,jb)%val(i,j) = 0.0 - ! 12th grade of Typhoon 32.7-36.9 m/s - ! NOTE by Wenzong: This is a problem when running a GNU-compiled PROGRAM, - ! because there is no data of forcn(5), temporarily comment the code below - ! IF (abs(forcn(5)%blk(ib,jb)%val(i,j))>40.0) forcn(5)%blk(ib,jb)%val(i,j) = & - ! 40.0*forcn(5)%blk(ib,jb)%val(i,j)/abs(forcn(5)%blk(ib,jb)%val(i,j)) - IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) forcn(6)%blk(ib,jb)%val(i,j) = & - 40.0*forcn(6)%blk(ib,jb)%val(i,j)/abs(forcn(6)%blk(ib,jb)%val(i,j)) - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('ERA5LAND') - - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j) * 1000./3600. - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('ERA5') - - IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - IF (abs(forcn(5)%blk(ib,jb)%val(i,j)) > 40.0) & - forcn(5)%blk(ib,jb)%val(i,j) = 40.0*sign(1.0,forcn(5)%blk(ib,jb)%val(i,j)) - IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) & - forcn(6)%blk(ib,jb)%val(i,j) = 40.0*sign(1.0,forcn(6)%blk(ib,jb)%val(i,j)) - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - - CASE ('MSWX') - - forcn(1)%blk(ib,jb)%val(i,j)=forcn(1)%blk(ib,jb)%val(i,j)+273.15 - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/10800. - IF (forcn(4)%blk(ib,jb)%val(i,j)>1000.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - IF (forcn(2)%blk(ib,jb)%val(i,j)<0.5E-05) & - forcn(2)%blk(ib,jb)%val(i,j) = 0.5E-05 - - CASE ('WFDE5') - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('WFDEI') - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('CLDAS') ! CLDAS forcing - - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600. - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('CMFD') ! CMFD forcing - - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600. - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - CASE ('CMFDv2') ! CMFDv2 forcing - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('CRUJRA') ! CRUJRA forcing - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/21600. - forcn(7)%blk(ib,jb)%val(i,j)=forcn(7)%blk(ib,jb)%val(i,j)/21600. - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('GDAS') ! GDAS forcing - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('JRA55') ! JRA55 forcing - - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/86400.0 !mm/s - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('JRA3Q') ! JRA3Q forcing - - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j) - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('TPMFD') ! TPMFD forcing - - forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600.!convert to mm/s - forcn(3)%blk(ib,jb)%val(i,j)=forcn(3)%blk(ib,jb)%val(i,j)*100. !convert to pa - - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - CASE ('CMIP6') ! CMIP6 forcing - - IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0 - - CASE ('IsoGSM') ! IsoGSM forcing - CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), & - es,esdT,qsat_tmp,dqsat_tmpdT) - IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN - forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp - ENDIF - - END select - - ENDDO - ENDDO - ENDDO - ENDIF - - END SUBROUTINE metpreprocess - -END MODULE MOD_UserSpecifiedForcing -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 deleted file mode 100644 index ee50c2aa0f..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 +++ /dev/null @@ -1,2970 +0,0 @@ -#include - -MODULE MOD_Vars_1DAccFluxes - - USE MOD_Precision -#ifdef DataAssimilation - USE MOD_DA_Vars_TimeVariables - USE MOD_DA_Vars_1DFluxes - USE MOD_Namelist -#endif -#ifdef EXTERNAL_LAKE - USE MOD_Lake_1DAccVars -#endif - - real(r8) :: nac ! number of accumulation - real(r8), allocatable :: nac_ln (:) - real(r8), allocatable :: nac_dt (:) - logical, allocatable :: filter_dt (:) - - real(r8), allocatable :: a_us (:) - real(r8), allocatable :: a_vs (:) - real(r8), allocatable :: a_t (:) - real(r8), allocatable :: a_q (:) - real(r8), allocatable :: a_prc (:) - real(r8), allocatable :: a_prl (:) - real(r8), allocatable :: a_pbot (:) - real(r8), allocatable :: a_frl (:) - real(r8), allocatable :: a_solarin (:) - real(r8), allocatable :: a_hpbl (:) - - real(r8), allocatable :: a_taux (:) - real(r8), allocatable :: a_tauy (:) - real(r8), allocatable :: a_fsena (:) - real(r8), allocatable :: a_lfevpa (:) - real(r8), allocatable :: a_fevpa (:) - real(r8), allocatable :: a_fsenl (:) - real(r8), allocatable :: a_fevpl (:) - real(r8), allocatable :: a_etr (:) - real(r8), allocatable :: a_fseng (:) - real(r8), allocatable :: a_fevpg (:) - real(r8), allocatable :: a_fgrnd (:) - real(r8), allocatable :: a_sabvsun (:) - real(r8), allocatable :: a_sabvsha (:) - real(r8), allocatable :: a_sabg (:) - real(r8), allocatable :: a_olrg (:) - real(r8), allocatable :: a_rnet (:) - real(r8), allocatable :: a_xerr (:) - real(r8), allocatable :: a_zerr (:) - real(r8), allocatable :: a_rsur (:) - real(r8), allocatable :: a_rsur_se (:) - real(r8), allocatable :: a_rsur_ie (:) - real(r8), allocatable :: a_rsub (:) - real(r8), allocatable :: a_rnof (:) -#ifdef CatchLateralFlow - real(r8), allocatable :: a_xwsur (:) - real(r8), allocatable :: a_xwsub (:) - real(r8), allocatable :: a_fldarea (:) -#endif - real(r8), allocatable :: a_qintr (:) - real(r8), allocatable :: a_qinfl (:) - real(r8), allocatable :: a_qdrip (:) - real(r8), allocatable :: a_rstfacsun (:) - real(r8), allocatable :: a_rstfacsha (:) - real(r8), allocatable :: a_gssun (:) - real(r8), allocatable :: a_gssha (:) - real(r8), allocatable :: a_rss (:) - real(r8), allocatable :: a_wdsrf (:) - real(r8), allocatable :: a_zwt (:) - real(r8), allocatable :: a_wa (:) - real(r8), allocatable :: a_wat (:) - real(r8), allocatable :: a_wetwat (:) - real(r8), allocatable :: a_assim (:) - real(r8), allocatable :: a_respc (:) - real(r8), allocatable :: a_assimsun (:) - real(r8), allocatable :: a_assimsha (:) - real(r8), allocatable :: a_etrsun (:) - real(r8), allocatable :: a_etrsha (:) - - real(r8), allocatable :: a_qcharge (:) - - real(r8), allocatable :: a_t_grnd (:) - real(r8), allocatable :: a_tleaf (:) - real(r8), allocatable :: a_ldew (:) - real(r8), allocatable :: a_ldew_rain (:) - real(r8), allocatable :: a_ldew_snow (:) - real(r8), allocatable :: a_scv (:) - real(r8), allocatable :: a_snowdp (:) - real(r8), allocatable :: a_fsno (:) - real(r8), allocatable :: a_frcsat (:) - real(r8), allocatable :: a_sigf (:) - real(r8), allocatable :: a_green (:) - real(r8), allocatable :: a_lai (:) - real(r8), allocatable :: a_laisun (:) - real(r8), allocatable :: a_laisha (:) - real(r8), allocatable :: a_sai (:) - real(r8), allocatable :: a_alb (:,:,:) - -#ifdef HYPERSPECTRAL - real(r8), allocatable :: a_alb_hires (:,:,:) - real(r8), allocatable :: a_reflectance_out (:,:,:) - real(r8), allocatable :: a_transmittance_out (:,:,:) -#endif - real(r8), allocatable :: a_emis (:) - real(r8), allocatable :: a_z0m (:) - real(r8), allocatable :: a_trad (:) - real(r8), allocatable :: a_tref (:) - real(r8), allocatable :: a_t2m_wmo (:) - real(r8), allocatable :: a_qref (:) - real(r8), allocatable :: a_rain (:) - real(r8), allocatable :: a_snow (:) - - real(r8), allocatable :: a_o3uptakesun(:) - real(r8), allocatable :: a_o3uptakesha(:) - -#ifdef DataAssimilation - real(r8), allocatable :: a_h2osoi_ens (:,:,:) - real(r8), allocatable :: a_t_brt_smap_ens (:,:,:) - real(r8), allocatable :: a_t_brt_fy3d_ens (:,:,:) - real(r8), allocatable :: a_t_brt_smap (:,:) - real(r8), allocatable :: a_t_brt_fy3d (:,:) - real(r8), allocatable :: a_wliq_soisno_ens(:,:,:) - real(r8), allocatable :: a_wice_soisno_ens(:,:,:) - real(r8), allocatable :: a_t_soisno_ens (:,:,:) -#endif - -#ifdef URBAN_MODEL - real(r8), allocatable :: a_t_room (:) !temperature of inner building [K] - real(r8), allocatable :: a_tafu (:) !temperature of outer building [K] - real(r8), allocatable :: a_fhac (:) !sensible flux from heat or cool AC [W/m2] - real(r8), allocatable :: a_fwst (:) !waste heat flux from heat or cool AC [W/m2] - real(r8), allocatable :: a_fach (:) !flux from inner and outer air exchange [W/m2] - real(r8), allocatable :: a_fahe (:) !flux from metabolic and vehicle [W/m2] - real(r8), allocatable :: a_fhah (:) !sensible flux from heating [W/m2] - real(r8), allocatable :: a_vehc (:) !flux from vehicle [W/m2] - real(r8), allocatable :: a_meta (:) !flux from metabolic [W/m2] - - real(r8), allocatable :: a_senroof (:) !sensible heat flux from roof [W/m2] - real(r8), allocatable :: a_senwsun (:) !sensible heat flux from sunlit wall [W/m2] - real(r8), allocatable :: a_senwsha (:) !sensible heat flux from shaded wall [W/m2] - real(r8), allocatable :: a_sengimp (:) !sensible heat flux from impervious road [W/m2] - real(r8), allocatable :: a_sengper (:) !sensible heat flux from pervious road [W/m2] - real(r8), allocatable :: a_senurbl (:) !sensible heat flux from urban vegetation [W/m2] - - real(r8), allocatable :: a_lfevproof (:) !latent heat flux from roof [W/m2] - real(r8), allocatable :: a_lfevpgimp (:) !latent heat flux from impervious road [W/m2] - real(r8), allocatable :: a_lfevpgper (:) !latent heat flux from pervious road [W/m2] - real(r8), allocatable :: a_lfevpurbl (:) !latent heat flux from urban vegetation [W/m2] - - real(r8), allocatable :: a_troof (:) !temperature of roof [K] - real(r8), allocatable :: a_twall (:) !temperature of wall [K] -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - real(r8), allocatable :: a_lai_enftemp (:) !1 - real(r8), allocatable :: a_lai_enfboreal (:) !2 - real(r8), allocatable :: a_lai_dnfboreal (:) !3 - real(r8), allocatable :: a_lai_ebftrop (:) !4 - real(r8), allocatable :: a_lai_ebftemp (:) !5 - real(r8), allocatable :: a_lai_dbftrop (:) !6 - real(r8), allocatable :: a_lai_dbftemp (:) !7 - real(r8), allocatable :: a_lai_dbfboreal (:) !8 - real(r8), allocatable :: a_lai_ebstemp (:) !9 - real(r8), allocatable :: a_lai_dbstemp (:) !10 - real(r8), allocatable :: a_lai_dbsboreal (:) !11 - real(r8), allocatable :: a_lai_c3arcgrass (:) !12 - real(r8), allocatable :: a_lai_c3grass (:) !13 - real(r8), allocatable :: a_lai_c4grass (:) !14 -#endif - -#ifdef BGC - real(r8), allocatable :: a_leafc (:) - real(r8), allocatable :: a_leafc_storage (:) - real(r8), allocatable :: a_leafc_xfer (:) - real(r8), allocatable :: a_frootc (:) - real(r8), allocatable :: a_frootc_storage (:) - real(r8), allocatable :: a_frootc_xfer (:) - real(r8), allocatable :: a_livestemc (:) - real(r8), allocatable :: a_livestemc_storage (:) - real(r8), allocatable :: a_livestemc_xfer (:) - real(r8), allocatable :: a_deadstemc (:) - real(r8), allocatable :: a_deadstemc_storage (:) - real(r8), allocatable :: a_deadstemc_xfer (:) - real(r8), allocatable :: a_livecrootc (:) - real(r8), allocatable :: a_livecrootc_storage (:) - real(r8), allocatable :: a_livecrootc_xfer (:) - real(r8), allocatable :: a_deadcrootc (:) - real(r8), allocatable :: a_deadcrootc_storage (:) - real(r8), allocatable :: a_deadcrootc_xfer (:) - real(r8), allocatable :: a_grainc (:) - real(r8), allocatable :: a_grainc_storage (:) - real(r8), allocatable :: a_grainc_xfer (:) - real(r8), allocatable :: a_leafn (:) - real(r8), allocatable :: a_leafn_storage (:) - real(r8), allocatable :: a_leafn_xfer (:) - real(r8), allocatable :: a_frootn (:) - real(r8), allocatable :: a_frootn_storage (:) - real(r8), allocatable :: a_frootn_xfer (:) - real(r8), allocatable :: a_livestemn (:) - real(r8), allocatable :: a_livestemn_storage (:) - real(r8), allocatable :: a_livestemn_xfer (:) - real(r8), allocatable :: a_deadstemn (:) - real(r8), allocatable :: a_deadstemn_storage (:) - real(r8), allocatable :: a_deadstemn_xfer (:) - real(r8), allocatable :: a_livecrootn (:) - real(r8), allocatable :: a_livecrootn_storage (:) - real(r8), allocatable :: a_livecrootn_xfer (:) - real(r8), allocatable :: a_deadcrootn (:) - real(r8), allocatable :: a_deadcrootn_storage (:) - real(r8), allocatable :: a_deadcrootn_xfer (:) - real(r8), allocatable :: a_grainn (:) - real(r8), allocatable :: a_grainn_storage (:) - real(r8), allocatable :: a_grainn_xfer (:) - real(r8), allocatable :: a_retransn (:) - real(r8), allocatable :: a_gpp (:) - real(r8), allocatable :: a_downreg (:) - real(r8), allocatable :: a_ar (:) - real(r8), allocatable :: a_cwdprod (:) - real(r8), allocatable :: a_cwddecomp (:) - real(r8), allocatable :: a_hr (:) - real(r8), allocatable :: a_fpg (:) - real(r8), allocatable :: a_fpi (:) - real(r8), allocatable :: a_totvegc (:) - real(r8), allocatable :: a_totlitc (:) - real(r8), allocatable :: a_totcwdc (:) - real(r8), allocatable :: a_totsomc (:) - real(r8), allocatable :: a_totcolc (:) - real(r8), allocatable :: a_totvegn (:) - real(r8), allocatable :: a_totlitn (:) - real(r8), allocatable :: a_totcwdn (:) - real(r8), allocatable :: a_totsomn (:) - real(r8), allocatable :: a_totcoln (:) - real(r8), allocatable :: a_gpp_enftemp (:) !1 - real(r8), allocatable :: a_gpp_enfboreal (:) !2 - real(r8), allocatable :: a_gpp_dnfboreal (:) !3 - real(r8), allocatable :: a_gpp_ebftrop (:) !4 - real(r8), allocatable :: a_gpp_ebftemp (:) !5 - real(r8), allocatable :: a_gpp_dbftrop (:) !6 - real(r8), allocatable :: a_gpp_dbftemp (:) !7 - real(r8), allocatable :: a_gpp_dbfboreal (:) !8 - real(r8), allocatable :: a_gpp_ebstemp (:) !9 - real(r8), allocatable :: a_gpp_dbstemp (:) !10 - real(r8), allocatable :: a_gpp_dbsboreal (:) !11 - real(r8), allocatable :: a_gpp_c3arcgrass (:) !12 - real(r8), allocatable :: a_gpp_c3grass (:) !13 - real(r8), allocatable :: a_gpp_c4grass (:) !14 - real(r8), allocatable :: a_npp_enftemp (:) !1 - real(r8), allocatable :: a_npp_enfboreal (:) !2 - real(r8), allocatable :: a_npp_dnfboreal (:) !3 - real(r8), allocatable :: a_npp_ebftrop (:) !4 - real(r8), allocatable :: a_npp_ebftemp (:) !5 - real(r8), allocatable :: a_npp_dbftrop (:) !6 - real(r8), allocatable :: a_npp_dbftemp (:) !7 - real(r8), allocatable :: a_npp_dbfboreal (:) !8 - real(r8), allocatable :: a_npp_ebstemp (:) !9 - real(r8), allocatable :: a_npp_dbstemp (:) !10 - real(r8), allocatable :: a_npp_dbsboreal (:) !11 - real(r8), allocatable :: a_npp_c3arcgrass (:) !12 - real(r8), allocatable :: a_npp_c3grass (:) !13 - real(r8), allocatable :: a_npp_c4grass (:) !14 - real(r8), allocatable :: a_npptoleafc_enftemp (:) !1 - real(r8), allocatable :: a_npptoleafc_enfboreal (:) !2 - real(r8), allocatable :: a_npptoleafc_dnfboreal (:) !3 - real(r8), allocatable :: a_npptoleafc_ebftrop (:) !4 - real(r8), allocatable :: a_npptoleafc_ebftemp (:) !5 - real(r8), allocatable :: a_npptoleafc_dbftrop (:) !6 - real(r8), allocatable :: a_npptoleafc_dbftemp (:) !7 - real(r8), allocatable :: a_npptoleafc_dbfboreal (:) !8 - real(r8), allocatable :: a_npptoleafc_ebstemp (:) !9 - real(r8), allocatable :: a_npptoleafc_dbstemp (:) !10 - real(r8), allocatable :: a_npptoleafc_dbsboreal (:) !11 - real(r8), allocatable :: a_npptoleafc_c3arcgrass (:) !12 - real(r8), allocatable :: a_npptoleafc_c3grass (:) !13 - real(r8), allocatable :: a_npptoleafc_c4grass (:) !14 - real(r8), allocatable :: a_leafc_enftemp (:) !1 - real(r8), allocatable :: a_leafc_enfboreal (:) !2 - real(r8), allocatable :: a_leafc_dnfboreal (:) !3 - real(r8), allocatable :: a_leafc_ebftrop (:) !4 - real(r8), allocatable :: a_leafc_ebftemp (:) !5 - real(r8), allocatable :: a_leafc_dbftrop (:) !6 - real(r8), allocatable :: a_leafc_dbftemp (:) !7 - real(r8), allocatable :: a_leafc_dbfboreal (:) !8 - real(r8), allocatable :: a_leafc_ebstemp (:) !9 - real(r8), allocatable :: a_leafc_dbstemp (:) !10 - real(r8), allocatable :: a_leafc_dbsboreal (:) !11 - real(r8), allocatable :: a_leafc_c3arcgrass (:) !12 - real(r8), allocatable :: a_leafc_c3grass (:) !13 - real(r8), allocatable :: a_leafc_c4grass (:) !14 - real(r8), allocatable :: a_O2_DECOMP_DEPTH_UNSAT (:,:) - real(r8), allocatable :: a_CONC_O2_UNSAT (:,:) -#ifdef CROP - real(r8), allocatable :: a_pdcorn (:) - real(r8), allocatable :: a_pdswheat (:) - real(r8), allocatable :: a_pdwwheat (:) - real(r8), allocatable :: a_pdsoybean (:) - real(r8), allocatable :: a_pdcotton (:) - real(r8), allocatable :: a_pdrice1 (:) - real(r8), allocatable :: a_pdrice2 (:) - real(r8), allocatable :: a_pdsugarcane (:) - real(r8), allocatable :: a_plantdate (:) - real(r8), allocatable :: a_manunitro (:) - real(r8), allocatable :: a_fertnitro_corn (:) - real(r8), allocatable :: a_fertnitro_swheat (:) - real(r8), allocatable :: a_fertnitro_wwheat (:) - real(r8), allocatable :: a_fertnitro_soybean (:) - real(r8), allocatable :: a_fertnitro_cotton (:) - real(r8), allocatable :: a_fertnitro_rice1 (:) - real(r8), allocatable :: a_fertnitro_rice2 (:) - real(r8), allocatable :: a_fertnitro_sugarcane (:) - real(r8), allocatable :: a_irrig_method_corn (:) - real(r8), allocatable :: a_irrig_method_swheat (:) - real(r8), allocatable :: a_irrig_method_wwheat (:) - real(r8), allocatable :: a_irrig_method_soybean (:) - real(r8), allocatable :: a_irrig_method_cotton (:) - real(r8), allocatable :: a_irrig_method_rice1 (:) - real(r8), allocatable :: a_irrig_method_rice2 (:) - real(r8), allocatable :: a_irrig_method_sugarcane(:) - - real(r8), allocatable :: a_cphase (:) - real(r8), allocatable :: a_gddplant (:) - real(r8), allocatable :: a_gddmaturity (:) - real(r8), allocatable :: a_vf (:) - real(r8), allocatable :: a_hui (:) - real(r8), allocatable :: a_cropprod1c (:) - real(r8), allocatable :: a_cropprod1c_loss (:) - real(r8), allocatable :: a_cropseedc_deficit (:) - real(r8), allocatable :: a_grainc_to_cropprodc (:) - real(r8), allocatable :: a_grainc_to_seed (:) - real(r8), allocatable :: a_fert_to_sminn (:) - - real(r8), allocatable :: a_sum_irrig (:) - real(r8), allocatable :: a_sum_deficit_irrig (:) - real(r8), allocatable :: a_sum_irrig_count (:) - real(r8), allocatable :: a_waterstorage (:) - real(r8), allocatable :: a_groundwater_demand (:) - real(r8), allocatable :: a_groundwater_supply (:) - real(r8), allocatable :: a_reservoirriver_demand(:) - real(r8), allocatable :: a_reservoirriver_supply(:) - real(r8), allocatable :: a_reservoir_supply (:) - real(r8), allocatable :: a_river_supply (:) - real(r8), allocatable :: a_runoff_supply (:) -#endif - real(r8), allocatable :: a_ndep_to_sminn (:) - real(r8), allocatable :: a_abm (:) - real(r8), allocatable :: a_gdp (:) - real(r8), allocatable :: a_peatf (:) - real(r8), allocatable :: a_hdm (:) - real(r8), allocatable :: a_lnfm (:) - real(r8), allocatable :: a_leafcCap (:) - real(r8), allocatable :: a_leafc_storageCap (:) - real(r8), allocatable :: a_leafc_xferCap (:) - real(r8), allocatable :: a_frootcCap (:) - real(r8), allocatable :: a_frootc_storageCap (:) - real(r8), allocatable :: a_frootc_xferCap (:) - real(r8), allocatable :: a_livestemcCap (:) - real(r8), allocatable :: a_livestemc_storageCap (:) - real(r8), allocatable :: a_livestemc_xferCap (:) - real(r8), allocatable :: a_deadstemcCap (:) - real(r8), allocatable :: a_deadstemc_storageCap (:) - real(r8), allocatable :: a_deadstemc_xferCap (:) - real(r8), allocatable :: a_livecrootcCap (:) - real(r8), allocatable :: a_livecrootc_storageCap (:) - real(r8), allocatable :: a_livecrootc_xferCap (:) - real(r8), allocatable :: a_deadcrootcCap (:) - real(r8), allocatable :: a_deadcrootc_storageCap (:) - real(r8), allocatable :: a_deadcrootc_xferCap (:) - real(r8), allocatable :: a_leafnCap (:) - real(r8), allocatable :: a_leafn_storageCap (:) - real(r8), allocatable :: a_leafn_xferCap (:) - real(r8), allocatable :: a_frootnCap (:) - real(r8), allocatable :: a_frootn_storageCap (:) - real(r8), allocatable :: a_frootn_xferCap (:) - real(r8), allocatable :: a_livestemnCap (:) - real(r8), allocatable :: a_livestemn_storageCap (:) - real(r8), allocatable :: a_livestemn_xferCap (:) - real(r8), allocatable :: a_deadstemnCap (:) - real(r8), allocatable :: a_deadstemn_storageCap (:) - real(r8), allocatable :: a_deadstemn_xferCap (:) - real(r8), allocatable :: a_livecrootnCap (:) - real(r8), allocatable :: a_livecrootn_storageCap (:) - real(r8), allocatable :: a_livecrootn_xferCap (:) - real(r8), allocatable :: a_deadcrootnCap (:) - real(r8), allocatable :: a_deadcrootn_storageCap (:) - real(r8), allocatable :: a_deadcrootn_xferCap (:) -#endif -! Ozone stress variables - real(r8), allocatable :: a_ozone (:) -! End ozone stress variables - - real(r8), allocatable :: a_t_soisno (:,:) - real(r8), allocatable :: a_wliq_soisno (:,:) - real(r8), allocatable :: a_wice_soisno (:,:) - real(r8), allocatable :: a_h2osoi (:,:) - real(r8), allocatable :: a_qlayer (:,:) - real(r8), allocatable :: a_lake_deficit (:) - real(r8), allocatable :: a_rootr (:,:) - real(r8), allocatable :: a_BD_all (:,:) - real(r8), allocatable :: a_wfc (:,:) - real(r8), allocatable :: a_OM_density (:,:) -!Plant Hydraulic parameters - real(r8), allocatable :: a_vegwp (:,:) -!END plant hydraulic parameters - real(r8), allocatable :: a_dz_lake (:,:) - real(r8), allocatable :: a_t_lake (:,:) - real(r8), allocatable :: a_lake_icefrac(:,:) - -#ifdef BGC - real(r8), allocatable :: a_litr1c_vr (:,:) - real(r8), allocatable :: a_litr2c_vr (:,:) - real(r8), allocatable :: a_litr3c_vr (:,:) - real(r8), allocatable :: a_soil1c_vr (:,:) - real(r8), allocatable :: a_soil2c_vr (:,:) - real(r8), allocatable :: a_soil3c_vr (:,:) - real(r8), allocatable :: a_cwdc_vr (:,:) - real(r8), allocatable :: a_litr1n_vr (:,:) - real(r8), allocatable :: a_litr2n_vr (:,:) - real(r8), allocatable :: a_litr3n_vr (:,:) - real(r8), allocatable :: a_soil1n_vr (:,:) - real(r8), allocatable :: a_soil2n_vr (:,:) - real(r8), allocatable :: a_soil3n_vr (:,:) - real(r8), allocatable :: a_cwdn_vr (:,:) - real(r8), allocatable :: a_totsoiln_vr (:,:) - real(r8), allocatable :: a_litr1cCap_vr(:,:) - real(r8), allocatable :: a_litr2cCap_vr(:,:) - real(r8), allocatable :: a_litr3cCap_vr(:,:) - real(r8), allocatable :: a_soil1cCap_vr(:,:) - real(r8), allocatable :: a_soil2cCap_vr(:,:) - real(r8), allocatable :: a_soil3cCap_vr(:,:) - real(r8), allocatable :: a_cwdcCap_vr (:,:) - real(r8), allocatable :: a_litr1nCap_vr(:,:) - real(r8), allocatable :: a_litr2nCap_vr(:,:) - real(r8), allocatable :: a_litr3nCap_vr(:,:) - real(r8), allocatable :: a_soil1nCap_vr(:,:) - real(r8), allocatable :: a_soil2nCap_vr(:,:) - real(r8), allocatable :: a_soil3nCap_vr(:,:) - real(r8), allocatable :: a_cwdnCap_vr (:,:) - real(r8), allocatable :: a_t_scalar (:,:) - real(r8), allocatable :: a_w_scalar (:,:) - real(r8), allocatable :: a_sminn_vr (:,:) - real(r8), allocatable :: decomp_vr_tmp (:,:) -#endif - - real(r8), allocatable :: a_ustar (:) - real(r8), allocatable :: a_ustar2 (:) - real(r8), allocatable :: a_tstar (:) - real(r8), allocatable :: a_qstar (:) - real(r8), allocatable :: a_zol (:) - real(r8), allocatable :: a_rib (:) - real(r8), allocatable :: a_fm (:) - real(r8), allocatable :: a_fh (:) - real(r8), allocatable :: a_fq (:) - - real(r8), allocatable :: a_us10m (:) - real(r8), allocatable :: a_vs10m (:) - real(r8), allocatable :: a_fm10m (:) - - real(r8), allocatable :: a_sr (:) - real(r8), allocatable :: a_solvd (:) - real(r8), allocatable :: a_solvi (:) - real(r8), allocatable :: a_solnd (:) - real(r8), allocatable :: a_solni (:) - real(r8), allocatable :: a_srvd (:) - real(r8), allocatable :: a_srvi (:) - real(r8), allocatable :: a_srnd (:) - real(r8), allocatable :: a_srni (:) - real(r8), allocatable :: a_solvdln (:) - real(r8), allocatable :: a_solviln (:) - real(r8), allocatable :: a_solndln (:) - real(r8), allocatable :: a_solniln (:) - real(r8), allocatable :: a_srvdln (:) - real(r8), allocatable :: a_srviln (:) - real(r8), allocatable :: a_srndln (:) - real(r8), allocatable :: a_srniln (:) -#ifdef HYPERSPECTRAL - real(r8), allocatable :: a_sol_dir_ln_hires(:,:) - real(r8), allocatable :: a_sol_dif_ln_hires(:,:) - real(r8), allocatable :: a_sr_dir_ln_hires (:,:) - real(r8), allocatable :: a_sr_dif_ln_hires (:,:) -#endif - real(r8), allocatable :: a_sensors (:,:) - - PUBLIC :: allocate_acc_fluxes - PUBLIC :: deallocate_acc_fluxes - PUBLIC :: flush_acc_fluxes - PUBLIC :: accumulate_fluxes - -CONTAINS - - SUBROUTINE allocate_acc_fluxes - - USE MOD_SPMD_Task - USE MOD_LandElm - USE MOD_LandPatch - USE MOD_LandUrban, only: numurban - USE MOD_Vars_1DFluxes, only: nsensor -#ifdef CROP - USE MOD_LandCrop -#endif - USE MOD_Vars_Global - IMPLICIT NONE - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - allocate (a_us (numpatch)) - allocate (a_vs (numpatch)) - allocate (a_t (numpatch)) - allocate (a_q (numpatch)) - allocate (a_prc (numpatch)) - allocate (a_prl (numpatch)) - allocate (a_pbot (numpatch)) - allocate (a_frl (numpatch)) - allocate (a_solarin (numpatch)) - allocate (a_hpbl (numpatch)) - - allocate (a_taux (numpatch)) - allocate (a_tauy (numpatch)) - allocate (a_fsena (numpatch)) - allocate (a_lfevpa (numpatch)) - allocate (a_fevpa (numpatch)) - allocate (a_fsenl (numpatch)) - allocate (a_fevpl (numpatch)) - allocate (a_etr (numpatch)) - allocate (a_fseng (numpatch)) - allocate (a_fevpg (numpatch)) - allocate (a_fgrnd (numpatch)) - allocate (a_sabvsun (numpatch)) - allocate (a_sabvsha (numpatch)) - allocate (a_sabg (numpatch)) - allocate (a_olrg (numpatch)) - allocate (a_rnet (numpatch)) - allocate (a_xerr (numpatch)) - allocate (a_zerr (numpatch)) - allocate (a_rsur (numpatch)) - allocate (a_rsur_se (numpatch)) - allocate (a_rsur_ie (numpatch)) - allocate (a_rsub (numpatch)) - allocate (a_rnof (numpatch)) -#ifdef CatchLateralFlow - allocate (a_xwsur (numpatch)) - allocate (a_xwsub (numpatch)) - allocate (a_fldarea (numpatch)) -#endif - allocate (a_qintr (numpatch)) - allocate (a_qinfl (numpatch)) - allocate (a_qdrip (numpatch)) - allocate (a_rstfacsun (numpatch)) - allocate (a_rstfacsha (numpatch)) - allocate (a_gssun (numpatch)) - allocate (a_gssha (numpatch)) - allocate (a_rss (numpatch)) - allocate (a_wdsrf (numpatch)) - - allocate (a_zwt (numpatch)) - allocate (a_wa (numpatch)) - allocate (a_wat (numpatch)) - allocate (a_wetwat (numpatch)) - allocate (a_assim (numpatch)) - allocate (a_respc (numpatch)) - - allocate (a_assimsun (numpatch)) - allocate (a_assimsha (numpatch)) - allocate (a_etrsun (numpatch)) - allocate (a_etrsha (numpatch)) - - allocate (a_qcharge (numpatch)) - - allocate (a_t_grnd (numpatch)) - allocate (a_tleaf (numpatch)) - allocate (a_ldew_rain (numpatch)) - allocate (a_ldew_snow (numpatch)) - allocate (a_ldew (numpatch)) - allocate (a_scv (numpatch)) - allocate (a_snowdp (numpatch)) - allocate (a_fsno (numpatch)) - allocate (a_frcsat (numpatch)) - allocate (a_sigf (numpatch)) - allocate (a_green (numpatch)) - allocate (a_lai (numpatch)) - allocate (a_laisun (numpatch)) - allocate (a_laisha (numpatch)) - allocate (a_sai (numpatch)) - - allocate (a_alb (2 ,2,numpatch)) -#ifdef HYPERSPECTRAL - allocate (a_alb_hires (211,2,numpatch)) - allocate (a_reflectance_out (211,16,numpatch)) - allocate (a_transmittance_out(211,16,numpatch)) -#endif - allocate (a_emis (numpatch)) - allocate (a_z0m (numpatch)) - allocate (a_trad (numpatch)) - allocate (a_tref (numpatch)) - allocate (a_t2m_wmo (numpatch)) - allocate (a_qref (numpatch)) - allocate (a_rain (numpatch)) - allocate (a_snow (numpatch)) - - allocate (a_o3uptakesun(numpatch)) - allocate (a_o3uptakesha(numpatch)) - -#ifdef DataAssimilation - allocate (a_h2osoi_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)) - allocate (a_t_brt_smap_ens (2,DEF_DA_ENS_NUM,numpatch)) - allocate (a_t_brt_fy3d_ens (2,DEF_DA_ENS_NUM,numpatch)) - allocate (a_t_brt_smap (2,numpatch)) - allocate (a_t_brt_fy3d (2,numpatch)) - allocate (a_wliq_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)) - allocate (a_wice_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)) - allocate (a_t_soisno_ens (maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)) -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - allocate (a_t_room (numurban)) - allocate (a_tafu (numurban)) - allocate (a_fhac (numurban)) - allocate (a_fwst (numurban)) - allocate (a_fach (numurban)) - allocate (a_fahe (numurban)) - allocate (a_fhah (numurban)) - allocate (a_vehc (numurban)) - allocate (a_meta (numurban)) - - allocate (a_senroof (numurban)) - allocate (a_senwsun (numurban)) - allocate (a_senwsha (numurban)) - allocate (a_sengimp (numurban)) - allocate (a_sengper (numurban)) - allocate (a_senurbl (numurban)) - - allocate (a_lfevproof (numurban)) - allocate (a_lfevpgimp (numurban)) - allocate (a_lfevpgper (numurban)) - allocate (a_lfevpurbl (numurban)) - - allocate (a_troof (numurban)) - allocate (a_twall (numurban)) - ENDIF -#endif -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - allocate (a_lai_enftemp (numpatch)) - allocate (a_lai_enfboreal (numpatch)) - allocate (a_lai_dnfboreal (numpatch)) - allocate (a_lai_ebftrop (numpatch)) - allocate (a_lai_ebftemp (numpatch)) - allocate (a_lai_dbftrop (numpatch)) - allocate (a_lai_dbftemp (numpatch)) - allocate (a_lai_dbfboreal (numpatch)) - allocate (a_lai_ebstemp (numpatch)) - allocate (a_lai_dbstemp (numpatch)) - allocate (a_lai_dbsboreal (numpatch)) - allocate (a_lai_c3arcgrass (numpatch)) - allocate (a_lai_c3grass (numpatch)) - allocate (a_lai_c4grass (numpatch)) -#endif -#ifdef BGC - allocate (a_leafc (numpatch)) - allocate (a_leafc_storage (numpatch)) - allocate (a_leafc_xfer (numpatch)) - allocate (a_frootc (numpatch)) - allocate (a_frootc_storage (numpatch)) - allocate (a_frootc_xfer (numpatch)) - allocate (a_livestemc (numpatch)) - allocate (a_livestemc_storage (numpatch)) - allocate (a_livestemc_xfer (numpatch)) - allocate (a_deadstemc (numpatch)) - allocate (a_deadstemc_storage (numpatch)) - allocate (a_deadstemc_xfer (numpatch)) - allocate (a_livecrootc (numpatch)) - allocate (a_livecrootc_storage (numpatch)) - allocate (a_livecrootc_xfer (numpatch)) - allocate (a_deadcrootc (numpatch)) - allocate (a_deadcrootc_storage (numpatch)) - allocate (a_deadcrootc_xfer (numpatch)) - allocate (a_grainc (numpatch)) - allocate (a_grainc_storage (numpatch)) - allocate (a_grainc_xfer (numpatch)) - allocate (a_leafn (numpatch)) - allocate (a_leafn_storage (numpatch)) - allocate (a_leafn_xfer (numpatch)) - allocate (a_frootn (numpatch)) - allocate (a_frootn_storage (numpatch)) - allocate (a_frootn_xfer (numpatch)) - allocate (a_livestemn (numpatch)) - allocate (a_livestemn_storage (numpatch)) - allocate (a_livestemn_xfer (numpatch)) - allocate (a_deadstemn (numpatch)) - allocate (a_deadstemn_storage (numpatch)) - allocate (a_deadstemn_xfer (numpatch)) - allocate (a_livecrootn (numpatch)) - allocate (a_livecrootn_storage (numpatch)) - allocate (a_livecrootn_xfer (numpatch)) - allocate (a_deadcrootn (numpatch)) - allocate (a_deadcrootn_storage (numpatch)) - allocate (a_deadcrootn_xfer (numpatch)) - allocate (a_grainn (numpatch)) - allocate (a_grainn_storage (numpatch)) - allocate (a_grainn_xfer (numpatch)) - allocate (a_retransn (numpatch)) - allocate (a_gpp (numpatch)) - allocate (a_downreg (numpatch)) - allocate (a_ar (numpatch)) - allocate (a_cwdprod (numpatch)) - allocate (a_cwddecomp (numpatch)) - allocate (a_hr (numpatch)) - allocate (a_fpg (numpatch)) - allocate (a_fpi (numpatch)) - allocate (a_totvegc (numpatch)) - allocate (a_totlitc (numpatch)) - allocate (a_totcwdc (numpatch)) - allocate (a_totsomc (numpatch)) - allocate (a_totcolc (numpatch)) - allocate (a_totvegn (numpatch)) - allocate (a_totlitn (numpatch)) - allocate (a_totcwdn (numpatch)) - allocate (a_totsomn (numpatch)) - allocate (a_totcoln (numpatch)) - allocate (a_gpp_enftemp (numpatch)) !1 - allocate (a_gpp_enfboreal (numpatch)) !2 - allocate (a_gpp_dnfboreal (numpatch)) !3 - allocate (a_gpp_ebftrop (numpatch)) !4 - allocate (a_gpp_ebftemp (numpatch)) !5 - allocate (a_gpp_dbftrop (numpatch)) !6 - allocate (a_gpp_dbftemp (numpatch)) !7 - allocate (a_gpp_dbfboreal (numpatch)) !8 - allocate (a_gpp_ebstemp (numpatch)) !9 - allocate (a_gpp_dbstemp (numpatch)) !10 - allocate (a_gpp_dbsboreal (numpatch)) !11 - allocate (a_gpp_c3arcgrass (numpatch)) !12 - allocate (a_gpp_c3grass (numpatch)) !13 - allocate (a_gpp_c4grass (numpatch)) !14 - allocate (a_npp_enftemp (numpatch)) !1 - allocate (a_npp_enfboreal (numpatch)) !2 - allocate (a_npp_dnfboreal (numpatch)) !3 - allocate (a_npp_ebftrop (numpatch)) !4 - allocate (a_npp_ebftemp (numpatch)) !5 - allocate (a_npp_dbftrop (numpatch)) !6 - allocate (a_npp_dbftemp (numpatch)) !7 - allocate (a_npp_dbfboreal (numpatch)) !8 - allocate (a_npp_ebstemp (numpatch)) !9 - allocate (a_npp_dbstemp (numpatch)) !10 - allocate (a_npp_dbsboreal (numpatch)) !11 - allocate (a_npp_c3arcgrass (numpatch)) !12 - allocate (a_npp_c3grass (numpatch)) !13 - allocate (a_npp_c4grass (numpatch)) !14 - allocate (a_npptoleafc_enftemp (numpatch)) !1 - allocate (a_npptoleafc_enfboreal (numpatch)) !2 - allocate (a_npptoleafc_dnfboreal (numpatch)) !3 - allocate (a_npptoleafc_ebftrop (numpatch)) !4 - allocate (a_npptoleafc_ebftemp (numpatch)) !5 - allocate (a_npptoleafc_dbftrop (numpatch)) !6 - allocate (a_npptoleafc_dbftemp (numpatch)) !7 - allocate (a_npptoleafc_dbfboreal (numpatch)) !8 - allocate (a_npptoleafc_ebstemp (numpatch)) !9 - allocate (a_npptoleafc_dbstemp (numpatch)) !10 - allocate (a_npptoleafc_dbsboreal (numpatch)) !11 - allocate (a_npptoleafc_c3arcgrass (numpatch)) !12 - allocate (a_npptoleafc_c3grass (numpatch)) !13 - allocate (a_npptoleafc_c4grass (numpatch)) !14 - allocate (a_leafc_enftemp (numpatch)) !1 - allocate (a_leafc_enfboreal (numpatch)) !2 - allocate (a_leafc_dnfboreal (numpatch)) !3 - allocate (a_leafc_ebftrop (numpatch)) !4 - allocate (a_leafc_ebftemp (numpatch)) !5 - allocate (a_leafc_dbftrop (numpatch)) !6 - allocate (a_leafc_dbftemp (numpatch)) !7 - allocate (a_leafc_dbfboreal (numpatch)) !8 - allocate (a_leafc_ebstemp (numpatch)) !9 - allocate (a_leafc_dbstemp (numpatch)) !10 - allocate (a_leafc_dbsboreal (numpatch)) !11 - allocate (a_leafc_c3arcgrass (numpatch)) !12 - allocate (a_leafc_c3grass (numpatch)) !13 - allocate (a_leafc_c4grass (numpatch)) !14 - - allocate (a_O2_DECOMP_DEPTH_UNSAT (1:nl_soil,numpatch)) - allocate (a_CONC_O2_UNSAT (1:nl_soil,numpatch)) - -#ifdef CROP - allocate (a_pdcorn (numpatch)) - allocate (a_pdswheat (numpatch)) - allocate (a_pdwwheat (numpatch)) - allocate (a_pdsoybean (numpatch)) - allocate (a_pdcotton (numpatch)) - allocate (a_pdrice1 (numpatch)) - allocate (a_pdrice2 (numpatch)) - allocate (a_pdsugarcane (numpatch)) - allocate (a_plantdate (numpatch)) - allocate (a_manunitro (numpatch)) - allocate (a_fertnitro_corn (numpatch)) - allocate (a_fertnitro_swheat (numpatch)) - allocate (a_fertnitro_wwheat (numpatch)) - allocate (a_fertnitro_soybean (numpatch)) - allocate (a_fertnitro_cotton (numpatch)) - allocate (a_fertnitro_rice1 (numpatch)) - allocate (a_fertnitro_rice2 (numpatch)) - allocate (a_fertnitro_sugarcane(numpatch)) - allocate (a_irrig_method_corn (numpatch)) - allocate (a_irrig_method_swheat (numpatch)) - allocate (a_irrig_method_wwheat (numpatch)) - allocate (a_irrig_method_soybean (numpatch)) - allocate (a_irrig_method_cotton (numpatch)) - allocate (a_irrig_method_rice1 (numpatch)) - allocate (a_irrig_method_rice2 (numpatch)) - allocate (a_irrig_method_sugarcane(numpatch)) - allocate (a_cphase (numpatch)) - allocate (a_hui (numpatch)) - allocate (a_gddmaturity (numpatch)) - allocate (a_gddplant (numpatch)) - allocate (a_vf (numpatch)) - allocate (a_cropprod1c (numpatch)) - allocate (a_cropprod1c_loss (numpatch)) - allocate (a_cropseedc_deficit (numpatch)) - allocate (a_grainc_to_cropprodc(numpatch)) - allocate (a_grainc_to_seed (numpatch)) - allocate (a_fert_to_sminn (numpatch)) - - allocate (a_sum_irrig (numpatch)) - allocate (a_sum_deficit_irrig (numpatch)) - allocate (a_sum_irrig_count (numpatch)) - allocate (a_waterstorage (numpatch)) - allocate (a_groundwater_demand (numpatch)) - allocate (a_groundwater_supply (numpatch)) - allocate (a_reservoirriver_demand(numpatch)) - allocate (a_reservoirriver_supply(numpatch)) - allocate (a_reservoir_supply (numpatch)) - allocate (a_river_supply (numpatch)) - allocate (a_runoff_supply (numpatch)) -#endif - allocate (a_ndep_to_sminn (numpatch)) - - allocate (a_abm (numpatch)) - allocate (a_gdp (numpatch)) - allocate (a_peatf (numpatch)) - allocate (a_hdm (numpatch)) - allocate (a_lnfm (numpatch)) - - allocate (a_leafcCap (numpatch)) - allocate (a_leafc_storageCap (numpatch)) - allocate (a_leafc_xferCap (numpatch)) - allocate (a_frootcCap (numpatch)) - allocate (a_frootc_storageCap (numpatch)) - allocate (a_frootc_xferCap (numpatch)) - allocate (a_livestemcCap (numpatch)) - allocate (a_livestemc_storageCap (numpatch)) - allocate (a_livestemc_xferCap (numpatch)) - allocate (a_deadstemcCap (numpatch)) - allocate (a_deadstemc_storageCap (numpatch)) - allocate (a_deadstemc_xferCap (numpatch)) - allocate (a_livecrootcCap (numpatch)) - allocate (a_livecrootc_storageCap (numpatch)) - allocate (a_livecrootc_xferCap (numpatch)) - allocate (a_deadcrootcCap (numpatch)) - allocate (a_deadcrootc_storageCap (numpatch)) - allocate (a_deadcrootc_xferCap (numpatch)) - allocate (a_leafnCap (numpatch)) - allocate (a_leafn_storageCap (numpatch)) - allocate (a_leafn_xferCap (numpatch)) - allocate (a_frootnCap (numpatch)) - allocate (a_frootn_storageCap (numpatch)) - allocate (a_frootn_xferCap (numpatch)) - allocate (a_livestemnCap (numpatch)) - allocate (a_livestemn_storageCap (numpatch)) - allocate (a_livestemn_xferCap (numpatch)) - allocate (a_deadstemnCap (numpatch)) - allocate (a_deadstemn_storageCap (numpatch)) - allocate (a_deadstemn_xferCap (numpatch)) - allocate (a_livecrootnCap (numpatch)) - allocate (a_livecrootn_storageCap (numpatch)) - allocate (a_livecrootn_xferCap (numpatch)) - allocate (a_deadcrootnCap (numpatch)) - allocate (a_deadcrootn_storageCap (numpatch)) - allocate (a_deadcrootn_xferCap (numpatch)) -#endif -! Ozone stress variables - allocate (a_ozone (numpatch)) -! End ozone stress variables - allocate (a_t_soisno (maxsnl+1:nl_soil,numpatch)) - allocate (a_wliq_soisno (maxsnl+1:nl_soil,numpatch)) - allocate (a_wice_soisno (maxsnl+1:nl_soil,numpatch)) - allocate (a_h2osoi (1:nl_soil, numpatch)) - allocate (a_qlayer (0:nl_soil, numpatch)) - allocate (a_lake_deficit (numpatch)) - allocate (a_rootr (1:nl_soil, numpatch)) - allocate (a_BD_all (1:nl_soil, numpatch)) - allocate (a_wfc (1:nl_soil, numpatch)) - allocate (a_OM_density (1:nl_soil, numpatch)) -!Plant Hydraulic parameters - allocate (a_vegwp (1:nvegwcs, numpatch)) -!End Plant Hydraulic parameters - allocate (a_dz_lake (nl_lake, numpatch)) - allocate (a_t_lake (nl_lake, numpatch)) - allocate (a_lake_icefrac(nl_lake, numpatch)) - -#ifdef BGC - allocate (a_litr1c_vr (1:nl_soil, numpatch)) - allocate (a_litr2c_vr (1:nl_soil, numpatch)) - allocate (a_litr3c_vr (1:nl_soil, numpatch)) - allocate (a_soil1c_vr (1:nl_soil, numpatch)) - allocate (a_soil2c_vr (1:nl_soil, numpatch)) - allocate (a_soil3c_vr (1:nl_soil, numpatch)) - allocate (a_cwdc_vr (1:nl_soil, numpatch)) - allocate (a_litr1n_vr (1:nl_soil, numpatch)) - allocate (a_litr2n_vr (1:nl_soil, numpatch)) - allocate (a_litr3n_vr (1:nl_soil, numpatch)) - allocate (a_soil1n_vr (1:nl_soil, numpatch)) - allocate (a_soil2n_vr (1:nl_soil, numpatch)) - allocate (a_soil3n_vr (1:nl_soil, numpatch)) - allocate (a_cwdn_vr (1:nl_soil, numpatch)) - allocate (a_totsoiln_vr (1:nl_soil, numpatch)) - allocate (a_sminn_vr (1:nl_soil, numpatch)) - allocate (decomp_vr_tmp (1:nl_soil, numpatch)) - - allocate (a_litr1cCap_vr(1:nl_soil, numpatch)) - allocate (a_litr2cCap_vr(1:nl_soil, numpatch)) - allocate (a_litr3cCap_vr(1:nl_soil, numpatch)) - allocate (a_soil1cCap_vr(1:nl_soil, numpatch)) - allocate (a_soil2cCap_vr(1:nl_soil, numpatch)) - allocate (a_soil3cCap_vr(1:nl_soil, numpatch)) - allocate (a_cwdcCap_vr (1:nl_soil, numpatch)) - allocate (a_litr1nCap_vr(1:nl_soil, numpatch)) - allocate (a_litr2nCap_vr(1:nl_soil, numpatch)) - allocate (a_litr3nCap_vr(1:nl_soil, numpatch)) - allocate (a_soil1nCap_vr(1:nl_soil, numpatch)) - allocate (a_soil2nCap_vr(1:nl_soil, numpatch)) - allocate (a_soil3nCap_vr(1:nl_soil, numpatch)) - allocate (a_cwdnCap_vr (1:nl_soil, numpatch)) - allocate (a_t_scalar (1:nl_soil, numpatch)) - allocate (a_w_scalar (1:nl_soil, numpatch)) -#endif - - allocate (a_ustar (numpatch)) - allocate (a_ustar2 (numpatch)) - allocate (a_tstar (numpatch)) - allocate (a_qstar (numpatch)) - allocate (a_zol (numpatch)) - allocate (a_rib (numpatch)) - allocate (a_fm (numpatch)) - allocate (a_fh (numpatch)) - allocate (a_fq (numpatch)) - - allocate (a_us10m (numpatch)) - allocate (a_vs10m (numpatch)) - allocate (a_fm10m (numpatch)) - - allocate (a_sr (numpatch)) - allocate (a_solvd (numpatch)) - allocate (a_solvi (numpatch)) - allocate (a_solnd (numpatch)) - allocate (a_solni (numpatch)) - allocate (a_srvd (numpatch)) - allocate (a_srvi (numpatch)) - allocate (a_srnd (numpatch)) - allocate (a_srni (numpatch)) - allocate (a_solvdln (numpatch)) - allocate (a_solviln (numpatch)) - allocate (a_solndln (numpatch)) - allocate (a_solniln (numpatch)) - allocate (a_srvdln (numpatch)) - allocate (a_srviln (numpatch)) - allocate (a_srndln (numpatch)) - allocate (a_srniln (numpatch)) -#ifdef HYPERSPECTRAL - allocate (a_sol_dir_ln_hires(211, numpatch)) - allocate (a_sol_dif_ln_hires(211, numpatch)) - allocate (a_sr_dir_ln_hires (211, numpatch)) - allocate (a_sr_dif_ln_hires (211, numpatch)) -#endif - allocate (a_sensors (nsensor,numpatch)) - - allocate (nac_ln (numpatch)) - allocate (nac_dt (numpatch)) - allocate (filter_dt (numpatch)) - - ENDIF - ENDIF - -#ifdef EXTERNAL_LAKE - CALL allocate_LakeAccVars -#endif - - IF (p_is_compute) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) - ENDIF - - END SUBROUTINE allocate_acc_fluxes - - SUBROUTINE deallocate_acc_fluxes () - - USE MOD_SPMD_Task - USE MOD_LandPatch, only: numpatch - USE MOD_LandUrban, only: numurban - IMPLICIT NONE - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - deallocate (a_us ) - deallocate (a_vs ) - deallocate (a_t ) - deallocate (a_q ) - deallocate (a_prc ) - deallocate (a_prl ) - deallocate (a_pbot ) - deallocate (a_frl ) - deallocate (a_solarin) - deallocate (a_hpbl ) - - deallocate (a_taux ) - deallocate (a_tauy ) - deallocate (a_fsena ) - deallocate (a_lfevpa ) - deallocate (a_fevpa ) - deallocate (a_fsenl ) - deallocate (a_fevpl ) - deallocate (a_etr ) - deallocate (a_fseng ) - deallocate (a_fevpg ) - deallocate (a_fgrnd ) - deallocate (a_sabvsun ) - deallocate (a_sabvsha ) - deallocate (a_sabg ) - deallocate (a_olrg ) - deallocate (a_rnet ) - deallocate (a_xerr ) - deallocate (a_zerr ) - deallocate (a_rsur ) - deallocate (a_rsur_se ) - deallocate (a_rsur_ie ) - deallocate (a_rsub ) - deallocate (a_rnof ) -#ifdef CatchLateralFlow - deallocate (a_xwsur ) - deallocate (a_xwsub ) - deallocate (a_fldarea ) -#endif - deallocate (a_qintr ) - deallocate (a_qinfl ) - deallocate (a_qdrip ) - deallocate (a_rstfacsun ) - deallocate (a_rstfacsha ) - deallocate (a_gssun ) - deallocate (a_gssha ) - deallocate (a_rss ) - deallocate (a_wdsrf ) - - deallocate (a_zwt ) - deallocate (a_wa ) - deallocate (a_wat ) - deallocate (a_wetwat ) - deallocate (a_assim ) - deallocate (a_respc ) - - deallocate (a_assimsun ) !1 - deallocate (a_assimsha ) !1 - deallocate (a_etrsun ) !1 - deallocate (a_etrsha ) !1 - - deallocate (a_qcharge ) - - deallocate (a_t_grnd ) - deallocate (a_tleaf ) - deallocate (a_ldew_rain ) - deallocate (a_ldew_snow ) - deallocate (a_ldew ) - deallocate (a_scv ) - deallocate (a_snowdp ) - deallocate (a_fsno ) - deallocate (a_frcsat ) - deallocate (a_sigf ) - deallocate (a_green ) - deallocate (a_lai ) - deallocate (a_laisun ) - deallocate (a_laisha ) - deallocate (a_sai ) - - deallocate (a_alb ) -#ifdef HYPERSPECTRAL - deallocate (a_alb_hires ) - deallocate (a_reflectance_out ) - deallocate (a_transmittance_out) -#endif - - deallocate (a_emis ) - deallocate (a_z0m ) - deallocate (a_trad ) - deallocate (a_tref ) - deallocate (a_t2m_wmo ) - deallocate (a_qref ) - deallocate (a_rain ) - deallocate (a_snow ) - - deallocate (a_o3uptakesun) - deallocate (a_o3uptakesha) - -#ifdef DataAssimilation - deallocate (a_h2osoi_ens ) - deallocate (a_t_brt_smap_ens ) - deallocate (a_t_brt_fy3d_ens ) - deallocate (a_t_brt_fy3d ) - deallocate (a_t_brt_smap ) - deallocate (a_wliq_soisno_ens) - deallocate (a_wice_soisno_ens) - deallocate (a_t_soisno_ens ) -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - deallocate (a_t_room ) - deallocate (a_tafu ) - deallocate (a_fhac ) - deallocate (a_fwst ) - deallocate (a_fach ) - deallocate (a_fahe ) - deallocate (a_fhah ) - deallocate (a_vehc ) - deallocate (a_meta ) - - deallocate (a_senroof ) - deallocate (a_senwsun ) - deallocate (a_senwsha ) - deallocate (a_sengimp ) - deallocate (a_sengper ) - deallocate (a_senurbl ) - - deallocate (a_lfevproof ) - deallocate (a_lfevpgimp ) - deallocate (a_lfevpgper ) - deallocate (a_lfevpurbl ) - - deallocate (a_troof ) - deallocate (a_twall ) - ENDIF -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - deallocate (a_lai_enftemp ) - deallocate (a_lai_enfboreal ) - deallocate (a_lai_dnfboreal ) - deallocate (a_lai_ebftrop ) - deallocate (a_lai_ebftemp ) - deallocate (a_lai_dbftrop ) - deallocate (a_lai_dbftemp ) - deallocate (a_lai_dbfboreal ) - deallocate (a_lai_ebstemp ) - deallocate (a_lai_dbstemp ) - deallocate (a_lai_dbsboreal ) - deallocate (a_lai_c3arcgrass ) - deallocate (a_lai_c3grass ) - deallocate (a_lai_c4grass ) -#endif - -#ifdef BGC - deallocate (a_leafc ) - deallocate (a_leafc_storage ) - deallocate (a_leafc_xfer ) - deallocate (a_frootc ) - deallocate (a_frootc_storage ) - deallocate (a_frootc_xfer ) - deallocate (a_livestemc ) - deallocate (a_livestemc_storage ) - deallocate (a_livestemc_xfer ) - deallocate (a_deadstemc ) - deallocate (a_deadstemc_storage ) - deallocate (a_deadstemc_xfer ) - deallocate (a_livecrootc ) - deallocate (a_livecrootc_storage ) - deallocate (a_livecrootc_xfer ) - deallocate (a_deadcrootc ) - deallocate (a_deadcrootc_storage ) - deallocate (a_deadcrootc_xfer ) - deallocate (a_grainc ) - deallocate (a_grainc_storage ) - deallocate (a_grainc_xfer ) - deallocate (a_leafn ) - deallocate (a_leafn_storage ) - deallocate (a_leafn_xfer ) - deallocate (a_frootn ) - deallocate (a_frootn_storage ) - deallocate (a_frootn_xfer ) - deallocate (a_livestemn ) - deallocate (a_livestemn_storage ) - deallocate (a_livestemn_xfer ) - deallocate (a_deadstemn ) - deallocate (a_deadstemn_storage ) - deallocate (a_deadstemn_xfer ) - deallocate (a_livecrootn ) - deallocate (a_livecrootn_storage ) - deallocate (a_livecrootn_xfer ) - deallocate (a_deadcrootn ) - deallocate (a_deadcrootn_storage ) - deallocate (a_deadcrootn_xfer ) - deallocate (a_grainn ) - deallocate (a_grainn_storage ) - deallocate (a_grainn_xfer ) - deallocate (a_retransn ) - deallocate (a_gpp ) - deallocate (a_downreg ) - deallocate (a_ar ) - deallocate (a_cwdprod ) - deallocate (a_cwddecomp ) - deallocate (a_hr ) - deallocate (a_fpg ) - deallocate (a_fpi ) - deallocate (a_totvegc ) - deallocate (a_totlitc ) - deallocate (a_totcwdc ) - deallocate (a_totsomc ) - deallocate (a_totcolc ) - deallocate (a_totvegn ) - deallocate (a_totlitn ) - deallocate (a_totcwdn ) - deallocate (a_totsomn ) - deallocate (a_totcoln ) - deallocate (a_gpp_enftemp ) !1 - deallocate (a_gpp_enfboreal ) !2 - deallocate (a_gpp_dnfboreal ) !3 - deallocate (a_gpp_ebftrop ) !4 - deallocate (a_gpp_ebftemp ) !5 - deallocate (a_gpp_dbftrop ) !6 - deallocate (a_gpp_dbftemp ) !7 - deallocate (a_gpp_dbfboreal ) !8 - deallocate (a_gpp_ebstemp ) !9 - deallocate (a_gpp_dbstemp ) !10 - deallocate (a_gpp_dbsboreal ) !11 - deallocate (a_gpp_c3arcgrass ) !12 - deallocate (a_gpp_c3grass ) !13 - deallocate (a_gpp_c4grass ) !14 - deallocate (a_npp_enftemp ) !1 - deallocate (a_npp_enfboreal ) !2 - deallocate (a_npp_dnfboreal ) !3 - deallocate (a_npp_ebftrop ) !4 - deallocate (a_npp_ebftemp ) !5 - deallocate (a_npp_dbftrop ) !6 - deallocate (a_npp_dbftemp ) !7 - deallocate (a_npp_dbfboreal ) !8 - deallocate (a_npp_ebstemp ) !9 - deallocate (a_npp_dbstemp ) !10 - deallocate (a_npp_dbsboreal ) !11 - deallocate (a_npp_c3arcgrass ) !12 - deallocate (a_npp_c3grass ) !13 - deallocate (a_npp_c4grass ) !14 - deallocate (a_npptoleafc_enftemp ) !1 - deallocate (a_npptoleafc_enfboreal ) !2 - deallocate (a_npptoleafc_dnfboreal ) !3 - deallocate (a_npptoleafc_ebftrop ) !4 - deallocate (a_npptoleafc_ebftemp ) !5 - deallocate (a_npptoleafc_dbftrop ) !6 - deallocate (a_npptoleafc_dbftemp ) !7 - deallocate (a_npptoleafc_dbfboreal ) !8 - deallocate (a_npptoleafc_ebstemp ) !9 - deallocate (a_npptoleafc_dbstemp ) !10 - deallocate (a_npptoleafc_dbsboreal ) !11 - deallocate (a_npptoleafc_c3arcgrass ) !12 - deallocate (a_npptoleafc_c3grass ) !13 - deallocate (a_npptoleafc_c4grass ) !14 - deallocate (a_leafc_enftemp ) !1 - deallocate (a_leafc_enfboreal ) !2 - deallocate (a_leafc_dnfboreal ) !3 - deallocate (a_leafc_ebftrop ) !4 - deallocate (a_leafc_ebftemp ) !5 - deallocate (a_leafc_dbftrop ) !6 - deallocate (a_leafc_dbftemp ) !7 - deallocate (a_leafc_dbfboreal ) !8 - deallocate (a_leafc_ebstemp ) !9 - deallocate (a_leafc_dbstemp ) !10 - deallocate (a_leafc_dbsboreal ) !11 - deallocate (a_leafc_c3arcgrass ) !12 - deallocate (a_leafc_c3grass ) !13 - deallocate (a_leafc_c4grass ) !14 - - deallocate (a_O2_DECOMP_DEPTH_UNSAT ) - deallocate (a_CONC_O2_UNSAT ) - -#ifdef CROP - deallocate (a_pdcorn ) - deallocate (a_pdswheat ) - deallocate (a_pdwwheat ) - deallocate (a_pdsoybean ) - deallocate (a_pdcotton ) - deallocate (a_pdrice1 ) - deallocate (a_pdrice2 ) - deallocate (a_pdsugarcane ) - deallocate (a_plantdate ) - deallocate (a_manunitro ) - deallocate (a_fertnitro_corn ) - deallocate (a_fertnitro_swheat ) - deallocate (a_fertnitro_wwheat ) - deallocate (a_fertnitro_soybean ) - deallocate (a_fertnitro_cotton ) - deallocate (a_fertnitro_rice1 ) - deallocate (a_fertnitro_rice2 ) - deallocate (a_fertnitro_sugarcane) - deallocate (a_irrig_method_corn ) - deallocate (a_irrig_method_swheat ) - deallocate (a_irrig_method_wwheat ) - deallocate (a_irrig_method_soybean ) - deallocate (a_irrig_method_cotton ) - deallocate (a_irrig_method_rice1 ) - deallocate (a_irrig_method_rice2 ) - deallocate (a_irrig_method_sugarcane) - deallocate (a_cphase ) - deallocate (a_hui ) - deallocate (a_vf ) - deallocate (a_gddmaturity ) - deallocate (a_gddplant ) - deallocate (a_cropprod1c ) - deallocate (a_cropprod1c_loss ) - deallocate (a_cropseedc_deficit ) - deallocate (a_grainc_to_cropprodc) - deallocate (a_grainc_to_seed ) - deallocate (a_fert_to_sminn ) - - deallocate (a_sum_irrig ) - deallocate (a_sum_deficit_irrig ) - deallocate (a_sum_irrig_count ) - deallocate (a_waterstorage ) - deallocate (a_groundwater_demand ) - deallocate (a_groundwater_supply ) - deallocate (a_reservoirriver_demand) - deallocate (a_reservoirriver_supply) - deallocate (a_reservoir_supply ) - deallocate (a_river_supply ) - deallocate (a_runoff_supply ) -#endif - deallocate (a_ndep_to_sminn ) - - deallocate (a_abm ) - deallocate (a_gdp ) - deallocate (a_peatf ) - deallocate (a_hdm ) - deallocate (a_lnfm ) - - deallocate (a_leafcCap ) - deallocate (a_leafc_storageCap ) - deallocate (a_leafc_xferCap ) - deallocate (a_frootcCap ) - deallocate (a_frootc_storageCap ) - deallocate (a_frootc_xferCap ) - deallocate (a_livestemcCap ) - deallocate (a_livestemc_storageCap ) - deallocate (a_livestemc_xferCap ) - deallocate (a_deadstemcCap ) - deallocate (a_deadstemc_storageCap ) - deallocate (a_deadstemc_xferCap ) - deallocate (a_livecrootcCap ) - deallocate (a_livecrootc_storageCap) - deallocate (a_livecrootc_xferCap ) - deallocate (a_deadcrootcCap ) - deallocate (a_deadcrootc_storageCap) - deallocate (a_deadcrootc_xferCap ) - deallocate (a_leafnCap ) - deallocate (a_leafn_storageCap ) - deallocate (a_leafn_xferCap ) - deallocate (a_frootnCap ) - deallocate (a_frootn_storageCap ) - deallocate (a_frootn_xferCap ) - deallocate (a_livestemnCap ) - deallocate (a_livestemn_storageCap ) - deallocate (a_livestemn_xferCap ) - deallocate (a_deadstemnCap ) - deallocate (a_deadstemn_storageCap ) - deallocate (a_deadstemn_xferCap ) - deallocate (a_livecrootnCap ) - deallocate (a_livecrootn_storageCap) - deallocate (a_livecrootn_xferCap ) - deallocate (a_deadcrootnCap ) - deallocate (a_deadcrootn_storageCap) - deallocate (a_deadcrootn_xferCap ) -#endif -! Ozone stress variables - deallocate (a_ozone ) -! END ozone stress variables - - deallocate (a_t_soisno ) - deallocate (a_wliq_soisno ) - deallocate (a_wice_soisno ) - deallocate (a_h2osoi ) - deallocate (a_qlayer ) - deallocate (a_lake_deficit) - deallocate (a_rootr ) - deallocate (a_BD_all ) - deallocate (a_wfc ) - deallocate (a_OM_density ) -!Plant Hydraulic parameters - deallocate (a_vegwp ) -!END plant hydraulic parameters - deallocate (a_dz_lake ) - deallocate (a_t_lake ) - deallocate (a_lake_icefrac) -#ifdef BGC - deallocate (a_litr1c_vr ) - deallocate (a_litr2c_vr ) - deallocate (a_litr3c_vr ) - deallocate (a_soil1c_vr ) - deallocate (a_soil2c_vr ) - deallocate (a_soil3c_vr ) - deallocate (a_cwdc_vr ) - deallocate (a_litr1n_vr ) - deallocate (a_litr2n_vr ) - deallocate (a_litr3n_vr ) - deallocate (a_soil1n_vr ) - deallocate (a_soil2n_vr ) - deallocate (a_soil3n_vr ) - deallocate (a_cwdn_vr ) - deallocate (a_totsoiln_vr ) - deallocate (a_sminn_vr ) - deallocate (decomp_vr_tmp ) - deallocate (a_litr1cCap_vr) - deallocate (a_litr2cCap_vr) - deallocate (a_litr3cCap_vr) - deallocate (a_soil1cCap_vr) - deallocate (a_soil2cCap_vr) - deallocate (a_soil3cCap_vr) - deallocate (a_cwdcCap_vr ) - deallocate (a_litr1nCap_vr) - deallocate (a_litr2nCap_vr) - deallocate (a_litr3nCap_vr) - deallocate (a_soil1nCap_vr) - deallocate (a_soil2nCap_vr) - deallocate (a_soil3nCap_vr) - deallocate (a_cwdnCap_vr ) - deallocate (a_t_scalar ) - deallocate (a_w_scalar ) -#endif - - deallocate (a_ustar ) - deallocate (a_ustar2 ) - deallocate (a_tstar ) - deallocate (a_qstar ) - deallocate (a_zol ) - deallocate (a_rib ) - deallocate (a_fm ) - deallocate (a_fh ) - deallocate (a_fq ) - - deallocate (a_us10m ) - deallocate (a_vs10m ) - deallocate (a_fm10m ) - - deallocate (a_sr ) - deallocate (a_solvd ) - deallocate (a_solvi ) - deallocate (a_solnd ) - deallocate (a_solni ) - deallocate (a_srvd ) - deallocate (a_srvi ) - deallocate (a_srnd ) - deallocate (a_srni ) - deallocate (a_solvdln ) - deallocate (a_solviln ) - deallocate (a_solndln ) - deallocate (a_solniln ) - deallocate (a_srvdln ) - deallocate (a_srviln ) - deallocate (a_srndln ) - deallocate (a_srniln ) -#ifdef HYPERSPECTRAL - deallocate (a_sol_dir_ln_hires) - deallocate (a_sol_dif_ln_hires) - deallocate (a_sr_dir_ln_hires ) - deallocate (a_sr_dif_ln_hires ) -#endif - deallocate (a_sensors ) - - deallocate (nac_ln ) - deallocate (nac_dt ) - deallocate (filter_dt ) - - ENDIF - ENDIF - -#ifdef EXTERNAL_LAKE - CALL deallocate_LakeAccVars -#endif - - END SUBROUTINE deallocate_acc_fluxes - - !----------------------- - SUBROUTINE FLUSH_acc_fluxes () - - USE MOD_SPMD_Task - USE MOD_LandPatch, only: numpatch - USE MOD_LandUrban, only: numurban - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - IF (p_is_compute) THEN - - nac = 0 - - IF (numpatch > 0) THEN - - ! flush the Fluxes for accumulation - a_us (:) = spval - a_vs (:) = spval - a_t (:) = spval - a_q (:) = spval - a_prc (:) = spval - a_prl (:) = spval - a_pbot (:) = spval - a_frl (:) = spval - a_solarin (:) = spval - a_hpbl (:) = spval - - a_taux (:) = spval - a_tauy (:) = spval - a_fsena (:) = spval - a_lfevpa (:) = spval - a_fevpa (:) = spval - a_fsenl (:) = spval - a_fevpl (:) = spval - a_etr (:) = spval - a_fseng (:) = spval - a_fevpg (:) = spval - a_fgrnd (:) = spval - a_sabvsun (:) = spval - a_sabvsha (:) = spval - a_sabg (:) = spval - a_olrg (:) = spval - a_rnet (:) = spval - a_xerr (:) = spval - a_zerr (:) = spval - a_rsur (:) = spval - a_rsur_se (:) = spval - a_rsur_ie (:) = spval - a_rsub (:) = spval - a_rnof (:) = spval -#ifdef CatchLateralFlow - a_xwsur (:) = spval - a_xwsub (:) = spval - a_fldarea (:) = spval -#endif - a_qintr (:) = spval - a_qinfl (:) = spval - a_qdrip (:) = spval - a_rstfacsun (:) = spval - a_rstfacsha (:) = spval - a_gssun (:) = spval - a_gssha (:) = spval - a_rss (:) = spval - - a_wdsrf (:) = spval - a_zwt (:) = spval - a_wa (:) = spval - a_wat (:) = spval - a_wetwat (:) = spval - a_assim (:) = spval - a_respc (:) = spval - a_assimsun (:) = spval - a_assimsha (:) = spval - a_etrsun (:) = spval - a_etrsha (:) = spval - - a_qcharge (:) = spval - - a_t_grnd (:) = spval - a_tleaf (:) = spval - a_ldew_rain (:) = spval - a_ldew_snow (:) = spval - a_ldew (:) = spval - a_scv (:) = spval - a_snowdp (:) = spval - a_fsno (:) = spval - a_frcsat (:) = spval - a_sigf (:) = spval - a_green (:) = spval - a_lai (:) = spval - a_laisun (:) = spval - a_laisha (:) = spval - a_sai (:) = spval - - a_alb (:,:,:) = spval - -#ifdef HYPERSPECTRAL - a_alb_hires (:,:,:) = spval -#endif - - a_emis (:) = spval - a_z0m (:) = spval - a_trad (:) = spval - a_tref (:) = spval - a_t2m_wmo (:) = spval - a_qref (:) = spval - a_rain (:) = spval - a_snow (:) = spval - - a_o3uptakesun(:) = spval - a_o3uptakesha(:) = spval - -#ifdef DataAssimilation - a_h2osoi_ens (:,:,:) = spval - a_t_brt_smap_ens (:,:,:) = spval - a_t_brt_fy3d_ens (:,:,:) = spval - a_t_brt_fy3d (:,:) = spval - a_t_brt_smap (:,:) = spval - a_wliq_soisno_ens(:,:,:) = spval - a_wice_soisno_ens(:,:,:) = spval - a_t_soisno_ens (:,:,:) = spval -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - a_t_room (:) = spval - a_tafu (:) = spval - a_fhac (:) = spval - a_fwst (:) = spval - a_fach (:) = spval - a_fahe (:) = spval - a_fhah (:) = spval - a_vehc (:) = spval - a_meta (:) = spval - - a_senroof (:) = spval - a_senwsun (:) = spval - a_senwsha (:) = spval - a_sengimp (:) = spval - a_sengper (:) = spval - a_senurbl (:) = spval - - a_lfevproof(:) = spval - a_lfevpgimp(:) = spval - a_lfevpgper(:) = spval - a_lfevpurbl(:) = spval - - a_troof (:) = spval - a_twall (:) = spval - ENDIF -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - a_lai_enftemp (:) = spval - a_lai_enfboreal (:) = spval - a_lai_dnfboreal (:) = spval - a_lai_ebftrop (:) = spval - a_lai_ebftemp (:) = spval - a_lai_dbftrop (:) = spval - a_lai_dbftemp (:) = spval - a_lai_dbfboreal (:) = spval - a_lai_ebstemp (:) = spval - a_lai_dbstemp (:) = spval - a_lai_dbsboreal (:) = spval - a_lai_c3arcgrass (:) = spval - a_lai_c3grass (:) = spval - a_lai_c4grass (:) = spval -#endif -#ifdef BGC - a_leafc (:) = spval - a_leafc_storage (:) = spval - a_leafc_xfer (:) = spval - a_frootc (:) = spval - a_frootc_storage (:) = spval - a_frootc_xfer (:) = spval - a_livestemc (:) = spval - a_livestemc_storage (:) = spval - a_livestemc_xfer (:) = spval - a_deadstemc (:) = spval - a_deadstemc_storage (:) = spval - a_deadstemc_xfer (:) = spval - a_livecrootc (:) = spval - a_livecrootc_storage (:) = spval - a_livecrootc_xfer (:) = spval - a_deadcrootc (:) = spval - a_deadcrootc_storage (:) = spval - a_deadcrootc_xfer (:) = spval - a_grainc (:) = spval - a_grainc_storage (:) = spval - a_grainc_xfer (:) = spval - a_leafn (:) = spval - a_leafn_storage (:) = spval - a_leafn_xfer (:) = spval - a_frootn (:) = spval - a_frootn_storage (:) = spval - a_frootn_xfer (:) = spval - a_livestemn (:) = spval - a_livestemn_storage (:) = spval - a_livestemn_xfer (:) = spval - a_deadstemn (:) = spval - a_deadstemn_storage (:) = spval - a_deadstemn_xfer (:) = spval - a_livecrootn (:) = spval - a_livecrootn_storage (:) = spval - a_livecrootn_xfer (:) = spval - a_deadcrootn (:) = spval - a_deadcrootn_storage (:) = spval - a_deadcrootn_xfer (:) = spval - a_grainn (:) = spval - a_grainn_storage (:) = spval - a_grainn_xfer (:) = spval - a_retransn (:) = spval - a_gpp (:) = spval - a_downreg (:) = spval - a_ar (:) = spval - a_cwdprod (:) = spval - a_cwddecomp (:) = spval - a_hr (:) = spval - a_fpg (:) = spval - a_fpi (:) = spval - a_totvegc (:) = spval - a_totlitc (:) = spval - a_totcwdc (:) = spval - a_totsomc (:) = spval - a_totcolc (:) = spval - a_totvegn (:) = spval - a_totlitn (:) = spval - a_totcwdn (:) = spval - a_totsomn (:) = spval - a_totcoln (:) = spval - a_gpp_enftemp (:) = spval - a_gpp_enfboreal (:) = spval - a_gpp_dnfboreal (:) = spval - a_gpp_ebftrop (:) = spval - a_gpp_ebftemp (:) = spval - a_gpp_dbftrop (:) = spval - a_gpp_dbftemp (:) = spval - a_gpp_dbfboreal (:) = spval - a_gpp_ebstemp (:) = spval - a_gpp_dbstemp (:) = spval - a_gpp_dbsboreal (:) = spval - a_gpp_c3arcgrass (:) = spval - a_gpp_c3grass (:) = spval - a_gpp_c4grass (:) = spval - a_npp_enftemp (:) = spval - a_npp_enfboreal (:) = spval - a_npp_dnfboreal (:) = spval - a_npp_ebftrop (:) = spval - a_npp_ebftemp (:) = spval - a_npp_dbftrop (:) = spval - a_npp_dbftemp (:) = spval - a_npp_dbfboreal (:) = spval - a_npp_ebstemp (:) = spval - a_npp_dbstemp (:) = spval - a_npp_dbsboreal (:) = spval - a_npp_c3arcgrass (:) = spval - a_npp_c3grass (:) = spval - a_npp_c4grass (:) = spval - a_npptoleafc_enftemp (:) = spval - a_npptoleafc_enfboreal (:) = spval - a_npptoleafc_dnfboreal (:) = spval - a_npptoleafc_ebftrop (:) = spval - a_npptoleafc_ebftemp (:) = spval - a_npptoleafc_dbftrop (:) = spval - a_npptoleafc_dbftemp (:) = spval - a_npptoleafc_dbfboreal (:) = spval - a_npptoleafc_ebstemp (:) = spval - a_npptoleafc_dbstemp (:) = spval - a_npptoleafc_dbsboreal (:) = spval - a_npptoleafc_c3arcgrass (:) = spval - a_npptoleafc_c3grass (:) = spval - a_npptoleafc_c4grass (:) = spval - a_leafc_enftemp (:) = spval - a_leafc_enfboreal (:) = spval - a_leafc_dnfboreal (:) = spval - a_leafc_ebftrop (:) = spval - a_leafc_ebftemp (:) = spval - a_leafc_dbftrop (:) = spval - a_leafc_dbftemp (:) = spval - a_leafc_dbfboreal (:) = spval - a_leafc_ebstemp (:) = spval - a_leafc_dbstemp (:) = spval - a_leafc_dbsboreal (:) = spval - a_leafc_c3arcgrass (:) = spval - a_leafc_c3grass (:) = spval - a_leafc_c4grass (:) = spval - - a_O2_DECOMP_DEPTH_UNSAT (:,:) = spval - a_CONC_O2_UNSAT (:,:) = spval -#ifdef CROP - a_pdcorn (:) = spval - a_pdswheat (:) = spval - a_pdwwheat (:) = spval - a_pdsoybean (:) = spval - a_pdcotton (:) = spval - a_pdrice1 (:) = spval - a_pdrice2 (:) = spval - a_pdsugarcane (:) = spval - a_plantdate (:) = spval - a_manunitro (:) = spval - a_fertnitro_corn (:) = spval - a_fertnitro_swheat (:) = spval - a_fertnitro_wwheat (:) = spval - a_fertnitro_soybean (:) = spval - a_fertnitro_cotton (:) = spval - a_fertnitro_rice1 (:) = spval - a_fertnitro_rice2 (:) = spval - a_fertnitro_sugarcane(:) = spval - a_irrig_method_corn (:) = spval - a_irrig_method_swheat (:) = spval - a_irrig_method_wwheat (:) = spval - a_irrig_method_soybean (:) = spval - a_irrig_method_cotton (:) = spval - a_irrig_method_rice1 (:) = spval - a_irrig_method_rice2 (:) = spval - a_irrig_method_sugarcane(:) = spval - a_cphase (:) = spval - a_vf (:) = spval - a_gddmaturity (:) = spval - a_gddplant (:) = spval - a_hui (:) = spval - a_cropprod1c (:) = spval - a_cropprod1c_loss (:) = spval - a_cropseedc_deficit (:) = spval - a_grainc_to_cropprodc(:) = spval - a_grainc_to_seed (:) = spval - a_fert_to_sminn (:) = spval - - a_sum_irrig (:) = spval - a_sum_deficit_irrig (:) = spval - a_sum_irrig_count (:) = spval - a_waterstorage (:) = spval - a_groundwater_demand (:) = spval - a_groundwater_supply (:) = spval - a_reservoirriver_demand(:) = spval - a_reservoirriver_supply(:) = spval - a_reservoir_supply (:) = spval - a_river_supply (:) = spval - a_runoff_supply (:) = spval -#endif - a_ndep_to_sminn (:) = spval - - a_abm (:) = spval - a_gdp (:) = spval - a_peatf (:) = spval - a_hdm (:) = spval - a_lnfm (:) = spval - - a_leafcCap (:) = spval - a_leafc_storageCap (:) = spval - a_leafc_xferCap (:) = spval - a_frootcCap (:) = spval - a_frootc_storageCap (:) = spval - a_frootc_xferCap (:) = spval - a_livestemcCap (:) = spval - a_livestemc_storageCap (:) = spval - a_livestemc_xferCap (:) = spval - a_deadstemcCap (:) = spval - a_deadstemc_storageCap (:) = spval - a_deadstemc_xferCap (:) = spval - a_livecrootcCap (:) = spval - a_livecrootc_storageCap(:) = spval - a_livecrootc_xferCap (:) = spval - a_deadcrootcCap (:) = spval - a_deadcrootc_storageCap(:) = spval - a_deadcrootc_xferCap (:) = spval - a_leafnCap (:) = spval - a_leafn_storageCap (:) = spval - a_leafn_xferCap (:) = spval - a_frootnCap (:) = spval - a_frootn_storageCap (:) = spval - a_frootn_xferCap (:) = spval - a_livestemnCap (:) = spval - a_livestemn_storageCap (:) = spval - a_livestemn_xferCap (:) = spval - a_deadstemnCap (:) = spval - a_deadstemn_storageCap (:) = spval - a_deadstemn_xferCap (:) = spval - a_livecrootnCap (:) = spval - a_livecrootn_storageCap(:) = spval - a_livecrootn_xferCap (:) = spval - a_deadcrootnCap (:) = spval - a_deadcrootn_storageCap(:) = spval - a_deadcrootn_xferCap (:) = spval -#endif - a_ozone (:) = spval - - a_t_soisno (:,:) = spval - a_wliq_soisno (:,:) = spval - a_wice_soisno (:,:) = spval - a_h2osoi (:,:) = spval - a_qlayer (:,:) = spval - a_lake_deficit (:) = spval - a_rootr (:,:) = spval - a_BD_all (:,:) = spval - a_wfc (:,:) = spval - a_OM_density (:,:) = spval -!Plant Hydraulic parameters - a_vegwp (:,:) = spval -!END plant hydraulic parameters - a_dz_lake (:,:) = spval - a_t_lake (:,:) = spval - a_lake_icefrac (:,:) = spval -#ifdef BGC - a_litr1c_vr (:,:) = spval - a_litr2c_vr (:,:) = spval - a_litr3c_vr (:,:) = spval - a_soil1c_vr (:,:) = spval - a_soil2c_vr (:,:) = spval - a_soil3c_vr (:,:) = spval - a_cwdc_vr (:,:) = spval - a_litr1n_vr (:,:) = spval - a_litr2n_vr (:,:) = spval - a_litr3n_vr (:,:) = spval - a_soil1n_vr (:,:) = spval - a_soil2n_vr (:,:) = spval - a_soil3n_vr (:,:) = spval - a_cwdn_vr (:,:) = spval - a_totsoiln_vr (:,:) = spval - - a_litr1cCap_vr (:,:) = spval - a_litr2cCap_vr (:,:) = spval - a_litr3cCap_vr (:,:) = spval - a_soil1cCap_vr (:,:) = spval - a_soil2cCap_vr (:,:) = spval - a_soil3cCap_vr (:,:) = spval - a_cwdcCap_vr (:,:) = spval - a_litr1nCap_vr (:,:) = spval - a_litr2nCap_vr (:,:) = spval - a_litr3nCap_vr (:,:) = spval - a_soil1nCap_vr (:,:) = spval - a_soil2nCap_vr (:,:) = spval - a_soil3nCap_vr (:,:) = spval - a_cwdnCap_vr (:,:) = spval - - a_t_scalar (:,:) = spval - a_w_scalar (:,:) = spval - - a_sminn_vr (:,:) = spval -#endif - - a_ustar (:) = spval - a_ustar2(:) = spval - a_tstar (:) = spval - a_qstar (:) = spval - a_zol (:) = spval - a_rib (:) = spval - a_fm (:) = spval - a_fh (:) = spval - a_fq (:) = spval - - a_us10m (:) = spval - a_vs10m (:) = spval - a_fm10m (:) = spval - - a_sr (:) = spval - a_solvd (:) = spval - a_solvi (:) = spval - a_solnd (:) = spval - a_solni (:) = spval - a_srvd (:) = spval - a_srvi (:) = spval - a_srnd (:) = spval - a_srni (:) = spval - a_solvdln (:) = spval - a_solviln (:) = spval - a_solndln (:) = spval - a_solniln (:) = spval - a_srvdln (:) = spval - a_srviln (:) = spval - a_srndln (:) = spval - a_srniln (:) = spval -#ifdef HYPERSPECTRAL - a_sol_dir_ln_hires(:,:) = spval - a_sol_dif_ln_hires(:,:) = spval - a_sr_dir_ln_hires (:,:) = spval - a_sr_dif_ln_hires (:,:) = spval -#endif - a_sensors(:,:) = spval - - nac_ln (:) = 0 - nac_dt (:) = 0 - filter_dt (:) = .true. - - ENDIF - ENDIF - -#ifdef EXTERNAL_LAKE - CALL Flush_LakeAccVars -#endif - - END SUBROUTINE FLUSH_acc_fluxes - - SUBROUTINE accumulate_fluxes -! ---------------------------------------------------------------------- -! perform the grid average mapping: average a subgrid input 1d vector -! of length numpatch to a output 2d array of length [ghist%xcnt,ghist%ycnt] -! -! Created by Yongjiu Dai, 03/2014 -!--------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE mod_forcing, only: forcmask_pch - USE MOD_Mesh, only: numelm - USE MOD_LandElm - USE MOD_LandPatch, only: numpatch, elm_patch - USE MOD_LandUrban, only: numurban - USE MOD_Const_Physical, only: vonkar, stefnc, cpair, rgas, grav - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Vars_1DForcing - USE MOD_Vars_1DFluxes - USE MOD_FrictionVelocity - USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_OZONESTRESS, DEF_USE_PLANTHYDRAULICS, DEF_USE_NITRIF - USE MOD_TurbulenceLEddy - USE MOD_Vars_Global -#ifdef CatchLateralFlow - USE MOD_Catch_Vars_1DFluxes - USE MOD_Catch_Hist, only: accumulate_fluxes_basin -#endif - - IMPLICIT NONE - - ! Local Variables - - real(r8), allocatable :: r_trad (:) - real(r8), allocatable :: r_ustar (:) - real(r8), allocatable :: r_ustar2 (:) !define a temporary for estimating us10m only, output should be r_ustar. Shaofeng, 2023.05.20 - real(r8), allocatable :: r_tstar (:) - real(r8), allocatable :: r_qstar (:) - real(r8), allocatable :: r_zol (:) - real(r8), allocatable :: r_rib (:) - real(r8), allocatable :: r_fm (:) - real(r8), allocatable :: r_fh (:) - real(r8), allocatable :: r_fq (:) - - real(r8), allocatable :: r_us10m (:) - real(r8), allocatable :: r_vs10m (:) - real(r8), allocatable :: r_fm10m (:) - - logical, allocatable :: filter (:) - - !--------------------------------------------------------------------- - integer ib, jb, i, j, ielm, istt, iend - real(r8) sumwt - real(r8) rhoair,thm,th,thv,ur,displa_av,zldis,hgt_u,hgt_t,hgt_q - real(r8) hpbl ! atmospheric boundary layer height [m] - real(r8) z0m_av,z0h_av,z0q_av,us,vs,tm,qm,psrf,taux_e,tauy_e,fsena_e,fevpa_e - real(r8) r_ustar_e, r_tstar_e, r_qstar_e, r_zol_e, r_ustar2_e, r_fm10m_e - real(r8) r_fm_e, r_fh_e, r_fq_e, r_rib_e, r_us10m_e, r_vs10m_e - real(r8) obu,fh2m,fq2m - real(r8) um,thvstar,beta,zii,wc,wc2 - - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - - ! count for time steps - nac = nac + 1 - - ! count for local noon time steps - DO i = 1, numpatch - IF (solvdln(i) /= spval) THEN - nac_ln(i) = nac_ln(i) + 1 - ENDIF - ENDDO - - ! set daytime filter - filter_dt(:) = coszen(:) > 0 - - ! count for daytime time steps - WHERE ( filter_dt(:) ) nac_dt(:) = nac_dt(:) + 1 - - CALL acc1d (forc_us , a_us ) - CALL acc1d (forc_vs , a_vs ) - CALL acc1d (forc_t , a_t ) - CALL acc1d (forc_q , a_q ) - CALL acc1d (forc_prc , a_prc ) - CALL acc1d (forc_prl , a_prl ) - CALL acc1d (forc_pbot , a_pbot ) - CALL acc1d (forc_frl , a_frl ) - - CALL acc1d (forc_sols , a_solarin ) - CALL acc1d (forc_soll , a_solarin ) - CALL acc1d (forc_solsd , a_solarin ) - CALL acc1d (forc_solld , a_solarin ) - - IF (DEF_USE_CBL_HEIGHT) THEN - CALL acc1d (forc_hpbl , a_hpbl) - ENDIF - - CALL acc1d (taux , a_taux ) - CALL acc1d (tauy , a_tauy ) - CALL acc1d (fsena , a_fsena ) - CALL acc1d (lfevpa , a_lfevpa ) - CALL acc1d (fevpa , a_fevpa ) - CALL acc1d (fsenl , a_fsenl ) - CALL acc1d (fevpl , a_fevpl ) - CALL acc1d (etr , a_etr ) - CALL acc1d (fseng , a_fseng ) - CALL acc1d (fevpg , a_fevpg ) - CALL acc1d (fgrnd , a_fgrnd ) - CALL acc1d (sabvsun , a_sabvsun ) - CALL acc1d (sabvsha , a_sabvsha ) - CALL acc1d (sabg , a_sabg ) - CALL acc1d (olrg , a_olrg ) - - IF (DEF_forcing%has_missing_value) THEN - WHERE (forcmask_pch) - rnet = sabg + sabvsun + sabvsha - olrg + forc_frl - END WHERE - ELSE - WHERE(patchmask) - rnet = sabg + sabvsun + sabvsha - olrg + forc_frl - END WHERE - ENDIF - CALL acc1d (rnet , a_rnet ) - - CALL acc1d (xerr , a_xerr ) - CALL acc1d (zerr , a_zerr ) - CALL acc1d (rsur , a_rsur ) -#ifndef CatchLateralFlow - CALL acc1d (rsur_se , a_rsur_se ) - CALL acc1d (rsur_ie , a_rsur_ie ) -#endif - CALL acc1d (rsub , a_rsub ) - CALL acc1d (rnof , a_rnof ) -#ifdef CatchLateralFlow - CALL acc1d (xwsur , a_xwsur ) - CALL acc1d (xwsub , a_xwsub ) - CALL acc1d (fldarea , a_fldarea ) -#endif - CALL acc1d (qintr , a_qintr ) - CALL acc1d (qinfl , a_qinfl ) - CALL acc1d (qdrip , a_qdrip ) - - CALL acc1d (rstfacsun_out , a_rstfacsun ) - CALL acc1d (rstfacsha_out , a_rstfacsha ) - - CALL acc1d (gssun_out , a_gssun ) - CALL acc1d (gssha_out , a_gssha ) - - CALL acc1d (rss , a_rss ) - CALL acc1d (wdsrf , a_wdsrf ) - CALL acc1d (zwt , a_zwt ) - CALL acc1d (wa , a_wa ) - CALL acc1d (wat , a_wat ) - CALL acc1d (wetwat , a_wetwat ) - CALL acc1d (assim , a_assim ) - CALL acc1d (respc , a_respc ) - CALL acc1d (assimsun_out , a_assimsun ) - CALL acc1d (assimsha_out , a_assimsha ) - CALL acc1d (etrsun_out , a_etrsun ) - CALL acc1d (etrsha_out , a_etrsha ) - - CALL acc1d (qcharge , a_qcharge ) - - CALL acc1d (t_grnd , a_t_grnd ) - CALL acc1d (tleaf , a_tleaf ) - CALL acc1d (ldew_rain , a_ldew_rain ) - CALL acc1d (ldew_snow , a_ldew_snow ) - CALL acc1d (ldew , a_ldew ) - CALL acc1d (scv , a_scv ) - CALL acc1d (snowdp , a_snowdp ) - CALL acc1d (fsno , a_fsno ) - CALL acc1d (frcsat , a_frcsat ) - CALL acc1d (sigf , a_sigf ) - CALL acc1d (green , a_green ) - CALL acc1d (lai , a_lai ) - CALL acc1d (laisun , a_laisun ) - CALL acc1d (laisha , a_laisha ) - CALL acc1d (sai , a_sai ) - - ! only acc for daytime for albedo - CALL acc3d (alb , a_alb, filter_dt ) -#ifdef HYPERSPECTRAL - CALL acc3d (alb_hires , a_alb_hires, filter_dt ) -#endif - - CALL acc1d (emis , a_emis ) - CALL acc1d (z0m , a_z0m ) - - allocate (r_trad (numpatch)) ; r_trad(:) = spval - DO i = 1, numpatch - IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask_pch(i)) CYCLE - ENDIF - - IF (.not. patchmask(i)) CYCLE - r_trad(i) = (olrg(i)/stefnc)**0.25 - ENDDO - CALL acc1d (r_trad , a_trad ) - deallocate (r_trad ) - - CALL acc1d (tref , a_tref ) - CALL acc1d (qref , a_qref ) - - ! set 2m WMO temperature - DO ielm = 1, numelm - - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - - ! landelm%settyp=1 means 2m WMO patch exist, - ! which is the last end patch in a element. - IF (landelm%settyp(ielm)==1 .and. forcmask_pch(iend)) THEN - ! all set to the 2m WMO patch tref - t2m_wmo(istt:iend) = tref(iend) - ELSE - ! if no 2m WMO patch, keep t2m_wmo to tref - t2m_wmo(istt:iend) = tref(istt:iend) - ENDIF - ENDDO - - CALL acc1d (t2m_wmo, a_t2m_wmo) - - CALL acc1d (forc_rain, a_rain ) - CALL acc1d (forc_snow, a_snow ) - - IF (DEF_USE_OZONESTRESS)THEN - CALL acc1d(o3uptakesun,a_o3uptakesun) - CALL acc1d(o3uptakesha,a_o3uptakesha) - ENDIF - -#ifdef DataAssimilation - CALL acc3d (h2osoi_ens , a_h2osoi_ens ) - CALL acc3d (t_brt_smap_ens , a_t_brt_smap_ens ) - CALL acc2d (t_brt_smap , a_t_brt_smap ) - CALL acc3d (t_brt_fy3d_ens , a_t_brt_fy3d_ens ) - CALL acc2d (t_brt_fy3d , a_t_brt_fy3d ) - CALL acc3d (wliq_soisno_ens, a_wliq_soisno_ens) - CALL acc3d (wice_soisno_ens, a_wice_soisno_ens) - CALL acc3d (t_soisno_ens , a_t_soisno_ens ) -#endif - -#ifdef URBAN_MODEL - IF (numurban > 0) THEN - CALL acc1d(t_room , a_t_room ) - CALL acc1d(tafu , a_tafu ) - CALL acc1d(fhac , a_fhac ) - CALL acc1d(fwst , a_fwst ) - CALL acc1d(fach , a_fach ) - CALL acc1d(fahe , a_fahe ) - CALL acc1d(fhah , a_fhah ) - CALL acc1d(vehc , a_vehc ) - CALL acc1d(meta , a_meta ) - - CALL acc1d(fsen_roof , a_senroof ) - CALL acc1d(fsen_wsun , a_senwsun ) - CALL acc1d(fsen_wsha , a_senwsha ) - CALL acc1d(fsen_gimp , a_sengimp ) - CALL acc1d(fsen_gper , a_sengper ) - CALL acc1d(fsen_urbl , a_senurbl ) - - CALL acc1d(lfevp_roof , a_lfevproof ) - CALL acc1d(lfevp_gimp , a_lfevpgimp ) - CALL acc1d(lfevp_gper , a_lfevpgper ) - CALL acc1d(lfevp_urbl , a_lfevpurbl ) - - CALL acc1d(t_roof , a_troof ) - CALL acc1d(t_wall , a_twall ) - ENDIF -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL acc1d (lai_enftemp , a_lai_enftemp ) - CALL acc1d (lai_enfboreal , a_lai_enfboreal ) - CALL acc1d (lai_dnfboreal , a_lai_dnfboreal ) - CALL acc1d (lai_ebftrop , a_lai_ebftrop ) - CALL acc1d (lai_ebftemp , a_lai_ebftemp ) - CALL acc1d (lai_dbftrop , a_lai_dbftrop ) - CALL acc1d (lai_dbftemp , a_lai_dbftemp ) - CALL acc1d (lai_dbfboreal , a_lai_dbfboreal ) - CALL acc1d (lai_ebstemp , a_lai_ebstemp ) - CALL acc1d (lai_dbstemp , a_lai_dbstemp ) - CALL acc1d (lai_dbsboreal , a_lai_dbsboreal ) - CALL acc1d (lai_c3arcgrass , a_lai_c3arcgrass ) - CALL acc1d (lai_c3grass , a_lai_c3grass ) - CALL acc1d (lai_c4grass , a_lai_c4grass ) -#endif -#ifdef BGC - CALL acc1d (leafc , a_leafc ) - CALL acc1d (leafc_storage , a_leafc_storage ) - CALL acc1d (leafc_xfer , a_leafc_xfer ) - CALL acc1d (frootc , a_frootc ) - CALL acc1d (frootc_storage , a_frootc_storage ) - CALL acc1d (frootc_xfer , a_frootc_xfer ) - CALL acc1d (livestemc , a_livestemc ) - CALL acc1d (livestemc_storage , a_livestemc_storage ) - CALL acc1d (livestemc_xfer , a_livestemc_xfer ) - CALL acc1d (deadstemc , a_deadstemc ) - CALL acc1d (deadstemc_storage , a_deadstemc_storage ) - CALL acc1d (deadstemc_xfer , a_deadstemc_xfer ) - CALL acc1d (livecrootc , a_livecrootc ) - CALL acc1d (livecrootc_storage , a_livecrootc_storage ) - CALL acc1d (livecrootc_xfer , a_livecrootc_xfer ) - CALL acc1d (deadcrootc , a_deadcrootc ) - CALL acc1d (deadcrootc_storage , a_deadcrootc_storage ) - CALL acc1d (deadcrootc_xfer , a_deadcrootc_xfer ) - CALL acc1d (grainc , a_grainc ) - CALL acc1d (grainc_storage , a_grainc_storage ) - CALL acc1d (grainc_xfer , a_grainc_xfer ) - CALL acc1d (leafn , a_leafn ) - CALL acc1d (leafn_storage , a_leafn_storage ) - CALL acc1d (leafn_xfer , a_leafn_xfer ) - CALL acc1d (frootn , a_frootn ) - CALL acc1d (frootn_storage , a_frootn_storage ) - CALL acc1d (frootn_xfer , a_frootn_xfer ) - CALL acc1d (livestemn , a_livestemn ) - CALL acc1d (livestemn_storage , a_livestemn_storage ) - CALL acc1d (livestemn_xfer , a_livestemn_xfer ) - CALL acc1d (deadstemn , a_deadstemn ) - CALL acc1d (deadstemn_storage , a_deadstemn_storage ) - CALL acc1d (deadstemn_xfer , a_deadstemn_xfer ) - CALL acc1d (livecrootn , a_livecrootn ) - CALL acc1d (livecrootn_storage , a_livecrootn_storage ) - CALL acc1d (livecrootn_xfer , a_livecrootn_xfer ) - CALL acc1d (deadcrootn , a_deadcrootn ) - CALL acc1d (deadcrootn_storage , a_deadcrootn_storage ) - CALL acc1d (deadcrootn_xfer , a_deadcrootn_xfer ) - CALL acc1d (grainn , a_grainn ) - CALL acc1d (grainn_storage , a_grainn_storage ) - CALL acc1d (grainn_xfer , a_grainn_xfer ) - CALL acc1d (retransn , a_retransn ) - CALL acc1d (gpp , a_gpp ) - CALL acc1d (downreg , a_downreg ) - CALL acc1d (ar , a_ar ) - CALL acc1d (cwdprod , a_cwdprod ) - CALL acc1d (cwddecomp , a_cwddecomp ) - CALL acc1d (decomp_hr , a_hr ) - CALL acc1d (fpg , a_fpg ) - CALL acc1d (fpi , a_fpi ) - CALL acc1d (totvegc , a_totvegc ) - CALL acc1d (totlitc , a_totlitc ) - CALL acc1d (totcwdc , a_totcwdc ) - CALL acc1d (totsomc , a_totsomc ) - CALL acc1d (totcolc , a_totcolc ) - CALL acc1d (totvegn , a_totvegn ) - CALL acc1d (totlitn , a_totlitn ) - CALL acc1d (totcwdn , a_totcwdn ) - CALL acc1d (totsomn , a_totsomn ) - CALL acc1d (totcoln , a_totcoln ) - CALL acc1d (gpp_enftemp , a_gpp_enftemp ) - CALL acc1d (gpp_enfboreal , a_gpp_enfboreal ) - CALL acc1d (gpp_dnfboreal , a_gpp_dnfboreal ) - CALL acc1d (gpp_ebftrop , a_gpp_ebftrop ) - CALL acc1d (gpp_ebftemp , a_gpp_ebftemp ) - CALL acc1d (gpp_dbftrop , a_gpp_dbftrop ) - CALL acc1d (gpp_dbftemp , a_gpp_dbftemp ) - CALL acc1d (gpp_dbfboreal , a_gpp_dbfboreal ) - CALL acc1d (gpp_ebstemp , a_gpp_ebstemp ) - CALL acc1d (gpp_dbstemp , a_gpp_dbstemp ) - CALL acc1d (gpp_dbsboreal , a_gpp_dbsboreal ) - CALL acc1d (gpp_c3arcgrass , a_gpp_c3arcgrass ) - CALL acc1d (gpp_c3grass , a_gpp_c3grass ) - CALL acc1d (gpp_c4grass , a_gpp_c4grass ) - CALL acc1d (npp_enftemp , a_npp_enftemp ) - CALL acc1d (npp_enfboreal , a_npp_enfboreal ) - CALL acc1d (npp_dnfboreal , a_npp_dnfboreal ) - CALL acc1d (npp_ebftrop , a_npp_ebftrop ) - CALL acc1d (npp_ebftemp , a_npp_ebftemp ) - CALL acc1d (npp_dbftrop , a_npp_dbftrop ) - CALL acc1d (npp_dbftemp , a_npp_dbftemp ) - CALL acc1d (npp_dbfboreal , a_npp_dbfboreal ) - CALL acc1d (npp_ebstemp , a_npp_ebstemp ) - CALL acc1d (npp_dbstemp , a_npp_dbstemp ) - CALL acc1d (npp_dbsboreal , a_npp_dbsboreal ) - CALL acc1d (npp_c3arcgrass , a_npp_c3arcgrass ) - CALL acc1d (npp_c3grass , a_npp_c3grass ) - CALL acc1d (npp_c4grass , a_npp_c4grass ) - CALL acc1d (npptoleafc_enftemp , a_npptoleafc_enftemp ) - CALL acc1d (npptoleafc_enfboreal , a_npptoleafc_enfboreal ) - CALL acc1d (npptoleafc_dnfboreal , a_npptoleafc_dnfboreal ) - CALL acc1d (npptoleafc_ebftrop , a_npptoleafc_ebftrop ) - CALL acc1d (npptoleafc_ebftemp , a_npptoleafc_ebftemp ) - CALL acc1d (npptoleafc_dbftrop , a_npptoleafc_dbftrop ) - CALL acc1d (npptoleafc_dbftemp , a_npptoleafc_dbftemp ) - CALL acc1d (npptoleafc_dbfboreal , a_npptoleafc_dbfboreal ) - CALL acc1d (npptoleafc_ebstemp , a_npptoleafc_ebstemp ) - CALL acc1d (npptoleafc_dbstemp , a_npptoleafc_dbstemp ) - CALL acc1d (npptoleafc_dbsboreal , a_npptoleafc_dbsboreal ) - CALL acc1d (npptoleafc_c3arcgrass , a_npptoleafc_c3arcgrass ) - CALL acc1d (npptoleafc_c3grass , a_npptoleafc_c3grass ) - CALL acc1d (npptoleafc_c4grass , a_npptoleafc_c4grass ) - CALL acc1d (leafc_enftemp , a_leafc_enftemp ) - CALL acc1d (leafc_enfboreal , a_leafc_enfboreal ) - CALL acc1d (leafc_dnfboreal , a_leafc_dnfboreal ) - CALL acc1d (leafc_ebftrop , a_leafc_ebftrop ) - CALL acc1d (leafc_ebftemp , a_leafc_ebftemp ) - CALL acc1d (leafc_dbftrop , a_leafc_dbftrop ) - CALL acc1d (leafc_dbftemp , a_leafc_dbftemp ) - CALL acc1d (leafc_dbfboreal , a_leafc_dbfboreal ) - CALL acc1d (leafc_ebstemp , a_leafc_ebstemp ) - CALL acc1d (leafc_dbstemp , a_leafc_dbstemp ) - CALL acc1d (leafc_dbsboreal , a_leafc_dbsboreal ) - CALL acc1d (leafc_c3arcgrass , a_leafc_c3arcgrass ) - CALL acc1d (leafc_c3grass , a_leafc_c3grass ) - CALL acc1d (leafc_c4grass , a_leafc_c4grass ) - IF(DEF_USE_NITRIF)THEN - CALL acc2d (to2_decomp_depth_unsat, a_O2_DECOMP_DEPTH_UNSAT) - CALL acc2d (tconc_o2_unsat , a_CONC_O2_UNSAT ) - ENDIF -#ifdef CROP - CALL acc1d (pdcorn , a_pdcorn ) - CALL acc1d (pdswheat , a_pdswheat ) - CALL acc1d (pdwwheat , a_pdwwheat ) - CALL acc1d (pdsoybean , a_pdsoybean ) - CALL acc1d (pdcotton , a_pdcotton ) - CALL acc1d (pdrice1 , a_pdrice1 ) - CALL acc1d (pdrice2 , a_pdrice2 ) - CALL acc1d (pdsugarcane , a_pdsugarcane ) - CALL acc1d (plantdate , a_plantdate ) - CALL acc1d (manunitro , a_manunitro ) - CALL acc1d (fertnitro_corn , a_fertnitro_corn ) - CALL acc1d (fertnitro_swheat , a_fertnitro_swheat ) - CALL acc1d (fertnitro_wwheat , a_fertnitro_wwheat ) - CALL acc1d (fertnitro_soybean , a_fertnitro_soybean ) - CALL acc1d (fertnitro_cotton , a_fertnitro_cotton ) - CALL acc1d (fertnitro_rice1 , a_fertnitro_rice1 ) - CALL acc1d (fertnitro_rice2 , a_fertnitro_rice2 ) - CALL acc1d (fertnitro_sugarcane, a_fertnitro_sugarcane) - CALL acc1d (real(irrig_method_corn ,r8), a_irrig_method_corn ) - CALL acc1d (real(irrig_method_swheat ,r8), a_irrig_method_swheat ) - CALL acc1d (real(irrig_method_wwheat ,r8), a_irrig_method_wwheat ) - CALL acc1d (real(irrig_method_soybean ,r8), a_irrig_method_soybean ) - CALL acc1d (real(irrig_method_cotton ,r8), a_irrig_method_cotton ) - CALL acc1d (real(irrig_method_rice1 ,r8), a_irrig_method_rice1 ) - CALL acc1d (real(irrig_method_rice2 ,r8), a_irrig_method_rice2 ) - CALL acc1d (real(irrig_method_sugarcane,r8), a_irrig_method_sugarcane) - CALL acc1d (cphase , a_cphase ) - CALL acc1d (hui , a_hui ) - CALL acc1d (vf , a_vf ) - CALL acc1d (gddmaturity , a_gddmaturity ) - CALL acc1d (gddplant , a_gddplant ) - CALL acc1d (cropprod1c , a_cropprod1c ) - CALL acc1d (cropprod1c_loss , a_cropprod1c_loss ) - CALL acc1d (cropseedc_deficit , a_cropseedc_deficit ) - CALL acc1d (grainc_to_cropprodc, a_grainc_to_cropprodc) - CALL acc1d (grainc_to_seed , a_grainc_to_seed ) - CALL acc1d (fert_to_sminn , a_fert_to_sminn ) - - a_sum_irrig = sum_irrig - a_sum_irrig_count = sum_irrig_count - a_waterstorage = waterstorage - CALL acc1d (groundwater_demand , a_groundwater_demand ) - CALL acc1d (groundwater_supply , a_groundwater_supply ) - CALL acc1d (reservoirriver_demand, a_reservoirriver_demand) - CALL acc1d (reservoirriver_supply, a_reservoirriver_supply) - CALL acc1d (reservoir_supply , a_reservoir_supply) - CALL acc1d (river_supply , a_river_supply) - CALL acc1d (runoff_supply , a_runoff_supply) -#endif - CALL acc1d (ndep_to_sminn , a_ndep_to_sminn ) - IF(DEF_USE_FIRE)THEN - CALL acc1d (abm_lf , a_abm ) - CALL acc1d (gdp_lf , a_gdp ) - CALL acc1d (peatf_lf , a_peatf ) - CALL acc1d (hdm_lf , a_hdm ) - CALL acc1d (lnfm , a_lnfm ) - ENDIF - IF(DEF_USE_DiagMatrix)THEN - CALL acc1d (leafcCap ,a_leafcCap ) - CALL acc1d (leafc_storageCap ,a_leafc_storageCap ) - CALL acc1d (leafc_xferCap ,a_leafc_xferCap ) - CALL acc1d (frootcCap ,a_frootcCap ) - CALL acc1d (frootc_storageCap ,a_frootc_storageCap ) - CALL acc1d (frootc_xferCap ,a_frootc_xferCap ) - CALL acc1d (livestemcCap ,a_livestemcCap ) - CALL acc1d (livestemc_storageCap ,a_livestemc_storageCap ) - CALL acc1d (livestemc_xferCap ,a_livestemc_xferCap ) - CALL acc1d (deadstemcCap ,a_deadstemcCap ) - CALL acc1d (deadstemc_storageCap ,a_deadstemc_storageCap ) - CALL acc1d (deadstemc_xferCap ,a_deadstemc_xferCap ) - CALL acc1d (livecrootcCap ,a_livecrootcCap ) - CALL acc1d (livecrootc_storageCap,a_livecrootc_storageCap) - CALL acc1d (livecrootc_xferCap ,a_livecrootc_xferCap ) - CALL acc1d (deadcrootcCap ,a_deadcrootcCap ) - CALL acc1d (deadcrootc_storageCap,a_deadcrootc_storageCap) - CALL acc1d (deadcrootc_xferCap ,a_deadcrootc_xferCap ) - CALL acc1d (leafnCap ,a_leafnCap ) - CALL acc1d (leafn_storageCap ,a_leafn_storageCap ) - CALL acc1d (leafn_xferCap ,a_leafn_xferCap ) - CALL acc1d (frootnCap ,a_frootnCap ) - CALL acc1d (frootn_storageCap ,a_frootn_storageCap ) - CALL acc1d (frootn_xferCap ,a_frootn_xferCap ) - CALL acc1d (livestemnCap ,a_livestemnCap ) - CALL acc1d (livestemn_storageCap ,a_livestemn_storageCap ) - CALL acc1d (livestemn_xferCap ,a_livestemn_xferCap ) - CALL acc1d (deadstemnCap ,a_deadstemnCap ) - CALL acc1d (deadstemn_storageCap ,a_deadstemn_storageCap ) - CALL acc1d (deadstemn_xferCap ,a_deadstemn_xferCap ) - CALL acc1d (livecrootnCap ,a_livecrootnCap ) - CALL acc1d (livecrootn_storageCap,a_livecrootn_storageCap) - CALL acc1d (livecrootn_xferCap ,a_livecrootn_xferCap ) - CALL acc1d (deadcrootnCap ,a_deadcrootnCap ) - CALL acc1d (deadcrootn_storageCap,a_deadcrootn_storageCap) - CALL acc1d (deadcrootn_xferCap ,a_deadcrootn_xferCap ) - ENDIF -#endif - IF(DEF_USE_OZONESTRESS)THEN - CALL acc1d (forc_ozone , a_ozone ) - ENDIF - - IF (.not. DEF_USE_Dynamic_Lake) THEN - CALL acc1d (lake_deficit, a_lake_deficit) - ENDIF - - CALL acc2d (t_soisno , a_t_soisno ) - CALL acc2d (wliq_soisno , a_wliq_soisno ) - CALL acc2d (wice_soisno , a_wice_soisno ) - - CALL acc2d (h2osoi , a_h2osoi ) - CALL acc2d (qlayer , a_qlayer ) - CALL acc2d (rootr , a_rootr ) - CALL acc2d (BD_all , a_BD_all ) - CALL acc2d (wfc , a_wfc ) - CALL acc2d (OM_density , a_OM_density ) - IF(DEF_USE_PLANTHYDRAULICS)THEN - CALL acc2d (vegwp , a_vegwp ) - ENDIF - IF (DEF_USE_Dynamic_Lake) THEN - CALL acc2d (dz_lake , a_dz_lake ) - ENDIF - CALL acc2d (t_lake , a_t_lake ) - CALL acc2d (lake_icefrac, a_lake_icefrac ) -#ifdef BGC - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_met_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr1c_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cel_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr2c_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_lig_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr3c_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil1,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil1c_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil2,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil2c_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil3,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil3c_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cwd,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_cwdc_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_met_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr1n_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cel_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr2n_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_lig_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr3n_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil1,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil1n_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil2,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil2n_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil3,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil3n_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cwd,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_cwdn_vr ) - CALL acc2d (totsoiln_vr , a_totsoiln_vr ) - - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_met_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr1cCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_cel_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr2cCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_lig_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr3cCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil1,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil1cCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil2,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil2cCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil3,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil3cCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_cwd,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_cwdcCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_met_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr1nCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_cel_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr2nCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_lig_lit,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_litr3nCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil1,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil1nCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil2,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil2nCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil3,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_soil3nCap_vr ) - DO i = 1, numpatch - DO j = 1, nl_soil - decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_cwd,i) - ENDDO - ENDDO - CALL acc2d (decomp_vr_tmp, a_cwdnCap_vr ) - CALL acc2d (sminn_vr , a_sminn_vr ) - - CALL acc2d (t_scalar , a_t_scalar ) - CALL acc2d (w_scalar , a_w_scalar ) -#endif - allocate (r_ustar (numpatch)); r_ustar (:) = spval - allocate (r_ustar2 (numpatch)); r_ustar2(:) = spval !Shaofeng, 2023.05.20 - allocate (r_tstar (numpatch)); r_tstar (:) = spval - allocate (r_qstar (numpatch)); r_qstar (:) = spval - allocate (r_zol (numpatch)); r_zol (:) = spval - allocate (r_rib (numpatch)); r_rib (:) = spval - allocate (r_fm (numpatch)); r_fm (:) = spval - allocate (r_fh (numpatch)); r_fh (:) = spval - allocate (r_fq (numpatch)); r_fq (:) = spval - allocate (r_us10m (numpatch)); r_us10m (:) = spval - allocate (r_vs10m (numpatch)); r_vs10m (:) = spval - allocate (r_fm10m (numpatch)); r_fm10m (:) = spval - - DO ielm = 1, numelm - - istt = elm_patch%substt(ielm) - iend = elm_patch%subend(ielm) - - allocate (filter (istt:iend)) - filter(:) = .true. - - filter(:) = patchmask(istt:iend) - - IF (DEF_forcing%has_missing_value) THEN - WHERE (.not. forcmask_pch(istt:iend)) filter = .false. - filter = filter .and. forcmask_pch(istt:iend) - ENDIF - - IF (.not. any(filter)) THEN - deallocate(filter) - CYCLE - ENDIF - - sumwt = sum(elm_patch%subfrc(istt:iend), mask = filter) - - ! Aggregate variables from patches to element (gridcell in latitude-longitude mesh) - z0m_av = sum(z0m (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - hgt_u = sum(forc_hgt_u (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - hgt_t = sum(forc_hgt_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - hgt_q = sum(forc_hgt_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - us = sum(forc_us (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - vs = sum(forc_vs (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - tm = sum(forc_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - qm = sum(forc_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - psrf = sum(forc_psrf (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - taux_e = sum(taux (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - tauy_e = sum(tauy (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - fsena_e = sum(fsena (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - fevpa_e = sum(fevpa (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 - hpbl = sum(forc_hpbl(istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - ENDIF - - z0h_av = z0m_av - z0q_av = z0m_av - - displa_av = 2./3.*z0m_av/0.07 - - hgt_u = max(hgt_u, 5.+displa_av) - hgt_t = max(hgt_t, 5.+displa_av) - hgt_q = max(hgt_q, 5.+displa_av) - - zldis = hgt_u-displa_av - - rhoair = (psrf - 0.378*qm*psrf/(0.622+0.378*qm)) / (rgas*tm) - - r_ustar_e = sqrt(max(1.e-6,sqrt(taux_e**2+tauy_e**2))/rhoair) - r_tstar_e = -fsena_e/(rhoair*r_ustar_e)/cpair - r_qstar_e = -fevpa_e/(rhoair*r_ustar_e) - - thm = tm + 0.0098*hgt_t - th = tm*(100000./psrf)**(rgas/cpair) - thv = th*(1.+0.61*qm) - - r_zol_e = zldis*vonkar*grav * (r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e) & - / (r_ustar_e**2*thv) - - IF(r_zol_e >= 0.)THEN !stable - r_zol_e = min(2.,max(r_zol_e,1.e-6)) - ELSE !unstable - r_zol_e = max(-100.,min(r_zol_e,-1.e-6)) - ENDIF - - beta = 1. - zii = 1000. - - thvstar=r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e - ur = sqrt(us*us+vs*vs) - IF(r_zol_e >= 0.)THEN - um = max(ur,0.1) - ELSE - IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 - zii = max(5.*hgt_u,hpbl) - ENDIF !//TODO: Shaofeng, 2023.05.18 - wc = (-grav*r_ustar_e*thvstar*zii/thv)**(1./3.) - wc2 = beta*beta*(wc*wc) - um = max(0.1,sqrt(ur*ur+wc2)) - ENDIF - - obu = zldis/r_zol_e - IF (DEF_USE_CBL_HEIGHT) THEN - CALL moninobuk_leddy(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& - obu,um, hpbl, r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20 - ELSE - CALL moninobuk(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& - obu,um,r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20 - ENDIF - - ! bug found by chen qiying 2013/07/01 - r_rib_e = r_zol_e /vonkar * r_ustar2_e**2 / (vonkar/r_fh_e*um**2) - r_rib_e = min(5.,r_rib_e) - - r_us10m_e = us/um * r_ustar2_e /vonkar * r_fm10m_e - r_vs10m_e = vs/um * r_ustar2_e /vonkar * r_fm10m_e - - ! Assign values from element (gridcell in latitude-longitude mesh) to patches. - ! Notice that all values on patches in an element are equal. - r_ustar (istt:iend) = r_ustar_e - r_ustar2(istt:iend) = r_ustar2_e - r_tstar (istt:iend) = r_tstar_e - r_qstar (istt:iend) = r_qstar_e - r_zol (istt:iend) = r_zol_e - r_rib (istt:iend) = r_rib_e - r_fm (istt:iend) = r_fm_e - r_fh (istt:iend) = r_fh_e - r_fq (istt:iend) = r_fq_e - r_us10m (istt:iend) = r_us10m_e - r_vs10m (istt:iend) = r_vs10m_e - r_fm10m (istt:iend) = r_fm10m_e - - deallocate(filter) - - ENDDO - - CALL acc1d (r_ustar , a_ustar ) - CALL acc1d (r_ustar2 , a_ustar2 ) - CALL acc1d (r_tstar , a_tstar ) - CALL acc1d (r_qstar , a_qstar ) - CALL acc1d (r_zol , a_zol ) - CALL acc1d (r_rib , a_rib ) - CALL acc1d (r_fm , a_fm ) - CALL acc1d (r_fh , a_fh ) - CALL acc1d (r_fq , a_fq ) - - CALL acc1d (r_us10m , a_us10m ) - CALL acc1d (r_vs10m , a_vs10m ) - CALL acc1d (r_fm10m , a_fm10m ) - - deallocate (r_ustar ) - deallocate (r_ustar2) !Shaofeng, 2023.05.20 - deallocate (r_tstar ) - deallocate (r_qstar ) - deallocate (r_zol ) - deallocate (r_rib ) - deallocate (r_fm ) - deallocate (r_fh ) - deallocate (r_fq ) - - deallocate (r_us10m ) - deallocate (r_vs10m ) - deallocate (r_fm10m ) - - CALL acc1d (sr , a_sr ) - CALL acc1d (solvd , a_solvd ) - CALL acc1d (solvi , a_solvi ) - CALL acc1d (solnd , a_solnd ) - CALL acc1d (solni , a_solni ) - CALL acc1d (srvd , a_srvd ) - CALL acc1d (srvi , a_srvi ) - CALL acc1d (srnd , a_srnd ) - CALL acc1d (srni , a_srni ) - CALL acc1d (solvdln , a_solvdln ) - CALL acc1d (solviln , a_solviln ) - CALL acc1d (solndln , a_solndln ) - CALL acc1d (solniln , a_solniln ) - CALL acc1d (srvdln , a_srvdln ) - CALL acc1d (srviln , a_srviln ) - CALL acc1d (srndln , a_srndln ) - CALL acc1d (srniln , a_srniln ) - - CALL acc2d (sensors , a_sensors ) -#ifdef HYPERSPECTRAL - CALL acc2d (sol_dir_ln_hires, a_sol_dir_ln_hires) - CALL acc2d (sol_dif_ln_hires, a_sol_dif_ln_hires) - CALL acc2d (sr_dir_ln_hires , a_sr_dir_ln_hires ) - CALL acc2d (sr_dif_ln_hires , a_sr_dif_ln_hires ) -#endif - - ENDIF - ENDIF - -#ifdef CatchLateralFlow - CALL accumulate_fluxes_basin () -#endif - -#ifdef EXTERNAL_LAKE - CALL accumulate_LakeTimeVars -#endif - - END SUBROUTINE accumulate_fluxes - - - !------ - SUBROUTINE acc1d (var, s) - - USE MOD_Precision - USE MOD_Vars_Global, only: spval - - IMPLICIT NONE - - real(r8), intent(in) :: var(:) - real(r8), intent(inout) :: s (:) - ! Local variables - integer :: i - - DO i = lbound(var,1), ubound(var,1) - IF (var(i) /= spval) THEN - IF (s(i) /= spval) THEN - s(i) = s(i) + var(i) - ELSE - s(i) = var(i) - ENDIF - ENDIF - ENDDO - - END SUBROUTINE acc1d - - !------ - SUBROUTINE acc2d (var, s) - - USE MOD_Precision - USE MOD_Vars_Global, only: spval - - IMPLICIT NONE - - real(r8), intent(in) :: var(:,:) - real(r8), intent(inout) :: s (:,:) - ! Local variables - integer :: i1, i2 - - DO i2 = lbound(var,2), ubound(var,2) - DO i1 = lbound(var,1), ubound(var,1) - IF (var(i1,i2) /= spval) THEN - IF (s(i1,i2) /= spval) THEN - s(i1,i2) = s(i1,i2) + var(i1,i2) - ELSE - s(i1,i2) = var(i1,i2) - ENDIF - ENDIF - ENDDO - ENDDO - - END SUBROUTINE acc2d - - !------ - SUBROUTINE acc3d (var, s, filter) - - USE MOD_Precision - USE MOD_Vars_Global, only: spval - - IMPLICIT NONE - - real(r8), intent(in) :: var(:,:,:) - real(r8), intent(inout) :: s (:,:,:) - logical, intent(in), optional :: filter(:) - - ! Local variables - integer :: i1, i2, i3 - - DO i3 = lbound(var,3), ubound(var,3) - - IF ( present(filter) ) THEN - IF ( .not. filter(i3) ) CYCLE - ENDIF - - DO i2 = lbound(var,2), ubound(var,2) - DO i1 = lbound(var,1), ubound(var,1) - IF (var(i1,i2,i3) /= spval) THEN - IF (s(i1,i2,i3) /= spval) THEN - s(i1,i2,i3) = s(i1,i2,i3) + var(i1,i2,i3) - ELSE - s(i1,i2,i3) = var(i1,i2,i3) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - - END SUBROUTINE acc3d - -END MODULE MOD_Vars_1DAccFluxes -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 index 1eed919be9..c99adaf678 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 @@ -108,11 +108,11 @@ SUBROUTINE allocate_1D_Fluxes ! ------------------------------------------------------------------- USE MOD_Precision USE MOD_Vars_Global - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -208,10 +208,10 @@ SUBROUTINE deallocate_1D_Fluxes () ! -------------------------------------------------------------------- ! deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 index d071335bc7..745c13b9bc 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 @@ -12,6 +12,8 @@ MODULE MOD_Vars_1DForcing IMPLICIT NONE SAVE + character(len=*), parameter :: forc_height_mode = 'absolute' + !----------------------------------------------------------------------- real(r8), allocatable :: forc_pco2m (:) ! CO2 concentration in atmos. (pascals) real(r8), allocatable :: forc_po2m (:) ! O2 concentration in atmos. (pascals) @@ -35,7 +37,7 @@ MODULE MOD_Vars_1DForcing real(r8), allocatable :: forc_hgt_t (:) ! observational height of temperature [m] real(r8), allocatable :: forc_hgt_q (:) ! observational height of humidity [m] real(r8), allocatable :: forc_rhoair(:) ! air density [kg/m3] - real(r8), allocatable :: forc_ozone (:) ! air density [kg/m3] + real(r8), allocatable :: forc_ozone (:) ! ozone concentration [ppbv] #ifdef HYPERSPECTRAL real(r8), allocatable :: forc_solarin(:) ! incident solar radiation [W/m2] #endif @@ -60,12 +62,13 @@ SUBROUTINE allocate_1D_Forcing ! ------------------------------------------------------------------- ! Allocates memory for CoLM 1d [numpatch] variables ! ------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Mesh USE MOD_LandPatch + USE MOD_Vars_Global, only: spval IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -94,7 +97,7 @@ SUBROUTINE allocate_1D_Forcing allocate (forc_hgt_t (numpatch) ) ! observational height of temperature [m] allocate (forc_hgt_q (numpatch) ) ! observational height of humidity [m] allocate (forc_rhoair (numpatch) ) ! air density [kg/m3] - allocate (forc_ozone (numpatch) ) ! air density [kg/m3] + allocate (forc_ozone (numpatch) ) ! ozone concentration [ppbv] allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] @@ -104,6 +107,36 @@ SUBROUTINE allocate_1D_Forcing allocate (forc_aerdep(14,numpatch) ) ! atmospheric aerosol deposition data [kg/m/s] + forc_pco2m = spval + forc_po2m = spval + forc_us = spval + forc_vs = spval + forc_t = spval + forc_q = spval + forc_prc = spval + forc_prl = spval + forc_rain = spval + forc_snow = spval + forc_psrf = spval + forc_pbot = spval +#ifdef HYPERSPECTRAL + forc_solarin = spval +#endif + forc_sols = spval + forc_soll = spval + forc_solsd = spval + forc_solld = spval + forc_frl = spval + forc_swrad = spval + forc_hgt_u = spval + forc_hgt_t = spval + forc_hgt_q = spval + forc_rhoair = spval + forc_ozone = spval + forc_hpbl = spval + IF (allocated(forc_topo)) forc_topo = spval + forc_aerdep = spval + ENDIF ENDIF @@ -113,12 +146,12 @@ END SUBROUTINE allocate_1D_Forcing SUBROUTINE deallocate_1D_Forcing () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Mesh USE MOD_LandPatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -147,7 +180,7 @@ SUBROUTINE deallocate_1D_Forcing () deallocate ( forc_hgt_t ) ! observational height of temperature [m] deallocate ( forc_hgt_q ) ! observational height of humidity [m] deallocate ( forc_rhoair ) ! air density [kg/m3] - deallocate ( forc_ozone ) ! Ozone partial pressure [mol/mol] + deallocate ( forc_ozone ) ! ozone concentration [ppbv] deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 index 0809c19479..183c40177b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 @@ -56,11 +56,11 @@ SUBROUTINE allocate_1D_PFTFluxes ! ------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN allocate (taux_p (numpft)) ; taux_p (:) = spval !wind stress: E-W [kg/m/s2] @@ -93,10 +93,10 @@ SUBROUTINE deallocate_1D_PFTFluxes ! ------------------------------------------------------------------- ! deallocates memory for CoLM PFT 1d [numpft] variables ! ------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN deallocate (taux_p ) @@ -131,14 +131,14 @@ SUBROUTINE set_1D_PFTFluxes(Values, Nan) ! ------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT IMPLICIT NONE real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN taux_p (:) = Values !wind stress: E-W [kg/m/s2] diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 deleted file mode 100644 index e0c961ef9e..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90 +++ /dev/null @@ -1,81 +0,0 @@ -#include - -MODULE MOD_Vars_2DForcing -!----------------------------------------------------------------------- -! Meteorogical Forcing -! -! Created by Yongjiu Dai, 03/2014 -!----------------------------------------------------------------------- - - USE MOD_DataType - IMPLICIT NONE - SAVE - -!----------------------------------------------------------------------- - type(block_data_real8_2d) :: forc_xy_pco2m ! CO2 concentration in atmos. (pascals) - type(block_data_real8_2d) :: forc_xy_po2m ! O2 concentration in atmos. (pascals) - type(block_data_real8_2d) :: forc_xy_us ! wind in eastward direction [m/s] - type(block_data_real8_2d) :: forc_xy_vs ! wind in northward direction [m/s] - type(block_data_real8_2d) :: forc_xy_t ! temperature at reference height [kelvin] - type(block_data_real8_2d) :: forc_xy_q ! specific humidity at reference height [kg/kg] - type(block_data_real8_2d) :: forc_xy_prc ! convective precipitation [mm/s] - type(block_data_real8_2d) :: forc_xy_prl ! large scale precipitation [mm/s] - type(block_data_real8_2d) :: forc_xy_psrf ! atmospheric pressure at the surface [pa] - type(block_data_real8_2d) :: forc_xy_pbot ! atm bottom level pressure (or reference height) (pa) - type(block_data_real8_2d) :: forc_xy_sols ! atm vis direct beam solar rad onto srf [W/m2] - type(block_data_real8_2d) :: forc_xy_soll ! atm nir direct beam solar rad onto srf [W/m2] - type(block_data_real8_2d) :: forc_xy_solsd ! atm vis diffuse solar rad onto srf [W/m2] - type(block_data_real8_2d) :: forc_xy_solld ! atm nir diffuse solar rad onto srf [W/m2] - type(block_data_real8_2d) :: forc_xy_frl ! atmospheric infrared (longwave) radiation [W/m2] - type(block_data_real8_2d) :: forc_xy_hgt_u ! observational height of wind [m] - type(block_data_real8_2d) :: forc_xy_hgt_t ! observational height of temperature [m] - type(block_data_real8_2d) :: forc_xy_hgt_q ! observational height of humidity [m] - type(block_data_real8_2d) :: forc_xy_rhoair ! air density [kg/m3] - type(block_data_real8_2d) :: forc_xy_hpbl ! atmospheric boundary layer height [m] - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_2D_Forcing - -CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_2D_Forcing (grid) - ! ------------------------------------------------------------------- - ! Allocates memory for CoLM 2d [lon_points,lat_points] variables - ! ------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_DataType - IMPLICIT NONE - - type(grid_type), intent(in) :: grid - - IF (p_is_active) THEN - - CALL allocate_block_data (grid, forc_xy_pco2m ) ! CO2 concentration in atmos. (pascals) - CALL allocate_block_data (grid, forc_xy_po2m ) ! O2 concentration in atmos. (pascals) - CALL allocate_block_data (grid, forc_xy_us ) ! wind in eastward direction [m/s] - CALL allocate_block_data (grid, forc_xy_vs ) ! wind in northward direction [m/s] - CALL allocate_block_data (grid, forc_xy_t ) ! temperature at reference height [kelvin] - CALL allocate_block_data (grid, forc_xy_q ) ! specific humidity at reference height [kg/kg] - CALL allocate_block_data (grid, forc_xy_prc ) ! convective precipitation [mm/s] - CALL allocate_block_data (grid, forc_xy_prl ) ! large scale precipitation [mm/s] - CALL allocate_block_data (grid, forc_xy_psrf ) ! atmospheric pressure at the surface [pa] - CALL allocate_block_data (grid, forc_xy_pbot ) ! atm bottom level pressure (or reference height) (pa) - CALL allocate_block_data (grid, forc_xy_sols ) ! atm vis direct beam solar rad onto srf [W/m2] - CALL allocate_block_data (grid, forc_xy_soll ) ! atm nir direct beam solar rad onto srf [W/m2] - CALL allocate_block_data (grid, forc_xy_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] - CALL allocate_block_data (grid, forc_xy_solld ) ! atm nir diffuse solar rad onto srf [W/m2] - CALL allocate_block_data (grid, forc_xy_frl ) ! atmospheric infrared (longwave) radiation [W/m2] - CALL allocate_block_data (grid, forc_xy_hgt_u ) ! observational height of wind [m] - CALL allocate_block_data (grid, forc_xy_hgt_t ) ! observational height of temperature [m] - CALL allocate_block_data (grid, forc_xy_hgt_q ) ! observational height of humidity [m] - CALL allocate_block_data (grid, forc_xy_rhoair) ! air density [kg/m3] - CALL allocate_block_data (grid, forc_xy_hpbl ) ! atmospheric boundary layer height [m] - ENDIF - - END SUBROUTINE allocate_2D_Forcing - -END MODULE MOD_Vars_2DForcing -! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 index d7d7224079..7bd3609e3b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 @@ -49,13 +49,13 @@ SUBROUTINE allocate_PFTimeInvariants ! Allocates memory for CoLM PFT 1d [numpft] variables ! ------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch USE MOD_LandPFT, only: numpft USE MOD_Precision IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN allocate (pftclass (numpft)) allocate (pftfrac (numpft)) @@ -132,10 +132,10 @@ SUBROUTINE deallocate_PFTimeInvariants ! ------------------------------------------------------------------- ! Deallocates memory for CoLM PFT 1d [numpft] variables ! ------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN deallocate (pftclass) deallocate (pftfrac ) @@ -317,11 +317,11 @@ SUBROUTINE allocate_TimeInvariants () USE MOD_Precision USE MOD_Vars_Global - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -448,7 +448,7 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) !==================================================================== USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFVector USE MOD_NetCDFSerial #ifdef RangeCheck @@ -517,7 +517,7 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] #endif #ifdef DataAssimilation - IF (numpatch > 0 .and. p_is_compute) wf_silt = 1.0_r8 - wf_gravels - wf_sand - wf_clay - wf_om + IF (numpatch > 0 .and. .true.) wf_silt = 1.0_r8 - wf_gravels - wf_sand - wf_clay - wf_om #endif CALL ncio_read_vector (file_restart, 'soiltext', landpatch, soiltext, defval = 0 ) @@ -632,11 +632,12 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) CALL check_TimeInvariants () #endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant restart read completion') #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) 'Loading Time Invariants done.' ENDIF @@ -650,9 +651,10 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) !==================================================================== USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_BEDROCK - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFSerial USE MOD_NetCDFVector + USE MOD_Utils, only: make_directory USE MOD_LandPatch USE MOD_Vars_Global @@ -670,11 +672,12 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) write(cyear,'(i4.4)') lc_year - IF (p_is_root) THEN - CALL system('mkdir -p ' // trim(dir_restart)//'/const') + IF (mpas_is_root) THEN + CALL make_directory(trim(dir_restart)//'/const') ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant restart directory creation') #endif file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' @@ -800,11 +803,12 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant vector write completion') #endif - if (p_is_root) then + if (mpas_is_root) then #if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) CALL ncio_create_file (file_restart) @@ -830,8 +834,9 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant scalar write completion') #endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) @@ -854,7 +859,7 @@ END SUBROUTINE WRITE_TimeInvariants SUBROUTINE deallocate_TimeInvariants () USE MOD_Namelist, only: DEF_USE_Forcing_Downscaling, DEF_USE_Forcing_Downscaling_Simple - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE @@ -863,7 +868,7 @@ SUBROUTINE deallocate_TimeInvariants () ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -985,7 +990,7 @@ END SUBROUTINE deallocate_TimeInvariants #ifdef RangeCheck SUBROUTINE check_TimeInvariants () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_RangeCheck USE MOD_Namelist, only: DEF_Runoff_SCHEME, DEF_TOPMOD_method, DEF_USE_BEDROCK, & DEF_USE_Forcing_Downscaling, DEF_USE_Forcing_Downscaling_Simple @@ -994,12 +999,13 @@ SUBROUTINE check_TimeInvariants () real(r8), allocatable :: tmpcheck(:,:) - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(/,A29)') 'Checking Time Invariants ...' ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant range-check entry') #endif CALL check_vector_data ('lakedepth [m] ', lakedepth ) ! @@ -1103,11 +1109,12 @@ SUBROUTINE check_TimeInvariants () CALL check_vector_data ('cur [-] ', cur_patches ) ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant range-check completion') #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(/,A)') 'Checking Constants ...' write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 index 0b6d23dc00..ea56676520 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 @@ -95,12 +95,12 @@ SUBROUTINE allocate_PFTimeVariables () ! Allocates memory for CoLM 1d [numpft] variables !-------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN allocate (tleaf_p (numpft)) ; tleaf_p (:) = spval !leaf temperature [K] allocate (ldew_p (numpft)) ; ldew_p (:) = spval !depth of water on foliage [mm] @@ -303,10 +303,10 @@ SUBROUTINE deallocate_PFTimeVariables !-------------------------------------------------------------------- ! Deallocates memory for CoLM 1d [numpft/numpc] variables !-------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPFT - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpft > 0) THEN deallocate (tleaf_p ) ! leaf temperature [K] deallocate (ldew_p ) ! depth of water on foliage [mm] @@ -639,12 +639,12 @@ SUBROUTINE allocate_TimeVariables USE MOD_Precision USE MOD_Vars_Global - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -845,7 +845,7 @@ END SUBROUTINE allocate_TimeVariables SUBROUTINE deallocate_TimeVariables () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch, only: numpatch IMPLICIT NONE @@ -853,7 +853,7 @@ SUBROUTINE deallocate_TimeVariables () ! Deallocates memory for CoLM 1d [numpatch] variables !-------------------------------------------------------------------- - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN @@ -1091,11 +1091,12 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 !==================================================================== - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & DEF_USE_IRRIGATION, DEF_USE_Dynamic_Lake, SITE_landtype - USE MOD_LandPatch - USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Utils, only: make_directory USE MOD_Vars_Global USE MOD_Vars_TimeInvariants, only: dz_lake USE MOD_Const_LC, only: patchtypes @@ -1107,7 +1108,13 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) character(len=*), intent(in) :: dir_restart ! Local variables - character(len=256) :: file_restart + character(len=256) :: file_restart + character(len=256) :: file_restart_vector +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef MPAS_EMBEDDED_COLM + character(len=256) :: file_restart_pft +#endif +#endif character(len=14) :: cdate character(len=256) :: cyear !character for lc_year integer :: compress @@ -1118,14 +1125,24 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) write(cyear,'(i4.4)') lc_year write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - IF (p_is_root) THEN - CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) + IF (mpas_is_root) THEN + CALL make_directory(trim(dir_restart)//'/'//trim(cdate)) ENDIF -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable restart directory creation') #endif file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart_vector = file_restart + CALL ncio_begin_distributed_write(file_restart_vector) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef MPAS_EMBEDDED_COLM + file_restart_pft = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'// & + trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL ncio_begin_distributed_write(file_restart_pft) +#endif +#endif #ifdef MPAS_EMBEDDED_COLM IF (numpatch > 0) THEN @@ -1266,11 +1283,19 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) #ifdef SinglePoint IF (patchtypes(SITE_landtype) == 0) THEN +#ifdef MPAS_EMBEDDED_COLM + file_restart = file_restart_pft +#else file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#endif CALL WRITE_PFTimeVariables (file_restart) ENDIF +#else +#ifdef MPAS_EMBEDDED_COLM + file_restart = file_restart_pft #else file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#endif CALL WRITE_PFTimeVariables (file_restart) #endif #endif @@ -1300,6 +1325,9 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) #ifdef MPAS_EMBEDDED_COLM ENDIF +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL ncio_complete_distributed_write(file_restart_pft) +#endif #endif #ifdef GridRiverLakeFlow @@ -1307,17 +1335,19 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) CALL WRITE_GridRiverLakeTimeVars (file_restart) #endif + CALL ncio_complete_distributed_write(file_restart_vector) + END SUBROUTINE WRITE_TimeVariables - SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) + SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart, require_complete_restart) !==================================================================== ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 !==================================================================== USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_NetCDFVector #ifdef RangeCheck USE MOD_RangeCheck @@ -1333,16 +1363,22 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) integer, intent(in) :: lc_year !year of land cover type data character(len=*), intent(in) :: site character(len=*), intent(in) :: dir_restart + logical, intent(in) :: require_complete_restart ! Local variables character(len=256) :: file_restart character(len=14) :: cdate, cyear +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + logical :: marker_exists +#endif -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable restart read entry') #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) 'Loading Time Variables ...' ENDIF @@ -1352,6 +1388,16 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#ifdef MPAS_EMBEDDED_COLM + IF (require_complete_restart) THEN + complete_marker = trim(file_restart)//'.mpas_complete' + inquire(file=trim(complete_marker), exist=marker_exists) + IF (.not. marker_exists) THEN + CALL CoLM_stop('MPAS restart requires a completed CoLM patch checkpoint: '//trim(complete_marker)) + ENDIF + ENDIF +#endif + #ifdef MPAS_EMBEDDED_COLM IF (numpatch > 0) THEN #endif @@ -1478,6 +1524,15 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) ENDIF #else file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#ifdef MPAS_EMBEDDED_COLM + IF (require_complete_restart) THEN + complete_marker = trim(file_restart)//'.mpas_complete' + inquire(file=trim(complete_marker), exist=marker_exists) + IF (.not. marker_exists) THEN + CALL CoLM_stop('MPAS restart requires a completed CoLM PFT checkpoint: '//trim(complete_marker)) + ENDIF + ENDIF +#endif CALL READ_PFTimeVariables (file_restart) #endif #endif @@ -1498,7 +1553,7 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) #ifdef GridRiverLakeFlow file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL READ_GridRiverLakeTimeVars (file_restart) + CALL READ_GridRiverLakeTimeVars (file_restart, require_complete_restart) #endif #ifdef MPAS_EMBEDDED_COLM @@ -1526,7 +1581,7 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) ENDIF #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) 'Loading Time Variables done.' ENDIF @@ -1536,7 +1591,7 @@ END SUBROUTINE READ_TimeVariables #ifdef RangeCheck SUBROUTINE check_TimeVariables () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_RangeCheck USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & DEF_USE_SNICAR, DEF_USE_Dynamic_Lake @@ -1544,10 +1599,11 @@ SUBROUTINE check_TimeVariables () IMPLICIT NONE -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable range-check entry') #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(/,A27)') 'Checking Time Variables ...' ENDIF @@ -1667,8 +1723,9 @@ SUBROUTINE check_TimeVariables () IF (DEF_DA_ENS_NUM > 1) CALL check_DATimeVariables #endif -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable range-check completion') #endif END SUBROUTINE check_TimeVariables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 index ea31551991..e844ffea95 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 @@ -20,7 +20,7 @@ SUBROUTINE vicpara_readin () USE MOD_Precision USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch USE MOD_NetCDFSerial USE MOD_NetCDFBlock @@ -74,14 +74,14 @@ SUBROUTINE vicpara_readin () CALL grid_Ds%define_by_center (lat, lon) CALL grid_DsM%define_by_center (lat, lon) - IF (p_is_active) THEN + IF (.true.) THEN CALL allocate_block_data (grid_b_infilt, f_xy_b_infilt) CALL allocate_block_data (grid_Ws, f_xy_Ws) CALL allocate_block_data (grid_Ds, f_xy_Ds) CALL allocate_block_data (grid_DsM, f_xy_DsM) ENDIF - IF (p_is_active) THEN + IF (.true.) THEN CALL ncio_read_block (file_vic_para,'b', grid_b_infilt, f_xy_b_infilt) CALL ncio_read_block (file_vic_para,'Ws', grid_Ws, f_xy_Ws) CALL ncio_read_block (file_vic_para,'Ds', grid_Ds, f_xy_Ds) @@ -98,7 +98,7 @@ SUBROUTINE vicpara_readin () IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) allocate (b_infilt_tmp (numpatch)) IF (numpatch > 0) allocate (Ws_tmp (numpatch)) IF (numpatch > 0) allocate (Ds_tmp (numpatch)) @@ -110,7 +110,7 @@ SUBROUTINE vicpara_readin () CALL mg2patch_Ds%grid2pset (f_xy_Ds, Ds_tmp(:)) CALL mg2patch_DsM%grid2pset (f_xy_DsM, DsM_tmp(:)) - IF (p_is_compute) THEN + IF (.true.) THEN vic_b_infilt(:) = -9999 vic_Dsmax(:) = -9999 vic_Ds(:) = -9999 @@ -118,7 +118,7 @@ SUBROUTINE vicpara_readin () vic_c = 2 ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN DO ipft = 1, numpatch !WRITE(*,*) 'Values of vic_b_infilt: ', DsM_tmp(ipft) vic_b_infilt(ipft) = b_infilt_tmp(ipft) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 index a1d8c4b3d4..4d11fdb97d 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 @@ -3,7 +3,7 @@ MODULE MOD_Opt_Baseflow USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -24,6 +24,8 @@ SUBROUTINE Opt_Baseflow_init () USE MOD_NetCDFVector USE MOD_Vars_TimeVariables, only: zwt USE MOD_LandPatch, only: numpatch, landpatch + USE MOD_Utils, only: make_directory + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE ! Local Variables @@ -32,17 +34,24 @@ SUBROUTINE Opt_Baseflow_init () file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' CALL ncio_read_vector (file_restart, 'scale_baseflow', landpatch, scale_baseflow, defval = 1.) - - IF (p_is_root) THEN - CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt') - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + IF (numpatch > 0) THEN + IF (.not. allocated(scale_baseflow) .or. size(scale_baseflow) /= numpatch) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale does not match the local patch decomposition.') + ENDIF + IF (.not. all(ieee_is_finite(scale_baseflow)) .or. any(scale_baseflow <= 0._r8)) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale must contain finite positive values.') + ENDIF + ENDIF + + IF (mpas_is_root) CALL make_directory(trim(DEF_dir_restart)//'/ParaOpt') +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('baseflow-scale initialization') #endif IF (DEF_Optimize_Baseflow) THEN - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN allocate (zwt_init (numpatch)); zwt_init (:) = zwt allocate (rchg_year (numpatch)); rchg_year (:) = spval @@ -66,6 +75,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) USE MOD_Vars_1DForcing, only: forc_prc, forc_prl USE MOD_Vars_1DFluxes, only: fevpa, rsur, rsub USE MOD_LandPatch, only: numpatch, landpatch + USE MOD_Utils, only: make_directory IMPLICIT NONE integer, intent(in) :: idate(3) @@ -80,7 +90,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) IF (DEF_Optimize_Baseflow .and. is_spinup) THEN - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN allocate (recharge(numpatch)); recharge(:) = spval @@ -102,11 +112,9 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) iter_bf_opt = iter_bf_opt + 1 write(strcyc,'(A1,I4.4)') 'c', iter_bf_opt - IF (p_is_root) THEN - CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt/'//strcyc) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + IF (mpas_is_root) CALL make_directory(trim(DEF_dir_restart)//'/ParaOpt/'//strcyc) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) #endif file_restart = trim(DEF_dir_restart)//'/ParaOpt/'//strcyc//'/'//trim(DEF_CASE_NAME)//'_baseflow.nc' CALL ncio_create_file_vector (file_restart, landpatch) @@ -117,7 +125,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) CALL ncio_write_vector (file_restart, 'total_recharge', 'patch', landpatch, rchg_year, 1) CALL ncio_write_vector (file_restart, 'total_subsurface_runoff', 'patch', landpatch, rsub_year, 1) - IF (p_is_compute) THEN + IF (.true.) THEN DO ipatch = 1, numpatch IF (patchtype(ipatch) <= 1) THEN @@ -148,7 +156,7 @@ SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') CALL ncio_write_vector (file_restart, 'scale_baseflow', 'patch', landpatch, scale_baseflow, 1) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numpatch > 0) THEN rchg_year(:) = spval rsub_year(:) = spval diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 index c8e307d36d..d9e6503427 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 @@ -44,7 +44,7 @@ MODULE MOD_Urban_Flux ! !----------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist, only: DEF_RSS_SCHEME, DEF_VEG_SNOW USE MOD_Vars_Global USE MOD_Qsadv, only: qsadv @@ -113,7 +113,7 @@ SUBROUTINE UrbanOnlyFlux ( & USE MOD_Const_Physical, only: cpair,vonkar,grav,hvap USE MOD_FrictionVelocity USE MOD_CanopyLayerProfile - USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + USE MOD_Vars_1DForcing, only: forc_height_mode IMPLICIT NONE !-------------------------- Dummy Arguments ---------------------------- @@ -514,7 +514,7 @@ SUBROUTINE UrbanOnlyFlux ( & hu_ = hu; ht_ = ht; hq_ = hq; - IF (trim(HEIGHT_mode) == 'absolute') THEN + IF (forc_height_mode == 'absolute') THEN IF (hu <= hroof+1) THEN hu_ = hroof + 1. @@ -544,7 +544,7 @@ SUBROUTINE UrbanOnlyFlux ( & IF (zldis <= 0.0) THEN write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort + CALL CoLM_stop('UrbanOnlyFlux received a reference height below displacement height.') ENDIF CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) @@ -918,7 +918,7 @@ SUBROUTINE UrbanVegFlux ( & USE MOD_FrictionVelocity USE MOD_CanopyLayerProfile USE MOD_AssimStomataConductance - USE MOD_UserSpecifiedForcing, only: HEIGHT_mode + USE MOD_Vars_1DForcing, only: forc_height_mode IMPLICIT NONE !-------------------------- Dummy Arguments ---------------------------- @@ -1526,7 +1526,7 @@ SUBROUTINE UrbanVegFlux ( & hu_ = hu; ht_ = ht; hq_ = hq; - IF (trim(HEIGHT_mode) == 'absolute') THEN + IF (forc_height_mode == 'absolute') THEN IF (hu <= hroof+1) THEN hu_ = hroof + 1. @@ -1556,7 +1556,7 @@ SUBROUTINE UrbanVegFlux ( & IF (zldis <= 0.0) THEN write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort + CALL CoLM_stop('UrbanVegFlux received a reference height below displacement height.') ENDIF CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 index 3b1de1a0b7..1863d32c8f 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 @@ -27,7 +27,7 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) USE MOD_Precision USE MOD_Namelist - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban USE MOD_Vars_Global USE MOD_Const_LC @@ -66,7 +66,7 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) CALL ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) #endif ! loop for urban patch to assign fraction of green leaf - IF (p_is_compute) THEN + IF (.true.) THEN DO u = 1, numurban npatch = urban2patch(u) tlai(npatch) = urb_lai(u) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 index 1a8628a5bf..2b331f176e 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 @@ -6,7 +6,7 @@ MODULE MOD_Urban_Shortwave USE MOD_LandUrban USE MOD_Vars_Global USE MOD_3DCanopyRadiation, only: tee, phi - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE SAVE diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 index cfd72215e4..3a5f772250 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 @@ -108,7 +108,7 @@ SUBROUTINE UrbanTHERMAL ( & USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& stefnc,denice,tfrz,vonkar,grav diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 index 3e20a7c3c4..530c064fe4 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 @@ -55,12 +55,12 @@ SUBROUTINE allocate_1D_UrbanFluxes ! -------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban USE MOD_Vars_Global, only: spval IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN !allocate (sabroof (numurban)) !allocate (sabwsun (numurban)) @@ -87,10 +87,10 @@ SUBROUTINE deallocate_1D_UrbanFluxes ! -------------------------------------------------------------------- ! deallocates memory for CLM 1d [numurban] variables ! -------------------------------------------------------------------- - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN !deallocate (sabroof ) @@ -121,13 +121,13 @@ SUBROUTINE set_1D_UrbanFluxes(Values, Nan) ! -------------------------------------------------------------------- USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban IMPLICIT NONE real(r8),intent(in) :: Values real(r8),intent(in) :: Nan - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN !sabroof (:) = Values !sabwsun (:) = Values diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 index bded9f3f79..5a12ab339c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 @@ -88,12 +88,12 @@ SUBROUTINE allocate_UrbanTimeInvariants () ! Allocates memory for CLM 1d [numurban] variants ! ------------------------------------------------------ USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN allocate (fveg_urb (numurban)) allocate (htop_urb (numurban)) @@ -283,12 +283,12 @@ END SUBROUTINE WRITE_UrbanTimeInvariants SUBROUTINE deallocate_UrbanTimeInvariants - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban ! deallocate (urbclass ) - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN deallocate (fveg_urb ) deallocate (htop_urb ) diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 index 31234bb8c5..29a433f9e2 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 @@ -123,12 +123,12 @@ SUBROUTINE allocate_UrbanTimeVariables () ! Allocates memory for CLM 1d [numurban] variables ! ------------------------------------------------------ USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban USE MOD_Vars_Global IMPLICIT NONE - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN allocate (fwsun (numurban)) allocate (dfwsun (numurban)) @@ -412,10 +412,10 @@ END SUBROUTINE WRITE_UrbanTimeVariables SUBROUTINE deallocate_UrbanTimeVariables - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandUrban - IF (p_is_compute) THEN + IF (.true.) THEN IF (numurban > 0) THEN deallocate (fwsun ) deallocate (dfwsun ) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 index 4a120a37e1..836a1bca58 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 @@ -119,7 +119,7 @@ END SUBROUTINE this_block_and_move_to_next ! ----- SUBROUTINE read_5x5_data_int32 (dir_5x5, sfx, grid, dataname, rdata) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Grid USE MOD_DataType @@ -148,7 +148,7 @@ SUBROUTINE read_5x5_data_int32 (dir_5x5, sfx, grid, dataname, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_active) THEN + IF (.true.) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -204,7 +204,7 @@ END SUBROUTINE read_5x5_data_int32 SUBROUTINE read_5x5_data_real8 (dir_5x5, sfx, grid, dataname, rdata) USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Grid USE MOD_DataType @@ -233,7 +233,7 @@ SUBROUTINE read_5x5_data_real8 (dir_5x5, sfx, grid, dataname, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_active) THEN + IF (.true.) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -289,7 +289,7 @@ END SUBROUTINE read_5x5_data_real8 SUBROUTINE read_5x5_data_pft (dir_5x5, sfx, grid, dataname, rdata) USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Grid USE MOD_DataType @@ -319,7 +319,7 @@ SUBROUTINE read_5x5_data_pft (dir_5x5, sfx, grid, dataname, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_active) THEN + IF (.true.) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -378,7 +378,7 @@ END SUBROUTINE read_5x5_data_pft SUBROUTINE read_5x5_data_time (dir_5x5, sfx, grid, dataname, time, rdata) USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Grid USE MOD_DataType @@ -408,7 +408,7 @@ SUBROUTINE read_5x5_data_time (dir_5x5, sfx, grid, dataname, time, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_active) THEN + IF (.true.) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) @@ -465,7 +465,7 @@ END SUBROUTINE read_5x5_data_time SUBROUTINE read_5x5_data_pft_time (dir_5x5, sfx, grid, dataname, time, rdata) USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Grid USE MOD_DataType @@ -496,7 +496,7 @@ SUBROUTINE read_5x5_data_pft_time (dir_5x5, sfx, grid, dataname, time, rdata) nxbox = nxglb / 360 * 5 nybox = nyglb / 180 * 5 - IF (p_is_active) THEN + IF (.true.) THEN DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 deleted file mode 100644 index c4517c21cc..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90 +++ /dev/null @@ -1,709 +0,0 @@ -#include - -MODULE MOD_AggregationRequestData - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Aggregation Utilities. -! -! On IO ranks, a data daemon is running to provide data -! at fine resolutions for rank processes. -! On rank processes, request is sent to IO ranks and -! data is returned from IO ranks. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - IMPLICIT NONE - - PUBLIC :: aggregation_request_data - -#ifdef USEMPI - PUBLIC :: aggregation_data_daemon - PUBLIC :: aggregation_compute_done -#endif - -! ---- subroutines ---- -CONTAINS - -#ifdef USEMPI - SUBROUTINE aggregation_data_daemon (grid_in, & - data_r8_2d_in1, data_r8_2d_in2, data_r8_2d_in3, data_r8_2d_in4, & - data_r8_2d_in5, data_r8_2d_in6, & - data_r8_3d_in1, n1_r8_3d_in1 , data_r8_3d_in2, n1_r8_3d_in2, & - data_i4_2d_in1, data_i4_2d_in2) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_DataType - - IMPLICIT NONE - - type (grid_type), intent(in) :: grid_in - - ! 2D REAL data - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in1 - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in2 - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in3 - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in4 - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in5 - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in6 - - ! 3D REAL data - integer, intent(in), optional :: n1_r8_3d_in1 - type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in1 - - integer, intent(in), optional :: n1_r8_3d_in2 - type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in2 - - ! 2D INTEGER data - type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in1 - type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in2 - - ! Local Variables - integer :: nreq, ireq, rmesg(2), isrc, idest - integer :: xblk, yblk, xloc, yloc - integer, allocatable :: ylist(:), xlist(:) - - real(r8), allocatable :: sbuf_r8_1d(:), sbuf_r8_2d(:,:) - integer , allocatable :: sbuf_i4_1d(:) - - logical, allocatable :: compute_done (:) - -#ifdef MPAS_EMBEDDED_COLM - RETURN -#endif - - IF (p_is_active) THEN - - allocate (compute_done (0:p_np_compute-1)) - - compute_done(:) = .false. - DO WHILE (any(.not. compute_done)) - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nreq = rmesg(2) - - IF (nreq > 0) THEN - - allocate (xlist (nreq)) - allocate (ylist (nreq)) - - CALL mpi_recv (xlist, nreq, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (ylist, nreq, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - idest = isrc - - allocate (sbuf_r8_1d (nreq)) - - IF (present(data_r8_2d_in1)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_1d(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - IF (present(data_r8_2d_in2)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_1d(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - IF (present(data_r8_2d_in3)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_1d(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - IF (present(data_r8_2d_in4)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_1d(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - IF (present(data_r8_2d_in5)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_1d(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - IF (present(data_r8_2d_in6)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_1d(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - - deallocate (sbuf_r8_1d) - - IF (present(data_r8_3d_in1) .and. present(n1_r8_3d_in1)) THEN - - allocate (sbuf_r8_2d (n1_r8_3d_in1,nreq)) - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_2d(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_2d, n1_r8_3d_in1*nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (sbuf_r8_2d) - ENDIF - - IF (present(data_r8_3d_in2) .and. present(n1_r8_3d_in2)) THEN - - allocate (sbuf_r8_2d (n1_r8_3d_in2,nreq)) - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_r8_2d(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_r8_2d, n1_r8_3d_in2*nreq, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (sbuf_r8_2d) - ENDIF - - allocate (sbuf_i4_1d (nreq)) - - IF (present(data_i4_2d_in1)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_i4_1d(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_i4_1d, nreq, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - IF (present(data_i4_2d_in2)) THEN - DO ireq = 1, nreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - sbuf_i4_1d(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc) - ENDDO - - CALL mpi_send (sbuf_i4_1d, nreq, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - - deallocate (sbuf_i4_1d) - - deallocate (ylist) - deallocate (xlist) - - ELSE - compute_done(p_itis_compute(isrc)) = .true. - ENDIF - - ENDDO - - deallocate (compute_done) - - ENDIF - - END SUBROUTINE aggregation_data_daemon - -#endif - - !---------------------------------------------------- - SUBROUTINE aggregation_request_data ( & - pixelset, iset, grid_in, zip, area, & - data_r8_2d_in1, data_r8_2d_out1, & - data_r8_2d_in2, data_r8_2d_out2, & - data_r8_2d_in3, data_r8_2d_out3, & - data_r8_2d_in4, data_r8_2d_out4, & - data_r8_2d_in5, data_r8_2d_out5, & - data_r8_2d_in6, data_r8_2d_out6, & - data_r8_3d_in1, data_r8_3d_out1, n1_r8_3d_in1, lb1_r8_3d_in1, & - data_r8_3d_in2, data_r8_3d_out2, n1_r8_3d_in2, lb1_r8_3d_in2, & - data_i4_2d_in1, data_i4_2d_out1, & - data_i4_2d_in2, data_i4_2d_out2, & - filledvalue_i4) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Pixel - USE MOD_Grid - USE MOD_DataType - USE MOD_Mesh - USE MOD_Pixelset - USE MOD_Utils - - IMPLICIT NONE - - type (pixelset_type), intent(in) :: pixelset - integer, intent(in) :: iset - - type (grid_type), intent(in) :: grid_in - logical, intent(in) :: zip - - real(r8), allocatable, intent(out), optional :: area(:) - - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in1 - real(r8), allocatable, intent(out), optional :: data_r8_2d_out1 (:) - - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in2 - real(r8), allocatable, intent(out), optional :: data_r8_2d_out2 (:) - - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in3 - real(r8), allocatable, intent(out), optional :: data_r8_2d_out3 (:) - - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in4 - real(r8), allocatable, intent(out), optional :: data_r8_2d_out4 (:) - - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in5 - real(r8), allocatable, intent(out), optional :: data_r8_2d_out5 (:) - - type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in6 - real(r8), allocatable, intent(out), optional :: data_r8_2d_out6 (:) - - integer, intent(in), optional :: n1_r8_3d_in1, lb1_r8_3d_in1 - type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in1 - real(r8), allocatable, intent(out), optional :: data_r8_3d_out1 (:,:) - - integer, intent(in), optional :: n1_r8_3d_in2, lb1_r8_3d_in2 - type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in2 - real(r8), allocatable, intent(out), optional :: data_r8_3d_out2 (:,:) - - type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in1 - integer, allocatable, intent(out), optional :: data_i4_2d_out1 (:) - - type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in2 - integer, allocatable, intent(out), optional :: data_i4_2d_out2 (:) - - integer, intent(in), optional :: filledvalue_i4 - - ! Local Variables - integer :: totalreq, ireq, nreq, smesg(2), isrc, idest, iproc - integer :: ilon, ilat, xblk, yblk, xloc, yloc, iloc, nx, ny, ix, iy, ig - integer :: ie, ipxstt, ipxend, npxl, ipxl, lb1, xgrdthis, ygrdthis - integer, allocatable :: ylist(:), xlist(:), ipt(:), ibuf(:), rbuf_i4_1d(:) - integer, allocatable :: xsorted(:), ysorted(:), xy2d(:,:) - real(r8), allocatable :: area2d(:,:), rbuf_r8_1d(:), rbuf_r8_2d(:,:) - logical, allocatable :: msk(:) - - - ie = pixelset%ielm (iset) - ipxstt = pixelset%ipxstt(iset) - ipxend = pixelset%ipxend(iset) - npxl = ipxend - ipxstt + 1 - - IF (zip) THEN - - allocate (xsorted(npxl)) - allocate (ysorted(npxl)) - - nx = 0; ny = 0 - DO ipxl = ipxstt, ipxend - xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl)) - ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl)) - CALL insert_into_sorted_list1 (xgrdthis, nx, xsorted, iloc) - CALL insert_into_sorted_list1 (ygrdthis, ny, ysorted, iloc) - ENDDO - - allocate (xy2d (nx,ny)); xy2d(:,:) = 0 - - IF (present(area)) THEN - allocate(area2d(nx,ny)); area2d(:,:) = 0. - ENDIF - - DO ipxl = ipxstt, ipxend - xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl)) - ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl)) - - ix = find_in_sorted_list1(xgrdthis, nx, xsorted) - iy = find_in_sorted_list1(ygrdthis, ny, ysorted) - - xy2d(ix,iy) = xy2d(ix,iy) + 1 - - IF (present(area)) THEN - area2d(ix,iy) = area2d(ix,iy) + areaquad (& - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) - ENDIF - ENDDO - - totalreq = count(xy2d > 0) - - allocate (xlist (totalreq)) - allocate (ylist (totalreq)) - - IF (present(area)) allocate(area(totalreq)) - - ig = 0 - DO ix = 1, nx - DO iy = 1, ny - IF (xy2d(ix,iy) > 0) THEN - ig = ig + 1 - xlist(ig) = xsorted(ix) - ylist(ig) = ysorted(iy) - IF (present(area)) area (ig) = area2d(ix,iy) - ENDIF - ENDDO - ENDDO - - deallocate (xsorted, ysorted, xy2d) - IF (present(area)) deallocate (area2d) - - ELSE - - allocate(xlist (npxl)) - allocate(ylist (npxl)) - - IF (present(area)) allocate (area (npxl)) - - totalreq = npxl - DO ipxl = ipxstt, ipxend - xlist(ipxl-ipxstt+1) = grid_in%xgrd(mesh(ie)%ilon(ipxl)) - ylist(ipxl-ipxstt+1) = grid_in%ygrd(mesh(ie)%ilat(ipxl)) - IF (present(area)) THEN - area(ipxl-ipxstt+1) = areaquad (& - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) - ENDIF - ENDDO - - ENDIF - - IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) allocate (data_r8_2d_out1 (totalreq)) - IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) allocate (data_r8_2d_out2 (totalreq)) - IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) allocate (data_r8_2d_out3 (totalreq)) - IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) allocate (data_r8_2d_out4 (totalreq)) - IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) allocate (data_r8_2d_out5 (totalreq)) - IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) allocate (data_r8_2d_out6 (totalreq)) - - IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN - IF (present(lb1_r8_3d_in1)) THEN - lb1 = lb1_r8_3d_in1 - ELSE - lb1 = 1 - ENDIF - allocate (data_r8_3d_out1 (lb1:lb1-1+n1_r8_3d_in1,totalreq)) - ENDIF - - IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN - IF (present(lb1_r8_3d_in2)) THEN - lb1 = lb1_r8_3d_in2 - ELSE - lb1 = 1 - ENDIF - allocate (data_r8_3d_out2 (lb1:lb1-1+n1_r8_3d_in2,totalreq)) - ENDIF - - IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN - allocate (data_i4_2d_out1 (totalreq)) - IF (present(filledvalue_i4)) THEN - data_i4_2d_out1 = filledvalue_i4 - ENDIF - ENDIF - - IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN - allocate (data_i4_2d_out2 (totalreq)) - IF (present(filledvalue_i4)) THEN - data_i4_2d_out2 = filledvalue_i4 - ENDIF - ENDIF - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - - allocate (ipt (totalreq)) - allocate (msk (totalreq)) - - ipt(:) = -1 - - DO ireq = 1, totalreq - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - ipt(ireq) = gblock%pio(xblk,yblk) - ENDDO - - DO iproc = 0, p_np_active-1 - msk = (ipt == p_address_active(iproc)) - nreq = count(msk) - - IF (nreq > 0) THEN - - smesg = (/p_iam_glb, nreq/) - idest = p_address_active(iproc) - CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) - - allocate (ibuf (nreq)) - - ibuf = pack(xlist(1:totalreq), msk) - CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - ibuf = pack(ylist(1:totalreq), msk) - CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - - isrc = idest - - allocate (rbuf_r8_1d (nreq)) - - IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN - CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out1) - ENDIF - - IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN - CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out2) - ENDIF - - IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN - CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out3) - ENDIF - - IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN - CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out4) - ENDIF - - IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN - CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out5) - ENDIF - - IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN - CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out6) - ENDIF - - deallocate (rbuf_r8_1d) - - IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN - allocate (rbuf_r8_2d (n1_r8_3d_in1,nreq)) - CALL mpi_recv (rbuf_r8_2d, n1_r8_3d_in1*nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_2d, msk, data_r8_3d_out1) - deallocate (rbuf_r8_2d) - ENDIF - - IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN - allocate (rbuf_r8_2d (n1_r8_3d_in2,nreq)) - CALL mpi_recv (rbuf_r8_2d, n1_r8_3d_in2*nreq, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_r8_2d, msk, data_r8_3d_out2) - deallocate (rbuf_r8_2d) - ENDIF - - allocate (rbuf_i4_1d (nreq)) - IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN - CALL mpi_recv (rbuf_i4_1d, nreq, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_i4_1d, msk, data_i4_2d_out1) - ENDIF - - IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN - CALL mpi_recv (rbuf_i4_1d, nreq, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL unpack_inplace (rbuf_i4_1d, msk, data_i4_2d_out2) - ENDIF - - deallocate (rbuf_i4_1d) - - deallocate (ibuf) - ENDIF - ENDDO - - deallocate (xlist) - deallocate (ylist) - deallocate (ipt ) - deallocate (msk ) - -#else - - DO ireq = 1, totalreq - - xblk = grid_in%xblk(xlist(ireq)) - yblk = grid_in%yblk(ylist(ireq)) - xloc = grid_in%xloc(xlist(ireq)) - yloc = grid_in%yloc(ylist(ireq)) - - IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN - data_r8_2d_out1(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN - data_r8_2d_out2(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN - data_r8_2d_out3(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN - data_r8_2d_out4(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN - data_r8_2d_out5(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN - data_r8_2d_out6(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN - data_r8_3d_out1(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc) - ENDIF - - IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN - data_r8_3d_out2(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc) - ENDIF - - IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN - data_i4_2d_out1(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN - data_i4_2d_out2(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc) - ENDIF - - ENDDO - -#endif - - END SUBROUTINE aggregation_request_data - -#ifdef USEMPI - - SUBROUTINE aggregation_compute_done () - - USE MOD_SPMD_Task - - IMPLICIT NONE - - integer :: smesg(2), iproc, idest - -#ifdef MPAS_EMBEDDED_COLM - RETURN -#endif - - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 - smesg = (/p_iam_glb, -1/) - idest = p_address_active(iproc) - CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) - ENDDO - ENDIF - - END SUBROUTINE aggregation_compute_done - -#endif - - - SUBROUTINE fillnan (vec, fill, defval) - - USE MOD_Precision - USE MOD_UserDefFun, only: isnan_ud - IMPLICIT NONE - - real(r8), intent(inout) :: vec(:) - logical, intent(in) :: fill - real(r8), intent(in) :: defval - - ! local variables - integer :: i, n - real(r8) :: s - - n = 0 - s = 0. - DO i = lbound(vec,1), ubound(vec,1) - IF (.not. isnan_ud(vec(i))) THEN - n = n + 1 - s = s + vec(i) - ENDIF - ENDDO - - IF ((n > 0) .and. (n < size(vec))) THEN - s = s/n - DO i = lbound(vec,1), ubound(vec,1) - IF (isnan_ud(vec(i))) vec(i) = s - ENDDO - ENDIF - - IF ((n == 0) .and. fill) THEN - vec(:) = defval - ENDIF - - END SUBROUTINE fillnan - -END MODULE MOD_AggregationRequestData diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 index e46580e731..5fc4504872 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 @@ -28,17 +28,12 @@ MODULE MOD_Block ! "gblock%lat_s(j), gblock%lat_n(j), gblock%lon_w(i), gblock%lon_e(i)" ! for south, north, west and east boundaries respectively. ! -! 2. -! The (i,j) element of 2D array gblock%pio saves the global communication -! number of process which is in charge of Input/Output of block (i,j). +! 2. In embedded mode, owner_rank(i,j) records whether this MPAS rank owns +! cells whose CoLM elements are stored in block (i,j). A value of -1 means +! that the block is not part of this rank's local cell subset. ! -! 3. -! For Input/Output processes, "gblock%nblkme, gblock%xblkme(:), gblock%yblkme(:)" -! SAVE the locations of blocks which are handled by themselves. -! -! 4. -! Division of blocks can be generated by number of blocks globally (by set_by_size), -! or set by predefined boundaries in files (by set_by_file). +! 3. "gblock%nblkme, gblock%xblkme(:), gblock%yblkme(:)" contain the local +! block list derived from MPAS cell ownership. ! ! Created by Shupeng Zhang, May 2023 !------------------------------------------------------------------------------------- @@ -56,23 +51,15 @@ MODULE MOD_Block real(r8), allocatable :: lon_w (:) real(r8), allocatable :: lon_e (:) - ! IO. - integer, allocatable :: pio(:,:) + integer, allocatable :: owner_rank(:,:) integer :: nblkme integer, allocatable :: xblkme(:), yblkme(:) CONTAINS - procedure, PUBLIC :: set => block_set - - procedure, PUBLIC :: save_to_file => block_save_to_file procedure, PUBLIC :: load_from_file => block_load_from_file - procedure, PRIVATE :: clip => block_clip - procedure, PRIVATE :: init_pio => block_init_pio - procedure, PRIVATE :: read_pio => block_read_pio - final :: block_free_mem END type block_type @@ -86,147 +73,12 @@ MODULE MOD_Block CONTAINS - ! -------------------------------- - SUBROUTINE block_set (this) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_Utils - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - IMPLICIT NONE - - class (block_type) :: this - - ! Local Variables - logical :: fexists - integer :: iblk, jblk - - inquire(file=trim(DEF_BlockInfoFile), exist=fexists) - - IF (fexists) THEN - - CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lat_s', this%lat_s) - CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lat_n', this%lat_n) - CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lon_w', this%lon_w) - CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lon_e', this%lon_e) - - this%nyblk = size(this%lat_s) - this%nxblk = size(this%lon_w) - - ! blocks should be from south to north - IF (this%lat_s(1) > this%lat_s(this%nyblk)) THEN - this%lat_s = this%lat_s(this%nyblk:1:-1) - this%lat_n = this%lat_n(this%nyblk:1:-1) - ENDIF - - ELSE - - IF (DEF_AverageElementSize > 0) THEN - - this%nxblk = floor(360./(DEF_AverageElementSize/120.*50)) - this%nxblk = min(this%nxblk,360) - DO WHILE ((this%nxblk < 360) .and. (mod(360,this%nxblk) /= 0)) - this%nxblk = this%nxblk + 1 - ENDDO - - this%nyblk = floor(180./(DEF_AverageElementSize/120.*50)) - this%nyblk = min(this%nyblk,180) - DO WHILE ((this%nyblk < 180) .and. (mod(180,this%nyblk) /= 0)) - this%nyblk = this%nyblk + 1 - ENDDO - - ELSE - - this%nxblk = DEF_nx_blocks - this%nyblk = DEf_ny_blocks - - ENDIF - - IF ((mod(360,this%nxblk) /= 0) .or. (mod(180,this%nyblk) /= 0)) THEN - IF (p_is_root) THEN - write(*,*) 'Number of blocks in longitude should be a factor of 360 ' - write(*,*) ' and Number of blocks in latitude should be a factor of 180.' - CALL CoLM_stop () - ENDIF - ENDIF - - allocate (this%lon_w (this%nxblk)) - allocate (this%lon_e (this%nxblk)) - - DO iblk = 1, this%nxblk - this%lon_w(iblk) = -180.0 + 360.0/this%nxblk * (iblk-1) - this%lon_e(iblk) = -180.0 + 360.0/this%nxblk * iblk - - CALL normalize_longitude (this%lon_w(iblk)) - CALL normalize_longitude (this%lon_e(iblk)) - ENDDO - - allocate (this%lat_s (this%nyblk)) - allocate (this%lat_n (this%nyblk)) - - DO jblk = 1, this%nyblk - this%lat_s(jblk) = -90.0 + 180.0/this%nyblk * (jblk-1) - this%lat_n(jblk) = -90.0 + 180.0/this%nyblk * jblk - ENDDO - - ENDIF - -#ifndef SinglePoint - IF (p_is_root) THEN - write (*,*) - write (*,'(A)') '----- Block information -----' - write (*,'(I4,A,I4,A)') this%nxblk, ' blocks in longitude,', & - this%nyblk, ' blocks in latitude.' - write (*,*) - ENDIF -#else - write(*,'(A)') 'Blocks : Set (360 longitude x 180 latitude) blocks for Single Point.' -#endif - -#ifndef SinglePoint - CALL this%init_pio () -#endif - - END SUBROUTINE block_set - - ! -------------------------------- - SUBROUTINE block_save_to_file (this, dir_landdata) - - USE MOD_NetCDFSerial - USE MOD_SPMD_Task - IMPLICIT NONE - - class (block_type) :: this - - character(len=*), intent(in) :: dir_landdata - - ! Local variables - character(len=256) :: filename - - IF (p_is_root) THEN - - filename = trim(dir_landdata) // '/block.nc' - - CALL ncio_create_file (filename) - - CALL ncio_define_dimension (filename, 'longitude', this%nxblk) - CALL ncio_define_dimension (filename, 'latitude', this%nyblk) - - CALL ncio_write_serial (filename, 'lat_s', this%lat_s, 'latitude' ) - CALL ncio_write_serial (filename, 'lat_n', this%lat_n, 'latitude' ) - CALL ncio_write_serial (filename, 'lon_w', this%lon_w, 'longitude') - CALL ncio_write_serial (filename, 'lon_e', this%lon_e, 'longitude') - - ENDIF - - END SUBROUTINE block_save_to_file - ! -------------------------------- SUBROUTINE block_load_from_file (this, dir_landdata) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI, only: mpas_is_root, CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE class (block_type) :: this @@ -245,321 +97,36 @@ SUBROUTINE block_load_from_file (this, dir_landdata) this%nyblk = size(this%lat_s) this%nxblk = size(this%lon_w) - IF (p_is_root) THEN - write (*,*) 'Block information:' - write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', & - this%nyblk, ' blocks in latitude.' - write (*,*) + IF (this%nxblk < 1 .or. this%nyblk < 1 .or. size(this%lat_n) /= this%nyblk .or. & + size(this%lon_e) /= this%nxblk) THEN + CALL CoLM_stop('CoLM block.nc contains inconsistent block-boundary dimensions.') ENDIF - -#ifdef MPAS_EMBEDDED_COLM - IF (allocated(this%pio)) deallocate(this%pio) - allocate (this%pio (this%nxblk,this%nyblk)) - this%pio(:,:) = -1 - this%nblkme = 0 -#else - CALL this%read_pio (dir_landdata) -#endif - - END SUBROUTINE block_load_from_file - - ! -------------------------------- - SUBROUTINE block_clip (this, & - iblk_south, iblk_north, iblk_west, iblk_east, numblocks) - - USE MOD_Namelist - USE MOD_Utils - IMPLICIT NONE - - class (block_type) :: this - integer, intent(out) :: iblk_south, iblk_north, iblk_west, iblk_east - integer, intent(out), optional :: numblocks - - ! Local Variables - real(r8) :: edges, edgen, edgew, edgee - integer :: numblocks_x, numblocks_y - - edges = DEF_domain%edges - edgen = DEF_domain%edgen - edgew = DEF_domain%edgew - edgee = DEF_domain%edgee - - iblk_south = find_nearest_south (edges, this%nyblk, this%lat_s) - iblk_north = find_nearest_north (edgen, this%nyblk, this%lat_n) - - CALL normalize_longitude (edgew) - CALL normalize_longitude (edgee) - - IF (edgew == edgee) THEN - iblk_west = 1 - iblk_east = this%nxblk - ELSE - iblk_west = find_nearest_west (edgew, this%nxblk, this%lon_w) - iblk_east = find_nearest_east (edgee, this%nxblk, this%lon_e) - - IF (iblk_west == iblk_east) THEN - IF ((lon_between_floor(edgee,this%lon_w(iblk_west),edgew)) & - .and. (this%lon_w(iblk_west) /= edgew)) THEN - iblk_west = 1 - iblk_east = this%nxblk - ENDIF - ENDIF - ENDIF - - IF (present(numblocks)) THEN - - numblocks_y = iblk_north - iblk_south + 1 - - IF (iblk_east >= iblk_west) THEN - numblocks_x = iblk_east - iblk_west + 1 - ELSE - numblocks_x = this%nxblk - iblk_west + 1 + iblk_east - ENDIF - - numblocks = numblocks_x * numblocks_y - - ENDIF - - END SUBROUTINE block_clip - - ! -------------------------------- - SUBROUTINE block_init_pio (this) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Utils - IMPLICIT NONE - - class (block_type) :: this - - integer :: iblk, jblk, iproc - integer :: iblk_south, iblk_north, iblk_west, iblk_east - integer :: numblocks, ngrp - integer :: iblkme - - IF (p_is_root) THEN - CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east, numblocks) - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - - IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN - ngrp = p_np_glb / DEF_PIO_groupsize - ELSE - ngrp = (p_np_glb-1) / DEF_PIO_groupsize - ENDIF - ngrp = min(max(ngrp, 1), numblocks) - - CALL divide_processes_into_groups (ngrp) -#endif - - allocate (this%pio (this%nxblk,this%nyblk)) - this%pio(:,:) = -1 - - IF (p_is_root) THEN - - iproc = -1 - DO jblk = iblk_south, iblk_north - - iblk = iblk_west - DO WHILE (.true.) -#ifdef USEMPI - iproc = mod(iproc+1, p_np_active) - this%pio(iblk,jblk) = p_address_active(iproc) -#else - this%pio(iblk,jblk) = p_root -#endif - - IF (iblk /= iblk_east) THEN - iblk = mod(iblk,this%nxblk) + 1 - ELSE - EXIT - ENDIF - ENDDO - ENDDO - - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, & - p_address_root, p_comm_glb, p_err) -#endif - - this%nblkme = 0 - IF (p_is_active) THEN - this%nblkme = count(this%pio == p_iam_glb) - IF (this%nblkme > 0) THEN - iblkme = 0 - allocate (this%xblkme(this%nblkme)) - allocate (this%yblkme(this%nblkme)) - DO iblk = 1, this%nxblk - DO jblk = 1, this%nyblk - IF (p_iam_glb == this%pio(iblk,jblk)) THEN - iblkme = iblkme + 1 - this%xblkme(iblkme) = iblk - this%yblkme(iblkme) = jblk - ENDIF - ENDDO - ENDDO - ENDIF + IF (.not. all(ieee_is_finite(this%lat_s)) .or. .not. all(ieee_is_finite(this%lat_n)) .or. & + .not. all(ieee_is_finite(this%lon_w)) .or. .not. all(ieee_is_finite(this%lon_e))) THEN + CALL CoLM_stop('CoLM block.nc contains non-finite block boundaries.') ENDIF - - END SUBROUTINE block_init_pio - - ! -------------------------------- - SUBROUTINE block_read_pio (this, dir_landdata) - - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - USE MOD_Namelist - IMPLICIT NONE - - class (block_type) :: this - character(len=*), intent(in) :: dir_landdata - - ! Local Variables - character(len=256) :: filename, cyear - integer, allocatable :: nelm_io(:), nelmblk(:,:) - integer :: iblk_south, iblk_north, iblk_west, iblk_east - integer :: numblocks, ngrp, iblk, jblk, iproc, jproc - integer :: iblkme - - IF (p_is_root) THEN - ! Whether it varies by year??? - write(cyear,'(i4.4)') DEF_LC_YEAR - filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' - CALL ncio_read_serial (filename, 'nelm_blk', nelmblk) - numblocks = count(nelmblk > 0) - - CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east) - + IF (any(this%lat_s < -90._r8) .or. any(this%lat_n > 90._r8) .or. & + any(this%lat_n <= this%lat_s)) THEN + CALL CoLM_stop('CoLM block.nc contains invalid latitude boundaries.') ENDIF - -#ifdef USEMPI - IF (p_is_root) THEN - - IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN - ngrp = p_np_glb / DEF_PIO_groupsize - ELSE - ngrp = (p_np_glb-1) / DEF_PIO_groupsize - ENDIF - ngrp = min(max(ngrp, 1), numblocks) - - DO WHILE (.true.) - - allocate (nelm_io (ngrp)) - nelm_io(:) = 0 - - DO jblk = iblk_south, iblk_north - iblk = iblk_west - DO WHILE (.true.) - - IF (nelmblk(iblk,jblk) > 0) THEN - iproc = minloc(nelm_io, dim=1) - nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk) - ENDIF - - IF (iblk /= iblk_east) THEN - iblk = mod(iblk,this%nxblk) + 1 - ELSE - EXIT - ENDIF - ENDDO - ENDDO - - IF (maxval(nelm_io) < 2 * minval(nelm_io)) THEN - deallocate (nelm_io) - EXIT - ELSE - ngrp = ngrp - 1 - deallocate (nelm_io) - ENDIF - ENDDO - - IF (DEF_nIO_eq_nBlock) THEN - ngrp = numblocks - ENDIF - - IF ((p_np_glb-1)/ngrp < 2) THEN - CALL CoLM_stop ('CoLM called STOP: Too many groups or Too few processors for this case.') - ENDIF + IF (this%nyblk > 1) THEN + IF (any(this%lat_s(2:) <= this%lat_s(:this%nyblk-1))) & + CALL CoLM_stop('CoLM block.nc latitude blocks are not ordered south to north.') ENDIF - - CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - CALL mpi_bcast (ngrp, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - CALL divide_processes_into_groups (ngrp) -#endif - - allocate (this%pio (this%nxblk,this%nyblk)) - this%pio(:,:) = -1 - - IF (p_is_root) THEN - -#ifdef USEMPI - allocate (nelm_io (0:p_np_active-1)) - nelm_io(:) = 0 - jproc = -1 -#endif - - DO jblk = iblk_south, iblk_north - iblk = iblk_west - DO WHILE (.true.) -#ifdef USEMPI - IF (nelmblk(iblk,jblk) > 0) THEN - iproc = minloc(nelm_io, dim=1) - 1 - this%pio(iblk,jblk) = p_address_active(iproc) - nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk) - ELSEIF (nelmblk(iblk,jblk) == 0) THEN - jproc = mod(jproc+1, p_np_active) - this%pio(iblk,jblk) = p_address_active(jproc) - ENDIF -#else - this%pio(iblk,jblk) = p_root -#endif - - IF (iblk /= iblk_east) THEN - iblk = mod(iblk,this%nxblk) + 1 - ELSE - EXIT - ENDIF - ENDDO - ENDDO - -#ifdef USEMPI - deallocate (nelm_io) -#endif + IF (mpas_is_root) THEN + write (*,*) 'Block information:' + write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', & + this%nyblk, ' blocks in latitude.' + write (*,*) ENDIF -#ifdef USEMPI - CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, & - p_address_root, p_comm_glb, p_err) -#endif - + IF (allocated(this%owner_rank)) deallocate(this%owner_rank) + allocate (this%owner_rank (this%nxblk,this%nyblk)) + this%owner_rank(:,:) = -1 this%nblkme = 0 - IF (p_is_active) THEN - this%nblkme = count(this%pio == p_iam_glb) - IF (this%nblkme > 0) THEN - iblkme = 0 - allocate (this%xblkme(this%nblkme)) - allocate (this%yblkme(this%nblkme)) - DO iblk = 1, this%nxblk - DO jblk = 1, this%nyblk - IF (p_iam_glb == this%pio(iblk,jblk)) THEN - iblkme = iblkme + 1 - this%xblkme(iblkme) = iblk - this%yblkme(iblkme) = jblk - ENDIF - ENDDO - ENDDO - ENDIF - ENDIF - IF (allocated(nelmblk)) deallocate (nelmblk) - - END SUBROUTINE block_read_pio + END SUBROUTINE block_load_from_file ! -------------------------------- SUBROUTINE block_free_mem (this) @@ -572,7 +139,7 @@ SUBROUTINE block_free_mem (this) IF (allocated (this%lon_w)) deallocate (this%lon_w) IF (allocated (this%lon_e)) deallocate (this%lon_e) - IF (allocated (this%pio) ) deallocate (this%pio ) + IF (allocated (this%owner_rank)) deallocate (this%owner_rank) IF (allocated (this%xblkme)) deallocate (this%xblkme) IF (allocated (this%yblkme)) deallocate (this%yblkme) @@ -591,8 +158,6 @@ SUBROUTINE get_blockname (iblk, jblk, blockname) ! Local variables character(len=4) :: cx character(len=3) :: cy - integer :: i - IF (gblock%lat_s(jblk) < 0) THEN write (cy, '(A1,I2.2)') 's', - floor(gblock%lat_s(jblk)) ELSE diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 deleted file mode 100644 index dcb444bc80..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90 +++ /dev/null @@ -1,375 +0,0 @@ -#include - -MODULE MOD_CatchmentDataReadin - -!-------------------------------------------------------------------------------------- -! !DESCRIPTION: -! -! Reading preprocessed MERIT Hydro data and generated catchment data in netcdf files. -! -! 1. If "in_one_file" is false, then the data is orgnized by 5 degree blocks. -! The file name gives the southwest corner of the block. -! For example, file "n60e075.nc" stores data in region from 65N to 60N and 75E to 80E, -! Subroutines loop over all 5 degree blocks in simulation region. -! -! 2. Data is saved in variables with types of "block_data_xxxxx_xd". -! -! 3. Latitude in files is from north to south. -! -! Created by Shupeng Zhang, May 2023 -!-------------------------------------------------------------------------------------- - - IMPLICIT NONE - - integer, parameter :: nxhbox = 6000 - integer, parameter :: nyhbox = 6000 - integer, parameter :: nxhglb = 432000 - integer, parameter :: nyhglb = 216000 - - INTERFACE catchment_data_read - MODULE procedure catchment_data_read_int32 - MODULE procedure catchment_data_read_real8 - END INTERFACE catchment_data_read - -CONTAINS - - ! ----- - SUBROUTINE catchment_data_read_int32 (file_meshdata_in, dataname, grid, rdata_int32, spv) - - USE MOD_Grid - USE MOD_DataType - IMPLICIT NONE - - character (len=*), intent(in) :: file_meshdata_in - character (len=*), intent(in) :: dataname - type (grid_type), intent(in) :: grid - - type (block_data_int32_2d), intent(inout) :: rdata_int32 - integer, intent(in), optional :: spv - - IF (present(spv)) THEN - CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & - rdata_int32 = rdata_int32, spv_i4 = spv) - ELSE - CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & - rdata_int32 = rdata_int32) - ENDIF - - END SUBROUTINE catchment_data_read_int32 - - ! ----- - SUBROUTINE catchment_data_read_real8 (file_meshdata_in, dataname, grid, rdata_real8, spv) - - USE MOD_Grid - USE MOD_DataType - IMPLICIT NONE - - character (len=*), intent(in) :: file_meshdata_in - character (len=*), intent(in) :: dataname - type (grid_type), intent(in) :: grid - - type (block_data_real8_2d), intent(inout) :: rdata_real8 - real(r8), intent(in), optional :: spv - - IF (present(spv)) THEN - CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & - rdata_real8 = rdata_real8, spv_r8 = spv) - ELSE - CALL catchment_data_read_general (file_meshdata_in, dataname, grid, & - rdata_real8 = rdata_real8) - ENDIF - - END SUBROUTINE catchment_data_read_real8 - - ! ----- - SUBROUTINE catchment_data_read_general (file_meshdata_in, dataname, grid, & - rdata_int32, spv_i4, rdata_real8, spv_r8) - - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_Utils - USE MOD_NetCDFSerial - IMPLICIT NONE - - character (len=*), intent(in) :: file_meshdata_in - character (len=*), intent(in) :: dataname - type (grid_type), intent(in) :: grid - - type (block_data_int32_2d), intent(inout), optional :: rdata_int32 - integer, intent(in), optional :: spv_i4 - - type (block_data_real8_2d), intent(inout), optional :: rdata_real8 - real(r8), intent(in), optional :: spv_r8 - - - ! Local Variables - logical :: in_one_file - integer :: nlat, nlon, ilon - integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox - integer :: xdsp, ydsp, i0, i1, j0, j1, il0, il1, jl0, jl1 - integer :: i0min, i1max, if0, if1, jf0, jf1, i0next, i1next - character(len=256) :: file_mesh, path_mesh - character(len=3) :: pre1 - character(len=4) :: pre2 - integer, allocatable :: dcache_i4(:,:) - real(r8), allocatable :: dcache_r8(:,:) - real(r8), allocatable :: latitude(:), longitude(:) - logical :: fexists - - IF (p_is_active) THEN - - IF (p_iam_active == p_root) THEN - IF (grid%yinc == 1) THEN - write(*,*) 'Warning: latitude in catchment data should be from north to south.' - ENDIF - ENDIF - - IF (p_iam_active == p_root) THEN - in_one_file = ncio_var_exist (file_meshdata_in, dataname) - ENDIF -#ifdef USEMPI - CALL mpi_bcast (in_one_file, 1, mpi_logical, p_root, p_comm_active, p_err) -#endif - - IF (in_one_file) THEN - - file_mesh = file_meshdata_in - - CALL ncio_read_serial (file_mesh, 'lat', latitude) - CALL ncio_read_serial (file_mesh, 'lon', longitude) - - nlat = size(latitude ) - nlon = size(longitude) - - isouth = find_nearest_south (latitude(nlat), grid%nlat, grid%lat_s) - inorth = find_nearest_north (latitude(1), grid%nlat, grid%lat_n) - - DO ilon = 1, nlon - CALL normalize_longitude (longitude(ilon)) - ENDDO - - iwest = find_nearest_west (longitude(1), grid%nlon, grid%lon_w) - ieast = find_nearest_east (longitude(nlon), grid%nlon, grid%lon_e) - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF (present(rdata_int32)) THEN - IF (present(spv_i4)) THEN - rdata_int32%blk(iblk,jblk)%val(:,:) = spv_i4 - ELSE - rdata_int32%blk(iblk,jblk)%val(:,:) = 0 - ENDIF - ENDIF - - IF (present(rdata_real8)) THEN - IF (present(spv_r8)) THEN - rdata_real8%blk(iblk,jblk)%val(:,:) = spv_r8 - ELSE - rdata_real8%blk(iblk,jblk)%val(:,:) = -1.e36_r8 - ENDIF - ENDIF - - IF ((inorth > grid%ydsp(jblk)+nyhbox) .or. (isouth < grid%ydsp(jblk)+1)) THEN - CYCLE - ENDIF - - j0 = max(inorth, grid%ydsp(jblk)+1) - j1 = min(isouth, grid%ydsp(jblk)+grid%ycnt(jblk)) - - jl0 = j0 - grid%ydsp(jblk) - jl1 = j1 - grid%ydsp(jblk) - jf0 = j0 - inorth + 1 - jf1 = j1 - inorth + 1 - - i0min = grid%xdsp(iblk) + 1 - i1max = grid%xdsp(iblk) + grid%xcnt(iblk) - IF (i1max > grid%nlon) i1max = i1max - grid%nlon - - DO WHILE ((i0min /= i1max) .and. (.not. (lon_between_floor(grid%lon_w(i0min), & - grid%lon_w(iwest), grid%lon_e(ieast))))) - i0min = i0min + 1; IF (i0min > grid%nlon) i0min = 1 - ENDDO - - IF (lon_between_floor(grid%lon_w(i0min), grid%lon_w(iwest), grid%lon_e(ieast))) THEN - i0 = i0min - i1 = i0 - i1next = i1 + 1; IF (i1next > grid%nlon) i1next = 1 - DO WHILE ((i1 /= i1max) .and. & - lon_between_floor(grid%lon_w(i1next), grid%lon_w(iwest), grid%lon_e(ieast))) - i1 = i1next - i1next = i1 + 1; IF (i1next > grid%nlon) i1next = 1 - ENDDO - - if0 = i0 - iwest + 1; IF (if0 <= 0) if0 = if0 + grid%nlon - if1 = i1 - iwest + 1; IF (if1 <= 0) if1 = if1 + grid%nlon - il0 = i0 - grid%xdsp(iblk); IF (il0 <= 0) il0 = il0 + grid%nlon - il1 = i1 - grid%xdsp(iblk); IF (il1 <= 0) il1 = il1 + grid%nlon - - IF (present(rdata_int32)) THEN - CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_i4) - dcache_i4 = transpose(dcache_i4) - - rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4 - ENDIF - - IF (present(rdata_real8)) THEN - CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_r8) - dcache_r8 = transpose(dcache_r8) - - rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8 - ENDIF - - ENDIF - - IF (lon_between_ceil(grid%lon_e(i1max), grid%lon_w(iwest), grid%lon_e(ieast))) THEN - i1 = i1max - i0 = i1 - i0next = i0 - 1; IF (i0next == 0) i0next = grid%nlon - DO WHILE ((i0 /= i0min) .and. & - lon_between_ceil(grid%lon_e(i0next), grid%lon_w(iwest), grid%lon_e(ieast))) - i0 = i0next - i0next = i0 - 1; IF (i0next == 0) i0next = grid%nlon - ENDDO - - IF (i0 /= i0min) THEN - if0 = i0 - iwest + 1; IF (if0 <= 0) if0 = if0 + grid%nlon - if1 = i1 - iwest + 1; IF (if1 <= 0) if1 = if1 + grid%nlon - il0 = i0 - grid%xdsp(iblk); IF (il0 <= 0) il0 = il0 + grid%nlon - il1 = i1 - grid%xdsp(iblk); IF (il1 <= 0) il1 = il1 + grid%nlon - - IF (present(rdata_int32)) THEN - CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_i4) - dcache_i4 = transpose(dcache_i4) - - rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4 - ENDIF - - IF (present(rdata_real8)) THEN - CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_r8) - dcache_r8 = transpose(dcache_r8) - - rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8 - ENDIF - ENDIF - ENDIF - - ENDDO - - ELSE - - ! remove suffix ".nc" - path_mesh = file_meshdata_in(1:len_trim(file_meshdata_in)-3) - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF (present(rdata_int32)) THEN - IF (present(spv_i4)) THEN - rdata_int32%blk(iblk,jblk)%val(:,:) = spv_i4 - ELSE - rdata_int32%blk(iblk,jblk)%val(:,:) = 0 - ENDIF - ENDIF - - IF (present(rdata_real8)) THEN - IF (present(spv_r8)) THEN - rdata_real8%blk(iblk,jblk)%val(:,:) = spv_r8 - ELSE - rdata_real8%blk(iblk,jblk)%val(:,:) = -1.e36_r8 - ENDIF - ENDIF - - inorth = grid%ydsp(jblk) + 1 - isouth = grid%ydsp(jblk) + grid%ycnt(jblk) - - iwest = grid%xdsp(iblk) + 1 - ieast = grid%xdsp(iblk) + grid%xcnt(iblk) - IF (ieast > nxhglb) ieast = ieast - nxhglb - - ibox = grid%xdsp(iblk)/nxhbox + 1 - jbox = grid%ydsp(jblk)/nyhbox + 1 - - DO WHILE (.true.) - - xdsp = (ibox-1) * nxhbox - ydsp = (jbox-1) * nyhbox - - j0 = max(inorth-ydsp, 1) - j1 = min(isouth-ydsp, nyhbox) - jl0 = j0 + ydsp - inorth + 1 - jl1 = j1 + ydsp - inorth + 1 - - IF (ieast >= iwest) THEN - i0 = max(iwest-xdsp, 1) - i1 = min(ieast-xdsp, nxhbox) - il0 = i0 + xdsp - iwest + 1 - il1 = i1 + xdsp - iwest + 1 - ELSE - IF (iwest <= xdsp+nxhbox) THEN - i0 = max(iwest-xdsp, 1) - i1 = nxhbox - il0 = i0 + xdsp - iwest + 1 - il1 = i1 + xdsp - iwest + 1 - ELSE - i0 = 1 - i1 = min(ieast-xdsp, nxhbox) - il0 = i0 + xdsp + nxhglb - iwest + 1 - il1 = i1 + xdsp + nxhglb - iwest + 1 - ENDIF - ENDIF - - IF (jbox <= 18) THEN - write (pre1,'(A1,I2.2)') 'n', (18-jbox)*5 - ELSE - write (pre1,'(A1,I2.2)') 's', (jbox-18)*5 - ENDIF - - IF (ibox <= 36) THEN - write (pre2,'(A1,I3.3)') 'w', (37-ibox)*5 - ELSE - write (pre2,'(A1,I3.3)') 'e', (ibox-37)*5 - ENDIF - - file_mesh = trim(path_mesh) // '/' // trim(pre1) // trim(pre2) // '.nc' - - inquire(file=file_mesh, exist=fexists) - IF (fexists) THEN - IF (present(rdata_int32)) THEN - CALL ncio_read_part_serial (file_mesh, dataname, (/j0,i0/), (/j1,i1/), dcache_i4) - dcache_i4 = transpose(dcache_i4) - - rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4 - ENDIF - - IF (present(rdata_real8)) THEN - CALL ncio_read_part_serial (file_mesh, dataname, (/j0,i0/), (/j1,i1/), dcache_r8) - dcache_r8 = transpose(dcache_r8) - - rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8 - ENDIF - ENDIF - - IF ((ieast >= xdsp + 1) .and. (ieast <= xdsp + nxhbox)) THEN - IF (isouth <= ydsp + nyhbox) THEN - EXIT - ELSE - ibox = grid%xdsp(iblk)/nxhbox + 1 - jbox = jbox + 1 - ENDIF - ELSE - ibox = mod(ibox, nxhglb/nxhbox) + 1 - ENDIF - - ENDDO - ENDDO - ENDIF - ENDIF - - END SUBROUTINE catchment_data_read_general - -END MODULE MOD_CatchmentDataReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 index d810f957f0..85750fb4b0 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 @@ -7,8 +7,9 @@ MODULE MOD_ComputePushData USE MOD_Precision USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Utils + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE ! -- Data Type : push data between ranks -- @@ -26,7 +27,7 @@ MODULE MOD_ComputePushData integer :: nself integer, allocatable :: self_from (:) integer, allocatable :: self_to (:) -#ifdef COLM_PARALLEL +#ifdef MPAS_MPI ! data is on other processors integer, allocatable :: n_to_other (:) integer, allocatable :: n_from_other (:) @@ -62,8 +63,6 @@ MODULE MOD_ComputePushData MODULE procedure build_compute_pushdata_multi END INTERFACE build_compute_pushdata - PUBLIC :: build_compute_pushdata_subset - PUBLIC :: build_compute_remapdata INTERFACE compute_push_data @@ -93,21 +92,33 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq ! Local Variables integer, allocatable :: ids_me_sorted(:), order_ids(:), self_from(:) -#ifdef COLM_PARALLEL +#ifdef MPAS_MPI integer, allocatable :: ids(:), loc_from_me(:), loc_from_other(:) integer :: request(3) #endif integer :: i, iloc, irank, jrank, n_req_other - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (num_me < 0 .or. num_me > size(ids_me)) THEN + CALL CoLM_stop('Invalid local ID count while building CoLM compute push data.') + ENDIF + IF (n_req_uniq < 0 .or. n_req_uniq > size(ids_req_uniq)) THEN + CALL CoLM_stop('Invalid request ID count while building CoLM compute push data.') + ENDIF allocate (ids_me_sorted (num_me)) allocate (order_ids (num_me)) IF (num_me > 0) THEN - ids_me_sorted = ids_me + ids_me_sorted = ids_me(1:num_me) order_ids = (/(i, i = 1, num_me)/) CALL quicksort (num_me, ids_me_sorted, order_ids) + IF (num_me > 1) THEN + IF (any(ids_me_sorted(2:num_me) == ids_me_sorted(1:num_me-1))) THEN + CALL CoLM_stop('Duplicate local source IDs while building CoLM compute push data.') + ENDIF + ENDIF ENDIF pushdata%nself = 0 @@ -132,40 +143,45 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq ENDIF ENDIF -#ifdef COLM_PARALLEL - CALL mpi_barrier (p_comm_compute, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push layout synchronization') - allocate (pushdata%n_to_other (0:p_np_compute-1)) - allocate (pushdata%to_other (0:p_np_compute-1)) + allocate (pushdata%n_to_other (0:mpas_size-1)) + allocate (pushdata%to_other (0:mpas_size-1)) - allocate (pushdata%n_from_other (0:p_np_compute-1)) - allocate (pushdata%other_to (0:p_np_compute-1)) + allocate (pushdata%n_from_other (0:mpas_size-1)) + allocate (pushdata%other_to (0:mpas_size-1)) pushdata%n_to_other (:) = 0 pushdata%n_from_other(:) = 0 IF (n_req_uniq > 0) allocate (loc_from_other (n_req_uniq)) - irank = modulo(p_iam_compute+1, p_np_compute) - jrank = modulo(p_iam_compute-1, p_np_compute) - DO WHILE (irank /= p_iam_compute) + irank = modulo(mpas_rank+1, mpas_size) + jrank = modulo(mpas_rank-1, mpas_size) + DO WHILE (irank /= mpas_rank) CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jrank, 10, & - p_comm_compute, request(1), p_err) + mpas_comm, request(1), mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-count send') IF (n_req_uniq > 0) THEN CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jrank, 11, & - p_comm_compute, request(2), p_err) + mpas_comm, request(2), mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-ID send') ENDIF CALL mpi_recv (n_req_other, 1, MPI_INTEGER, irank, 10, & - p_comm_compute, p_stat, p_err) + mpas_comm, mpas_status, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-count receive') IF (n_req_other > 0) THEN allocate (ids (n_req_other)) CALL mpi_recv (ids, n_req_other, MPI_INTEGER, irank, 11, & - p_comm_compute, p_stat, p_err) + mpas_comm, mpas_status, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-ID receive') allocate (loc_from_me (n_req_other)) loc_from_me(:) = -1 @@ -186,14 +202,16 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq ENDIF CALL mpi_isend (loc_from_me, n_req_other, MPI_INTEGER, irank, 12, & - p_comm_compute, request(3), p_err) + mpas_comm, request(3), mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push source-location send') ENDIF IF (n_req_uniq > 0) THEN CALL mpi_recv (loc_from_other, n_req_uniq, MPI_INTEGER, & - jrank, 12, p_comm_compute, p_stat, p_err) + jrank, 12, mpas_comm, mpas_status, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push source-location receive') pushdata%n_from_other(jrank) = count(loc_from_other > 0) IF (pushdata%n_from_other(jrank) > 0) THEN @@ -203,20 +221,28 @@ SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq ENDIF - CALL mpi_wait(request(1), MPI_STATUS_IGNORE, p_err) - IF (n_req_uniq > 0) CALL mpi_wait(request(2), MPI_STATUSES_IGNORE, p_err) - IF (n_req_other > 0) CALL mpi_wait(request(3), MPI_STATUSES_IGNORE, p_err) + CALL mpi_wait(request(1), MPI_STATUS_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-count send completion') + IF (n_req_uniq > 0) THEN + CALL mpi_wait(request(2), MPI_STATUS_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-ID send completion') + ENDIF + IF (n_req_other > 0) THEN + CALL mpi_wait(request(3), MPI_STATUS_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push source-location send completion') + ENDIF IF (allocated(ids )) deallocate(ids ) IF (allocated(loc_from_me)) deallocate(loc_from_me) - irank = modulo(irank+1, p_np_compute) - jrank = modulo(jrank-1, p_np_compute) + irank = modulo(irank+1, mpas_size) + jrank = modulo(jrank-1, mpas_size) ENDDO IF (allocated (loc_from_other)) deallocate (loc_from_other) - CALL mpi_barrier (p_comm_compute, p_err) + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push layout completion') #endif IF (allocated(ids_me_sorted)) deallocate(ids_me_sorted) @@ -240,18 +266,25 @@ SUBROUTINE build_compute_pushdata_single (num_me, ids_me, num_req, ids_req, push integer :: n_req_uniq, iloc, i integer, allocatable :: ids_req_uniq (:) - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (num_me < 0 .or. num_me > size(ids_me)) THEN + CALL CoLM_stop('Invalid local ID count while building single CoLM compute push data.') + ENDIF + IF (num_req < 0 .or. num_req > size(ids_req)) THEN + CALL CoLM_stop('Invalid request count while building single CoLM compute push data.') + ENDIF n_req_uniq = 0 allocate (ids_req_uniq (num_req)) IF (num_req > 0) THEN - DO i = 1, size(ids_req) + DO i = 1, num_req CALL insert_into_sorted_list1 (ids_req(i), n_req_uniq, ids_req_uniq, iloc) ENDDO allocate (pushdata%addr_single (num_req)) - DO i = 1, size(ids_req) + DO i = 1, num_req pushdata%addr_single(i) = & find_in_sorted_list1 (ids_req(i), n_req_uniq, ids_req_uniq(1:n_req_uniq)) ENDDO @@ -284,7 +317,22 @@ SUBROUTINE build_compute_pushdata_multi ( & integer, allocatable :: ids_req_uniq (:) logical, allocatable :: id_found (:) - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (num_me < 0 .or. num_me > size(ids_me)) THEN + CALL CoLM_stop('Invalid local ID count while building multi CoLM compute push data.') + ENDIF + IF (num_req < 0 .or. num_req > size(ids_req, 2) .or. num_req > size(area_req, 2)) THEN + CALL CoLM_stop('Invalid request count while building multi CoLM compute push data.') + ENDIF + IF (size(area_req, 1) /= size(ids_req, 1)) THEN + CALL CoLM_stop('ID and area shapes differ while building multi CoLM compute push data.') + ENDIF + IF (num_req > 0) THEN + IF (.not. all(ieee_is_finite(area_req(:,1:num_req)))) THEN + CALL CoLM_stop('Non-finite overlap area while building multi CoLM compute push data.') + ENDIF + ENDIF n_req_uniq = 0 @@ -318,9 +366,9 @@ SUBROUTINE build_compute_pushdata_multi ( & allocate (pushdata%area_multi (ndim1,num_req)) allocate (pushdata%sum_area (num_req)) - pushdata%area_multi = area_req + pushdata%area_multi = area_req(:,1:num_req) - WHERE ((area_req <= 0.) .or. (ids_req <= 0)) + WHERE ((pushdata%area_multi <= 0.) .or. (ids_req(:,1:num_req) <= 0)) pushdata%area_multi = 0. END WHERE @@ -328,8 +376,8 @@ SUBROUTINE build_compute_pushdata_multi ( & id_found(:) = .false. IF (pushdata%nself > 0) id_found(pushdata%self_to) = .true. -#ifdef COLM_PARALLEL - DO irank = 0, p_np_compute-1 +#ifdef MPAS_MPI + DO irank = 0, mpas_size-1 IF (pushdata%n_from_other(irank) > 0) THEN id_found(pushdata%other_to(irank)%val) = .true. ENDIF @@ -356,194 +404,6 @@ SUBROUTINE build_compute_pushdata_multi ( & END SUBROUTINE build_compute_pushdata_multi ! ---------- - SUBROUTINE build_compute_pushdata_subset ( & - num_me, num_req, pushdata_in, subset_in, pushdata_out, subset_out, numsubset) - - USE MOD_Pixelset - IMPLICIT NONE - - integer, intent(in) :: num_me - integer, intent(in) :: num_req - - type(compute_pushdata_type), intent(in) :: pushdata_in - type(subset_type), intent(in) :: subset_in - - type(compute_pushdata_type), intent(inout) :: pushdata_out - type(subset_type), optional, intent(inout) :: subset_out - integer, optional, intent(inout) :: numsubset - - ! Local Variables - integer :: i, j, ii, jj, idsp, jdsp, kdsp, nsub, irank - integer, allocatable :: nsub_me (:), nsub_req(:), nsub_req_uniq(:) - integer, allocatable :: subdsp_me(:), subdsp_req_uniq(:) - - IF (p_is_compute) THEN - - IF (num_me > 0) THEN - allocate (nsub_me (num_me)) - nsub_me = subset_in%subend - subset_in%substt + 1 - ENDIF - - IF (num_req > 0) THEN - allocate (nsub_req (num_req)) - ENDIF - - CALL compute_push_data (pushdata_in, nsub_me, nsub_req, 0) - - IF (present(subset_out) .and. present(numsubset)) THEN - IF (num_req > 0) THEN - allocate (subset_out%substt (num_req)) - allocate (subset_out%subend (num_req)) - - idsp = 0 - DO i = 1, num_req - IF (nsub_req(i) == 0) THEN - subset_out%substt(i) = 0 - subset_out%subend(i) = -1 - ELSE - subset_out%substt(i) = idsp + 1 - subset_out%subend(i) = idsp + nsub_req(i) - ENDIF - idsp = idsp + nsub_req(i) - ENDDO - - numsubset = idsp - ELSE - numsubset = 0 - ENDIF - ENDIF - - IF (num_me > 0) THEN - allocate (subdsp_me (num_me)) - idsp = 0 - DO i = 1, num_me - IF (nsub_me(i) > 0) THEN - subdsp_me(i) = idsp - idsp = idsp + nsub_me(i) - ENDIF - ENDDO - ENDIF - - pushdata_out%num_req_uniq = 0 - IF (pushdata_in%num_req_uniq > 0) THEN - - allocate (nsub_req_uniq (pushdata_in%num_req_uniq)) - allocate (subdsp_req_uniq (pushdata_in%num_req_uniq)) - - nsub_req_uniq(:) = 0 - DO i = 1, size(pushdata_in%addr_single) - nsub_req_uniq(pushdata_in%addr_single(i)) = nsub_req(i) - ENDDO - - idsp = 0 - DO i = 1, pushdata_in%num_req_uniq - IF (nsub_req_uniq(i) > 0) THEN - subdsp_req_uniq(i) = idsp - idsp = idsp + nsub_req_uniq(i) - ENDIF - ENDDO - - pushdata_out%num_req_uniq = sum(nsub_req_uniq) - ENDIF - - - IF (pushdata_out%num_req_uniq > 0) THEN - allocate (pushdata_out%addr_single (sum(nsub_req))) - - idsp = 0 - DO i = 1, num_req - IF (nsub_req(i) > 0) THEN - jdsp = subdsp_req_uniq(pushdata_in%addr_single(i)) - pushdata_out%addr_single(idsp+1:idsp+nsub_req(i)) = & - (/(jj, jj=jdsp+1,jdsp+nsub_req(i))/) - idsp = idsp + nsub_req(i) - ENDIF - ENDDO - ENDIF - - pushdata_out%nself = 0 - DO i = 1, pushdata_in%nself - pushdata_out%nself = pushdata_out%nself + nsub_me(pushdata_in%self_from(i)) - ENDDO - - IF (pushdata_out%nself > 0) THEN - allocate (pushdata_out%self_from (pushdata_out%nself)) - allocate (pushdata_out%self_to (pushdata_out%nself)) - - kdsp = 0 - DO i = 1, pushdata_in%nself - IF (nsub_me(pushdata_in%self_from(i)) > 0) THEN - nsub = nsub_me(pushdata_in%self_from(i)) - idsp = subdsp_me (pushdata_in%self_from(i)) - jdsp = subdsp_req_uniq(pushdata_in%self_to (i)) - pushdata_out%self_from(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) - pushdata_out%self_to (kdsp+1:kdsp+nsub) = (/(jj, jj=jdsp+1,jdsp+nsub)/) - kdsp = kdsp + nsub - ENDIF - ENDDO - ENDIF - -#ifdef COLM_PARALLEL - allocate (pushdata_out%n_to_other (0:p_np_compute-1)) - allocate (pushdata_out%to_other (0:p_np_compute-1)) - - DO irank = 0, p_np_compute-1 - - pushdata_out%n_to_other(irank) = 0 - DO i = 1, pushdata_in%n_to_other(irank) - pushdata_out%n_to_other(irank) = pushdata_out%n_to_other(irank) & - + nsub_me(pushdata_in%to_other(irank)%val(i)) - ENDDO - - IF (pushdata_out%n_to_other(irank) > 0) THEN - allocate (pushdata_out%to_other(irank)%val (pushdata_out%n_to_other(irank))) - kdsp = 0 - DO i = 1, pushdata_in%n_to_other(irank) - IF (nsub_me(pushdata_in%to_other(irank)%val(i)) > 0) THEN - nsub = nsub_me (pushdata_in%to_other(irank)%val(i)) - idsp = subdsp_me(pushdata_in%to_other(irank)%val(i)) - pushdata_out%to_other(irank)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) - kdsp = kdsp + nsub - ENDIF - ENDDO - ENDIF - - ENDDO - - allocate (pushdata_out%n_from_other (0:p_np_compute-1)) - allocate (pushdata_out%other_to (0:p_np_compute-1)) - - DO irank = 0, p_np_compute-1 - pushdata_out%n_from_other(irank) = 0 - DO i = 1, pushdata_in%n_from_other(irank) - pushdata_out%n_from_other(irank) = pushdata_out%n_from_other(irank) & - + nsub_req_uniq(pushdata_in%other_to(irank)%val(i)) - ENDDO - - IF (pushdata_out%n_from_other(irank) > 0) THEN - allocate (pushdata_out%other_to(irank)%val (pushdata_out%n_from_other(irank))) - kdsp = 0 - DO i = 1, pushdata_in%n_from_other(irank) - IF (nsub_req_uniq(pushdata_in%other_to(irank)%val(i)) > 0) THEN - nsub = nsub_req_uniq (pushdata_in%other_to(irank)%val(i)) - idsp = subdsp_req_uniq(pushdata_in%other_to(irank)%val(i)) - pushdata_out%other_to(irank)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/) - kdsp = kdsp + nsub - ENDIF - ENDDO - ENDIF - ENDDO -#endif - - IF (allocated (nsub_me )) deallocate (nsub_me ) - IF (allocated (nsub_req )) deallocate (nsub_req ) - IF (allocated (nsub_req_uniq )) deallocate (nsub_req_uniq ) - IF (allocated (subdsp_me )) deallocate (subdsp_me ) - IF (allocated (subdsp_req_uniq)) deallocate (subdsp_req_uniq) - - ENDIF - - END SUBROUTINE build_compute_pushdata_subset ! ---------- SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) @@ -566,10 +426,10 @@ SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) CALL mapping%build_arealweighted (grid, pixelset) - IF (p_is_compute) THEN + IF (.true.) THEN ngrid = 0 - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 ngrid = ngrid + mapping%glist(iproc)%ng ENDDO @@ -579,7 +439,7 @@ SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) ENDIF ngrid = 0 - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 DO ig = 1, mapping%glist(iproc)%ng CALL insert_into_sorted_list2 ( & mapping%glist(iproc)%ilon(ig), mapping%glist(iproc)%ilat(ig), & @@ -600,17 +460,45 @@ SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) remapdata%npset = mapping%npset + IF (remapdata%npset < 0) THEN + CALL CoLM_stop('Negative pixel-set count while building CoLM compute remap data.') + ENDIF + IF (remapdata%npset > 0) THEN + IF (.not. allocated(mapping%npart) .or. .not. allocated(mapping%address) .or. & + .not. allocated(mapping%areapart) .or. .not. allocated(mapping%glist)) THEN + CALL CoLM_stop('Incomplete spatial mapping while building CoLM compute remap data.') + ENDIF + IF (size(mapping%npart) < remapdata%npset .or. & + size(mapping%address) < remapdata%npset .or. & + size(mapping%areapart) < remapdata%npset) THEN + CALL CoLM_stop('Spatial mapping count mismatch while building CoLM compute remap data.') + ENDIF + allocate (remapdata%sum_area (remapdata%npset)) allocate (remapdata%npart (remapdata%npset)) allocate (remapdata%part_to (remapdata%npset)) allocate (remapdata%areapart (remapdata%npset)) remapdata%npart = mapping%npart + remapdata%sum_area = 0._r8 + + IF (any(remapdata%npart < 0)) THEN + CALL CoLM_stop('Negative part count while building CoLM compute remap data.') + ENDIF DO iset = 1, remapdata%npset IF (remapdata%npart(iset) > 0) THEN + IF (.not. allocated(mapping%address(iset)%val) .or. & + .not. allocated(mapping%areapart(iset)%val)) THEN + CALL CoLM_stop('Incomplete spatial mapping while building CoLM compute remap data.') + ENDIF + IF (size(mapping%address(iset)%val,1) < 2 .or. & + size(mapping%address(iset)%val,2) < remapdata%npart(iset) .or. & + size(mapping%areapart(iset)%val) < remapdata%npart(iset)) THEN + CALL CoLM_stop('Spatial mapping shape mismatch while building CoLM compute remap data.') + ENDIF allocate (remapdata%part_to(iset)%val (remapdata%npart(iset))) allocate (remapdata%areapart(iset)%val (remapdata%npart(iset))) ENDIF @@ -618,14 +506,37 @@ SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) DO ipart = 1, remapdata%npart(iset) iproc = mapping%address(iset)%val(1,ipart) iloc = mapping%address(iset)%val(2,ipart) + IF (iproc < lbound(mapping%glist,1) .or. iproc > ubound(mapping%glist,1)) THEN + CALL CoLM_stop('Spatial mapping rank is outside the CoLM active communicator.') + ENDIF + IF (.not. allocated(mapping%glist(iproc)%ilon) .or. & + .not. allocated(mapping%glist(iproc)%ilat)) THEN + CALL CoLM_stop('Spatial mapping grid list is incomplete.') + ENDIF + IF (iloc < 1 .or. iloc > mapping%glist(iproc)%ng .or. & + iloc > size(mapping%glist(iproc)%ilon) .or. & + iloc > size(mapping%glist(iproc)%ilat)) THEN + CALL CoLM_stop('Spatial mapping address is outside the local CoLM grid list.') + ENDIF remapdata%part_to(iset)%val(ipart) = find_in_sorted_list2 ( & mapping%glist(iproc)%ilon(iloc), mapping%glist(iproc)%ilat(iloc), ngrid, ilon_me, ilat_me) + IF (remapdata%part_to(iset)%val(ipart) <= 0) THEN + CALL CoLM_stop('Spatial mapping target is missing from the local CoLM remap grid.') + ENDIF ! from km^2 to m^2 - remapdata%areapart(iset)%val(ipart) = mapping%areapart(iset)%val(ipart) * 1.e6 + remapdata%areapart(iset)%val(ipart) = mapping%areapart(iset)%val(ipart) * 1.e6_r8 + IF (.not. ieee_is_finite(remapdata%areapart(iset)%val(ipart)) .or. & + remapdata%areapart(iset)%val(ipart) <= 0._r8) THEN + CALL CoLM_stop('Invalid overlap area while building CoLM compute remap data.') + ENDIF ENDDO IF (remapdata%npart(iset) > 0) THEN remapdata%sum_area(iset) = sum(remapdata%areapart(iset)%val) + IF (.not. ieee_is_finite(remapdata%sum_area(iset)) .or. & + remapdata%sum_area(iset) <= 0._r8) THEN + CALL CoLM_stop('Invalid total area while building CoLM compute remap data.') + ENDIF ENDIF ENDDO ENDIF @@ -637,6 +548,78 @@ SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) END SUBROUTINE build_compute_remapdata + ! ---------- + SUBROUTINE validate_compute_push_layout (pushdata, send_size, recv_size) + + IMPLICIT NONE + + type(compute_pushdata_type), intent(in) :: pushdata + integer, intent(in) :: send_size, recv_size + + integer :: irank + + IF (send_size < 0 .or. recv_size < 0 .or. pushdata%num_req_uniq < 0 .or. & + pushdata%num_req_uniq > recv_size .or. pushdata%nself < 0) THEN + CALL CoLM_stop('Invalid dimensions in CoLM compute push layout.') + ENDIF + + IF (pushdata%nself > 0) THEN + IF (.not. allocated(pushdata%self_from) .or. .not. allocated(pushdata%self_to)) THEN + CALL CoLM_stop('Incomplete self-address vectors in CoLM compute push layout.') + ENDIF + IF (size(pushdata%self_from) < pushdata%nself .or. size(pushdata%self_to) < pushdata%nself) THEN + CALL CoLM_stop('Short self-address vectors in CoLM compute push layout.') + ENDIF + IF (any(pushdata%self_from(1:pushdata%nself) < 1) .or. & + any(pushdata%self_from(1:pushdata%nself) > send_size) .or. & + any(pushdata%self_to(1:pushdata%nself) < 1) .or. & + any(pushdata%self_to(1:pushdata%nself) > recv_size)) THEN + CALL CoLM_stop('Out-of-range self address in CoLM compute push layout.') + ENDIF + ENDIF + +#ifdef MPAS_MPI + IF (.not. allocated(pushdata%n_to_other) .or. .not. allocated(pushdata%n_from_other) .or. & + .not. allocated(pushdata%to_other) .or. .not. allocated(pushdata%other_to)) THEN + CALL CoLM_stop('Incomplete remote-address tables in CoLM compute push layout.') + ENDIF + IF (lbound(pushdata%n_to_other,1) > 0 .or. ubound(pushdata%n_to_other,1) < mpas_size-1 .or. & + lbound(pushdata%n_from_other,1) > 0 .or. ubound(pushdata%n_from_other,1) < mpas_size-1 .or. & + lbound(pushdata%to_other,1) > 0 .or. ubound(pushdata%to_other,1) < mpas_size-1 .or. & + lbound(pushdata%other_to,1) > 0 .or. ubound(pushdata%other_to,1) < mpas_size-1) THEN + CALL CoLM_stop('Remote-address table bounds do not match the CoLM compute communicator.') + ENDIF + IF (any(pushdata%n_to_other(0:mpas_size-1) < 0) .or. & + any(pushdata%n_from_other(0:mpas_size-1) < 0)) THEN + CALL CoLM_stop('Negative remote message count in CoLM compute push layout.') + ENDIF + + DO irank = 0, mpas_size-1 + IF (pushdata%n_to_other(irank) > 0) THEN + IF (.not. allocated(pushdata%to_other(irank)%val)) THEN + CALL CoLM_stop('Missing remote send addresses in CoLM compute push layout.') + ENDIF + IF (size(pushdata%to_other(irank)%val) < pushdata%n_to_other(irank) .or. & + any(pushdata%to_other(irank)%val(1:pushdata%n_to_other(irank)) < 1) .or. & + any(pushdata%to_other(irank)%val(1:pushdata%n_to_other(irank)) > send_size)) THEN + CALL CoLM_stop('Out-of-range remote send address in CoLM compute push layout.') + ENDIF + ENDIF + IF (pushdata%n_from_other(irank) > 0) THEN + IF (.not. allocated(pushdata%other_to(irank)%val)) THEN + CALL CoLM_stop('Missing remote receive addresses in CoLM compute push layout.') + ENDIF + IF (size(pushdata%other_to(irank)%val) < pushdata%n_from_other(irank) .or. & + any(pushdata%other_to(irank)%val(1:pushdata%n_from_other(irank)) < 1) .or. & + any(pushdata%other_to(irank)%val(1:pushdata%n_from_other(irank)) > recv_size)) THEN + CALL CoLM_stop('Out-of-range remote receive address in CoLM compute push layout.') + ENDIF + ENDIF + ENDDO +#endif + + END SUBROUTINE validate_compute_push_layout + ! ---------- SUBROUTINE compute_push_data_uniq_real8 ( & pushdata, vec_send, vec_recv, fillvalue) @@ -661,7 +644,12 @@ SUBROUTINE compute_push_data_uniq_real8 ( & integer :: irank, iproc, idsp, istt, iend, i, i_to - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (.not. present(vec_send) .or. .not. present(vec_recv) .or. .not. present(fillvalue)) THEN + CALL CoLM_stop('CoLM real compute push requires send, receive, and fill-value arguments.') + ENDIF + CALL validate_compute_push_layout(pushdata, size(vec_send), size(vec_recv)) IF (pushdata%num_req_uniq > 0) THEN vec_recv = fillvalue @@ -671,7 +659,7 @@ SUBROUTINE compute_push_data_uniq_real8 ( & vec_recv(pushdata%self_to) = vec_send(pushdata%self_from) ENDIF -#ifdef COLM_PARALLEL +#ifdef MPAS_MPI ndatasend = sum(pushdata%n_to_other) IF (ndatasend > 0) THEN @@ -680,7 +668,7 @@ SUBROUTINE compute_push_data_uniq_real8 ( & iproc = 0 idsp = 0 - DO irank = 0, p_np_compute-1 + DO irank = 0, mpas_size-1 IF (pushdata%n_to_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 @@ -688,7 +676,8 @@ SUBROUTINE compute_push_data_uniq_real8 ( & sendcache(istt:iend) = vec_send(pushdata%to_other(irank)%val) CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(irank), MPI_REAL8, & - irank, 101, p_comm_compute, req_send(iproc), p_err) + irank, 101, mpas_comm, req_send(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push data send') idsp = iend ENDIF @@ -703,14 +692,15 @@ SUBROUTINE compute_push_data_uniq_real8 ( & iproc = 0 idsp = 0 - DO irank = 0, p_np_compute-1 + DO irank = 0, mpas_size-1 IF (pushdata%n_from_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 iend = idsp + pushdata%n_from_other(irank) CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(irank), MPI_REAL8, & - irank, 101, p_comm_compute, req_recv(iproc), p_err) + irank, 101, mpas_comm, req_recv(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push data receive') idsp = iend ENDIF @@ -719,10 +709,11 @@ SUBROUTINE compute_push_data_uniq_real8 ( & IF (ndatarecv > 0) THEN - CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) + CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push receive completion') idsp = 0 - DO irank = 0, p_np_compute-1 + DO irank = 0, mpas_size-1 DO i = 1, pushdata%n_from_other(irank) IF (recvcache(idsp+i) /= fillvalue) THEN @@ -741,7 +732,8 @@ SUBROUTINE compute_push_data_uniq_real8 ( & ENDIF IF (ndatasend > 0) THEN - CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, p_err) + CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push send completion') ENDIF IF (allocated(req_send )) deallocate(req_send ) @@ -778,7 +770,12 @@ SUBROUTINE compute_push_data_uniq_int32 ( & integer :: irank, iproc, idsp, istt, iend, i, i_to - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (.not. present(vec_send) .or. .not. present(vec_recv) .or. .not. present(fillvalue)) THEN + CALL CoLM_stop('CoLM integer compute push requires send, receive, and fill-value arguments.') + ENDIF + CALL validate_compute_push_layout(pushdata, size(vec_send), size(vec_recv)) IF (pushdata%num_req_uniq > 0) THEN vec_recv = fillvalue @@ -788,7 +785,7 @@ SUBROUTINE compute_push_data_uniq_int32 ( & vec_recv(pushdata%self_to) = vec_send(pushdata%self_from) ENDIF -#ifdef COLM_PARALLEL +#ifdef MPAS_MPI ndatasend = sum(pushdata%n_to_other) IF (ndatasend > 0) THEN @@ -797,7 +794,7 @@ SUBROUTINE compute_push_data_uniq_int32 ( & iproc = 0 idsp = 0 - DO irank = 0, p_np_compute-1 + DO irank = 0, mpas_size-1 IF (pushdata%n_to_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 @@ -805,7 +802,8 @@ SUBROUTINE compute_push_data_uniq_int32 ( & sendcache(istt:iend) = vec_send(pushdata%to_other(irank)%val) CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(irank), MPI_INTEGER, & - irank, 101, p_comm_compute, req_send(iproc), p_err) + irank, 101, mpas_comm, req_send(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push data send') idsp = iend ENDIF @@ -820,14 +818,15 @@ SUBROUTINE compute_push_data_uniq_int32 ( & iproc = 0 idsp = 0 - DO irank = 0, p_np_compute-1 + DO irank = 0, mpas_size-1 IF (pushdata%n_from_other(irank) > 0) THEN iproc = iproc + 1 istt = idsp + 1 iend = idsp + pushdata%n_from_other(irank) CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(irank), MPI_INTEGER, & - irank, 101, p_comm_compute, req_recv(iproc), p_err) + irank, 101, mpas_comm, req_recv(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push data receive') idsp = iend ENDIF @@ -836,10 +835,11 @@ SUBROUTINE compute_push_data_uniq_int32 ( & IF (ndatarecv > 0) THEN - CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err) + CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push receive completion') idsp = 0 - DO irank = 0, p_np_compute-1 + DO irank = 0, mpas_size-1 DO i = 1, pushdata%n_from_other(irank) IF (recvcache(idsp+i) /= fillvalue) THEN @@ -858,7 +858,8 @@ SUBROUTINE compute_push_data_uniq_int32 ( & ENDIF IF (ndatasend > 0) THEN - CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, p_err) + CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push send completion') ENDIF IF (allocated(req_send )) deallocate(req_send ) @@ -885,7 +886,16 @@ SUBROUTINE compute_push_data_single_real8 (pushdata, vec_send, vec_recv, fillval ! Local Variables real(r8), allocatable :: vec_recv_uniq (:) - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (size(vec_recv) > 0) vec_recv = fillvalue + IF (allocated(pushdata%addr_single)) THEN + IF (size(vec_recv) < size(pushdata%addr_single)) THEN + CALL CoLM_stop('Receive array is too small for single CoLM compute push data.') + ENDIF + ELSEIF (pushdata%num_req_uniq > 0) THEN + CALL CoLM_stop('Single CoLM compute push data has no request-address map.') + ENDIF ! Always allocate (zero-length if no requests) to avoid passing ! unallocated array to compute_push_data_uniq_real8. @@ -896,8 +906,8 @@ SUBROUTINE compute_push_data_single_real8 (pushdata, vec_send, vec_recv, fillval CALL compute_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) - IF (pushdata%num_req_uniq > 0) THEN - vec_recv = vec_recv_uniq(pushdata%addr_single) + IF (pushdata%num_req_uniq > 0 .and. allocated(pushdata%addr_single)) THEN + vec_recv(1:size(pushdata%addr_single)) = vec_recv_uniq(pushdata%addr_single) ENDIF deallocate (vec_recv_uniq) @@ -923,7 +933,19 @@ SUBROUTINE compute_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalu integer :: i, j real(r8) :: val, sumarea - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (trim(mode) /= 'sum' .and. trim(mode) /= 'average') THEN + CALL CoLM_stop('CoLM multi compute push mode must be sum or average.') + ENDIF + IF (size(vec_recv) > 0) vec_recv = fillvalue + IF (allocated(pushdata%addr_multi)) THEN + IF (size(vec_recv) < size(pushdata%addr_multi, 2)) THEN + CALL CoLM_stop('Receive array is too small for multi CoLM compute push data.') + ENDIF + ELSEIF (pushdata%num_req_uniq > 0) THEN + CALL CoLM_stop('Multi CoLM compute push data has no request-address map.') + ENDIF ! Always allocate (zero-length if no requests) to avoid passing ! unallocated array to compute_push_data_uniq_real8. @@ -936,8 +958,6 @@ SUBROUTINE compute_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalu IF (pushdata%num_req_uniq > 0) THEN - vec_recv(:) = fillvalue - DO j = 1, size(pushdata%addr_multi,2) sumarea = 0. @@ -956,7 +976,11 @@ SUBROUTINE compute_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalu IF (trim(mode) == 'average') THEN IF (vec_recv(j) /= fillvalue) THEN - vec_recv(j) = vec_recv(j) / sumarea + IF (sumarea > 0._r8) THEN + vec_recv(j) = vec_recv(j) / sumarea + ELSE + vec_recv(j) = fillvalue + ENDIF ENDIF ENDIF ENDDO @@ -982,7 +1006,16 @@ SUBROUTINE compute_push_data_single_int32 (pushdata, vec_send, vec_recv, fillval ! Local Variables integer, allocatable :: vec_recv_uniq (:) - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (size(vec_recv) > 0) vec_recv = fillvalue + IF (allocated(pushdata%addr_single)) THEN + IF (size(vec_recv) < size(pushdata%addr_single)) THEN + CALL CoLM_stop('Receive array is too small for integer CoLM compute push data.') + ENDIF + ELSEIF (pushdata%num_req_uniq > 0) THEN + CALL CoLM_stop('Integer CoLM compute push data has no request-address map.') + ENDIF allocate (vec_recv_uniq (pushdata%num_req_uniq)) IF (pushdata%num_req_uniq > 0) THEN @@ -991,8 +1024,8 @@ SUBROUTINE compute_push_data_single_int32 (pushdata, vec_send, vec_recv, fillval CALL compute_push_data_uniq_int32 (pushdata, vec_send, vec_recv_uniq, fillvalue) - IF (pushdata%num_req_uniq > 0) THEN - vec_recv = vec_recv_uniq(pushdata%addr_single) + IF (pushdata%num_req_uniq > 0 .and. allocated(pushdata%addr_single)) THEN + vec_recv(1:size(pushdata%addr_single)) = vec_recv_uniq(pushdata%addr_single) ENDIF deallocate (vec_recv_uniq) @@ -1017,7 +1050,13 @@ SUBROUTINE compute_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillv real(r8) :: area - IF (p_is_compute) THEN + IF (.true.) THEN + IF (size(vec_in) < remapdata%npset .or. size(filter) < remapdata%npset) THEN + CALL CoLM_stop('Pixel-set input is too small for CoLM compute remap data.') + ENDIF + IF (size(vec_out) < remapdata%num_grid) THEN + CALL CoLM_stop('Grid output is too small for CoLM compute remap data.') + ENDIF IF (remapdata%num_grid > 0) THEN vec_out(:) = fillvalue @@ -1028,6 +1067,9 @@ SUBROUTINE compute_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillv iloc = remapdata%part_to(iset)%val(ipart) area = remapdata%areapart(iset)%val(ipart) + IF (iloc < 1 .or. iloc > remapdata%num_grid) THEN + CALL CoLM_stop('Pixel-set to grid remap contains an invalid target address.') + ENDIF IF (vec_out(iloc) == fillvalue) THEN vec_out(iloc) = vec_in(iset) * area @@ -1061,7 +1103,16 @@ SUBROUTINE compute_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillv integer :: iset, ipart, iloc real(r8) :: area, sumarea - IF (p_is_compute) THEN + IF (.true.) THEN + IF (trim(mode) /= 'sum' .and. trim(mode) /= 'average') THEN + CALL CoLM_stop('CoLM compute remap mode must be sum or average.') + ENDIF + IF (size(vec_in) < remapdata%num_grid) THEN + CALL CoLM_stop('Grid input is too small for CoLM compute remap data.') + ENDIF + IF (size(vec_out) < remapdata%npset) THEN + CALL CoLM_stop('Pixel-set output is too small for CoLM compute remap data.') + ENDIF IF (remapdata%npset > 0) THEN vec_out(:) = fillvalue @@ -1073,6 +1124,9 @@ SUBROUTINE compute_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillv DO ipart = 1, remapdata%npart(iset) iloc = remapdata%part_to(iset)%val(ipart) area = remapdata%areapart(iset)%val(ipart) + IF (iloc < 1 .or. iloc > remapdata%num_grid) THEN + CALL CoLM_stop('Grid to pixel-set remap contains an invalid source address.') + ENDIF IF (vec_in(iloc) /= fillvalue) THEN IF (vec_out(iset) == fillvalue) THEN @@ -1086,7 +1140,11 @@ SUBROUTINE compute_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillv IF (trim(mode) == 'average') THEN IF (vec_out(iset) /= fillvalue) THEN - vec_out(iset) = vec_out(iset) / sumarea + IF (sumarea > 0._r8 .and. ieee_is_finite(sumarea)) THEN + vec_out(iset) = vec_out(iset) / sumarea + ELSE + vec_out(iset) = fillvalue + ENDIF ENDIF ENDIF ENDDO @@ -1108,7 +1166,7 @@ SUBROUTINE compute_pushdata_free_mem (this) IF (allocated(this%sum_area )) deallocate(this%sum_area ) IF (allocated(this%self_from )) deallocate(this%self_from ) IF (allocated(this%self_to )) deallocate(this%self_to ) -#ifdef COLM_PARALLEL +#ifdef MPAS_MPI IF (allocated(this%n_to_other )) deallocate(this%n_to_other ) IF (allocated(this%n_from_other)) deallocate(this%n_from_other) IF (allocated(this%to_other )) deallocate(this%to_other ) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 index 54d355350e..61fc85e9c3 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 @@ -223,7 +223,7 @@ SUBROUTINE allocate_block_data_int32_2d (grid, gdata) USE MOD_Grid USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(grid_type), intent(in) :: grid @@ -285,7 +285,7 @@ SUBROUTINE allocate_block_data_real8_2d (grid, gdata) USE MOD_Grid USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(grid_type), intent(in) :: grid @@ -347,7 +347,7 @@ SUBROUTINE allocate_block_data_real8_3d (grid, gdata, ndim1, lb1) USE MOD_Grid USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(grid_type), intent(in) :: grid @@ -419,7 +419,7 @@ SUBROUTINE allocate_block_data_real8_4d (grid, gdata, ndim1, ndim2, lb1, lb2) USE MOD_Grid USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(grid_type), intent(in) :: grid @@ -487,7 +487,7 @@ SUBROUTINE flush_block_data_real8_2d (gdata, spval) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_real8_2d), intent(inout) :: gdata @@ -509,7 +509,7 @@ SUBROUTINE flush_block_data_int32_2d (gdata, spval) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_int32_2d), intent(inout) :: gdata @@ -531,7 +531,7 @@ SUBROUTINE flush_block_data_real8_3d (gdata, spval) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_real8_3d), intent(inout) :: gdata @@ -553,7 +553,7 @@ SUBROUTINE flush_block_data_real8_4d (gdata, spval) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_real8_4d), intent(inout) :: gdata @@ -575,7 +575,7 @@ SUBROUTINE block_data_linear_transform (gdata, scl, dsp) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_real8_2d), intent(inout) :: gdata @@ -608,7 +608,7 @@ SUBROUTINE block_data_copy (gdata_from, gdata_to, sca) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_real8_2d), intent(in) :: gdata_from @@ -636,7 +636,7 @@ SUBROUTINE block_data_linear_interp ( & USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type(block_data_real8_2d), intent(in) :: gdata_from1, gdata_from2 @@ -661,7 +661,7 @@ SUBROUTINE block_data_division (gdata, sumdata, spv) USE MOD_Precision USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -672,7 +672,7 @@ SUBROUTINE block_data_division (gdata, sumdata, spv) ! Local variables integer :: iblkme, iblk, jblk - IF (p_is_active) THEN + IF (.true.) THEN IF (.not. present(spv)) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 deleted file mode 100644 index 4f14eaf2af..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90 +++ /dev/null @@ -1,188 +0,0 @@ -#include - -#if (defined UNSTRUCTURED || defined CATCHMENT) -MODULE MOD_ElmVector - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Address of Data associated with land element. -! -! To output a vector, Data is gathered from compute ranks directly to -! root rank. "elm_data_address" stores information on how to reorganize data -! gathered. The output data in vector is sorted by global element index. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_DataType - IMPLICIT NONE - - integer :: totalnumelm - type(pointer_int32_1d), allocatable :: elm_data_address (:) - - integer*8, allocatable :: eindex_glb (:) - -CONTAINS - - ! -------- - SUBROUTINE elm_vector_init - - USE MOD_SPMD_Task - USE MOD_Utils - USE MOD_Pixelset - USE MOD_Utils - USE MOD_UserDefFun - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch -#ifdef CROP - USE MOD_LandCrop -#endif - IMPLICIT NONE - - ! Local Variables - integer :: mesg(2), iwork, isrc, ndata - integer, allocatable :: numelm_rank (:) - - integer :: i, idsp - integer, allocatable :: vec_rank_dsp (:) - - integer*8, allocatable :: indexelm (:) - integer, allocatable :: order (:) - - IF (p_is_compute) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) - ENDIF - - IF (p_is_compute) THEN -#ifdef USEMPI - IF (numelm > 0) THEN - allocate (indexelm (numelm)) - indexelm = landelm%eindex - ENDIF - - IF (p_iam_compute == p_root) allocate (numelm_rank (0:p_np_compute-1)) - CALL mpi_gather (numelm, 1, MPI_INTEGER, & - numelm_rank, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN -#ifndef MPAS_EMBEDDED_COLM - CALL mpi_send (numelm_rank, p_np_compute, MPI_INTEGER, & - p_address_root, mpi_tag_size, p_comm_glb, p_err) -#endif - ENDIF - - mesg = (/p_iam_glb, numelm/) -#ifdef MPAS_EMBEDDED_COLM - IF (.not. (p_is_root .and. p_iam_compute == p_root)) THEN -#endif - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numelm > 0) THEN - CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#ifdef MPAS_EMBEDDED_COLM - ENDIF -#endif -#else - IF (numelm > 0) THEN - allocate (eindex_glb (numelm)) - eindex_glb = landelm%eindex - ENDIF -#endif - ENDIF - - IF (p_is_root) THEN -#ifdef USEMPI -#ifndef MPAS_EMBEDDED_COLM - allocate (numelm_rank (0:p_np_compute-1)) - CALL mpi_recv (numelm_rank, p_np_compute, MPI_INTEGER, p_address_compute(p_root), & - mpi_tag_size, p_comm_glb, p_stat, p_err) -#endif - - allocate (vec_rank_dsp (0:p_np_compute-1)) - vec_rank_dsp(0) = 0 - DO iwork = 1, p_np_compute-1 - vec_rank_dsp(iwork) = vec_rank_dsp(iwork-1) + numelm_rank(iwork-1) - ENDDO - - totalnumelm = sum(numelm_rank) - - allocate (eindex_glb (totalnumelm)) - - allocate (elm_data_address(0:p_np_compute-1)) - DO iwork = 0, p_np_compute-1 - IF (numelm_rank(iwork) > 0) THEN - allocate (elm_data_address(iwork)%val (numelm_rank(iwork))) - ENDIF - ENDDO - - DO iwork = 0, p_np_compute-1 -#ifdef MPAS_EMBEDDED_COLM - IF (iwork == p_root) THEN - ndata = numelm_rank(iwork) - IF (ndata > 0) THEN - idsp = vec_rank_dsp(iwork) - eindex_glb(idsp+1:idsp+ndata) = indexelm(1:ndata) - ENDIF - CYCLE - ENDIF -#endif - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - idsp = vec_rank_dsp(p_itis_compute(isrc)) - CALL mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER8, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDDO -#else - totalnumelm = numelm - allocate (elm_data_address(0:0)) - allocate (elm_data_address(0)%val (totalnumelm)) -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (totalnumelm, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) -#endif - - IF (p_is_root) THEN - allocate (order (totalnumelm)) - order = (/(i, i=1,totalnumelm)/) - - CALL quicksort (totalnumelm, eindex_glb, order) - -#ifdef USEMPI - DO i = 1, totalnumelm - iwork = findloc_ud(order(i) > vec_rank_dsp, back=.true.) - 1 - elm_data_address(iwork)%val(order(i)-vec_rank_dsp(iwork)) = i - ENDDO -#else - elm_data_address(0)%val (order) = (/(i, i=1,totalnumelm)/) -#endif - ENDIF - - IF (allocated(numelm_rank)) deallocate(numelm_rank) - IF (allocated(vec_rank_dsp)) deallocate(vec_rank_dsp) - IF (allocated(indexelm)) deallocate(indexelm) - IF (allocated(order)) deallocate(order) - - END SUBROUTINE elm_vector_init - - ! ---------- - SUBROUTINE elm_vector_final () - - IMPLICIT NONE - - IF (allocated(elm_data_address)) deallocate (elm_data_address) - IF (allocated(eindex_glb)) deallocate (eindex_glb) - - END SUBROUTINE elm_vector_final - -END MODULE MOD_ElmVector -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 index 1b61638bfb..d4a9842254 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 @@ -112,10 +112,6 @@ MODULE MOD_Grid final :: grid_concat_free_mem END type grid_concat_type - - ! -- PUBLIC SUBROUTINEs -- - PUBLIC :: get_region_by_this_IO - CONTAINS ! -------------------------------- @@ -417,13 +413,12 @@ SUBROUTINE grid_define_from_file (this, filename, latname, lonname) END SUBROUTINE grid_define_from_file !----------------------------------------------------- - SUBROUTINE grid_define_by_copy (this, grid_in) + RECURSIVE SUBROUTINE grid_define_by_copy (this, grid_in) USE MOD_NetCDFSerial IMPLICIT NONE - class (grid_type) :: this - - type(grid_type) :: grid_in + class(grid_type), intent(inout) :: this + type(grid_type), intent(in) :: grid_in CALL this%init (grid_in%nlon, grid_in%nlat) @@ -923,7 +918,7 @@ SUBROUTINE set_grid_concat (this, grid) DO ixseg = 1, this%nxseg iblk = this%xsegs(ixseg)%blk jblk = this%ysegs(iyseg)%blk - IF (gblock%pio(iblk,jblk) >= 0) THEN + IF (gblock%owner_rank(iblk,jblk) >= 0) THEN this%ndatablk = this%ndatablk + 1 ENDIF ENDDO @@ -950,55 +945,4 @@ SUBROUTINE grid_concat_free_mem (this) END SUBROUTINE grid_concat_free_mem - ! ------- - SUBROUTINE get_region_by_this_IO ( grid, & - west, east, north, south, iwest, ieast, isouth, inorth) - - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - type(grid_type), intent(in) :: grid - - real(r8), intent(out) :: west, east, north, south - integer, intent(out) :: iwest, ieast, inorth, isouth - - ! Local Variables - integer :: iblk, jblk - - IF (p_is_active) THEN - - IF (gblock%nblkme /= 1) THEN - write(*,*) 'Warning: more than one block is on IO processor: ', p_iam_glb - west = spval; iwest = -1 - east = spval; ieast = -1 - north = spval; inorth = -1 - south = spval; isouth = -1 - RETURN - ENDIF - - iblk = gblock%xblkme(1) - jblk = gblock%yblkme(1) - - iwest = grid%xdsp(iblk) + 1 - ieast = grid%xdsp(iblk) + grid%xcnt(iblk) - - IF (grid%yinc == 1) THEN - inorth = grid%ydsp(jblk) + grid%ycnt(jblk) - isouth = grid%ydsp(jblk) + 1 - ELSE - inorth = grid%ydsp(jblk) + 1 - isouth = grid%ydsp(jblk) + grid%ycnt(jblk) - ENDIF - - west = grid%lon_w(iwest ) - east = grid%lon_e(ieast ) - north = grid%lat_n(inorth) - south = grid%lat_s(isouth) - - ENDIF - - END SUBROUTINE get_region_by_this_IO - END MODULE MOD_Grid diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 deleted file mode 100644 index 8115d9cab3..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 +++ /dev/null @@ -1,215 +0,0 @@ -#include - -#if (defined CATCHMENT) -MODULE MOD_HRUVector - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Address of Data associated with HRU. -! -! To output a vector, Data is gathered from compute ranks directly to -! root rank. "hru_data_address" stores information on how to reorganize data -! gathered. The output data in vector is sorted by global element index -! (i.e. catchment index) -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_DataType - IMPLICIT NONE - - integer :: totalnumhru - type(pointer_int32_1d), allocatable :: hru_data_address (:) - - integer*8, allocatable :: eindx_hru (:) - integer, allocatable :: htype_hru (:) - -CONTAINS - - ! -------- - SUBROUTINE hru_vector_init - - USE MOD_SPMD_Task - USE MOD_Utils - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandHRU - USE MOD_LandPatch - USE MOD_ElmVector -#ifdef CROP - USE MOD_LandCrop -#endif - IMPLICIT NONE - - ! Local Variables - integer :: mesg(2), iwork, isrc, ndata - - integer, allocatable :: nhru_bsn (:) - integer, allocatable :: nhru_bsn_glb (:) - integer, allocatable :: rbuff (:) - - integer, allocatable :: hru_dsp_glb (:) - integer :: ielm, i, ielm_glb - - integer :: nhru, nelm, hru_dsp_loc - - IF (p_is_compute) THEN - - CALL elm_hru%build (landelm, landhru, use_frac = .true.) - - CALL hru_patch%build (landhru, landpatch, use_frac = .true.) - - IF (numelm > 0) THEN - allocate (nhru_bsn (numelm)) - nhru_bsn = elm_hru%subend - elm_hru%substt + 1 - ENDIF - -#ifdef USEMPI - mesg = (/p_iam_glb, numelm/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numelm > 0) THEN - CALL mpi_send (nhru_bsn, numelm, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF -#endif - ENDIF - - IF (p_is_root) THEN - - allocate (hru_data_address (0:p_np_compute-1)) - - allocate (nhru_bsn_glb (totalnumelm)) - -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate (rbuff (ndata)) - - CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - - nhru_bsn_glb(elm_data_address(p_itis_compute(isrc))%val) = rbuff - - IF (sum(rbuff) > 0) THEN - allocate(hru_data_address(p_itis_compute(isrc))%val (sum(rbuff))) - ENDIF - - deallocate(rbuff) - ENDIF - ENDDO -#else - nhru_bsn_glb(elm_data_address(0)%val) = nhru_bsn - IF (sum(nhru_bsn) > 0) THEN - allocate(hru_data_address(0)%val (sum(nhru_bsn))) - ENDIF -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_root) THEN - - totalnumhru = sum(nhru_bsn_glb) - - allocate (hru_dsp_glb (totalnumelm)) - hru_dsp_glb(1) = 0 - DO ielm = 2, totalnumelm - hru_dsp_glb(ielm) = hru_dsp_glb(ielm-1) + nhru_bsn_glb(ielm-1) - ENDDO - - DO iwork = 0, p_np_compute-1 - IF (allocated(elm_data_address(iwork)%val)) THEN - nelm = size(elm_data_address(iwork)%val) - hru_dsp_loc = 0 - DO ielm = 1, nelm - ielm_glb = elm_data_address(iwork)%val(ielm) - nhru = nhru_bsn_glb(ielm_glb) - IF (nhru > 0) THEN - hru_data_address(iwork)%val (hru_dsp_loc+1:hru_dsp_loc+nhru) = & - (/ (i, i = hru_dsp_glb(ielm_glb)+1, hru_dsp_glb(ielm_glb)+nhru) /) - hru_dsp_loc = hru_dsp_loc + nhru - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF -#ifdef USEMPI - CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_compute) THEN - mesg = (/p_iam_glb, numhru/) - CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err) - IF (numhru > 0) THEN - CALL mpi_send (landhru%settyp, numhru, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDIF -#endif - - IF (p_is_root) THEN - - allocate (eindx_hru (totalnumhru)) - - DO ielm = 1, totalnumelm - eindx_hru(hru_dsp_glb(ielm)+1:hru_dsp_glb(ielm)+nhru_bsn_glb(ielm)) = & - eindex_glb(ielm) - ENDDO - - allocate (htype_hru (totalnumhru)) - -#ifdef USEMPI - DO iwork = 0, p_np_compute-1 - CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = mesg(1) - ndata = mesg(2) - IF (ndata > 0) THEN - allocate (rbuff (ndata)) - - CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, & - mpi_tag_data, p_comm_glb, p_stat, p_err) - htype_hru(hru_data_address(p_itis_compute(isrc))%val) = rbuff - - deallocate(rbuff) - ENDIF - ENDDO -#else - htype_hru(hru_data_address(0)%val) = landhru%settyp -#endif - - ! To distinguish between lake HRUs and hillslopes, the program sets the - ! type of lake HRUs as a negative number. - ! Set it as a positive number for output. - htype_hru = abs(htype_hru) - - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) -#endif - - END SUBROUTINE hru_vector_init - - ! ---------- - SUBROUTINE hru_vector_final () - - IMPLICIT NONE - - IF (allocated(hru_data_address)) deallocate (hru_data_address) - IF (allocated(eindx_hru)) deallocate (eindx_hru) - IF (allocated(htype_hru)) deallocate (htype_hru) - - END SUBROUTINE hru_vector_final - -END MODULE MOD_HRUVector -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90 deleted file mode 100644 index e646025a2b..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90 +++ /dev/null @@ -1,249 +0,0 @@ -#include - -MODULE MOD_Land2mWMO - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Build a virtual patch "land2mWMO" for output 2 m WMO temperature. -! -! Created by Wenzong Dong and Hua Yuan, 2025/08 -! -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Grid - USE MOD_Pixelset - USE MOD_LandPatch - USE MOD_LandElm - USE MOD_Vars_Global - USE MOD_Const_LC - IMPLICIT NONE - - ! ---- Instance ---- - integer, allocatable :: wmo_patch (:) !2m wmo patch index - integer, allocatable :: wmo_source (:) !source patch of a wmo patch - -CONTAINS - - ! ------------------------------- - SUBROUTINE land2mwmo_build (lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Utils - USE MOD_UserDefFun - USE MOD_Grid - USE MOD_DataType - USE MOD_Mesh - USE MOD_LandElm - USE MOD_Namelist - USE MOD_NetCDFBlock - - IMPLICIT NONE - - integer, intent(in) :: lc_year - character(len=255) :: cyear - - integer :: numpatch_ - integer :: numset - integer :: iset - integer :: spatch, epatch, ipatch, jpatch - integer :: ipth, numpxl, numpth - integer :: src_pth, pthtype, maxpxl - integer*8, allocatable :: eindex_(:) - integer, allocatable :: settyp_(:), ipxstt_(:), ipxend_(:), ielm_(:) - integer, allocatable :: locpth(:) - - integer :: npatch_glb - integer :: numwmo - - write(cyear,'(i4.4)') lc_year - IF (p_is_root) THEN - write(*,'(A)') 'Making land 2 m wmo patches:' - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_compute) THEN - - numset = numelm - - numwmo = 0 - numpatch_ = 0 - jpatch = 0 - - ! Count for 2 m WMO patches need to be set virtually - DO iset = 1, numset - - numpth = count(landpatch%eindex==landelm%eindex(iset)) - IF (allocated(locpth)) deallocate(locpth) - allocate(locpth(numpth)) - locpth = pack([(ipth, ipth=1, numpatch)], & - landpatch%eindex==landelm%eindex(iset)) - - spatch = minval(locpth) ! elm_patch%substt(iset) - epatch = maxval(locpth) ! elm_patch%subend(iset) - - maxpxl = 0 - src_pth = -1 - - DO ipatch = spatch, epatch - - pthtype = patchtypes(landpatch%settyp(ipatch)) - numpxl = landpatch%ipxend(ipatch) - landpatch%ipxstt(ipatch) + 1 - - IF (numpxl>maxpxl .and. pthtype==0) THEN - maxpxl = numpxl - src_pth = ipatch - ENDIF - ENDDO - - ! a new 2m WMO patch - IF (src_pth /= -1) THEN - wmo_source (iset) = src_pth - numwmo = numwmo + 1 - landelm%settyp(iset) = 1 - ELSE - wmo_source (iset) = -1 - ENDIF - - ENDDO - - ! allocate new temporal patches memory - IF (numpatch > 0) THEN - ! a numpatch with WMO patch number - numpatch_ = numpatch + numwmo - - allocate (eindex_ (numpatch_ )) - allocate (ipxstt_ (numpatch_ )) - allocate (ipxend_ (numpatch_ )) - allocate (settyp_ (numpatch_ )) - allocate (ielm_ (numpatch_ )) - - ENDIF - - numwmo = 0 - - ! set for new 2 m WMO patch - DO iset = 1, numset - numpth = count(landpatch%eindex==landelm%eindex(iset)) - - IF (allocated(locpth)) deallocate(locpth) - allocate(locpth(numpth)) - - locpth = pack([(ipth, ipth=1, numpatch)], & - landpatch%eindex==landelm%eindex(iset)) - - spatch = minval(locpth) ! elm_patch%substt(iset) - epatch = maxval(locpth) ! elm_patch%subend(iset) - - DO ipatch = spatch, epatch - jpatch = jpatch + 1 - eindex_(jpatch) = landpatch%eindex(ipatch) - settyp_(jpatch) = landpatch%settyp(ipatch) - ipxstt_(jpatch) = landpatch%ipxstt(ipatch) - ipxend_(jpatch) = landpatch%ipxend(ipatch) - ielm_ (jpatch) = landpatch%ielm (ipatch) - ENDDO - - IF (wmo_source(iset) > 0) THEN - jpatch = jpatch + 1 - eindex_(jpatch) = landpatch%eindex(epatch) - settyp_(jpatch) = landpatch%settyp(wmo_source(iset)) - ipxstt_(jpatch) = -1 - ipxend_(jpatch) = -1 - ielm_ (jpatch) = landpatch%ielm (epatch) - - ! update the newly 2m WMO source/patch index - wmo_patch (iset) = jpatch - wmo_source(iset) = wmo_source(iset) + numwmo - numwmo = numwmo + 1 - ENDIF - ENDDO - - ! 2m WMO patch number check - IF (jpatch .ne. numpatch_) THEN - write(*,'(A)') 'Count land 2 m WMO patches error! See MOD_Land2mWMO.F90.' - ENDIF - - ! set the new patch number - numpatch = numpatch_ - - ! allocate and save the new patches info - IF (numpatch > 0) THEN - ! update landpath with new patch number - IF (allocated (landpatch%eindex)) deallocate (landpatch%eindex) - IF (allocated (landpatch%ipxstt)) deallocate (landpatch%ipxstt) - IF (allocated (landpatch%ipxend)) deallocate (landpatch%ipxend) - IF (allocated (landpatch%settyp)) deallocate (landpatch%settyp) - IF (allocated (landpatch%ielm )) deallocate (landpatch%ielm ) - - allocate (landpatch%eindex (numpatch)) - allocate (landpatch%ipxstt (numpatch)) - allocate (landpatch%ipxend (numpatch)) - allocate (landpatch%settyp (numpatch)) - allocate (landpatch%ielm (numpatch)) - - ! update all information of landpatch - landpatch%eindex = eindex_(1:numpatch) - landpatch%ipxstt = ipxstt_(1:numpatch) - landpatch%ipxend = ipxend_(1:numpatch) - landpatch%settyp = settyp_(1:numpatch) - landpatch%ielm = ielm_ (1:numpatch) - - ENDIF - ENDIF - - landpatch%nset = numpatch - - CALL landpatch%set_vecgs - - IF (allocated (eindex_ )) deallocate (eindex_ ) - IF (allocated (settyp_ )) deallocate (settyp_ ) - IF (allocated (ipxstt_ )) deallocate (ipxstt_ ) - IF (allocated (ipxend_ )) deallocate (ipxend_ ) - IF (allocated (ielm_ )) deallocate (ielm_ ) - IF (allocated (locpth )) deallocate (locpth ) - -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' -#endif - - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) - - CALL write_patchfrac (DEF_dir_landdata, lc_year) - - END SUBROUTINE land2mwmo_build - - SUBROUTINE land2mwmo_init - USE MOD_Mesh - IMPLICIT NONE - - allocate (wmo_patch (numelm)) - allocate (wmo_source (numelm)) - - wmo_patch = -1 - wmo_source = -1 - - END SUBROUTINE land2mwmo_init - - SUBROUTINE land2mwmo_final - IMPLICIT NONE - - IF (allocated (wmo_patch )) deallocate (wmo_patch ) - IF (allocated (wmo_source)) deallocate (wmo_source) - - END SUBROUTINE land2mwmo_final - -END MODULE MOD_Land2mWMO diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 deleted file mode 100644 index 85ed62521c..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 +++ /dev/null @@ -1,152 +0,0 @@ -#include - -#ifdef CROP -MODULE MOD_LandCrop - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Build crop patches. -! -! Created by Shupeng Zhang, Sep 2023 -! porting codes from Hua Yuan's OpenMP version to MPI parallel version. -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Grid - IMPLICIT NONE - - ! ---- Instance ---- - type(grid_type) :: grid_crop - integer, allocatable :: cropclass (:) - real(r8), allocatable :: cropfrac (:) - -CONTAINS - - ! ------------------------------- - SUBROUTINE landcrop_build (lc_year) - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Block - USE MOD_DataType - USE MOD_LandElm -#ifdef CATCHMENT - USE MOD_LandHRU -#endif - USE MOD_LandPatch - USE MOD_NetCDFBlock - USE MOD_PixelsetShared - USE MOD_5x5DataReadin - - IMPLICIT NONE - - integer, intent(in) :: lc_year - - ! Local Variables - character(len=255) :: cyear, file_patch, dir_5x5, suffix - integer :: npatch_glb - type(block_data_real8_2d) :: pctcrop_xy - type(block_data_real8_3d) :: pctshared_xy - type(block_data_real8_3d) :: cropdata - integer :: sharedfilter(1), cropfilter(1) - integer :: iblkme, ib, jb - real(r8), allocatable :: pctshared (:) - integer , allocatable :: classshared(:) - - write(cyear,'(i4.4)') lc_year - IF (p_is_root) THEN - write(*,'(A)') 'Making patches (crop shared):' - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_active) THEN - - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(cyear) - - CALL allocate_block_data (grid_patch, pctcrop_xy) - CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'PCT_CROP', pctcrop_xy) - - CALL allocate_block_data (grid_patch, pctshared_xy, 2) - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - pctshared_xy%blk(ib,jb)%val(1,:,:) = 1. - pctcrop_xy%blk(ib,jb)%val/100. - pctshared_xy%blk(ib,jb)%val(2,:,:) = pctcrop_xy%blk(ib,jb)%val/100. - ENDDO - ENDIF - - sharedfilter = (/ 1 /) - - IF (landpatch%has_shared) then - CALL pixelsetshared_build (landpatch, grid_patch, pctshared_xy, 2, sharedfilter, & - pctshared, classshared, fracin = landpatch%pctshared) - ELSE - CALL pixelsetshared_build (landpatch, grid_patch, pctshared_xy, 2, sharedfilter, & - pctshared, classshared) - ENDIF - - IF (p_is_compute) THEN - IF (landpatch%nset > 0) THEN - WHERE (classshared == 2) landpatch%settyp = CROPLAND - ENDIF - ENDIF - - IF (p_is_active) THEN - file_patch = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc' - CALL allocate_block_data (grid_crop, cropdata, N_CFT) - CALL ncio_read_block (file_patch, 'PCT_CFT', grid_crop, N_CFT, cropdata) - ENDIF - - cropfilter = (/ CROPLAND /) - - CALL pixelsetshared_build (landpatch, grid_crop, cropdata, N_CFT, cropfilter, & - cropfrac, cropclass, fracin = pctshared) - - numpatch = landpatch%nset - - landpatch%has_shared = .true. - IF (p_is_compute) THEN - IF (numpatch > 0) THEN - IF (allocated(landpatch%pctshared)) THEN - deallocate(landpatch%pctshared) - ENDIF - - allocate(landpatch%pctshared(numpatch)) - landpatch%pctshared = cropfrac - ENDIF - ENDIF - - IF (allocated(pctshared )) deallocate(pctshared ) - IF (allocated(classshared)) deallocate(classshared) - -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches (with crop).' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' -#endif - -IF ( .not. DEF_Output_2mWMO ) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#ifdef CATCHMENT - CALL hru_patch%build (landhru, landpatch, use_frac = .true.) -#endif - - CALL write_patchfrac (DEF_dir_landdata, lc_year) -ENDIF - - END SUBROUTINE landcrop_build - -END MODULE MOD_LandCrop -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 index 69d75a4878..22710badca 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 @@ -32,18 +32,18 @@ MODULE MOD_LandElm SUBROUTINE landelm_build USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Mesh IMPLICIT NONE ! Local Variables integer :: ielm, nelm_glb - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(A)') 'Making land elements:' ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN allocate (landelm%eindex (numelm)) allocate (landelm%ipxstt (numelm)) @@ -64,17 +64,20 @@ SUBROUTINE landelm_build landelm%nset = numelm CALL landelm%set_vecgs -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('land-element count reduction entry') - IF (p_is_compute) THEN - CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN + IF (.true.) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('land-element count reduction') + IF (mpas_rank == 0) THEN write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements.' ENDIF ENDIF - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('land-element construction completion') #else write(*,'(A,I12,A)') 'Total: ', numelm, ' elements.' #endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 deleted file mode 100644 index 7e490ebf47..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90 +++ /dev/null @@ -1,252 +0,0 @@ -#include - -#ifdef CATCHMENT - -MODULE MOD_LandHRU - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Build pixelset "landhru". -! -! In CoLM, the global/regional area is divided into a hierarchical structure: -! 1. If GRIDBASED or UNSTRUCTURED is defined, it is -! ELEMENT >>> PATCH -! 2. If CATCHMENT is defined, it is -! ELEMENT >>> HRU >>> PATCH -! If Plant Function Type classification is used, PATCH is further divided into PFT. -! If Plant Community classification is used, PATCH is further divided into PC. -! -! "landhru" refers to pixelset HRU. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Pixelset - USE MOD_Grid - IMPLICIT NONE - - ! ---- Instance ---- - integer :: numhru - type(grid_type) :: grid_hru - type(pixelset_type) :: landhru - - type(subset_type) :: elm_hru - -CONTAINS - - ! ------------------------------- - SUBROUTINE landhru_build () - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_NetcdfSerial - USE MOD_Utils - USE MOD_Block - USE MOD_Grid - USE MOD_DataType - USE MOD_Mesh - USE MOD_LandElm - USE MOD_CatchmentDataReadin - USE MOD_Namelist - USE MOD_AggregationRequestData - - IMPLICIT NONE - - ! Local Variables - type (block_data_int32_2d) :: hrudata - integer :: iwork, ncat, nhru, ie, typsgn, npxl, ipxl - integer*8, allocatable :: catnum(:) - integer, allocatable :: numhru_all_g(:), lakeid(:) - integer, allocatable :: types(:), order(:), ibuff(:) - integer :: nhru_glb - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_root) THEN - write(*,'(A)') 'Making land hydro units:' - ENDIF - - IF (p_is_root) THEN - CALL ncio_read_serial (DEF_CatchmentMesh_data, 'basin_numhru', numhru_all_g) - CALL ncio_read_serial (DEF_CatchmentMesh_data, 'lake_id', lakeid) - ENDIF - -#ifdef USEMPI -#ifdef MPAS_EMBEDDED_COLM - IF (p_is_root) THEN - ncat = size(numhru_all_g) - ELSE - ncat = 0 - ENDIF - CALL mpi_bcast (ncat, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) - IF (.not. p_is_root) THEN - allocate (numhru_all_g(ncat)) - allocate (lakeid(ncat)) - ENDIF - CALL mpi_bcast (numhru_all_g, ncat, MPI_INTEGER, p_root, p_comm_glb, p_err) - CALL mpi_bcast (lakeid, ncat, MPI_INTEGER, p_root, p_comm_glb, p_err) - - IF (p_is_compute) THEN - IF (numelm > 0) THEN - allocate (catnum(numelm)) - allocate (ibuff(numelm)) - catnum = landelm%eindex - numhru = sum(numhru_all_g(catnum)) - ibuff = lakeid(catnum) - deallocate (lakeid) - allocate (lakeid(numelm)) - lakeid = ibuff - deallocate (catnum) - deallocate (ibuff) - ELSE - numhru = 0 - ENDIF - ENDIF -#else - IF (p_is_root) THEN - DO iwork = 0, p_np_compute-1 - - CALL mpi_recv (ncat, 1, MPI_INTEGER, p_address_compute(iwork), mpi_tag_size, & - p_comm_glb, p_stat, p_err) - - IF (ncat > 0) THEN - allocate (catnum(ncat)) - allocate (ibuff (ncat)) - - CALL mpi_recv (catnum, ncat, MPI_INTEGER8, p_address_compute(iwork), mpi_tag_data, & - p_comm_glb, p_stat, p_err) - - nhru = sum(numhru_all_g(catnum)) - CALL mpi_send (nhru, 1, MPI_INTEGER, & - p_address_compute(iwork), mpi_tag_size, p_comm_glb, p_err) - - ibuff = lakeid(catnum) - CALL mpi_send (ibuff, ncat, MPI_INTEGER, & - p_address_compute(iwork), mpi_tag_data, p_comm_glb, p_err) - - deallocate(catnum) - deallocate(ibuff ) - ENDIF - ENDDO - ENDIF - - IF (p_is_compute) THEN - CALL mpi_send (numelm, 1, MPI_INTEGER, p_address_root, mpi_tag_size, p_comm_glb, p_err) - IF (numelm > 0) THEN - allocate (lakeid (numelm)) - CALL mpi_send (landelm%eindex, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_recv (numhru, 1, MPI_INTEGER, p_address_root, mpi_tag_size, p_comm_glb, p_stat, p_err) - CALL mpi_recv (lakeid, numelm, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ELSE - numhru = 0 - ENDIF - ENDIF -#endif -#else - numhru = sum(numhru_all_g) -#endif - - IF (allocated(numhru_all_g)) deallocate(numhru_all_g) - - IF (p_is_active) CALL allocate_block_data (grid_hru, hrudata) - CALL catchment_data_read (DEF_CatchmentMesh_data, 'ihydrounit2d', grid_hru, hrudata) - -#ifdef USEMPI - IF (p_is_active) THEN - CALL aggregation_data_daemon (grid_hru, data_i4_2d_in1 = hrudata) - ENDIF -#endif - - IF (p_is_compute) THEN - - IF (numhru > 0) THEN - allocate (landhru%eindex (numhru)) - allocate (landhru%settyp (numhru)) - allocate (landhru%ipxstt (numhru)) - allocate (landhru%ipxend (numhru)) - allocate (landhru%ielm (numhru)) - ENDIF - - numhru = 0 - - DO ie = 1, numelm - - IF (lakeid(ie) > 0) THEN - typsgn = -1 - ELSE - typsgn = 1 - ENDIF - - npxl = mesh(ie)%npxl - - allocate (types (1:npxl)) - - CALL aggregation_request_data (landelm, ie, grid_hru, zip = .false., & - data_i4_2d_in1 = hrudata, data_i4_2d_out1 = ibuff) - - types = ibuff - - allocate (order (1:npxl)) - order = (/ (ipxl, ipxl = 1, npxl) /) - - CALL quicksort (npxl, types, order) - - mesh(ie)%ilon(1:npxl) = mesh(ie)%ilon(order) - mesh(ie)%ilat(1:npxl) = mesh(ie)%ilat(order) - - DO ipxl = 1, npxl - IF (ipxl == 1) THEN - numhru = numhru + 1 - landhru%eindex (numhru) = mesh(ie)%indx - landhru%settyp (numhru) = types(ipxl) * typsgn - landhru%ipxstt (numhru) = ipxl - landhru%ielm (numhru) = ie - ELSEIF (types(ipxl) /= types(ipxl-1)) THEN - landhru%ipxend(numhru) = ipxl - 1 - - numhru = numhru + 1 - landhru%eindex (numhru) = mesh(ie)%indx - landhru%settyp (numhru) = types(ipxl) * typsgn - landhru%ipxstt (numhru) = ipxl - landhru%ielm (numhru) = ie - ENDIF - ENDDO - landhru%ipxend(numhru) = npxl - - deallocate (ibuff) - deallocate (types) - deallocate (order) - - ENDDO - -#ifdef USEMPI - CALL aggregation_compute_done () -#endif - ENDIF - - landhru%nset = numhru - CALL landhru%set_vecgs - -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numhru, nhru_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', nhru_glb, ' hydro units.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numhru, ' hydro units.' -#endif - - IF (allocated(lakeid)) deallocate(lakeid) - - END SUBROUTINE landhru_build - -END MODULE MOD_LandHRU -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 index 4c8d17e875..cf95355f2b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 @@ -37,250 +37,37 @@ MODULE MOD_LandPFT integer , allocatable :: patch_pft_s (:) !start PFT index of a patch integer , allocatable :: patch_pft_e (:) !end PFT index of a patch - ! ---- PUBLIC routines ---- - PUBLIC :: landpft_build - CONTAINS ! ------------------------------- - SUBROUTINE landpft_build (lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_DataType - USE MOD_Namelist - USE MOD_5x5DataReadin - USE MOD_LandPatch - USE MOD_Land2mWMO - USE MOD_AggregationRequestData - USE MOD_Const_LC -#ifdef CROP - USE MOD_LandCrop -#endif - - IMPLICIT NONE - - integer, intent(in) :: lc_year - ! Local Variables - character(len=256) :: dir_5x5, suffix, cyear - type (block_data_real8_3d) :: pctpft - real(r8), allocatable :: pctpft_patch(:,:), pctpft_one(:,:) - real(r8), allocatable :: area_one (:) - logical, allocatable :: patchmask (:) - integer :: ipatch, ipft, npatch, npft, npft_glb - integer :: wmo_src, ipft_grass - real(r8) :: sumarea, maxgrass - - IF (p_is_root) THEN - write(*,'(A)') 'Making land plant function type tiles:' - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - landpft%has_shared = .true. - - IF (p_is_active) THEN - - CALL allocate_block_data (grid_patch, pctpft, N_PFT_modis, lb1 = 0) - CALL flush_block_data (pctpft, 1.0) - - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - ! add parameter input for time year - write(cyear,'(i4.4)') lc_year - suffix = 'MOD'//trim(cyear) - CALL read_5x5_data_pft (dir_5x5, suffix, grid_patch, 'PCT_PFT', pctpft) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_patch, data_r8_3d_in1 = pctpft, n1_r8_3d_in1 = N_PFT_modis) -#endif - ENDIF - - - IF (p_is_compute) THEN - - IF (numpatch > 0) THEN - allocate (pctpft_patch (0:N_PFT-1,numpatch)) - allocate (patchmask (numpatch)) - - pctpft_patch(:,:) = 0 - patchmask (:) = .true. - ENDIF - - DO ipatch = 1, numpatch - - IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN - - wmo_src = wmo_source(landpatch%ielm(ipatch)) - maxgrass = maxval(pctpft_patch(12:14,wmo_src)) - - IF (maxgrass > 0) THEN - ipft_grass = maxloc(pctpft_patch(12:14,wmo_src), dim=1) + 11 - pctpft_patch(:,ipatch) = 0 - pctpft_patch(ipft_grass,ipatch) = 1. - ELSE - pctpft_patch(0,ipatch) = 1. - ENDIF - - CYCLE - ENDIF -#ifndef CROP - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN -#else - IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN -#endif - CALL aggregation_request_data (landpatch, ipatch, grid_patch, zip = .false., area = area_one, & - data_r8_3d_in1 = pctpft, data_r8_3d_out1 = pctpft_one, n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) - - sumarea = sum(area_one * sum(pctpft_one(0:N_PFT-1,:),dim=1)) - - ! In case of no PFT data, set patchtype=0 to 100% bare. - IF (sumarea <= 0.0) THEN - pctpft_patch(0,ipatch) = 1. - ELSE - DO ipft = 0, N_PFT-1 - pctpft_patch(ipft,ipatch) = sum(pctpft_one(ipft,:) * area_one) / sumarea - ENDDO - ENDIF - - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_compute_done () -#endif - - IF (numpatch > 0) THEN - npatch = count(patchmask) - numpft = count(pctpft_patch > 0.) -#ifdef CROP - numpft = numpft + count(landpatch%settyp == CROPLAND) -#endif - IF (npatch > 0) THEN - allocate (patch_pft_s (npatch)) - allocate (patch_pft_e (npatch)) - ENDIF - ELSE - numpft = 0 - ENDIF - - IF (numpft > 0) THEN - - allocate (pft2patch (numpft)) - - allocate (landpft%eindex (numpft)) - allocate (landpft%settyp (numpft)) - allocate (landpft%ipxstt (numpft)) - allocate (landpft%ipxend (numpft)) - allocate (landpft%ielm (numpft)) - - allocate (landpft%pctshared (numpft)) - landpft%pctshared(:) = 1. - - npft = 0 - npatch = 0 - DO ipatch = 1, numpatch - IF (patchmask(ipatch)) THEN - npatch = npatch + 1 - -#ifndef CROP - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN -#else - IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN -#endif - patch_pft_s(npatch) = npft + 1 - patch_pft_e(npatch) = npft + count(pctpft_patch(:,ipatch) > 0) - - DO ipft = 0, N_PFT-1 - IF (pctpft_patch(ipft,ipatch) > 0) THEN - npft = npft + 1 - - landpft%ielm (npft) = landpatch%ielm (ipatch) - landpft%eindex(npft) = landpatch%eindex(ipatch) - landpft%ipxstt(npft) = landpatch%ipxstt(ipatch) - landpft%ipxend(npft) = landpatch%ipxend(ipatch) - landpft%settyp(npft) = ipft - - landpft%pctshared(npft) = pctpft_patch(ipft,ipatch) - - pft2patch(npft) = npatch - ENDIF - ENDDO -#ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN - npft = npft + 1 - patch_pft_s(npatch) = npft - patch_pft_e(npatch) = npft - - landpft%ielm (npft) = landpatch%ielm (ipatch) - landpft%eindex(npft) = landpatch%eindex(ipatch) - landpft%ipxstt(npft) = landpatch%ipxstt(ipatch) - landpft%ipxend(npft) = landpatch%ipxend(ipatch) - landpft%settyp(npft) = cropclass(ipatch) + N_PFT - 1 - - landpft%pctshared(npft) = landpatch%pctshared(ipatch) - - pft2patch(npft) = npatch -#endif - ELSE - patch_pft_s(npatch) = -1 - patch_pft_e(npatch) = -1 - ENDIF - ENDIF - ENDDO - - ENDIF - - ENDIF - - CALL landpatch%pset_pack(patchmask, numpatch) - - landpft%nset = numpft - CALL landpft%set_vecgs - -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numpft, npft_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', npft_glb, ' plant function type tiles.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numpft, ' plant function type tiles.' -#endif - - IF (allocated(pctpft_patch)) deallocate (pctpft_patch) - IF (allocated(pctpft_one )) deallocate (pctpft_one ) - IF (allocated(area_one )) deallocate (area_one ) - IF (allocated(patchmask )) deallocate (patchmask ) - - END SUBROUTINE landpft_build ! ---------------------- SUBROUTINE map_patch_to_pft - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch USE MOD_Const_LC IMPLICIT NONE integer :: ipatch, ipft - IF (p_is_compute) THEN - - IF ((numpatch <= 0) .or. (numpft <= 0)) RETURN + IF (.true.) THEN IF (allocated(patch_pft_s)) deallocate(patch_pft_s) IF (allocated(patch_pft_e)) deallocate(patch_pft_e) IF (allocated(pft2patch )) deallocate(pft2patch ) - allocate (patch_pft_s (numpatch)) - allocate (patch_pft_e (numpatch)) + IF (numpatch <= 0 .and. numpft > 0) THEN + CALL CoLM_stop('CoLM has PFT/PC entries on a rank with no loaded patches.') + ENDIF + IF (numpatch <= 0) RETURN + + allocate (patch_pft_s (numpatch)) + allocate (patch_pft_e (numpatch)) allocate (pft2patch (numpft )) + patch_pft_s(:) = -1 + patch_pft_e(:) = -1 + pft2patch(:) = -1 ipft = 1 DO ipatch = 1, numpatch @@ -303,8 +90,12 @@ SUBROUTINE map_patch_to_pft EXIT ENDIF ENDDO + IF (patch_pft_e(ipatch) < patch_pft_s(ipatch)) THEN + CALL CoLM_stop('A vegetated CoLM patch has no matching PFT/PC state.') + ENDIF #ifdef CROP ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + IF (ipft > numpft) CALL CoLM_stop('A CoLM crop patch has no matching PFT state.') patch_pft_s(ipatch) = ipft patch_pft_e(ipatch) = ipft pft2patch (ipft ) = ipatch @@ -316,6 +107,9 @@ SUBROUTINE map_patch_to_pft ENDIF ENDDO + IF (ipft /= numpft + 1 .or. any(pft2patch < 1)) THEN + CALL CoLM_stop('CoLM PFT/PC entries do not map one-to-one onto loaded patches.') + ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 index 04c76fe18b..fb7fe94a49 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 @@ -42,278 +42,5 @@ MODULE MOD_LandPatch #endif -CONTAINS - - ! ------------------------------- - SUBROUTINE landpatch_build (lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Utils - USE MOD_UserDefFun - USE MOD_Grid - USE MOD_DataType - USE MOD_Mesh - USE MOD_LandElm -#ifdef CATCHMENT - USE MOD_LandHRU -#endif - USE MOD_Namelist - USE MOD_NetCDFBlock - USE MOD_AggregationRequestData - - IMPLICIT NONE - - integer, intent(in) :: lc_year - ! Local Variables - character(len=256) :: file_patch - character(len=255) :: cyear - type (block_data_int32_2d) :: patchdata - integer :: iloc, npxl, ipxl, numset - integer :: ie, iset, ipxstt, ipxend - integer, allocatable :: types(:), order(:), ibuff(:) - integer*8, allocatable :: eindex_tmp(:) - integer, allocatable :: settyp_tmp(:), ipxstt_tmp(:), ipxend_tmp(:), ielm_tmp(:) - logical, allocatable :: msk(:) - integer :: npatch_glb - integer :: dominant_type - integer, allocatable :: npxl_types (:) - - write(cyear,'(i4.4)') lc_year - IF (p_is_root) THEN - write(*,'(A)') 'Making land patches:' - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_active) THEN - - CALL allocate_block_data (grid_patch, patchdata) - -#ifndef LULC_USGS - ! add parameter input for time year - file_patch = trim(DEF_dir_rawdata)//'landtypes/landtype-igbp-modis-'//trim(cyear)//'.nc' -#else - !TODO: need usgs land cover type data - file_patch = trim(DEF_dir_rawdata) //'/landtypes/landtype-usgs-update.nc' -#endif - CALL ncio_read_block (file_patch, 'landtype', grid_patch, patchdata) - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_patch, data_i4_2d_in1 = patchdata) -#endif - ENDIF - - IF (p_is_compute) THEN - -#ifdef CATCHMENT - numset = numhru -#else - numset = numelm -#endif - - IF (numset > 0) THEN - allocate (eindex_tmp (numset*N_land_classification)) - allocate (settyp_tmp (numset*N_land_classification)) - allocate (ipxstt_tmp (numset*N_land_classification)) - allocate (ipxend_tmp (numset*N_land_classification)) - allocate (ielm_tmp (numset*N_land_classification)) - ENDIF - - numpatch = 0 - - DO iset = 1, numset -#ifdef CATCHMENT - ie = landhru%ielm (iset) - ipxstt = landhru%ipxstt(iset) - ipxend = landhru%ipxend(iset) -#else - ie = landelm%ielm (iset) - ipxstt = landelm%ipxstt(iset) - ipxend = landelm%ipxend(iset) -#endif - - npxl = ipxend - ipxstt + 1 - - allocate (types (ipxstt:ipxend)) - -#ifdef CATCHMENT - CALL aggregation_request_data (landhru, iset, grid_patch, zip = .false., & -#else - CALL aggregation_request_data (landelm, iset, grid_patch, zip = .false., & -#endif - data_i4_2d_in1 = patchdata, data_i4_2d_out1 = ibuff) - - - types(:) = ibuff - deallocate (ibuff) - -#ifdef CATCHMENT - IF (landhru%settyp(iset) <= 0) THEN - types(ipxstt:ipxend) = WATERBODY - ENDIF - WHERE (types == 0) - ! set land in MERITHydro while ocean in landtype data as water body - types = WATERBODY - END WHERE - WHERE (types == 11) - types = 10 - END WHERE -#endif - - IF ((DEF_USE_PFT .and. (.not. DEF_SOLO_PFT)) .or. DEF_FAST_PC) THEN - ! For classification of plant function types or fast PC, - ! merge all land types with soil ground - DO ipxl = ipxstt, ipxend - IF (types(ipxl) > 0) THEN - IF (patchtypes(types(ipxl)) == 0) THEN - ! Deal with cropland separately for fast PC - IF (DEF_FAST_PC .and. & - (types(ipxl)==CROPLAND .or. types(ipxl)==14)) THEN - types(ipxl) = CROPLAND - ELSE - types(ipxl) = 1 - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF - - allocate (order (ipxstt:ipxend)) - order = (/ (ipxl, ipxl = ipxstt, ipxend) /) - - CALL quicksort (npxl, types, order) - - mesh(ie)%ilon(ipxstt:ipxend) = mesh(ie)%ilon(order) - mesh(ie)%ilat(ipxstt:ipxend) = mesh(ie)%ilat(order) - - IF (DEF_USE_DOMINANT_PATCHTYPE) THEN - allocate (npxl_types (0:maxval(types))) - npxl_types(:) = 0 - DO ipxl = ipxstt, ipxend - npxl_types(types(ipxl)) = npxl_types(types(ipxl)) + 1 - ENDDO - - IF (any(types > 0)) THEN - iloc = findloc_ud(types > 0) + ipxstt - 1 - dominant_type = maxloc(npxl_types(1:), dim=1) - types(iloc:ipxend) = dominant_type - ENDIF - - deallocate(npxl_types) - ENDIF - - DO ipxl = ipxstt, ipxend - IF (ipxl == ipxstt) THEN - numpatch = numpatch + 1 - eindex_tmp(numpatch) = mesh(ie)%indx - settyp_tmp(numpatch) = types(ipxl) - ipxstt_tmp(numpatch) = ipxl - ielm_tmp (numpatch) = ie - ELSEIF (types(ipxl) /= types(ipxl-1)) THEN - ipxend_tmp(numpatch) = ipxl - 1 - - numpatch = numpatch + 1 - eindex_tmp(numpatch) = mesh(ie)%indx - settyp_tmp(numpatch) = types(ipxl) - ipxstt_tmp(numpatch) = ipxl - ielm_tmp (numpatch) = ie - ENDIF - ENDDO - ipxend_tmp(numpatch) = ipxend - - deallocate (types) - deallocate (order) - - ENDDO - - IF (numpatch > 0) THEN - allocate (landpatch%eindex (numpatch)) - allocate (landpatch%settyp (numpatch)) - allocate (landpatch%ipxstt (numpatch)) - allocate (landpatch%ipxend (numpatch)) - allocate (landpatch%ielm (numpatch)) - - landpatch%eindex = eindex_tmp(1:numpatch) - landpatch%ipxstt = ipxstt_tmp(1:numpatch) - landpatch%ipxend = ipxend_tmp(1:numpatch) - landpatch%settyp = settyp_tmp(1:numpatch) - landpatch%ielm = ielm_tmp (1:numpatch) - ENDIF - - IF (numset > 0) THEN - deallocate (eindex_tmp) - deallocate (ipxstt_tmp) - deallocate (ipxend_tmp) - deallocate (settyp_tmp) - deallocate (ielm_tmp ) - ENDIF - -#ifdef USEMPI - CALL aggregation_compute_done () -#endif - - ENDIF - - landpatch%nset = numpatch - - CALL landpatch%set_vecgs - - -#if (!defined(URBAN_MODEL) && !defined(CROP)) -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' -#endif - -IF ( .not. DEF_Output_2mWMO ) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#ifdef CATCHMENT - CALL hru_patch%build (landhru, landpatch, use_frac = .true.) -#endif - - CALL write_patchfrac (DEF_dir_landdata, lc_year) -ENDIF -#endif - - END SUBROUTINE landpatch_build - - ! ----- - SUBROUTINE write_patchfrac (dir_landdata, lc_year) - - USE MOD_Namelist - USE MOD_NetCDFVector - IMPLICIT NONE - - integer, intent(in) :: lc_year - character(len=*), intent(in) :: dir_landdata - character(len=256) :: lndname, cyear - - write(cyear,'(i4.4)') lc_year - CALL system('mkdir -p ' // trim(dir_landdata) // '/landpatch/' // trim(cyear)) - - lndname = trim(dir_landdata)//'/landpatch/'//trim(cyear)//'/patchfrac_elm.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'patchfrac_elm', 'patch', landpatch, elm_patch%subfrc, DEF_Srfdata_CompressLevel) - -#ifdef CATCHMENT - lndname = trim(dir_landdata)//'/landpatch/'//trim(cyear)//'/patchfrac_hru.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'patchfrac_hru', 'patch', landpatch, hru_patch%subfrc, DEF_Srfdata_CompressLevel) -#endif - - END SUBROUTINE write_patchfrac END MODULE MOD_LandPatch diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 index 76fd7e77fe..6f5469ca8d 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 @@ -31,358 +31,22 @@ MODULE MOD_LandUrban integer , allocatable :: urban2patch (:) !patch index of a urban integer , allocatable :: patch2urban (:) !urban index of a patch - ! ---- PUBLIC routines ---- - PUBLIC :: landurban_build PUBLIC :: map_patch_to_urban CONTAINS ! ------------------------------- - SUBROUTINE landurban_build (lc_year) - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_NetCDFBlock - USE MOD_Grid - USE MOD_DataType - USE MOD_Namelist - USE MOD_5x5DataReadin - USE MOD_Mesh - USE MOD_LandPatch - USE MOD_LandElm -#ifdef CATCHMENT - USE MOD_LandHRU -#endif - USE MOD_AggregationRequestData - USE MOD_Utils - - IMPLICIT NONE - - integer, intent(in) :: lc_year - ! Local Variables - character(len=256) :: dir_urban - type (block_data_int32_2d) :: data_urb_class ! urban type index - - ! local vars - integer, allocatable :: ibuff(:), types(:), order(:) - - ! index - integer :: ipatch, jpatch, iurban - integer :: ie, ipxstt, ipxend, npxl, ipxl - integer :: nurb_glb, npatch_glb - - ! local vars for landpath and landurban - integer :: numpatch_ - integer*8, allocatable :: eindex_(:) - integer, allocatable :: ipxstt_(:) - integer, allocatable :: ipxend_(:) - integer, allocatable :: settyp_(:) - integer, allocatable :: ielm_ (:) - - integer :: numurban_ - integer :: iurb, ib, imiss - integer :: buff_count(N_URB) - real(r8) :: buff_p(N_URB) - - integer , allocatable :: urbclass (:) - real(r8), allocatable :: area_one (:) - - character(len=256) :: suffix, cyear - - IF (p_is_root) THEN - write(*,'(A)') 'Making urban type tiles:' - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! allocate and read the grided LCZ/NCAR urban type - IF (p_is_active) THEN - - dir_urban = trim(DEF_dir_rawdata) // '/urban_type' - - CALL allocate_block_data (grid_urban, data_urb_class) - CALL flush_block_data (data_urb_class, 0) - - ! read urban type data - suffix = 'URBTYP' -IF (DEF_URBAN_type_scheme == 1) THEN - CALL read_5x5_data (dir_urban, suffix, grid_urban, 'URBAN_DENSITY_CLASS', data_urb_class) -ELSE IF (DEF_URBAN_type_scheme == 2) THEN - CALL read_5x5_data (dir_urban, suffix, grid_urban, 'LCZ_DOM', data_urb_class) -ENDIF - -#ifdef USEMPI - CALL aggregation_data_daemon (grid_urban, data_i4_2d_in1 = data_urb_class) -#endif - ENDIF - - IF (p_is_compute) THEN - - IF (numpatch > 0) THEN - ! a temporary numpatch with max urban patch number - numpatch_ = numpatch + count(landpatch%settyp == URBAN) * (N_URB-1) - - allocate (eindex_ (numpatch_ )) - allocate (ipxstt_ (numpatch_ )) - allocate (ipxend_ (numpatch_ )) - allocate (settyp_ (numpatch_ )) - allocate (ielm_ (numpatch_ )) - - ! max urban patch number (temporary) - numurban_ = count(landpatch%settyp == URBAN) * N_URB - IF (numurban_ > 0) THEN - allocate (urbclass(numurban_)) - ENDIF - ENDIF - - jpatch = 0 - iurban = 0 - - ! loop for temporary numpatch to filter duplicate urban patch - DO ipatch = 1, numpatch - IF (landpatch%settyp(ipatch) == URBAN) THEN - - ie = landpatch%ielm (ipatch) - ipxstt = landpatch%ipxstt(ipatch) - ipxend = landpatch%ipxend(ipatch) - - CALL aggregation_request_data (landpatch, ipatch, grid_urban, zip = .false., area = area_one, & - data_i4_2d_in1 = data_urb_class, data_i4_2d_out1 = ibuff) - - ! when there is missing urban types - !NOTE@tungwz: need double check below and add appropriate annotations - ! check if there is urban pixel without URBAN ID - imiss = count(ibuff<1 .or. ibuff>N_URB) - IF (imiss > 0) THEN - ! Calculate the relative ratio of each urban types by excluding urban pixels without URBAN ID - WHERE (ibuff<1 .or. ibuff>N_URB) - area_one = 0 - END WHERE - - buff_p = 0 - IF (sum(area_one) > 0) THEN - DO ib = 1, size(area_one) - IF (ibuff(ib)>1 .and. ibuff(ib)N_URB) THEN - type_loop: DO iurb = 1, N_URB - IF (buff_count(iurb) > 0) THEN - ibuff(ib) = iurb - buff_count(iurb) = buff_count(iurb) - 1 - EXIT type_loop - ENDIF - ENDDO type_loop - ENDIF - ENDDO - ENDIF - ENDIF - - npxl = ipxend - ipxstt + 1 - - allocate (types (ipxstt:ipxend)) - - types(:) = ibuff - - deallocate (ibuff) - - allocate (order (ipxstt:ipxend)) - order = (/ (ipxl, ipxl = ipxstt, ipxend) /) - - ! change order vars, types->regid ? still types below - ! add region information, because urban type may be same, - ! but from different region in this urban patch - ! relative code is changed - CALL quicksort (npxl, types, order) - - mesh(ie)%ilon(ipxstt:ipxend) = mesh(ie)%ilon(order) - mesh(ie)%ilat(ipxstt:ipxend) = mesh(ie)%ilat(order) - - DO ipxl = ipxstt, ipxend - IF (ipxl /= ipxstt) THEN - IF (types(ipxl) /= types(ipxl-1)) THEN - ipxend_(jpatch) = ipxl - 1 - ELSE - CYCLE - ENDIF - ENDIF - - jpatch = jpatch + 1 - eindex_(jpatch) = mesh(ie)%indx - settyp_(jpatch) = URBAN - ipxstt_(jpatch) = ipxl - ielm_ (jpatch) = ie - - iurban = iurban + 1 - urbclass(iurban) = types(ipxl) - ENDDO - - ipxend_(jpatch) = ipxend - - deallocate (types) - deallocate (order) - - ELSE - jpatch = jpatch + 1 - eindex_(jpatch) = landpatch%eindex(ipatch) - ipxstt_(jpatch) = landpatch%ipxstt(ipatch) - ipxend_(jpatch) = landpatch%ipxend(ipatch) - settyp_(jpatch) = landpatch%settyp(ipatch) - ielm_ (jpatch) = landpatch%ielm (ipatch) - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_compute_done () -#endif - - numpatch = jpatch - - IF (numpatch > 0) THEN - ! update landpath with new patch number - ! all urban type patch are included - IF (allocated (landpatch%eindex)) deallocate (landpatch%eindex) - IF (allocated (landpatch%ipxstt)) deallocate (landpatch%ipxstt) - IF (allocated (landpatch%ipxend)) deallocate (landpatch%ipxend) - IF (allocated (landpatch%settyp)) deallocate (landpatch%settyp) - IF (allocated (landpatch%ielm )) deallocate (landpatch%ielm ) - - allocate (landpatch%eindex (numpatch)) - allocate (landpatch%ipxstt (numpatch)) - allocate (landpatch%ipxend (numpatch)) - allocate (landpatch%settyp (numpatch)) - allocate (landpatch%ielm (numpatch)) - - ! update all information of landpatch - landpatch%eindex = eindex_(1:jpatch) - landpatch%ipxstt = ipxstt_(1:jpatch) - landpatch%ipxend = ipxend_(1:jpatch) - landpatch%settyp = settyp_(1:jpatch) - landpatch%ielm = ielm_ (1:jpatch) - ENDIF - - ! update urban patch number - IF (numpatch > 0) THEN - numurban = count(landpatch%settyp == URBAN) - ELSE - numurban = 0 - ENDIF - - IF (numurban > 0) THEN - allocate (landurban%eindex (numurban)) - allocate (landurban%settyp (numurban)) - allocate (landurban%ipxstt (numurban)) - allocate (landurban%ipxend (numurban)) - allocate (landurban%ielm (numurban)) - - ! copy urban path information from landpatch for landurban - landurban%eindex = pack(landpatch%eindex, landpatch%settyp == URBAN) - landurban%ipxstt = pack(landpatch%ipxstt, landpatch%settyp == URBAN) - landurban%ipxend = pack(landpatch%ipxend, landpatch%settyp == URBAN) - landurban%ielm = pack(landpatch%ielm , landpatch%settyp == URBAN) - - ! assign urban region id and type for each urban patch - landurban%settyp = urbclass(1:numurban) - ENDIF - - ! update land patch with urban type patch - ! set numurban - landurban%nset = numurban - landpatch%nset = numpatch - ENDIF - - CALL landpatch%set_vecgs - CALL landurban%set_vecgs - - CALL map_patch_to_urban - -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numurban, nurb_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', nurb_glb, ' urban tiles.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numurban, ' urban tiles.' -#endif - -#ifndef CROP -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' -#endif - -IF ( .not. DEF_Output_2mWMO ) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#ifdef CATCHMENT - CALL hru_patch%build (landhru, landpatch, use_frac = .true.) -#endif - CALL write_patchfrac (DEF_dir_landdata, lc_year) -ENDIF -#endif - - IF (allocated (ibuff )) deallocate (ibuff ) - IF (allocated (types )) deallocate (types ) - IF (allocated (order )) deallocate (order ) - - IF (allocated (eindex_ )) deallocate (eindex_ ) - IF (allocated (ipxstt_ )) deallocate (ipxstt_ ) - IF (allocated (ipxend_ )) deallocate (ipxend_ ) - IF (allocated (settyp_ )) deallocate (settyp_ ) - IF (allocated (ielm_ )) deallocate (ielm_ ) - - IF (allocated (urbclass)) deallocate (urbclass ) - IF (allocated (area_one)) deallocate (area_one ) - - END SUBROUTINE landurban_build ! ---------------------- SUBROUTINE map_patch_to_urban - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_LandPatch IMPLICIT NONE integer :: ipatch, iurban - IF (p_is_compute) THEN + IF (.true.) THEN IF ((numpatch <= 0) .or. (numurban <= 0)) RETURN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 new file mode 100644 index 0000000000..590f288c45 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 @@ -0,0 +1,115 @@ +#include + +MODULE MOD_MPAS_MPI + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! MPAS owns MPI initialization, finalization, and domain decomposition. +! Embedded CoLM never creates a process pool or reserves additional ranks. +! Every MPAS rank advances its locally owned CoLM elements, with rank 0 used +! only as a collective root for logging and scalar metadata. +! +! CoLM element ownership is supplied by MPAS cell ownership. Patch/PFT state +! remains internal to CoLM and is mapped back to the owning element/cell by CoLM. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------------------------- + + USE mpi + USE MOD_Precision + IMPLICIT NONE + + integer, parameter :: mpas_root = 0 + + logical :: mpas_is_root = .false. + + ! mpas_comm is borrowed from the MPAS LSM driver and never duplicated or + ! freed here. MPAS owns the isolated message context and its lifetime. + integer :: mpas_comm = MPI_COMM_NULL + integer :: mpas_rank = -1 + integer :: mpas_size = 0 + + integer :: mpas_status (MPI_STATUS_SIZE) + integer :: mpas_mpi_ierr = 0 + + integer, PUBLIC, parameter :: mpi_tag_size = 1 + integer, PUBLIC, parameter :: mpi_tag_mesg = 2 + integer, PUBLIC, parameter :: mpi_tag_data = 3 + + PUBLIC :: mpas_mpi_attach + PUBLIC :: mpas_mpi_detach + PUBLIC :: mpas_mpi_check + +CONTAINS + + !----------------------------------------- + SUBROUTINE mpas_mpi_attach (mpas_domain_comm) + + IMPLICIT NONE + integer, intent(in) :: mpas_domain_comm + IF (mpas_domain_comm == MPI_COMM_NULL) STOP 'MPAS supplied MPI_COMM_NULL to embedded CoLM.' + IF (mpas_comm /= MPI_COMM_NULL) CALL CoLM_stop('Embedded CoLM communicator was initialized more than once.') + + mpas_comm = mpas_domain_comm + + CALL mpi_comm_rank (mpas_comm, mpas_rank, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM could not query its MPAS communicator rank.') + CALL mpi_comm_size (mpas_comm, mpas_size, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM could not query its MPAS communicator size.') + IF (mpas_size < 1 .or. mpas_rank < 0 .or. mpas_rank >= mpas_size) THEN + CALL CoLM_stop('Embedded CoLM received an invalid MPAS communicator rank or size.') + ENDIF + + mpas_is_root = (mpas_rank == mpas_root) + + END SUBROUTINE mpas_mpi_attach + + !----------------------------------------- + SUBROUTINE mpas_mpi_detach + + mpas_comm = MPI_COMM_NULL + mpas_rank = -1 + mpas_size = 0 + mpas_is_root = .false. + + END SUBROUTINE mpas_mpi_detach + + !----------------------------------------- + SUBROUTINE mpas_mpi_check (operation) + + IMPLICIT NONE + character(len=*), intent(in) :: operation + + IF (mpas_mpi_ierr /= MPI_SUCCESS) THEN + CALL CoLM_stop('Embedded CoLM MPI failure during '//trim(operation)//'.') + ENDIF + + END SUBROUTINE mpas_mpi_check + + ! -- STOP all processes -- + SUBROUTINE CoLM_stop (mesg) + + IMPLICIT NONE + character(len=*), optional :: mesg + logical :: mpi_inited + logical :: mpi_is_finalized + integer :: ierr_local + + IF (present(mesg)) write(*,*) trim(mesg) + + ierr_local = MPI_SUCCESS + CALL MPI_INITIALIZED (mpi_inited, ierr_local) + mpi_is_finalized = .false. + IF (ierr_local == MPI_SUCCESS .and. mpi_inited) THEN + CALL MPI_FINALIZED (mpi_is_finalized, ierr_local) + ENDIF + IF (ierr_local == MPI_SUCCESS .and. mpi_inited .and. (.not. mpi_is_finalized)) THEN + IF (mpas_comm /= MPI_COMM_NULL) CALL mpi_abort (mpas_comm, 1, ierr_local) + ENDIF + + STOP + + END SUBROUTINE CoLM_stop + +END MODULE MOD_MPAS_MPI diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 index 24bfc019c8..f0efc8645b 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -66,15 +66,15 @@ MODULE MOD_Mesh #ifdef GRIDBASED SUBROUTINE init_gridbased_mesh_grid () - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist IMPLICIT NONE - IF (p_is_root) THEN + IF (mpas_is_root) THEN inquire (file=trim(DEF_file_mesh), exist=read_mesh_from_file) ENDIF -#ifdef USEMPI - CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, p_address_root, p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, mpas_root, mpas_comm, mpas_mpi_ierr) #endif IF (read_mesh_from_file) THEN CALL gridmesh%define_from_file (DEF_file_mesh) @@ -108,924 +108,7 @@ SUBROUTINE copy_elm (elm_from, elm_to) END SUBROUTINE copy_elm ! -------------------------------- - SUBROUTINE mesh_build () - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_NetCDFBlock - USE MOD_Block - USE MOD_Pixel - USE MOD_Grid - USE MOD_Utils - USE MOD_DataType - USE MOD_CatchmentDataReadin - - IMPLICIT NONE - - ! Local Variables - type(block_data_int32_2d) :: datamesh - - integer :: nelm, ie, je, dsp - integer :: iblkme, iblk, jblk, xloc, yloc, xg, yg, ixloc, iyloc - integer :: xp, yp, xblk, yblk, npxl, ipxl, ix, iy - integer :: irank, iproc, idest, isrc, iloc, iloc_max(2) - integer :: ylg, yug, ysp, ynp, nyp - integer :: xlg, xug, xwp, xep, nxp - real(r8) :: dlatp, dlonp - logical :: is_new - integer :: smesg(6), rmesg(6), blktag, nsend, nrecv, irecv - integer :: iblk_p, jblk_p, nelm_max_blk, nelm_glb - - integer, allocatable :: nelm_rank(:) - type(pointer_int64_1d), allocatable :: elist_rank(:) - - integer*8 :: elmid - integer*8, allocatable :: elist(:), elist2(:,:), sbuf64(:), elist_recv(:) - - integer, allocatable :: iaddr(:), elmindx (:), order(:) - integer, allocatable :: xlist(:), ylist (:), npxl_(:), xlist_recv(:), ylist_recv(:), sbuf(:) - logical, allocatable :: msk (:), work_done(:) - - integer, allocatable :: xlist2(:,:), ylist2(:,:), ipt2(:,:), npxl_blk(:,:), blkdsp(:,:), blkcnt(:,:) - logical, allocatable :: msk2 (:,:) - - type(irregular_elm_type), allocatable :: meshtmp (:) - - - IF (p_is_active) THEN - CALL allocate_block_data (gridmesh, datamesh) - ENDIF - -#ifdef GRIDBASED - IF (read_mesh_from_file) THEN - CALL ncio_read_block (DEF_file_mesh, 'landmask', gridmesh, datamesh) - ELSE - CALL flush_block_data (datamesh, 1) - ENDIF -#endif - -#ifdef CATCHMENT - CALL catchment_data_read (DEF_CatchmentMesh_data, 'icatchment2d', gridmesh, datamesh, spv = -1) -#endif - -#ifdef UNSTRUCTURED - CALL ncio_read_block (DEF_file_mesh, 'elmindex', gridmesh, datamesh) -#endif - - ! Step 1: How many elms in each block? - IF (p_is_active) THEN - - nelm = 0 - - allocate (nelm_rank (0:p_np_compute-1)) - nelm_rank(:) = 0 - - allocate (elist_rank (0:p_np_compute-1)) - DO irank = 0, p_np_compute-1 - allocate (elist_rank(irank)%val (1000)) - ENDDO - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - DO yloc = 1, gridmesh%ycnt(jblk) - DO xloc = 1, gridmesh%xcnt(iblk) - -#ifdef GRIDBASED - IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN - xg = gridmesh%xdsp(iblk) + xloc - IF (xg > gridmesh%nlon) xg = xg - gridmesh%nlon - - yg = gridmesh%ydsp(jblk) + yloc - - elmid = int(gridmesh%nlon,8) * (yg-1) + xg - ELSE - elmid = 0 - ENDIF -#endif -#ifdef CATCHMENT - elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) -#endif -#ifdef UNSTRUCTURED - elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) -#endif - - IF (elmid > 0) THEN - - irank = mod(elmid, p_np_compute) - CALL insert_into_sorted_list1 ( & - elmid, nelm_rank(irank), elist_rank(irank)%val, iloc) - - IF (nelm_rank(irank) == size(elist_rank(irank)%val)) THEN - CALL expand_list (elist_rank(irank)%val, 0.2_r8) - ENDIF - - ENDIF - - ENDDO - ENDDO - -#ifdef USEMPI - DO irank = 0, p_np_compute-1 - IF (nelm_rank(irank) > 0) THEN - idest = p_address_compute(irank) - smesg(1:2) = (/p_iam_glb, nelm_rank(irank)/) - ! send(01) - CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & - idest, mpi_tag_size, p_comm_glb, p_err) - ENDIF - ENDDO -#endif - - nelm = nelm + sum(nelm_rank) - nelm_rank(:) = 0 - ENDDO - -#ifdef USEMPI - DO irank = 0, p_np_compute-1 - idest = p_address_compute(irank) - ! send(02) - smesg(1:2) = (/p_iam_glb, 0/) - CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & - idest, mpi_tag_size, p_comm_glb, p_err) - ENDDO -#endif - - deallocate (nelm_rank) - DO irank = 0, p_np_compute-1 - deallocate (elist_rank(irank)%val) - ENDDO - deallocate (elist_rank) - - ENDIF - -#ifdef USEMPI - IF (p_is_compute) THEN - nelm = 0 - allocate(work_done(0:p_np_active-1)) - work_done(:) = .false. - DO WHILE (.not. all(work_done)) - ! recv(01,02) - CALL mpi_recv (rmesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_size, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - - IF (nrecv > 0) THEN - nelm = nelm + nrecv - ELSE - work_done(p_itis_active(isrc)) = .true. - ENDIF - ENDDO - - deallocate(work_done) - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! Step 2: Build pixel list for each elm. - IF (p_is_compute) THEN - IF (nelm > 0) THEN - allocate (meshtmp (nelm)) - allocate (elist (nelm)) - allocate (iaddr (nelm)) - ENDIF - nelm = 0 - ENDIF - - IF (p_is_active) THEN - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - IF (gridmesh%xcnt(iblk) <= 0) CYCLE - IF (gridmesh%ycnt(jblk) <= 0) CYCLE - - ylg = gridmesh%ydsp(jblk) + 1 - yug = gridmesh%ydsp(jblk) + gridmesh%ycnt(jblk) - IF (gridmesh%yinc == 1) THEN - ysp = find_nearest_south (gridmesh%lat_s(ylg), pixel%nlat, pixel%lat_s) - ynp = find_nearest_north (gridmesh%lat_n(yug), pixel%nlat, pixel%lat_n) - ELSE - ysp = find_nearest_south (gridmesh%lat_s(yug), pixel%nlat, pixel%lat_s) - ynp = find_nearest_north (gridmesh%lat_n(ylg), pixel%nlat, pixel%lat_n) - ENDIF - - nyp = ynp - ysp + 1 - - xlg = gridmesh%xdsp(iblk) + 1 - xug = gridmesh%xdsp(iblk) + gridmesh%xcnt(iblk) - IF (xug > gridmesh%nlon) xug = xug - gridmesh%nlon - - xwp = find_nearest_west (gridmesh%lon_w(xlg), pixel%nlon, pixel%lon_w) - IF (.not. lon_between_floor(pixel%lon_w(xwp), gridmesh%lon_w(xlg), gridmesh%lon_e(xlg))) THEN - xwp = mod(xwp,pixel%nlon) + 1 - ENDIF - - xep = find_nearest_east (gridmesh%lon_e(xug), pixel%nlon, pixel%lon_e) - IF (.not. lon_between_ceil(pixel%lon_e(xep), gridmesh%lon_w(xug), gridmesh%lon_e(xug))) THEN - xep = xep - 1 - IF (xep == 0) xep = pixel%nlon - ENDIF - - nxp = xep - xwp + 1 - IF (nxp <= 0) nxp = nxp + pixel%nlon - - allocate (elist2 (nxp,nyp)) - allocate (xlist2 (nxp,nyp)) - allocate (ylist2 (nxp,nyp)) - allocate (msk2 (nxp,nyp)) - - DO iy = ysp, ynp - yg = gridmesh%ygrd(iy) - yloc = gridmesh%yloc(yg) - - iyloc = iy - ysp + 1 - dlatp = pixel%lat_n(iy) - pixel%lat_s(iy) - IF (dlatp < 1.0e-6_r8) THEN - elist2(:,iyloc) = 0 - CYCLE - ENDIF - - ix = xwp - ixloc = 0 - DO WHILE (.true.) - ixloc = ixloc + 1 - dlonp = pixel%lon_e(ix) - pixel%lon_w(ix) - IF (dlonp < 0) dlonp = dlonp + 360.0_r8 - - xg = gridmesh%xgrd(ix) - xloc = gridmesh%xloc(xg) - -#ifdef GRIDBASED - IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN - elmid = int(gridmesh%nlon,8) * (yg-1) + xg - ELSE - elmid = 0 - ENDIF -#endif -#ifdef CATCHMENT - elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) -#endif -#ifdef UNSTRUCTURED - elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) -#endif - - xlist2(ixloc,iyloc) = ix - ylist2(ixloc,iyloc) = iy - elist2(ixloc,iyloc) = elmid - - IF (dlonp < 1.0e-6_r8) THEN - elist2(ixloc,iyloc) = 0 - ENDIF - - IF (ix == xep) EXIT - ix = mod(ix,pixel%nlon) + 1 - ENDDO - ENDDO - -#ifdef USEMPI - allocate (sbuf (nxp*nyp)) - allocate (ipt2 (nxp,nyp)) - - allocate (sbuf64 (nxp*nyp)) - - blktag = iblkme - ipt2 = mod(elist2, p_np_compute) - DO iproc = 0, p_np_compute-1 - msk2 = (ipt2 == iproc) .and. (elist2 > 0) - nsend = count(msk2) - IF (nsend > 0) THEN - - idest = p_address_compute(iproc) - - smesg(1:3) = (/p_iam_glb, nsend, blktag/) - ! send(03) - CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - sbuf64(1:nsend) = pack(elist2, msk2) - ! send(04) - CALL mpi_send (sbuf64(1:nsend), nsend, MPI_INTEGER8, & - idest, blktag, p_comm_glb, p_err) - - sbuf(1:nsend) = pack(xlist2, msk2) - ! send(05) - CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, & - idest, blktag, p_comm_glb, p_err) - - sbuf(1:nsend) = pack(ylist2, msk2) - ! send(06) - CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, & - idest, blktag, p_comm_glb, p_err) - - ENDIF - ENDDO - - deallocate (sbuf ) - deallocate (ipt2 ) - deallocate (sbuf64) -#else - - DO iy = 1, nyp - DO ix = 1, nxp - - elmid = elist2(ix,iy) - IF (elmid > 0) THEN - - CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new) - - msk2 = (elist2 == elmid) - npxl = count(msk2) - - IF (is_new) THEN - IF (iloc < nelm) THEN - iaddr(iloc+1:nelm) = iaddr(iloc:nelm-1) - ENDIF - iaddr(iloc) = nelm - - meshtmp(iaddr(iloc))%indx = elmid - meshtmp(iaddr(iloc))%npxl = npxl - ELSE - meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl - ENDIF - - allocate (xlist(npxl)) - allocate (ylist(npxl)) - xlist = pack(xlist2, msk2) - ylist = pack(ylist2, msk2) - - CALL append_to_list (meshtmp(iaddr(iloc))%ilon, xlist) - CALL append_to_list (meshtmp(iaddr(iloc))%ilat, ylist) - - WHERE(msk2) elist2 = -1 - - deallocate (xlist) - deallocate (ylist) - ENDIF - - ENDDO - ENDDO -#endif - - deallocate (elist2) - deallocate (xlist2) - deallocate (ylist2) - deallocate (msk2 ) - - ENDDO - -#ifdef USEMPI - DO irank = 0, p_np_compute-1 - idest = p_address_compute(irank) - ! send(07) - smesg(1:3) = (/p_iam_glb, 0, 0/) - CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - ENDDO -#endif - - ENDIF - -#ifdef USEMPI - IF (p_is_compute) THEN - - allocate(work_done(0:p_np_active-1)) - work_done(:) = .false. - DO WHILE (.not. all(work_done)) - ! recv(03,07) - CALL mpi_recv (rmesg(1:3), 3, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - blktag = rmesg(3) - IF (nrecv > 0) THEN - - allocate (elist_recv (nrecv)) - ! recv(04) - CALL mpi_recv (elist_recv, nrecv, MPI_INTEGER8, & - isrc, blktag, p_comm_glb, p_stat, p_err) - - allocate (xlist_recv (nrecv)) - ! recv(05) - CALL mpi_recv (xlist_recv, nrecv, MPI_INTEGER, & - isrc, blktag, p_comm_glb, p_stat, p_err) - - allocate (ylist_recv (nrecv)) - ! recv(06) - CALL mpi_recv (ylist_recv, nrecv, MPI_INTEGER, & - isrc, blktag, p_comm_glb, p_stat, p_err) - - allocate (msk(nrecv)) - - DO irecv = 1, nrecv - - elmid = elist_recv(irecv) - - IF (elmid > 0) THEN - - CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new) - - msk = (elist_recv == elmid) - npxl = count(msk) - - IF (is_new) THEN - IF (iloc < nelm) THEN - iaddr(iloc+1:nelm) = iaddr(iloc:nelm-1) - ENDIF - iaddr(iloc) = nelm - - meshtmp(iaddr(iloc))%indx = elmid - meshtmp(iaddr(iloc))%npxl = npxl - ELSE - meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl - ENDIF - - allocate (xlist(npxl)) - allocate (ylist(npxl)) - xlist = pack(xlist_recv, msk) - ylist = pack(ylist_recv, msk) - - CALL append_to_list (meshtmp(iaddr(iloc))%ilon, xlist) - CALL append_to_list (meshtmp(iaddr(iloc))%ilat, ylist) - - WHERE(msk) elist_recv = -1 - deallocate (xlist) - deallocate (ylist) - ENDIF - - ENDDO - - deallocate (msk) - deallocate (elist_recv) - deallocate (xlist_recv) - deallocate (ylist_recv) - ELSE - work_done(p_itis_active(isrc)) = .true. - ENDIF - ENDDO - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (allocated(elist)) deallocate (elist) - IF (allocated(iaddr)) deallocate (iaddr) - - ! Step 3: Which block each elm locates at. - IF (p_is_compute) THEN - - allocate (npxl_blk (gblock%nxblk,gblock%nyblk)) - allocate (nelm_blk (gblock%nxblk,gblock%nyblk)) - - nelm_blk(:,:) = 0 - - DO ie = 1, nelm - - npxl_blk (:,:) = 0 - - DO ipxl = 1, meshtmp(ie)%npxl - xp = meshtmp(ie)%ilon(ipxl) - yp = meshtmp(ie)%ilat(ipxl) - - xg = gridmesh%xgrd(xp) - yg = gridmesh%ygrd(yp) - - xblk = gridmesh%xblk(xg) - yblk = gridmesh%yblk(yg) - - npxl_blk(xblk,yblk) = npxl_blk(xblk,yblk) + 1 - ENDDO - - iloc_max = maxloc(npxl_blk) - meshtmp(ie)%xblk = iloc_max(1) - meshtmp(ie)%yblk = iloc_max(2) - - nelm_blk(iloc_max(1), iloc_max(2)) = & - nelm_blk(iloc_max(1), iloc_max(2)) + 1 - - ENDDO - - deallocate (npxl_blk) - ENDIF - -#ifdef USEMPI - IF (.not. p_is_compute) THEN - allocate (nelm_blk (gblock%nxblk,gblock%nyblk)) - nelm_blk(:,:) = 0 - ENDIF - - CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, & - MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) -#endif - - ! Step 4: IF MPI is used, sending elms from rank to their IO processes. - - IF (p_is_active) THEN - - allocate (blkdsp (gblock%nxblk, gblock%nyblk)) - blkdsp(1,1) = 0 - DO iblk = 1, gblock%nxblk - DO jblk = 1, gblock%nyblk - IF ((iblk /= 1) .or. (jblk /= 1)) THEN - IF (jblk == 1) THEN - iblk_p = iblk - 1 - jblk_p = gblock%nyblk - ELSE - iblk_p = iblk - jblk_p = jblk - 1 - ENDIF - - IF (gblock%pio(iblk_p,jblk_p) == p_iam_glb) THEN - blkdsp(iblk,jblk) = blkdsp(iblk_p,jblk_p) + nelm_blk(iblk_p,jblk_p) - ELSE - blkdsp(iblk,jblk) = blkdsp(iblk_p,jblk_p) - ENDIF - ENDIF - ENDDO - ENDDO - - ENDIF - -#ifdef USEMPI - IF (p_is_compute) THEN - DO iblk = 1, gblock%nxblk - DO jblk = 1, gblock%nyblk - - idest = gblock%pio(iblk,jblk) - - nsend = 0 - npxl = 0 - DO ie = 1, nelm - IF ((meshtmp(ie)%xblk == iblk) .and. (meshtmp(ie)%yblk == jblk)) THEN - nsend = nsend + 1 - npxl = npxl + meshtmp(ie)%npxl - ENDIF - ENDDO - - IF (nsend > 0) THEN - - allocate (elist (nsend)) - allocate (npxl_ (nsend)) - allocate (xlist (npxl )) - allocate (ylist (npxl )) - - nsend = 0 - npxl = 0 - DO ie = 1, nelm - IF ((meshtmp(ie)%xblk == iblk) .and. (meshtmp(ie)%yblk == jblk)) THEN - - nsend = nsend + 1 - - elist(nsend) = meshtmp(ie)%indx - npxl_(nsend) = meshtmp(ie)%npxl - - xlist(npxl+1:npxl+meshtmp(ie)%npxl) = meshtmp(ie)%ilon - ylist(npxl+1:npxl+meshtmp(ie)%npxl) = meshtmp(ie)%ilat - - npxl = npxl + meshtmp(ie)%npxl - ENDIF - ENDDO - - blktag = p_iam_glb + 1000 - - ! send(09) - smesg(1:6) = (/p_iam_glb, blktag, iblk, jblk, nsend, npxl/) - CALL mpi_send (smesg(1:6), 6, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err) - - ! send(10) - CALL mpi_send (elist, nsend, MPI_INTEGER8, idest, blktag, p_comm_glb, p_err) - CALL mpi_send (npxl_, nsend, MPI_INTEGER, idest, blktag, p_comm_glb, p_err) - - ! send(11) - CALL mpi_send (xlist, npxl, MPI_INTEGER, idest, blktag, p_comm_glb, p_err) - CALL mpi_send (ylist, npxl, MPI_INTEGER, idest, blktag, p_comm_glb, p_err) - - deallocate (elist) - deallocate (npxl_) - deallocate (xlist) - deallocate (ylist) - - ENDIF - ENDDO - ENDDO - ENDIF - - IF (p_is_active) THEN - - numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) - - IF (numelm > 0) THEN - - allocate (mesh (numelm)) - - allocate (blkcnt (gblock%nxblk, gblock%nyblk)) - blkcnt(:,:) = 0 - - DO WHILE (sum(blkcnt) < numelm) - - ! recv(09) - CALL mpi_recv (rmesg(1:6), 6, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = rmesg(1) - blktag = rmesg(2) - xblk = rmesg(3) - yblk = rmesg(4) - nrecv = rmesg(5) - npxl = rmesg(6) - - allocate (elist (nrecv)) - allocate (npxl_ (nrecv)) - allocate (xlist (npxl )) - allocate (ylist (npxl )) - - ! recv(10) - CALL mpi_recv (elist, nrecv, MPI_INTEGER8, isrc, blktag, p_comm_glb, p_stat, p_err) - CALL mpi_recv (npxl_, nrecv, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err) - - ! recv(11) - CALL mpi_recv (xlist, npxl, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err) - CALL mpi_recv (ylist, npxl, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err) - - dsp = 0 - DO ie = 1, nrecv - - je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk) + ie - - mesh(je)%indx = elist(ie) - mesh(je)%xblk = xblk - mesh(je)%yblk = yblk - mesh(je)%npxl = npxl_(ie) - - allocate (mesh(je)%ilon (npxl_(ie))) - allocate (mesh(je)%ilat (npxl_(ie))) - - mesh(je)%ilon = xlist(dsp+1:dsp+npxl_(ie)) - mesh(je)%ilat = ylist(dsp+1:dsp+npxl_(ie)) - - dsp = dsp + npxl_(ie) - - ENDDO - - blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + nrecv - - deallocate (elist) - deallocate (npxl_) - deallocate (xlist) - deallocate (ylist) - - ENDDO - - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) - -#else - numelm = nelm - IF (numelm > 0) THEN - - allocate (mesh (numelm)) - - allocate (blkcnt (gblock%nxblk, gblock%nyblk)) - blkcnt(:,:) = 0 - DO ie = 1, numelm - - xblk = meshtmp(ie)%xblk - yblk = meshtmp(ie)%yblk - - blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + 1 - je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk) - - CALL copy_elm (meshtmp(ie), mesh(je)) - - ENDDO - - ENDIF -#endif - - ! Step 4-2: sort elms. - IF (p_is_active) THEN - IF (allocated (meshtmp)) THEN - DO ie = 1, size(meshtmp) - IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon) - IF (allocated(meshtmp(ie)%ilat)) deallocate (meshtmp(ie)%ilat) - ENDDO - deallocate (meshtmp) - ENDIF - - IF (numelm > 0) THEN - allocate (meshtmp (numelm)) - DO ie = 1, numelm - CALL copy_elm(mesh(ie), meshtmp(ie)) - ENDDO - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - IF (blkcnt(iblk,jblk) > 0) THEN - allocate (elmindx (blkcnt(iblk,jblk))) - allocate (order (blkcnt(iblk,jblk))) - - DO ie = blkdsp(iblk,jblk)+1, blkdsp(iblk,jblk)+blkcnt(iblk,jblk) - elmindx(ie-blkdsp(iblk,jblk)) = mesh(ie)%indx - ENDDO - - order = (/ (ie, ie = 1, blkcnt(iblk,jblk)) /) - CALL quicksort (blkcnt(iblk,jblk), elmindx, order) - - DO ie = 1, blkcnt(iblk,jblk) - CALL copy_elm (meshtmp(blkdsp(iblk,jblk)+order(ie)), & - mesh(blkdsp(iblk,jblk)+ie)) - ENDDO - - deallocate (elmindx) - deallocate (order ) - ENDIF - - ENDDO - ENDIF - ENDIF - - IF (allocated(blkdsp)) deallocate(blkdsp) - IF (allocated(blkcnt)) deallocate(blkcnt) - - IF (allocated (meshtmp)) THEN - DO ie = 1, size(meshtmp) - IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon) - IF (allocated(meshtmp(ie)%ilat)) deallocate (meshtmp(ie)%ilat) - ENDDO - - deallocate (meshtmp ) - ENDIF - - ! Step 5: IF MPI is used, scatter elms from IO to ranks. -#ifdef USEMPI -#ifndef MPAS_EMBEDDED_COLM - CALL scatter_mesh_legacy_roles () -#endif -#endif - - IF (p_is_root) THEN - write(*,'(A)') 'Making mesh elements:' - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) - - IF (p_is_active) THEN - - CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_active, p_err) - IF (p_iam_active == p_root) THEN - write(*,'(A,I12,A)') 'Total : ', nelm_glb, ' elements.' - ENDIF - - nelm_max_blk = maxval(nelm_blk, mask = gblock%pio == p_iam_glb) - CALL mpi_allreduce (MPI_IN_PLACE, nelm_max_blk, 1, MPI_INTEGER, MPI_MAX, p_comm_active, p_err) - IF (p_iam_active == p_root) THEN - write(*,'(A,I12,A)') 'Maximum : ', nelm_max_blk, & - ' elements in one block (More than 3600 is recommended).' - write(*,'(/,A)') ' -----------------------------------------------------------------' - write(*,'(A)') ' | Examples for setting of blocks and processor groupsize: |' - write(*,'(A)') ' | Resolution DEF_nx_blocks DEF_ny_blocks DEF_PIO_groupsize |' - write(*,'(A)') ' | 2x2 18 9 15 |' - write(*,'(A)') ' | 1x1 18 9 24 |' - write(*,'(A)') ' | 0.5x0.5 18 9 36 |' - write(*,'(A)') ' | 0.25x0.25 30 15 45 |' - write(*,'(A)') ' | 0.1x0.1 72 36 64 |' - write(*,'(A,/)') ' -----------------------------------------------------------------' - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numelm, ' elements.' -#endif - - END SUBROUTINE mesh_build - - -#ifdef USEMPI -#ifndef MPAS_EMBEDDED_COLM - ! -------------------------------- - SUBROUTINE scatter_mesh_legacy_roles - - USE MOD_SPMD_Task - USE MOD_Block - IMPLICIT NONE - - ! Local variables - integer :: iblk, jblk, nave, nres, iproc, ndsp, nsend, idest, ie - integer :: smesg(4), rmesg(4) - integer, allocatable :: nelm_rank(:) - integer :: iblkme - character(len=20) :: wfmt - - CALL mpi_barrier (p_comm_glb, p_err) - - IF (p_is_active) THEN - - allocate (nelm_rank (1:p_np_group-1)) - nelm_rank(:) = 0 - - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - nave = nelm_blk(iblk,jblk) / (p_np_group-1) - nres = mod(nelm_blk(iblk,jblk), p_np_group-1) - DO iproc = 1, p_np_group-1 - nelm_rank(iproc) = nelm_rank(iproc) + nave - IF (iproc <= nres) nelm_rank(iproc) = nelm_rank(iproc) + 1 - ENDDO - ENDDO - - IF (any(nelm_rank == 0)) THEN - write(*,'(A,/,A)') 'Warning: there are idle ranks, please use less processors ' // & - 'OR larger working group ', ' (set by DEF_PIO_groupsize in CoLM namelist).' - write(wfmt,'(A,I0,A)') '(A,I6,A,', p_np_group-1, '(X,I0))' - write(*,wfmt) 'Numbers of elements by ranks in group ', p_iam_glb, ' are ', nelm_rank - ENDIF - - DO iproc = 1, p_np_group-1 - CALL mpi_send (nelm_rank(iproc), 1, MPI_INTEGER, & - iproc, mpi_tag_size, p_comm_group, p_err) - ENDDO - deallocate (nelm_rank) - - ndsp = 0 - DO iblkme = 1, gblock%nblkme - iblk = gblock%xblkme(iblkme) - jblk = gblock%yblkme(iblkme) - - nave = nelm_blk(iblk,jblk) / (p_np_group-1) - nres = mod(nelm_blk(iblk,jblk), p_np_group-1) - DO iproc = 1, p_np_group-1 - nsend = nave - IF (iproc <= nres) nsend = nsend + 1 - - DO ie = ndsp+1, ndsp+nsend - idest = iproc - CALL mpi_send (mesh(ie)%indx, 1, MPI_INTEGER8, & - idest, mpi_tag_mesg, p_comm_group, p_err) - smesg(1:3) = (/mesh(ie)%xblk, mesh(ie)%yblk, mesh(ie)%npxl/) - CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_group, p_err) - CALL mpi_send (mesh(ie)%ilon, mesh(ie)%npxl, & - MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err) - CALL mpi_send (mesh(ie)%ilat, mesh(ie)%npxl, & - MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err) - ENDDO - ndsp = ndsp + nsend - ENDDO - ENDDO - - ENDIF - - IF (p_is_compute) THEN - - CALL mpi_recv (numelm, 1, MPI_INTEGER, & - p_root, mpi_tag_size, p_comm_group, p_stat, p_err) - - IF (numelm > 0) THEN - allocate (mesh (numelm)) - - DO ie = 1, numelm - CALL mpi_recv (mesh(ie)%indx, 1, MPI_INTEGER8, & - p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err) - CALL mpi_recv (rmesg, 3, MPI_INTEGER, & - p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err) - - mesh(ie)%xblk = rmesg(1) - mesh(ie)%yblk = rmesg(2) - mesh(ie)%npxl = rmesg(3) - - allocate (mesh(ie)%ilon (mesh(ie)%npxl)) - allocate (mesh(ie)%ilat (mesh(ie)%npxl)) - - CALL mpi_recv (mesh(ie)%ilon, mesh(ie)%npxl, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_group, p_stat, p_err) - CALL mpi_recv (mesh(ie)%ilat, mesh(ie)%npxl, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_group, p_stat, p_err) - ENDDO - - ENDIF - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) - - END SUBROUTINE scatter_mesh_legacy_roles - -#endif -#endif ! -------------------------------- SUBROUTINE mesh_free_mem () @@ -1044,6 +127,9 @@ SUBROUTINE mesh_free_mem () deallocate (mesh) ENDIF + IF (allocated(nelm_blk)) deallocate(nelm_blk) + CALL grid_free_mem(gridmesh) + numelm = 0 END SUBROUTINE mesh_free_mem diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 deleted file mode 100644 index d4796ff885..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 +++ /dev/null @@ -1,181 +0,0 @@ -#include - -MODULE MOD_MeshFilter - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Mesh filter. -! Mesh filter can be used to mask part of region or globe as needed. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - USE MOD_Grid - IMPLICIT NONE - - logical :: has_mesh_filter - type(grid_type) :: grid_filter - -CONTAINS - - logical FUNCTION inquire_mesh_filter () - - USE MOD_SPMD_Task - USE MOD_Namelist - IMPLICIT NONE - logical :: fexists - - IF (p_is_root) THEN - - inquire (file=trim(DEF_file_mesh_filter), exist=fexists) - - IF (.not. fexists) THEN - write(*,'(/, 2A)') 'Note: Mesh Filter not used: file ', trim(DEF_file_mesh_filter) - ELSE - write(*,'(/, 2A)') 'Note: Mesh Filter from file ', trim(DEF_file_mesh_filter) - ENDIF - ENDIF - -#ifdef USEMPI - CALL mpi_bcast (fexists, 1, MPI_LOGICAL, p_address_root, p_comm_glb, p_err) -#endif - - inquire_mesh_filter = fexists - - END FUNCTION inquire_mesh_filter - - ! ------------- - SUBROUTINE mesh_filter (gridf, ffilter, fvname) - - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_NetCDFBlock - USE MOD_DataType - USE MOD_LandElm - USE MOD_Mesh - USE MOD_AggregationRequestData - USE MOD_Block - IMPLICIT NONE - - type(grid_type), intent(in) :: gridf - character(len=*), intent(in) :: ffilter - character(len=*), intent(in) :: fvname - - ! local variables: - ! --------------------------------------------------------------- - type (block_data_int32_2d) :: datafilter - integer, allocatable :: ifilter(:), xtemp(:), ytemp(:) - logical, allocatable :: filter(:) - integer :: ielm, jelm, npxl, nelm_glb - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) THEN - write(*,'(/, A)') 'Filtering pixels ...' - ENDIF - - IF (p_is_active) THEN - CALL allocate_block_data (gridf, datafilter) - CALL ncio_read_block (trim(ffilter), trim(fvname), gridf, datafilter) - -#ifdef USEMPI - CALL aggregation_data_daemon (gridf, data_i4_2d_in1 = datafilter) -#endif - ENDIF - - IF (p_is_compute) THEN - - jelm = 0 - DO ielm = 1, numelm - CALL aggregation_request_data (landelm, ielm, gridf, zip = .false., & - data_i4_2d_in1 = datafilter, data_i4_2d_out1 = ifilter, & - filledvalue_i4 = -1) - - allocate (filter (mesh(ielm)%npxl)) - filter = ifilter > 0 - - IF (any(filter)) THEN - jelm = jelm + 1 - IF (.not. all(filter)) THEN - - npxl = count(filter) - - allocate (xtemp(npxl)) - allocate (ytemp(npxl)) - xtemp = pack(mesh(ielm)%ilon, filter) - ytemp = pack(mesh(ielm)%ilat, filter) - - deallocate(mesh(ielm)%ilon) - deallocate(mesh(ielm)%ilat) - - mesh(ielm)%npxl = npxl - - allocate(mesh(ielm)%ilon(npxl)) - allocate(mesh(ielm)%ilat(npxl)) - mesh(ielm)%ilon = xtemp - mesh(ielm)%ilat = ytemp - - deallocate (xtemp) - deallocate (ytemp) - ENDIF - - IF (jelm /= ielm) THEN - CALL copy_elm (mesh(ielm), mesh(jelm)) - ENDIF - - ENDIF - - deallocate (filter) - ENDDO - - numelm = jelm - -#ifdef USEMPI - CALL aggregation_compute_done () -#endif - ENDIF - - IF (p_is_compute) THEN - IF (allocated(landelm%eindex)) deallocate (landelm%eindex) - IF (allocated(landelm%ipxstt)) deallocate (landelm%ipxstt) - IF (allocated(landelm%ipxend)) deallocate (landelm%ipxend) - IF (allocated(landelm%settyp)) deallocate (landelm%settyp) - IF (allocated(landelm%ielm )) deallocate (landelm%ielm ) - ENDIF - - CALL landelm_build () - -#ifdef USEMPI - IF (p_is_compute) THEN - CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err) - IF (p_iam_compute == 0) THEN - write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements after mesh filtering.' - ENDIF - ENDIF -#else - write(*,'(A,I12,A)') 'Total: ', numelm, ' elements after mesh filtering.' -#endif - - ! Update nelm_blk - nelm_blk(:,:) = 0 - IF (p_is_compute) THEN - DO ielm = 1, numelm - nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) = & - nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) + 1 - ENDDO - ENDIF -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, & - MPI_INTEGER, MPI_SUM, p_comm_glb, p_err) -#endif - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - END SUBROUTINE mesh_filter - -END MODULE MOD_MeshFilter diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 index d22cdf17ed..ee69e299c7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 @@ -48,11 +48,6 @@ MODULE MOD_Namelist integer :: DEF_nx_blocks = 72 integer :: DEF_ny_blocks = 36 - ! Standalone CoLM used this to size its role-split groups. - ! MPAS-embedded CoLM maps all active ranks to MPAS compute ranks. - integer :: DEF_PIO_groupsize = 12 - logical :: DEF_nIO_eq_nBlock = .false. - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! ----- Part 3: For Single Point ----- ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -128,8 +123,6 @@ MODULE MOD_Namelist character(len=256) :: DEF_CatchmentMesh_data = 'path/to/catchment/data' - character(len=256) :: DEF_file_mesh_filter = 'path/to/mesh/filter' - ! ----- Use surface data from existing dataset ----- ! case 1: from a larger region logical :: USE_srfdata_from_larger_region = .false. @@ -165,12 +158,6 @@ MODULE MOD_Namelist ! 2: Read a global soil color map from CLM integer :: DEF_SOIL_REFL_SCHEME = 2 - ! ----- merge data in aggregation when send data from IO to compute rank ----- - logical :: USE_zip_for_aggregation = .true. - - ! ----- compress level in writing aggregated surface data ----- - integer :: DEF_Srfdata_CompressLevel = 1 - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! ----- Part 7: Leaf Area Index ----- ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1025,7 +1012,8 @@ MODULE MOD_Namelist SUBROUTINE read_namelist (nlfile) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI + USE MOD_Utils, only: make_directory IMPLICIT NONE character(len=*), intent(in) :: nlfile @@ -1066,8 +1054,6 @@ SUBROUTINE read_namelist (nlfile) DEF_AverageElementSize, & DEF_nx_blocks, & DEF_ny_blocks, & - DEF_PIO_groupsize, & - DEF_nIO_eq_nBlock, & DEF_simulation_time, & DEF_dir_rawdata, & DEF_dir_runtime, & @@ -1076,7 +1062,6 @@ SUBROUTINE read_namelist (nlfile) DEF_GRIDBASED_lon_res, & DEF_GRIDBASED_lat_res, & DEF_CatchmentMesh_data, & - DEF_file_mesh_filter, & DEF_USE_LCT, & DEF_USE_PFT, & @@ -1128,8 +1113,6 @@ SUBROUTINE read_namelist (nlfile) DEF_dir_existing_srfdata, & USE_srfdata_from_larger_region, & USE_srfdata_from_3D_gridded_data, & - USE_zip_for_aggregation, & - DEF_Srfdata_CompressLevel, & DEF_USE_CBL_HEIGHT, & !add by zhongwang wei @ sysu 2022/12/31 DEF_USE_PLANTHYDRAULICS, & !add by xingjie lu @ sysu 2023/05/28 @@ -1254,7 +1237,7 @@ SUBROUTINE read_namelist (nlfile) namelist /nl_colm_history/ DEF_hist_vars ! ----- open the namelist file ----- - IF (p_is_root) THEN + IF (mpas_is_root) THEN open(10, status='OLD', file=nlfile, form="FORMATTED") read(10, nml=nl_colm, iostat=ierr, iomsg=iomesg) @@ -1264,26 +1247,32 @@ SUBROUTINE read_namelist (nlfile) ENDIF close(10) - open(10, status='OLD', file=trim(DEF_forcing_namelist), form="FORMATTED") - read(10, nml=nl_colm_forcing, iostat=ierr, iomsg=iomesg) - IF (ierr /= 0) THEN - write(*,*) 'ERROR in ', trim(DEF_forcing_namelist), ' : ', trim(iomesg) - CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(DEF_forcing_namelist)) - ENDIF - close(10) - - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - DEF_forcing%has_missing_value = .false. - ENDIF +#ifndef MPAS_EMBEDDED_COLM + open(10, status='OLD', file=trim(DEF_forcing_namelist), form="FORMATTED") + read(10, nml=nl_colm_forcing, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(DEF_forcing_namelist), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(DEF_forcing_namelist)) + ENDIF + close(10) + + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + DEF_forcing%has_missing_value = .false. + ENDIF +#endif DEF_dir_landdata = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/landdata' DEF_dir_restart = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/restart' DEF_dir_history = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/history' - CALL system('mkdir -p ' // trim(adjustl(DEF_dir_output ))) - CALL system('mkdir -p ' // trim(adjustl(DEF_dir_landdata))) - CALL system('mkdir -p ' // trim(adjustl(DEF_dir_restart ))) - CALL system('mkdir -p ' // trim(adjustl(DEF_dir_history ))) + CALL make_directory(DEF_dir_output) +#ifndef MPAS_EMBEDDED_COLM + CALL make_directory(DEF_dir_landdata) +#endif + CALL make_directory(DEF_dir_restart) +#ifndef MPAS_EMBEDDED_COLM + CALL make_directory(DEF_dir_history) +#endif #ifdef SinglePoint DEF_nx_blocks = 360 @@ -1291,11 +1280,13 @@ SUBROUTINE read_namelist (nlfile) DEF_HIST_mode = 'one' #endif +#ifndef MPAS_EMBEDDED_COLM IF (DEF_simulation_time%timestep > 3600.) THEN write(*,*) ' ***** ' write(*,*) 'Warning: timestep should be less than or equal to 3600 seconds.' CALL CoLM_Stop () ENDIF +#endif ! =============================================================== ! ----- Macros&Namelist conflicts and dependency management ----- @@ -1617,284 +1608,282 @@ SUBROUTINE read_namelist (nlfile) ENDIF -#ifdef USEMPI - CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) +#ifdef MPAS_MPI + CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_PIO_groupsize ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_nIO_eq_nBlock ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) #if (defined GRIDBASED || defined UNSTRUCTURED) - CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) #endif #ifdef CATCHMENT - CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) #endif - CALL mpi_bcast (DEF_file_mesh_filter ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (USE_zip_for_aggregation ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Srfdata_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 07/2023, added by yuan: subgrid setting related - CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 05/2023, added by Xingjie lu - CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! LULC related - CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) - CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 05/2023, added by yuan - CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 06/2023, added by weinan - CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 06/2023, added by hua yuan - CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 07/2023, added by zhuo liu - CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 02/2024, added by Shupeng Zhang - CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ! 08/2023, added by hua yuan - CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - - CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + +#ifndef MPAS_EMBEDDED_COLM + CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) DO ivar = 1, 8 - CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) ENDDO - CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) - CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err) + CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) +#endif + CALL mpas_mpi_check('CoLM namelist broadcast') #endif - CALL sync_hist_vars (set_defaults = .true.) +#ifndef MPAS_EMBEDDED_COLM + CALL sync_hist_vars (set_defaults = .true.) - IF (p_is_root) THEN + IF (mpas_is_root) THEN inquire (file=trim(DEF_HIST_vars_namelist), exist=fexists) IF (.not. fexists) THEN @@ -1967,7 +1956,8 @@ SUBROUTINE read_namelist (nlfile) ENDIF ENDIF - CALL sync_hist_vars (set_defaults = .false.) + CALL sync_hist_vars (set_defaults = .false.) +#endif END SUBROUTINE read_namelist @@ -2487,20 +2477,20 @@ END SUBROUTINE sync_hist_vars SUBROUTINE sync_hist_vars_one (onoff, set_defaults) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE logical, intent(inout) :: onoff logical, intent(in) :: set_defaults - IF (p_is_root) THEN + IF (mpas_is_root) THEN IF (set_defaults) THEN onoff = DEF_HIST_vars_out_default ENDIF ENDIF -#ifdef USEMPI - CALL mpi_bcast (onoff, 1, mpi_logical, p_address_root, p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_bcast (onoff, 1, mpi_logical, mpas_root, mpas_comm, mpas_mpi_ierr) #endif END SUBROUTINE sync_hist_vars_one diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 index 68f36f0231..25c100fba1 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 @@ -47,7 +47,7 @@ SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character (len=*), intent(in) :: filename @@ -61,7 +61,7 @@ SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) integer :: ncid, varid integer :: iblkme - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -107,7 +107,7 @@ SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character (len=*), intent(in) :: filename @@ -121,7 +121,7 @@ SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) integer :: ncid, varid integer :: iblkme - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -167,7 +167,7 @@ SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character (len=*), intent(in) :: filename @@ -182,7 +182,7 @@ SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) integer :: iblk, jblk, ndims(3), start3(3), count3(3), start_mem integer :: iblkme - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -229,7 +229,7 @@ SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character (len=*), intent(in) :: filename @@ -244,7 +244,7 @@ SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata integer :: ncid, varid integer :: iblkme - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -291,7 +291,7 @@ SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character (len=*), intent(in) :: filename @@ -306,7 +306,7 @@ SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata integer :: ncid, varid integer :: iblkme - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -352,7 +352,7 @@ SUBROUTINE ncio_read_block_real8_3d_time (filename, dataname, grid, ndim1, itime USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character (len=*), intent(in) :: filename @@ -367,7 +367,7 @@ SUBROUTINE ncio_read_block_real8_3d_time (filename, dataname, grid, ndim1, itime integer :: ncid, varid integer :: iblkme - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') @@ -413,7 +413,7 @@ SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) USE netcdf USE MOD_Block USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist IMPLICIT NONE @@ -430,7 +430,7 @@ SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) integer, SAVE :: ncid, time_dim logical, SAVE :: fid = .false. - IF (p_is_active) THEN + IF (.true.) THEN CALL check_ncfile_exist (filename) IF ((.not. fid) .or. (trim(fileopen) /= trim(filename))) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 index 89c0b68b60..5b7c5d655d 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 @@ -139,7 +139,7 @@ MODULE MOD_NetCDFSerial ! ---- SUBROUTINE nccheck (status, trace) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE integer, intent(in) :: status @@ -160,7 +160,7 @@ END SUBROUTINE nccheck ! ---- SUBROUTINE check_ncfile_exist (filename) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character(len=*), intent(in) :: filename @@ -827,18 +827,19 @@ END SUBROUTINE ncio_read_serial_real8_5d SUBROUTINE ncio_read_bcast_serial_int32_0d (filename, dataname, rdata) USE netcdf - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character(len=*), intent(in) :: filename character(len=*), intent(in) :: dataname integer, intent(out) :: rdata -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_int32_0d (filename, dataname, rdata) ENDIF - CALL mpi_bcast (rdata, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (rdata, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF scalar integer broadcast') #else CALL ncio_read_serial_int32_0d (filename, dataname, rdata) #endif @@ -848,7 +849,7 @@ END SUBROUTINE ncio_read_bcast_serial_int32_0d !--------------------------------------------------------- SUBROUTINE ncio_read_bcast_serial_real8_0d (filename, dataname, rdata) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Precision IMPLICIT NONE @@ -856,11 +857,12 @@ SUBROUTINE ncio_read_bcast_serial_real8_0d (filename, dataname, rdata) character(len=*), intent(in) :: dataname real(r8), intent(out) :: rdata -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_real8_0d (filename, dataname, rdata) ENDIF - CALL mpi_bcast (rdata, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (rdata, 1, MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF scalar real broadcast') #else CALL ncio_read_serial_real8_0d (filename, dataname, rdata) #endif @@ -870,7 +872,7 @@ END SUBROUTINE ncio_read_bcast_serial_real8_0d !--------------------------------------------------------- SUBROUTINE ncio_read_bcast_serial_int32_1d (filename, dataname, rdata) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character(len=*), intent(in) :: filename @@ -878,14 +880,16 @@ SUBROUTINE ncio_read_bcast_serial_int32_1d (filename, dataname, rdata) integer, allocatable, intent(out) :: rdata (:) integer :: vlen -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_int32_1d(filename, dataname, rdata) vlen = size(rdata) ENDIF - CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vlen)) - CALL mpi_bcast (rdata, vlen, MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vlen, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer vector length broadcast') + IF (.not. mpas_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer vector broadcast') #else CALL ncio_read_serial_int32_1d(filename, dataname, rdata) #endif @@ -895,7 +899,7 @@ END SUBROUTINE ncio_read_bcast_serial_int32_1d !--------------------------------------------------------- SUBROUTINE ncio_read_bcast_serial_int32_2d (filename, dataname, rdata) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character(len=*), intent(in) :: filename @@ -903,14 +907,16 @@ SUBROUTINE ncio_read_bcast_serial_int32_2d (filename, dataname, rdata) integer, allocatable, intent(out) :: rdata (:,:) integer :: vsize(2) -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_int32_2d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vsize(1), vsize(2))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 2, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer array shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1), vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer array broadcast') #else CALL ncio_read_serial_int32_2d(filename, dataname, rdata) #endif @@ -921,7 +927,7 @@ END SUBROUTINE ncio_read_bcast_serial_int32_2d SUBROUTINE ncio_read_bcast_serial_real8_1d (filename, dataname, rdata) USE netcdf - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Precision IMPLICIT NONE @@ -930,14 +936,16 @@ SUBROUTINE ncio_read_bcast_serial_real8_1d (filename, dataname, rdata) real(r8), allocatable, intent(out) :: rdata (:) integer :: vlen -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_real8_1d(filename, dataname, rdata) vlen = size(rdata) ENDIF - CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vlen)) - CALL mpi_bcast (rdata, vlen, MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vlen, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF real vector length broadcast') + IF (.not. mpas_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF real vector broadcast') #else CALL ncio_read_serial_real8_1d(filename, dataname, rdata) #endif @@ -948,7 +956,7 @@ END SUBROUTINE ncio_read_bcast_serial_real8_1d SUBROUTINE ncio_read_bcast_serial_real8_2d (filename, dataname, rdata) USE netcdf - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Precision IMPLICIT NONE @@ -957,14 +965,16 @@ SUBROUTINE ncio_read_bcast_serial_real8_2d (filename, dataname, rdata) real(r8), allocatable, intent(out) :: rdata (:,:) integer :: vsize(2) -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_real8_2d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 2, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-2 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-2 real broadcast') #else CALL ncio_read_serial_real8_2d(filename, dataname, rdata) #endif @@ -975,7 +985,7 @@ END SUBROUTINE ncio_read_bcast_serial_real8_2d SUBROUTINE ncio_read_bcast_serial_real8_3d (filename, dataname, rdata) USE netcdf - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Precision IMPLICIT NONE @@ -984,14 +994,16 @@ SUBROUTINE ncio_read_bcast_serial_real8_3d (filename, dataname, rdata) real(r8), allocatable, intent(out) :: rdata (:,:,:) integer :: vsize(3) -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_real8_3d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 3, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 3, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-3 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-3 real broadcast') #else CALL ncio_read_serial_real8_3d(filename, dataname, rdata) #endif @@ -1002,7 +1014,7 @@ END SUBROUTINE ncio_read_bcast_serial_real8_3d SUBROUTINE ncio_read_bcast_serial_real8_4d (filename, dataname, rdata) USE netcdf - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Precision IMPLICIT NONE @@ -1011,14 +1023,16 @@ SUBROUTINE ncio_read_bcast_serial_real8_4d (filename, dataname, rdata) real(r8), allocatable, intent(out) :: rdata (:,:,:,:) integer :: vsize(4) -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_real8_4d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 4, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4), MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 4, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-4 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-4 real broadcast') #else CALL ncio_read_serial_real8_4d(filename, dataname, rdata) #endif @@ -1029,7 +1043,7 @@ END SUBROUTINE ncio_read_bcast_serial_real8_4d SUBROUTINE ncio_read_bcast_serial_real8_5d (filename, dataname, rdata) USE netcdf - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Precision IMPLICIT NONE @@ -1038,14 +1052,16 @@ SUBROUTINE ncio_read_bcast_serial_real8_5d (filename, dataname, rdata) real(r8), allocatable, intent(out) :: rdata (:,:,:,:,:) integer :: vsize(5) -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_real8_5d(filename, dataname, rdata) vsize = shape(rdata) ENDIF - CALL mpi_bcast (vsize, 5, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4),vsize(5))) - CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4)*vsize(5), MPI_REAL8, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vsize, 5, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-5 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4),vsize(5))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4)*vsize(5), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-5 real broadcast') #else CALL ncio_read_serial_real8_5d(filename, dataname, rdata) #endif @@ -1055,7 +1071,7 @@ END SUBROUTINE ncio_read_bcast_serial_real8_5d ! ------------------------------- SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE character(len=*), intent(in) :: filename @@ -1064,8 +1080,8 @@ SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) integer :: vlen integer(1), allocatable :: rdata_byte(:) -#ifdef USEMPI - IF (p_is_root) THEN +#ifdef MPAS_MPI + IF (mpas_is_root) THEN CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) vlen = size(rdata_byte) @@ -1074,9 +1090,11 @@ SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) deallocate (rdata_byte) ENDIF - CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err) - IF (.not. p_is_root) allocate (rdata (vlen)) - CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, p_address_root, p_comm_glb, p_err) + CALL mpi_bcast (vlen, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF logical vector length broadcast') + IF (.not. mpas_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF logical vector broadcast') #else CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) vlen = size(rdata_byte) @@ -1193,7 +1211,8 @@ SUBROUTINE ncio_read_indexed_serial_int32_1d (filename, dataname, index, rdata) istart = 1 DO WHILE (istart <= nidx) iend = istart - DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT iend = iend + 1 ENDDO nread = iend - istart + 1 @@ -1233,7 +1252,8 @@ SUBROUTINE ncio_read_indexed_serial_real8_1d (filename, dataname, index, rdata) istart = 1 DO WHILE (istart <= nidx) iend = istart - DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT iend = iend + 1 ENDDO nread = iend - istart + 1 @@ -1278,7 +1298,8 @@ SUBROUTINE ncio_read_indexed_serial_int32_2d (filename, dataname, index, rdata) istart = 1 DO WHILE (istart <= nidx) iend = istart - DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT iend = iend + 1 ENDDO nread = iend - istart + 1 @@ -1325,7 +1346,8 @@ SUBROUTINE ncio_read_indexed_serial_real8_2d (filename, dataname, index, rdata) istart = 1 DO WHILE (istart <= nidx) iend = istart - DO WHILE (iend < nidx .and. index(iend+1) == index(iend) + 1) + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT iend = iend + 1 ENDDO nread = iend - istart + 1 diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 index f803c3d468..3c8f419d0c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -1,9 +1,5 @@ #include -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) -#define COLM_VECTOR_MPI_IO -#endif - !---------------------------------------------------------------------------------- ! !DESCRIPTION: ! @@ -35,8 +31,34 @@ MODULE MOD_NetCDFVector USE MOD_DataType +#ifdef MPAS_EMBEDDED_COLM + USE mpi, only: MPI_Barrier + USE MOD_MPAS_MPI, only: CoLM_stop +#endif IMPLICIT NONE +#ifdef MPAS_EMBEDDED_COLM + type :: distributed_vector_map_type + character(len=512) :: filename = '' + integer :: iblk = 0 + integer :: jblk = 0 + integer :: istt = 0 + integer :: iend = -1 + integer*8, allocatable :: eindex(:) + integer, allocatable :: ipxstt(:) + integer, allocatable :: ipxend(:) + integer, allocatable :: settyp(:) + integer, allocatable :: source_rank(:) + integer, allocatable :: source_pos(:) + integer, allocatable :: source_ranks(:) + integer, allocatable :: source_lengths(:) + END type distributed_vector_map_type + + type(distributed_vector_map_type), allocatable, save :: distributed_vector_maps(:) + character(len=512), allocatable, save :: validated_distributed_markers(:) + integer, allocatable, save :: distributed_marker_ranks(:) +#endif + ! PUBLIC subroutines INTERFACE ncio_read_vector @@ -52,6 +74,9 @@ MODULE MOD_NetCDFVector PUBLIC :: ncio_create_file_vector PUBLIC :: ncio_define_dimension_vector + PUBLIC :: ncio_begin_distributed_write + PUBLIC :: ncio_complete_distributed_write + PUBLIC :: ncio_reset_distributed_validation INTERFACE ncio_write_vector MODULE procedure ncio_write_vector_logical_1d @@ -65,14 +90,27 @@ MODULE MOD_NetCDFVector MODULE procedure ncio_write_vector_real8_5d END INTERFACE ncio_write_vector +#ifdef MPAS_EMBEDDED_COLM + INTERFACE read_distributed_vector_block + MODULE procedure read_distributed_int32_1d + MODULE procedure read_distributed_int64_1d + MODULE procedure read_distributed_int8_1d + MODULE procedure read_distributed_real8_1d + MODULE procedure read_distributed_real8_2d + MODULE procedure read_distributed_real8_3d + MODULE procedure read_distributed_real8_4d + MODULE procedure read_distributed_real8_5d + END INTERFACE read_distributed_vector_block +#endif + CONTAINS !--------------------------------------------------------- - SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write, use_srcpos) + SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write, use_srcpos, distributed_restart) USE MOD_Block, only: get_filename_block #ifdef MPAS_EMBEDDED_COLM - USE MOD_SPMD_Task, only: p_iam_glb + USE MOD_MPAS_MPI, only: mpas_rank, CoLM_stop #endif IMPLICIT NONE @@ -81,47 +119,908 @@ SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write character(len=*), intent(out) :: fileblock logical, intent(in), optional :: for_write logical, intent(inout), optional :: use_srcpos + logical, intent(out), optional :: distributed_restart #ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker character(len=256) :: fileblock_rank - character(len=32) :: rank_suffix - integer :: idot - logical :: rank_local_file + logical :: marker_exists, rank_file_exists, distributed_file #endif CALL get_filename_block (filename, iblk, jblk, fileblock) + IF (present(distributed_restart)) distributed_restart = .false. #ifdef MPAS_EMBEDDED_COLM - write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb - idot = len_trim(fileblock) - DO WHILE (idot > 0) - IF (fileblock(idot:idot) == '.') EXIT - idot = idot - 1 - ENDDO - - IF (idot > 0) THEN - fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) - ELSE - fileblock_rank = trim(fileblock) // trim(rank_suffix) - ENDIF - - rank_local_file = .false. - IF (present(for_write)) rank_local_file = for_write - IF ((.not. rank_local_file) .and. present(use_srcpos)) THEN - inquire(file=trim(fileblock_rank), exist=rank_local_file) + CALL add_rank_suffix(fileblock, mpas_rank, fileblock_rank) + + distributed_file = .false. + IF (present(for_write)) distributed_file = for_write + IF ((.not. distributed_file) .and. present(use_srcpos)) THEN + complete_marker = trim(filename)//'.mpas_complete' + inquire(file=trim(complete_marker), exist=marker_exists) + IF (marker_exists) THEN + distributed_file = .true. + ELSE + inquire(file=trim(fileblock_rank), exist=rank_file_exists) + IF (rank_file_exists) THEN + CALL CoLM_stop('MPAS embedded CoLM found an incomplete distributed restart without its completion marker: '// & + trim(fileblock_rank)) + ENDIF + ENDIF ENDIF - IF (rank_local_file) THEN + IF (present(for_write)) THEN + IF (distributed_file) fileblock = fileblock_rank + ELSEIF (distributed_file) THEN + ! A distributed restart can be repartitioned. The caller selects the + ! old rank shards through the stable pixelset identity map below. fileblock = fileblock_rank IF (present(use_srcpos)) use_srcpos = .false. ENDIF + IF (present(distributed_restart)) distributed_restart = distributed_file #endif END SUBROUTINE get_filename_vector_block + !--------------------------------------------------------- + SUBROUTINE add_rank_suffix(fileblock, rank, fileblock_rank) + + IMPLICIT NONE + + character(len=*), intent(in) :: fileblock + integer, intent(in) :: rank + character(len=*), intent(out) :: fileblock_rank + + character(len=32) :: rank_suffix + integer :: idot + + write(rank_suffix,'("_mpasr",I8.8)') rank + idot = len_trim(fileblock) + DO WHILE (idot > 0) + IF (fileblock(idot:idot) == '.') EXIT + idot = idot - 1 + ENDDO + + IF (idot > 0) THEN + fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) + ELSE + fileblock_rank = trim(fileblock) // trim(rank_suffix) + ENDIF + + END SUBROUTINE add_rank_suffix + + !--------------------------------------------------------- + SUBROUTINE read_distributed_marker(complete_marker, marker_ranks) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: CoLM_stop +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: complete_marker + integer, intent(out) :: marker_ranks + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: line + character(len=512), allocatable :: markers_new(:) + integer, allocatable :: marker_ranks_new(:) + integer :: i, iunit, ios, nvalidated, separator + + IF (allocated(validated_distributed_markers)) THEN + DO i = 1, size(validated_distributed_markers) + IF (trim(validated_distributed_markers(i)) == trim(complete_marker)) THEN + marker_ranks = distributed_marker_ranks(i) + RETURN + ENDIF + ENDDO + ENDIF + + open(newunit=iunit, file=trim(complete_marker), status='old', action='read', iostat=ios) + IF (ios /= 0) CALL CoLM_stop('Cannot read MPAS embedded CoLM restart marker: '//trim(complete_marker)) + read(iunit,'(A)',iostat=ios) line + close(iunit) + separator = index(line, ':') + IF (ios /= 0 .or. separator < 1 .or. separator >= len_trim(line)) THEN + CALL CoLM_stop('Invalid MPAS embedded CoLM restart marker: '//trim(complete_marker)) + ENDIF + read(line(separator+1:),*,iostat=ios) marker_ranks + IF (ios /= 0 .or. marker_ranks < 1) THEN + CALL CoLM_stop('Invalid MPI rank count in MPAS embedded CoLM restart marker: '//trim(complete_marker)) + ENDIF + IF (allocated(validated_distributed_markers)) THEN + nvalidated = size(validated_distributed_markers) + allocate(markers_new(nvalidated + 1)) + allocate(marker_ranks_new(nvalidated + 1)) + markers_new(1:nvalidated) = validated_distributed_markers + marker_ranks_new(1:nvalidated) = distributed_marker_ranks + markers_new(nvalidated + 1) = complete_marker + marker_ranks_new(nvalidated + 1) = marker_ranks + CALL move_alloc(markers_new, validated_distributed_markers) + CALL move_alloc(marker_ranks_new, distributed_marker_ranks) + ELSE + allocate(validated_distributed_markers(1)) + allocate(distributed_marker_ranks(1)) + validated_distributed_markers(1) = complete_marker + distributed_marker_ranks(1) = marker_ranks + ENDIF +#endif + + END SUBROUTINE read_distributed_marker + + !--------------------------------------------------------- + SUBROUTINE remove_rank_distributed_shards(filename) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_Block, only: gblock, get_filename_block + USE MOD_MPAS_MPI, only: mpas_rank, CoLM_stop +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: fileblock, fileblock_rank + integer :: iblk, jblk, iunit, iostat_open, iostat_close + logical :: shard_exists + + IF (gblock%nxblk < 1 .or. gblock%nyblk < 1) THEN + CALL CoLM_stop('Cannot clean distributed CoLM restart shards before block metadata is initialized.') + ENDIF + + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + CALL get_filename_block(filename, iblk, jblk, fileblock) + CALL add_rank_suffix(fileblock, mpas_rank, fileblock_rank) + inquire(file=trim(fileblock_rank), exist=shard_exists) + IF (.not. shard_exists) CYCLE + + open(newunit=iunit, file=trim(fileblock_rank), status='old', action='readwrite', iostat=iostat_open) + IF (iostat_open /= 0) THEN + CALL CoLM_stop('Cannot open stale MPAS embedded CoLM restart shard for removal: '// & + trim(fileblock_rank)) + ENDIF + close(iunit, status='delete', iostat=iostat_close) + IF (iostat_close /= 0) THEN + CALL CoLM_stop('Cannot remove stale MPAS embedded CoLM restart shard: '//trim(fileblock_rank)) + ENDIF + ENDDO + ENDDO +#endif + + END SUBROUTINE remove_rank_distributed_shards + + !--------------------------------------------------------- + SUBROUTINE ncio_begin_distributed_write(filename) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: mpas_is_root, mpas_comm, mpas_mpi_ierr, CoLM_stop, mpas_mpi_check +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + integer :: iunit, iostat_open, iostat_close + logical :: marker_exists + + complete_marker = trim(filename)//'.mpas_complete' + IF (mpas_is_root) THEN + inquire(file=trim(complete_marker), exist=marker_exists) + IF (marker_exists) THEN + open(newunit=iunit, file=trim(complete_marker), status='old', action='readwrite', iostat=iostat_open) + IF (iostat_open /= 0) CALL CoLM_stop('Cannot replace MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + close(iunit, status='delete', iostat=iostat_close) + IF (iostat_close /= 0) CALL CoLM_stop('Cannot remove stale MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + ENDIF + ENDIF + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart marker removal') + CALL remove_rank_distributed_shards(filename) + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart shard cleanup') +#endif + + END SUBROUTINE ncio_begin_distributed_write + + !--------------------------------------------------------- + SUBROUTINE ncio_complete_distributed_write(filename) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: mpas_is_root, mpas_comm, mpas_mpi_ierr, mpas_size, CoLM_stop, mpas_mpi_check +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + integer :: iunit, iostat_open, iostat_close + + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart shard completion') + complete_marker = trim(filename)//'.mpas_complete' + IF (mpas_is_root) THEN + open(newunit=iunit, file=trim(complete_marker), status='replace', action='write', iostat=iostat_open) + IF (iostat_open /= 0) CALL CoLM_stop('Cannot create MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + write(iunit,'(A,I0)') 'MPAS ranks: ', mpas_size + write(iunit,'(A)') 'Format: distributed-pixelset-v1' + close(iunit, iostat=iostat_close) + IF (iostat_close /= 0) CALL CoLM_stop('Cannot close MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + ENDIF + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart marker publication') +#endif + + END SUBROUTINE ncio_complete_distributed_write + + !--------------------------------------------------------- + SUBROUTINE ncio_reset_distributed_validation() + + IF (allocated(distributed_vector_maps)) deallocate(distributed_vector_maps) + IF (allocated(validated_distributed_markers)) deallocate(validated_distributed_markers) + IF (allocated(distributed_marker_ranks)) deallocate(distributed_marker_ranks) + + END SUBROUTINE ncio_reset_distributed_validation + + !--------------------------------------------------------- + SUBROUTINE prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + + USE MOD_NetCDFSerial + USE MOD_Block, only: get_filename_block + USE MOD_Pixelset + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + character(len=*), intent(in) :: filename + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer, intent(out) :: map_index + +#ifdef MPAS_EMBEDDED_COLM + type(distributed_vector_map_type), allocatable :: maps_new(:) + character(len=256) :: fileblock, source_file + character(len=512) :: complete_marker + integer :: istt, iend, nlocal, marker_ranks, irank, isource, ilocal + integer :: imap, nmaps, nused, iused + integer*8, allocatable :: file_eindex(:) + integer, allocatable :: file_ipxstt(:), file_ipxend(:), file_settyp(:) + integer, allocatable :: rank_lengths(:) + logical, allocatable :: used_rank(:) + logical :: source_exists + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + nlocal = iend - istt + 1 + IF (nlocal < 1 .or. istt < 1 .or. iend > pixelset%nset) THEN + CALL CoLM_stop('Invalid local pixelset block while preparing distributed restart mapping.') + ENDIF + IF (.not. allocated(pixelset%eindex) .or. .not. allocated(pixelset%ipxstt) .or. & + .not. allocated(pixelset%ipxend) .or. .not. allocated(pixelset%settyp)) THEN + CALL CoLM_stop('Current MPAS embedded CoLM pixelset lacks restart identity metadata.') + ENDIF + IF (size(pixelset%eindex) /= pixelset%nset .or. size(pixelset%ipxstt) /= pixelset%nset .or. & + size(pixelset%ipxend) /= pixelset%nset .or. size(pixelset%settyp) /= pixelset%nset) THEN + CALL CoLM_stop('Current MPAS embedded CoLM pixelset restart identity lengths are inconsistent.') + ENDIF + CALL validate_identity_vector(pixelset%eindex(istt:iend), pixelset%ipxstt(istt:iend), & + pixelset%ipxend(istt:iend), pixelset%settyp(istt:iend), & + 'current MPAS decomposition') + + IF (allocated(distributed_vector_maps)) THEN + DO imap = 1, size(distributed_vector_maps) + IF (trim(distributed_vector_maps(imap)%filename) /= trim(filename) .or. & + distributed_vector_maps(imap)%iblk /= iblk .or. & + distributed_vector_maps(imap)%jblk /= jblk .or. & + distributed_vector_maps(imap)%istt /= istt .or. & + distributed_vector_maps(imap)%iend /= iend) CYCLE + IF (all(distributed_vector_maps(imap)%eindex == pixelset%eindex(istt:iend)) .and. & + all(distributed_vector_maps(imap)%ipxstt == pixelset%ipxstt(istt:iend)) .and. & + all(distributed_vector_maps(imap)%ipxend == pixelset%ipxend(istt:iend)) .and. & + all(distributed_vector_maps(imap)%settyp == pixelset%settyp(istt:iend))) THEN + map_index = imap + RETURN + ENDIF + ENDDO + ENDIF + + complete_marker = trim(filename)//'.mpas_complete' + CALL read_distributed_marker(complete_marker, marker_ranks) + CALL get_filename_block(filename, iblk, jblk, fileblock) + allocate(rank_lengths(marker_ranks), used_rank(marker_ranks)) + rank_lengths = 0 + used_rank = .false. + + IF (allocated(distributed_vector_maps)) THEN + nmaps = size(distributed_vector_maps) + ELSE + nmaps = 0 + ENDIF + allocate(maps_new(nmaps + 1)) + IF (nmaps > 0) maps_new(1:nmaps) = distributed_vector_maps + map_index = nmaps + 1 + maps_new(map_index)%filename = filename + maps_new(map_index)%iblk = iblk + maps_new(map_index)%jblk = jblk + maps_new(map_index)%istt = istt + maps_new(map_index)%iend = iend + maps_new(map_index)%eindex = pixelset%eindex(istt:iend) + maps_new(map_index)%ipxstt = pixelset%ipxstt(istt:iend) + maps_new(map_index)%ipxend = pixelset%ipxend(istt:iend) + maps_new(map_index)%settyp = pixelset%settyp(istt:iend) + allocate(maps_new(map_index)%source_rank(nlocal)) + allocate(maps_new(map_index)%source_pos(nlocal)) + maps_new(map_index)%source_rank = -1 + maps_new(map_index)%source_pos = -1 + + DO irank = 0, marker_ranks - 1 + CALL add_rank_suffix(fileblock, irank, source_file) + inquire(file=trim(source_file), exist=source_exists) + IF (.not. source_exists) CYCLE + IF (.not. ncio_var_exist(source_file, 'mpas_eindex', readflag=.false.) .or. & + .not. ncio_var_exist(source_file, 'mpas_ipxstt', readflag=.false.) .or. & + .not. ncio_var_exist(source_file, 'mpas_ipxend', readflag=.false.) .or. & + .not. ncio_var_exist(source_file, 'mpas_settyp', readflag=.false.)) THEN + CALL CoLM_stop('Distributed MPAS-CoLM restart shard lacks pixelset identity metadata: '// & + trim(source_file)) + ENDIF + CALL ncio_read_serial(source_file, 'mpas_eindex', file_eindex) + CALL ncio_read_serial(source_file, 'mpas_ipxstt', file_ipxstt) + CALL ncio_read_serial(source_file, 'mpas_ipxend', file_ipxend) + CALL ncio_read_serial(source_file, 'mpas_settyp', file_settyp) + IF (size(file_eindex) < 1 .or. size(file_ipxstt) /= size(file_eindex) .or. & + size(file_ipxend) /= size(file_eindex) .or. size(file_settyp) /= size(file_eindex)) THEN + CALL CoLM_stop('Distributed MPAS-CoLM restart shard has inconsistent identity metadata: '// & + trim(source_file)) + ENDIF + CALL validate_identity_vector(file_eindex, file_ipxstt, file_ipxend, file_settyp, source_file) + rank_lengths(irank + 1) = size(file_eindex) + + DO isource = 1, size(file_eindex) + ilocal = find_identity(pixelset%eindex(istt:iend), pixelset%ipxstt(istt:iend), & + pixelset%ipxend(istt:iend), pixelset%settyp(istt:iend), & + file_eindex(isource), file_ipxstt(isource), & + file_ipxend(isource), file_settyp(isource)) + IF (ilocal > 0) THEN + IF (maps_new(map_index)%source_rank(ilocal) >= 0) THEN + CALL CoLM_stop('Duplicate pixelset identity across distributed MPAS-CoLM restart shards.') + ENDIF + maps_new(map_index)%source_rank(ilocal) = irank + maps_new(map_index)%source_pos(ilocal) = isource + used_rank(irank + 1) = .true. + ENDIF + ENDDO + + deallocate(file_eindex, file_ipxstt, file_ipxend, file_settyp) + ENDDO + + IF (any(maps_new(map_index)%source_rank < 0)) THEN + ilocal = minloc(maps_new(map_index)%source_rank, dim=1) + write(*,'(A,I0,A,I0,A,I0,A,I0)') 'Missing distributed restart identity: element=', & + maps_new(map_index)%eindex(ilocal), ', ipxstt=', maps_new(map_index)%ipxstt(ilocal), & + ', ipxend=', maps_new(map_index)%ipxend(ilocal), ', settyp=', maps_new(map_index)%settyp(ilocal) + CALL CoLM_stop('Distributed MPAS-CoLM restart does not cover the current pixelset decomposition.') + ENDIF + + nused = count(used_rank) + allocate(maps_new(map_index)%source_ranks(nused)) + allocate(maps_new(map_index)%source_lengths(nused)) + iused = 0 + DO irank = 0, marker_ranks - 1 + IF (.not. used_rank(irank + 1)) CYCLE + iused = iused + 1 + maps_new(map_index)%source_ranks(iused) = irank + maps_new(map_index)%source_lengths(iused) = rank_lengths(irank + 1) + ENDDO + + deallocate(rank_lengths, used_rank) + CALL move_alloc(maps_new, distributed_vector_maps) +#else + map_index = 0 +#endif + + END SUBROUTINE prepare_distributed_vector_map + + !--------------------------------------------------------- + SUBROUTINE validate_identity_vector(eindex, ipxstt, ipxend, settyp, source_name) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer*8, intent(in) :: eindex(:) + integer, intent(in) :: ipxstt(:), ipxend(:), settyp(:) + character(len=*), intent(in) :: source_name + integer :: istart, iend, i, j + + IF (size(ipxstt) /= size(eindex) .or. size(ipxend) /= size(eindex) .or. & + size(settyp) /= size(eindex)) THEN + CALL CoLM_stop('Inconsistent pixelset identity vector lengths in '//trim(source_name)//'.') + ENDIF + IF (size(eindex) > 1) THEN + IF (any(eindex(2:) < eindex(:size(eindex)-1))) THEN + CALL CoLM_stop('Pixelset identities are not ordered by element in '//trim(source_name)//'.') + ENDIF + ENDIF + + istart = 1 + DO WHILE (istart <= size(eindex)) + iend = istart + DO WHILE (iend < size(eindex)) + IF (eindex(iend + 1) /= eindex(istart)) EXIT + iend = iend + 1 + ENDDO + DO i = istart, iend - 1 + DO j = i + 1, iend + IF (ipxstt(i) == ipxstt(j) .and. ipxend(i) == ipxend(j) .and. & + settyp(i) == settyp(j)) THEN + CALL CoLM_stop('Duplicate pixelset identity in '//trim(source_name)//'.') + ENDIF + ENDDO + ENDDO + istart = iend + 1 + ENDDO + + END SUBROUTINE validate_identity_vector + + !--------------------------------------------------------- + INTEGER FUNCTION find_identity(eindex, ipxstt, ipxend, settyp, target_eindex, & + target_ipxstt, target_ipxend, target_settyp) + + IMPLICIT NONE + + integer*8, intent(in) :: eindex(:), target_eindex + integer, intent(in) :: ipxstt(:), ipxend(:), settyp(:) + integer, intent(in) :: target_ipxstt, target_ipxend, target_settyp + integer :: lo, hi, mid, ifirst, ilast, i + + find_identity = 0 + lo = 1 + hi = size(eindex) + DO WHILE (lo <= hi) + mid = lo + (hi - lo) / 2 + IF (eindex(mid) < target_eindex) THEN + lo = mid + 1 + ELSEIF (eindex(mid) > target_eindex) THEN + hi = mid - 1 + ELSE + ifirst = mid + ilast = mid + DO WHILE (ifirst > 1) + IF (eindex(ifirst - 1) /= target_eindex) EXIT + ifirst = ifirst - 1 + ENDDO + DO WHILE (ilast < size(eindex)) + IF (eindex(ilast + 1) /= target_eindex) EXIT + ilast = ilast + 1 + ENDDO + DO i = ifirst, ilast + IF (ipxstt(i) == target_ipxstt .and. ipxend(i) == target_ipxend .and. & + settyp(i) == target_settyp) THEN + find_identity = i + RETURN + ENDIF + ENDDO + RETURN + ENDIF + ENDDO + + END FUNCTION find_identity + + !--------------------------------------------------------- + SUBROUTINE get_distributed_source(map_index, source_index, source_file, source_rank, source_length) + + USE MOD_Block, only: get_filename_block + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: map_index, source_index + character(len=*), intent(out) :: source_file + integer, intent(out) :: source_rank, source_length + +#ifdef MPAS_EMBEDDED_COLM + character(len=256) :: fileblock + + IF (.not. allocated(distributed_vector_maps) .or. map_index < 1 .or. & + map_index > size(distributed_vector_maps)) THEN + CALL CoLM_stop('Invalid distributed MPAS-CoLM restart map index.') + ENDIF + IF (source_index < 1 .or. source_index > size(distributed_vector_maps(map_index)%source_ranks)) THEN + CALL CoLM_stop('Invalid distributed MPAS-CoLM restart source index.') + ENDIF + source_rank = distributed_vector_maps(map_index)%source_ranks(source_index) + source_length = distributed_vector_maps(map_index)%source_lengths(source_index) + CALL get_filename_block(distributed_vector_maps(map_index)%filename, & + distributed_vector_maps(map_index)%iblk, & + distributed_vector_maps(map_index)%jblk, fileblock) + CALL add_rank_suffix(fileblock, source_rank, source_file) +#else + source_file = '' + source_rank = -1 + source_length = 0 +#endif + + END SUBROUTINE get_distributed_source + +#ifdef MPAS_EMBEDDED_COLM + !--------------------------------------------------------- + SUBROUTINE read_distributed_int32_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer, allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + integer, intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + integer, allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_int32_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_int64_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer*8, allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + integer*8, intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + integer*8, allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_int64_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_int8_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer(1), allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + logical, intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + integer(1), allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) THEN + IF (defval) THEN + rdata = 1 + ELSE + rdata = 0 + ENDIF + ENDIF + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + IF (any((source_data /= int(0,kind=kind(source_data))) .and. & + (source_data /= int(1,kind=kind(source_data))))) THEN + CALL CoLM_stop('Invalid logical vector value in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_int8_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + real(r8), allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_2d(filename, dataname, ndim1, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1)/), (/ndim1/), source_file, dataname) + IF (size(source_data,2) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,2) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,ilocal) = source_data(:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_2d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_3d(filename, dataname, ndim1, ndim2, pixelset, iblk, jblk, & + rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, ndim2, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,ndim2,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1),size(source_data,2)/), & + (/ndim1,ndim2/), source_file, dataname) + IF (size(source_data,3) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,3) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,:,ilocal) = source_data(:,:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_3d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_4d(filename, dataname, ndim1, ndim2, ndim3, pixelset, iblk, jblk, & + rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, ndim2, ndim3, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:,:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:,:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,ndim2,ndim3,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1),size(source_data,2), & + size(source_data,3)/), & + (/ndim1,ndim2,ndim3/), source_file, dataname) + IF (size(source_data,4) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,4) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,:,:,ilocal) = source_data(:,:,:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_4d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_5d(filename, dataname, ndim1, ndim2, ndim3, ndim4, pixelset, iblk, jblk, & + rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, ndim2, ndim3, ndim4, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:,:,:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:,:,:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,ndim2,ndim3,ndim4,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1),size(source_data,2), & + size(source_data,3),size(source_data,4)/), & + (/ndim1,ndim2,ndim3,ndim4/), source_file, dataname) + IF (size(source_data,5) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,5) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,:,:,:,ilocal) = source_data(:,:,:,:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_5d +#endif + !--------------------------------------------------------- SUBROUTINE ncio_vector_stop_missing_block (filename, dataname, fileblock) - USE MOD_SPMD_Task, only: CoLM_stop + USE MOD_MPAS_MPI, only: CoLM_stop IMPLICIT NONE character(len=*), intent(in) :: filename @@ -134,12 +1033,74 @@ SUBROUTINE ncio_vector_stop_missing_block (filename, dataname, fileblock) END SUBROUTINE ncio_vector_stop_missing_block + !--------------------------------------------------------- + SUBROUTINE validate_vector_block_data(pixelset, istt, iend, source_length, & + use_srcpos, fileblock, dataname) + + USE MOD_Pixelset, only: pixelset_type + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: istt, iend, source_length + logical, intent(in) :: use_srcpos + character(len=*), intent(in) :: fileblock, dataname + + integer :: expected_length + + IF (istt < 1 .or. iend < istt .or. iend > pixelset%nset) THEN + CALL CoLM_stop('Invalid local vector bounds while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + + expected_length = iend - istt + 1 + IF (use_srcpos) THEN + IF (.not. allocated(pixelset%srcpos)) THEN + CALL CoLM_stop('Missing source-position map while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + IF (size(pixelset%srcpos) /= pixelset%nset) THEN + CALL CoLM_stop('Invalid source-position map length while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + IF (source_length < 1 .or. minval(pixelset%srcpos(istt:iend)) < 1 .or. & + maxval(pixelset%srcpos(istt:iend)) > source_length) THEN + CALL CoLM_stop('Source-position map exceeds vector data while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + ELSEIF (source_length /= expected_length) THEN + CALL CoLM_stop('Rank-local vector length mismatch while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + + END SUBROUTINE validate_vector_block_data + + !--------------------------------------------------------- + SUBROUTINE validate_vector_fixed_dimensions(actual, expected, fileblock, dataname) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: actual(:), expected(:) + character(len=*), intent(in) :: fileblock, dataname + + IF (size(actual) /= size(expected)) THEN + CALL CoLM_stop('Non-vector rank mismatch while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + IF (any(actual /= expected)) THEN + CALL CoLM_stop('Non-vector dimension mismatch while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + + END SUBROUTINE validate_vector_fixed_dimensions + !--------------------------------------------------------- SUBROUTINE ncio_read_vector_int32_1d ( & filename, dataname, pixelset, rdata, defval) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -154,10 +1115,10 @@ SUBROUTINE ncio_read_vector_int32_1d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - integer, allocatable :: sbuff(:), rbuff(:) - logical :: any_data_exists, block_has_data, use_srcpos + integer, allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -165,52 +1126,50 @@ SUBROUTINE ncio_read_vector_int32_1d ( & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & - MPI_IN_PLACE, 0, MPI_INTEGER, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(iset) = sbuff(pixelset%srcpos(iset)) ENDDO ELSE rdata(istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -225,36 +1184,6 @@ SUBROUTINE ncio_read_vector_int32_1d ( & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks - rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_int32_1d @@ -263,7 +1192,7 @@ SUBROUTINE ncio_read_vector_int64_1d ( & filename, dataname, pixelset, rdata, defval) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -273,15 +1202,15 @@ SUBROUTINE ncio_read_vector_int64_1d ( & type(pixelset_type), intent(in) :: pixelset integer*8, allocatable, intent(inout) :: rdata (:) - integer, intent(in), optional :: defval + integer*8, intent(in), optional :: defval ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - integer*8, allocatable :: sbuff(:), rbuff(:) - logical :: any_data_exists, block_has_data, use_srcpos + integer*8, allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -289,52 +1218,50 @@ SUBROUTINE ncio_read_vector_int64_1d ( & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & - MPI_IN_PLACE, 0, MPI_INTEGER8, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(iset) = sbuff(pixelset%srcpos(iset)) ENDDO ELSE rdata(istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -349,36 +1276,6 @@ SUBROUTINE ncio_read_vector_int64_1d ( & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks - rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_int64_1d @@ -387,7 +1284,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & defval) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -402,10 +1299,10 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - integer(1), allocatable :: sbuff(:), rbuff(:) - logical :: any_data_exists, block_has_data, use_srcpos + integer(1), allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -413,56 +1310,54 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - IF (defval) THEN - sbuff(:) = 1 - ELSE - sbuff(:) = 0 - ENDIF - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + IF (defval) THEN + sbuff(:) = 1 + ELSE + sbuff(:) = 0 + ENDIF + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF ENDIF + any_data_exists = any_data_exists .or. block_has_data -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, & - MPI_IN_PLACE, 0, MPI_INTEGER1, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend - rdata(iset) = (sbuff(pixelset%srcpos(iset)) == 1) + rdata(iset) = (sbuff(pixelset%srcpos(iset)) == int(1, kind=kind(sbuff))) ENDDO ELSE - rdata(istt:iend) = (sbuff == 1) + rdata(istt:iend) = (sbuff == int(1, kind=kind(sbuff))) ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -477,36 +1372,6 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! unused on non-root ranks - rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(istt:iend) = (rbuff == 1) - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_logical_1d @@ -516,7 +1381,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -531,10 +1396,10 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:), rbuff(:) - logical :: any_data_exists, block_has_data, use_srcpos + real(r8), allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (pixelset%nset)) ENDIF @@ -542,52 +1407,50 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - MPI_IN_PLACE, 0, MPI_REAL8, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(iset) = sbuff(pixelset%srcpos(iset)) ENDDO ELSE rdata(istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -601,37 +1464,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & ENDIF ENDIF ENDIF - -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif + END SUBROUTINE ncio_read_vector_real8_1d @@ -641,7 +1474,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -657,10 +1490,10 @@ SUBROUTINE ncio_read_vector_real8_2d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:), rbuff(:,:) - logical :: any_data_exists, block_has_data, use_srcpos + real(r8), allocatable :: sbuff(:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1, pixelset%nset)) ENDIF @@ -668,52 +1501,52 @@ SUBROUTINE ncio_read_vector_real8_2d ( & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - MPI_IN_PLACE, 0, MPI_REAL8, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1)/), (/ndim1/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,2), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(:,iset) = sbuff(:,pixelset%srcpos(iset)) ENDDO ELSE rdata(:,istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -728,36 +1561,6 @@ SUBROUTINE ncio_read_vector_real8_2d ( & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1,1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - rbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(:,istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_real8_2d @@ -767,7 +1570,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -783,10 +1586,10 @@ SUBROUTINE ncio_read_vector_real8_3d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) - logical :: any_data_exists, block_has_data, use_srcpos + real(r8), allocatable :: sbuff(:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1,ndim2, pixelset%nset)) ENDIF @@ -794,52 +1597,53 @@ SUBROUTINE ncio_read_vector_real8_3d ( & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:,:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - MPI_IN_PLACE, 0, MPI_REAL8, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, ndim2, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1),size(sbuff,2)/), & + (/ndim1,ndim2/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,3), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(:,:,iset) = sbuff(:,:,pixelset%srcpos(iset)) ENDDO ELSE rdata(:,:,istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -854,36 +1658,6 @@ SUBROUTINE ncio_read_vector_real8_3d ( & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1,1,1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - rbuff, ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(:,:,istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_real8_3d @@ -893,7 +1667,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -909,10 +1683,10 @@ SUBROUTINE ncio_read_vector_real8_4d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) - logical :: any_data_exists, block_has_data, use_srcpos + real(r8), allocatable :: sbuff(:,:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1,ndim2,ndim3, pixelset%nset)) ENDIF @@ -920,52 +1694,53 @@ SUBROUTINE ncio_read_vector_real8_4d ( & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:,:,:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - MPI_IN_PLACE, 0, MPI_REAL8, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, ndim2, ndim3, & + pixelset, iblk, jblk, sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1),size(sbuff,2),size(sbuff,3)/), & + (/ndim1,ndim2,ndim3/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,4), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(:,:,:,iset) = sbuff(:,:,:,pixelset%srcpos(iset)) ENDDO ELSE rdata(:,:,:,istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -980,36 +1755,6 @@ SUBROUTINE ncio_read_vector_real8_4d ( & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1,1,1,1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(:,:,:,istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_real8_4d @@ -1020,7 +1765,7 @@ SUBROUTINE ncio_read_vector_real8_5d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1036,10 +1781,10 @@ SUBROUTINE ncio_read_vector_real8_5d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, iset character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:) - logical :: any_data_exists, block_has_data, use_srcpos + real(r8), allocatable :: sbuff(:,:,:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart - IF (p_is_compute) THEN + IF (.true.) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN allocate (rdata (ndim1,ndim2,ndim3,ndim4, pixelset%nset)) ENDIF @@ -1047,52 +1792,54 @@ SUBROUTINE ncio_read_vector_real8_5d ( & any_data_exists = .false. - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) - allocate (sbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk))) use_srcpos = allocated(pixelset%srcpos) - CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos) - - block_has_data = .false. - IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN - CALL ncio_read_serial (fileblock, dataname, sbuff) - any_data_exists = .true. - block_has_data = .true. - ELSEIF (present(defval)) THEN - sbuff(:,:,:,:,:) = defval - ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) - ENDIF - -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_scatterv ( & - sbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - MPI_IN_PLACE, 0, MPI_REAL8, & - p_root, p_comm_group, p_err) -#else + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, ndim2, ndim3, ndim4, & + pixelset, iblk, jblk, sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) - IF (use_srcpos .and. block_has_data) THEN + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1),size(sbuff,2),size(sbuff,3), & + size(sbuff,4)/), & + (/ndim1,ndim2,ndim3,ndim4/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,5), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN DO iset = istt, iend rdata(:,:,:,:,iset) = sbuff(:,:,:,:,pixelset%srcpos(iset)) ENDDO ELSE rdata(:,:,:,:,istt:iend) = sbuff ENDIF -#endif deallocate (sbuff) ENDDO -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) -#endif IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN IF (ncio_vector_report_missing(.not. present(defval))) THEN IF (.not. present(defval)) THEN @@ -1107,36 +1854,6 @@ SUBROUTINE ncio_read_vector_real8_5d ( & ENDIF ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (rbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk))) - ELSE - allocate (rbuff(1,1,1,1,1)) - ENDIF - - CALL mpi_scatterv ( & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - rdata(:,:,:,:,istt:iend) = rbuff - ENDIF - - IF (allocated(rbuff)) deallocate (rbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_read_vector_real8_5d @@ -1145,7 +1862,7 @@ END SUBROUTINE ncio_read_vector_real8_5d SUBROUTINE ncio_create_file_vector (filename, pixelset) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1155,15 +1872,34 @@ SUBROUTINE ncio_create_file_vector (filename, pixelset) ! Local variables integer :: iblkgrp, iblk, jblk +#ifdef MPAS_EMBEDDED_COLM + integer :: istt, iend +#endif character(len=256) :: fileblock - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) CALL ncio_create_file (fileblock) +#ifdef MPAS_EMBEDDED_COLM + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (iend >= istt) THEN + IF (.not. allocated(pixelset%eindex) .or. .not. allocated(pixelset%ipxstt) .or. & + .not. allocated(pixelset%ipxend) .or. .not. allocated(pixelset%settyp)) THEN + write(*,'(A)') 'Error: MPAS embedded CoLM cannot write vector state without pixelset identity metadata.' + CALL CoLM_stop() + ENDIF + CALL ncio_define_dimension(fileblock, 'mpas_local_set', iend - istt + 1) + CALL ncio_write_serial(fileblock, 'mpas_eindex', pixelset%eindex(istt:iend), 'mpas_local_set') + CALL ncio_write_serial(fileblock, 'mpas_ipxstt', pixelset%ipxstt(istt:iend), 'mpas_local_set') + CALL ncio_write_serial(fileblock, 'mpas_ipxend', pixelset%ipxend(istt:iend), 'mpas_local_set') + CALL ncio_write_serial(fileblock, 'mpas_settyp', pixelset%settyp(istt:iend), 'mpas_local_set') + ENDIF +#endif ENDDO ENDIF @@ -1174,7 +1910,7 @@ END SUBROUTINE ncio_create_file_vector SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1189,7 +1925,7 @@ SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) character(len=256) :: fileblock logical :: fexists - IF (p_is_active) THEN + IF (.true.) THEN DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) @@ -1212,12 +1948,93 @@ SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) END SUBROUTINE ncio_define_dimension_vector + !--------------------------------------------------------- + SUBROUTINE validate_vector_write_layout(pixelset, vector_size, dataname, actual_dims, expected_dims) + + USE MOD_Pixelset, only: pixelset_type + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: vector_size + character(len=*), intent(in) :: dataname + integer, intent(in), optional :: actual_dims(:) + integer, intent(in), optional :: expected_dims(:) + + integer :: iblkgrp + integer :: iblk + integer :: jblk + integer :: istt + integer :: iend + integer :: vlen + logical, allocatable :: covered(:) + + IF (pixelset%nset < 0 .or. vector_size /= pixelset%nset) THEN + CALL CoLM_stop('Invalid vector length while writing '//trim(dataname)//'.') + ENDIF + IF (present(actual_dims) .neqv. present(expected_dims)) THEN + CALL CoLM_stop('Incomplete fixed-dimension metadata while writing '//trim(dataname)//'.') + ENDIF + IF (present(actual_dims) .and. present(expected_dims)) THEN + IF (size(actual_dims) /= size(expected_dims) .or. any(actual_dims /= expected_dims) .or. & + any(actual_dims <= 0)) THEN + CALL CoLM_stop('Fixed dimensions do not match the data while writing '//trim(dataname)//'.') + ENDIF + ENDIF + + IF (pixelset%nblkgrp < 0) THEN + CALL CoLM_stop('Invalid block count while writing '//trim(dataname)//'.') + ENDIF + IF (pixelset%nset == 0) THEN + IF (pixelset%nblkgrp /= 0) CALL CoLM_stop('Empty vector has nonempty block layout while writing '//trim(dataname)//'.') + RETURN + ENDIF + IF (pixelset%nblkgrp < 1 .or. .not. allocated(pixelset%xblkgrp) .or. & + .not. allocated(pixelset%yblkgrp) .or. .not. allocated(pixelset%vecgs%vlen) .or. & + .not. allocated(pixelset%vecgs%vstt) .or. .not. allocated(pixelset%vecgs%vend)) THEN + CALL CoLM_stop('Missing vector block layout while writing '//trim(dataname)//'.') + ENDIF + IF (size(pixelset%xblkgrp) /= pixelset%nblkgrp .or. & + size(pixelset%yblkgrp) /= pixelset%nblkgrp) THEN + CALL CoLM_stop('Inconsistent vector block list while writing '//trim(dataname)//'.') + ENDIF + IF (any(shape(pixelset%vecgs%vlen) /= shape(pixelset%vecgs%vstt)) .or. & + any(shape(pixelset%vecgs%vlen) /= shape(pixelset%vecgs%vend))) THEN + CALL CoLM_stop('Inconsistent vector block arrays while writing '//trim(dataname)//'.') + ENDIF + + allocate(covered(pixelset%nset)) + covered = .false. + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + IF (iblk < lbound(pixelset%vecgs%vlen,1) .or. iblk > ubound(pixelset%vecgs%vlen,1) .or. & + jblk < lbound(pixelset%vecgs%vlen,2) .or. jblk > ubound(pixelset%vecgs%vlen,2)) THEN + CALL CoLM_stop('Vector block index is out of range while writing '//trim(dataname)//'.') + ENDIF + vlen = pixelset%vecgs%vlen(iblk,jblk) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (vlen < 1 .or. istt < 1 .or. iend < istt .or. iend > pixelset%nset .or. & + iend - istt + 1 /= vlen) THEN + CALL CoLM_stop('Invalid vector block bounds while writing '//trim(dataname)//'.') + ENDIF + IF (any(covered(istt:iend))) THEN + CALL CoLM_stop('Overlapping vector blocks while writing '//trim(dataname)//'.') + ENDIF + covered(istt:iend) = .true. + ENDDO + IF (.not. all(covered)) CALL CoLM_stop('Vector block layout has gaps while writing '//trim(dataname)//'.') + deallocate(covered) + + END SUBROUTINE validate_vector_write_layout + !--------------------------------------------------------- SUBROUTINE ncio_write_vector_int32_1d ( & filename, dataname, dimname, pixelset, wdata, compress_level) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1233,25 +2050,19 @@ SUBROUTINE ncio_write_vector_int32_1d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - integer, allocatable :: sbuff(:), rbuff(:) + integer, allocatable :: rbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & - rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) @@ -1268,33 +2079,6 @@ SUBROUTINE ncio_write_vector_int32_1d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(istt:iend) - ELSE - allocate (sbuff (1)) - ENDIF - - CALL mpi_gatherv ( & - sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_int32_1d @@ -1303,7 +2087,7 @@ SUBROUTINE ncio_write_vector_logical_1d ( & filename, dataname, dimname, pixelset, wdata, compress_level) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1319,21 +2103,16 @@ SUBROUTINE ncio_write_vector_logical_1d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend, i character(len=256) :: fileblock - integer(1), allocatable :: sbuff(:), rbuff(:) + integer(1), allocatable :: rbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER1, & - rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) DO i = istt, iend @@ -1343,7 +2122,6 @@ SUBROUTINE ncio_write_vector_logical_1d ( & rbuff(i-istt+1) = 0 ENDIF ENDDO -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) @@ -1360,39 +2138,6 @@ SUBROUTINE ncio_write_vector_logical_1d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - DO i = istt, iend - IF(wdata(i))THEN - sbuff(i-istt+1) = 1 - ELSE - sbuff(i-istt+1) = 0 - ENDIF - ENDDO - ELSE - allocate (sbuff (1)) - ENDIF - - CALL mpi_gatherv ( & - sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_logical_1d @@ -1402,7 +2147,7 @@ SUBROUTINE ncio_write_vector_int32_3d ( & dim3name, pixelset, wdata, compress_level) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1419,25 +2164,20 @@ SUBROUTINE ncio_write_vector_int32_3d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - integer, allocatable :: sbuff(:,:,:), rbuff(:,:,:) + integer, allocatable :: rbuff(:,:,:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,3), dataname, & + (/size(wdata,1), size(wdata,2)/), (/ndim1, ndim2/)) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & - rbuff, ndim1*ndim2*pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1*ndim2*pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(:,:,istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) @@ -1455,33 +2195,6 @@ SUBROUTINE ncio_write_vector_int32_3d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(:,:,istt:iend) - ELSE - allocate (sbuff (1,1,1)) - ENDIF - - CALL mpi_gatherv ( & - sbuff, ndim1*ndim2*pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_int32_3d @@ -1490,7 +2203,7 @@ SUBROUTINE ncio_write_vector_int64_1d ( & filename, dataname, dimname, pixelset, wdata, compress_level) USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1506,25 +2219,19 @@ SUBROUTINE ncio_write_vector_int64_1d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - integer*8, allocatable :: sbuff(:), rbuff(:) + integer*8, allocatable :: rbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & - rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) @@ -1541,33 +2248,6 @@ SUBROUTINE ncio_write_vector_int64_1d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(istt:iend) - ELSE - allocate (sbuff (1)) - ENDIF - - CALL mpi_gatherv ( & - sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_int64_1d @@ -1577,7 +2257,7 @@ SUBROUTINE ncio_write_vector_real8_1d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1593,25 +2273,19 @@ SUBROUTINE ncio_write_vector_real8_1d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:), rbuff(:) + real(r8), allocatable :: rbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv ( MPI_IN_PLACE, 0, MPI_REAL8, & - rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & - pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) IF (present(compress_level)) THEN @@ -1627,33 +2301,6 @@ SUBROUTINE ncio_write_vector_real8_1d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(istt:iend) - ELSE - allocate (sbuff (1)) - ENDIF - - CALL mpi_gatherv ( & - sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_real8_1d @@ -1664,7 +2311,7 @@ SUBROUTINE ncio_write_vector_real8_2d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1681,25 +2328,20 @@ SUBROUTINE ncio_write_vector_real8_2d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:), rbuff(:,:) + real(r8), allocatable :: rbuff(:,:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,2), dataname, & + (/size(wdata,1)/), (/ndim1/)) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & - rbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(:,istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) @@ -1717,33 +2359,6 @@ SUBROUTINE ncio_write_vector_real8_2d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (ndim1,pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(:,istt:iend) - ELSE - allocate (sbuff (1,1)) - ENDIF - - CALL mpi_gatherv ( & - sbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_real8_2d @@ -1754,7 +2369,7 @@ SUBROUTINE ncio_write_vector_real8_3d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1771,25 +2386,20 @@ SUBROUTINE ncio_write_vector_real8_3d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) + real(r8), allocatable :: rbuff(:,:,:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,3), dataname, & + (/size(wdata,1), size(wdata,2)/), (/ndim1, ndim2/)) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (ndim1, ndim2, pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & - rbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(:,:,istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) IF (present(compress_level)) THEN @@ -1806,33 +2416,6 @@ SUBROUTINE ncio_write_vector_real8_3d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(:,:,istt:iend) - ELSE - allocate (sbuff (1,1,1)) - ENDIF - - CALL mpi_gatherv ( sbuff, & - ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_real8_3d @@ -1843,7 +2426,7 @@ SUBROUTINE ncio_write_vector_real8_4d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1860,25 +2443,21 @@ SUBROUTINE ncio_write_vector_real8_4d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) + real(r8), allocatable :: rbuff(:,:,:,:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,4), dataname, & + (/size(wdata,1), size(wdata,2), size(wdata,3)/), & + (/ndim1, ndim2, ndim3/)) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (ndim1, ndim2, ndim3, pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & - rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(:,:,:,istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) IF (present(compress_level)) THEN @@ -1895,33 +2474,6 @@ SUBROUTINE ncio_write_vector_real8_4d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (ndim1,ndim2,ndim3,pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(:,:,:,istt:iend) - ELSE - allocate (sbuff (1,1,1,1)) - ENDIF - - CALL mpi_gatherv ( sbuff, & - ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_real8_4d @@ -1933,7 +2485,7 @@ SUBROUTINE ncio_write_vector_real8_5d ( & USE MOD_Precision USE MOD_NetCDFSerial - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_Pixelset IMPLICIT NONE @@ -1950,25 +2502,21 @@ SUBROUTINE ncio_write_vector_real8_5d ( & ! Local variables integer :: iblkgrp, iblk, jblk, istt, iend character(len=256) :: fileblock - real(r8), allocatable :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:) + real(r8), allocatable :: rbuff(:,:,:,:,:) - IF (p_is_active) THEN + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,5), dataname, & + (/size(wdata,1), size(wdata,2), size(wdata,3), size(wdata,4)/), & + (/ndim1, ndim2, ndim3, ndim4/)) DO iblkgrp = 1, pixelset%nblkgrp iblk = pixelset%xblkgrp(iblkgrp) jblk = pixelset%yblkgrp(iblkgrp) allocate (rbuff (ndim1, ndim2, ndim3, ndim4, pixelset%vecgs%vlen(iblk,jblk))) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & - rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vcnt(:,iblk,jblk), & - ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & - p_root, p_comm_group, p_err) -#else istt = pixelset%vecgs%vstt(iblk,jblk) iend = pixelset%vecgs%vend(iblk,jblk) rbuff = wdata(:,:,:,:,istt:iend) -#endif CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) IF (present(compress_level)) THEN @@ -1985,48 +2533,21 @@ SUBROUTINE ncio_write_vector_real8_5d ( & ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_compute) THEN - - DO iblkgrp = 1, pixelset%nblkgrp - iblk = pixelset%xblkgrp(iblkgrp) - jblk = pixelset%yblkgrp(iblkgrp) - - IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN - allocate (sbuff (ndim1,ndim2,ndim3,ndim4,pixelset%vecgs%vlen(iblk,jblk))) - istt = pixelset%vecgs%vstt(iblk,jblk) - iend = pixelset%vecgs%vend(iblk,jblk) - sbuff = wdata(:,:,:,:,istt:iend) - ELSE - allocate (sbuff (1,1,1,1,1)) - ENDIF - - CALL mpi_gatherv ( sbuff, & - ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & - MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - IF (allocated(sbuff)) deallocate (sbuff) - - ENDDO - - ENDIF -#endif END SUBROUTINE ncio_write_vector_real8_5d !------------------------------------------------ LOGICAL FUNCTION ncio_vector_report_missing(mandatory) - USE MOD_SPMD_Task, only: p_iam_active, p_root + USE MOD_MPAS_MPI, only: mpas_rank, mpas_root IMPLICIT NONE logical, intent(in) :: mandatory #ifdef MPAS_EMBEDDED_COLM - ncio_vector_report_missing = mandatory .or. (p_iam_active == p_root) + ncio_vector_report_missing = mandatory .or. (mpas_rank == mpas_root) #else - ncio_vector_report_missing = (p_iam_active == p_root) + ncio_vector_report_missing = (mpas_rank == mpas_root) #endif END FUNCTION ncio_vector_report_missing diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 index 69f6d2bf3c..59bbc8bcfd 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 @@ -48,7 +48,6 @@ MODULE MOD_Pixel procedure, PUBLIC :: map_to_grid => pixel_map_to_grid - procedure, PUBLIC :: save_to_file => pixel_save_to_file procedure, PUBLIC :: load_from_file => pixel_load_from_file final :: pixel_free_mem @@ -65,7 +64,7 @@ SUBROUTINE pixel_set_edges (this, & edges_in, edgen_in, edgew_in, edgee_in) USE MOD_Precision - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Utils IMPLICIT NONE @@ -95,7 +94,7 @@ SUBROUTINE pixel_set_edges (this, & this%lon_w(1) = this%edgew this%lon_e(1) = this%edgee - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,'(A)') '----- Region information -----' write(*,'(A,F10.4,A,F10.4,A,F10.4,A,F10.4,A)') ' (south,north,west,east) = (', & this%edges, ',', this%edgen, ',', this%edgew, ',', this%edgee, ')' @@ -337,46 +336,12 @@ SUBROUTINE pixel_map_to_grid (this, grd) END SUBROUTINE pixel_map_to_grid - ! -------------------------------- - SUBROUTINE pixel_save_to_file (this, dir_landdata) - - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - IMPLICIT NONE - class(pixel_type) :: this - - character(len=*), intent(in) :: dir_landdata - - ! Local variables - character(len=256) :: filename - - IF (p_is_root) THEN - - filename = trim(dir_landdata) // '/pixel.nc' - - CALL ncio_create_file (filename) - - CALL ncio_write_serial (filename, 'edges', this%edges) - CALL ncio_write_serial (filename, 'edgen', this%edgen) - CALL ncio_write_serial (filename, 'edgew', this%edgew) - CALL ncio_write_serial (filename, 'edgee', this%edgee) - - CALL ncio_define_dimension (filename, 'latitude', this%nlat) - CALL ncio_define_dimension (filename, 'longitude', this%nlon) - - CALL ncio_write_serial (filename, 'lat_s', this%lat_s, 'latitude' ) - CALL ncio_write_serial (filename, 'lat_n', this%lat_n, 'latitude' ) - CALL ncio_write_serial (filename, 'lon_w', this%lon_w, 'longitude') - CALL ncio_write_serial (filename, 'lon_e', this%lon_e, 'longitude') - - ENDIF - - END SUBROUTINE pixel_save_to_file - ! -------------------------------- SUBROUTINE pixel_load_from_file (this, dir_landdata) USE MOD_NetCDFSerial + USE MOD_MPAS_MPI, only: CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE class(pixel_type) :: this @@ -400,6 +365,24 @@ SUBROUTINE pixel_load_from_file (this, dir_landdata) this%nlon = size(this%lon_w) this%nlat = size(this%lat_s) + IF (this%nlon < 1 .or. this%nlat < 1 .or. size(this%lon_e) /= this%nlon .or. & + size(this%lat_n) /= this%nlat) THEN + CALL CoLM_stop('CoLM pixel.nc contains inconsistent pixel-boundary dimensions.') + ENDIF + IF (.not. all(ieee_is_finite((/this%edges, this%edgen, this%edgew, this%edgee/))) .or. & + .not. all(ieee_is_finite(this%lat_s)) .or. .not. all(ieee_is_finite(this%lat_n)) .or. & + .not. all(ieee_is_finite(this%lon_w)) .or. .not. all(ieee_is_finite(this%lon_e))) THEN + CALL CoLM_stop('CoLM pixel.nc contains non-finite pixel boundaries.') + ENDIF + IF (any(this%lat_s < -90._r8) .or. any(this%lat_n > 90._r8) .or. & + any(this%lat_n <= this%lat_s)) THEN + CALL CoLM_stop('CoLM pixel.nc contains invalid latitude boundaries.') + ENDIF + IF (this%nlat > 1) THEN + IF (any(this%lat_s(2:) <= this%lat_s(:this%nlat-1))) & + CALL CoLM_stop('CoLM pixel.nc latitude pixels are not ordered south to north.') + ENDIF + END SUBROUTINE pixel_load_from_file ! -------------------------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 index a5276283a4..6eec2bbed6 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -1,9 +1,5 @@ #include -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) -#define COLM_VECTOR_MPI_IO -#endif - MODULE MOD_Pixelset !------------------------------------------------------------------------------------ @@ -38,7 +34,6 @@ MODULE MOD_Pixelset ! "Vector" is a collection of data when each pixelset in a given level is associated ! with a value, representing its averaged physical, chemical or biological state. ! -! Legacy vector MPI I/O may redistribute vector data between ranks for IO. ! MPAS-embedded CoLM keeps land vectors on MPAS-owned cell subsets. ! ! Created by Shupeng Zhang, May 2023 @@ -58,10 +53,6 @@ MODULE MOD_Pixelset integer, allocatable :: vstt(:,:) integer, allocatable :: vend(:,:) - ! gathered vector counts/displacements - integer, allocatable :: vcnt(:,:,:) - integer, allocatable :: vdsp(:,:,:) - CONTAINS final :: vec_gather_scatter_free_mem @@ -338,27 +329,35 @@ SUBROUTINE copy_pixelset(pixel_from, pixel_to) SUBROUTINE vec_gather_scatter_set (this) USE MOD_Block - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Mesh IMPLICIT NONE class(pixelset_type) :: this ! Local variables - integer :: iproc - integer :: iset, ie, xblk, yblk, iblk, jblk, scnt, iblkgrp, iblkall + integer :: iset, ie, xblk, yblk, iblk, jblk, iblkgrp logical, allocatable :: nonzero(:,:) -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_barrier (p_comm_glb, p_err) -#endif IF (.not. allocated (this%vecgs%vlen)) THEN allocate (this%vecgs%vlen (gblock%nxblk, gblock%nyblk)) this%vecgs%vlen(:,:) = 0 ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN + + IF (this%nset > 0) THEN + IF (.not. allocated(this%eindex) .or. size(this%eindex) /= this%nset) THEN + CALL CoLM_stop('Invalid pixelset element-index vector in set_vecgs.') + ENDIF + IF (.not. allocated(this%ielm) .or. size(this%ielm) /= this%nset) THEN + CALL CoLM_stop('Pixelset element mapping must be established before set_vecgs.') + ENDIF + IF (.not. allocated(mesh)) THEN + CALL CoLM_stop('Pixelset vector layout requires an allocated local element mesh.') + ENDIF + ENDIF IF (.not. allocated (this%vecgs%vstt)) THEN allocate (this%vecgs%vstt (gblock%nxblk, gblock%nyblk)) @@ -368,13 +367,20 @@ SUBROUTINE vec_gather_scatter_set (this) this%vecgs%vstt(:,:) = 0 this%vecgs%vend(:,:) = -1 - ie = 1 xblk = 0 yblk = 0 DO iset = 1, this%nset - DO WHILE (this%eindex(iset) /= mesh(ie)%indx) - ie = ie + 1 - ENDDO + ie = this%ielm(iset) + IF (ie < 1 .or. ie > size(mesh)) THEN + CALL CoLM_stop('Pixelset contains an out-of-range local element index in set_vecgs.') + ENDIF + IF (this%eindex(iset) /= mesh(ie)%indx) THEN + CALL CoLM_stop('Pixelset element ID does not match its local CoLM element in set_vecgs.') + ENDIF + IF (mesh(ie)%xblk < 1 .or. mesh(ie)%xblk > gblock%nxblk .or. & + mesh(ie)%yblk < 1 .or. mesh(ie)%yblk > gblock%nyblk) THEN + CALL CoLM_stop('Pixelset references an element with an invalid CoLM block index.') + ENDIF IF ((mesh(ie)%xblk /= xblk) .or. (mesh(ie)%yblk /= yblk)) THEN xblk = mesh(ie)%xblk @@ -387,61 +393,13 @@ SUBROUTINE vec_gather_scatter_set (this) this%vecgs%vlen = this%vecgs%vend - this%vecgs%vstt + 1 -#ifdef COLM_VECTOR_MPI_IO - DO jblk = 1, gblock%nyblk - DO iblk = 1, gblock%nxblk - IF (gblock%pio(iblk,jblk) == p_address_active(p_my_group)) THEN - - scnt = this%vecgs%vlen(iblk,jblk) - CALL mpi_gather (scnt, 1, MPI_INTEGER, & - MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err) - - ENDIF - ENDDO - ENDDO -#endif ENDIF -#ifdef COLM_VECTOR_MPI_IO - IF (p_is_active) THEN - IF (.not. allocated(this%vecgs%vcnt)) THEN - allocate (this%vecgs%vcnt (0:p_np_group-1,gblock%nxblk,gblock%nyblk)) - allocate (this%vecgs%vdsp (0:p_np_group-1,gblock%nxblk,gblock%nyblk)) - ENDIF - - this%vecgs%vcnt(:,:,:) = 0 - DO jblk = 1, gblock%nyblk - DO iblk = 1, gblock%nxblk - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - scnt = 0 - CALL mpi_gather (scnt, 1, MPI_INTEGER, & - this%vecgs%vcnt(:,iblk,jblk), 1, MPI_INTEGER, & - p_root, p_comm_group, p_err) - - this%vecgs%vdsp(0,iblk,jblk) = 0 - DO iproc = 1, p_np_group-1 - this%vecgs%vdsp(iproc,iblk,jblk) = & - this%vecgs%vdsp(iproc-1,iblk,jblk) + this%vecgs%vcnt(iproc-1,iblk,jblk) - ENDDO - - this%vecgs%vlen(iblk,jblk) = sum(this%vecgs%vcnt(:,iblk,jblk)) - - ENDIF - ENDDO - ENDDO - ENDIF -#endif - - IF (p_is_active .or. p_is_compute) THEN + IF (.true.) THEN allocate (nonzero (gblock%nxblk,gblock%nyblk)) nonzero = this%vecgs%vlen > 0 -#ifdef COLM_VECTOR_MPI_IO - CALL mpi_allreduce (MPI_IN_PLACE, nonzero, gblock%nxblk * gblock%nyblk, & - MPI_LOGICAL, MPI_LOR, p_comm_group, p_err) -#endif this%nblkgrp = count(nonzero) IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) @@ -468,7 +426,7 @@ END SUBROUTINE vec_gather_scatter_set ! -------------------------------- SUBROUTINE pixelset_pack (this, mask, nset_packed) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class(pixelset_type) :: this logical, intent(in) :: mask(:) @@ -484,7 +442,7 @@ SUBROUTINE pixelset_pack (this, mask, nset_packed) real(r8), allocatable :: pctshared_(:) integer :: s, e - IF (p_is_compute) THEN + IF (.true.) THEN IF (this%nset > 0) THEN IF (count(mask) < this%nset) THEN @@ -592,9 +550,6 @@ SUBROUTINE vec_gather_scatter_free_mem (this) IF (allocated(this%vlen)) deallocate (this%vlen) IF (allocated(this%vstt)) deallocate (this%vstt) IF (allocated(this%vend)) deallocate (this%vend) - IF (allocated(this%vcnt)) deallocate (this%vcnt) - IF (allocated(this%vdsp)) deallocate (this%vdsp) - END SUBROUTINE vec_gather_scatter_free_mem ! -------------------------------- @@ -603,6 +558,8 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) USE MOD_Mesh USE MOD_Pixel USE MOD_Utils + USE MOD_MPAS_MPI, only: CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite IMPLICIT NONE CLASS(subset_type) :: this @@ -613,6 +570,7 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) ! Local Variables integer :: isuperset, isubset, ielm, ipxl, istt, iend + real(r8) :: subset_area IF (superset%has_shared) THEN write(*,*) 'Warning: superset has shared area.' @@ -637,6 +595,9 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) isuperset = 1 isubset = 1 DO WHILE (isubset <= subset%nset) + IF (isuperset > superset%nset) THEN + CALL CoLM_stop('A CoLM subset does not belong to any loaded element.') + ENDIF IF ( (subset%eindex(isubset) == superset%eindex(isuperset)) & .and. (subset%ipxstt(isubset) >= superset%ipxstt(isuperset) .or. & subset%ipxstt(isubset) == -1 ) & @@ -659,6 +620,17 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) DO isubset = 1, subset%nset ielm = subset%ielm(isubset) + IF (ielm < 1 .or. ielm > size(mesh)) THEN + CALL CoLM_stop('A CoLM subset references an invalid local element.') + ENDIF + IF (subset%ipxstt(isubset) /= -1) THEN + IF (subset%ipxstt(isubset) < 1 .or. subset%ipxend(isubset) < subset%ipxstt(isubset) .or. & + subset%ipxend(isubset) > mesh(ielm)%npxl) THEN + CALL CoLM_stop('A CoLM subset references pixels outside its element.') + ENDIF + ELSEIF (subset%ipxend(isubset) /= -1) THEN + CALL CoLM_stop('A CoLM virtual subset has inconsistent pixel bounds.') + ENDIF this%subfrc(isubset) = 0 DO ipxl = subset%ipxstt(isubset), subset%ipxend(isubset) IF (ipxl == -1) CYCLE @@ -678,7 +650,11 @@ SUBROUTINE subset_build (this, superset, subset, use_frac) IF (this%substt(isuperset) /= 0) THEN istt = this%substt(isuperset) iend = this%subend(isuperset) - this%subfrc(istt:iend) = this%subfrc(istt:iend) / sum(this%subfrc(istt:iend)) + subset_area = sum(this%subfrc(istt:iend)) + IF (.not. ieee_is_finite(subset_area) .or. subset_area <= 0._r8) THEN + CALL CoLM_stop('A CoLM element has no positive finite subset area.') + ENDIF + this%subfrc(istt:iend) = this%subfrc(istt:iend) / subset_area ENDIF ENDDO diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90 deleted file mode 100644 index 61f5ab7bdf..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90 +++ /dev/null @@ -1,213 +0,0 @@ -#include - -MODULE MOD_PixelsetShared -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Shared pixelset refer to two or more pixelsets sharing the same geographic area. -! -! For example, for patch of crops, multiple crops can be planted on a piece of land. -! When planting these crops, different irrigation schemes may be used. Thus the water -! and energy processes have difference in crops and should be modeled independently. -! By using shared pixelset, crop patch is splitted to two or more shared patches. -! Each shared patch is assigned with a percentage of area and has its own states. -! -! Example of shared pixelsets -! |<------------------- ELEMENT ------------------>| <-- level 1 -! | subset 1 | subset 2 | subset 3 | <-- level 2 -! | subset 2 shared 1 50% | -! | subset 2 shared 2 20% | <-- subset 2 shares -! | subset 2 shared 3 30% | -! -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - IMPLICIT NONE - -CONTAINS - - SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typfilter, & - fracout, sharedclass, fracin) - - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_DataType - USE MOD_Pixel - USE MOD_Pixelset - USE MOD_Mesh - USE MOD_Utils - USE MOD_AggregationRequestData - IMPLICIT NONE - - type(pixelset_type), intent(inout) :: pixelset - type(grid_type), intent(in) :: gshared - type(block_data_real8_3d), intent(in) :: datashared - integer, intent(in) :: nmaxshared - integer, intent(in) :: typfilter(:) - - real(r8), intent(out), allocatable :: fracout(:) - integer, intent(out), allocatable :: sharedclass(:) - real(r8), intent(in), optional :: fracin (:) - - ! Local Variables - real(r8), allocatable :: pctshared(:,:) - real(r8), allocatable :: datashared1d(:,:), areapixel(:), rbuff(:,:) - integer :: nsetshared, ipset, jpset - integer :: ipxl, ie, ipxstt, ipxend, ishared - integer*8,allocatable :: eindex1(:) - integer, allocatable :: ielm1(:), ipxstt1(:), ipxend1(:), settyp1(:) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_active) THEN - CALL aggregation_data_daemon (gshared, data_r8_3d_in1 = datashared, n1_r8_3d_in1 = nmaxshared) - ENDIF -#endif - - IF (p_is_compute) THEN - - nsetshared = 0 - - allocate (pctshared(nmaxshared,pixelset%nset)) - - DO ipset = 1, pixelset%nset - IF (any(typfilter(:) == pixelset%settyp(ipset))) THEN - - ie = pixelset%ielm (ipset) - ipxstt = pixelset%ipxstt(ipset) - ipxend = pixelset%ipxend(ipset) - - allocate (datashared1d (nmaxshared, ipxstt:ipxend)) - - CALL aggregation_request_data (pixelset, ipset, gshared, zip = .false., & - data_r8_3d_in1 = datashared, data_r8_3d_out1 = rbuff, n1_r8_3d_in1 = nmaxshared) - - datashared1d = rbuff - - allocate (areapixel(ipxstt:ipxend)) - DO ipxl = ipxstt, ipxend - areapixel(ipxl) = areaquad (& - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) - ENDDO - - DO ishared = 1, nmaxshared - pctshared(ishared,ipset) = sum(datashared1d(ishared,:) * areapixel) - ENDDO - - IF (any(pctshared(:,ipset) > 0.)) THEN - nsetshared = nsetshared + count(pctshared(:,ipset) > 0.) - pctshared(:,ipset) = pctshared(:,ipset) / sum(pctshared(:,ipset)) - ENDIF - - deallocate (rbuff ) - deallocate (areapixel ) - deallocate (datashared1d) - - ELSE - nsetshared = nsetshared + 1 - ENDIF - - ENDDO - -#ifdef USEMPI - CALL aggregation_compute_done () -#endif - ENDIF - - IF (p_is_compute) THEN - - IF (pixelset%nset > 0) THEN - - allocate (eindex1(pixelset%nset)) - allocate (ipxstt1(pixelset%nset)) - allocate (ipxend1(pixelset%nset)) - allocate (settyp1(pixelset%nset)) - allocate (ielm1 (pixelset%nset)) - - eindex1 = pixelset%eindex - ipxstt1 = pixelset%ipxstt - ipxend1 = pixelset%ipxend - settyp1 = pixelset%settyp - ielm1 = pixelset%ielm - - deallocate (pixelset%eindex) - deallocate (pixelset%ipxstt) - deallocate (pixelset%ipxend) - deallocate (pixelset%settyp) - deallocate (pixelset%ielm ) - - allocate (pixelset%eindex(nsetshared)) - allocate (pixelset%ipxstt(nsetshared)) - allocate (pixelset%ipxend(nsetshared)) - allocate (pixelset%settyp(nsetshared)) - allocate (pixelset%ielm (nsetshared)) - - allocate (fracout (nsetshared)) - allocate (sharedclass(nsetshared)) - - fracout(:) = 1.0 - - jpset = 0 - DO ipset = 1, pixelset%nset - IF (any(typfilter(:) == settyp1(ipset))) THEN - IF (any(pctshared(:,ipset) > 0.)) THEN - DO ishared = 1, nmaxshared - IF (pctshared(ishared,ipset) > 0.) THEN - jpset = jpset + 1 - pixelset%eindex(jpset) = eindex1(ipset) - pixelset%ipxstt(jpset) = ipxstt1(ipset) - pixelset%ipxend(jpset) = ipxend1(ipset) - pixelset%settyp(jpset) = settyp1(ipset) - pixelset%ielm (jpset) = ielm1 (ipset) - - IF (present(fracin)) THEN - fracout(jpset) = fracin(ipset) * pctshared(ishared,ipset) - ELSE - fracout(jpset) = pctshared(ishared,ipset) - ENDIF - - sharedclass(jpset) = ishared - ENDIF - ENDDO - ENDIF - ELSE - jpset = jpset + 1 - pixelset%eindex(jpset) = eindex1(ipset) - pixelset%ipxstt(jpset) = ipxstt1(ipset) - pixelset%ipxend(jpset) = ipxend1(ipset) - pixelset%settyp(jpset) = settyp1(ipset) - pixelset%ielm (jpset) = ielm1 (ipset) - - IF (present(fracin)) THEN - fracout(jpset) = fracin(ipset) - ELSE - fracout(jpset) = 1. - ENDIF - - sharedclass(jpset) = 0 ! no meaning - ENDIF - ENDDO - - pixelset%nset = nsetshared - - deallocate (eindex1) - deallocate (ipxstt1) - deallocate (ipxend1) - deallocate (settyp1) - deallocate (ielm1 ) - deallocate (pctshared) - - ENDIF - - ENDIF - - CALL pixelset%set_vecgs - - END SUBROUTINE pixelsetshared_build - -END MODULE MOD_PixelsetShared diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 deleted file mode 100644 index e66c2dc779..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90 +++ /dev/null @@ -1,886 +0,0 @@ -#include - -MODULE MOD_RangeCheck - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! Subroutines show the range of values in block data or vector data. -! -! Notice that: -! 1. "check_block_data" can only be called by IO processes. -! 2. "check_vector_data" can only be called by compute ranks. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - -#ifdef RangeCheck - USE MOD_UserDefFun, only: isnan_ud - IMPLICIT NONE - - INTERFACE check_block_data - MODULE procedure check_block_data_real8_2d - END INTERFACE check_block_data - - INTERFACE check_vector_data - MODULE procedure check_vector_data_real8_1d - MODULE procedure check_vector_data_real8_2d - MODULE procedure check_vector_data_real8_3d - MODULE procedure check_vector_data_real8_4d - MODULE procedure check_vector_data_real8_5d - MODULE procedure check_vector_data_int32_1d - END INTERFACE check_vector_data - -CONTAINS - - ! ---------- - SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_DataType - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: varname - type(block_data_real8_2d), intent(in) :: gdata - real(r8), intent(in), optional :: spv_in - real(r8), intent(in), optional :: limits(2) - - ! Local variables - real(r8) :: gmin, gmax, spv - real(r8), allocatable :: gmin_all(:), gmax_all(:) - logical, allocatable :: msk2(:,:) - integer :: iblkme, ib, jb, ix, iy - logical :: has_nan - character(len=256) :: wfmt, exception, str_print - - IF (p_is_active) THEN - - IF (present(spv_in)) THEN - spv = spv_in - ELSE - spv = spval - ENDIF - - gmin = spv - gmax = spv - - has_nan = .false. - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - - IF (.not. allocated(gdata%blk(ib,jb)%val)) CYCLE - - allocate(msk2 (size(gdata%blk(ib,jb)%val,1), size(gdata%blk(ib,jb)%val,2))) - msk2 = gdata%blk(ib,jb)%val /= spv - - IF (any(msk2)) THEN - IF (gmin == spv) THEN - gmin = minval(gdata%blk(ib,jb)%val, mask = msk2) - ELSE - gmin = min(gmin, minval(gdata%blk(ib,jb)%val, mask = msk2)) - ENDIF - - IF (gmax == spv) THEN - gmax = maxval(gdata%blk(ib,jb)%val, mask = msk2) - ELSE - gmax = max(gmax, maxval(gdata%blk(ib,jb)%val, mask = msk2)) - ENDIF - ENDIF - - DO iy = 1, size(gdata%blk(ib,jb)%val,2) - DO ix = 1, size(gdata%blk(ib,jb)%val,1) - has_nan = has_nan .or. isnan_ud(gdata%blk(ib,jb)%val(ix,iy)) - ENDDO - ENDDO - - deallocate(msk2) - - ENDDO - -#ifdef USEMPI - IF (p_iam_active == p_root) THEN - allocate (gmin_all (0:p_np_active-1)) - allocate (gmax_all (0:p_np_active-1)) - CALL mpi_gather (gmin, 1, MPI_REAL8, gmin_all, 1, MPI_REAL8, p_root, p_comm_active, p_err) - CALL mpi_gather (gmax, 1, MPI_REAL8, gmax_all, 1, MPI_REAL8, p_root, p_comm_active, p_err) - ELSE - CALL mpi_gather (gmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_active, p_err) - CALL mpi_gather (gmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_active, p_err) - ENDIF - - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) - - IF (p_iam_active == p_root) THEN - IF (any(gmin_all /= spv)) THEN - gmin = minval(gmin_all, mask = (gmin_all /= spv)) - ELSE - gmin = spv - ENDIF - - IF (any(gmax_all /= spv)) THEN - gmax = maxval(gmax_all, mask = (gmax_all /= spv)) - ELSE - gmax = spv - ENDIF - - deallocate (gmin_all) - deallocate (gmax_all) - ENDIF -#endif - IF (p_iam_active == p_root) THEN - - exception = '' - - IF (has_nan) THEN - exception = trim(exception) // ' with NAN' - ENDIF - - IF (present(limits)) THEN - IF ((gmin < limits(1)) .or. (gmax > limits(2))) THEN - exception = trim(exception) // ' Out of Range!' - ENDIF - ENDIF - - wfmt = "('Check block data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" - write(str_print,wfmt) varname, gmin, gmax, trim(exception) - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_active(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_active(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - - write(*,'(A)') trim(str_print) - -#if (defined CoLMDEBUG) - IF (len_trim(exception) > 0) THEN - CALL CoLM_stop () - ENDIF -#endif - ENDIF - - END SUBROUTINE check_block_data_real8_2d - - - ! ---------- - SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: varname - real(r8), allocatable, intent(in) :: vdata(:) - - real(r8), intent(in), optional :: spv_in - real(r8), intent(in), optional :: limits(2) - - ! Local variables - real(r8) :: vmin, vmax, spv - real(r8), allocatable :: vmin_all(:), vmax_all(:) - integer :: i - logical :: has_nan - character(len=256) :: wfmt, exception, str_print - - IF (p_is_compute) THEN - - IF (present(spv_in)) THEN - spv = spv_in - ELSE - spv = spval - ENDIF - - IF (allocated(vdata)) THEN - IF (any(vdata /= spv)) THEN - vmin = minval(vdata, mask = vdata /= spv) - vmax = maxval(vdata, mask = vdata /= spv) - ELSE - vmin = spv - vmax = spv - ENDIF - - has_nan = .false. - DO i = lbound(vdata,1), ubound(vdata,1) - has_nan = has_nan .or. isnan_ud(vdata(i)) - ENDDO - ELSE - vmin = spv; vmax = spv - has_nan = .false. - ENDIF - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (vmin_all (0:p_np_compute-1)) - allocate (vmax_all (0:p_np_compute-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ENDIF - - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN - IF (any(vmin_all /= spv)) THEN - vmin = minval(vmin_all, mask = (vmin_all /= spv)) - ELSE - vmin = spv - ENDIF - - IF (any(vmax_all /= spv)) THEN - vmax = maxval(vmax_all, mask = (vmax_all /= spv)) - ELSE - vmax = spv - ENDIF - - deallocate (vmin_all) - deallocate (vmax_all) - ENDIF -#endif - - IF (p_iam_compute == p_root) THEN - - exception = '' - - IF (has_nan) THEN - exception = trim(exception) // ' with NAN' - ENDIF - - IF (present(limits)) THEN - IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN - exception = trim(exception) // ' Out of Range!' - ENDIF - ENDIF - - wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" - write(str_print,wfmt) varname, vmin, vmax, trim(exception) - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - - write(*,'(A)') trim(str_print) - -#if (defined CoLMDEBUG) - IF (len_trim(exception) > 0) THEN - CALL CoLM_stop () - ENDIF -#endif - ENDIF - - END SUBROUTINE check_vector_data_real8_1d - - ! ---------- - SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: varname - real(r8), allocatable, intent(in) :: vdata(:,:) - - real(r8), intent(in), optional :: spv_in - real(r8), intent(in), optional :: limits(2) - - ! Local variables - real(r8) :: vmin, vmax, spv - real(r8), allocatable :: vmin_all(:), vmax_all(:) - integer :: i, j - logical :: has_nan - character(len=256) :: wfmt, exception, str_print - - IF (p_is_compute) THEN - - IF (present(spv_in)) THEN - spv = spv_in - ELSE - spv = spval - ENDIF - - IF (allocated(vdata)) THEN - IF (any(vdata /= spv)) THEN - vmin = minval(vdata, mask = vdata /= spv) - vmax = maxval(vdata, mask = vdata /= spv) - ELSE - vmin = spv - vmax = spv - ENDIF - - has_nan = .false. - DO j = lbound(vdata,2), ubound(vdata,2) - DO i = lbound(vdata,1), ubound(vdata,1) - has_nan = has_nan .or. isnan_ud(vdata(i,j)) - ENDDO - ENDDO - ELSE - vmin = spv; vmax = spv - has_nan = .false. - ENDIF - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (vmin_all (0:p_np_compute-1)) - allocate (vmax_all (0:p_np_compute-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ENDIF - - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN - IF (any(vmin_all /= spv)) THEN - vmin = minval(vmin_all, mask = (vmin_all /= spv)) - ELSE - vmin = spv - ENDIF - - IF (any(vmax_all /= spv)) THEN - vmax = maxval(vmax_all, mask = (vmax_all /= spv)) - ELSE - vmax = spv - ENDIF - - deallocate (vmin_all) - deallocate (vmax_all) - ENDIF -#endif - - IF (p_iam_compute == p_root) THEN - - exception = '' - - IF (has_nan) THEN - exception = trim(exception) // ' with NAN' - ENDIF - - IF (present(limits)) THEN - IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN - exception = trim(exception) // ' Out of Range!' - ENDIF - ENDIF - - wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" - write(str_print,wfmt) varname, vmin, vmax, trim(exception) - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - - write(*,'(A)') trim(str_print) - -#if (defined CoLMDEBUG) - IF (len_trim(exception) > 0) THEN - CALL CoLM_stop () - ENDIF -#endif - ENDIF - - END SUBROUTINE check_vector_data_real8_2d - - ! ---------- - SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: varname - real(r8), allocatable, intent(in) :: vdata(:,:,:) - - real(r8), intent(in), optional :: spv_in - real(r8), intent(in), optional :: limits(2) - - ! Local variables - real(r8) :: vmin, vmax, spv - real(r8), allocatable :: vmin_all(:), vmax_all(:) - integer :: i, j, k - logical :: has_nan - character(len=256) :: wfmt, exception, str_print - - IF (p_is_compute) THEN - - IF (present(spv_in)) THEN - spv = spv_in - ELSE - spv = spval - ENDIF - - IF (allocated(vdata)) THEN - IF (any(vdata /= spv)) THEN - vmin = minval(vdata, mask = vdata /= spv) - vmax = maxval(vdata, mask = vdata /= spv) - ELSE - vmin = spv - vmax = spv - ENDIF - - has_nan = .false. - DO k = lbound(vdata,3), ubound(vdata,3) - DO j = lbound(vdata,2), ubound(vdata,2) - DO i = lbound(vdata,1), ubound(vdata,1) - has_nan = has_nan .or. isnan_ud(vdata(i,j,k)) - ENDDO - ENDDO - ENDDO - ELSE - vmin = spv; vmax = spv - has_nan = .false. - ENDIF - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (vmin_all (0:p_np_compute-1)) - allocate (vmax_all (0:p_np_compute-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ENDIF - - - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN - IF (any(vmin_all /= spv)) THEN - vmin = minval(vmin_all, mask = (vmin_all /= spv)) - ELSE - vmin = spv - ENDIF - - IF (any(vmax_all /= spv)) THEN - vmax = maxval(vmax_all, mask = (vmax_all /= spv)) - ELSE - vmax = spv - ENDIF - - deallocate (vmin_all) - deallocate (vmax_all) - ENDIF -#endif - - IF (p_iam_compute == p_root) THEN - - exception = '' - - IF (has_nan) THEN - exception = trim(exception) // ' with NAN' - ENDIF - - IF (present(limits)) THEN - IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN - exception = trim(exception) // ' Out of Range!' - ENDIF - ENDIF - - wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" - write(str_print,wfmt) varname, vmin, vmax, trim(exception) - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - - write(*,'(A)') trim(str_print) - -#if (defined CoLMDEBUG) - IF (len_trim(exception) > 0) THEN - CALL CoLM_stop () - ENDIF -#endif - ENDIF - - END SUBROUTINE check_vector_data_real8_3d - - ! ---------- - SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global, only: spval - IMPLICIT NONE - - character(len=*), intent(in) :: varname - real(r8), allocatable, intent(in) :: vdata(:,:,:,:) - - real(r8), intent(in), optional :: spv_in - real(r8), intent(in), optional :: limits(2) - - ! Local variables - real(r8) :: vmin, vmax, spv - real(r8), allocatable :: vmin_all(:), vmax_all(:) - integer :: i, j, k, l - logical :: has_nan - character(len=256) :: wfmt, exception, str_print - - IF (p_is_compute) THEN - - IF (present(spv_in)) THEN - spv = spv_in - ELSE - spv = spval - ENDIF - - IF (allocated(vdata)) THEN - IF (any(vdata /= spv)) THEN - vmin = minval(vdata, mask = vdata /= spv) - vmax = maxval(vdata, mask = vdata /= spv) - ELSE - vmin = spv - vmax = spv - ENDIF - - has_nan = .false. - DO l = lbound(vdata,4), ubound(vdata,4) - DO k = lbound(vdata,3), ubound(vdata,3) - DO j = lbound(vdata,2), ubound(vdata,2) - DO i = lbound(vdata,1), ubound(vdata,1) - has_nan = has_nan .or. isnan_ud(vdata(i,j,k,l)) - ENDDO - ENDDO - ENDDO - ENDDO - ELSE - vmin = spv; vmax = spv - has_nan = .false. - ENDIF - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (vmin_all (0:p_np_compute-1)) - allocate (vmax_all (0:p_np_compute-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ENDIF - - - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN - IF (any(vmin_all /= spv)) THEN - vmin = minval(vmin_all, mask = (vmin_all /= spv)) - ELSE - vmin = spv - ENDIF - - IF (any(vmax_all /= spv)) THEN - vmax = maxval(vmax_all, mask = (vmax_all /= spv)) - ELSE - vmax = spv - ENDIF - - deallocate (vmin_all) - deallocate (vmax_all) - ENDIF -#endif - - IF (p_iam_compute == p_root) THEN - - exception = '' - - IF (has_nan) THEN - exception = trim(exception) // ' with NAN' - ENDIF - - IF (present(limits)) THEN - IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN - exception = trim(exception) // ' Out of Range!' - ENDIF - ENDIF - - wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" - write(str_print,wfmt) varname, vmin, vmax, trim(exception) - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - - write(*,'(A)') trim(str_print) - -#if (defined CoLMDEBUG) - IF (len_trim(exception) > 0) THEN - CALL CoLM_stop () - ENDIF -#endif - ENDIF - - END SUBROUTINE check_vector_data_real8_4d - - - ! ---------- - SUBROUTINE check_vector_data_real8_5d (varname, vdata, spv_in, limits) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - character(len=*), intent(in) :: varname - real(r8), intent(in) :: vdata(:,:,:,:,:) - real(r8), intent(in), optional :: spv_in - real(r8), intent(in), optional :: limits(2) - - ! Local variables - real(r8) :: vmin, vmax, spv - real(r8), allocatable :: vmin_all(:), vmax_all(:) - integer :: i, j, k, l, m - logical :: has_nan - character(len=256) :: wfmt, ss, info - - IF (p_is_compute) THEN - - IF (present(spv_in)) THEN - spv = spv_in - ELSE - spv = spval - ENDIF - - IF (any(vdata /= spv)) THEN - vmin = minval(vdata, mask = vdata /= spv) - vmax = maxval(vdata, mask = vdata /= spv) - ELSE - vmin = spv - vmax = spv - ENDIF - - has_nan = .false. - DO m = 1, size(vdata,5) - DO l = 1, size(vdata,4) - DO k = 1, size(vdata,3) - DO j = 1, size(vdata,2) - DO i = 1, size(vdata,1) - has_nan = has_nan .or. isnan_ud(vdata(i,j,k,l,m)) - ENDDO - ENDDO - ENDDO - ENDDO - ENDDO - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (vmin_all (0:p_np_compute-1)) - allocate (vmax_all (0:p_np_compute-1)) - CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ELSE - CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err) - ENDIF - - - CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err) - - IF (p_iam_compute == p_root) THEN - IF (any(vmin_all /= spv)) THEN - vmin = minval(vmin_all, mask = (vmin_all /= spv)) - ELSE - vmin = spv - ENDIF - - IF (any(vmax_all /= spv)) THEN - vmax = maxval(vmax_all, mask = (vmax_all /= spv)) - ELSE - vmax = spv - ENDIF - - deallocate (vmin_all) - deallocate (vmax_all) - ENDIF -#endif - - IF (p_iam_compute == p_root) THEN - - info = '' - - IF (has_nan) THEN - info = trim(info) // ' with NAN' - ENDIF - - IF (present(limits)) THEN - IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN - info = trim(info) // ' Out of Range!' - ENDIF - ENDIF - - wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)" - write(*,wfmt) varname, vmin, vmax, info - -#if(defined CoLMDEBUG) - IF (len_trim(info) > 0) THEN - CALL CoLM_stop () - ENDIF -#endif - - ENDIF - - ENDIF - - END SUBROUTINE check_vector_data_real8_5d - - - ! ---------- - SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in) - - USE MOD_Precision - USE MOD_SPMD_Task - IMPLICIT NONE - - character(len=*), intent(in) :: varname - integer, allocatable, intent(in) :: vdata(:) - - integer, intent(in), optional :: spv_in - - ! Local variables - integer :: vmin, vmax - logical :: isnull - logical, allocatable :: null_all(:) - integer, allocatable :: vmin_all(:), vmax_all(:) - character(len=256) :: wfmt, str_print - - IF (p_is_compute) THEN - - isnull = .not. allocated(vdata) - - IF (.not. isnull) THEN - IF (present(spv_in)) THEN - IF (any(vdata /= spv_in)) THEN - vmin = minval(vdata, mask = vdata /= spv_in) - vmax = maxval(vdata, mask = vdata /= spv_in) - ELSE - vmin = spv_in - vmax = spv_in - ENDIF - ELSE - vmin = minval(vdata) - vmax = maxval(vdata) - ENDIF - ENDIF - -#ifdef USEMPI - IF (p_iam_compute == p_root) THEN - allocate (null_all (0:p_np_compute-1)) - allocate (vmin_all (0:p_np_compute-1)) - allocate (vmax_all (0:p_np_compute-1)) - CALL mpi_gather (isnull, 1, MPI_LOGICAL, null_all, 1, MPI_LOGICAL, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmin, 1, MPI_INTEGER, vmin_all, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_INTEGER, vmax_all, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) - ELSE - CALL mpi_gather (isnull, 1, MPI_LOGICAL, MPI_LNULL_P, 1, MPI_LOGICAL, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmin, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) - CALL mpi_gather (vmax, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_compute, p_err) - ENDIF - - IF (p_iam_compute == p_root) THEN - IF (present(spv_in)) THEN - null_all = null_all .and. (vmin_all == spv_in) - ENDIF - - vmin = minval(vmin_all, mask = .not. null_all) - vmax = maxval(vmax_all, mask = .not. null_all) - - deallocate (null_all) - deallocate (vmin_all) - deallocate (vmax_all) - ENDIF -#endif - - IF (p_iam_compute == p_root) THEN - wfmt = "('Check vector data:', A25, ' is in (', I20, ',', I20, ')')" - write(str_print,wfmt) varname, vmin, vmax -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, & - mpi_tag_mesg, p_comm_glb, p_err) -#endif - ENDIF - ENDIF - - IF (p_is_root) THEN -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), & - mpi_tag_mesg, p_comm_glb, p_stat, p_err) -#endif - write(*,'(A)') trim(str_print) - ENDIF - - END SUBROUTINE check_vector_data_int32_1d - -#endif - -END MODULE MOD_RangeCheck diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 deleted file mode 100644 index f14cd1c143..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 +++ /dev/null @@ -1,212 +0,0 @@ -#include - -MODULE MOD_SPMD_Task - -!----------------------------------------------------------------------------------------- -! !DESCRIPTION: -! -! SPMD refers to "Single PROGRAM/Multiple Data" parallelization. -! -! MPAS owns MPI initialization and decomposition. Every MPAS rank stays active -! as a CoLM compute rank, with rank 0 used only for logging/error aggregation. -! -! CoLM element ownership is supplied by MPAS cell ownership. Patch/PFT state -! remains internal to CoLM and is mapped back to the owning element/cell by CoLM. -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - - include 'mpif.h' - - integer, parameter :: p_root = 0 - - logical :: p_is_root = .false. - logical :: p_is_active = .false. - logical :: p_is_compute = .false. - logical :: p_is_history_task = .false. - - integer :: p_comm_glb_plus = MPI_COMM_NULL - integer :: p_iam_glb_plus = -1 - - ! MPAS-owned communicator aliases used by legacy CoLM helper APIs. - integer :: p_comm_glb = MPI_COMM_NULL - integer :: p_iam_glb = -1 - integer :: p_np_glb = 0 - - integer :: p_comm_group = MPI_COMM_NULL - integer :: p_iam_group = -1 - integer :: p_np_group = 0 - - integer :: p_my_group = 0 - integer :: p_address_root = p_root - - integer :: p_comm_active = MPI_COMM_NULL - integer :: p_iam_active = -1 - integer :: p_np_active = 0 - - integer, allocatable :: p_itis_active (:) - integer, allocatable :: p_address_active (:) - - integer :: p_comm_compute = MPI_COMM_NULL - integer :: p_iam_compute = -1 - integer :: p_np_compute = 0 - - integer, allocatable :: p_itis_compute (:) - integer, allocatable :: p_address_compute (:) - - integer :: p_address_history_task = -1 - - integer :: p_stat (MPI_STATUS_SIZE) - integer :: p_err = 0 - - integer, PUBLIC, parameter :: mpi_tag_size = 1 - integer, PUBLIC, parameter :: mpi_tag_mesg = 2 - integer, PUBLIC, parameter :: mpi_tag_data = 3 - - integer :: MPI_INULL_P(1) - logical :: MPI_LNULL_P(1) - real(r8) :: MPI_RNULL_P(1) - - integer, parameter :: MesgMaxSize = 4194304 ! 4MB - - PUBLIC :: spmd_init - PUBLIC :: spmd_exit - PUBLIC :: divide_processes_into_groups - PUBLIC :: spmd_assign_history_task - -CONTAINS - - !----------------------------------------- - SUBROUTINE spmd_init (MyComm_r) - - IMPLICIT NONE - integer, intent(in), optional :: MyComm_r - logical mpi_inited - integer :: iproc - - CALL MPI_INITIALIZED (mpi_inited, p_err) - - IF ( .not. mpi_inited ) THEN - CALL mpi_init (p_err) - ENDIF - - IF (present(MyComm_r)) THEN - CALL MPI_Comm_dup (MyComm_r, p_comm_glb, p_err) - ELSE - CALL MPI_Comm_dup (MPI_COMM_WORLD, p_comm_glb, p_err) - ENDIF - - CALL mpi_comm_rank (p_comm_glb, p_iam_glb, p_err) - CALL mpi_comm_size (p_comm_glb, p_np_glb, p_err) - - p_address_root = p_root - p_is_root = (p_iam_glb == p_address_root) - p_is_active = .true. - p_is_compute = .true. - p_is_history_task = .false. - - p_comm_group = p_comm_glb - p_iam_group = p_iam_glb - p_np_group = p_np_glb - p_my_group = 0 - - p_comm_active = p_comm_glb - p_iam_active = p_iam_glb - p_np_active = p_np_glb - - p_comm_compute = p_comm_glb - p_iam_compute = p_iam_glb - p_np_compute = p_np_glb - - p_comm_glb_plus = MPI_COMM_NULL - p_iam_glb_plus = -1 - p_address_history_task = -1 - - IF (allocated(p_itis_active )) deallocate (p_itis_active ) - IF (allocated(p_address_active )) deallocate (p_address_active ) - IF (allocated(p_itis_compute )) deallocate (p_itis_compute ) - IF (allocated(p_address_compute)) deallocate (p_address_compute) - - allocate (p_itis_active (0:p_np_glb-1)) - allocate (p_address_active (0:p_np_glb-1)) - allocate (p_itis_compute (0:p_np_glb-1)) - allocate (p_address_compute (0:p_np_glb-1)) - - DO iproc = 0, p_np_glb-1 - p_itis_active(iproc) = iproc - p_address_active(iproc) = iproc - p_itis_compute(iproc) = iproc - p_address_compute(iproc) = iproc - ENDDO - - END SUBROUTINE spmd_init - - !----------------------------------------- - SUBROUTINE divide_processes_into_groups (ngrp) - - IMPLICIT NONE - integer, intent(in) :: ngrp - - IF (ngrp <= 0) THEN - CALL mpi_abort (p_comm_glb, 1, p_err) - ENDIF - - ! MPAS owns the process decomposition. Keep every MPAS rank active. - p_comm_group = p_comm_glb - p_iam_group = p_iam_glb - p_np_group = p_np_glb - p_my_group = 0 - - END SUBROUTINE divide_processes_into_groups - - !----------------------------------------- - SUBROUTINE spmd_exit - - IF (allocated(p_itis_active )) deallocate (p_itis_active ) - IF (allocated(p_address_active )) deallocate (p_address_active ) - IF (allocated(p_itis_compute )) deallocate (p_itis_compute ) - IF (allocated(p_address_compute)) deallocate (p_address_compute) - - IF (p_comm_glb /= MPI_COMM_NULL) THEN - CALL mpi_barrier (p_comm_glb, p_err) - CALL MPI_Comm_free (p_comm_glb, p_err) - ENDIF - - p_comm_glb = MPI_COMM_NULL - p_comm_group = MPI_COMM_NULL - p_comm_active = MPI_COMM_NULL - p_comm_compute = MPI_COMM_NULL - - END SUBROUTINE spmd_exit - - ! ----- ----- - SUBROUTINE spmd_assign_history_task () - - IMPLICIT NONE - - CALL CoLM_stop('MPAS embedded CoLM does not support a dedicated history MPI task.') - - END SUBROUTINE spmd_assign_history_task - - ! -- STOP all processes -- - SUBROUTINE CoLM_stop (mesg) - - IMPLICIT NONE - character(len=*), optional :: mesg - logical :: mpi_inited - - IF (present(mesg)) write(*,*) trim(mesg) - - CALL MPI_INITIALIZED (mpi_inited, p_err) - IF (mpi_inited .and. p_comm_glb /= MPI_COMM_NULL) THEN - CALL mpi_abort (p_comm_glb, 1, p_err) - ENDIF - - STOP - - END SUBROUTINE CoLM_stop - -END MODULE MOD_SPMD_Task diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 deleted file mode 100644 index 80de18fdf7..0000000000 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 +++ /dev/null @@ -1,3472 +0,0 @@ -#include - -#ifdef SinglePoint -MODULE MOD_SingleSrfdata -!----------------------------------------------------------------------- -! !DESCRIPTION: -! -! This module includes subroutines to read or write surface data for -! "SinglePoint". -! -! Created by Shupeng Zhang, May 2023 -!----------------------------------------------------------------------- - - USE MOD_Precision, only: r8 - USE MOD_Vars_Global - USE MOD_Const_LC - USE MOD_Namelist - USE MOD_SPMD_Task - IMPLICIT NONE - SAVE - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - integer, allocatable :: SITE_pfttyp (:) - real(r8), allocatable :: SITE_pctpfts (:) -#endif - -#ifdef CROP - integer, allocatable :: SITE_croptyp (:) - real(r8), allocatable :: SITE_pctcrop (:) -#endif - - real(r8) :: SITE_htop -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - real(r8), allocatable :: SITE_htop_pfts (:) -#endif - - real(r8), allocatable :: SITE_LAI_monthly (:,:) - real(r8), allocatable :: SITE_SAI_monthly (:,:) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - real(r8), allocatable :: SITE_LAI_pfts_monthly (:,:,:) - real(r8), allocatable :: SITE_SAI_pfts_monthly (:,:,:) -#endif - - integer, allocatable :: SITE_LAI_year (:) - real(r8), allocatable :: SITE_LAI_8day (:,:) - - real(r8) :: SITE_lakedepth = 1. - - real(r8) :: SITE_soil_s_v_alb - real(r8) :: SITE_soil_d_v_alb - real(r8) :: SITE_soil_s_n_alb - real(r8) :: SITE_soil_d_n_alb - - real(r8), allocatable :: SITE_soil_vf_quartz_mineral (:) - real(r8), allocatable :: SITE_soil_vf_gravels (:) - real(r8), allocatable :: SITE_soil_vf_sand (:) - real(r8), allocatable :: SITE_soil_vf_clay (:) - real(r8), allocatable :: SITE_soil_vf_om (:) - real(r8), allocatable :: SITE_soil_wf_gravels (:) - real(r8), allocatable :: SITE_soil_wf_sand (:) - real(r8), allocatable :: SITE_soil_wf_clay (:) - real(r8), allocatable :: SITE_soil_wf_om (:) - real(r8), allocatable :: SITE_soil_OM_density (:) - real(r8), allocatable :: SITE_soil_BD_all (:) - real(r8), allocatable :: SITE_soil_theta_s (:) - real(r8), allocatable :: SITE_soil_k_s (:) - real(r8), allocatable :: SITE_soil_csol (:) - real(r8), allocatable :: SITE_soil_tksatu (:) - real(r8), allocatable :: SITE_soil_tksatf (:) - real(r8), allocatable :: SITE_soil_tkdry (:) - real(r8), allocatable :: SITE_soil_k_solids (:) - real(r8), allocatable :: SITE_soil_psi_s (:) - real(r8), allocatable :: SITE_soil_lambda (:) - real(r8), allocatable :: SITE_soil_theta_r (:) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8), allocatable :: SITE_soil_alpha_vgm (:) - real(r8), allocatable :: SITE_soil_L_vgm (:) - real(r8), allocatable :: SITE_soil_n_vgm (:) -#endif - real(r8), allocatable :: SITE_soil_BA_alpha (:) - real(r8), allocatable :: SITE_soil_BA_beta (:) - - integer :: SITE_soil_texture - - real(r8) :: SITE_dbedrock = 0. - - real(r8) :: SITE_elevation = 0. - real(r8) :: SITE_elvstd = 0. - real(r8) :: SITE_sloperatio = 0. - - ! topography factors used for downscaling - real(r8) :: SITE_svf = 0. - real(r8) :: SITE_cur = 0. - real(r8), allocatable :: SITE_slp_type (:) - real(r8), allocatable :: SITE_asp_type (:) - real(r8), allocatable :: SITE_area_type(:) - real(r8), allocatable :: SITE_sf_lut (:,:) - - logical :: u_site_landtype, u_site_crop, u_site_pfts, u_site_htop, & - u_site_lai, u_site_lakedepth, u_site_soil_bright, u_site_vf_quartz_mineral, & - u_site_vf_gravels, u_site_vf_sand, u_site_vf_clay, u_site_vf_om, & - u_site_wf_gravels, u_site_wf_sand, u_site_wf_clay, u_site_wf_om, & - u_site_OM_density, u_site_BD_all, u_site_theta_s, u_site_k_s, & - u_site_csol, u_site_tksatu, u_site_tksatf, u_site_tkdry, & - u_site_k_solids, u_site_psi_s, u_site_lambda, u_site_theta_r, & - u_site_alpha_vgm, u_site_L_vgm, u_site_n_vgm, u_site_BA_alpha, & - u_site_BA_beta, u_site_soil_texture, u_site_dbedrock, u_site_elevation, & - u_site_elvstd, u_site_svf, u_site_cur, u_site_slp_type, & - u_site_asp_type, u_site_area_type, u_site_sf_lut, u_site_sloperatio - - - integer :: SITE_ncar_rid - integer :: SITE_urbtyp - - real(r8) :: SITE_lucyid - - real(r8) :: SITE_fveg_urb - real(r8) :: SITE_htop_urb - real(r8) :: SITE_flake_urb - real(r8) :: SITE_froof - real(r8) :: SITE_hroof - real(r8) :: SITE_fgimp - real(r8) :: SITE_fgper - real(r8) :: SITE_hlr - real(r8) :: SITE_lambdaw - real(r8) :: SITE_popden - - real(r8) :: SITE_em_roof - real(r8) :: SITE_em_wall - real(r8) :: SITE_em_gimp - real(r8) :: SITE_em_gper - real(r8) :: SITE_t_roommax - real(r8) :: SITE_t_roommin - - real(r8) :: SITE_thickroof - real(r8) :: SITE_thickwall - - real(r8), allocatable :: SITE_cv_roof (:) - real(r8), allocatable :: SITE_cv_wall (:) - real(r8), allocatable :: SITE_cv_gimp (:) - real(r8), allocatable :: SITE_tk_roof (:) - real(r8), allocatable :: SITE_tk_wall (:) - real(r8), allocatable :: SITE_tk_gimp (:) - - real(r8), allocatable :: SITE_alb_roof (:,:) - real(r8), allocatable :: SITE_alb_wall (:,:) - real(r8), allocatable :: SITE_alb_gimp (:,:) - real(r8), allocatable :: SITE_alb_gper (:,:) - - logical :: u_site_froof, u_site_hroof, u_site_fgper , u_site_hlr , & - u_site_fveg , u_site_htopu, u_site_urblai , u_site_urbsai , & - u_site_flake, u_site_utype, & - u_site_albr , u_site_albw , u_site_albgimp, u_site_albgper, & - u_site_emr , u_site_emw , u_site_emgimp , u_site_emgper , & - u_site_cvr , u_site_cvw , u_site_cvgimp , & - u_site_tkr , u_site_tkw , u_site_tkgimp , & - u_site_tbmax, u_site_tbmin, u_site_thickr , u_site_thickw , & - u_site_pop , u_site_lucy - - ! ----------------------------------------------------------------------------------- - ! The soil color and reflectance is from the work: - ! Peter J. Lawrence and Thomas N. Chase, 2007: - ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0): - ! Part 1 generating MODIS consistent land surface parameters - ! ----------------------------------------------------------------------------------- - real(r8), parameter :: soil_s_v_refl(20) = & ! Saturated visible soil reflectance - (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, & - 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /) - real(r8), parameter :: soil_d_v_refl(20) = & ! Dry visible soil reflectance - (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, & - 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /) - real(r8), parameter :: soil_s_n_refl(20) = & ! Saturated near infrared soil reflectance - (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, & - 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /) - real(r8), parameter :: soil_d_n_refl(20) = & ! Dry near infrared soil reflectance - (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, & - 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /) - -CONTAINS - - -!----------------------------------------------------------------------- - SUBROUTINE read_surface_data_single (fsrfdata, for_surface_build) - - USE MOD_TimeManager - USE MOD_Grid - USE MOD_Block - USE MOD_NetCDFSerial - USE MOD_NetCDFPoint - USE MOD_Namelist - USE MOD_Utils - USE MOD_Vars_Global, only: PI - USE MOD_Const_LC - USE MOD_Const_PFT - USE MOD_SPMD_Task - USE MOD_LandPatch -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT -#endif - USE MOD_Mesh, only: numelm - USE MOD_LandElm - IMPLICIT NONE - - character(len=*), intent(in) :: fsrfdata - logical, intent(in) :: for_surface_build - - ! Local Variables - real(r8) :: lat_in, lon_in - real(r8) :: LAI, lakedepth, slp, asp, zenith_angle - integer :: i, isc, nsl, typ, a, z, arraysize - integer :: iyear, idate(3), simulation_lai_year_start, simulation_lai_year_end - integer :: start_year, end_year, ntime, itime - - character(len=256) :: filename, dir_5x5, fmt_str - character(len=4) :: cyear, c - - type(grid_type) :: gridpatch, gridcrop, gridpft, gridhtop, gridlai, gridlake, & - gridbright, gridsoil, gridrock, gridtopo, grid_topo_factor - - integer, allocatable :: croptyp(:), pfttyp (:) - real(r8), allocatable :: pctcrop(:), pctpfts(:), pftLAI(:), pftSAI(:), tea_f(:), tea_b(:) - - integer, parameter :: N_PFT_modis = 16 - logical :: readflag - - CALL Init_GlobalVars - CALL Init_LC_Const - - IF (for_surface_build) THEN - write(*,*) - write(*,*) ' ---------------- Make Single Point Surface Data ---------------- ' - ENDIF - - IF (ncio_var_exist(fsrfdata, 'latitude')) THEN - CALL ncio_read_serial (fsrfdata, 'latitude', lat_in) - IF ((lat_in /= SITE_lat_location) .and. (SITE_lat_location /= -1.e36_r8)) THEN - write(*,*) 'Warning: Latitude mismatch: ', & - lat_in, ' in data file and ', SITE_lat_location, 'in namelist.' - ENDIF - SITE_lat_location = lat_in - ENDIF - - IF (ncio_var_exist(fsrfdata, 'longitude')) THEN - CALL ncio_read_serial (fsrfdata, 'longitude', lon_in) - IF ((lon_in /= SITE_lon_location) .and. (SITE_lon_location /= -1.e36_r8)) THEN - write(*,*) 'Warning: Longitude mismatch: ', & - lon_in, ' in data file and ', SITE_lon_location, 'in namelist.' - ENDIF - SITE_lon_location = lon_in - ENDIF - - CALL normalize_longitude (SITE_lon_location) - - IF (.not. isgreenwich) THEN - LocalLongitude = SITE_lon_location - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location - write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location - ENDIF - - - DEF_domain%edges = floor(SITE_lat_location) - DEF_domain%edgen = floor(SITE_lat_location) + 1. - DEF_domain%edgew = floor(SITE_lon_location) - DEF_domain%edgee = floor(SITE_lon_location) + 1. - - CALL gblock%set () - gblock%nblkme = 1 - allocate(gblock%xblkme(1)) - allocate(gblock%yblkme(1)) - gblock%xblkme(1) = find_nearest_west (SITE_lon_location, gblock%nxblk, gblock%lon_w) - gblock%yblkme(1) = find_nearest_south (SITE_lat_location, gblock%nyblk, gblock%lat_s) - - - ! (1) build/read "land patch" by using land cover type data - numpatch = 1 - -#ifdef LULC_USGS - u_site_landtype = (.not. for_surface_build) .or. (SITE_landtype >= 0) & - .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'USGS_classification')) - - IF (u_site_landtype) THEN - IF (SITE_landtype == -1) THEN - CALL ncio_read_serial (fsrfdata, 'USGS_classification', SITE_landtype) - ENDIF - ELSE - CALL gridpatch%define_by_name ('colm_1km') - filename = trim(DEF_dir_rawdata)//'/landtypes/landtype-usgs-update.nc' - CALL read_point_var_2d_int32 (gridpatch, filename, 'landtype', & - SITE_lon_location, SITE_lat_location, SITE_landtype) - ENDIF -#else - u_site_landtype = (.not. for_surface_build) .or. (SITE_landtype >= 0) & - .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'IGBP_classification')) - - IF (u_site_landtype) THEN - IF (SITE_landtype == -1) THEN - CALL ncio_read_serial (fsrfdata, 'IGBP_classification', SITE_landtype) - ENDIF - ELSE - CALL gridpatch%define_by_name ('colm_500m') - write(cyear,'(i4.4)') DEF_LC_YEAR - filename = trim(DEF_dir_rawdata)//'landtypes/landtype-igbp-modis-'//trim(cyear)//'.nc' - CALL read_point_var_2d_int32 (gridpatch, filename, 'landtype', & - SITE_lon_location, SITE_lat_location, SITE_landtype) - ENDIF -#endif - - IF (SITE_landtype < 0) THEN - write(*,*) 'Error! Please set SITE_landtype in namelist file !' - CALL CoLM_stop() - ENDIF - -#ifdef URBAN_MODEL - IF (SITE_landtype /= URBAN) THEN - write(*,*) 'Error! Please set SITE_landtype to URBAN in namelist file !' - CALL CoLM_stop() - ENDIF -#endif - - IF (for_surface_build) THEN - write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), & - ' (from ',trim(datasource(u_site_landtype)),')' - ENDIF - - ! (2) build/read "land crop" by using crop data -#ifdef CROP - IF (SITE_landtype == CROPLAND) THEN - - readflag = ((.not. for_surface_build) .or. USE_SITE_pctcrop) - u_site_crop = readflag & - .and. ncio_var_exist(fsrfdata,'croptyp',readflag) .and. ncio_var_exist(fsrfdata,'pctcrop',readflag) - - IF (u_site_crop) THEN - CALL ncio_read_serial (fsrfdata, 'croptyp', croptyp) - CALL ncio_read_serial (fsrfdata, 'pctcrop', pctcrop) - ELSE - allocate (croptyp (N_CFT)) - croptyp = (/(i, i = 1, N_CFT)/) - - filename = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc' - CALL gridcrop%define_from_file (filename, 'lat', 'lon') - CALL read_point_var_3d_first_real8 (gridcrop, filename, 'PCT_CFT', & - SITE_lon_location, SITE_lat_location, N_CFT, pctcrop) - ENDIF - - numpatch = count(pctcrop > 0.) - - IF (numpatch == 0) THEN - write(*,*) 'There is no crop at this point!' - CALL CoLM_stop() - ENDIF - - allocate (SITE_croptyp (numpatch)) - allocate (SITE_pctcrop (numpatch)) - - SITE_croptyp = pack(croptyp, pctcrop > 0.) - SITE_pctcrop = pack(pctcrop, pctcrop > 0.) / sum(pctcrop) - - IF (for_surface_build) THEN - write(c,'(I0)') numpatch - write(*,'(A,'//trim(c)//'I5,3A)') 'crop type : ', SITE_croptyp, ' (from ',trim(datasource(u_site_crop)),')' - write(*,'(A,'//trim(c)//'F5.2,3A)') 'crop frac : ', SITE_pctcrop, ' (from ',trim(datasource(u_site_crop)),')' - ENDIF - - ENDIF -#endif - - - ! (3) build/read "land pft" or "land pc" by using plant functional type data -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) -#ifndef CROP - IF (patchtypes(SITE_landtype) == 0) THEN -#else - IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN -#endif - readflag = ((.not. for_surface_build) .or. USE_SITE_pctpfts) - u_site_pfts = readflag & - .and. ncio_var_exist(fsrfdata,'pfttyp',readflag) .and. ncio_var_exist(fsrfdata,'pctpfts',readflag) - - IF (u_site_pfts) THEN - CALL ncio_read_serial (fsrfdata, 'pfttyp', pfttyp ) - CALL ncio_read_serial (fsrfdata, 'pctpfts', pctpfts) - ELSE - allocate (pfttyp (N_PFT_modis)) - pfttyp = (/(i, i = 0, N_PFT_modis-1)/) - - CALL gridpft%define_by_name ('colm_500m') - - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - write(cyear,'(i4.4)') DEF_LC_YEAR - CALL read_point_5x5_var_3d_real8 (gridpft, dir_5x5, 'MOD'//trim(cyear), 'PCT_PFT', & - SITE_lon_location, SITE_lat_location, N_PFT_modis, pctpfts) - ENDIF - - numpft = count(pctpfts > 0.) - - allocate (SITE_pfttyp (numpft)) - allocate (SITE_pctpfts (numpft)) - - SITE_pfttyp = pack(pfttyp, pctpfts > 0.) - SITE_pctpfts = pack(pctpfts, pctpfts > 0.) / sum(pctpfts) - -#ifdef CROP - ELSEIF (SITE_landtype == CROPLAND) THEN - u_site_pfts = .false. - numpft = numpatch - allocate (SITE_pfttyp (numpft)) - allocate (SITE_pctpfts (numpft)) - SITE_pfttyp = SITE_croptyp + N_PFT - 1 - SITE_pctpfts = 1. -#endif - ELSE - numpft = 0 - ENDIF - - IF ((patchtypes(SITE_landtype) == 0) .and. (numpft == 0)) THEN - write(*,*) 'Warning : There is no plant functional type at this site ! ' - CALL CoLM_stop() - ENDIF - - IF (for_surface_build) THEN - IF (numpft > 0) THEN - write(*,'(4A)') 'PFT type and fraction : ', ' (from ',trim(datasource(u_site_pfts)),')' - DO i = 1, numpft - write(*,'(A,F5.2)') ' '//trim(pftclassname(SITE_pfttyp(i))), SITE_pctpfts(i) - ENDDO - ENDIF - ENDIF - -#endif - - - ! (4) forest height - readflag = (.not. for_surface_build) .or. USE_SITE_htop -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtypes(SITE_landtype) == 0) THEN - u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height_pfts',readflag) - ELSE - u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height',readflag) - ENDIF -#else - u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height',readflag) -#endif - - IF (u_site_htop) THEN -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtypes(SITE_landtype) == 0) THEN - CALL ncio_read_serial (fsrfdata, 'canopy_height_pfts', SITE_htop_pfts) - ELSE - CALL ncio_read_serial (fsrfdata, 'canopy_height', SITE_htop) - ENDIF -#else - CALL ncio_read_serial (fsrfdata, 'canopy_height', SITE_htop) -#endif - ELSE -#ifdef LULC_USGS - CALL gridhtop%define_by_name ('colm_1km') - filename = trim(DEF_dir_rawdata)//'/Forest_Height.nc' - CALL read_point_var_2d_real8 (gridhtop, filename, 'forest_height', & - SITE_lon_location, SITE_lat_location, SITE_htop) -#else - - CALL gridhtop%define_by_name ('colm_500m') - - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - write(cyear,'(i4.4)') DEF_LC_YEAR - CALL read_point_5x5_var_2d_real8 (gridhtop, dir_5x5, 'MOD'//trim(cyear), 'HTOP', & - SITE_lon_location, SITE_lat_location, SITE_htop) - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - allocate (SITE_htop_pfts (numpft)) - SITE_htop_pfts(:) = SITE_htop - ENDIF -#endif -#endif - ENDIF - - IF (for_surface_build) THEN -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtypes(SITE_landtype) == 0) THEN - arraysize = size(SITE_htop_pfts) - write(fmt_str, '("(A,", I0, "F8.2,3A)")') arraysize - write(*,fmt_str) 'Forest height : ', SITE_htop_pfts, ' (from ',trim(datasource(u_site_htop)),')' - ELSE - write(*,'(A,F8.2,3A)') 'Forest height : ', SITE_htop, ' (from ',trim(datasource(u_site_htop)),')' - ENDIF -#else - write(*,'(A,F8.2,3A)') 'Forest height : ', SITE_htop, ' (from ',trim(datasource(u_site_htop)),')' -#endif - ENDIF - - - ! (5) LAI - readflag = ((.not. for_surface_build) .or. USE_SITE_LAI) - readflag = readflag .and. ncio_var_exist(fsrfdata,'LAI_year',readflag) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtypes(SITE_landtype) == 0) THEN - u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_pfts_monthly',readflag) & - .and. ncio_var_exist(fsrfdata,'SAI_pfts_monthly',readflag) - ELSE - u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_monthly',readflag) & - .and. ncio_var_exist(fsrfdata,'SAI_monthly',readflag) - ENDIF -#else - IF (DEF_LAI_MONTHLY) THEN - u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_monthly',readflag) & - .and. ncio_var_exist(fsrfdata,'SAI_monthly',readflag) - ELSE - u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_8day',readflag) - ENDIF -#endif - - IF (u_site_lai) THEN - CALL ncio_read_serial (fsrfdata, 'LAI_year', SITE_LAI_year) - start_year = 1 - end_year = size(SITE_LAI_year) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtypes(SITE_landtype) == 0) THEN - CALL ncio_read_serial (fsrfdata, 'LAI_pfts_monthly', SITE_LAI_pfts_monthly) - CALL ncio_read_serial (fsrfdata, 'SAI_pfts_monthly', SITE_SAI_pfts_monthly) - ntime = size(SITE_LAI_pfts_monthly,2) - ELSE - CALL ncio_read_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly) - CALL ncio_read_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly) - ntime = size(SITE_LAI_monthly,1) - ENDIF -#else - IF (DEF_LAI_MONTHLY) THEN - CALL ncio_read_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly) - CALL ncio_read_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly) - ntime = size(SITE_LAI_monthly,1) - ELSE - CALL ncio_read_serial (fsrfdata, 'LAI_8day', SITE_LAI_8day) - ntime = size(SITE_LAI_8day,1) - ENDIF -#endif - ELSE - - idate(1) = DEF_simulation_time%start_year - IF (.not. isgreenwich) THEN - idate(3) = DEF_simulation_time%start_sec - CALL monthday2julian (idate(1), & - DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2)) - CALL localtime2gmt(idate) - ENDIF - - simulation_lai_year_start = idate(1) - - idate(1) = DEF_simulation_time%end_year - IF (.not. isgreenwich) THEN - idate(3) = DEF_simulation_time%end_sec - CALL monthday2julian (idate(1), & - DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2)) - CALL localtime2gmt(idate) - ENDIF - - simulation_lai_year_end = idate(1) - - IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) - start_year = min(start_year, DEF_LAI_END_YEAR ) - end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) - end_year = max(end_year, DEF_LAI_START_YEAR ) - ELSE - start_year = DEF_LC_YEAR - end_year = DEF_LC_YEAR - ENDIF - - allocate (SITE_LAI_year (start_year:end_year)) - SITE_LAI_year = (/(iyear, iyear = start_year, end_year)/) - - IF (DEF_LAI_MONTHLY) THEN - ntime = 12 - allocate (SITE_LAI_monthly (12,start_year:end_year)) - allocate (SITE_SAI_monthly (12,start_year:end_year)) - ELSE - ntime = 46 - allocate (SITE_LAI_8day (46,start_year:end_year)) - ENDIF - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - allocate (SITE_LAI_pfts_monthly (numpft,12,start_year:end_year)) - allocate (SITE_SAI_pfts_monthly (numpft,12,start_year:end_year)) - ENDIF -#endif - - CALL gridlai%define_by_name ('colm_500m') - - DO iyear = start_year, end_year - - write(cyear,'(i4.4)') iyear - - DO itime = 1, ntime -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - CALL read_point_5x5_var_3d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'MONTHLY_PFT_LAI', & - SITE_lon_location, SITE_lat_location, N_PFT_modis, itime, pftLAI) - CALL read_point_5x5_var_3d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'MONTHLY_PFT_SAI', & - SITE_lon_location, SITE_lat_location, N_PFT_modis, itime, pftSAI) - -#ifndef CROP - IF (patchtypes(SITE_landtype) == 0) THEN -#else - IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN -#endif - IF (allocated(pctpfts)) deallocate (pctpfts) - allocate(pctpfts (0:N_PFT_modis-1)); pctpfts(:) = 0. - pctpfts(SITE_pfttyp) = SITE_pctpfts - - SITE_LAI_pfts_monthly(:,itime,iyear) = pack(pftLAI, pctpfts > 0.) - SITE_SAI_pfts_monthly(:,itime,iyear) = pack(pftSAI, pctpfts > 0.) -#ifdef CROP - ELSEIF (SITE_landtype == CROPLAND) THEN - CALL read_point_5x5_var_3d_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'PCT_PFT', & - SITE_lon_location, SITE_lat_location, N_PFT_modis, pctpfts) - SITE_LAI_pfts_monthly(:,itime,iyear) = sum(pftLAI * pctpfts) / sum(pctpfts) - SITE_SAI_pfts_monthly(:,itime,iyear) = sum(pftSAI * pctpfts) / sum(pctpfts) -#endif - ELSE - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & - 'MONTHLY_LC_LAI', SITE_lon_location, SITE_lat_location, itime, & - SITE_LAI_monthly(itime,iyear)) - CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & - 'MONTHLY_LC_SAI', SITE_lon_location, SITE_lat_location, itime, & - SITE_SAI_monthly(itime,iyear)) - ENDIF - -#else - IF (DEF_LAI_MONTHLY) THEN - dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' - CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & - 'MONTHLY_LC_LAI', SITE_lon_location, SITE_lat_location, itime, & - SITE_LAI_monthly(itime,iyear)) - CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), & - 'MONTHLY_LC_SAI', SITE_lon_location, SITE_lat_location, itime, & - SITE_SAI_monthly(itime,iyear)) - ELSE - filename = trim(DEF_dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc' - CALL read_point_var_2d_time_real8 (gridlai, filename, 'lai', & - SITE_lon_location, SITE_lat_location, itime, LAI) - SITE_LAI_8day(itime,iyear) = LAI * 0.1 - ENDIF -#endif - ENDDO - ENDDO - ENDIF - - IF (for_surface_build) THEN - DO iyear = start_year, end_year - write(c,'(i2)') ntime -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtypes(SITE_landtype) == 0) THEN - DO i = 1, numpft - write(*,'(A,I4,A,I2,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), & - ', pft ', SITE_pfttyp(i),') : ', SITE_LAI_pfts_monthly(i,:,iyear), & - ' (from ',trim(datasource(u_site_lai)),')' - write(*,'(A,I4,A,I2,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), & - ', pft ', SITE_pfttyp(i),') : ', SITE_SAI_pfts_monthly(i,:,iyear), & - ' (from ',trim(datasource(u_site_lai)),')' - ENDDO - ELSE - write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', & - SITE_LAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' - write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), ') : ', & - SITE_SAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' - ENDIF -#else - IF (DEF_LAI_MONTHLY) THEN - write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', & - SITE_LAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' - write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), ') : ', & - SITE_SAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' - ELSE - write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', & - SITE_LAI_8day(:,iyear), ' (from ',trim(datasource(u_site_lai)),')' - ENDIF -#endif - ENDDO - ENDIF - - - ! (6) lake depth - readflag = ((.not. for_surface_build) .or. USE_SITE_lakedepth) - u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag) - - IF (u_site_lakedepth) THEN - CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth) - ELSE - CALL gridlake%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/lake_depth.nc' - CALL read_point_var_2d_real8 (gridlake, filename, 'lake_depth', & - SITE_lon_location, SITE_lat_location, lakedepth) - SITE_lakedepth = lakedepth * 0.1 - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',trim(datasource(u_site_lakedepth)),')' - ENDIF - - - ! (7) soil brightness parameters - readflag = ((.not. for_surface_build) .or. USE_SITE_soilreflectance) - u_site_soil_bright = readflag & - .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) & - .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) & - .and. ncio_var_exist(fsrfdata,'soil_s_n_alb',readflag) & - .and. ncio_var_exist(fsrfdata,'soil_d_n_alb',readflag) - - IF (u_site_soil_bright) THEN - CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) - CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) - CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) - CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) - ELSE - SITE_soil_s_v_alb = spval - SITE_soil_d_v_alb = spval - SITE_soil_s_n_alb = spval - SITE_soil_d_n_alb = spval - - CALL gridbright%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/soil_brightness.nc' - CALL read_point_var_2d_int32 (gridbright, filename, 'soil_brightness', & - SITE_lon_location, SITE_lat_location, isc) - -#ifdef LULC_USGS - IF(SITE_landtype /= 16 .and. SITE_landtype /= 24)THEN ! NOT WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(SITE_landtype /= 17 .and. SITE_landtype /= 15)THEN ! NOT WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - IF ((isc >= 1) .and. (isc <= 20)) THEN - SITE_soil_s_v_alb = soil_s_v_refl( isc ) - SITE_soil_d_v_alb = soil_d_v_refl( isc ) - SITE_soil_s_n_alb = soil_s_n_refl( isc ) - SITE_soil_d_n_alb = soil_d_n_refl( isc ) - ENDIF - ENDIF - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - write(*,'(A,F8.2,3A)') 'Soil brightness d_n : ', SITE_soil_d_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - ENDIF - - - ! (8) soil parameters - - CALL gridsoil%define_by_name ('colm_500m') - - readflag = ((.not. for_surface_build) .or. USE_SITE_soilparameters) - u_site_vf_quartz_mineral = readflag & - .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag) - IF (u_site_vf_quartz_mineral) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) - ELSE - allocate (SITE_soil_vf_quartz_mineral (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_quartz_mineral_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_quartz_mineral(nsl)) - ENDDO - ENDIF - - u_site_vf_gravels = readflag & - .and. ncio_var_exist(fsrfdata,'soil_vf_gravels',readflag) - IF (u_site_vf_gravels) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels) - ELSE - allocate (SITE_soil_vf_gravels (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_gravels_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_gravels_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_gravels(nsl)) - ENDDO - ENDIF - - u_site_vf_sand = readflag & - .and. ncio_var_exist(fsrfdata,'soil_vf_sand',readflag) - IF (u_site_vf_sand) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand) - ELSE - allocate (SITE_soil_vf_sand (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_sand_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_sand_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_sand(nsl)) - ENDDO - ENDIF - - u_site_vf_clay = readflag & - .and. ncio_var_exist(fsrfdata,'soil_vf_clay',readflag) - IF (u_site_vf_clay) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay) - ELSE - allocate (SITE_soil_vf_clay (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_clay_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_clay_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_clay(nsl)) - ENDDO - ENDIF - - u_site_vf_om = readflag & - .and. ncio_var_exist(fsrfdata,'soil_vf_om',readflag) - IF (u_site_vf_om) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om) - ELSE - allocate (SITE_soil_vf_om (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_om_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_om_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_om(nsl)) - ENDDO - ENDIF - - u_site_wf_gravels = readflag & - .and. ncio_var_exist(fsrfdata,'soil_wf_gravels',readflag) - IF (u_site_wf_gravels) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels) - ELSE - allocate (SITE_soil_wf_gravels (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_gravels_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_gravels_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_gravels(nsl)) - ENDDO - ENDIF - - u_site_wf_sand = readflag & - .and. ncio_var_exist(fsrfdata,'soil_wf_sand',readflag) - IF (u_site_wf_sand) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand) - ELSE - allocate (SITE_soil_wf_sand (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_sand_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_sand_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_sand(nsl)) - ENDDO - ENDIF - - u_site_wf_clay = readflag & - .and. ncio_var_exist(fsrfdata,'soil_wf_clay',readflag) - IF (u_site_wf_clay) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay) - ELSE - allocate (SITE_soil_wf_clay (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_clay_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_clay_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_clay(nsl)) - ENDDO - ENDIF - - u_site_wf_om = readflag & - .and. ncio_var_exist(fsrfdata,'soil_wf_om',readflag) - IF (u_site_wf_om) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om) - ELSE - allocate (SITE_soil_wf_om (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_om_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_om_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_om(nsl)) - ENDDO - ENDIF - - u_site_OM_density = readflag & - .and. ncio_var_exist(fsrfdata,'soil_OM_density',readflag) - IF (u_site_OM_density) THEN - CALL ncio_read_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density) - ELSE - allocate (SITE_soil_OM_density (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/OM_density_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'OM_density_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_OM_density(nsl)) - ENDDO - ENDIF - - u_site_BD_all = readflag & - .and. ncio_var_exist(fsrfdata,'soil_BD_all',readflag) - IF (u_site_BD_all) THEN - CALL ncio_read_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all) - ELSE - allocate (SITE_soil_BD_all (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/BD_all_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'BD_all_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_BD_all(nsl)) - ENDDO - ENDIF - - u_site_theta_s = readflag & - .and. ncio_var_exist(fsrfdata,'soil_theta_s',readflag) - IF (u_site_theta_s) THEN - CALL ncio_read_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s) - ELSE - allocate (SITE_soil_theta_s (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/theta_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'theta_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_theta_s(nsl)) - ENDDO - ENDIF - - u_site_k_s = readflag & - .and. ncio_var_exist(fsrfdata,'soil_k_s',readflag) - IF (u_site_k_s) THEN - CALL ncio_read_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s) - ELSE - allocate (SITE_soil_k_s (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/k_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'k_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_k_s(nsl)) - ENDDO - ENDIF - - u_site_csol = readflag & - .and. ncio_var_exist(fsrfdata,'soil_csol',readflag) - IF (u_site_csol) THEN - CALL ncio_read_serial (fsrfdata, 'soil_csol', SITE_soil_csol) - ELSE - allocate (SITE_soil_csol (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/csol.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'csol_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_csol(nsl)) - ENDDO - ENDIF - - u_site_tksatu = readflag & - .and. ncio_var_exist(fsrfdata,'soil_tksatu',readflag) - IF (u_site_tksatu) THEN - CALL ncio_read_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu) - ELSE - allocate (SITE_soil_tksatu (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/tksatu.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatu_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_tksatu(nsl)) - ENDDO - ENDIF - - u_site_tksatf = readflag & - .and. ncio_var_exist(fsrfdata,'soil_tksatf',readflag) - IF (u_site_tksatf) THEN - CALL ncio_read_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf) - ELSE - allocate (SITE_soil_tksatf (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/tksatf.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatf_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_tksatf(nsl)) - ENDDO - ENDIF - - u_site_tkdry = readflag & - .and. ncio_var_exist(fsrfdata,'soil_tkdry',readflag) - IF (u_site_tkdry) THEN - CALL ncio_read_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry) - ELSE - allocate (SITE_soil_tkdry (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/tkdry.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'tkdry_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_tkdry(nsl)) - ENDDO - ENDIF - - u_site_k_solids = readflag & - .and. ncio_var_exist(fsrfdata,'soil_k_solids',readflag) - IF (u_site_k_solids) THEN - CALL ncio_read_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids) - ELSE - allocate (SITE_soil_k_solids (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/k_solids.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'k_solids_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_k_solids(nsl)) - ENDDO - ENDIF - - u_site_psi_s = readflag & - .and. ncio_var_exist(fsrfdata,'soil_psi_s',readflag) - IF (u_site_psi_s) THEN - CALL ncio_read_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s) - ELSE - allocate (SITE_soil_psi_s (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/psi_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'psi_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_psi_s(nsl)) - ENDDO - ENDIF - - u_site_lambda = readflag & - .and. ncio_var_exist(fsrfdata,'soil_lambda',readflag) - IF (u_site_lambda) THEN - CALL ncio_read_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda) - ELSE - allocate (SITE_soil_lambda (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/lambda.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'lambda_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_lambda(nsl)) - ENDDO - ENDIF - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - u_site_theta_r = readflag & - .and. ncio_var_exist(fsrfdata,'soil_theta_r',readflag) - IF (u_site_theta_r) THEN - CALL ncio_read_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r) - ELSE - allocate (SITE_soil_theta_r (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_theta_r.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_theta_r_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_theta_r(nsl)) - ENDDO - ENDIF - - u_site_alpha_vgm = readflag & - .and. ncio_var_exist(fsrfdata,'soil_alpha_vgm',readflag) - IF (u_site_alpha_vgm) THEN - CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm) - ELSE - allocate (SITE_soil_alpha_vgm (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_alpha.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_alpha_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_alpha_vgm(nsl)) - ENDDO - ENDIF - - u_site_L_vgm = readflag & - .and. ncio_var_exist(fsrfdata,'soil_L_vgm',readflag) - IF (u_site_L_vgm) THEN - CALL ncio_read_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm) - ELSE - allocate (SITE_soil_L_vgm (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_L.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_L_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_L_vgm(nsl)) - ENDDO - ENDIF - - u_site_n_vgm = readflag & - .and. ncio_var_exist(fsrfdata,'soil_n_vgm',readflag) - IF (u_site_n_vgm) THEN - CALL ncio_read_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm) - ELSE - allocate (SITE_soil_n_vgm (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_n.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_n_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_n_vgm(nsl)) - ENDDO - ENDIF -#endif - - u_site_BA_alpha = u_site_vf_gravels .and. u_site_vf_sand - u_site_BA_beta = u_site_vf_gravels .and. u_site_vf_sand - allocate (SITE_soil_BA_alpha (8)) - allocate (SITE_soil_BA_beta (8)) - DO nsl = 1, 8 - IF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.4) THEN - SITE_soil_BA_alpha(nsl) = 0.38 - SITE_soil_BA_beta (nsl) = 35.0 - ELSEIF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.25) THEN - SITE_soil_BA_alpha(nsl) = 0.24 - SITE_soil_BA_beta (nsl) = 26.0 - ELSE - SITE_soil_BA_alpha(nsl) = 0.20 - SITE_soil_BA_beta (nsl) = 10.0 - ENDIF - ENDDO - - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - u_site_soil_texture = readflag & - .and. ncio_var_exist(fsrfdata,'soil_texture',readflag) - IF (u_site_soil_texture) THEN - CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture) - ELSE - filename = trim(DEF_dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc' - CALL read_point_var_2d_int32 (gridsoil, filename, 'soiltexture', & - SITE_lon_location, SITE_lat_location, SITE_soil_texture) - ENDIF - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_clay : ', SITE_soil_vf_clay (1:8), ' (from ',trim(datasource(u_site_vf_clay )),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_om : ', SITE_soil_vf_om (1:8), ' (from ',trim(datasource(u_site_vf_om )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_gravels : ', SITE_soil_wf_gravels (1:8), ' (from ',trim(datasource(u_site_wf_gravels )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_sand : ', SITE_soil_wf_sand (1:8), ' (from ',trim(datasource(u_site_wf_sand )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_clay : ', SITE_soil_wf_clay (1:8), ' (from ',trim(datasource(u_site_wf_clay )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_om : ', SITE_soil_wf_om (1:8), ' (from ',trim(datasource(u_site_wf_om )),')' - write(*,'(A,8ES10.2,3A)') 'soil_OM_density : ', SITE_soil_OM_density (1:8), ' (from ',trim(datasource(u_site_OM_density )),')' - write(*,'(A,8ES10.2,3A)') 'soil_BD_all : ', SITE_soil_BD_all (1:8), ' (from ',trim(datasource(u_site_BD_all )),')' - write(*,'(A,8ES10.2,3A)') 'soil_theta_s : ', SITE_soil_theta_s (1:8), ' (from ',trim(datasource(u_site_theta_s )),')' - write(*,'(A,8ES10.2,3A)') 'soil_k_s : ', SITE_soil_k_s (1:8), ' (from ',trim(datasource(u_site_k_s )),')' - write(*,'(A,8ES10.2,3A)') 'soil_csol : ', SITE_soil_csol (1:8), ' (from ',trim(datasource(u_site_csol )),')' - write(*,'(A,8ES10.2,3A)') 'soil_tksatu : ', SITE_soil_tksatu (1:8), ' (from ',trim(datasource(u_site_tksatu )),')' - write(*,'(A,8ES10.2,3A)') 'soil_tksatf : ', SITE_soil_tksatf (1:8), ' (from ',trim(datasource(u_site_tksatf )),')' - write(*,'(A,8ES10.2,3A)') 'soil_tkdry : ', SITE_soil_tkdry (1:8), ' (from ',trim(datasource(u_site_tkdry )),')' - write(*,'(A,8ES10.2,3A)') 'soil_k_solids : ', SITE_soil_k_solids (1:8), ' (from ',trim(datasource(u_site_k_solids )),')' - write(*,'(A,8ES10.2,3A)') 'soil_psi_s : ', SITE_soil_psi_s (1:8), ' (from ',trim(datasource(u_site_psi_s )),')' - write(*,'(A,8ES10.2,3A)') 'soil_lambda : ', SITE_soil_lambda (1:8), ' (from ',trim(datasource(u_site_lambda )),')' -#ifdef vanGenuchten_Mualem_SOIL_MODEL - write(*,'(A,8ES10.2,3A)') 'soil_theta_r : ', SITE_soil_theta_r (1:8), ' (from ',trim(datasource(u_site_theta_r )),')' - write(*,'(A,8ES10.2,3A)') 'soil_alpha_vgm : ', SITE_soil_alpha_vgm (1:8), ' (from ',trim(datasource(u_site_alpha_vgm )),')' - write(*,'(A,8ES10.2,3A)') 'soil_L_vgm : ', SITE_soil_L_vgm (1:8), ' (from ',trim(datasource(u_site_L_vgm )),')' - write(*,'(A,8ES10.2,3A)') 'soil_n_vgm : ', SITE_soil_n_vgm (1:8), ' (from ',trim(datasource(u_site_n_vgm )),')' -#endif - write(*,'(A,8ES10.2,3A)') 'soil_BA_alpha : ', SITE_soil_BA_alpha (1:8), ' (from ',trim(datasource(u_site_BA_alpha )),')' - write(*,'(A,8ES10.2,3A)') 'soil_BA_beta : ', SITE_soil_BA_beta (1:8), ' (from ',trim(datasource(u_site_BA_beta )),')' - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - write(*,'(A,I3,3A)') 'soil texture : ', SITE_soil_texture, ' (from ',trim(datasource(u_site_soil_texture)),')' - ENDIF - ENDIF - - - ! (9) depth to bedrock - IF (DEF_USE_BEDROCK) THEN - readflag = ((.not. for_surface_build) .or. USE_SITE_dbedrock) - u_site_dbedrock = readflag & - .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag) - IF (u_site_dbedrock) THEN - CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) - ELSE - CALL gridrock%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/bedrock.nc' - CALL read_point_var_2d_real8 (gridrock, filename, 'dbedrock', & - SITE_lon_location, SITE_lat_location, SITE_dbedrock) - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',trim(datasource(u_site_dbedrock)),')' - ENDIF - - ENDIF - - ! (10) topography - readflag = ((.not. for_surface_build) .or. USE_SITE_topography) - - u_site_elevation = readflag & - .and. ncio_var_exist (fsrfdata, 'elevation',readflag) - IF (u_site_elevation) THEN - CALL ncio_read_serial (fsrfdata, 'elevation', SITE_elevation) - ELSE - CALL gridtopo%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/topography.nc' - CALL read_point_var_2d_real8 (gridtopo, filename, 'elevation', & - SITE_lon_location, SITE_lat_location, SITE_elevation) - ENDIF - - u_site_elvstd = readflag & - .and. ncio_var_exist (fsrfdata, 'elvstd',readflag) - IF (u_site_elvstd) THEN - CALL ncio_read_serial (fsrfdata, 'elvstd', SITE_elvstd) - ELSE - CALL gridtopo%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/topography.nc' - CALL read_point_var_2d_real8 (gridtopo, filename, 'elvstd', & - SITE_lon_location, SITE_lat_location, SITE_elvstd) - ENDIF - - u_site_sloperatio = readflag & - .and. ncio_var_exist (fsrfdata, 'sloperatio',readflag) - IF (u_site_sloperatio) THEN - CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio) - ELSE - CALL gridtopo%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/topography.nc' - CALL read_point_var_2d_real8 (gridtopo, filename, 'slope', & - SITE_lon_location, SITE_lat_location, SITE_sloperatio) - ENDIF - - IF (DEF_USE_Forcing_Downscaling) THEN - - filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" - IF (ncio_var_exist(filename,'lat') .and. ncio_var_exist(filename,'lon')) THEN - CALL grid_topo_factor%define_from_file (filename, "lat", "lon") - ENDIF - - u_site_svf = readflag & - .and. ncio_var_exist (fsrfdata, 'SITE_svf',readflag) - IF (u_site_svf) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/sky_view_factor.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'svf', & - SITE_lon_location, SITE_lat_location, SITE_svf) - ENDIF - - u_site_cur = readflag & - .and. ncio_var_exist (fsrfdata, 'SITE_cur',readflag) - IF (u_site_cur) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/curvature.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'curvature', & - SITE_lon_location, SITE_lat_location, SITE_cur) - ENDIF - - u_site_slp_type = readflag & - .and. ncio_var_exist (fsrfdata, 'SITE_slp_type', readflag) & - .and. ncio_var_exist (fsrfdata, 'SITE_asp_type', readflag) & - .and. ncio_var_exist (fsrfdata, 'SITE_area_type',readflag) - u_site_asp_type = u_site_slp_type - u_site_area_type = u_site_slp_type - - IF (u_site_slp_type) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type ) - CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type ) - CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type ) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'slope', & - SITE_lon_location, SITE_lat_location, slp) - - filename = trim(DEF_DS_HiresTopographyDataDir)//"/aspect.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'aspect', & - SITE_lon_location, SITE_lat_location, asp) - - allocate (SITE_slp_type (num_slope_type)); SITE_slp_type (:) = 0. - allocate (SITE_asp_type (num_slope_type)); SITE_asp_type (:) = 0. - allocate (SITE_area_type (num_slope_type)); SITE_area_type(:) = 0. - - IF ((asp.ge.0 .and. asp.le.90*pi/180) .or. (asp.ge.270*pi/180 .and. asp.le.360*pi/180)) THEN - IF ((slp.ge.15*pi/180)) THEN ! north abrupt slope - typ = 1 - ELSE ! north gentle slope - typ = 2 - ENDIF - ELSE - IF ((slp.ge.15*pi/180)) THEN ! south abrupt slope - typ = 3 - ELSE ! south gentle slope - typ = 4 - ENDIF - ENDIF - - SITE_slp_type (typ) = slp - SITE_asp_type (typ) = asp - SITE_area_type(typ) = 1. - - ENDIF - - u_site_sf_lut = readflag & - .and. ncio_var_exist (fsrfdata, 'SITE_sf_lut',readflag) - IF (u_site_sf_lut) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_front.nc" - CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_front', & - SITE_lon_location, SITE_lat_location, num_azimuth, tea_f) - - filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_back.nc" - CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_back', & - SITE_lon_location, SITE_lat_location, num_azimuth, tea_b) - - allocate (SITE_sf_lut (num_azimuth, num_zenith)) - - DO a = 1, num_azimuth - - tea_f(a) = asin(max(min(tea_f(a),1.),-1.)) - tea_b(a) = asin(max(min(tea_b(a),1.),-1.)) - - IF (tea_f(a) <= tea_b(a)) tea_f(a) = tea_b(a) + 0.001 - - DO z = 1, num_zenith - zenith_angle = pi/(2*num_zenith)*(z-1) - - IF (pi*0.5 - zenith_angle < tea_b(a)) THEN - SITE_sf_lut(a,z) = 0 - ELSE IF (pi*0.5 - zenith_angle > tea_f(a)) THEN - SITE_sf_lut(a,z) = 1 - ELSE - SITE_sf_lut(a,z) = (0.5*pi - zenith_angle - tea_b(a))/(tea_f(a) - tea_b(a)) - ENDIF - - ENDDO - ENDDO - - ENDIF - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation , ' (from ',trim(datasource(u_site_elevation)),')' - write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd , ' (from ',trim(datasource(u_site_elvstd)),')' - write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio, ' (from ',trim(datasource(u_site_sloperatio)),')' - - IF (DEF_USE_Forcing_Downscaling) THEN - write(*,'(A,F8.2,3A)') 'Sky view factor : ', SITE_svf, ' (from ',trim(datasource(u_site_svf)),')' - write(*,'(A,F8.2,3A)') 'Curvature : ', SITE_cur, ' (from ',trim(datasource(u_site_cur)),')' - write(c,'(I0)') num_slope_type - write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type : ', SITE_slp_type, ' (from ',trim(datasource(u_site_slp_type)),')' - write(*,'(A,'//trim(c)//'F8.2,3A)') 'Aspect type : ', SITE_asp_type, ' (from ',trim(datasource(u_site_slp_type)),')' - write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type area : ', SITE_area_type, ' (from ',trim(datasource(u_site_slp_type)),')' - write(c,'(I0)') num_azimuth*num_zenith - write(*,'(A,A,I3,A,I3,A,'//trim(c)//'F8.2,3A)') 'Shadow lookup table : ', & - '(', num_azimuth, ' in azimuth,', num_zenith, ' in zenith)', & - SITE_sf_lut , ' (from ',trim(datasource(u_site_sf_lut)),')' - ENDIF - ENDIF - - - IF (.not. for_surface_build) THEN - - landpatch%nset = numpatch - - allocate (landpatch%settyp (numpatch)); landpatch%settyp = SITE_landtype - - landpatch%nblkgrp = 1 - allocate (landpatch%xblkgrp(1)); landpatch%xblkgrp(1) = 1 - allocate (landpatch%yblkgrp(1)); landpatch%yblkgrp(1) = 1 - - allocate (landpatch%vecgs%vlen(1,1)); landpatch%vecgs%vlen(1,1) = numpatch - allocate (landpatch%vecgs%vstt(1,1)); landpatch%vecgs%vstt(1,1) = 1 - allocate (landpatch%vecgs%vend(1,1)); landpatch%vecgs%vend(1,1) = numpatch - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - - IF (numpft > 0) THEN - - landpft%nset = numpft - - allocate (landpft%settyp (numpft)); landpft%settyp = SITE_pfttyp - - landpft%nblkgrp = 1 - allocate (landpft%xblkgrp(1)); landpft%xblkgrp(1) = 1 - allocate (landpft%yblkgrp(1)); landpft%yblkgrp(1) = 1 - - allocate (landpft%vecgs%vlen(1,1)); landpft%vecgs%vlen(1,1) = numpft - allocate (landpft%vecgs%vstt(1,1)); landpft%vecgs%vstt(1,1) = 1 - allocate (landpft%vecgs%vend(1,1)); landpft%vecgs%vend(1,1) = numpft - - allocate (patch_pft_s (numpatch)) - allocate (patch_pft_e (numpatch)) - allocate (pft2patch (numpft )) -#ifdef CROP - IF (SITE_landtype == CROPLAND) THEN - patch_pft_s = (/(i, i = 1, numpatch)/) - patch_pft_e = (/(i, i = 1, numpatch)/) - pft2patch = (/(i, i = 1, numpatch)/) - ELSE - patch_pft_s = 1 - patch_pft_e = numpft - pft2patch = 1 - ENDIF -#else - patch_pft_s = 1 - patch_pft_e = numpft - pft2patch = 1 -#endif - ENDIF -#endif - - numelm = 1 - allocate (landelm%settyp (1)); landelm%settyp (1) = 0 - allocate (elm_patch%substt (1)); elm_patch%substt(1) = 1 - allocate (elm_patch%subend (1)); elm_patch%subend(1) = numpatch - - allocate (elm_patch%subfrc (numpatch)); elm_patch%subfrc = 1./numpatch -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) -#ifdef CROP - elm_patch%subfrc = SITE_pctcrop -#endif -#endif - - ENDIF - - END SUBROUTINE read_surface_data_single - -!----------------------------------------------------------------------- - SUBROUTINE read_urban_surface_data_single (fsrfdata, for_surface_build, mkrun) - - USE MOD_TimeManager - USE MOD_Grid - USE MOD_Block - USE MOD_NetCDFSerial - USE MOD_NetCDFPoint - USE MOD_Namelist - USE MOD_Utils - USE MOD_SPMD_Task - USE MOD_LandPatch - USE MOD_LandUrban - USE MOD_Urban_Const_LCZ - USE MOD_Vars_Global, only: PI, URBAN - USE MOD_Mesh, only: numelm - USE MOD_LandElm - IMPLICIT NONE - - character(len=*), intent(in) :: fsrfdata - logical, intent(in) :: for_surface_build - logical, intent(in), optional :: mkrun - - ! Local Variables - real(r8), allocatable, dimension(:,:) :: hwrbld_ncar , fgper_ncar , htroof_ncar , wtroof_ncar - real(r8), allocatable, dimension(:,:) :: emroof_ncar , emwall_ncar , emgimp_ncar , emgper_ncar - real(r8), allocatable, dimension(:,:) :: thkroof_ncar, thkwall_ncar, tbldmin_ncar, tbldmax_ncar - real(r8), allocatable, dimension(:,:,:) :: cvroof_ncar , cvwall_ncar , cvgimp_ncar , & - tkroof_ncar , tkwall_ncar , tkgimp_ncar - real(r8), allocatable, dimension(:,:,:,:) :: albroof_ncar, albwall_ncar, albgimp_ncar, albgper_ncar - - real(r8) :: lat_in, lon_in - real(r8) :: LAI, lakedepth, slp, asp, zenith_angle - integer :: i, isc, nsl, typ, a, z, rid, utyp - integer :: iyear, idate(3), simulation_lai_year_start, simulation_lai_year_end - integer :: start_year, end_year, ntime, itime, pop_i - logical :: readflag - - character(len=256) :: filename, dir_5x5 - character(len=4) :: cyear, c, c5year - - type(grid_type) :: gridupatch, gridhroof, gridfroof , gridhtopu, gridfvegu, gridflakeu, gridlaiu, & - gridpopu , gridlucy , gridbright, gridsoil , gridrock , gridtopo , gridlake, & - grid_topo_factor - - real(r8), allocatable :: tea_f(:), tea_b(:) - - u_site_froof = .false.; u_site_hroof = .false.; u_site_fgper = .false.; u_site_hlr = .false.; - u_site_fveg = .false.; u_site_htopu = .false.; u_site_urblai = .false.; u_site_urbsai = .false.; - u_site_flake = .false.; - - u_site_albr = .false.; u_site_albw = .false.; u_site_albgimp = .false.; u_site_albgper = .false.; - u_site_emr = .false.; u_site_emw = .false.; u_site_emgimp = .false.; u_site_emgper = .false.; - - u_site_cvr = .false.; u_site_cvw = .false.; u_site_cvgimp = .false.; - u_site_tkr = .false.; u_site_tkw = .false.; u_site_tkgimp = .false.; - - u_site_tbmax = .false.; u_site_tbmin = .false.; u_site_thickr = .false.; u_site_thickw = .false.; - u_site_pop = .false.; u_site_lucy = .false.; - - IF (for_surface_build) THEN - write(*,*) - write(*,*) ' ---------------- Make Single Point Surface Data ---------------- ' - ENDIF - - IF (ncio_var_exist(fsrfdata, 'latitude')) THEN - CALL ncio_read_serial (fsrfdata, 'latitude', lat_in) - IF (lat_in /= SITE_lat_location) THEN - write(*,*) 'Warning: Latitude mismatch: ', & - lat_in, ' in data file and ', SITE_lat_location, 'in namelist.' - ENDIF - SITE_lat_location = lat_in - ENDIF - - IF (ncio_var_exist(fsrfdata, 'longitude')) THEN - CALL ncio_read_serial (fsrfdata, 'longitude', lon_in) - IF (lon_in /= SITE_lon_location) THEN - write(*,*) 'Warning: Longitude mismatch: ', & - lon_in, ' in data file and ', SITE_lon_location, 'in namelist.' - ENDIF - SITE_lon_location = lon_in - ENDIF - - CALL normalize_longitude (SITE_lon_location) - - IF (.not. isgreenwich) THEN - LocalLongitude = SITE_lon_location - ENDIF - - IF (for_surface_build) THEN - write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location - write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location - ENDIF - - DEF_domain%edges = floor(SITE_lat_location) - DEF_domain%edgen = floor(SITE_lat_location) + 1. - DEF_domain%edgew = floor(SITE_lon_location) - DEF_domain%edgee = floor(SITE_lon_location) + 1. - - CALL gblock%set () - gblock%nblkme = 1 - allocate(gblock%xblkme(1)) - allocate(gblock%yblkme(1)) - gblock%xblkme(1) = find_nearest_west (SITE_lon_location, gblock%nxblk, gblock%lon_w) - gblock%yblkme(1) = find_nearest_south (SITE_lat_location, gblock%nyblk, gblock%lat_s) - - ! (1) build/read "land patch" by using land cover type data - IF (trim(fsrfdata) /= 'null') THEN - SITE_landtype = URBAN - ELSEIF (SITE_landtype /= URBAN) THEN - write(*,*) 'Error! Please set SITE_landtype to URBAN in namelist file !' - CALL CoLM_stop() - ENDIF - - numpatch = 1 - numurban = 1 - u_site_landtype = (SITE_landtype >= 0) - IF (for_surface_build) THEN - write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), & - ' (from ',trim(datasource(u_site_landtype)),')' - ENDIF - - IF (for_surface_build) THEN - ! (2) build/read "urban type" by using land cover type data -IF (DEF_URBAN_type_scheme == 1) THEN - u_site_utype = ncio_var_exist(fsrfdata,'URBAN_DENSITY_CLASS') - - IF ( u_site_utype ) THEN - CALL ncio_read_serial (fsrfdata, 'URBTYP' , SITE_ncar_rid) - CALL ncio_read_serial (fsrfdata, 'URBAN_DENSITY_CLASS', SITE_urbtyp ) - ELSE - CALL gridupatch%define_by_name ('colm_500m') - - dir_5x5 = trim(DEF_dir_rawdata) // '/urban_type/' - CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'REGION_ID', & - SITE_lon_location, SITE_lat_location, SITE_ncar_rid) - - CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'URBAN_DENSITY_CLASS', & - SITE_lon_location, SITE_lat_location, SITE_urbtyp) - - write(*,'(A,I0,A,I0,3A)') 'Urban type : NCAR ', SITE_urbtyp, ' of Region ', SITE_ncar_rid, & - ' (from ',trim(datasource(u_site_utype)),')' - ENDIF -ELSE - u_site_utype = ncio_var_exist(fsrfdata,'LCZ_DOM') - IF ( u_site_utype ) THEN - CALL ncio_read_serial (fsrfdata, 'LCZ_DOM', SITE_urbtyp ) - ELSE - CALL gridupatch%define_by_name ('colm_500m') - - dir_5x5 = trim(DEF_dir_rawdata) // '/urban_type/' - CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'LCZ_DOM', & - SITE_lon_location, SITE_lat_location, SITE_urbtyp) - ENDIF - write(*,'(A,I0,3A)') 'Urban type : LCZ ', SITE_urbtyp, & - ' (from ',trim(datasource(u_site_utype)),')' -ENDIF - - - ! (4) urban geometry - readflag = USE_SITE_urban_geometry - u_site_hroof = ncio_var_exist(fsrfdata,'building_mean_height',readflag) - IF ( u_site_hroof ) THEN - CALL ncio_read_serial (fsrfdata, 'building_mean_height', SITE_hroof ) - ELSE - CALL gridhroof%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' - write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 - -IF (DEF_Urban_geom_data == 1) THEN - CALL read_point_5x5_var_2d_real8 (gridhroof, dir_5x5, 'URBSRF'//trim(c5year), 'HT_ROOF_GHSL', & - SITE_lon_location, SITE_lat_location, SITE_hroof) -ELSE - CALL read_point_5x5_var_2d_real8 (gridhroof, dir_5x5, 'URBSRF'//trim(c5year), 'HT_ROOF_Li', & - SITE_lon_location, SITE_lat_location, SITE_hroof) -ENDIF - ENDIF - - u_site_froof = readflag .and. ncio_var_exist(fsrfdata,'roof_area_fraction',readflag) - IF ( u_site_froof ) THEN - CALL ncio_read_serial (fsrfdata, 'roof_area_fraction', SITE_froof ) - ELSE - CALL gridfroof%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' - write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 -IF (DEF_Urban_geom_data == 1) THEN - CALL read_point_5x5_var_2d_real8 (gridfroof, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_ROOF_GHSL', & - SITE_lon_location, SITE_lat_location, SITE_froof) -ELSE - CALL read_point_5x5_var_2d_real8 (gridfroof, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_ROOF_Li', & - SITE_lon_location, SITE_lat_location, SITE_froof) -ENDIF - ENDIF - - u_site_fgper = readflag .and. ncio_var_exist(fsrfdata,'impervious_area_fraction',readflag) - IF ( u_site_fgper ) THEN - CALL ncio_read_serial (fsrfdata, 'impervious_area_fraction', SITE_fgimp ) - ENDIF - - u_site_thickr = readflag .and. ncio_var_exist(fsrfdata,'THICK_ROOF',readflag) - IF ( u_site_thickr ) THEN - CALL ncio_read_serial (fsrfdata, 'THICK_ROOF', SITE_thickroof ) - ENDIF - - u_site_thickw = readflag .and. ncio_var_exist(fsrfdata,'THICK_WALL',readflag) - IF ( u_site_thickw ) THEN - CALL ncio_read_serial (fsrfdata, 'THICK_WALL', SITE_thickwall ) - ENDIF - -IF (DEF_USE_CANYON_HWR) THEN - u_site_hlr = readflag .and. ncio_var_exist(fsrfdata,'canyon_height_width_ratio',readflag) - IF ( u_site_hlr ) THEN - CALL ncio_read_serial (fsrfdata, 'canyon_height_width_ratio', SITE_hlr ) - ENDIF -ELSE - u_site_hlr = readflag .and. ncio_var_exist(fsrfdata,'wall_to_plan_area_ratio',readflag) - IF ( u_site_hlr ) THEN - CALL ncio_read_serial (fsrfdata, 'wall_to_plan_area_ratio', SITE_lambdaw ) - SITE_hlr = SITE_lambdaw/4/SITE_froof - ENDIF -ENDIF - ! (5) urban ecology - readflag = USE_SITE_urban_ecology - u_site_htopu = readflag .and. ncio_var_exist(fsrfdata,'tree_mean_height',readflag) - IF ( u_site_htopu ) THEN - CALL ncio_read_serial (fsrfdata, 'tree_mean_height', SITE_htop_urb ) - ELSE - CALL gridhtopu%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' - write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 - - CALL read_point_5x5_var_2d_real8 (gridhtopu, dir_5x5, 'URBSRF'//trim(c5year), 'HTOP', & - SITE_lon_location, SITE_lat_location, SITE_htop_urb) - ENDIF - - u_site_flake = readflag .and. ncio_var_exist(fsrfdata,'water_area_fraction',readflag) - IF ( u_site_flake ) THEN - CALL ncio_read_serial (fsrfdata, 'water_area_fraction', SITE_flake_urb ) - ELSE - CALL gridflakeu%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' - write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 - - CALL read_point_5x5_var_2d_real8 (gridflakeu, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_Water', & - SITE_lon_location, SITE_lat_location, SITE_flake_urb) - - SITE_flake_urb = SITE_flake_urb/100 - ENDIF - - u_site_fveg = readflag .and. ncio_var_exist(fsrfdata,'tree_area_fraction',readflag) - IF ( u_site_fveg ) THEN - CALL ncio_read_serial (fsrfdata, 'tree_area_fraction', SITE_fveg_urb ) - ELSE - CALL gridfvegu%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' - write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 - - CALL read_point_5x5_var_2d_real8 (gridfvegu, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_Tree', & - SITE_lon_location, SITE_lat_location, SITE_fveg_urb) - - SITE_fveg_urb = SITE_fveg_urb/100 - ENDIF - - u_site_urblai = readflag .and. ncio_var_exist(fsrfdata,'TREE_LAI',readflag) - IF ( u_site_urblai) THEN - CALL ncio_read_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly ) - CALL ncio_read_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly ) - ELSE - - idate(1) = DEF_simulation_time%start_year - IF (.not. isgreenwich) THEN - idate(3) = DEF_simulation_time%start_sec - CALL monthday2julian (idate(1), & - DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2)) - CALL localtime2gmt(idate) - ENDIF - simulation_lai_year_start = idate(1) - - idate(1) = DEF_simulation_time%end_year - IF (.not. isgreenwich) THEN - idate(3) = DEF_simulation_time%end_sec - CALL monthday2julian (idate(1), & - DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2)) - CALL localtime2gmt(idate) - ENDIF - simulation_lai_year_end = idate(1) - - IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR ) - start_year = min(start_year, DEF_LAI_END_YEAR ) - end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR ) - end_year = max(end_year, DEF_LAI_START_YEAR ) - ELSE - start_year = DEF_LC_YEAR - end_year = DEF_LC_YEAR - ENDIF - - allocate (SITE_LAI_year (start_year:end_year)) - SITE_LAI_year = (/(iyear, iyear = start_year, end_year)/) - - ntime = 12 - allocate (SITE_LAI_monthly (12,start_year:end_year)) - allocate (SITE_SAI_monthly (12,start_year:end_year)) - - CALL gridlaiu%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban_lai_500m/' - - DO iyear = start_year, end_year - write(cyear,'(i4.4)') iyear - DO itime = 1, ntime - CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBLAI_'//trim(cyear), & - 'URBAN_TREE_LAI', SITE_lon_location, SITE_lat_location, itime, & - SITE_LAI_monthly(itime,iyear)) - - CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBLAI_'//trim(cyear), & - 'URBAN_TREE_SAI', SITE_lon_location, SITE_lat_location, itime, & - SITE_SAI_monthly(itime,iyear)) - ENDDO - ENDDO - ENDIF - - ! (6) urban radiation - readflag = USE_SITE_urban_radiation - u_site_albr = readflag .and. ncio_var_exist(fsrfdata,'ALB_ROOF',readflag) - IF ( u_site_albr ) THEN - CALL ncio_read_serial (fsrfdata, 'ALB_ROOF', SITE_alb_roof ) - ENDIF - - u_site_albw = readflag .and. ncio_var_exist(fsrfdata,'ALB_WALL',readflag) - IF ( u_site_albw ) THEN - CALL ncio_read_serial (fsrfdata, 'ALB_WALL', SITE_alb_wall ) - ENDIF - - u_site_albgper = readflag .and. ncio_var_exist(fsrfdata,'ALB_GPER',readflag) - IF ( u_site_albgper ) THEN - CALL ncio_read_serial (fsrfdata, 'ALB_GPER', SITE_alb_gper ) - ENDIF - - u_site_albgimp = readflag .and. ncio_var_exist(fsrfdata,'ALB_GIMP',readflag) - IF ( u_site_albgimp ) THEN - CALL ncio_read_serial (fsrfdata, 'ALB_GIMP', SITE_alb_gimp ) - ENDIF - - u_site_emr = readflag .and. ncio_var_exist(fsrfdata,'EM_ROOF',readflag) - IF ( u_site_emr ) THEN - CALL ncio_read_serial (fsrfdata, 'EM_ROOF', SITE_em_roof ) - ENDIF - - u_site_emw = readflag .and. ncio_var_exist(fsrfdata,'EM_WALL',readflag) - IF ( u_site_emw ) THEN - CALL ncio_read_serial (fsrfdata, 'EM_WALL', SITE_em_wall ) - ENDIF - - u_site_emgper = readflag .and. ncio_var_exist(fsrfdata,'EM_GPER',readflag) - IF ( u_site_emgper ) THEN - CALL ncio_read_serial (fsrfdata, 'EM_GPER', SITE_em_gper ) - ENDIF - - u_site_emgimp = readflag .and. ncio_var_exist(fsrfdata,'EM_GIMP',readflag) - IF ( u_site_emgimp ) THEN - CALL ncio_read_serial (fsrfdata, 'EM_GIMP', SITE_em_gimp ) - ENDIF - - ! (6) urban thermal - readflag = USE_SITE_urban_thermal - u_site_cvr = readflag .and. ncio_var_exist(fsrfdata,'CV_ROOF',readflag) - IF ( u_site_cvr ) THEN - CALL ncio_read_serial (fsrfdata, 'CV_ROOF', SITE_cv_roof ) - ENDIF - - u_site_cvw = readflag .and. ncio_var_exist(fsrfdata,'CV_WALL',readflag) - IF ( u_site_cvw ) THEN - CALL ncio_read_serial (fsrfdata, 'CV_WALL', SITE_cv_wall ) - ENDIF - - u_site_cvgimp = readflag .and. ncio_var_exist(fsrfdata,'CV_GIMP',readflag) - IF ( u_site_cvgimp ) THEN - CALL ncio_read_serial (fsrfdata, 'CV_GIMP', SITE_cv_gimp ) - ENDIF - - u_site_tkr = readflag .and. ncio_var_exist(fsrfdata,'TK_ROOF',readflag) - IF ( u_site_tkr ) THEN - CALL ncio_read_serial (fsrfdata, 'TK_ROOF', SITE_tk_roof ) - ENDIF - - u_site_tkw = readflag .and. ncio_var_exist(fsrfdata,'TK_WALL',readflag) - IF ( u_site_tkw ) THEN - CALL ncio_read_serial (fsrfdata, 'TK_WALL', SITE_tk_wall ) - ENDIF - - u_site_tkgimp = readflag .and. ncio_var_exist(fsrfdata,'TK_GIMP',readflag) - IF ( u_site_tkgimp ) THEN - CALL ncio_read_serial (fsrfdata, 'TK_GIMP', SITE_tk_gimp ) - ENDIF - - ! (6) urban human - readflag = USE_SITE_urban_human - u_site_pop= readflag .and. ncio_var_exist(fsrfdata,'resident_population_density',readflag) - IF ( u_site_pop) THEN - CALL ncio_read_serial (fsrfdata, 'resident_population_density', SITE_popden ) - ELSE - CALL gridpopu%define_by_name ('colm_500m') - dir_5x5 = trim(DEF_dir_rawdata) // '/urban/' - write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5 - - IF (mod(DEF_LC_YEAR,5) == 0) THEN - pop_i = 1 - ELSE - pop_i = 5 - (ceiling(DEF_LC_YEAR*1./5.)*5 - DEF_LC_YEAR) + 1 - ENDIF - - CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBSRF'//trim(c5year), & - 'POP_DEN', SITE_lon_location, SITE_lat_location, pop_i, & - SITE_popden) - ENDIF - - u_site_lucy= readflag .and. ncio_var_exist(fsrfdata,'LUCY_ID',readflag) - IF ( u_site_lucy) THEN - CALL ncio_read_serial (fsrfdata, 'LUCY_ID', SITE_lucyid ) - ELSE - CALL gridlucy%define_by_name ('colm_5km') - filename = trim(DEF_dir_rawdata) // '/urban/LUCY_regionid.nc' - - CALL read_point_var_2d_real8 (gridlucy, filename, 'LUCY_REGION_ID', & - SITE_lon_location, SITE_lat_location, SITE_lucyid) - ENDIF - - u_site_tbmax= readflag .and. ncio_var_exist(fsrfdata,'T_BUILDING_MAX',readflag) - IF ( u_site_tbmax) THEN - CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) - ENDIF - - u_site_tbmin= readflag .and. ncio_var_exist(fsrfdata,'T_BUILDING_MIN',readflag) - IF ( u_site_tbmin) THEN - CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) - ENDIF - -IF (DEF_URBAN_type_scheme == 1) THEN - filename = trim(DEF_dir_rawdata)//'urban/NCAR_urban_properties.nc' - - CALL ncio_read_bcast_serial (filename, "WTLUNIT_ROOF" , wtroof_ncar ) - CALL ncio_read_bcast_serial (filename, "HT_ROOF" , htroof_ncar ) - CALL ncio_read_bcast_serial (filename, "CANYON_HWR" , hwrbld_ncar ) - CALL ncio_read_bcast_serial (filename, "WTROAD_PERV" , fgper_ncar ) - CALL ncio_read_bcast_serial (filename, "EM_ROOF" , emroof_ncar ) - CALL ncio_read_bcast_serial (filename, "EM_WALL" , emwall_ncar ) - CALL ncio_read_bcast_serial (filename, "EM_IMPROAD" , emgimp_ncar ) - CALL ncio_read_bcast_serial (filename, "EM_PERROAD" , emgper_ncar ) - CALL ncio_read_bcast_serial (filename, "ALB_ROOF" , albroof_ncar) - CALL ncio_read_bcast_serial (filename, "ALB_WALL" , albwall_ncar) - CALL ncio_read_bcast_serial (filename, "ALB_IMPROAD" , albgimp_ncar) - CALL ncio_read_bcast_serial (filename, "ALB_PERROAD" , albgper_ncar) - CALL ncio_read_bcast_serial (filename, "TK_ROOF" , tkroof_ncar ) - CALL ncio_read_bcast_serial (filename, "TK_WALL" , tkwall_ncar ) - CALL ncio_read_bcast_serial (filename, "TK_IMPROAD" , tkgimp_ncar ) - CALL ncio_read_bcast_serial (filename, "CV_ROOF" , cvroof_ncar ) - CALL ncio_read_bcast_serial (filename, "CV_WALL" , cvwall_ncar ) - CALL ncio_read_bcast_serial (filename, "CV_IMPROAD" , cvgimp_ncar ) - CALL ncio_read_bcast_serial (filename, "THICK_ROOF" , thkroof_ncar) - CALL ncio_read_bcast_serial (filename, "THICK_WALL" , thkwall_ncar) - CALL ncio_read_bcast_serial (filename, "T_BUILDING_MIN", tbldmin_ncar) - CALL ncio_read_bcast_serial (filename, "T_BUILDING_MAX", tbldmax_ncar) - - rid = SITE_ncar_rid - utyp = SITE_urbtyp - - IF (.not. u_site_emr ) SITE_em_roof = emroof_ncar(utyp, rid) - IF (.not. u_site_emw ) SITE_em_wall = emwall_ncar(utyp, rid) - IF (.not. u_site_emgimp ) SITE_em_gimp = emgimp_ncar(utyp, rid) - IF (.not. u_site_emgper ) SITE_em_gper = emgper_ncar(utyp, rid) - - IF (.not. u_site_tbmax ) SITE_t_roommax = tbldmax_ncar (utyp, rid) - IF (.not. u_site_tbmin ) SITE_t_roommin = tbldmin_ncar (utyp, rid) - - IF (.not. u_site_thickr ) SITE_thickroof = thkroof_ncar(utyp, rid) - IF (.not. u_site_thickw ) SITE_thickwall = thkwall_ncar(utyp, rid) - - IF (.not. u_site_cvr ) THEN - allocate( SITE_cv_roof (nl_roof) ) - SITE_cv_roof(:) = cvroof_ncar(utyp, rid, :) - ENDIF - - IF (.not. u_site_cvw ) THEN - allocate( SITE_cv_wall (nl_wall) ) - SITE_cv_wall(:) = cvwall_ncar(utyp, rid, :) - ENDIF - - IF (.not. u_site_cvgimp) THEN - allocate( SITE_cv_gimp (nl_soil) ) - SITE_cv_gimp(:) = cvgimp_ncar(utyp, rid, :) - ENDIF - - IF (.not. u_site_tkr ) THEN - allocate( SITE_tk_roof (nl_roof) ) - SITE_tk_roof(:) = tkroof_ncar(utyp, rid, :) - ENDIF - - IF (.not. u_site_tkw ) THEN - allocate( SITE_tk_wall (nl_wall) ) - SITE_tk_wall(:) = tkwall_ncar(utyp, rid, :) - ENDIF - - IF (.not. u_site_tkgimp) THEN - allocate( SITE_tk_gimp (nl_soil) ) - SITE_tk_gimp(:) = tkgimp_ncar(utyp, rid, :) - ENDIF - - IF (.not. u_site_albr ) THEN - allocate( SITE_alb_roof (2, 2) ) - SITE_alb_roof(:,:) = albroof_ncar(utyp, rid, :, :) - ENDIF - - IF (.not. u_site_albw ) THEN - allocate( SITE_alb_wall (2, 2) ) - SITE_alb_wall(:,:) = albwall_ncar(utyp, rid, :, :) - ENDIF - - IF (.not. u_site_albgimp) THEN - allocate( SITE_alb_gimp (2, 2) ) - SITE_alb_gimp(:,:) = albgimp_ncar(utyp, rid, :, :) - ENDIF - - IF (.not. u_site_albgper) THEN - allocate( SITE_alb_gper (2, 2) ) - SITE_alb_gper(:,:) = albgper_ncar(utyp, rid, :, :) - ENDIF - - IF (.not. u_site_hlr ) SITE_hlr = hwrbld_ncar(utyp, rid) - IF (.not. u_site_fgper) SITE_fgimp = 1-fgper_ncar(utyp, rid) -ELSE - utyp = SITE_urbtyp - IF (.not. u_site_emr ) SITE_em_roof = emroof_lcz(utyp) - IF (.not. u_site_emw ) SITE_em_wall = emwall_lcz(utyp) - IF (.not. u_site_emgimp) SITE_em_gimp = emgimp_lcz(utyp) - IF (.not. u_site_emgper) SITE_em_gper = emgper_lcz(utyp) - - IF (.not. u_site_tbmax) SITE_t_roommax = tbldmax_lcz(utyp) - IF (.not. u_site_tbmin) SITE_t_roommin = tbldmin_lcz(utyp) - - IF (.not. u_site_thickr) SITE_thickroof = thkroof_lcz(utyp) - IF (.not. u_site_thickw) SITE_thickwall = thkwall_lcz(utyp) - - IF (.not. u_site_cvr ) THEN - allocate( SITE_cv_roof (nl_roof) ) - SITE_cv_roof(:) = cvroof_lcz(utyp) - ENDIF - - IF (.not. u_site_cvw ) THEN - allocate( SITE_cv_wall (nl_wall) ) - SITE_cv_wall(:) = cvwall_lcz(utyp) - ENDIF - - IF (.not. u_site_cvgimp) THEN - allocate( SITE_cv_gimp (nl_soil) ) - SITE_cv_gimp(:) = cvgimp_lcz(utyp) - ENDIF - - IF (.not. u_site_tkr ) THEN - allocate( SITE_tk_roof (nl_roof) ) - SITE_tk_roof(:) = tkroof_lcz(utyp) - ENDIF - - IF (.not. u_site_tkw ) THEN - allocate( SITE_tk_wall (nl_wall) ) - SITE_tk_wall(:) = tkwall_lcz(utyp) - ENDIF - - IF (.not. u_site_tkgimp) THEN - allocate( SITE_tk_gimp (nl_soil) ) - SITE_tk_gimp(:) = tkgimp_lcz(utyp) - ENDIF - - IF (.not. u_site_albr ) THEN - allocate( SITE_alb_roof (2, 2) ) - SITE_alb_roof(:,:) = albroof_lcz(utyp) - ENDIF - - IF (.not. u_site_albw ) THEN - allocate( SITE_alb_wall (2, 2) ) - SITE_alb_wall(:,:) = albwall_lcz(utyp) - ENDIF - - IF (.not. u_site_albgimp) THEN - allocate( SITE_alb_gimp (2, 2) ) - SITE_alb_gimp(:,:) = albgimp_lcz(utyp) - ENDIF - - IF (.not. u_site_albgper) THEN - allocate( SITE_alb_gper (2, 2) ) - SITE_alb_gper(:,:) = albgper_lcz(utyp) - ENDIF - - IF (.not. u_site_hlr ) SITE_hlr = hwrbld_lcz(utyp) - - IF (.not. u_site_fgper) SITE_fgimp = 1-fgper_lcz(utyp)/(1-SITE_froof) -ENDIF - -IF (DEF_USE_CANYON_HWR) THEN - SITE_hlr =SITE_hlr*(1-sqrt(SITE_froof))/sqrt(SITE_froof) -ENDIF - - ! (6) lake depth - readflag = u_site_lakedepth - u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag) - IF (u_site_lakedepth) THEN - CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth) - ELSE - CALL gridlake%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/lake_depth.nc' - CALL read_point_var_2d_real8 (gridlake, filename, 'lake_depth', & - SITE_lon_location, SITE_lat_location, lakedepth) - SITE_lakedepth = lakedepth * 0.1 - ENDIF - - write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',datasource(u_site_lakedepth),')' - - ! (7) soil brightness parameters - readflag = USE_SITE_soilreflectance - u_site_soil_bright = readflag & - .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) & - .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) & - .and. ncio_var_exist(fsrfdata,'soil_s_n_alb',readflag) & - .and. ncio_var_exist(fsrfdata,'soil_d_n_alb',readflag) - - IF (u_site_soil_bright) THEN - CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) - CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) - CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) - CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) - ELSE - SITE_soil_s_v_alb = spval - SITE_soil_d_v_alb = spval - SITE_soil_s_n_alb = spval - SITE_soil_d_n_alb = spval - - CALL gridbright%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/soil_brightness.nc' - CALL read_point_var_2d_int32 (gridbright, filename, 'soil_brightness', & - SITE_lon_location, SITE_lat_location, isc) - -#ifdef LULC_USGS - IF(SITE_landtype /= 16 .and. SITE_landtype /= 24)THEN ! NOT WATER BODIES(16)/GLACIER and ICESHEET(24) -#else - IF(SITE_landtype /= 17 .and. SITE_landtype /= 15)THEN ! NOT WATER BODIES(17)/GLACIER and ICE SHEET(15) -#endif - IF ((isc >= 1) .and. (isc <= 20)) THEN - SITE_soil_s_v_alb = soil_s_v_refl( isc ) - SITE_soil_d_v_alb = soil_d_v_refl( isc ) - SITE_soil_s_n_alb = soil_s_n_refl( isc ) - SITE_soil_d_n_alb = soil_d_n_refl( isc ) - ENDIF - ENDIF - ENDIF - - write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - write(*,'(A,F8.2,3A)') 'Soil brightness d_n : ', SITE_soil_d_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')' - - ! (8) soil parameters - CALL gridsoil%define_by_name ('colm_500m') - - readflag = USE_SITE_soilparameters - u_site_vf_quartz_mineral = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag) - IF (u_site_vf_quartz_mineral) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) - ELSE - allocate (SITE_soil_vf_quartz_mineral (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_quartz_mineral_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_quartz_mineral(nsl)) - ENDDO - ENDIF - - u_site_vf_gravels = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_gravels',readflag) - IF (u_site_vf_gravels) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels) - ELSE - allocate (SITE_soil_vf_gravels (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_gravels_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_gravels_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_gravels(nsl)) - ENDDO - ENDIF - - u_site_vf_sand = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_sand',readflag) - IF (u_site_vf_sand) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand) - ELSE - allocate (SITE_soil_vf_sand (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_sand_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_sand_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_sand(nsl)) - ENDDO - ENDIF - - u_site_vf_clay = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_clay',readflag) - IF (u_site_vf_clay) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay) - ELSE - allocate (SITE_soil_vf_clay (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_clay_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_clay_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_clay(nsl)) - ENDDO - ENDIF - - u_site_vf_om = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_om',readflag) - IF (u_site_vf_om) THEN - CALL ncio_read_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om) - ELSE - allocate (SITE_soil_vf_om (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/vf_om_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_om_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_vf_om(nsl)) - ENDDO - ENDIF - - u_site_wf_gravels = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_gravels',readflag) - IF (u_site_wf_gravels) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels) - ELSE - allocate (SITE_soil_wf_gravels (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_gravels_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_gravels_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_gravels(nsl)) - ENDDO - ENDIF - - u_site_wf_sand = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_sand',readflag) - IF (u_site_wf_sand) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand) - ELSE - allocate (SITE_soil_wf_sand (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_sand_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_sand_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_sand(nsl)) - ENDDO - ENDIF - - u_site_wf_clay = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_clay',readflag) - IF (u_site_wf_clay) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay) - ELSE - allocate (SITE_soil_wf_clay (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_clay_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_clay_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_clay(nsl)) - ENDDO - ENDIF - - u_site_wf_om = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_om',readflag) - IF (u_site_wf_om) THEN - CALL ncio_read_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om) - ELSE - allocate (SITE_soil_wf_om (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/wf_om_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_om_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_wf_om(nsl)) - ENDDO - ENDIF - - u_site_OM_density = readflag .and. ncio_var_exist(fsrfdata,'soil_OM_density',readflag) - IF (u_site_OM_density) THEN - CALL ncio_read_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density) - ELSE - allocate (SITE_soil_OM_density (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/OM_density_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'OM_density_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_OM_density(nsl)) - ENDDO - ENDIF - - u_site_BD_all = readflag .and. ncio_var_exist(fsrfdata,'soil_BD_all',readflag) - IF (u_site_BD_all) THEN - CALL ncio_read_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all) - ELSE - allocate (SITE_soil_BD_all (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/BD_all_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'BD_all_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_BD_all(nsl)) - ENDDO - ENDIF - - u_site_theta_s = readflag .and. ncio_var_exist(fsrfdata,'soil_theta_s',readflag) - IF (u_site_theta_s) THEN - CALL ncio_read_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s) - ELSE - allocate (SITE_soil_theta_s (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/theta_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'theta_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_theta_s(nsl)) - ENDDO - ENDIF - - u_site_k_s = readflag .and. ncio_var_exist(fsrfdata,'soil_k_s',readflag) - IF (u_site_k_s) THEN - CALL ncio_read_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s) - ELSE - allocate (SITE_soil_k_s (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/k_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'k_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_k_s(nsl)) - ENDDO - ENDIF - - u_site_csol = readflag .and. ncio_var_exist(fsrfdata,'soil_csol',readflag) - IF (u_site_csol) THEN - CALL ncio_read_serial (fsrfdata, 'soil_csol', SITE_soil_csol) - ELSE - allocate (SITE_soil_csol (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/csol.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'csol_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_csol(nsl)) - ENDDO - ENDIF - - u_site_tksatu = readflag .and. ncio_var_exist(fsrfdata,'soil_tksatu',readflag) - IF (u_site_tksatu) THEN - CALL ncio_read_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu) - ELSE - allocate (SITE_soil_tksatu (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/tksatu.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatu_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_tksatu(nsl)) - ENDDO - ENDIF - - u_site_tksatf = readflag .and. ncio_var_exist(fsrfdata,'soil_tksatf',readflag) - IF (u_site_tksatf) THEN - CALL ncio_read_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf) - ELSE - allocate (SITE_soil_tksatf (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/tksatf.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatf_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_tksatf(nsl)) - ENDDO - ENDIF - - u_site_tkdry = readflag .and. ncio_var_exist(fsrfdata,'soil_tkdry',readflag) - IF (u_site_tkdry) THEN - CALL ncio_read_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry) - ELSE - allocate (SITE_soil_tkdry (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/tkdry.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'tkdry_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_tkdry(nsl)) - ENDDO - ENDIF - - u_site_k_solids = readflag .and. ncio_var_exist(fsrfdata,'soil_k_solids',readflag) - IF (u_site_k_solids) THEN - CALL ncio_read_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids) - ELSE - allocate (SITE_soil_k_solids (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/k_solids.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'k_solids_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_k_solids(nsl)) - ENDDO - ENDIF - - u_site_psi_s = readflag .and. ncio_var_exist(fsrfdata,'soil_psi_s',readflag) - IF (u_site_psi_s) THEN - CALL ncio_read_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s) - ELSE - allocate (SITE_soil_psi_s (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/psi_s.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'psi_s_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_psi_s(nsl)) - ENDDO - ENDIF - - u_site_lambda = readflag .and. ncio_var_exist(fsrfdata,'soil_lambda',readflag) - IF (u_site_lambda) THEN - CALL ncio_read_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda) - ELSE - allocate (SITE_soil_lambda (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/lambda.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'lambda_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_lambda(nsl)) - ENDDO - ENDIF - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - u_site_theta_r = readflag .and. ncio_var_exist(fsrfdata,'soil_theta_r',readflag) - IF (u_site_theta_r) THEN - CALL ncio_read_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r) - ELSE - allocate (SITE_soil_theta_r (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_theta_r.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_theta_r_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_theta_r(nsl)) - ENDDO - ENDIF - - u_site_alpha_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_alpha_vgm',readflag) - IF (u_site_alpha_vgm) THEN - CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm) - ELSE - allocate (SITE_soil_alpha_vgm (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_alpha.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_alpha_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_alpha_vgm(nsl)) - ENDDO - ENDIF - - u_site_L_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_L_vgm',readflag) - IF (u_site_L_vgm) THEN - CALL ncio_read_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm) - ELSE - allocate (SITE_soil_L_vgm (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_L.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_L_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_L_vgm(nsl)) - ENDDO - ENDIF - - u_site_n_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_n_vgm',readflag) - IF (u_site_n_vgm) THEN - CALL ncio_read_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm) - ELSE - allocate (SITE_soil_n_vgm (8)) - DO nsl = 1, 8 - write(c,'(i1)') nsl - filename = trim(DEF_dir_rawdata)//'/soil/VGM_n.nc' - CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_n_l'//trim(c), & - SITE_lon_location, SITE_lat_location, SITE_soil_n_vgm(nsl)) - ENDDO - ENDIF -#endif - - u_site_BA_alpha = .false. - u_site_BA_beta = .false. - allocate (SITE_soil_BA_alpha (8)) - allocate (SITE_soil_BA_beta (8)) - DO nsl = 1, 8 - IF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.4) THEN - SITE_soil_BA_alpha(nsl) = 0.38 - SITE_soil_BA_beta (nsl) = 35.0 - ELSEIF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.25) THEN - SITE_soil_BA_alpha(nsl) = 0.24 - SITE_soil_BA_beta (nsl) = 26.0 - ELSE - SITE_soil_BA_alpha(nsl) = 0.20 - SITE_soil_BA_beta (nsl) = 10.0 - ENDIF - ENDDO - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - u_site_soil_texture = readflag .and. ncio_var_exist(fsrfdata,'soil_texture',readflag) - IF (u_site_soil_texture) THEN - CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture) - ELSE - filename = trim(DEF_dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc' - CALL read_point_var_2d_int32 (gridsoil, filename, 'soiltexture', & - SITE_lon_location, SITE_lat_location, SITE_soil_texture) - ENDIF - ENDIF - - write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_clay : ', SITE_soil_vf_clay (1:8), ' (from ',trim(datasource(u_site_vf_clay )),')' - write(*,'(A,8ES10.2,3A)') 'soil_vf_om : ', SITE_soil_vf_om (1:8), ' (from ',trim(datasource(u_site_vf_om )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_gravels : ', SITE_soil_wf_gravels (1:8), ' (from ',trim(datasource(u_site_wf_gravels )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_sand : ', SITE_soil_wf_sand (1:8), ' (from ',trim(datasource(u_site_wf_sand )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_clay : ', SITE_soil_wf_clay (1:8), ' (from ',trim(datasource(u_site_wf_clay )),')' - write(*,'(A,8ES10.2,3A)') 'soil_wf_om : ', SITE_soil_wf_om (1:8), ' (from ',trim(datasource(u_site_wf_om )),')' - write(*,'(A,8ES10.2,3A)') 'soil_OM_density : ', SITE_soil_OM_density (1:8), ' (from ',trim(datasource(u_site_OM_density )),')' - write(*,'(A,8ES10.2,3A)') 'soil_BD_all : ', SITE_soil_BD_all (1:8), ' (from ',trim(datasource(u_site_BD_all )),')' - write(*,'(A,8ES10.2,3A)') 'soil_theta_s : ', SITE_soil_theta_s (1:8), ' (from ',trim(datasource(u_site_theta_s )),')' - write(*,'(A,8ES10.2,3A)') 'soil_k_s : ', SITE_soil_k_s (1:8), ' (from ',trim(datasource(u_site_k_s )),')' - write(*,'(A,8ES10.2,3A)') 'soil_csol : ', SITE_soil_csol (1:8), ' (from ',trim(datasource(u_site_csol )),')' - write(*,'(A,8ES10.2,3A)') 'soil_tksatu : ', SITE_soil_tksatu (1:8), ' (from ',trim(datasource(u_site_tksatu )),')' - write(*,'(A,8ES10.2,3A)') 'soil_tksatf : ', SITE_soil_tksatf (1:8), ' (from ',trim(datasource(u_site_tksatf )),')' - write(*,'(A,8ES10.2,3A)') 'soil_tkdry : ', SITE_soil_tkdry (1:8), ' (from ',trim(datasource(u_site_tkdry )),')' - write(*,'(A,8ES10.2,3A)') 'soil_k_solids : ', SITE_soil_k_solids (1:8), ' (from ',trim(datasource(u_site_k_solids )),')' - write(*,'(A,8ES10.2,3A)') 'soil_psi_s : ', SITE_soil_psi_s (1:8), ' (from ',trim(datasource(u_site_psi_s )),')' - write(*,'(A,8ES10.2,3A)') 'soil_lambda : ', SITE_soil_lambda (1:8), ' (from ',trim(datasource(u_site_lambda )),')' -#ifdef vanGenuchten_Mualem_SOIL_MODEL - write(*,'(A,8ES10.2,3A)') 'soil_theta_r : ', SITE_soil_theta_r (1:8), ' (from ',trim(datasource(u_site_theta_r )),')' - write(*,'(A,8ES10.2,3A)') 'soil_alpha_vgm : ', SITE_soil_alpha_vgm (1:8), ' (from ',trim(datasource(u_site_alpha_vgm )),')' - write(*,'(A,8ES10.2,3A)') 'soil_L_vgm : ', SITE_soil_L_vgm (1:8), ' (from ',trim(datasource(u_site_L_vgm )),')' - write(*,'(A,8ES10.2,3A)') 'soil_n_vgm : ', SITE_soil_n_vgm (1:8), ' (from ',trim(datasource(u_site_n_vgm )),')' -#endif - write(*,'(A,8ES10.2,3A)') 'soil_BA_alpha : ', SITE_soil_BA_alpha (1:8), ' (from ',trim(datasource(u_site_BA_alpha )),')' - write(*,'(A,8ES10.2,3A)') 'soil_BA_beta : ', SITE_soil_BA_beta (1:8), ' (from ',trim(datasource(u_site_BA_beta )),')' - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - write(*,'(A,I3,3A)') 'soil texture : ', SITE_soil_texture, ' (from ',trim(datasource(u_site_soil_texture)),')' - ENDIF - - ! (9) depth to bedrock - IF (DEF_USE_BEDROCK) THEN - readflag = USE_SITE_dbedrock - u_site_dbedrock = readflag .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag) - IF (u_site_dbedrock) THEN - CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) - ELSE - CALL gridrock%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/bedrock.nc' - CALL read_point_var_2d_real8 (gridrock, filename, 'dbedrock', & - SITE_lon_location, SITE_lat_location, SITE_dbedrock) - ENDIF - - write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',datasource(u_site_dbedrock),')' - ENDIF - - ! (10) topography - readflag = USE_SITE_topography - - u_site_elevation = readflag .and. ncio_var_exist (fsrfdata, 'elevation',readflag) - IF (u_site_elevation) THEN - CALL ncio_read_serial (fsrfdata, 'elevation', SITE_elevation) - ELSE - CALL gridtopo%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/elevation.nc' - CALL read_point_var_2d_real8 (gridtopo, filename, 'elevation', & - SITE_lon_location, SITE_lat_location, SITE_elevation) - ENDIF - - u_site_elvstd = readflag & - .and. ncio_var_exist (fsrfdata, 'elvstd',readflag) - IF (u_site_elvstd) THEN - CALL ncio_read_serial (fsrfdata, 'elvstd', SITE_elvstd) - ELSE - CALL gridtopo%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/topography.nc' - CALL read_point_var_2d_real8 (gridtopo, filename, 'elvstd', & - SITE_lon_location, SITE_lat_location, SITE_elvstd) - ENDIF - - u_site_sloperatio = readflag & - .and. ncio_var_exist (fsrfdata, 'sloperatio',readflag) - IF (u_site_sloperatio) THEN - CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio) - ELSE - CALL gridtopo%define_by_name ('colm_500m') - filename = trim(DEF_dir_rawdata)//'/topography.nc' - CALL read_point_var_2d_real8 (gridtopo, filename, 'slope', & - SITE_lon_location, SITE_lat_location, SITE_sloperatio) - ENDIF - - IF (DEF_USE_Forcing_Downscaling) THEN - - filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" - IF (ncio_var_exist(filename,'lat') .and. ncio_var_exist(filename,'lon')) THEN - CALL grid_topo_factor%define_from_file (filename, "lat", "lon") - ENDIF - - u_site_svf = readflag .and. ncio_var_exist (fsrfdata, 'SITE_svf',readflag) - IF (u_site_svf) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/sky_view_factor.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'svf', & - SITE_lon_location, SITE_lat_location, SITE_svf) - ENDIF - - u_site_cur = readflag .and. ncio_var_exist (fsrfdata, 'SITE_cur',readflag) - IF (u_site_cur) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/curvature.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'curvature', & - SITE_lon_location, SITE_lat_location, SITE_cur) - ENDIF - - u_site_slp_type = readflag & - .and. ncio_var_exist (fsrfdata, 'SITE_slp_type' ,readflag) & - .and. ncio_var_exist (fsrfdata, 'SITE_asp_type' ,readflag) & - .and. ncio_var_exist (fsrfdata, 'SITE_area_type',readflag) - u_site_asp_type = u_site_slp_type - u_site_area_type = u_site_slp_type - - IF (u_site_slp_type) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type ) - CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type ) - CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type ) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'slope', & - SITE_lon_location, SITE_lat_location, slp) - - filename = trim(DEF_DS_HiresTopographyDataDir)//"/aspect.nc" - CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'aspect', & - SITE_lon_location, SITE_lat_location, asp) - - allocate (SITE_slp_type (num_slope_type)); SITE_slp_type (:) = 0. - allocate (SITE_asp_type (num_slope_type)); SITE_asp_type (:) = 0. - allocate (SITE_area_type (num_slope_type)); SITE_area_type(:) = 0. - - IF ((asp.ge.0 .and. asp.le.90*pi/180) .or. (asp.ge.270*pi/180 .and. asp.le.360*pi/180)) THEN - IF ((slp.ge.15*pi/180)) THEN ! north abrupt slope - typ = 1 - ELSE ! north gentle slope - typ = 2 - ENDIF - ELSE - IF ((slp.ge.15*pi/180)) THEN ! south abrupt slope - typ = 3 - ELSE ! south gentle slope - typ = 4 - ENDIF - ENDIF - - SITE_slp_type (typ) = slp - SITE_asp_type (typ) = asp - SITE_area_type(typ) = 1. - - ENDIF - - u_site_sf_lut = readflag .and. ncio_var_exist (fsrfdata, 'SITE_sf_lut',readflag) - IF (u_site_sf_lut) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut) - ELSE - filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_front.nc" - CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_front', & - SITE_lon_location, SITE_lat_location, num_azimuth, tea_f) - - filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_back.nc" - CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_back', & - SITE_lon_location, SITE_lat_location, num_azimuth, tea_b) - - allocate (SITE_sf_lut (num_azimuth, num_zenith)) - - DO a = 1, num_azimuth - - tea_f(a) = asin(max(min(tea_f(a),1.),-1.)) - tea_b(a) = asin(max(min(tea_b(a),1.),-1.)) - - IF (tea_f(a) <= tea_b(a)) tea_f(a) = tea_b(a) + 0.001 - - DO z = 1, num_zenith - zenith_angle = pi/(2*num_zenith)*(z-1) - - IF (pi*0.5 - zenith_angle < tea_b(a)) THEN - SITE_sf_lut(a,z) = 0 - ELSE IF (pi*0.5 - zenith_angle > tea_f(a)) THEN - SITE_sf_lut(a,z) = 1 - ELSE - SITE_sf_lut(a,z) = (0.5*pi - zenith_angle - tea_b(a))/(tea_f(a) - tea_b(a)) - ENDIF - - ENDDO - ENDDO - - ENDIF - ENDIF - - write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation, ' (from ',datasource(u_site_elevation),')' - write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd, ' (from ',datasource(u_site_elvstd),')' - write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio,' (from ',datasource(u_site_sloperatio),')' - - IF (DEF_USE_Forcing_Downscaling) THEN - write(*,'(A,F8.2,3A)') 'Sky view factor : ', SITE_svf, ' (from ',datasource(u_site_svf),')' - write(*,'(A,F8.2,3A)') 'Curvature : ', SITE_cur, ' (from ',datasource(u_site_cur),')' - write(c,'(I0)') num_slope_type - write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type : ', SITE_slp_type, ' (from ',datasource(u_site_slp_type),')' - write(*,'(A,'//trim(c)//'F8.2,3A)') 'Aspect type : ', SITE_asp_type, ' (from ',datasource(u_site_slp_type),')' - write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type area : ', SITE_area_type, ' (from ',datasource(u_site_slp_type),')' - write(c,'(I0)') num_azimuth*num_zenith - write(*,'(A,A,I3,A,I3,A,'//trim(c)//'F8.2,3A)') 'Shadow lookup table : ', & - '(', num_azimuth, ' in azimuth,', num_zenith, ' in zenith)', & - SITE_sf_lut , ' (from ',datasource(u_site_sf_lut),')' - ENDIF - - ELSE - CALL ncio_read_serial (fsrfdata, 'LAI_year' , SITE_LAI_year ) - CALL ncio_read_serial (fsrfdata, 'TREE_LAI' , SITE_LAI_monthly) - CALL ncio_read_serial (fsrfdata, 'TREE_SAI' , SITE_SAI_monthly) - - CALL ncio_read_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp ) - CALL ncio_read_serial (fsrfdata, 'LUCY_id' , SITE_lucyid ) - CALL ncio_read_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb ) - CALL ncio_read_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb ) - CALL ncio_read_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb ) - CALL ncio_read_serial (fsrfdata, 'WT_ROOF' , SITE_froof ) - CALL ncio_read_serial (fsrfdata, 'HT_ROOF' , SITE_hroof ) - CALL ncio_read_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper ) - CALL ncio_read_serial (fsrfdata, 'BUILDING_HLR' , SITE_hlr ) - CALL ncio_read_serial (fsrfdata, 'POP_DEN' , SITE_popden ) - - CALL ncio_read_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof ) - CALL ncio_read_serial (fsrfdata, 'EM_WALL' , SITE_em_wall ) - CALL ncio_read_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp ) - CALL ncio_read_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper ) - CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) - CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) - CALL ncio_read_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof ) - CALL ncio_read_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall ) - - CALL ncio_read_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof ) - CALL ncio_read_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall ) - CALL ncio_read_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp ) - CALL ncio_read_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper ) - - CALL ncio_read_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof ) - CALL ncio_read_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall ) - CALL ncio_read_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp ) - CALL ncio_read_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof ) - CALL ncio_read_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall ) - CALL ncio_read_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp ) - - CALL ncio_read_serial (fsrfdata, 'lakedepth' , SITE_lakedepth ) - - CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb' , SITE_soil_s_v_alb) - CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb' , SITE_soil_d_v_alb) - CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb' , SITE_soil_s_n_alb) - CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb' , SITE_soil_d_n_alb) - - CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) - CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels' , SITE_soil_vf_gravels ) - CALL ncio_read_serial (fsrfdata, 'soil_vf_sand' , SITE_soil_vf_sand ) - CALL ncio_read_serial (fsrfdata, 'soil_vf_clay' , SITE_soil_vf_clay ) - CALL ncio_read_serial (fsrfdata, 'soil_vf_om' , SITE_soil_vf_om ) - CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels' , SITE_soil_wf_gravels ) - CALL ncio_read_serial (fsrfdata, 'soil_wf_sand' , SITE_soil_wf_sand ) - CALL ncio_read_serial (fsrfdata, 'soil_wf_clay' , SITE_soil_wf_clay ) - CALL ncio_read_serial (fsrfdata, 'soil_wf_om' , SITE_soil_wf_om ) - - CALL ncio_read_serial (fsrfdata, 'soil_OM_density' , SITE_soil_OM_density) - CALL ncio_read_serial (fsrfdata, 'soil_BD_all' , SITE_soil_BD_all ) - CALL ncio_read_serial (fsrfdata, 'soil_theta_s' , SITE_soil_theta_s ) - CALL ncio_read_serial (fsrfdata, 'soil_k_s' , SITE_soil_k_s ) - CALL ncio_read_serial (fsrfdata, 'soil_csol' , SITE_soil_csol ) - CALL ncio_read_serial (fsrfdata, 'soil_tksatu' , SITE_soil_tksatu ) - CALL ncio_read_serial (fsrfdata, 'soil_tksatf' , SITE_soil_tksatf ) - CALL ncio_read_serial (fsrfdata, 'soil_tkdry' , SITE_soil_tkdry ) - CALL ncio_read_serial (fsrfdata, 'soil_k_solids' , SITE_soil_k_solids ) - CALL ncio_read_serial (fsrfdata, 'soil_lambda' , SITE_soil_lambda ) - CALL ncio_read_serial (fsrfdata, 'soil_psi_s' , SITE_soil_psi_s ) - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - CALL ncio_read_serial (fsrfdata, 'soil_theta_r' , SITE_soil_theta_r ) - CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm) - CALL ncio_read_serial (fsrfdata, 'soil_L_vgm' , SITE_soil_L_vgm ) - CALL ncio_read_serial (fsrfdata, 'soil_n_vgm' , SITE_soil_n_vgm ) -#endif - - CALL ncio_read_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha) - CALL ncio_read_serial (fsrfdata, 'soil_BA_beta' , SITE_soil_BA_beta ) - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture) - ENDIF - - IF(DEF_USE_BEDROCK)THEN - CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) - ENDIF - - CALL ncio_read_serial (fsrfdata, 'elevation' , SITE_elevation ) - CALL ncio_read_serial (fsrfdata, 'elvstd' , SITE_elvstd ) - CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio) - - ! used for downscaling - IF (DEF_USE_Forcing_Downscaling) THEN - CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf ) - CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur ) - CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut' , SITE_sf_lut ) - CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type ) - CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type ) - CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type) - ENDIF - ENDIF - - IF (.not. for_surface_build) THEN - - landpatch%nset = numpatch - - allocate (landpatch%settyp (numpatch)); landpatch%settyp = SITE_landtype - - landpatch%nblkgrp = 1 - allocate (landpatch%xblkgrp(1)); landpatch%xblkgrp(1) = 1 - allocate (landpatch%yblkgrp(1)); landpatch%yblkgrp(1) = 1 - - allocate (landpatch%vecgs%vlen(1,1)); landpatch%vecgs%vlen(1,1) = numpatch - allocate (landpatch%vecgs%vstt(1,1)); landpatch%vecgs%vstt(1,1) = 1 - allocate (landpatch%vecgs%vend(1,1)); landpatch%vecgs%vend(1,1) = numpatch - - landurban%nset = numurban - - allocate (landurban%settyp (numurban)); landurban%settyp = SITE_urbtyp - - landurban%nblkgrp = 1 - allocate (landurban%xblkgrp(1)); landurban%xblkgrp(1) = 1 - allocate (landurban%yblkgrp(1)); landurban%yblkgrp(1) = 1 - - allocate (landurban%vecgs%vlen(1,1)); landurban%vecgs%vlen(1,1) = numurban - allocate (landurban%vecgs%vstt(1,1)); landurban%vecgs%vstt(1,1) = 1 - allocate (landurban%vecgs%vend(1,1)); landurban%vecgs%vend(1,1) = numurban - - allocate (patch2urban (numurban)); patch2urban(1) = 1 - allocate (urban2patch (numurban)); urban2patch(1) = 1 - - numelm = 1 - allocate (landelm%settyp (1)); landelm%settyp (1) = 0 - allocate (elm_patch%substt (1)); elm_patch%substt(1) = 1 - allocate (elm_patch%subend (1)); elm_patch%subend(1) = numpatch - allocate (elm_patch%subfrc (numpatch)); elm_patch%subfrc = 1./numpatch - - ENDIF - - END SUBROUTINE read_urban_surface_data_single - - -!----------------------------------------------------------------------- - SUBROUTINE write_surface_data_single (numpatch, numpft) - - USE MOD_NetCDFSerial - USE MOD_Namelist - USE MOD_Const_LC - IMPLICIT NONE - - integer, intent(in) :: numpatch - integer, intent(in), optional :: numpft - - ! Local Variables - character(len=256) :: fsrfdata - integer :: ipft, iyear, itime - character(len=18) :: source - - fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc' - - CALL ncio_create_file (fsrfdata) - - CALL ncio_define_dimension (fsrfdata, 'patch', numpatch) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - CALL ncio_define_dimension (fsrfdata, 'pft', numpft) - ENDIF -#endif - - CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year)) - IF (DEF_LAI_MONTHLY) THEN - CALL ncio_define_dimension (fsrfdata, 'month', 12) - ELSE - CALL ncio_define_dimension (fsrfdata, 'J8day', 46) - ENDIF - - CALL ncio_define_dimension (fsrfdata, 'soil', 8) - - IF (DEF_USE_Forcing_Downscaling) THEN - CALL ncio_define_dimension (fsrfdata, 'slope_type', num_slope_type) - CALL ncio_define_dimension (fsrfdata, 'azi', num_azimuth) - CALL ncio_define_dimension (fsrfdata, 'zen', num_zenith) - ENDIF - - - CALL ncio_write_serial (fsrfdata, 'latitude', SITE_lat_location) - CALL ncio_put_attr (fsrfdata, 'latitude', 'units', 'degrees_north') - - CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location) - CALL ncio_put_attr (fsrfdata, 'longitude','units', 'degrees_east') - -#ifdef LULC_USGS - CALL ncio_write_serial (fsrfdata, 'USGS_classification', SITE_landtype) - CALL ncio_put_attr (fsrfdata, 'USGS_classification', 'source', trim(datasource(u_site_landtype))) - CALL ncio_put_attr (fsrfdata, 'USGS_classification', 'long_name', 'GLCC USGS Land Use/Land Cover') -#else - CALL ncio_write_serial (fsrfdata, 'IGBP_classification', SITE_landtype) - CALL ncio_put_attr (fsrfdata, 'IGBP_classification', 'source', trim(datasource(u_site_landtype))) - CALL ncio_put_attr (fsrfdata, 'IGBP_classification', 'long_name', 'MODIS IGBP Land Use/Land Cover') -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - CALL ncio_write_serial (fsrfdata, 'pfttyp', SITE_pfttyp, 'pft') - CALL ncio_put_attr (fsrfdata, 'pfttyp', 'source', trim(datasource(u_site_pfts))) - CALL ncio_put_attr (fsrfdata, 'pfttyp', 'long_name', 'plant functional type') - - CALL ncio_write_serial (fsrfdata, 'pctpfts', SITE_pctpfts, 'pft') - CALL ncio_put_attr (fsrfdata, 'pctpfts', 'source', trim(datasource(u_site_pfts))) - CALL ncio_put_attr (fsrfdata, 'pctpfts', 'long_name', 'fraction of plant functional type') - ENDIF -#endif -#if (defined CROP) - IF (SITE_landtype == CROPLAND) THEN - CALL ncio_write_serial (fsrfdata, 'croptyp', SITE_croptyp, 'patch') - CALL ncio_put_attr (fsrfdata, 'croptyp', 'source', trim(datasource(u_site_crop))) - CALL ncio_put_attr (fsrfdata, 'croptyp', 'long_name', 'crop type') - - CALL ncio_write_serial (fsrfdata, 'pctcrop', SITE_pctcrop, 'patch') - CALL ncio_put_attr (fsrfdata, 'pctcrop', 'source', trim(datasource(u_site_crop))) - CALL ncio_put_attr (fsrfdata, 'pctcrop', 'long_name', 'fraction of crop type') - ENDIF -#endif - - CALL ncio_write_serial (fsrfdata, 'canopy_height', SITE_htop) - CALL ncio_put_attr (fsrfdata, 'canopy_height', 'source', trim(datasource(u_site_htop))) - CALL ncio_put_attr (fsrfdata, 'canopy_height', 'long_name', 'canopy height') - CALL ncio_put_attr (fsrfdata, 'canopy_height', 'units', 'm') -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - CALL ncio_write_serial (fsrfdata, 'canopy_height_pfts', SITE_htop_pfts, 'pft') - CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'source', trim(datasource(u_site_htop))) - CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'long_name', 'canopy height') - CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'units', 'm') - ENDIF -#endif - - source = trim(datasource(u_site_lai)) - CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year') -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - CALL ncio_write_serial (fsrfdata, 'LAI_pfts_monthly', SITE_LAI_pfts_monthly, 'pft', 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'LAI_pfts_monthly', 'source', source) - CALL ncio_put_attr (fsrfdata, 'LAI_pfts_monthly', 'long_name', 'monthly leaf area index associated with PFT') - - CALL ncio_write_serial (fsrfdata, 'SAI_pfts_monthly', SITE_SAI_pfts_monthly, 'pft', 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'SAI_pfts_monthly', 'source', source) - CALL ncio_put_attr (fsrfdata, 'SAI_pfts_monthly', 'long_name', 'monthly stem area index associated with PFT') - ELSE - CALL ncio_write_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly, 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'source', source) - CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'long_name', 'monthly leaf area index') - - CALL ncio_write_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly, 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'source', source) - CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'long_name', 'monthly stem area index') - ENDIF -#else - IF (DEF_LAI_MONTHLY) THEN - CALL ncio_write_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly, 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'source', source) - CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'long_name', 'monthly leaf area index') - - CALL ncio_write_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly, 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'source', source) - CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'long_name', 'monthly stem area index') - ELSE - CALL ncio_write_serial (fsrfdata, 'LAI_8day', SITE_LAI_8day, 'J8day', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'LAI_8day', 'source', source) - CALL ncio_put_attr (fsrfdata, 'LAI_8day', 'long_name', '8-day leaf area index') - ENDIF -#endif - - CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth) - CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', trim(datasource(u_site_lakedepth))) - CALL ncio_put_attr (fsrfdata, 'lakedepth', 'long_name', 'lake depth') - CALL ncio_put_attr (fsrfdata, 'lakedepth', 'units', 'm') - - CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) - CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'long_name', 'albedo of visible of the saturated soil') - - CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) - CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'long_name', 'albedo of visible of the dry soil') - - CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) - CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'long_name', 'albedo of near infrared of the saturated soil') - - CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) - CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'long_name', 'albedo of near infrared of the dry soil') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', trim(datasource(u_site_vf_quartz_mineral))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'long_name', 'volumetric fraction of quartz within mineral soil') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'source', trim(datasource(u_site_vf_gravels))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'long_name', 'volumetric fraction of gravels') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'source', trim(datasource(u_site_vf_sand))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'long_name', 'volumetric fraction of sand') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'source', trim(datasource(u_site_vf_clay))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'long_name', 'volumetric fraction of clay') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'source', trim(datasource(u_site_vf_om))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'long_name', 'volumetric fraction of organic matter') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'source', trim(datasource(u_site_wf_gravels))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'long_name', 'gravimetric fraction of gravels') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'source', trim(datasource(u_site_wf_sand))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'long_name', 'gravimetric fraction of sand') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'source', trim(datasource(u_site_wf_clay))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'long_name', 'gravimetric fraction of clay') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'source', trim(datasource(u_site_wf_om))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'long_name', 'gravimetric fraction of om') - - CALL ncio_write_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'source', trim(datasource(u_site_OM_density))) - CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'long_name', 'OM density') - CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'units', 'kg/m3') - - CALL ncio_write_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'source', trim(datasource(u_site_BD_all))) - CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'long_name', 'bulk density of soil (GRAVELS + OM + mineral soils)') - CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'units', 'kg/m3') - - CALL ncio_write_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'source', trim(datasource(u_site_theta_s))) - CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'long_name', 'saturated water content') - CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'units', 'cm3/cm3') - - CALL ncio_write_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'source', trim(datasource(u_site_k_s))) - CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'long_name', 'saturated hydraulic conductivity') - CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'units', 'cm/day') - - CALL ncio_write_serial (fsrfdata, 'soil_csol', SITE_soil_csol(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_csol', 'source', trim(datasource(u_site_csol))) - CALL ncio_put_attr (fsrfdata, 'soil_csol', 'long_name', 'heat capacity of soil solids') - CALL ncio_put_attr (fsrfdata, 'soil_csol', 'units', 'J/(m3 K)') - - CALL ncio_write_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'source', trim(datasource(u_site_tksatu))) - CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'long_name', 'thermal conductivity of saturated unfrozen soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'units', 'W/m-K') - - CALL ncio_write_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'source', trim(datasource(u_site_tksatf))) - CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'long_name', 'thermal conductivity of saturated frozen soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'units', 'W/m-K') - - CALL ncio_write_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'source', trim(datasource(u_site_tkdry))) - CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'long_name', 'thermal conductivity for dry soil') - CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'units', 'W/(m-K)') - - CALL ncio_write_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'source', trim(datasource(u_site_k_solids))) - CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'long_name', 'thermal conductivity of minerals soil') - CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'units', 'W/m-K') - - CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', trim(datasource(u_site_lambda))) - CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'long_name', 'pore size distribution index (dimensionless)') - - CALL ncio_write_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', trim(datasource(u_site_psi_s))) - CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'long_name', 'matric potential at saturation') - CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'units', 'cm') - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - CALL ncio_write_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'source', trim(datasource(u_site_theta_r))) - CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'long_name', 'residual water content') - CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'units', 'cm3/cm3') - - CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', trim(datasource(u_site_alpha_vgm))) - CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'long_name', 'a parameter corresponding approximately to the inverse of the air-entry value') - - CALL ncio_write_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'source', trim(datasource(u_site_L_vgm))) - CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'long_name', 'pore-connectivity parameter [dimensionless]') - - CALL ncio_write_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'source', trim(datasource(u_site_n_vgm))) - CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'long_name', 'a shape parameter [dimensionless]') - -#endif - - CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', trim(datasource(u_site_BA_alpha))) - CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'long_name', 'alpha in Balland and Arp(2005) thermal conductivity scheme') - - CALL ncio_write_serial (fsrfdata, 'soil_BA_beta', SITE_soil_BA_beta(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'source', trim(datasource(u_site_BA_beta))) - CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'long_name', 'beta in Balland and Arp(2005) thermal conductivity scheme') - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - CALL ncio_write_serial (fsrfdata, 'soil_texture ', SITE_soil_texture) - CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'source', trim(datasource(u_site_soil_texture))) - CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'long_name', 'USDA soil texture') - ENDIF - - IF(DEF_USE_BEDROCK)THEN - CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) - CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', trim(datasource(u_site_dbedrock))) - ENDIF - - CALL ncio_write_serial (fsrfdata, 'elevation', SITE_elevation) - CALL ncio_put_attr (fsrfdata, 'elevation', 'source', trim(datasource(u_site_elevation))) - - CALL ncio_write_serial (fsrfdata, 'elvstd', SITE_elvstd) - CALL ncio_put_attr (fsrfdata, 'elvstd', 'source', trim(datasource(u_site_elvstd))) - CALL ncio_put_attr (fsrfdata, 'elvstd', 'long_name', 'standard deviation of elevation') - - CALL ncio_write_serial (fsrfdata, 'sloperatio', SITE_sloperatio) - CALL ncio_put_attr (fsrfdata, 'sloperatio', 'source', trim(datasource(u_site_sloperatio))) - CALL ncio_put_attr (fsrfdata, 'sloperatio', 'long_name', 'slope ratio') - - ! used for downscaling - IF (DEF_USE_Forcing_Downscaling) THEN - CALL ncio_write_serial (fsrfdata, 'SITE_svf', SITE_svf) - CALL ncio_put_attr (fsrfdata, 'SITE_svf','source', trim(datasource(u_site_svf))) - CALL ncio_put_attr (fsrfdata, 'SITE_svf','long_name', 'sky view factor') - - CALL ncio_write_serial (fsrfdata, 'SITE_cur', SITE_cur) - CALL ncio_put_attr (fsrfdata, 'SITE_cur','source', trim(datasource(u_site_cur))) - CALL ncio_put_attr (fsrfdata, 'SITE_cur','long_name', 'curvature') - - CALL ncio_write_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut, 'azi', 'zen') - CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','source', trim(datasource(u_site_sf_lut))) - CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','long_name', 'look up table of shadow factor') - - CALL ncio_write_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type , 'type') - CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','source', trim(datasource(u_site_slp_type))) - CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','long_name', 'topographic slope of each character') - - CALL ncio_write_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type , 'type') - CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','source', trim(datasource(u_site_asp_type))) - CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','long_name', 'topographic aspect of each character') - - CALL ncio_write_serial (fsrfdata, 'SITE_area_type', SITE_area_type, 'type') - CALL ncio_put_attr (fsrfdata, 'SITE_area_type','source', trim(datasource(u_site_area_type))) - CALL ncio_put_attr (fsrfdata, 'SITE_area_type','long_name', 'area percentage of each character') - ENDIF - - END SUBROUTINE write_surface_data_single - - -!----------------------------------------------------------------------- - SUBROUTINE write_urban_surface_data_single (numurban) - - USE MOD_NetCDFSerial - USE MOD_Namelist - USE MOD_Const_LC - IMPLICIT NONE - - integer, intent(in) :: numurban - - ! Local Variables - character(len=256) :: fsrfdata - integer :: iyear, itime - character(len=8) :: source - - fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc' - - SITE_fgper = 1 - (SITE_fgimp-SITE_froof)/(1-SITE_froof-SITE_flake_urb) - SITE_froof = SITE_froof/(1-SITE_flake_urb) - SITE_fveg_urb = SITE_fveg_urb * 100 - SITE_flake_urb = SITE_flake_urb * 100 - - CALL ncio_create_file (fsrfdata) - - CALL ncio_define_dimension (fsrfdata, 'soil', 8) - - CALL ncio_define_dimension (fsrfdata, 'azi', num_azimuth) - CALL ncio_define_dimension (fsrfdata, 'zen', num_zenith) - CALL ncio_define_dimension (fsrfdata, 'slope_type', num_slope_type) - - CALL ncio_define_dimension (fsrfdata, 'patch', numurban) - - CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year)) - CALL ncio_define_dimension (fsrfdata, 'month', 12) - - CALL ncio_define_dimension (fsrfdata, 'ulev' , 10) - CALL ncio_define_dimension (fsrfdata, 'numsolar', 2 ) - CALL ncio_define_dimension (fsrfdata, 'numrad' , 2 ) - - CALL ncio_write_serial (fsrfdata, 'latitude' , SITE_lat_location) - CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location) - - CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year') - CALL ncio_write_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly, 'month', 'LAI_year') - CALL ncio_write_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly, 'month', 'LAI_year') - CALL ncio_put_attr (fsrfdata, 'TREE_LAI', 'source', trim(datasource(u_site_urblai))) - CALL ncio_put_attr (fsrfdata, 'TREE_SAI', 'source', trim(datasource(u_site_urbsai))) - - CALL ncio_write_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp ) - CALL ncio_write_serial (fsrfdata, 'LUCY_id' , SITE_lucyid ) - CALL ncio_write_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb ) - CALL ncio_write_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb ) - CALL ncio_write_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb ) - CALL ncio_write_serial (fsrfdata, 'WT_ROOF' , SITE_froof ) - CALL ncio_write_serial (fsrfdata, 'HT_ROOF' , SITE_hroof ) - CALL ncio_write_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper ) - CALL ncio_write_serial (fsrfdata, 'BUILDING_HLR' , SITE_hlr ) - CALL ncio_write_serial (fsrfdata, 'POP_DEN' , SITE_popden ) - - CALL ncio_put_attr (fsrfdata, 'PCT_Tree' , 'source', trim(datasource(u_site_fveg ))) - CALL ncio_put_attr (fsrfdata, 'URBAN_TREE_TOP', 'source', trim(datasource(u_site_htopu))) - CALL ncio_put_attr (fsrfdata, 'PCT_Water' , 'source', trim(datasource(u_site_flake))) - CALL ncio_put_attr (fsrfdata, 'WT_ROOF' , 'source', trim(datasource(u_site_froof))) - CALL ncio_put_attr (fsrfdata, 'HT_ROOF' , 'source', trim(datasource(u_site_hroof))) - CALL ncio_put_attr (fsrfdata, 'WTROAD_PERV' , 'source', trim(datasource(u_site_fgper))) - CALL ncio_put_attr (fsrfdata, 'BUILDING_HLR' , 'source', trim(datasource(u_site_hlr ))) - CALL ncio_put_attr (fsrfdata, 'POP_DEN' , 'source', trim(datasource(u_site_pop ))) - - CALL ncio_write_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof ) - CALL ncio_write_serial (fsrfdata, 'EM_WALL' , SITE_em_wall ) - CALL ncio_write_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp ) - CALL ncio_write_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper ) - CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) - CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) - CALL ncio_write_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof ) - CALL ncio_write_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall ) - - CALL ncio_put_attr (fsrfdata, 'EM_ROOF' , 'source', trim(datasource(u_site_emr ))) - CALL ncio_put_attr (fsrfdata, 'EM_WALL' , 'source', trim(datasource(u_site_emw ))) - CALL ncio_put_attr (fsrfdata, 'EM_IMPROAD' , 'source', trim(datasource(u_site_emgimp))) - CALL ncio_put_attr (fsrfdata, 'EM_PERROAD' , 'source', trim(datasource(u_site_emgper))) - CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MAX', 'source', trim(datasource(u_site_tbmax ))) - CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MIN', 'source', trim(datasource(u_site_tbmin ))) - CALL ncio_put_attr (fsrfdata, 'THICK_ROOF' , 'source', trim(datasource(u_site_thickr))) - CALL ncio_put_attr (fsrfdata, 'THICK_WALL' , 'source', trim(datasource(u_site_thickw))) - - CALL ncio_write_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof , 'numrad', 'numsolar') - CALL ncio_write_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall , 'numrad', 'numsolar') - CALL ncio_write_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp , 'numrad', 'numsolar') - CALL ncio_write_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper , 'numrad', 'numsolar') - - CALL ncio_put_attr (fsrfdata, 'ALB_ROOF' , 'source', trim(datasource(u_site_albr ))) - CALL ncio_put_attr (fsrfdata, 'ALB_WALL' , 'source', trim(datasource(u_site_albw ))) - CALL ncio_put_attr (fsrfdata, 'ALB_IMPROAD' , 'source', trim(datasource(u_site_albgimp))) - CALL ncio_put_attr (fsrfdata, 'ALB_PERROAD' , 'source', trim(datasource(u_site_albgper))) - - CALL ncio_write_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof , 'ulev') - CALL ncio_write_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall , 'ulev') - CALL ncio_write_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp , 'ulev') - CALL ncio_write_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof , 'ulev') - CALL ncio_write_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall , 'ulev') - CALL ncio_write_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp , 'ulev') - - CALL ncio_put_attr (fsrfdata, 'CV_ROOF' , 'source', trim(datasource(u_site_cvr ))) - CALL ncio_put_attr (fsrfdata, 'CV_WALL' , 'source', trim(datasource(u_site_cvw ))) - CALL ncio_put_attr (fsrfdata, 'CV_IMPROAD' , 'source', trim(datasource(u_site_cvgimp))) - CALL ncio_put_attr (fsrfdata, 'TK_ROOF' , 'source', trim(datasource(u_site_tkr ))) - CALL ncio_put_attr (fsrfdata, 'TK_WALL' , 'source', trim(datasource(u_site_tkw ))) - CALL ncio_put_attr (fsrfdata, 'TK_IMPROAD' , 'source', trim(datasource(u_site_tkgimp))) - - CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth) - CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', trim(datasource(u_site_lakedepth))) - CALL ncio_put_attr (fsrfdata, 'lakedepth', 'long_name', 'lake depth') - CALL ncio_put_attr (fsrfdata, 'lakedepth', 'units', 'm') - - CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) - CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'long_name', 'albedo of visible of the saturated soil') - - CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) - CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'long_name', 'albedo of visible of the dry soil') - - CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) - CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'long_name', 'albedo of near infrared of the saturated soil') - - CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) - CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', trim(datasource(u_site_soil_bright))) - CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'long_name', 'albedo of near infrared of the dry soil') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', trim(datasource(u_site_vf_quartz_mineral))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'long_name', 'volumetric fraction of quartz within mineral soil') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'source', trim(datasource(u_site_vf_gravels))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'long_name', 'volumetric fraction of gravels') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'source', trim(datasource(u_site_vf_sand))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'long_name', 'volumetric fraction of sand') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'source', trim(datasource(u_site_vf_clay))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'long_name', 'volumetric fraction of clay') - - CALL ncio_write_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'source', trim(datasource(u_site_vf_om))) - CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'long_name', 'volumetric fraction of organic matter') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'source', trim(datasource(u_site_wf_gravels))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'long_name', 'gravimetric fraction of gravels') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'source', trim(datasource(u_site_wf_sand))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'long_name', 'gravimetric fraction of sand') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'source', trim(datasource(u_site_wf_clay))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'long_name', 'gravimetric fraction of clay') - - CALL ncio_write_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'source', trim(datasource(u_site_wf_om))) - CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'long_name', 'gravimetric fraction of om') - - CALL ncio_write_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'source', trim(datasource(u_site_OM_density))) - CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'long_name', 'OM density') - CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'units', 'kg/m3') - - CALL ncio_write_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'source', trim(datasource(u_site_BD_all))) - CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'long_name', 'bulk density of soil (GRAVELS + OM + mineral soils)') - CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'units', 'kg/m3') - - CALL ncio_write_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'source', trim(datasource(u_site_theta_s))) - CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'long_name', 'saturated water content') - CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'units', 'cm3/cm3') - - CALL ncio_write_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'source', trim(datasource(u_site_k_s))) - CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'long_name', 'saturated hydraulic conductivity') - CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'units', 'cm/day') - - CALL ncio_write_serial (fsrfdata, 'soil_csol', SITE_soil_csol(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_csol', 'source', trim(datasource(u_site_csol))) - CALL ncio_put_attr (fsrfdata, 'soil_csol', 'long_name', 'heat capacity of soil solids') - CALL ncio_put_attr (fsrfdata, 'soil_csol', 'units', 'J/(m3 K)') - - CALL ncio_write_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'source', trim(datasource(u_site_tksatu))) - CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'long_name', 'thermal conductivity of saturated unfrozen soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'units', 'W/m-K') - - CALL ncio_write_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'source', trim(datasource(u_site_tksatf))) - CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'long_name', 'thermal conductivity of saturated frozen soil') - CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'units', 'W/m-K') - - CALL ncio_write_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'source', trim(datasource(u_site_tkdry))) - CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'long_name', 'thermal conductivity for dry soil') - CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'units', 'W/(m-K)') - - CALL ncio_write_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'source', trim(datasource(u_site_k_solids))) - CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'long_name', 'thermal conductivity of minerals soil') - CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'units', 'W/m-K') - - CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', trim(datasource(u_site_lambda))) - CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'long_name', 'pore size distribution index (dimensionless)') - - CALL ncio_write_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', trim(datasource(u_site_psi_s))) - CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'long_name', 'matric potential at saturation') - CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'units', 'cm') - -#ifdef vanGenuchten_Mualem_SOIL_MODEL - CALL ncio_write_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'source', trim(datasource(u_site_theta_r))) - CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'long_name', 'residual water content') - CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'units', 'cm3/cm3') - - CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', trim(datasource(u_site_alpha_vgm))) - CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'long_name', 'a parameter corresponding approximately to the inverse of the air-entry value') - - CALL ncio_write_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'source', trim(datasource(u_site_L_vgm))) - CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'long_name', 'pore-connectivity parameter [dimensionless]') - - CALL ncio_write_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'source', trim(datasource(u_site_n_vgm))) - CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'long_name', 'a shape parameter [dimensionless]') - -#endif - - CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', trim(datasource(u_site_BA_alpha))) - CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'long_name', 'alpha in Balland and Arp(2005) thermal conductivity scheme') - - CALL ncio_write_serial (fsrfdata, 'soil_BA_beta', SITE_soil_BA_beta(1:8), 'soil') - CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'source', trim(datasource(u_site_BA_beta))) - CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'long_name', 'beta in Balland and Arp(2005) thermal conductivity scheme') - - IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC - CALL ncio_write_serial (fsrfdata, 'soil_texture ', SITE_soil_texture) - CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'source', trim(datasource(u_site_soil_texture))) - CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'long_name', 'USDA soil texture') - ENDIF - - IF(DEF_USE_BEDROCK)THEN - CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) - CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', trim(datasource(u_site_dbedrock))) - ENDIF - - CALL ncio_write_serial (fsrfdata, 'elevation', SITE_elevation) - CALL ncio_put_attr (fsrfdata, 'elevation', 'source', trim(datasource(u_site_elevation))) - - CALL ncio_write_serial (fsrfdata, 'elvstd', SITE_elvstd) - CALL ncio_put_attr (fsrfdata, 'elvstd', 'source', trim(datasource(u_site_elvstd))) - CALL ncio_put_attr (fsrfdata, 'elvstd', 'long_name', 'standard deviation of elevation') - - CALL ncio_write_serial (fsrfdata, 'sloperatio', SITE_sloperatio) - CALL ncio_put_attr (fsrfdata, 'sloperatio', 'source', trim(datasource(u_site_sloperatio))) - CALL ncio_put_attr (fsrfdata, 'sloperatio', 'long_name', 'slope ratio') - - ! used for downscaling - IF (DEF_USE_Forcing_Downscaling) THEN - CALL ncio_write_serial (fsrfdata, 'SITE_svf', SITE_svf) - CALL ncio_put_attr (fsrfdata, 'SITE_svf','source', trim(datasource(u_site_svf))) - CALL ncio_put_attr (fsrfdata, 'SITE_svf','long_name', 'sky view factor') - - CALL ncio_write_serial (fsrfdata, 'SITE_cur', SITE_cur) - CALL ncio_put_attr (fsrfdata, 'SITE_cur','source', trim(datasource(u_site_cur))) - CALL ncio_put_attr (fsrfdata, 'SITE_cur','long_name', 'curvature') - - CALL ncio_write_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut, 'azi', 'zen') - CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','source', trim(datasource(u_site_sf_lut))) - CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','long_name', 'look up table of shadow factor') - - CALL ncio_write_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type , 'type') - CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','source', trim(datasource(u_site_slp_type))) - CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','long_name', 'topographic slope of each character') - - CALL ncio_write_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type , 'type') - CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','source', trim(datasource(u_site_asp_type))) - CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','long_name', 'topographic aspect of each character') - - CALL ncio_write_serial (fsrfdata, 'SITE_area_type', SITE_area_type, 'type') - CALL ncio_put_attr (fsrfdata, 'SITE_area_type','source', trim(datasource(u_site_area_type))) - CALL ncio_put_attr (fsrfdata, 'SITE_area_type','long_name', 'area percentage of each character') - ENDIF - - END SUBROUTINE write_urban_surface_data_single - - -!----------------------------------------------------------------------- - character(len=18) FUNCTION datasource (is_site) - - IMPLICIT NONE - logical, intent(in) :: is_site - - IF (is_site) THEN - datasource = 'SITE' - ELSE - datasource = 'CoLM 2024 raw data' - ENDIF - - END FUNCTION datasource - - -!----------------------------------------------------------------------- - SUBROUTINE single_srfdata_final () - - IMPLICIT NONE - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (allocated(SITE_pfttyp )) deallocate(SITE_pfttyp ) - IF (allocated(SITE_pctpfts)) deallocate(SITE_pctpfts) -#endif - -#ifdef CROP - IF (allocated(SITE_croptyp)) deallocate(SITE_croptyp) - IF (allocated(SITE_pctcrop)) deallocate(SITE_pctcrop) -#endif - -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (allocated(SITE_htop_pfts)) deallocate(SITE_htop_pfts) -#endif - - IF (allocated(SITE_LAI_monthly)) deallocate(SITE_LAI_monthly) - IF (allocated(SITE_SAI_monthly)) deallocate(SITE_SAI_monthly) -#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (allocated(SITE_LAI_pfts_monthly)) deallocate(SITE_LAI_pfts_monthly) - IF (allocated(SITE_SAI_pfts_monthly)) deallocate(SITE_SAI_pfts_monthly) -#endif - - IF (allocated(SITE_LAI_year)) deallocate(SITE_LAI_year) - IF (allocated(SITE_LAI_8day)) deallocate(SITE_LAI_8day) - - IF (allocated(SITE_soil_vf_quartz_mineral)) deallocate(SITE_soil_vf_quartz_mineral) - IF (allocated(SITE_soil_vf_gravels )) deallocate(SITE_soil_vf_gravels ) - IF (allocated(SITE_soil_vf_sand )) deallocate(SITE_soil_vf_sand ) - IF (allocated(SITE_soil_vf_clay )) deallocate(SITE_soil_vf_clay ) - IF (allocated(SITE_soil_vf_om )) deallocate(SITE_soil_vf_om ) - IF (allocated(SITE_soil_wf_gravels )) deallocate(SITE_soil_wf_gravels ) - IF (allocated(SITE_soil_wf_sand )) deallocate(SITE_soil_wf_sand ) - IF (allocated(SITE_soil_wf_clay )) deallocate(SITE_soil_wf_clay ) - IF (allocated(SITE_soil_wf_om )) deallocate(SITE_soil_wf_om ) - IF (allocated(SITE_soil_OM_density )) deallocate(SITE_soil_OM_density ) - IF (allocated(SITE_soil_BD_all )) deallocate(SITE_soil_BD_all ) - IF (allocated(SITE_soil_theta_s )) deallocate(SITE_soil_theta_s ) - IF (allocated(SITE_soil_k_s )) deallocate(SITE_soil_k_s ) - IF (allocated(SITE_soil_csol )) deallocate(SITE_soil_csol ) - IF (allocated(SITE_soil_tksatu )) deallocate(SITE_soil_tksatu ) - IF (allocated(SITE_soil_tksatf )) deallocate(SITE_soil_tksatf ) - IF (allocated(SITE_soil_tkdry )) deallocate(SITE_soil_tkdry ) - IF (allocated(SITE_soil_k_solids )) deallocate(SITE_soil_k_solids ) - IF (allocated(SITE_soil_psi_s )) deallocate(SITE_soil_psi_s ) - IF (allocated(SITE_soil_lambda )) deallocate(SITE_soil_lambda ) - IF (allocated(SITE_soil_theta_r )) deallocate(SITE_soil_theta_r ) -#ifdef vanGenuchten_Mualem_SOIL_MODEL - IF (allocated(SITE_soil_alpha_vgm )) deallocate(SITE_soil_alpha_vgm ) - IF (allocated(SITE_soil_L_vgm )) deallocate(SITE_soil_L_vgm ) - IF (allocated(SITE_soil_n_vgm )) deallocate(SITE_soil_n_vgm ) -#endif - IF (allocated(SITE_soil_BA_alpha )) deallocate(SITE_soil_BA_alpha ) - IF (allocated(SITE_soil_BA_beta )) deallocate(SITE_soil_BA_beta ) - - IF (allocated(SITE_sf_lut )) deallocate(SITE_sf_lut ) - IF (allocated(SITE_slp_type )) deallocate(SITE_slp_type ) - IF (allocated(SITE_asp_type )) deallocate(SITE_asp_type ) - IF (allocated(SITE_area_type )) deallocate(SITE_area_type ) - - END SUBROUTINE single_srfdata_final - -END MODULE MOD_SingleSrfdata -#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 index a47fa6e21c..c5fe73c5e7 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 @@ -1,5 +1,11 @@ #include +#ifdef MPAS_EMBEDDED_COLM +#define COLM_SPATIAL_LOCAL_RANK mpas_rank +#else +#define COLM_SPATIAL_LOCAL_RANK 0 +#endif + MODULE MOD_SpatialMapping !-------------------------------------------------------------------------------- @@ -91,7 +97,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) USE MOD_DataType USE MOD_Mesh USE MOD_Utils - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -120,11 +126,8 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) logical :: skip, is_new -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,"(A, I0, A, I0, A)") & 'Making areal weighted mapping between pixel set and grid: ', & @@ -196,7 +199,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) #endif - IF (p_is_compute) THEN + IF (.true.) THEN this%npset = pixelset%nset @@ -295,9 +298,15 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) area = areaquad (lat_s, lat_n, lon_w, lon_e) - CALL insert_into_sorted_list2 ( ix, iy, & - gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & - iloc, is_new) + IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN + CALL expand_list (gfrom(iset)%ilat, 0.2_r8) + CALL expand_list (gfrom(iset)%ilon, 0.2_r8) + CALL expand_list (afrac(iset)%val, 0.2_r8) + ENDIF + + CALL insert_into_sorted_list2 ( ix, iy, & + gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & + iloc, is_new) IF (is_new) THEN IF (iloc < gfrom(iset)%ng) THEN @@ -310,18 +319,11 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) afrac(iset)%val(iloc) = afrac(iset)%val(iloc) + area ENDIF - IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN - CALL expand_list (gfrom(iset)%ilat, 0.2_r8) - CALL expand_list (gfrom(iset)%ilon, 0.2_r8) - CALL expand_list (afrac(iset)%val, 0.2_r8) - ENDIF - - CALL insert_into_sorted_list1 ( & - ix, ng_lat(iy), list_lat(iy)%val, iloc) - - IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN - CALL expand_list (list_lat(iy)%val, 0.2_r8) - ENDIF + IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN + CALL expand_list (list_lat(iy)%val, 0.2_r8) + ENDIF + CALL insert_into_sorted_list1 ( & + ix, ng_lat(iy), list_lat(iy)%val, iloc) ENDIF @@ -357,24 +359,11 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDDO deallocate (list_lat) -#ifdef USEMPI - allocate (ipt (ng_all)) - allocate (msk (ng_all)) - DO ig = 1, ng_all - xblk = fgrid%xblk(xlist(ig)) - yblk = fgrid%yblk(ylist(ig)) - ipt(ig) = gblock%pio(xblk,yblk) - ENDDO -#endif - allocate (this%glist (0:p_np_active-1)) - DO iproc = 0, p_np_active-1 -#ifdef USEMPI - msk = (ipt == p_address_active(iproc)) - ng = count(msk) -#else - ng = ng_all -#endif + allocate (this%glist (0:mpas_size-1)) + DO iproc = 0, mpas_size-1 + ng = 0 + IF (iproc == COLM_SPATIAL_LOCAL_RANK) ng = ng_all this%glist(iproc)%ng = ng @@ -382,20 +371,11 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) allocate (this%glist(iproc)%ilat (ng)) allocate (this%glist(iproc)%ilon (ng)) -#ifdef USEMPI - this%glist(iproc)%ilon = pack(xlist, msk) - this%glist(iproc)%ilat = pack(ylist, msk) -#else this%glist(iproc)%ilon = xlist this%glist(iproc)%ilat = ylist -#endif ENDIF ENDDO -#ifdef USEMPI - deallocate (ipt) - deallocate (msk) -#endif allocate (this%address (pixelset%nset)) allocate (this%areapart (pixelset%nset)) @@ -423,11 +403,7 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) xblk = fgrid%xblk(ilon) yblk = fgrid%yblk(ilat) -#ifdef USEMPI - iproc = p_itis_active(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif + iproc = COLM_SPATIAL_LOCAL_RANK this%address(iset)%val(1,ig) = iproc this%address(iset)%val(2,ig) = find_in_sorted_list2 ( & @@ -449,56 +425,8 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDIF -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - IF (p_is_compute) THEN - - DO iproc = 0, p_np_active-1 - idest = p_address_active(iproc) - smesg = (/p_iam_glb, this%glist(iproc)%ng/) - - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iproc)%ng > 0) THEN - CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO - - ENDIF - - IF (p_is_active) THEN - - allocate (this%glist (0:p_np_compute-1)) - - DO irank = 0, p_np_compute-1 - - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_compute(isrc) - - this%glist(iproc)%ng = nrecv - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - ENDDO - - ENDIF -#endif - IF (p_is_compute) THEN + IF (.true.) THEN IF (this%npset > 0) THEN allocate (this%areapset (this%npset)) this%areapset(:) = 0. @@ -510,8 +438,9 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) ENDDO ENDIF - IF (p_is_active) CALL allocate_block_data (fgrid, this%areagrid) - IF (p_is_compute) THEN +#ifndef MPAS_EMBEDDED_COLM + IF (.true.) CALL allocate_block_data (fgrid, this%areagrid) + IF (.true.) THEN IF (this%npset > 0) THEN allocate (msk (this%npset)) msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 @@ -520,11 +449,9 @@ SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) CALL this%get_sumarea (this%areagrid, msk) IF (allocated(msk)) deallocate(msk) +#endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif END SUBROUTINE spatial_mapping_build_arealweighted @@ -540,7 +467,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) USE MOD_Mesh USE MOD_Pixelset USE MOD_Utils - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: pi IMPLICIT NONE @@ -568,11 +495,8 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) real(r8) :: lon, lonw, lone, latn, lats real(r8) :: distn, dists, distw, diste, diffw, diffe, areathis -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) write(*,"(A, I0, A, I0, A)") & @@ -609,7 +533,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt - IF (p_is_compute) THEN + IF (.true.) THEN allocate (this%grid%lat_s(this%grid%nlat)); this%grid%lat_s = fgrid%lat_s allocate (this%grid%lat_n(this%grid%nlat)); this%grid%lat_n = fgrid%lat_n @@ -739,24 +663,11 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDDO -#ifdef USEMPI - allocate (ipt (nglist)) - allocate (msk (nglist)) - DO ig = 1, nglist - xblk = this%grid%xblk(xlist(ig)) - yblk = this%grid%yblk(ylist(ig)) - ipt(ig) = gblock%pio(xblk,yblk) - ENDDO -#endif - allocate (this%glist (0:p_np_active-1)) - DO iproc = 0, p_np_active-1 -#ifdef USEMPI - msk = (ipt == p_address_active(iproc)) - ng = count(msk) -#else - ng = nglist -#endif + allocate (this%glist (0:mpas_size-1)) + DO iproc = 0, mpas_size-1 + ng = 0 + IF (iproc == COLM_SPATIAL_LOCAL_RANK) ng = nglist this%glist(iproc)%ng = ng @@ -764,13 +675,8 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) allocate (this%glist(iproc)%ilat (ng)) allocate (this%glist(iproc)%ilon (ng)) -#ifdef USEMPI - this%glist(iproc)%ilon = pack(xlist(1:nglist), msk) - this%glist(iproc)%ilat = pack(ylist(1:nglist), msk) -#else this%glist(iproc)%ilon = xlist(1:nglist) this%glist(iproc)%ilat = ylist(1:nglist) -#endif ENDIF ENDDO @@ -778,63 +684,10 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) deallocate (xlist) deallocate (ylist) -#ifdef USEMPI - deallocate (ipt) - deallocate (msk) -#endif - ENDIF - -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 - idest = p_address_active(iproc) - smesg = (/p_iam_glb, this%glist(iproc)%ng/) - - CALL mpi_send (smesg, 2, MPI_INTEGER, & - idest, mpi_tag_mesg, p_comm_glb, p_err) - - IF (this%glist(iproc)%ng > 0) THEN - CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO ENDIF - IF (p_is_active) THEN - - allocate (this%glist (0:p_np_compute-1)) - - DO irank = 0, p_np_compute-1 - CALL mpi_recv (rmesg, 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - - isrc = rmesg(1) - nrecv = rmesg(2) - iproc = p_itis_compute(isrc) - - this%glist(iproc)%ng = nrecv - - IF (nrecv > 0) THEN - allocate (this%glist(iproc)%ilon (nrecv)) - allocate (this%glist(iproc)%ilat (nrecv)) - - CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF - - ENDDO - - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_compute) THEN + IF (.true.) THEN allocate (this%address (this%npset)) allocate (this%npart (this%npset)) @@ -872,13 +725,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ! northwest grid ix = xw(iset); iy = yn(iset); -#ifdef USEMPI - xblk = this%grid%xblk(ix) - yblk = this%grid%yblk(iy) - iproc = p_itis_active(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif + iproc = COLM_SPATIAL_LOCAL_RANK this%address(iset)%val(1,1) = iproc this%address(iset)%val(2,1) = find_in_sorted_list2 ( ix, iy, & this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) @@ -887,13 +734,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ! northeast grid ix = xe(iset); iy = yn(iset); -#ifdef USEMPI - xblk = this%grid%xblk(ix) - yblk = this%grid%yblk(iy) - iproc = p_itis_active(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif + iproc = COLM_SPATIAL_LOCAL_RANK this%address(iset)%val(1,2) = iproc this%address(iset)%val(2,2) = find_in_sorted_list2 ( ix, iy, & this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) @@ -902,13 +743,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ! southwest ix = xw(iset); iy = ys(iset); -#ifdef USEMPI - xblk = this%grid%xblk(ix) - yblk = this%grid%yblk(iy) - iproc = p_itis_active(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif + iproc = COLM_SPATIAL_LOCAL_RANK this%address(iset)%val(1,3) = iproc this%address(iset)%val(2,3) = find_in_sorted_list2 ( ix, iy, & this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) @@ -917,13 +752,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ! southeast ix = xe(iset); iy = ys(iset); -#ifdef USEMPI - xblk = this%grid%xblk(ix) - yblk = this%grid%yblk(iy) - iproc = p_itis_active(gblock%pio(xblk,yblk)) -#else - iproc = 0 -#endif + iproc = COLM_SPATIAL_LOCAL_RANK this%address(iset)%val(1,4) = iproc this%address(iset)%val(2,4) = find_in_sorted_list2 ( ix, iy, & this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) @@ -934,7 +763,7 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN IF (this%npset > 0) THEN allocate (this%areapset (this%npset)) ENDIF @@ -943,14 +772,16 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) ENDDO ENDIF - IF (p_is_active) CALL allocate_block_data (fgrid, this%areagrid) - IF (p_is_compute) THEN +#ifndef MPAS_EMBEDDED_COLM + IF (.true.) CALL allocate_block_data (fgrid, this%areagrid) + IF (.true.) THEN IF (this%npset > 0) THEN allocate (msk (this%npset)) msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 ENDIF ENDIF CALL this%get_sumarea (this%areagrid, msk) +#endif IF (allocated(this%grid%lat_s)) deallocate(this%grid%lat_s) @@ -975,9 +806,6 @@ SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) IF (allocated(msk)) deallocate(msk) -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif END SUBROUTINE spatial_mapping_build_bilinear @@ -988,7 +816,7 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -1008,9 +836,9 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) this%has_missing_value = .true. this%missing_value = missing_value - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -1027,13 +855,6 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) ENDDO -#ifdef USEMPI - idest = p_address_compute(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif ENDIF ENDDO @@ -1048,23 +869,17 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_active(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff deallocate (gbuff) -#endif ENDIF ENDDO @@ -1090,7 +905,7 @@ SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) ENDDO - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1107,7 +922,7 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -1129,14 +944,14 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod character(len=256) :: inmode real(r8) :: sumwt - IF (p_is_compute) THEN + IF (.true.) THEN inmode = 'average' IF (present(input_mode)) inmode = trim(input_mode) - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) @@ -1183,19 +998,10 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod ENDDO ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN IF (present(spv)) THEN CALL flush_block_data (gdata, spv) @@ -1203,18 +1009,12 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod CALL flush_block_data (gdata, 0.0_r8) ENDIF - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng IF (present(spv)) THEN @@ -1252,8 +1052,8 @@ SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mod ENDIF - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1270,7 +1070,7 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -1291,14 +1091,14 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) type(pointer_real8_2d), allocatable :: pbuff(:) - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) lb1 = lbound(pdata,1) ub1 = ubound(pdata,1) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (lb1:ub1, this%glist(iproc)%ng)) @@ -1338,21 +1138,10 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) ENDDO ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, & - (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN lb1 = gdata%lb1 ub1 = gdata%ub1 @@ -1363,19 +1152,12 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) CALL flush_block_data (gdata, 0.0_r8) ENDIF - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (lb1:ub1, this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, & - (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng ilon = this%glist(iproc)%ilon(ig) @@ -1409,8 +1191,8 @@ SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1426,7 +1208,7 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -1446,9 +1228,9 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) real(r8), allocatable :: gbuff(:,:,:) type(pointer_real8_3d), allocatable :: pbuff(:) - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) lb1 = lbound(pdata,1) ub1 = ubound(pdata,1) @@ -1458,7 +1240,7 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ub2 = ubound(pdata,2) ndim2 = ub2 - lb2 + 1 - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) @@ -1500,19 +1282,10 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ENDDO ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN lb1 = gdata%lb1 ub1 = gdata%ub1 @@ -1528,18 +1301,12 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) CALL flush_block_data (gdata, 0.0_r8) ENDIF - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng ilon = this%glist(iproc)%ilon(ig) @@ -1573,8 +1340,8 @@ SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) ENDDO ENDIF - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1590,7 +1357,7 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -1609,11 +1376,11 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) pbuff(iproc)%val(:) = spval @@ -1642,34 +1409,19 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) ENDDO ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN CALL flush_block_data (gdata, spval) - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng IF (gbuff(ig) /= spval) THEN @@ -1695,8 +1447,8 @@ SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) ENDIF - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1712,7 +1464,7 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -1732,16 +1484,16 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff (:) - IF (p_is_compute) THEN - allocate (pbuff (0:p_np_active-1)) - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + allocate (pbuff (0:mpas_size-1)) + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) ENDIF ENDDO ENDIF - IF (p_is_active) THEN + IF (.true.) THEN CALL flush_block_data (gdata, spv) ENDIF @@ -1749,9 +1501,9 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, DO ityp = 1, ntyps - IF (p_is_compute) THEN + IF (.true.) THEN - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN pbuff(iproc)%val(:) = spv ENDIF @@ -1774,32 +1526,17 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, ENDIF ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng IF (gbuff(ig) /= spv) THEN @@ -1826,13 +1563,10 @@ SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif ENDDO - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1848,7 +1582,7 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -1864,9 +1598,9 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) type(pointer_real8_1d), allocatable :: pbuff(:) #ifdef MPAS_EMBEDDED_COLM - IF (p_is_active) CALL flush_block_data (sumarea, 0.0_r8) + IF (.true.) CALL flush_block_data (sumarea, 0.0_r8) - IF (p_is_compute) THEN + IF (.true.) THEN DO iset = 1, this%npset IF (present(filter)) THEN @@ -1875,7 +1609,7 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) DO ipart = 1, this%npart(iset) iproc = this%address(iset)%val(1,ipart) - IF (p_address_active(iproc) /= p_iam_glb) CYCLE + IF (iproc /= mpas_rank) CYCLE iloc = this%address(iset)%val(2,ipart) ilon = this%glist(iproc)%ilon(iloc) @@ -1894,11 +1628,11 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) RETURN #endif - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) pbuff(iproc)%val(:) = 0.0 @@ -1918,34 +1652,19 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) ENDDO ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN CALL flush_block_data (sumarea, 0.0_r8) - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng ilon = this%glist(iproc)%ilon(ig) @@ -1965,8 +1684,8 @@ SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) ENDIF - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -1983,7 +1702,7 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) USE MOD_Grid USE MOD_Pixelset USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -1999,9 +1718,9 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2018,35 +1737,22 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) ENDDO -#ifdef USEMPI - idest = p_address_compute(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif ENDIF ENDDO ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_active(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff deallocate (gbuff) -#endif ENDIF ENDDO @@ -2074,7 +1780,7 @@ SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) ENDDO - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2092,7 +1798,7 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) USE MOD_Grid USE MOD_Pixelset USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -2110,9 +1816,9 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) type(pointer_real8_2d), allocatable :: pbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (ndim1, this%glist(iproc)%ng)) @@ -2128,35 +1834,22 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) gbuff(:,ig) = gdata%blk(xblk,yblk)%val(:,xloc,yloc) ENDDO -#ifdef USEMPI - idest = p_address_compute(iproc) - CALL mpi_send (gbuff, ndim1 * this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif ENDIF ENDDO ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_active(iproc) - CALL mpi_recv (pbuff(iproc)%val, ndim1 * this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff deallocate (gbuff) -#endif ENDIF ENDDO @@ -2185,7 +1878,7 @@ SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) ENDDO - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2203,7 +1896,7 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) USE MOD_Grid USE MOD_Pixelset USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -2219,9 +1912,9 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) integer, allocatable :: gbuff(:) type(pointer_int32_1d), allocatable :: pbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2238,35 +1931,22 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) ENDDO -#ifdef USEMPI - idest = p_address_compute(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif ENDIF ENDDO ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_active(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff deallocate (gbuff) -#endif ENDIF ENDDO @@ -2281,7 +1961,7 @@ SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) ENDIF ENDDO - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2300,7 +1980,7 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) USE MOD_Grid USE MOD_Pixelset USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -2317,9 +1997,9 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) type(pointer_real8_1d), allocatable :: pbuff(:) real(r8), allocatable :: pdata_tem(:) - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2336,36 +2016,23 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) ENDDO -#ifdef USEMPI - idest = p_address_compute(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif ENDIF ENDDO ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) allocate (pdata_tem (size(pdata))) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_active(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff deallocate (gbuff) -#endif ENDIF ENDDO @@ -2393,7 +2060,7 @@ SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) pdata = pdata_tem - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2412,7 +2079,7 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) USE MOD_Grid USE MOD_Pixelset USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -2428,9 +2095,9 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_active) THEN + IF (.true.) THEN - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) @@ -2447,35 +2114,22 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) ENDDO -#ifdef USEMPI - idest = p_address_compute(iproc) - CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (gbuff) -#endif ENDIF ENDDO ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_active(iproc) - CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - pbuff(0)%val = gbuff + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff deallocate (gbuff) -#endif ENDIF ENDDO @@ -2488,7 +2142,7 @@ SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) ENDDO ENDDO - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2506,7 +2160,7 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) USE MOD_Block USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -2522,11 +2176,11 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) real(r8), allocatable :: gbuff(:) type(pointer_real8_1d), allocatable :: pbuff(:) - IF (p_is_compute) THEN + IF (.true.) THEN - allocate (pbuff (0:p_np_active-1)) + allocate (pbuff (0:mpas_size-1)) - DO iproc = 0, p_np_active-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) pbuff(iproc)%val(:) = 0.0 @@ -2543,34 +2197,19 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) ENDDO ENDDO -#ifdef USEMPI - DO iproc = 0, p_np_active-1 - IF (this%glist(iproc)%ng > 0) THEN - idest = p_address_active(iproc) - CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - ENDIF - ENDDO -#endif ENDIF - IF (p_is_active) THEN + IF (.true.) THEN CALL flush_block_data (gdata, 0.0_r8) - DO iproc = 0, p_np_compute-1 + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN allocate (gbuff (this%glist(iproc)%ng)) -#ifdef USEMPI - isrc = p_address_compute(iproc) - CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) -#else - gbuff = pbuff(0)%val -#endif + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val DO ig = 1, this%glist(iproc)%ng ilon = this%glist(iproc)%ilon(ig) @@ -2602,8 +2241,8 @@ SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) ENDIF - IF (p_is_compute) THEN - DO iproc = 0, p_np_active-1 + IF (.true.) THEN + DO iproc = 0, mpas_size-1 IF (this%glist(iproc)%ng > 0) THEN deallocate (pbuff(iproc)%val) ENDIF @@ -2621,7 +2260,7 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) USE MOD_Grid USE MOD_Pixelset USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -2637,12 +2276,12 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) type(pointer_real8_1d), allocatable :: scaldata(:) - IF (p_is_active) CALL allocate_block_data (this%grid, sumdata) - IF (p_is_compute) CALL this%allocate_part (scaldata) + IF (.true.) CALL allocate_block_data (this%grid, sumdata) + IF (.true.) CALL this%allocate_part (scaldata) CALL this%part2grid (sdata, sumdata) - IF (p_is_active) THEN + IF (.true.) THEN DO iblkme = 1, gblock%nblkme xblk = gblock%xblkme(iblkme) @@ -2657,7 +2296,7 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) CALL this%grid2part (sumdata, scaldata) - IF (p_is_compute) THEN + IF (.true.) THEN DO iset = 1, this%npset DO ipart = 1, this%npart(iset) @@ -2671,7 +2310,7 @@ SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) ENDIF - IF (p_is_compute) deallocate(scaldata) + IF (.true.) deallocate(scaldata) END SUBROUTINE spatial_mapping_normalize @@ -2681,7 +2320,7 @@ SUBROUTINE spatial_mapping_part2pset (this, sdata, pdata) USE MOD_Precision USE MOD_Grid USE MOD_DataType - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Vars_Global, only: spval IMPLICIT NONE @@ -2693,7 +2332,7 @@ SUBROUTINE spatial_mapping_part2pset (this, sdata, pdata) ! Local variables integer :: iset - IF (p_is_compute) THEN + IF (.true.) THEN pdata(:) = spval @@ -2710,7 +2349,7 @@ END SUBROUTINE spatial_mapping_part2pset !----------------------------------------------------- SUBROUTINE spatial_mapping_allocate_part (this, datapart) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_DataType IMPLICIT NONE @@ -2721,7 +2360,7 @@ SUBROUTINE spatial_mapping_allocate_part (this, datapart) ! Local variables integer :: iset - IF (p_is_compute) THEN + IF (.true.) THEN IF (this%npset > 0) THEN allocate (datapart (this%npset)) @@ -2740,7 +2379,7 @@ END SUBROUTINE spatial_mapping_allocate_part !----------------------------------------------------- SUBROUTINE spatial_mapping_deallocate_part (this, datapart) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_DataType IMPLICIT NONE @@ -2751,7 +2390,7 @@ SUBROUTINE spatial_mapping_deallocate_part (this, datapart) ! Local variables integer :: iset - IF (p_is_compute) THEN + IF (.true.) THEN DO iset = 1, this%npset IF (this%npart(iset) > 0) THEN @@ -2770,7 +2409,7 @@ END SUBROUTINE spatial_mapping_deallocate_part !----------------------------------------------------- SUBROUTINE spatial_mapping_free_mem (this) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE type (spatial_mapping_type) :: this @@ -2796,7 +2435,7 @@ SUBROUTINE spatial_mapping_free_mem (this) deallocate (this%glist) ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN IF (allocated(this%npart)) deallocate(this%npart) @@ -2828,7 +2467,7 @@ END SUBROUTINE spatial_mapping_free_mem SUBROUTINE forc_free_mem_spatial_mapping(this) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI IMPLICIT NONE class (spatial_mapping_type) :: this @@ -2854,7 +2493,7 @@ SUBROUTINE forc_free_mem_spatial_mapping(this) deallocate (this%glist) ENDIF - IF (p_is_compute) THEN + IF (.true.) THEN IF (allocated(this%npart)) deallocate(this%npart) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 index f56f51a1f0..06fa3b5f95 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -12,253 +12,17 @@ MODULE MOD_SrfdataRestart IMPLICIT NONE ! ----- subroutines ----- - PUBLIC :: mesh_save_to_file PUBLIC :: mesh_load_from_file - PUBLIC :: pixelset_save_to_file PUBLIC :: pixelset_load_from_file CONTAINS - ! ----------------------- - SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) - - USE MOD_SPMD_Task - USE MOD_NetCDFSerial - USE MOD_Mesh - USE MOD_Block - USE MOD_Utils - IMPLICIT NONE - - character(len=*), intent(in) :: dir_landdata - integer , intent(in) :: lc_year - - ! Local variables - character(len=256) :: filename, fileblock, cyear - integer :: ie, je, nelm, totlen, tothis, iblk, jblk, owner_rank, i - integer, allocatable :: nelm_rank(:), ndsp_rank(:) - integer*8, allocatable :: elmindx(:) - integer, allocatable :: npxlall(:) - integer, allocatable :: elmpixels(:,:) - real(r8), allocatable :: lon(:), lat(:) - - integer :: nsend, nrecv, ndone, ndsp - -#ifdef MPAS_EMBEDDED_COLM - CALL CoLM_stop('MPAS embedded CoLM does not support standalone mesh_save_to_file.') -#endif - - ! add parameter input for time year - write(cyear,'(i4.4)') lc_year -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) THEN - write(*,*) 'Saving land elements ...' - CALL system('mkdir -p ' // trim(dir_landdata) // '/mesh/' // trim(cyear)) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - filename = trim(dir_landdata) // '/mesh/' //trim(cyear) // '/mesh.nc' - - DO jblk = 1, gblock%nyblk - DO iblk = 1, gblock%nxblk - -#ifdef USEMPI - IF (p_is_compute) THEN - IF (gblock%pio(iblk,jblk) == p_address_active(p_my_group)) THEN -#endif - nelm = 0 - totlen = 0 - DO ie = 1, numelm - IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN - nelm = nelm + 1 - totlen = totlen + mesh(ie)%npxl - ENDIF - ENDDO - - IF (nelm > 0) THEN - - allocate (elmindx (nelm)) - allocate (npxlall (nelm)) - allocate (elmpixels (2,totlen)) - - je = 0 - ndsp = 0 - DO ie = 1, numelm - IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN - je = je + 1 - elmindx(je) = mesh(ie)%indx - npxlall(je) = mesh(ie)%npxl - - elmpixels(1,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilon - elmpixels(2,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilat - - ndsp = ndsp + npxlall(je) - ENDIF - ENDDO - ENDIF - -#ifdef USEMPI - CALL mpi_gather (nelm, 1, MPI_INTEGER, & - MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err) - - CALL mpi_gatherv (elmindx, nelm, MPI_INTEGER8, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - CALL mpi_gatherv (npxlall, nelm, MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks - p_root, p_comm_group, p_err) - - ndone = 0 - DO WHILE (ndone < totlen) - nsend = max(min(totlen-ndone, MesgMaxSize/8), 1) - CALL mpi_send (nsend, 1, & - MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_err) - CALL mpi_send (elmpixels(:,ndone+1:ndone+nsend), 2*nsend, & - MPI_INTEGER, p_root, mpi_tag_data, p_comm_group, p_err) - ndone = ndone + nsend - ENDDO - ENDIF - ENDIF -#endif - -#ifdef USEMPI - IF (p_is_active) THEN - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - - allocate (nelm_rank (0:p_np_group-1)) - nelm_rank(0) = 0 - CALL mpi_gather (MPI_IN_PLACE, 0, MPI_INTEGER, & - nelm_rank, 1, MPI_INTEGER, p_root, p_comm_group, p_err) - - nelm = sum(nelm_rank) - - allocate (ndsp_rank(0:p_np_group-1)) - ndsp_rank(0) = 0 - DO owner_rank = 1, p_np_group-1 - ndsp_rank(owner_rank) = ndsp_rank(owner_rank-1) + nelm_rank(owner_rank-1) - ENDDO - - allocate (elmindx (nelm)) - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & - elmindx, nelm_rank(0:), ndsp_rank(0:), MPI_INTEGER8, & - p_root, p_comm_group, p_err) - - allocate (npxlall (nelm)) - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & - npxlall, nelm_rank(0:), ndsp_rank(0:), MPI_INTEGER, & - p_root, p_comm_group, p_err) - - totlen = sum(npxlall) - allocate (elmpixels (2, totlen)) - - ndone = 0 - DO owner_rank = 1, p_np_group-1 - - ndsp = ndsp_rank(owner_rank) - tothis = ndone + sum(npxlall(ndsp+1:ndsp+nelm_rank(owner_rank))) - - DO WHILE (ndone < tothis) - - CALL mpi_recv (nrecv, 1, & - MPI_INTEGER, owner_rank, mpi_tag_size, p_comm_group, p_stat, p_err) - CALL mpi_recv (elmpixels(:,ndone+1:ndone+nrecv), 2*nrecv, & - MPI_INTEGER, owner_rank, mpi_tag_data, p_comm_group, p_stat, p_err) - - ndone = ndone + nrecv - ENDDO - ENDDO - ENDIF - ENDIF -#endif - - IF (p_is_active) THEN - IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - IF (nelm > 0) THEN - CALL get_filename_block (filename, iblk, jblk, fileblock) - CALL ncio_create_file (fileblock) - - CALL ncio_define_dimension (fileblock, 'element',nelm) - CALL ncio_define_dimension (fileblock, 'ncoor', 2 ) - CALL ncio_define_dimension (fileblock, 'pixel', totlen) - - CALL ncio_write_serial (fileblock, 'elmindex', elmindx, 'element') - CALL ncio_write_serial (fileblock, 'elmnpxl', npxlall, 'element') - CALL ncio_write_serial (fileblock, 'elmpixels', elmpixels, & - 'ncoor', 'pixel', compress = 1) - ENDIF - ENDIF - ENDIF - - IF (allocated (elmindx)) deallocate(elmindx) - IF (allocated (npxlall)) deallocate(npxlall) - IF (allocated (elmpixels)) deallocate(elmpixels) - - IF (allocated (nelm_rank)) deallocate(nelm_rank) - IF (allocated (ndsp_rank)) deallocate(ndsp_rank) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_group, p_err) -#endif - ENDDO - ENDDO - - IF (p_is_root) THEN - - CALL ncio_create_file (filename) - - CALL ncio_define_dimension (filename, 'xblk', gblock%nxblk) - CALL ncio_define_dimension (filename, 'yblk', gblock%nyblk) - CALL ncio_write_serial (filename, 'nelm_blk', nelm_blk, 'xblk', 'yblk') - - CALL ncio_define_dimension (filename, 'longitude', gridmesh%nlon) - CALL ncio_define_dimension (filename, 'latitude' , gridmesh%nlat) - - allocate (lon (gridmesh%nlon)) - allocate (lat (gridmesh%nlat)) - - DO i = 1, gridmesh%nlon - lon(i) = (gridmesh%lon_w(i) + gridmesh%lon_e(i)) * 0.5 - IF (gridmesh%lon_w(i) > gridmesh%lon_e(i)) THEN - lon(i) = lon(i) + 180.0 - CALL normalize_longitude (lon(i)) - ENDIF - ENDDO - CALL ncio_write_serial (filename, 'longitude', lon, 'longitude') - - DO i = 1, gridmesh%nlat - lat(i) = (gridmesh%lat_s(i) + gridmesh%lat_n(i)) * 0.5 - ENDDO - CALL ncio_write_serial (filename, 'latitude', lat, 'latitude') - -#ifdef GRIDBASED - CALL ncio_write_serial (filename, 'lat_s', gridmesh%lat_s, 'latitude' ) - CALL ncio_write_serial (filename, 'lat_n', gridmesh%lat_n, 'latitude' ) - CALL ncio_write_serial (filename, 'lon_w', gridmesh%lon_w, 'longitude') - CALL ncio_write_serial (filename, 'lon_e', gridmesh%lon_e, 'longitude') -#endif - - deallocate (lon) - deallocate (lat) - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_root) write(*,*) 'SAVE land elements done.' - - END SUBROUTINE mesh_save_to_file - !------------------------------------ SUBROUTINE prepare_subset_eindex(subset_eindex, sorted_subset) USE MOD_Utils, only: quicksort + USE MOD_MPAS_MPI, only: CoLM_stop IMPLICIT NONE integer*8, intent(in) :: subset_eindex(:) @@ -275,6 +39,10 @@ SUBROUTINE prepare_subset_eindex(subset_eindex, sorted_subset) order = (/ (i, i = 1, size(sorted_subset)) /) CALL quicksort(size(sorted_subset), sorted_subset, order) deallocate(order) + + IF (any(sorted_subset(2:) == sorted_subset(:size(sorted_subset)-1))) THEN + CALL CoLM_stop('MPAS supplied duplicate owned cell IDs to embedded CoLM.') + ENDIF ENDIF END SUBROUTINE prepare_subset_eindex @@ -318,7 +86,7 @@ END FUNCTION count_subset_eindex !------------------------------------ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Namelist USE MOD_Block USE MOD_NetCDFSerial @@ -339,25 +107,29 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) logical, allocatable :: keep_elm(:) logical :: use_subset -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('mesh-load entry synchronization') #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) 'Loading land elements ...' ENDIF ! add parameter input for time year write(cyear,'(i4.4)') lc_year filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' + IF (.true.) CALL mesh_free_mem() CALL ncio_read_bcast_serial (filename, 'nelm_blk', nelm_blk) use_subset = present(subset_eindex) IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) - IF (p_is_active) THEN - - CALL mesh_free_mem() - numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb) + IF (.true.) THEN + IF (use_subset) THEN + numelm = size(subset_eindex) + ELSE + numelm = sum(nelm_blk, mask = gblock%owner_rank == mpas_rank) + ENDIF IF (numelm > 0) THEN @@ -377,6 +149,13 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) CALL ncio_read_serial (fileblock, 'elmindex', elmindx) CALL ncio_read_serial (fileblock, 'elmnpxl', npxl ) + IF (size(elmindx) /= nelm .or. size(npxl) /= nelm) THEN + CALL CoLM_stop('CoLM mesh block metadata lengths disagree with nelm_blk: '//trim(fileblock)) + ENDIF + IF (any(npxl < 1)) THEN + CALL CoLM_stop('CoLM mesh block contains an element with no pixels: '//trim(fileblock)) + ENDIF + IF (use_subset) THEN allocate (keep_elm(nelm)) DO ie = 1, nelm @@ -393,8 +172,17 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) CALL ncio_inquire_varsize (fileblock, 'elmpixels', datasize) IF (size(datasize) == 3) THEN CALL ncio_read_serial (fileblock, 'elmpixels', pixels2d) - ELSE + IF (size(pixels2d,1) < 2 .or. size(pixels2d,3) < nelm .or. & + size(pixels2d,2) < maxval(npxl)) THEN + CALL CoLM_stop('CoLM mesh block has inconsistent 3-D elmpixels dimensions: '//trim(fileblock)) + ENDIF + ELSEIF (size(datasize) == 2) THEN CALL ncio_read_serial (fileblock, 'elmpixels', pixels) + IF (size(pixels,1) < 2 .or. size(pixels,2) < sum(npxl)) THEN + CALL CoLM_stop('CoLM mesh block has inconsistent 2-D elmpixels dimensions: '//trim(fileblock)) + ENDIF + ELSE + CALL CoLM_stop('CoLM mesh elmpixels must be a two- or three-dimensional variable: '//trim(fileblock)) ENDIF pdsp = 0 @@ -407,6 +195,9 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDIF ndsp = ndsp + 1 + IF (ndsp > size(mesh)) THEN + CALL CoLM_stop('MPAS embedded CoLM mesh contains duplicate element IDs for an owned cell subset.') + ENDIF mesh(ndsp)%indx = elmindx(ie) mesh(ndsp)%npxl = npxl(ie) mesh(ndsp)%xblk = iblk @@ -434,6 +225,9 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDIF ENDDO + IF (ndsp /= size(mesh)) THEN + CALL CoLM_stop('MPAS embedded CoLM mesh does not contain exactly one element per owned MPAS cell.') + ENDIF numelm = ndsp IF (numelm == 0) CALL mesh_free_mem() ENDIF @@ -456,88 +250,30 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) ENDIF #ifdef CoLMDEBUG - IF (p_is_active) write(*,'(I10,A,I4)') numelm, ' elements on group ', p_iam_active + IF (.true.) write(*,'(I10,A,I4)') numelm, ' elements on group ', mpas_rank #endif -#ifdef USEMPI -#ifndef MPAS_EMBEDDED_COLM - CALL scatter_mesh_legacy_roles -#endif - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('mesh-load completion synchronization') #endif - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) 'Loading land elements done.' ENDIF END SUBROUTINE mesh_load_from_file - !------------------------------------------------ - SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year) - - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Block - USE MOD_NetCDFVector - USE MOD_Pixelset - IMPLICIT NONE - - character(len=*), intent(in) :: dir_landdata - character(len=*), intent(in) :: psetname - type(pixelset_type), intent(in) :: pixelset - integer , intent(in) :: lc_year - - ! Local variables - character(len=256) :: filename, cyear - -#ifdef MPAS_EMBEDDED_COLM - CALL CoLM_stop('MPAS embedded CoLM does not support standalone pixelset_save_to_file.') -#endif - - write(cyear,'(i4.4)') lc_year -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - IF (p_is_root) THEN - write(*,*) 'Saving Pixel Sets ' // trim(psetname) // ' ...' - CALL system('mkdir -p ' // trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear)) - ENDIF -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc' - - CALL ncio_create_file_vector (filename, pixelset) - CALL ncio_define_dimension_vector (filename, pixelset, trim(psetname)) - - CALL ncio_write_vector (filename, 'eindex', trim(psetname), pixelset, pixelset%eindex, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (filename, 'ipxstt', trim(psetname), pixelset, pixelset%ipxstt, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (filename, 'ipxend', trim(psetname), pixelset, pixelset%ipxend, DEF_Srfdata_CompressLevel) - CALL ncio_write_vector (filename, 'settyp', trim(psetname), pixelset, pixelset%settyp, DEF_Srfdata_CompressLevel) - - IF (pixelset%has_shared) THEN - CALL ncio_write_vector (filename, 'pctshared', trim(psetname), pixelset, pixelset%pctshared, DEF_Srfdata_CompressLevel) - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_root) write(*,*) 'SAVE Pixel Sets ' // trim(psetname) // ' done.' - - END SUBROUTINE pixelset_save_to_file - - !--------------------------- SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc_year, subset_eindex) - USE MOD_SPMD_Task + USE MOD_MPAS_MPI USE MOD_Block USE MOD_NetCDFSerial USE MOD_NetCDFVector USE MOD_Mesh USE MOD_Pixelset + USE MOD_Utils, only: quicksort, find_in_sorted_list1 IMPLICIT NONE integer , intent(in) :: lc_year @@ -548,26 +284,29 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc integer*8, optional, intent(in) :: subset_eindex(:) ! Local variables - character(len=256) :: filename, fileblock, blockname, cyear - integer :: iset, nset, nset_file, ndsp, iblkme, iblk, jblk, ie, je, nave, nres, left, iproc, ipos - integer :: nsend, nrecv - integer*8, allocatable :: rbuff(:), sbuff(:) + character(len=256) :: filename, fileblock, cyear +#if (defined VectorInOneFileS || defined VectorInOneFileP) + character(len=256) :: blockname +#endif + integer :: iset, nset, nset_file, ndsp, iblkme, iblk, jblk, ie, ipos + integer :: match + integer*8, allocatable :: rbuff(:), mesh_sorted(:) integer*8, allocatable :: subset_sorted(:) - integer, allocatable :: owner_rank(:) - logical, allocatable :: msk(:) + integer, allocatable :: mesh_order(:) logical, allocatable :: keep_set(:) logical :: fexists, fexists_any logical :: use_subset write(cyear,'(i4.4)') lc_year -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('pixelset-load entry synchronization') #endif use_subset = present(subset_eindex) IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) - IF (p_is_root) THEN + IF (mpas_is_root) THEN write(*,*) 'Loading Pixel Sets ' // trim(psetname) // ' ...' ENDIF @@ -575,7 +314,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc CALL pixelset%forc_free_mem() - IF (p_is_active) THEN + IF (.true.) THEN pixelset%nset = 0 @@ -619,8 +358,9 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc inquire(file=trim(filename), exist=fexists_any) #endif -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err) +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('pixelset file-presence reduction') #endif IF (.not. fexists_any) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' @@ -659,6 +399,9 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF IF (nset > 0) THEN + IF (ndsp + nset > pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset count changed while loading '//trim(psetname)//'.') + ENDIF IF (use_subset) THEN pixelset%eindex(ndsp+1:ndsp+nset) = pack(rbuff, keep_set) pixelset%srcpos(ndsp+1:ndsp+nset) = & @@ -693,6 +436,9 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF IF (nset > 0) THEN + IF (ndsp + nset > pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset count changed while loading '//trim(psetname)//'.') + ENDIF IF (use_subset) THEN pixelset%eindex(ndsp+1:ndsp+nset) = pack(rbuff, keep_set) pixelset%srcpos(ndsp+1:ndsp+nset) = & @@ -711,75 +457,49 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc #endif ENDDO + + IF (ndsp /= pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset count changed between metadata and data reads for '//trim(psetname)//'.') + ENDIF ENDIF ENDIF -#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM) - IF (p_is_active) THEN - IF (pixelset%nset > 0) THEN - allocate (owner_rank (pixelset%nset)) - allocate (msk (pixelset%nset)) - - ie = 1 - je = 1 - iblk = mesh(ie)%xblk - jblk = mesh(ie)%yblk - DO iset = 1, pixelset%nset - DO WHILE (pixelset%eindex(iset) /= mesh(ie)%indx) - ie = ie + 1 - je = je + 1 - IF ((mesh(ie)%xblk /= iblk) .or. (mesh(ie)%yblk /= jblk)) THEN - je = 1 - iblk = mesh(ie)%xblk - jblk = mesh(ie)%yblk - ENDIF - ENDDO - - nave = nelm_blk(iblk,jblk) / (p_np_group-1) - nres = mod(nelm_blk(iblk,jblk), p_np_group-1) - left = (nave+1) * nres - IF (je <= left) THEN - owner_rank(iset) = (je-1) / (nave+1) + 1 - ELSE - owner_rank(iset) = (je-left-1) / nave + 1 + nres - ENDIF - ENDDO - - DO iproc = 1, p_np_group-1 - msk = (owner_rank == iproc) - nsend = count(msk) - CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err) - - IF (nsend > 0) THEN - allocate (sbuff(nsend)) - sbuff = pack(pixelset%eindex, msk) - CALL mpi_send (sbuff, nsend, MPI_INTEGER8, iproc, mpi_tag_data, p_comm_group, p_err) - deallocate (sbuff) - ENDIF - ENDDO - ELSE - DO iproc = 1, p_np_group-1 - nsend = 0 - CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err) - ENDDO + IF (.true. .and. pixelset%nset > 0) THEN + IF (.not. allocated(mesh) .or. numelm < 1 .or. size(mesh) /= numelm) THEN + CALL CoLM_stop('Cannot map '//trim(psetname)//' because the local CoLM element mesh is empty or inconsistent.') + ENDIF + IF (.not. allocated(pixelset%eindex) .or. size(pixelset%eindex) /= pixelset%nset) THEN + CALL CoLM_stop('Invalid element-index vector while loading '//trim(psetname)//'.') ENDIF - ENDIF - - IF (p_is_compute) THEN + allocate (mesh_sorted(numelm)) + allocate (mesh_order (numelm)) + DO ie = 1, numelm + mesh_sorted(ie) = mesh(ie)%indx + mesh_order(ie) = ie + ENDDO + IF (numelm > 1) CALL quicksort(numelm, mesh_sorted, mesh_order) + IF (numelm > 1) THEN + IF (any(mesh_sorted(2:numelm) == mesh_sorted(1:numelm-1))) THEN + CALL CoLM_stop('The local CoLM mesh contains duplicate element IDs while loading '//trim(psetname)//'.') + ENDIF + ENDIF - CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_stat, p_err) + allocate (pixelset%ielm(pixelset%nset)) + DO iset = 1, pixelset%nset + match = find_in_sorted_list1(pixelset%eindex(iset), numelm, mesh_sorted) + IF (match < 1) THEN + write(*,'(A,A,A,I0,A,I0)') 'CoLM ', trim(psetname), ' entry ', iset, & + ' references missing element ', pixelset%eindex(iset) + CALL CoLM_stop('CoLM pixelset and MPAS-owned element mesh are inconsistent.') + ENDIF + pixelset%ielm(iset) = mesh_order(match) + ENDDO - pixelset%nset = nrecv - IF (nrecv > 0) THEN - allocate (pixelset%eindex (nrecv)) - CALL mpi_recv (pixelset%eindex, nrecv, MPI_INTEGER8, & - p_root, mpi_tag_data, p_comm_group, p_stat, p_err) - ENDIF + deallocate (mesh_sorted) + deallocate (mesh_order) ENDIF -#endif - CALL pixelset%set_vecgs @@ -787,27 +507,41 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc CALL ncio_read_vector (filename, 'ipxend', pixelset, pixelset%ipxend) CALL ncio_read_vector (filename, 'settyp', pixelset, pixelset%settyp) - IF (p_is_compute) THEN - IF (pixelset%nset > 0) THEN - - allocate (pixelset%ielm (pixelset%nset)) - ie = 1 - DO iset = 1, pixelset%nset - DO WHILE (pixelset%eindex(iset) /= mesh(ie)%indx) - ie = ie + 1 - ENDDO - pixelset%ielm(iset) = ie - ENDDO + IF (.true. .and. pixelset%nset > 0) THEN + IF (.not. allocated(pixelset%ipxstt) .or. .not. allocated(pixelset%ipxend) .or. & + .not. allocated(pixelset%settyp)) THEN + CALL CoLM_stop('CoLM pixelset identity vectors are incomplete for '//trim(psetname)//'.') + ENDIF + IF (size(pixelset%ipxstt) /= pixelset%nset .or. size(pixelset%ipxend) /= pixelset%nset .or. & + size(pixelset%settyp) /= pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset identity vector lengths are inconsistent for '//trim(psetname)//'.') + ENDIF + DO iset = 1, pixelset%nset + ie = pixelset%ielm(iset) + IF (ie < 1 .or. ie > numelm) THEN + CALL CoLM_stop('CoLM pixelset references an invalid local element for '//trim(psetname)//'.') + ENDIF + IF (pixelset%ipxstt(iset) == -1) THEN + IF (pixelset%ipxend(iset) /= -1) THEN + CALL CoLM_stop('CoLM virtual pixelset has inconsistent pixel bounds for '//trim(psetname)//'.') + ENDIF + ELSEIF (pixelset%ipxstt(iset) < 1 .or. pixelset%ipxend(iset) < pixelset%ipxstt(iset) .or. & + pixelset%ipxend(iset) > mesh(ie)%npxl) THEN + CALL CoLM_stop('CoLM pixelset references pixels outside its element for '//trim(psetname)//'.') + ENDIF + ENDDO + ENDIF - ELSE - write(*,*) 'Warning: 0 ',trim(psetname), ' on rank :', p_iam_glb + IF (.true.) THEN + IF (pixelset%nset == 0) THEN + write(*,*) 'Warning: 0 ',trim(psetname), ' on rank :', mpas_rank ENDIF ENDIF numset = pixelset%nset pixelset%has_shared = .false. - IF (p_is_compute) THEN + IF (.true.) THEN DO iset = 1, pixelset%nset-1 IF ((pixelset%ielm(iset) == pixelset%ielm(iset+1)) & .and. (pixelset%ipxstt(iset) == pixelset%ipxstt(iset+1))) THEN @@ -817,9 +551,10 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDDO ENDIF -#ifdef USEMPI +#ifdef MPAS_MPI CALL mpi_allreduce (MPI_IN_PLACE, pixelset%has_shared, 1, MPI_LOGICAL, & - MPI_LOR, p_comm_glb, p_err) + MPI_LOR, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('shared-pixelset presence reduction') #endif IF (pixelset%has_shared) THEN @@ -827,7 +562,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF #ifdef CoLMDEBUG - IF (p_is_active) write(*,*) numset, trim(psetname), ' on group', p_iam_active + IF (.true.) write(*,*) numset, trim(psetname), ' on group', mpas_rank #endif IF (allocated(subset_sorted)) deallocate(subset_sorted) diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 index 0b1b63cf2d..5ffb9a1288 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 @@ -466,8 +466,7 @@ SUBROUTINE localtime2gmt(idate) ENDIF ENDIF - IF (idate(3) > 86400) THEN - + DO WHILE (idate(3) > 86400) idate(3) = idate(3) - 86400 idate(2) = idate(2) + 1 @@ -481,7 +480,7 @@ SUBROUTINE localtime2gmt(idate) idate(1) = idate(1) + 1 idate(2) = 1 ENDIF - ENDIF + ENDDO END SUBROUTINE localtime2gmt @@ -494,8 +493,7 @@ SUBROUTINE ticktime(deltim, idate) integer maxday idate(3) = idate(3) + nint(deltim) - IF (idate(3) > 86400) THEN - + DO WHILE (idate(3) > 86400) idate(3) = idate(3) - 86400 idate(2) = idate(2) + 1 @@ -509,7 +507,7 @@ SUBROUTINE ticktime(deltim, idate) idate(1) = idate(1) + 1 idate(2) = 1 ENDIF - ENDIF + ENDDO END SUBROUTINE ticktime diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 index 4f22b5b0b5..f7eb11bcc2 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 @@ -14,6 +14,7 @@ MODULE MOD_Utils ! ---- PUBLIC subroutines ---- PUBLIC :: normalize_longitude + PUBLIC :: make_directory INTERFACE expand_list MODULE procedure expand_list_int32 @@ -76,6 +77,40 @@ MODULE MOD_Utils CONTAINS + !--------------------------------- + SUBROUTINE make_directory (path) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + character(len=*), intent(in) :: path + character(len=:), allocatable :: directory, command + integer :: cmdstat, exitstat + logical :: exists + + directory = trim(adjustl(path)) + IF (len(directory) == 0) CALL CoLM_stop('Cannot create an empty directory path.') + IF (verify(directory, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_./+-') /= 0) THEN + CALL CoLM_stop('CoLM directory paths may contain only letters, digits, _, ., /, +, and -.') + ENDIF + + inquire(file=directory, exist=exists) + IF (exists) RETURN + + IF (directory(1:1) == '/') THEN + command = 'mkdir -p ' // directory + ELSE + command = 'mkdir -p ./' // directory + ENDIF + CALL execute_command_line(command, wait=.true., exitstat=exitstat, cmdstat=cmdstat) + IF (cmdstat /= 0 .or. exitstat /= 0) THEN + CALL CoLM_stop('Failed to create CoLM directory: '//directory) + ENDIF + inquire(file=directory, exist=exists) + IF (.not. exists) CALL CoLM_stop('CoLM directory creation did not produce: '//directory) + + END SUBROUTINE make_directory + !--------------------------------- SUBROUTINE normalize_longitude (lon) From b1928d65539efdab97dafcfe762dd5d0aaba039e Mon Sep 17 00:00:00 2001 From: Zhongwang Wei Date: Sun, 12 Jul 2026 23:20:45 +0800 Subject: [PATCH 17/17] Prevent invalid CoLM surface states and startup failures Keep MPAS diagnostics in their declared physical units, make startup validation independent of Fortran short-circuit behavior, and retain MPAS sea-ice thermodynamics for cells outside CoLM land processing. Constraint: MPAS owns ocean/sea-ice physics and MPI lifecycle; CoLM retains native 10-layer land state. Rejected: Disable MPAS sea-ice for sf_colm2024 | Ocean and sea-ice cells would receive no thermodynamic update. Confidence: high Scope-risk: moderate Directive: Keep q2 and qsfc as specific humidity, and route sf_colm2024 ocean cells through MPAS seaice_noah. Tested: CMake Debug build and install; full -fcheck=all build; MPI exchange, river, and repartitioned restart tests. Not-tested: End-to-end forecast with production CoLM landdata and fractional sea ice. --- .../mpas_atmphys_driver_lsm_colm2024.F | 6 ++---- .../physics/mpas_atmphys_driver_seaice.F | 2 +- .../drivers/mpas/MOD_CoLM_MPAS_Interface.F90 | 14 ++++++++++---- .../main/HYDRO/MOD_Grid_RiverLakeFlow.F90 | 5 ++++- .../main/ParaOpt/MOD_Opt_Baseflow.F90 | 19 +++++++++++-------- .../physics_colm2024/share/MOD_Pixelset.F90 | 10 ++++++++-- .../share/MOD_SrfdataRestart.F90 | 10 ++++++++-- 7 files changed, 44 insertions(+), 22 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F index c4d2e85d93..742d6cd16a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -963,11 +963,9 @@ subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,diag_physics t2m(i) = real(t2m_colm, RKIND) u10(i) = real(u10m_colm, RKIND) v10(i) = real(v10m_colm, RKIND) - ! Noah-MP and the MPAS Registry keep qsfc as specific humidity, while q2 uses the WRF mixing-ratio convention. + ! CoLM qref and MPAS q2/qsfc are specific humidity. qsfc(i) = real(qsfc_colm, RKIND) - if(abs(q2m_colm) < colm_state_bad_value .and. q2m_colm >= 0._colm_r8 .and. q2m_colm < 1._colm_r8) then - q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND) - endif + q2(i) = real(q2m_colm, RKIND) sfc_emiss(i) = real(emissivity, RKIND) z0(i) = real(roughness, RKIND) znt(i) = real(roughness, RKIND) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F b/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F index 4bf3c39591..6dcea74995 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F @@ -516,7 +516,7 @@ subroutine driver_seaice(configs,diag_physics,sfc_input,its,ite) ) - case("sf_noahmp") + case("sf_noahmp", "sf_colm2024") call seaice_noah( & dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & qv3d = qv_p , xice = xice_p , snoalb2d = snoalb_p , & diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 index df1d542fc3..a5c6a42a2a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -778,7 +778,8 @@ SUBROUTINE colm_mpas_validate_cell_geometry(mpas_cell_id, mpas_cell_lat, mpas_ce IF (n_mpas_cells < 1) RETURN IF (size(mpas_cell_id) < n_mpas_cells .or. size(mpas_cell_lat) < n_mpas_cells .or. & size(mpas_cell_lon) < n_mpas_cells .or. size(cell_to_element) < n_mpas_cells) RETURN - IF (.not. allocated(mesh) .or. size(mesh) /= numelm) RETURN + IF (.not. allocated(mesh)) RETURN + IF (size(mesh) /= numelm) RETURN IF (.not. allocated(pixel%lat_s) .or. .not. allocated(pixel%lat_n) .or. & .not. allocated(pixel%lon_w) .or. .not. allocated(pixel%lon_e)) RETURN @@ -903,8 +904,11 @@ SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr) EXIT ENDIF total_fraction = total_fraction + fraction - IF (.not. require_active_patch .or. patchmask(patch)) & + IF (.not. require_active_patch) THEN active_fraction = active_fraction + fraction + ELSEIF (patchmask(patch)) THEN + active_fraction = active_fraction + fraction + ENDIF ENDDO ENDIF IF (.not. ieee_is_finite(total_fraction) .or. & @@ -958,7 +962,8 @@ SUBROUTINE colm_mpas_validate_pft_fractions(ierr) IF (.not. allocated(patch_pft_s) .or. .not. allocated(patch_pft_e)) RETURN IF (size(patch_pft_s) /= numpatch .or. size(patch_pft_e) /= numpatch) RETURN IF (numpft > 0) THEN - IF (.not. allocated(pftfrac) .or. size(pftfrac) /= numpft) RETURN + IF (.not. allocated(pftfrac)) RETURN + IF (size(pftfrac) /= numpft) RETURN ENDIF DO patch = 1, numpatch @@ -1413,7 +1418,8 @@ SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_he IF (abs(air_density) < bad_value .and. air_density > 0._r8 .and. & abs(moisture_exchange_velocity) < bad_value .and. & moisture_exchange_velocity > tiny(1._r8)) THEN - IF (.not. allocated(forc_q) .or. patch > size(forc_q)) RETURN + IF (.not. allocated(forc_q)) RETURN + IF (patch > size(forc_q)) RETURN IF (.not. ieee_is_finite(forc_q(patch)) .or. forc_q(patch) < 0._r8 .or. & forc_q(patch) >= 1._r8) RETURN ! The atmospheric boundary sees canopy-air humidity, not ground qg. diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 index 0d12dab18a..6172a6272a 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -55,7 +55,10 @@ SUBROUTINE grid_riverlake_flow_init () CALL CoLM_stop('Embedded CoLM river state dimensions do not match local unit catchments.') ENDIF IF (DEF_Reservoir_Method > 0) THEN - IF (.not. allocated(volresv) .or. size(volresv) /= numresv) THEN + IF (.not. allocated(volresv)) THEN + CALL CoLM_stop('Embedded CoLM river state is missing local reservoir storage.') + ENDIF + IF (size(volresv) /= numresv) THEN CALL CoLM_stop('Embedded CoLM reservoir state dimensions do not match local reservoirs.') ENDIF ENDIF diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 index 4d11fdb97d..033e21602c 100644 --- a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 @@ -34,14 +34,17 @@ SUBROUTINE Opt_Baseflow_init () file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' CALL ncio_read_vector (file_restart, 'scale_baseflow', landpatch, scale_baseflow, defval = 1.) - IF (numpatch > 0) THEN - IF (.not. allocated(scale_baseflow) .or. size(scale_baseflow) /= numpatch) THEN - CALL CoLM_stop('Embedded CoLM baseflow scale does not match the local patch decomposition.') - ENDIF - IF (.not. all(ieee_is_finite(scale_baseflow)) .or. any(scale_baseflow <= 0._r8)) THEN - CALL CoLM_stop('Embedded CoLM baseflow scale must contain finite positive values.') - ENDIF - ENDIF + IF (numpatch > 0) THEN + IF (.not. allocated(scale_baseflow)) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale is not allocated.') + ENDIF + IF (size(scale_baseflow) /= numpatch) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale does not match the local patch decomposition.') + ENDIF + IF (.not. all(ieee_is_finite(scale_baseflow)) .or. any(scale_baseflow <= 0._r8)) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale must contain finite positive values.') + ENDIF + ENDIF IF (mpas_is_root) CALL make_directory(trim(DEF_dir_restart)//'/ParaOpt') #ifdef MPAS_MPI diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 index 6eec2bbed6..d8a52b15a9 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -348,10 +348,16 @@ SUBROUTINE vec_gather_scatter_set (this) IF (.true.) THEN IF (this%nset > 0) THEN - IF (.not. allocated(this%eindex) .or. size(this%eindex) /= this%nset) THEN + IF (.not. allocated(this%eindex)) THEN CALL CoLM_stop('Invalid pixelset element-index vector in set_vecgs.') ENDIF - IF (.not. allocated(this%ielm) .or. size(this%ielm) /= this%nset) THEN + IF (size(this%eindex) /= this%nset) THEN + CALL CoLM_stop('Invalid pixelset element-index vector in set_vecgs.') + ENDIF + IF (.not. allocated(this%ielm)) THEN + CALL CoLM_stop('Pixelset element mapping must be established before set_vecgs.') + ENDIF + IF (size(this%ielm) /= this%nset) THEN CALL CoLM_stop('Pixelset element mapping must be established before set_vecgs.') ENDIF IF (.not. allocated(mesh)) THEN diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 index 06fa3b5f95..632e4afb78 100644 --- a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -466,10 +466,16 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc IF (.true. .and. pixelset%nset > 0) THEN - IF (.not. allocated(mesh) .or. numelm < 1 .or. size(mesh) /= numelm) THEN + IF (.not. allocated(mesh)) THEN CALL CoLM_stop('Cannot map '//trim(psetname)//' because the local CoLM element mesh is empty or inconsistent.') ENDIF - IF (.not. allocated(pixelset%eindex) .or. size(pixelset%eindex) /= pixelset%nset) THEN + IF (numelm < 1 .or. size(mesh) /= numelm) THEN + CALL CoLM_stop('Cannot map '//trim(psetname)//' because the local CoLM element mesh is empty or inconsistent.') + ENDIF + IF (.not. allocated(pixelset%eindex)) THEN + CALL CoLM_stop('Invalid element-index vector while loading '//trim(psetname)//'.') + ENDIF + IF (size(pixelset%eindex) /= pixelset%nset) THEN CALL CoLM_stop('Invalid element-index vector while loading '//trim(psetname)//'.') ENDIF